X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=644ee1914c221ab38227825a97f09599391140a6;hb=c5d17be5654a1b22bc4d8364da5136fc3669aae6;hp=e2162be192dc2a34d7c714339f180ba1f75b3449;hpb=613a9d60145361cec8ed96e49193f730e113a53a;p=scheme.forth.jl.git

diff --git a/scheme.4th b/scheme.4th
index e2162be..644ee19 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -6,13 +6,14 @@ include defer-is.4th
 
 \ ------ Types ------
 
-0 constant number-type
+0 constant fixnum-type
 1 constant boolean-type
 2 constant character-type
 3 constant string-type
 4 constant nil-type
 5 constant pair-type
 6 constant symbol-type
+7 constant primitive-type
 : istype? ( obj type -- obj bool )
     over = ;
 
@@ -82,6 +83,20 @@ variable nextfree
 : objeq? ( obj obj -- bool )
     rot = -rot = and ;
 
+: 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
+    >R >R ( a1 a2 b1 b2 )
+    2swap ( b1 b2 a1 a2 )
+    R> R> ( b1 b2 a1 a2 c1 c2 )
+    2swap
+;
+
+: -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
+    2swap ( a1 a2 c1 c2 b1 b2 )
+    >R >R ( a1 a2 c1 c2 )
+    2swap ( c1 c2 a1 a2 )
+    R> R>
+;
+
 \ }}}
 
 \ ---- Pre-defined symbols ---- {{{
@@ -243,8 +258,63 @@ global-env setobj
 
 \ }}}
 
+\ ---- Primitives ---- {{{
+
+: make-primitive ( cfa -- )
+    bl word
+    count
+
+    (create-symbol)
+    drop symbol-type
+    
+    2dup
+
+    symbol-table fetchobj
+    cons
+    symbol-table setobj
+
+    rot primitive-type ( var prim )
+    global-env fetchobj define-var
+;
+
+: arg-count-error
+            bold fg red ." Incorrect argument count." reset-term cr
+            abort
+;
+
+: ensure-arg-count ( args n -- )
+    dup 0= if
+        drop nil objeq? false = if
+            arg-count-error
+        then
+    else
+        -rot 2dup nil objeq? if
+            arg-count-error
+        then
+        
+        cdr rot 1- recurse
+    then
+;
+
+: arg-type-error
+            bold fg red ." Incorrect argument type." reset-term cr
+            abort
+;
+
+: ensure-arg-type ( arg type -- )
+    istype? false = if
+        arg-type-error
+    then
+;
+
+include scheme-primitives.4th
+
+\ }}}
+
 \ ---- Read ---- {{{
 
+defer read
+
 variable parse-idx
 variable stored-parse-idx
 create parse-str 161 allot
@@ -323,10 +393,20 @@ parse-idx-stack parse-idx-sp !
 : minus? ( -- bool )
     nextchar [char] - = ;
 
-: number? ( -- bool )
-    digit? minus? or false = if
-        false
-        exit
+: fixnum? ( -- bool )
+    minus? if
+        inc-parse-idx
+
+        delim? if
+            dec-parse-idx
+            false exit
+        else
+            dec-parse-idx
+        then
+    else
+        digit? false = if
+            false exit
+        then
     then
 
     push-parse-idx
@@ -426,7 +506,7 @@ parse-idx-stack parse-idx-sp !
 
     swap if negate then
 
-    number-type
+    fixnum-type
 ;
 
 : readbool ( -- bool-atom )
@@ -552,8 +632,6 @@ parse-idx-stack parse-idx-sp !
     symbol-table setobj
 ;
 
-defer read
-
 : readpair ( -- pairobj )
     eatspaces
 
@@ -601,7 +679,7 @@ defer read
 
     eatspaces
 
-    number? if
+    fixnum? if
         readnum
         exit
     then
@@ -674,7 +752,7 @@ defer eval
 
 : self-evaluating? ( obj -- obj bool )
     boolean-type istype? if true exit then
-    number-type istype? if true exit then
+    fixnum-type istype? if true exit then
     character-type istype? if true exit then
     string-type istype? if true exit then
     nil-type istype? if true exit then
@@ -725,7 +803,7 @@ defer eval
     
     2swap definition-var 2swap ( env var val )
 
-    >R >R 2swap R> R> 2swap ( var val env )
+    2rot ( var val env )
     define-var
 
     ok-symbol
@@ -739,7 +817,7 @@ defer eval
     
     2swap assignment-var 2swap ( env var val )
 
-    >R >R 2swap R> R> 2swap ( var val env )
+    2rot ( var val env )
     set-var
 
     ok-symbol
@@ -770,9 +848,39 @@ defer eval
     then
 ;
 
-: true? ( boolobj -- boolean )
+: true? ( boolobj -- bool )
     false? invert ;
 
+: application? ( obj -- obj bool)
+    pair-type istype? ;
+
+: operator ( obj -- operator )
+    car ;
+
+: operands ( obj -- operands )
+    cdr ;
+
+: nooperands? ( operands -- bool )
+    nil objeq? ;
+
+: first-operand ( operands -- operand )
+    car ;
+
+: rest-operands ( operands -- other-operands )
+    cdr ;
+
+: list-of-vals ( args env -- vals )
+    2swap
+
+    2dup nooperands? if
+        2swap 2drop
+    else
+        2over 2over first-operand 2swap eval
+        -2rot rest-operands 2swap recurse
+        cons
+    then
+;
+
 :noname ( obj env -- result )
     2swap
 
@@ -816,6 +924,22 @@ defer eval
         2swap ['] eval goto
     then
 
+    application? if
+        2over 2over
+        operator 2swap eval
+
+        primitive-type istype? false = if
+            bold fg red ." Object not applicable. Aboring." reset-term cr
+            abort
+        then
+
+        -2rot
+        operands 2swap list-of-vals
+
+        2swap drop execute
+        exit
+    then
+
     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
     abort
 ; is eval
@@ -824,6 +948,8 @@ defer eval
 
 \ ---- Print ---- {{{
 
+defer print
+
 : printnum ( numobj -- ) drop 0 .R ;
 
 : printbool ( numobj -- )
@@ -873,7 +999,6 @@ defer eval
 : printnil ( nilobj -- )
     2drop ." ()" ;
 
-defer print
 : printpair ( pairobj -- )
     2dup
     car print
@@ -883,14 +1008,18 @@ defer print
     ."  . " print
 ;
 
+: printprim ( primobj -- )
+    2drop ." <primitive procedure>" ;
+
 :noname ( obj -- )
-    number-type istype? if printnum exit then
+    fixnum-type istype? if printnum exit then
     boolean-type istype? if printbool exit then
     character-type istype? if printchar exit then
     string-type istype? if printstring exit then
     symbol-type istype? if printsymbol exit then
     nil-type istype? if printnil exit then
     pair-type istype? if ." (" printpair ." )" exit then
+    primitive-type istype? if printprim exit then
 
     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
     abort