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

diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index edf5894..8dad18e 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -1,52 +1,46 @@
-\ ==== Type predicates ==== {{{
+\ ==== Type predilcates ==== {{{
 
 :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?
+    flonum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive flonum?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car string-type istype? -rot 2drop boolean-type
-; make-primitive string?
+    character-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive char?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
-
-    car pair-type istype? -rot 2drop boolean-type
-; make-primitive pair?
+    string-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive string?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
+    pair-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive pair?
 
-    car primitive-proc-type istype? -rot 2drop boolean-type
-; make-primitive procedure?
+:noname ( args -- boolobj )
+    primitive-proc-type istype? if
+        true
+    else
+        compound-proc-type istype?
+    then
+        
+    -rot 2drop boolean-type
+; 1 make-fa-primitive procedure?
 
 \ }}}
 
@@ -157,224 +151,273 @@
 
 \ }}}
 
-\ ==== 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
+\ --- Fixnums ---
+
+:noname ( fixnum fixnum -- boolobj )
+    objeq? boolean-type
+; 2 make-fa-primitive fix:=
+
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop < boolean-type
+; 2 make-fa-primitive fix:<
+
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop > boolean-type
+; 2 make-fa-primitive fix:>
+
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop <= boolean-type
+; 2 make-fa-primitive fix:<=
+
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop >= boolean-type
+; 2 make-fa-primitive fix:>=
+
+:noname ( fixnum -- boolobj )
+    drop 0= boolean-type
+; 1 make-fa-primitive fix:zero?
+
+:noname ( fixnum -- boolobj )
+    drop 0> boolean-type
+; 1 make-fa-primitive fix:positive?
+
+:noname ( fixnum -- boolobj )
+    drop 0< boolean-type
+; 1 make-fa-primitive fix:negative?
+
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop + fixnum-type
+; 2 make-fa-primitive fix:+
+
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop - fixnum-type
+; 2 make-fa-primitive fix:-
+
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop * fixnum-type
+; 2 make-fa-primitive fix:*
+
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop / fixnum-type
+; 2 make-fa-primitive fix:quotient
+
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop mod fixnum-type
+; 2 make-fa-primitive fix:remainder
+
+:noname ( fixnum -- fixnum+1 )
+    swap 1+ swap
+; 1 make-fa-primitive fix:1+
+
+:noname ( fixnum -- fixnum-1 )
+    swap 1- swap
+; 1 make-fa-primitive fix:-1+
+
+:noname ( fixnum -- -fixnum )
+    swap negate swap
+; 1 make-fa-primitive fix:neg
+
+( Find the GCD of n1 and n2 where n2 < n1. )
+: gcd ( n1 n2 -- m )
+    
 ;
-' add-prim make-primitive +
 
-: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 -
+\ --- Flonums ---
 
-: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 ( flonum flonum -- bool )
+    objeq? boolean-type
+; 2 make-fa-primitive flo:=
 
-:noname ( args -- fixnum )
-    2dup 2 ensure-arg-count
+:noname ( flonum flonum -- bool )
+    drop swap drop f< boolean-type
+; 2 make-fa-primitive flo:<
 
-    2dup car fixnum-type ensure-arg-type
-    2swap cdr car fixnum-type ensure-arg-type
+:noname ( flonum flonum -- bool )
+    drop swap drop f> boolean-type
+; 2 make-fa-primitive flo:>
 
-    drop swap drop
 
-    / fixnum-type
-; make-primitive quotient
+:noname ( flonum -- bool )
+    drop 0.0 = boolean-type
+; 1 make-fa-primitive flo:zero?
 
-:noname ( args -- fixnum )
-    2dup 2 ensure-arg-count
+:noname ( flonum -- bool )
+    drop 0.0 f> boolean-type
+; 1 make-fa-primitive flo:positive?
 
-    2dup car fixnum-type ensure-arg-type
-    2swap cdr car fixnum-type ensure-arg-type
+:noname ( flonum -- bool )
+    drop 0.0 f< boolean-type
+; 1 make-fa-primitive flo:negative?
 
-    drop swap drop
 
-    mod fixnum-type
-; make-primitive remainder
+:noname ( flonum1 flonum2 -- flonum1+flonum2 )
+    drop swap drop f+ flonum-type
+; 2 make-fa-primitive flo:+
 
-variable relcfa
+:noname ( flonum1 flonum2 -- flonum1-flonum2 )
+    drop swap drop f- flonum-type
+; 2 make-fa-primitive flo:-
 
-: test-relation ( args -- bool )
+:noname ( flonum1 flonum2 -- flonum1*flonum2 )
+    drop swap drop f* flonum-type
+; 2 make-fa-primitive flo:*
 
-    2dup nil objeq? if
-        2drop
-        true boolean-type exit
-    then
+:noname ( flonum1 flonum2 -- flonum1/flonum2 )
+    drop swap drop f/ flonum-type
+; 2 make-fa-primitive flo:/
 
-    ( args )
+:noname ( flonum1 flonum2 -- flonum1/flonum2 )
+    drop swap drop f/ flonum-type
+; 2 make-fa-primitive flo:/
 
-    2dup car fixnum-type ensure-arg-type ( args arg0 )
-    2swap cdr ( arg0 args' )
 
-    2dup nil objeq? if
-        2drop 2drop
-        true boolean-type exit
-    then
+:noname ( flonum -- bool )
+    drop dup
+    fnan? swap finf? or invert
+; 1 make-fa-primitive flo:finite?
 
-    ( arg0 args' )
 
-    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 ( flonum -- flonum )
+    swap fabs swap
+; 1 make-fa-primitive flo:abs
 
-        2swap cdr ( arg0 args'' )
-    repeat
+:noname ( flonum -- flonum )
+    swap fexp swap
+; 1 make-fa-primitive flo:exp
 
-    2drop 2drop
-    true boolean-type
-; 
+:noname ( flonum -- flonum )
+    swap flog swap
+; 1 make-fa-primitive flo:log
 
-: fixnum-lt ( obj1 obj2 -- bool )
-    drop swap drop <
-;
+:noname ( flonum -- flonum )
+    swap fsin swap
+; 1 make-fa-primitive flo:sin
 
-:noname
-    ['] fixnum-lt relcfa !
-    test-relation
-; make-primitive <
+:noname ( flonum -- flonum )
+    swap fcos swap
+; 1 make-fa-primitive flo:cos
 
-: fixnum-gt ( obj1 obj2 -- bool )
-    drop swap drop >
-;
+:noname ( flonum -- flonum )
+    swap ftan swap
+; 1 make-fa-primitive flo:tan
 
-:noname
-    ['] fixnum-gt relcfa !
-    test-relation
-; make-primitive >
+:noname ( flonum -- flonum )
+    swap fasin swap
+; 1 make-fa-primitive flo:asin
 
-: fixnum-eq ( obj1 obj2 -- bool )
-    drop swap drop =
-;
+:noname ( flonum -- flonum )
+    swap facos swap
+; 1 make-fa-primitive flo:acos
 
-:noname
-    ['] fixnum-eq relcfa !
-    test-relation
-; make-primitive =
+:noname ( flonum -- flonum )
+    swap fatan swap
+; 1 make-fa-primitive flo:atan
 
-hide relcfa
+:noname ( flonum -- flonum )
+    swap fsqrt swap
+; 1 make-fa-primitive flo:sqrt
 
-\ }}}
+:noname ( flonum flonum -- flonum )
+    drop swap drop f^ flonum-type
+; 2 make-fa-primitive flo:expt
 
-\ ==== Pairs and Lists ==== {{{
+:noname ( flonum -- flonum )
+    swap floor swap
+; 1 make-fa-primitive flo:floor
 
-:noname ( args -- pair )
-    2dup 2 ensure-arg-count
+:noname ( flonum -- flonum )
+    swap ceiling swap
+; 1 make-fa-primitive flo:ceiling
 
-    2dup car 2swap cdr car
-    cons
-; make-primitive cons
+:noname ( flonum -- flonum )
+    swap truncate swap
+; 1 make-fa-primitive flo:truncate
 
-:noname ( args -- list )
-    \ args is already a list!
-; make-primitive list
+:noname ( flonum -- flonum )
+    swap fround swap
+; 1 make-fa-primitive flo:round
 
-:noname ( args -- obj )
-    2dup 1 ensure-arg-count
-    car pair-type ensure-arg-type
+:noname ( flonum -- flonum )
+    drop floor f->i fixnum-type
+; 1 make-fa-primitive flo:floor->exact
+
+:noname ( flonum -- flonum )
+    drop ceiling f->i fixnum-type
+; 1 make-fa-primitive flo:ceiling->exact
+
+:noname ( flonum -- flonum )
+    drop truncate f->i fixnum-type
+; 1 make-fa-primitive flo:truncate->exact
 
+:noname ( flonum -- flonum )
+    drop f->i fixnum-type
+; 1 make-fa-primitive flo:round->exact
+
+:noname ( flonum flonum -- flonum )
+    drop swap drop f/ fatan flonum-type
+; 2 make-fa-primitive flo:atan2
+
+\ }}}
+
+\ ==== Pairs and Lists ==== {{{
+
+:noname ( arg1 arg2 -- pair )
+    cons
+; 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 +452,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 +501,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
 
 \ }}}