X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme-primitives.4th;h=1ed995b2439a3a5169105dd535f97fe3bd4d9e70;hb=bc2450b4b29d6bb8ba5422fb9eb7a75d1b6b5a57;hp=9203f71c721c26b0c7d887747a395dfbd1523c2b;hpb=73373387ae07d9da0ee049d96338555707b6d7b7;p=scheme.forth.jl.git

diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index 9203f71..1ed995b 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -1,4 +1,4 @@
-\ ==== Type predicates ==== {{{
+\ ==== Type predilcates ==== {{{
 
 :noname ( args -- boolobj )
     nil objeq? boolean-type
@@ -16,6 +16,14 @@
     fixnum-type istype? -rot 2drop boolean-type
 ; 1 make-fa-primitive fixnum?
 
+:noname ( args -- boolobj )
+    flonum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive flonum?
+
+:noname ( args -- boolobj )
+    ratnum-type istype? -rot 2drop boolean-type
+; 1 make-fa-primitive ratnum?
+
 :noname ( args -- boolobj )
     character-type istype? -rot 2drop boolean-type
 ; 1 make-fa-primitive char?
@@ -29,7 +37,13 @@
 ; 1 make-fa-primitive pair?
 
 :noname ( args -- boolobj )
-    primitive-proc-type istype? -rot 2drop boolean-type
+    primitive-proc-type istype? if
+        true
+    else
+        compound-proc-type istype?
+    then
+        
+    -rot 2drop boolean-type
 ; 1 make-fa-primitive procedure?
 
 \ }}}
@@ -139,9 +153,40 @@
     charlist>symbol
 ; make-primitive string->symbol
 
+:noname ( charlist -- string )
+    2dup 1 ensure-arg-count
+
+    car nil? if
+        2drop
+        nil nil cons
+        drop string-type
+        exit
+    then
+    
+    pair-type ensure-arg-type
+
+    duplicate-charlist
+    drop string-type
+; make-primitive list->string
+
+:noname ( string -- charlist )
+    2dup 1 ensure-arg-count
+    car string-type ensure-arg-type
+
+    drop pair-type
+
+    2dup car nil? if
+        2swap 2drop
+    else
+        2drop
+        duplicate-charlist
+    then
+
+; make-primitive string->list
+
 \ }}}
 
-\ ==== Primitivle Arithmetic ==== {{{
+\ ==== Numeric types ==== {{{
 
 \ --- Fixnums ---
 
@@ -165,15 +210,15 @@
     drop swap drop >= boolean-type
 ; 2 make-fa-primitive fix:>=
 
-:noname ( fixnum fixnum -- boolobj )
+:noname ( fixnum -- boolobj )
     drop 0= boolean-type
 ; 1 make-fa-primitive fix:zero?
 
-:noname ( fixnum fixnum -- boolobj )
+:noname ( fixnum -- boolobj )
     drop 0> boolean-type
 ; 1 make-fa-primitive fix:positive?
 
-:noname ( fixnum fixnum -- boolobj )
+:noname ( fixnum -- boolobj )
     drop 0< boolean-type
 ; 1 make-fa-primitive fix:negative?
 
@@ -209,10 +254,170 @@
     swap negate swap
 ; 1 make-fa-primitive fix:neg
 
-( Find the GCD of n1 and n2 where n2 < n1. )
-: gcd ( n1 n2 -- m )
-    
-;
+:noname ( fixnum -- -fixnum )
+    swap abs swap
+; 1 make-fa-primitive fix:abs
+
+:noname ( fixnum fixnum -- fixnum' )
+    drop swap drop gcd fixnum-type
+; 2 make-fa-primitive fix:gcd
+
+\ --- Flonums ---
+
+:noname ( flonum flonum -- bool )
+    objeq? boolean-type
+; 2 make-fa-primitive flo:=
+
+: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:>
+
+
+:noname ( flonum -- bool )
+    drop 0.0 = boolean-type
+; 1 make-fa-primitive flo:zero?
+
+:noname ( flonum -- bool )
+    drop 0.0 f> boolean-type
+; 1 make-fa-primitive flo:positive?
+
+: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
 
 \ }}}
 
@@ -258,6 +463,32 @@
 
 \ ==== Input/Output ==== {{{
 
+: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
+
+: 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