X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme-primitives.4th;h=b347d8add9b005cb67e2d92d10bc43412daa0b81;hb=21606409845e717c4760793e95326c25e4e95029;hp=03d885bebd3cce1f9b02e4be224c4e020fbb9869;hpb=9ad6e6f21fbbefe9e38bc6b4b8d2a78f8cbca229;p=scheme.forth.jl.git

diff --git a/scheme-primitives.4th b/scheme-primitives.4th
index 03d885b..b347d8a 100644
--- a/scheme-primitives.4th
+++ b/scheme-primitives.4th
@@ -45,7 +45,7 @@
 :noname ( args -- boolobj )
     2dup 1 ensure-arg-count
 
-    car primitive-type istype? -rot 2drop boolean-type
+    car primitive-proc-type istype? -rot 2drop boolean-type
 ; make-primitive procedure?
 
 ( = Type conversions = )
@@ -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 )