From: Tim Vaughan 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 )