From 0bef27a3e92222d3024396ee4f37b243d4f8ef18 Mon Sep 17 00:00:00 2001
From: Tim Vaughan <tgvaughan@gmail.com>
Date: Thu, 21 Jul 2016 22:05:12 +1200
Subject: [PATCH] Primitive fixnum relations working.

---
 scheme-primitives.4th | 38 +++++++++++++++++++++++++++++++++++---
 1 file changed, 35 insertions(+), 3 deletions(-)

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 )
-- 
2.20.1