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

diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index edf5894..c3eeb5d 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -1,52 +1,54 @@
-\ ==== 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
+    ratnum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive ratnum?
 
-    car string-type istype? -rot 2drop boolean-type
-; make-primitive string?
+:noname ( args -- boolobj )
+    character-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive char?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
+    string-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive string?
 
-    car pair-type istype? -rot 2drop boolean-type
-; make-primitive pair?
+:noname ( args -- boolobj )
+    pair-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive pair?
 
 :noname ( args -- boolobj )
-    2dup 1 ensure-arg-count
+    primitive-proc-type istype? if
+        true
+    else
+        compound-proc-type istype?
+    then
+        
+    -rot 2drop boolean-type
+; 1 make-fa-primitive procedure?
 
-    car primitive-proc-type istype? -rot 2drop boolean-type
-; make-primitive procedure?
+:noname ( args -- boolobj )
+    port-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive port?
 
 \ }}}
 
@@ -155,226 +157,394 @@
     charlist>symbol
 ; make-primitive string->symbol
 
-\ }}}
-
-\ ==== Arithmetic ==== {{{
+:noname ( charlist -- string )
+    2dup 1 ensure-arg-count
 
-: add-prim ( args -- fixnum )
-    2dup nil objeq? if
+    car nil? if
         2drop
-        0 fixnum-type
-    else
-        2dup car drop
-        -rot cdr recurse drop
-        + fixnum-type
+        nil nil cons
+        drop string-type
+        exit
     then
-;
-' add-prim make-primitive +
+    
+    pair-type ensure-arg-type
 
-: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 -
+    duplicate-charlist
+    drop string-type
+; make-primitive list->string
 
-:noname ( args -- fixnum )
-    2dup nil objeq? if
-        2drop
-        1 fixnum-type
+:noname ( string -- charlist )
+    2dup 1 ensure-arg-count
+    car string-type ensure-arg-type
+
+    drop pair-type
+
+    2dup car nil? if
+        2swap 2drop
     else
-        2dup car drop
-        -rot cdr recurse drop
-        * fixnum-type
+        2drop
+        duplicate-charlist
     then
-; make-primitive *
 
-:noname ( args -- fixnum )
-    2dup 2 ensure-arg-count
+; make-primitive string->list
 
-    2dup car fixnum-type ensure-arg-type
-    2swap cdr car fixnum-type ensure-arg-type
+\ }}}
 
-    drop swap drop
+\ ==== Numeric types ==== {{{
 
-    / fixnum-type
-; make-primitive quotient
+\ --- Fixnums ---
 
-:noname ( args -- fixnum )
-    2dup 2 ensure-arg-count
+:noname ( fixnum fixnum -- boolobj )
+    objeq? 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 swap drop <= boolean-type
+; 2 make-fa-primitive fix:<=
 
-variable relcfa
+:noname ( fixnum fixnum -- boolobj )
+    drop swap drop >= boolean-type
+; 2 make-fa-primitive fix:>=
 
-: test-relation ( args -- bool )
+:noname ( fixnum -- boolobj )
+    drop 0= boolean-type
+; 1 make-fa-primitive fix:zero?
 
-    2dup nil objeq? if
-        2drop
-        true boolean-type exit
-    then
+:noname ( fixnum -- boolobj )
+    drop 0> boolean-type
+; 1 make-fa-primitive fix:positive?
 
-    ( args )
+:noname ( fixnum -- boolobj )
+    drop 0< boolean-type
+; 1 make-fa-primitive fix:negative?
 
-    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:-
 
-    ( arg0 args' )
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop * fixnum-type
+; 2 make-fa-primitive fix:*
 
-    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 -- fixnum' )
+    drop swap drop / fixnum-type
+; 2 make-fa-primitive fix:quotient
 
-        2swap cdr ( arg0 args'' )
-    repeat
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop mod fixnum-type
+; 2 make-fa-primitive fix:remainder
 
-    2drop 2drop
-    true boolean-type
-; 
+:noname ( fixnum -- fixnum+1 )
+    swap 1+ swap
+; 1 make-fa-primitive fix:1+
 
-: fixnum-lt ( obj1 obj2 -- bool )
-    drop swap drop <
-;
+:noname ( fixnum -- fixnum-1 )
+    swap 1- swap
+; 1 make-fa-primitive fix:-1+
 
-:noname
-    ['] fixnum-lt relcfa !
-    test-relation
-; make-primitive <
+:noname ( fixnum -- -fixnum )
+    swap negate swap
+; 1 make-fa-primitive fix:neg
 
-: fixnum-gt ( obj1 obj2 -- bool )
-    drop swap drop >
-;
+:noname ( fixnum -- -fixnum )
+    swap abs swap
+; 1 make-fa-primitive fix:abs
 
-:noname
-    ['] fixnum-gt relcfa !
-    test-relation
-; make-primitive >
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop gcd fixnum-type
+; 2 make-fa-primitive fix:gcd
 
-: fixnum-eq ( obj1 obj2 -- bool )
-    drop swap drop =
-;
+\ --- Flonums ---
 
-:noname
-    ['] fixnum-eq relcfa !
-    test-relation
-; make-primitive =
+:noname ( flonum flonum -- bool )
+    objeq? boolean-type
+; 2 make-fa-primitive flo:=
 
-hide relcfa
+:noname ( flonum flonum -- bool )
+    drop swap drop f< boolean-type
+; 2 make-fa-primitive flo:<
 
-\ }}}
+:noname ( flonum flonum -- bool )
+    drop swap drop f> boolean-type
+; 2 make-fa-primitive flo:>
 
-\ ==== Pairs and Lists ==== {{{
+:noname ( flonum flonum -- bool )
+    drop swap drop f<= boolean-type
+; 2 make-fa-primitive flo:<=
 
-:noname ( args -- pair )
-    2dup 2 ensure-arg-count
+:noname ( flonum flonum -- bool )
+    drop swap drop f>= boolean-type
+; 2 make-fa-primitive flo:>=
 
-    2dup car 2swap cdr car
-    cons
-; make-primitive cons
+:noname ( flonum -- bool )
+    drop 0.0 = boolean-type
+; 1 make-fa-primitive flo:zero?
 
-:noname ( args -- list )
-    \ args is already a list!
-; make-primitive list
+:noname ( flonum -- bool )
+    drop 0.0 f> boolean-type
+; 1 make-fa-primitive flo:positive?
 
-:noname ( args -- obj )
-    2dup 1 ensure-arg-count
-    car pair-type ensure-arg-type
+:noname ( flonum -- bool )
+    drop 0.0 f< boolean-type
+; 1 make-fa-primitive flo:negative?
+
+
+:noname ( flonum1 flonum2 -- flonum1+flonum2 )
+    drop swap drop f+ flonum-type
+; 2 make-fa-primitive flo:+
+
+:noname ( flonum1 flonum2 -- flonum1-flonum2 )
+    drop swap drop f- flonum-type
+; 2 make-fa-primitive flo:-
+
+:noname ( flonum1 flonum2 -- flonum1*flonum2 )
+    drop swap drop f* flonum-type
+; 2 make-fa-primitive flo:*
+
+:noname ( flonum1 flonum2 -- flonum1/flonum2 )
+    drop swap drop f/ flonum-type
+; 2 make-fa-primitive flo:/
+
+:noname ( flonum1 flonum2 -- flonum1/flonum2 )
+    drop swap drop f/ flonum-type
+; 2 make-fa-primitive flo:/
+
+
+:noname ( flonum -- bool )
+    drop dup
+    fnan? swap finf? or invert
+; 1 make-fa-primitive flo:finite?
+
+
+:noname ( flonum -- flonum )
+    swap -1.0 f* swap
+; 1 make-fa-primitive flo:neg
+
+:noname ( flonum -- flonum )
+    swap fabs swap
+; 1 make-fa-primitive flo:abs
+
+:noname ( flonum -- flonum )
+    swap fexp swap
+; 1 make-fa-primitive flo:exp
+
+:noname ( flonum -- flonum )
+    swap flog swap
+; 1 make-fa-primitive flo:log
+
+:noname ( flonum -- flonum )
+    swap fsin swap
+; 1 make-fa-primitive flo:sin
+
+:noname ( flonum -- flonum )
+    swap fcos swap
+; 1 make-fa-primitive flo:cos
+
+:noname ( flonum -- flonum )
+    swap ftan swap
+; 1 make-fa-primitive flo:tan
+
+:noname ( flonum -- flonum )
+    swap fasin swap
+; 1 make-fa-primitive flo:asin
+
+:noname ( flonum -- flonum )
+    swap facos swap
+; 1 make-fa-primitive flo:acos
+
+:noname ( flonum -- flonum )
+    swap fatan swap
+; 1 make-fa-primitive flo:atan
+
+: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
+
+:noname ( flonum -- flonum )
+    swap floor swap
+; 1 make-fa-primitive flo:floor
+
+:noname ( flonum -- flonum )
+    swap ceiling swap
+; 1 make-fa-primitive flo:ceiling
+
+:noname ( flonum -- flonum )
+    swap truncate swap
+; 1 make-fa-primitive flo:truncate
 
+:noname ( flonum -- flonum )
+    swap fround swap
+; 1 make-fa-primitive flo:round
+
+: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
+
+\ --- Rationals ---
+
+' make-rational 2 make-fa-primitive make-rational
+
+:noname ( ratnum -- fixnum )
+    drop pair-type car
+; 1 make-fa-primitive rat:numerator
+
+:noname ( ratnum -- fixnum )
+    drop pair-type cdr
+; 1 make-fa-primitive rat:denominator
+
+\ --- Conversion ---
+
+:noname ( fixnum -- flonum )
+    drop i->f flonum-type
+; 1 make-fa-primitive fixnum->flonum
+
+\ }}}
+
+\ ==== 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
+:noname ( -- port )
+    console-i/o-port obj@
+; 0 make-fa-primitive console-i/o-port
+
+:noname ( -- port )
+    current-input-port obj@
+; 0 make-fa-primitive current-input-port
 
+:noname ( args -- charobj )
+    nil? if
+        2drop current-input-port obj@
+    else
+        car port-type ensure-arg-type
+    then
+
+    read-char
+; make-primitive read-char
+
+:noname ( args -- charobj )
+    nil? if
+        2drop current-input-port obj@
+    else
+        car port-type ensure-arg-type
+    then
+
+    peek-char
+; make-primitive peek-char
+
+:noname ( args -- stringobj )
+    nil? if
+        2drop current-input-port obj@
+    else
+        car port-type ensure-arg-type
+    then
+
+    read-line
+; make-primitive read-line
+
+: charlist>cstr ( charlist addr -- n )
+
+    dup 2swap ( origaddr addr charlist )
+
+    begin 
+        nil? false =
+    while
+        2dup cdr 2swap car 
+        drop ( origaddr addr charlist char )
+        -rot 2swap ( origaddr charlist addr char )
+        over !
+        1+ -rot ( origaddr nextaddr charlist )
+    repeat
+
+    2drop ( origaddr finaladdr ) 
+    swap -
+;
+
+:noname ( args -- finalResult )
     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 +579,21 @@ defer display
     print
 ; is display
 
-:noname ( args -- none )
-    2dup 1 ensure-arg-count
-    car string-type ensure-arg-type
-
-    displaystring
-
-    none
-; make-primitive display-string
-
-: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
+:noname ( stringobj -- none )
+    displaystring none
+; string-type 1 make-fa-type-primitive display-string
 
-    display
+:noname ( charobj -- none )
+    displaychar none
+; character-type 1 make-fa-type-primitive display-character
 
-    none
-; make-primitive display
+:noname ( obj -- none )
+    display none
+; 1 make-fa-primitive display
 
 :noname ( args -- none )
-    0 ensure-arg-count
-
-    cr
-
-    none
-; make-primitive newline
+    cr none
+; 0 make-fa-primitive newline
 
 \ }}}
 
@@ -450,12 +601,24 @@ defer display
 
 :noname ( args -- result )
     2dup car 2swap cdr
-
+ 
     nil? false = if car then ( proc argvals )
-    
-    apply
+     
+    2swap apply
 ; make-primitive apply 
 
+:noname ( proc -- result )
+    make-continuation
+
+    drop if
+        nil cons
+        2swap apply
+    else
+        2swap 2drop
+    then
+
+; 1 make-fa-primitive call-with-current-continuation
+
 \ }}}
 
 \ ==== Miscellaneous  ==== {{{
@@ -467,7 +630,17 @@ defer display
     nil? if
         ." Error."
     else
-        ." Error: " car display
+        ." Error:"
+
+        2dup car space display
+        cdr nil? invert if
+            begin
+                2dup car space print
+                cdr nil?
+            until
+        then
+
+        2drop
     then
 
     reset-term
@@ -477,18 +650,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
 
 \ }}}