X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=1d06ea63dd7458efbc0a9fe22574dd023d266d91;hb=9b75e5d50017b95ee8d10ade294c6676a1a60af4;hp=7ac6355287f14b249c1a201d0de7d517756fc81d;hpb=a966a509dd23259423e21c55d973403b88b86ea4;p=scheme.forth.jl.git

diff --git a/scheme.4th b/scheme.4th
index 7ac6355..1d06ea6 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -180,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 ;
 
@@ -239,7 +239,7 @@ objvar symbol-table
 ;
 
 
-: cstr>charlist ( addr n -- symbol-obj )
+: cstr>charlist ( addr n -- charlist )
     dup 0= if
         2drop nil
     else
@@ -256,13 +256,7 @@ 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+ @
@@ -336,7 +330,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
@@ -402,13 +396,63 @@ objvar global-env
 nil nil nil extend-env
 global-env obj!
 
+\ }}}
+
+\ ---- Primitives ---- {{{
+
+: make-primitive ( cfa -- )
+    bl word
+    count
+
+    \ 2dup ." Defining primitive " type ." ..." cr
+
+    cstr>charlist
+    charlist>symbol
+  
+    rot primitive-proc-type ( var prim )
+    global-env obj@ 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 nil? 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 -- arg )
+    istype? false = if
+        arg-type-error
+    then
+;
+
+
 \ }}}
 
 \ ---- Macros ---- {{{
 
 objvar macro-table
 
-: lookup-macro ( name_symbol -- proc? bool )
+( Look up macro in macro table. Returns nil if
+  no macro is found. )
+: lookup-macro ( name_symbol -- proc )
     macro-table obj@
 
     begin
@@ -418,11 +462,13 @@ objvar macro-table
         car car objeq? if
             2swap 2drop
             car cdr
-            true exit
+            exit
         then
+
+        cdr
     repeat
 
-    2drop false
+    2swap 2drop
 ;
 
 : make-macro ( name_symbol params body env -- )
@@ -442,6 +488,8 @@ objvar macro-table
             set-cdr!
             exit
         then
+
+        cdr
     repeat
 
     2drop
@@ -974,19 +1022,34 @@ parse-idx-stack parse-idx-sp !
 : make-lambda ( params body -- lambda-exp )
     lambda-symbol -2rot cons cons ;
 
-: definition-var ( obj -- var )
-    cdr car
-    symbol-type istype? false = if car then
+( Handles iterative expansion of defines in
+  terms of nested lambdas. Most Schemes only
+  handle one iteration of expansion! )
+: definition-var-val ( obj -- var val )
+
+    cdr 2dup cdr 2swap car ( val var )
+
+    begin
+        symbol-type istype? false =
+    while
+        2dup cdr 2swap car ( val formals var' )
+        -2rot 2swap ( var' formals val )
+        make-lambda nil cons ( var' val' )
+        2swap ( val' var' )
+    repeat
+
+    2swap car
 ;
 
-: definition-val ( obj -- val )
-    2dup cdr car symbol-type istype? if
-        2drop
-        cdr cdr car
-    else
-        cdr 2swap cdr cdr
-        make-lambda
-    then
+: eval-definition ( obj env -- res )
+    2dup 2rot ( env env obj )
+    definition-var-val ( env env var val )
+    2rot eval  ( env var val )
+
+    2rot ( var val env )
+    define-var
+
+    ok-symbol
 ;
 
 : assignment? ( obj -- obj bool )
@@ -998,20 +1061,6 @@ parse-idx-stack parse-idx-sp !
 : assignment-val ( obj -- val )
     cdr cdr car ;
 
-: eval-definition ( obj env -- res )
-    2swap 
-    2over 2over ( env obj env obj )
-    definition-val 2swap ( env obj valexp env )
-    eval  ( env obj val )
-    
-    2swap definition-var 2swap ( env var val )
-
-    2rot ( var val env )
-    define-var
-
-    ok-symbol
-;
-    
 : eval-assignment ( obj env -- res )
     2swap 
     2over 2over ( env obj env obj )
@@ -1029,6 +1078,31 @@ parse-idx-stack parse-idx-sp !
 : 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? ;
 
@@ -1040,7 +1114,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
@@ -1080,14 +1154,14 @@ parse-idx-stack parse-idx-sp !
     2swap ( env explist )
 
     \ Abort on empty list
-    2dup nil objeq? if
+    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
@@ -1140,7 +1214,15 @@ parse-idx-stack parse-idx-sp !
 ( Ensure terminating symbol arg name is handled
   specially to allow for variadic procedures. )
 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
-    nil? if exit then
+    nil? if
+        2over nil? false = if
+            bold fg red ." Too many arguments supplied to compound method. Aborting." reset-term cr
+            abort
+        else
+            2drop
+        then
+        exit
+    then
 
     symbol-type istype? if
         nil cons
@@ -1150,17 +1232,26 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
-    2over cdr 2over cdr
+    2over
+    nil? if
+        bold fg red ." Too few arguments supplied to compound method. Aborting." reset-term cr
+        abort
+    else
+        cdr
+    then
+
+    2over cdr
+
     recurse ( argvals argnames argvals'' argnames'' )
     2rot car 2swap cons  ( argvals argvals'' argnames' )
     2rot car 2rot cons ( argnames' argvals' )
     2swap
 ;
 
-: apply ( proc argvals )
+: apply ( proc argvals -- result )
         2swap dup case
             primitive-proc-type of
-                drop execute
+                drop execute     
             endof
 
             compound-proc-type of
@@ -1179,11 +1270,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
 
@@ -1248,27 +1352,35 @@ parse-idx-stack parse-idx-sp !
 
     application? if
 
-        2over 2over
-        operator
+        2over 2over ( env exp env exp )
+        operator ( env exp env opname )
 
-        find-macro-proc nil objeq? if
-            \ Regular function application
+        2dup lookup-macro nil? false = if
+             \ Macro function evaluation
 
-            2swap eval
-            -2rot
-            operands 2swap list-of-vals
+            ( env exp env opname mproc )
+            2swap 2drop -2rot 2drop cdr ( env mproc body )
 
-            apply
+            2dup print cr
+            macro-expand
+            2dup print cr
+
+            2swap
+            ['] eval goto-deferred
         else
-            \ Macro function evaluation
+           \ Regular function application
 
-            2swap 2drop 2swap ( env mproc exp )
+            2drop ( env exp env opname )
 
-            apply 2swap ( expanded-exp env )
+            2swap eval ( env exp proc )
 
-            ['] eval goto-deferred
+            -2rot ( proc env exp )
+            operands 2swap ( proc operands env )
+            list-of-vals ( proc argvals )
+
+            apply
+            exit
         then
-        exit
     then
 
     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
@@ -1471,61 +1583,6 @@ variable gc-stack-depth
 
 \ }}}
 
-\ ---- Primitives ---- {{{
-
-: make-primitive ( cfa -- )
-    bl word
-    count
-
-    \ 2dup ." Defining primitive " type ." ..." cr
-
-    cstr>charlist
-    drop symbol-type
-    
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
-
-    rot primitive-proc-type ( var prim )
-    global-env obj@ 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 -- arg )
-    istype? false = if
-        arg-type-error
-    then
-;
-
-include scheme-primitives.4th
-
-\ }}}
-
 \ ---- Loading files ---- {{{
 
 : charlist>cstr ( charlist addr -- n )
@@ -1533,7 +1590,7 @@ include scheme-primitives.4th
     dup 2swap ( origaddr addr charlist )
 
     begin 
-        2dup nil objeq? false =
+        nil? false =
     while
         2dup cdr 2swap car 
         drop ( origaddr addr charlist char )
@@ -1567,15 +1624,14 @@ include scheme-primitives.4th
     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 ---- {{{
 
+    include scheme-primitives.4th
+
+    s" scheme-library.scm" load 2drop
+    
 \ }}}
 
 \ ---- REPL ----