[Implemented term comparisons; compare_terms/3 predicate.
Gergö Barany <gergo@complang.tuwien.ac.at>**20090125171552] {
hunk ./wam.fs 2
-42 constant atom-tag
-4242 constant integer-tag
-424242 constant reference-tag
-42424242 constant unbound-tag
-4242424242 constant functor-tag
-424242424242 constant nil-tag
+\ 2009-01-24: Rearranged to make ordering easier.
+42 constant reference-tag
+4242 constant unbound-tag
+424242 constant integer-tag
+42424242 constant atom-tag
+4242424242 constant nil-tag
+424242424242 constant functor-tag
hunk ./wam.fs 1235
+\ compare_terms +Term1, +Term2): Compare the two terms, bind Order to
+\ one of the atoms 'less', 'greater', or 'equal'.
+\ Comparison is almost according to the standard order of terms. Our order
+\ is:
+\   (unbound) variable < number < atom < nil < compound < cons
+\ where
+\ - variables are ordered by address
+\ - numbers are ordered by value
+\ - atoms are ordered alphabetically
+\ - compounds are ordered by:
+\   - functor arity
+\   - functor name (alphabetically)
+\   - arguments, left-to-right
+s" less" create-atom constant less-atom
+s" greater" create-atom constant greater-atom
+s" equal" create-atom constant equal-atom
+
+defer compare-unbound
+defer compare-integer
+defer compare-atom
+defer compare-nil
+defer compare-functor
+defer compare-list
+: compare-terms ( term1 term2 -- cmp-result )
+    dereference swap dereference swap
+    { t1 t2 }
+    t1 tag t2 tag < if
+       -1
+    else t1 tag t2 tag > if
+        1
+    else
+        t1 t2
+        t1 tag case
+            unbound-tag of compare-unbound endof
+            integer-tag of compare-integer endof
+            atom-tag    of compare-atom    endof
+            nil-tag     of compare-nil     endof
+            functor-tag of compare-functor endof
+            list-tag    of compare-list    endof
+        endcase
+    endif endif
+    ;
+
+: number-compare ( n1 n2 -- cmp-result )
+    2dup < if -1 else
+    2dup > if  1 else
+               0
+    endif endif
+    ( n1 n2 result )
+    nip nip
+    ;
+
+:noname ( unbound1 unbound2 -- cmp-result )
+    number-compare
+    ; is compare-unbound
+
+:noname ( integer1 integer2 -- cmp-result )
+    integer-value swap integer-value swap
+    number-compare
+    ; is compare-integer
+
+:noname ( atom1 atom2 -- cmp-result )
+    atom-name rot atom-name 2swap
+    compare \ yippie, this word is predefined
+    ; is compare-atom
+
+:noname ( nil1 nil2 -- cmp-result )
+  \ nil is always equal to nil
+    drop drop 0
+    ; is compare-nil
+
+: compare-args ( args1 args2 n -- cmp-result )
+    0 \ so far, the arg lists are equal; top-of-stack will keep track of
+      \ this status
+    begin
+        ( args1 args2 counter cmp-result )
+        over 0 > over 0 = and while
+            ( args1 args2 counter cmp-result )
+            drop \ result is 0, we don't need to hang on to it
+            1- { next-counter }
+            ( args1 args2 )
+            over @ over @ compare-terms { result }
+          \ setup stack for next iteration
+            cell+ swap cell+ swap
+            next-counter
+            result
+    repeat
+    ( args1 args2 0 result )
+    { final-result }
+    drop drop drop
+    final-result
+    ;
+
+:noname ( compound1 compound2 -- cmp-result )
+    2dup functor-arity swap functor-arity swap ( c1 c2 a1 a2 )
+    number-compare dup 0 = if
+        ( c1 c2 0 ) drop
+        functor-name rot functor-name 2swap
+        compare dup 0 = if
+            ( c1 c2 0 ) drop
+            dup functor-arity
+            ( c1 c2 n )
+            rot functor-args
+            rot functor-args
+            rot
+            ( args1 args2 n )
+            >r 2dup r> compare-args 
+        endif
+    endif
+    ( c1 c2 cmp-result )
+    nip nip
+    ; is compare-functor
+
+: compare_terms ( -- )
+    wam-instr-prologue
+    a2 @ a3 @ compare-terms
+    case
+        -1 of less-atom    endof
+         0 of equal-atom   endof
+         1 of greater-atom endof
+    endcase a1 get_constant
+    wam-instr-epilogue
+    ;
+
}