X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme-primitives.4th;h=934c80ed12946ddcee3b9636d0017fff22cc0b5b;hb=f675338306652fc8accf3c5ba154b915d0d24cdc;hp=edf5894ab5e87962b15abc78991e5d260f775058;hpb=a39894e12a9e84a17411e3bdd5d49fae3369e0d4;p=scheme.forth.jl.git

diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index edf5894..934c80e 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -1,52 +1,42 @@
 \ ==== Type predicates ==== {{{
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car nil objeq? boolean-type
-; make-primitive null?
+    nil objeq? boolean-type
+; 1 make-fa-primitive null?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car boolean-type istype? -rot 2drop boolean-type
-; make-primitive boolean?
+    boolean-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive boolean?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car symbol-type istype? -rot 2drop boolean-type
-; make-primitive symbol?
+    symbol-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive symbol?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car fixnum-type istype? -rot 2drop boolean-type
-; make-primitive integer?
+    fixnum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive fixnum?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car character-type istype? -rot 2drop boolean-type
-; make-primitive char?
+    character-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive char?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car string-type istype? -rot 2drop boolean-type
-; make-primitive string?
+    string-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive string?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car pair-type istype? -rot 2drop boolean-type
-; make-primitive pair?
+    pair-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive pair?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car primitive-proc-type istype? -rot 2drop boolean-type
-; make-primitive procedure?
+    primitive-proc-type istype? if
+        true
+    else
+        compound-proc-type istype?
+    then
+        
+    -rot 2drop boolean-type
+; 1 make-fa-primitive procedure?
 
 \ }}}
 
@@ -157,224 +147,138 @@
 
 \ }}}
 
-\ ==== Arithmetic ==== {{{
+\ ==== Primitivle Arithmetic ==== {{{
 
-: add-prim ( args -- fixnum )
-    2dup nil objeq? if
-        2drop
-        0 fixnum-type
-    else
-        2dup car drop
-        -rot cdr recurse drop
-        + fixnum-type
-    then
-;
-' add-prim make-primitive +
+\ --- Fixnums ---
 
-:noname ( args -- fixnum )
-    2dup nil objeq? if
-        2drop
-        0 fixnum-type
-    else
-        2dup car drop
-        -rot cdr
-        2dup nil objeq? if
-            2drop negate
-        else
-            add-prim drop
-            -
-        then
-        fixnum-type
-    then
-; make-primitive -
-
-:noname ( args -- fixnum )
-    2dup nil objeq? if
-        2drop
-        1 fixnum-type
-    else
-        2dup car drop
-        -rot cdr recurse drop
-        * fixnum-type
-    then
-; make-primitive *
-
-:noname ( args -- fixnum )
-    2dup 2 ensure-arg-count
-
-    2dup car fixnum-type ensure-arg-type
-    2swap cdr car fixnum-type ensure-arg-type
-
-    drop swap drop
+:noname ( fixnum fixnum -- boolobj )
+    objeq? boolean-type
+; 2 make-fa-primitive fix:=
 
-    / fixnum-type
-; make-primitive quotient
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop < boolean-type
+; 2 make-fa-primitive fix:<
 
-:noname ( args -- fixnum )
-    2dup 2 ensure-arg-count
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop > boolean-type
+; 2 make-fa-primitive fix:>
 
-    2dup car fixnum-type ensure-arg-type
-    2swap cdr car fixnum-type ensure-arg-type
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop <= boolean-type
+; 2 make-fa-primitive fix:<=
 
-    drop swap drop
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop >= boolean-type
+; 2 make-fa-primitive fix:>=
 
-    mod fixnum-type
-; make-primitive remainder
+:noname ( fixnum fixnum -- boolobj )
+    drop 0= boolean-type
+; 1 make-fa-primitive fix:zero?
 
-variable relcfa
+:noname ( fixnum fixnum -- boolobj )
+    drop 0> boolean-type
+; 1 make-fa-primitive fix:positive?
 
-: test-relation ( args -- bool )
+:noname ( fixnum fixnum -- boolobj )
+    drop 0< boolean-type
+; 1 make-fa-primitive fix:negative?
 
-    2dup nil objeq? if
-        2drop
-        true boolean-type exit
-    then
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop + fixnum-type
+; 2 make-fa-primitive fix:+
 
-    ( args )
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop - fixnum-type
+; 2 make-fa-primitive fix:-
 
-    2dup car fixnum-type ensure-arg-type ( args arg0 )
-    2swap cdr ( arg0 args' )
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop * fixnum-type
+; 2 make-fa-primitive fix:*
 
-    2dup nil objeq? if
-        2drop 2drop
-        true boolean-type exit
-    then
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop / fixnum-type
+; 2 make-fa-primitive fix:quotient
 
-    ( arg0 args' )
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop mod fixnum-type
+; 2 make-fa-primitive fix:remainder
 
-    begin
-        2dup nil objeq? false =
-    while
-        2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
-        2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
-        relcfa @ execute false = if
-            2drop 2drop
-            false boolean-type exit
-        then
+:noname ( fixnum -- fixnum+1 )
+    swap 1+ swap
+; 1 make-fa-primitive fix:1+
 
-        2swap cdr ( arg0 args'' )
-    repeat
+:noname ( fixnum -- fixnum-1 )
+    swap 1- swap
+; 1 make-fa-primitive fix:-1+
 
-    2drop 2drop
-    true boolean-type
-; 
+:noname ( fixnum -- -fixnum )
+    swap negate swap
+; 1 make-fa-primitive fix:neg
 
-: 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 =
+( Find the GCD of n1 and n2 where n2 < n1. )
+: gcd ( n1 n2 -- m )
+    
 ;
 
-:noname
-    ['] fixnum-eq relcfa !
-    test-relation
-; make-primitive =
-
-hide relcfa
-
 \ }}}
 
 \ ==== Pairs and Lists ==== {{{
 
-:noname ( args -- pair )
-    2dup 2 ensure-arg-count
-
-    2dup car 2swap cdr car
+:noname ( arg1 arg2 -- pair )
     cons
-; make-primitive cons
-
-:noname ( args -- list )
-    \ args is already a list!
-; make-primitive list
-
-:noname ( args -- obj )
-    2dup 1 ensure-arg-count
-    car pair-type ensure-arg-type
+; 2 make-fa-primitive cons
 
+:noname ( pair-obj -- obj )
     car
-; make-primitive car
+; pair-type 1 make-fa-type-primitive car
 
 :noname ( args -- obj )
-    2dup 1 ensure-arg-count
-    car pair-type ensure-arg-type
-
     cdr
-; make-primitive cdr
+; pair-type 1 make-fa-type-primitive cdr
 
-:noname ( args -- ok )
-    2dup 2 ensure-arg-count
-    2dup cdr car
-    2swap car pair-type ensure-arg-type
+:noname ( pair obj  -- ok )
+    2swap pair-type ensure-arg-type
 
     set-car!
 
     ok-symbol
-; make-primitive set-car!
+; 2 make-fa-primitive set-car!
 
-:noname ( args -- ok )
-    2dup 2 ensure-arg-count
-    2dup cdr car
-    2swap car pair-type ensure-arg-type
+:noname ( pair obj -- ok )
+    2swap pair-type ensure-arg-type
 
     set-cdr!
 
     ok-symbol
-; make-primitive set-cdr!
+; 2 make-fa-primitive set-cdr!
 
 \ }}}
 
 \ ==== Polymorphic equality testing ==== {{{
 
-:noname ( args -- bool )
-    2dup 2 ensure-arg-count
-    2dup cdr car
-    2swap car
-
+:noname ( arg1 arg2 -- bool )
     objeq? boolean-type
-; make-primitive eq?
+; 2 make-fa-primitive eq?
 
 \ }}}
 
 \ ==== Input/Output ==== {{{
 
 :noname ( args -- finalResult )
-    2dup 1 ensure-arg-count
-    car string-type ensure-arg-type
-
     drop pair-type
     pad charlist>cstr
     pad swap load
-; make-primitive load
+; string-type 1 make-fa-type-primitive load
 
 :noname ( args -- obj )
-    0 ensure-arg-count
     read
-; make-primitive read
+; 0 make-fa-primitive read
 
 defer display
-:noname ( args -- none )
-    2dup 1 ensure-arg-count
 
-    car print
-
-    none
-; make-primitive write
+:noname ( obj -- none )
+    print none
+; 1 make-fa-primitive write
 
 : displaypair ( pairobj -- )
     2dup
@@ -409,40 +313,21 @@ defer display
     print
 ; is display
 
-:noname ( args -- none )
-    2dup 1 ensure-arg-count
-    car string-type ensure-arg-type
+:noname ( stringobj -- none )
+    displaystring none
+; string-type 1 make-fa-type-primitive display-string
 
-    displaystring
+:noname ( charobj -- none )
+    displaychar none
+; character-type 1 make-fa-type-primitive display-character
 
-    none
-; make-primitive display-string
+:noname ( obj -- none )
+    display none
+; 1 make-fa-primitive display
 
 :noname ( args -- none )
-    2dup 1 ensure-arg-count
-    car character-type ensure-arg-type
-
-    displaychar
-
-    none
-; make-primitive display-character
-
-:noname ( args -- none )
-    2dup 1 ensure-arg-count
-    car
-
-    display
-
-    none
-; make-primitive display
-
-:noname ( args -- none )
-    0 ensure-arg-count
-
-    cr
-
-    none
-; make-primitive newline
+    cr none
+; 0 make-fa-primitive newline
 
 \ }}}
 
@@ -477,18 +362,14 @@ defer display
 
 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 :noname ( args -- result )
-    0 ensure-arg-count
-
     [char] _  character-type nil cons
     drop symbol-type
-; make-primitive gensym
+; 0 make-fa-primitive gensym
 
 ( Generate the NONE object indicating an unspecified return value. )
 :noname ( args -- result )
-    0 ensure-arg-count
-    
     none
-; make-primitive none
+; 0 make-fa-primitive none
 
 \ }}}