X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=c4a08cfa4a61d7a8625e78d5eccdd035cf14248b;hb=d2dc6c641693e0db30a8e11d7cb404148ba95838;hp=08b4bcd070b0cc912eb283b72479a7da33f9a8db;hpb=4d9d90cad9c4280d93d6bf67f2083ef9d3c8235f;p=scheme.forth.jl.git

diff --git a/scheme.4th b/scheme.4th
index 08b4bcd..c4a08cf 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -28,6 +28,7 @@ make-type boolean-type
 make-type character-type
 make-type string-type
 make-type nil-type
+make-type none-type
 make-type pair-type
 make-type symbol-type
 make-type primitive-proc-type
@@ -36,7 +37,7 @@ make-type fileport-type
 : istype? ( obj type -- obj bool )
     over = ;
 
-\ ------ List-structured memory ------ {{{
+\ ---- List-structured memory ---- {{{
 
 10000 constant scheme-memsize
 
@@ -112,6 +113,9 @@ variable nextfree
 : nil 0 nil-type ;
 : nil? nil-type istype? ;
 
+: none 0 none-type ;
+: none? none-type istype? ;
+
 : objvar create nil swap , , ;
 
 : value@ ( objvar -- val ) @ ;
@@ -176,7 +180,7 @@ console-i/o-port obj@ current-input-port obj!
 objvar symbol-table
 
 : duplicate-charlist ( charlist -- copy )
-    2dup nil objeq? false = if
+    nil? false = if
         2dup car 2swap cdr recurse cons
     then ;
 
@@ -235,7 +239,7 @@ objvar symbol-table
 ;
 
 
-: cstr>charlist ( addr n -- symbol-obj )
+: cstr>charlist ( addr n -- charlist )
     dup 0= if
         2drop nil
     else
@@ -252,26 +256,22 @@ objvar symbol-table
     count
 
     cstr>charlist
-    drop symbol-type
-
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
+    charlist>symbol
 
     create swap , ,
     does> dup @ swap 1+ @
 ;
 
-create-symbol quote     quote-symbol
-create-symbol define    define-symbol
-create-symbol set!      set!-symbol
-create-symbol ok        ok-symbol
-create-symbol if        if-symbol
-create-symbol lambda    lambda-symbol
-create-symbol λ         λ-symbol
-create-symbol begin     begin-symbol
+create-symbol quote         quote-symbol
+create-symbol define        define-symbol
+create-symbol define-macro  define-macro-symbol
+create-symbol set!          set!-symbol
+create-symbol ok            ok-symbol
+create-symbol if            if-symbol
+create-symbol lambda        lambda-symbol
+create-symbol λ             λ-symbol
+create-symbol begin         begin-symbol
+create-symbol apply         apply-symbol
 
 \ }}}
 
@@ -331,7 +331,7 @@ objvar vals
 : get-vars-vals ( var env -- vars? vals? bool )
 
     begin
-        2dup nil objeq? false =
+        nil? false =
     while
         2over 2over first-frame
         get-vars-vals-frame if
@@ -387,12 +387,73 @@ objvar env
 
 hide env
 
+: make-procedure ( params body env -- proc )
+    nil
+    cons cons cons
+    drop compound-proc-type
+;
+
 objvar global-env
 nil nil nil extend-env
 global-env obj!
 
 \ }}}
 
+\ ---- Macros ---- {{{
+
+objvar macro-table
+
+( Look up macro in macro table. Returns nil if
+  no macro is found. )
+: lookup-macro ( name_symbol -- proc )
+    macro-table obj@
+
+    begin
+        nil? false =
+    while
+        2over 2over
+        car car objeq? if
+            2swap 2drop
+            car cdr
+            exit
+        then
+
+        cdr
+    repeat
+
+    2swap 2drop
+;
+
+: make-macro ( name_symbol params body env -- )
+    make-procedure
+
+    2swap ( proc name_symbol )
+
+    macro-table obj@
+
+    begin
+        nil? false =
+    while
+        2over 2over ( proc name table name table )
+        car car objeq? if
+            2swap 2drop ( proc table )
+            car ( proc entry )
+            set-cdr!
+            exit
+        then
+
+        cdr
+    repeat
+
+    2drop
+
+    2swap cons
+    macro-table obj@ cons
+    macro-table obj!
+;
+
+\ }}}
+
 \ ---- Read ---- {{{
 
 variable parse-idx
@@ -886,6 +947,7 @@ parse-idx-stack parse-idx-sp !
     character-type istype? if true exit then
     string-type istype? if true exit then
     nil-type istype? if true exit then
+    none-type istype? if true exit then
 
     false
 ;
@@ -965,6 +1027,34 @@ parse-idx-stack parse-idx-sp !
     ok-symbol
 ;
 
+: macro-definition? ( obj -- obj bool )
+    define-macro-symbol tagged-list? ;
+
+: macro-definition-name ( exp -- mname )
+    cdr car car ;
+
+: macro-definition-params ( exp -- params )
+    cdr car cdr ;
+
+: macro-definition-body ( exp -- body )
+    cdr cdr ;
+
+objvar env
+: eval-define-macro ( obj env -- res )
+    env obj!
+
+    2dup macro-definition-name 2swap ( name obj )
+    2dup macro-definition-params 2swap ( name params obj )
+    macro-definition-body ( name params body )
+
+    env obj@ ( name params body env )
+
+    make-macro
+
+    ok-symbol
+;
+hide env
+
 : if? ( obj -- obj bool )
     if-symbol tagged-list? ;
 
@@ -976,7 +1066,7 @@ parse-idx-stack parse-idx-sp !
 
 : if-alternative ( ifobj -- alt|false )
     cdr cdr cdr
-    2dup nil objeq? if
+    nil? if
         2drop false
     else
         car
@@ -1002,12 +1092,6 @@ parse-idx-stack parse-idx-sp !
 : lambda-body ( obj -- body )
     cdr cdr ;
 
-: make-procedure ( params body env -- proc )
-    nil
-    cons cons cons
-    drop compound-proc-type
-;
-
 : begin? ( obj -- obj bool )
     begin-symbol tagged-list? ;
 
@@ -1022,11 +1106,14 @@ parse-idx-stack parse-idx-sp !
     2swap ( env explist )
 
     \ Abort on empty list
-    2dup nil objeq? if 2swap exit then
+    nil? if
+        2drop none
+        2swap exit
+    then
 
     begin
         2dup cdr ( env explist nextexplist )
-        2dup nil objeq? false =
+        nil? false =
     while
         -2rot car 2over ( nextexplist env exp env )
         eval
@@ -1037,7 +1124,7 @@ parse-idx-stack parse-idx-sp !
     2drop car 2swap ( finalexp env )
 ;
 
-: application? ( obj -- obj bool)
+: application? ( obj -- obj bool )
     pair-type istype? ;
 
 : operator ( obj -- operator )
@@ -1076,16 +1163,40 @@ parse-idx-stack parse-idx-sp !
 : procedure-env ( proc -- body )
     drop pair-type cdr cdr car ;
 
-: apply ( proc args )
+( Ensure terminating symbol arg name is handled
+  specially to allow for variadic procedures. )
+: flatten-proc-args ( argvals argnames -- argvals' argnames' )
+    nil? if exit then
+
+    symbol-type istype? if
+        nil cons
+        2swap
+        nil cons
+        2swap
+        exit
+    then
+
+    2over cdr 2over cdr
+    recurse ( argvals argnames argvals'' argnames'' )
+    2rot car 2swap cons  ( argvals argvals'' argnames' )
+    2rot car 2rot cons ( argnames' argvals' )
+    2swap
+;
+
+: apply ( proc argvals -- result )
         2swap dup case
             primitive-proc-type of
-                drop execute
+                drop execute     
             endof
 
             compound-proc-type of
-                2dup procedure-body ( args proc body )
-                -2rot 2dup procedure-params ( body args proc params )
-                -2rot procedure-env ( body params args procenv )
+                2dup procedure-body ( argvals proc body )
+                -2rot 2dup procedure-params ( body argvals proc argnames )
+                -2rot procedure-env ( body argnames argvals procenv )
+
+                -2rot 2swap
+                flatten-proc-args
+                2swap 2rot
 
                 extend-env ( body env )
 
@@ -1094,11 +1205,24 @@ parse-idx-stack parse-idx-sp !
                 R> drop ['] eval goto-deferred  \ Tail call optimization
             endof
 
-            bold fg red ." Object not applicable. Aboring." reset-term cr
+            bold fg red ." Object not applicable. Aborting." reset-term cr
             abort
         endcase
 ;
 
+: macro-expand ( proc expbody -- result )
+    2swap
+    2dup procedure-body ( expbody proc procbody )
+    -2rot 2dup procedure-params ( procbody expbody proc argnames )
+    -2rot procedure-env ( procbody argnames expbody procenv )
+    
+    -2rot 2swap
+    flatten-proc-args
+    2swap 2rot
+
+    extend-env eval-sequence eval
+;
+
 :noname ( obj env -- result )
     2swap
 
@@ -1128,6 +1252,11 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
+    macro-definition? if
+        2swap eval-define-macro
+        exit
+    then
+
     if? if
         2over 2over
         if-predicate
@@ -1151,14 +1280,57 @@ parse-idx-stack parse-idx-sp !
     then
 
     begin? if
-        \ TODO
+        begin-actions 2swap
+        eval-sequence
+        ['] eval goto-deferred
     then
 
     application? if
-        2over 2over
-        operator 2swap eval
-        -2rot
-        operands 2swap list-of-vals
+
+        2over 2over ( env exp env exp )
+        operator ( env exp env opname )
+
+        2dup apply-symbol objeq? if
+
+            2drop 2swap ( env env exp )
+            cdr 2dup car 2rot ( env expbody real-opname env )
+            eval ( env expbody proc )
+            2swap cdr
+            nil? false = if car then ( env proc real-operand )
+
+            2rot eval ( proc argvals )
+
+            pair-type istype? false = if
+                bold fg red ." Error: apply requires a list of operand arguments." cr
+                reset-term abort
+            then
+
+            apply
+            exit
+        then
+
+        2dup lookup-macro nil? false = if
+             \ Macro function evaluation
+
+            ( env exp env opname mproc )
+            2swap 2drop -2rot 2drop cdr ( env mproc body )
+
+            2dup print cr
+            macro-expand
+            2dup print cr
+
+            2swap
+            ['] eval goto-deferred
+        then
+
+       \ Regular function application
+
+        2drop ( env exp env opname )
+
+        2swap eval ( env exp proc )
+        -2rot ( proc env exp )
+        operands 2swap ( proc operands env )
+        list-of-vals ( proc argvals )
 
         apply
         exit
@@ -1238,6 +1410,9 @@ parse-idx-stack parse-idx-sp !
 : printcomp ( primobj -- )
     2drop ." <compound procedure>" ;
 
+: printnone ( noneobj -- )
+    2drop ." Unspecified return value" ;
+
 :noname ( obj -- )
     fixnum-type istype? if printfixnum exit then
     realnum-type istype? if printrealnum exit then
@@ -1249,6 +1424,7 @@ parse-idx-stack parse-idx-sp !
     pair-type istype? if ." (" printpair ." )" exit then
     primitive-proc-type istype? if printprim exit then
     compound-proc-type istype? if printcomp exit then
+    none-type istype? if printnone exit then
 
     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
     abort
@@ -1343,6 +1519,7 @@ variable gc-stack-depth
     gc-unmark
 
     symbol-table obj@ gc-mark-obj
+    macro-table obj@ gc-mark-obj
     global-env obj@ gc-mark-obj
 
     depth gc-stack-depth @ do
@@ -1359,6 +1536,49 @@ variable gc-stack-depth
 
 \ }}}
 
+\ ---- Loading files ---- {{{
+
+: 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 -
+;
+
+: load ( addr n -- finalResult )
+    open-input-file
+
+    empty-parse-str
+
+    ok-symbol ( port res )
+
+    begin
+        2over read-port ( port res obj )
+
+        2dup EOF character-type objeq? if
+            2drop 2swap close-port
+            exit
+        then
+
+        2swap 2drop ( port obj )
+
+        global-env obj@ eval ( port res )
+    again
+;
+
+\ }}}
+
 \ ---- Primitives ---- {{{
 
 : make-primitive ( cfa -- )
@@ -1368,14 +1588,8 @@ variable gc-stack-depth
     \ 2dup ." Defining primitive " type ." ..." cr
 
     cstr>charlist
-    drop symbol-type
-    
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
-
+    charlist>symbol
+  
     rot primitive-proc-type ( var prim )
     global-env obj@ define-var
 ;
@@ -1391,7 +1605,7 @@ variable gc-stack-depth
             arg-count-error
         then
     else
-        -rot 2dup nil objeq? if
+        -rot nil? if
             arg-count-error
         then
         
@@ -1414,56 +1628,10 @@ include scheme-primitives.4th
 
 \ }}}
 
-\ ---- Loading files ---- {{{
-
-: charlist>cstr ( charlist addr -- n )
-
-    dup 2swap ( origaddr addr charlist )
-
-    begin 
-        2dup nil objeq? 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 -
-;
-
-: load ( addr n -- finalResult )
-    open-input-file
-
-    empty-parse-str
-
-    ok-symbol ( port res )
-
-    begin
-        2over read-port ( port res obj )
-
-        2dup EOF character-type objeq? if
-            2drop 2swap close-port
-            exit
-        then
-
-        2swap 2drop ( port obj )
-
-        global-env obj@ eval ( port res )
-    again
-;
-
-: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
+\ ---- Standard Library ---- {{{
 
+    s" scheme-library.scm" load 2drop
+    
 \ }}}
 
 \ ---- REPL ----
@@ -1481,6 +1649,7 @@ include scheme-primitives.4th
         read-console
 
         2dup EOF character-type objeq? if
+            2drop
             bold fg blue ." Moriturus te saluto." reset-term cr
             exit
         then