From: Tim Vaughan <tgvaughan@gmail.com>
Date: Thu, 21 Jul 2016 10:05:12 +0000 (+1200)
Subject: Primitive fixnum relations working.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=0bef27a3e92222d3024396ee4f37b243d4f8ef18;p=scheme.forth.jl.git

Primitive fixnum relations working.
---

diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index 03d885b..9afc2c2 100644
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -212,9 +212,12 @@
     mod fixnum-type
 ; make-primitive remainder
 
-:noname ( args -- bool )
+variable relcfa
+
+: test-relation ( args -- bool )
 
     2dup nil objeq? if
+        2drop
         true boolean-type exit
     then
 
@@ -234,8 +237,8 @@
         2dup nil objeq? false =
     while
         2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
-        2rot 2dup 2rot ( args' arg0 arg0 arg1 )
-        objeq? false = if
+        2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
+        relcfa @ execute false = if
             2drop 2drop
             false boolean-type exit
         then
@@ -245,8 +248,37 @@
 
     2drop 2drop
     true boolean-type
+; 
+
+: fixnum-lt ( obj1 obj2 -- bool )
+    drop swap drop <
+;
+
+:noname
+    ['] fixnum-lt relcfa !
+    test-relation
+; make-primitive <
+
+: fixnum-gt ( obj1 obj2 -- bool )
+    drop swap drop >
+;
+
+:noname
+    ['] fixnum-gt relcfa !
+    test-relation
+; make-primitive >
+
+: fixnum-eq ( obj1 obj2 -- bool )
+    drop swap drop =
+;
+
+:noname
+    ['] fixnum-eq relcfa !
+    test-relation
 ; make-primitive =
 
+hide relcfa
+
 ( = Pairs and Lists = )
 
 :noname ( args -- pair )