X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=fc307d718b150f12e547dbbd508eb9ae7eb5f6c9;hb=7ea88126cc603f83d9bfd54816bc47e88a12e7cf;hp=89b316011ffb5a1b318ae46396f7f9075905e401;hpb=1e77138f35f12ccc6fe20d943482ac6b57c3f7cd;p=scheme.forth.jl.git

diff --git a/scheme.4th b/scheme.4th
index 89b3160..fc307d7 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -28,24 +28,49 @@ 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
 make-type compound-proc-type
+make-type fileport-type
 : istype? ( obj type -- obj bool )
     over = ;
 
-\ ------ Cons cell memory ------ {{{
+\ ---- List-structured memory ---- {{{
 
-10000 constant N
-create car-cells N allot
-create car-type-cells N allot
-create cdr-cells N allot
-create cdr-type-cells N allot
+10000 constant scheme-memsize
 
+create car-cells scheme-memsize allot
+create car-type-cells scheme-memsize allot
+create cdr-cells scheme-memsize allot
+create cdr-type-cells scheme-memsize allot
+
+create nextfrees scheme-memsize allot
+:noname
+    scheme-memsize 0 do
+        i 1+ nextfrees i + !
+    loop
+; execute
+        
 variable nextfree
 0 nextfree !
 
+: inc-nextfree
+    nextfrees nextfree @ + @
+    nextfree !
+
+    nextfree @ scheme-memsize >= if
+        collect-garbage
+    then
+
+    nextfree @ scheme-memsize >= if
+        fg red bold
+        ." Out of memory! Aborting."
+        reset-term abort
+    then
+;
+
 : cons ( car-obj cdr-obj -- pair-obj )
     cdr-type-cells nextfree @ + !
     cdr-cells nextfree @ + !
@@ -53,10 +78,7 @@ variable nextfree
     car-cells nextfree @ + !
 
     nextfree @ pair-type
-
-    1 nextfree +!
-
-    collect-garbage
+    inc-nextfree
 ;
 
 : car ( pair-obj -- car-obj )
@@ -91,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 ) @ ;
@@ -119,25 +144,34 @@ variable nextfree
 
 \ }}}
 
-\ ---- Garbage Collection ---- {{{
+\ ---- Port I/O ----  {{{
 
-variable gc-enabled
-false gc-enabled !
+: fileport>fid ( fileport -- fid )
+    drop ;
 
-: gc-enable
-    true gc-enabled ! ;
+: fid>fileport ( fid -- fileport )
+    fileport-type ;
 
-: gc-disable
-    false gc-enabled ! ;
+: open-input-file ( addr n -- fileport )
+    r/o open-file drop fid>fileport
+;
 
-: gc-enabled?
-    gc-enabled @ ;
+: close-port ( fileport -- )
+    fileport>fid close-file drop
+;
 
-:noname 
-    gc-enabled? if
-        .s ." GC!" cr
-    then
-; is collect-garbage
+objvar console-i/o-port
+0 fileport-type console-i/o-port obj!
+
+objvar current-input-port
+console-i/o-port obj@ current-input-port obj!
+
+: read-port ( fileport -- obj )
+    current-input-port obj!
+    read ;
+
+: read-console ( -- obj )
+    console-i/o-port obj@ read-port ;
 
 \ }}}
 
@@ -146,7 +180,7 @@ false gc-enabled !
 objvar symbol-table
 
 : duplicate-charlist ( charlist -- copy )
-    2dup nil objeq? false = if
+    nil? false = if
         2dup car 2swap cdr recurse cons
     then ;
 
@@ -205,7 +239,7 @@ objvar symbol-table
 ;
 
 
-: (create-symbol) ( addr n -- symbol-obj )
+: cstr>charlist ( addr n -- charlist )
     dup 0= if
         2drop nil
     else
@@ -221,26 +255,25 @@ objvar symbol-table
     bl word
     count
 
-    (create-symbol)
-    drop symbol-type
-
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
+    cstr>charlist
+    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 quote             quote-symbol
+create-symbol quasiquote        quasiquote-symbol
+create-symbol unquote           unquote-symbol
+create-symbol unquote-splicing  unquote-splicing-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
 
 \ }}}
 
@@ -300,7 +333,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
@@ -356,6 +389,12 @@ 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!
@@ -370,15 +409,9 @@ global-env obj!
 
     \ 2dup ." Defining primitive " type ." ..." cr
 
-    (create-symbol)
-    drop symbol-type
-    
-    2dup
-
-    symbol-table obj@
-    cons
-    symbol-table obj!
-
+    cstr>charlist
+    charlist>symbol
+  
     rot primitive-proc-type ( var prim )
     global-env obj@ define-var
 ;
@@ -394,7 +427,7 @@ global-env obj!
             arg-count-error
         then
     else
-        -rot 2dup nil objeq? if
+        -rot nil? if
             arg-count-error
         then
         
@@ -413,7 +446,61 @@ global-env obj!
     then
 ;
 
-include scheme-primitives.4th
+
+\ }}}
+
+\ ---- 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!
+;
 
 \ }}}
 
@@ -445,13 +532,24 @@ parse-idx-stack parse-idx-sp !
     '\n' parse-str parse-str-span @ + !
     1 parse-str-span +! ;
 
+: append-eof
+    4 parse-str parse-str-span @ + !
+    1 parse-str-span +!  ;
+
 : empty-parse-str
     0 parse-str-span !
     0 parse-idx ! ;
 
 : getline
-    parse-str 160 expect cr
-    span @ parse-str-span !
+    current-input-port obj@ console-i/o-port obj@ objeq? if
+        parse-str 160 expect cr
+        span @ parse-str-span !
+    else
+        parse-str 160 current-input-port obj@ fileport>fid read-line
+        drop swap parse-str-span !
+
+        parse-str-span @ 0= and if append-eof then
+    then
     append-newline
     0 parse-idx ! ;
 
@@ -468,12 +566,16 @@ parse-idx-stack parse-idx-sp !
     charavailable? false = if getline then
     parse-str parse-idx @ + @ ;
 
+: '\t' 9 ;
 : whitespace? ( -- bool )
     nextchar BL = 
-    nextchar '\n' = or ;
+    nextchar '\n' =
+    nextchar '\t' =
+    or or ;
 
+: EOF 4 ; 
 : eof? ( -- bool )
-    nextchar 4 = ;
+    nextchar EOF = ;
 
 : delim? ( -- bool )
     whitespace?
@@ -691,7 +793,7 @@ parse-idx-stack parse-idx-sp !
     realnum-type
 ;
 
-: readbool ( -- bool-atom )
+: readbool ( -- bool-obj )
     inc-parse-idx
     
     nextchar [char] f = if
@@ -705,7 +807,7 @@ parse-idx-stack parse-idx-sp !
     boolean-type
 ;
 
-: readchar ( -- char-atom )
+: readchar ( -- char-obj )
     inc-parse-idx
     inc-parse-idx
 
@@ -867,10 +969,25 @@ parse-idx-stack parse-idx-sp !
         quote-symbol recurse nil cons cons exit
     then
 
+    nextchar [char] ` = if
+        inc-parse-idx
+        quasiquote-symbol recurse nil cons cons exit
+    then
+
+    nextchar [char] , = if
+        inc-parse-idx
+        nextchar [char] @ = if
+            inc-parse-idx
+            unquote-splicing-symbol recurse nil cons cons exit
+        else
+            unquote-symbol recurse nil cons cons exit
+        then
+    then
+
     eof? if
+        EOF character-type
         inc-parse-idx
-        bold fg blue ." Moriturus te saluto." reset-term cr
-        quit
+        exit
     then
 
     \ Anything else is parsed as a symbol
@@ -895,6 +1012,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
 ;
@@ -922,19 +1040,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 )
@@ -946,20 +1079,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 )
@@ -974,6 +1093,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? ;
 
@@ -985,7 +1132,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
@@ -1011,13 +1158,39 @@ 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? ;
+
+: begin-actions ( obj -- actions )
+    cdr ;
+
+: eval-sequence ( explist env -- finalexp env )
+    ( Evaluates all bar the final expressions in
+      an an expression list. The final expression
+      is returned to allow for tail optimization. )
+
+    2swap ( env explist )
+
+    \ Abort on empty list
+    nil? if
+        2drop none
+        2swap exit
+    then
+
+    begin
+        2dup cdr ( env explist nextexplist )
+        nil? false =
+    while
+        -2rot car 2over ( nextexplist env exp env )
+        eval
+        2drop \ discard result
+        2swap ( env nextexplist )
+    repeat
+
+    2drop car 2swap ( finalexp env )
 ;
 
-: application? ( obj -- obj bool)
+: application? ( obj -- obj bool )
     pair-type istype? ;
 
 : operator ( obj -- operator )
@@ -1056,41 +1229,83 @@ 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
+        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
+        2swap
+        nil cons
+        2swap
+        exit
+    then
+
+    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 -- 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 )
 
-                extend-env ( body env )
+                -2rot 2swap
+                flatten-proc-args
+                2swap 2rot
 
-                2swap ( env body )
-
-                begin
-                    2dup cdr 2dup nil objeq? false =
-                while
-                    -2rot car 2over ( nextbody env exp env )
-                    eval
-                    2drop \ discard result
-                    2swap ( env nextbody )
-                repeat
+                extend-env ( body env )
 
-                2drop ( env body )
-                car 2swap ( exp env )
+                eval-sequence
 
                 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
 
@@ -1120,6 +1335,11 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
+    macro-definition? if
+        2swap eval-define-macro
+        exit
+    then
+
     if? if
         2over 2over
         if-predicate
@@ -1142,14 +1362,41 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
+    begin? if
+        begin-actions 2swap
+        eval-sequence
+        ['] eval goto-deferred
+    then
+
     application? if
-        2over 2over
-        operator 2swap eval
-        -2rot
-        operands 2swap list-of-vals
 
-        apply
-        exit
+        2over 2over ( env exp env exp )
+        operator ( env exp env opname )
+
+        2dup lookup-macro nil? false = if
+             \ Macro function evaluation
+
+            ( env exp env opname mproc )
+            2swap 2drop -2rot 2drop cdr ( env mproc body )
+
+            macro-expand
+
+            2swap
+            ['] eval goto-deferred
+        else
+           \ 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
+        then
     then
 
     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
@@ -1226,6 +1473,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
@@ -1237,6 +1487,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
@@ -1244,20 +1495,180 @@ parse-idx-stack parse-idx-sp !
 
 \ }}}
 
+\ ---- Garbage Collection ---- {{{
+
+variable gc-enabled
+false gc-enabled !
+
+variable gc-stack-depth
+
+: enable-gc
+    depth gc-stack-depth !
+    true gc-enabled ! ;
+
+: disable-gc
+    false gc-enabled ! ;
+
+: gc-enabled?
+    gc-enabled @ ;
+
+: pairlike? ( obj -- obj bool )
+    pair-type istype? if true exit then
+    string-type istype? if true exit then
+    symbol-type istype? if true exit then
+    compound-proc-type istype? if true exit then
+
+    false
+;
+
+: pairlike-marked? ( obj -- obj bool )
+    over nextfrees + @ 0=
+;
+
+: mark-pairlike ( obj -- obj )
+        over nextfrees + 0 swap !
+;
+
+: gc-unmark ( -- )
+    scheme-memsize 0 do
+        1 nextfrees i + !
+    loop
+;
+
+: gc-mark-obj ( obj -- )
+
+    pairlike? invert if 2drop exit then
+    pairlike-marked? if 2drop exit then
+
+    mark-pairlike
+
+    drop pair-type 2dup
+
+    car recurse
+    cdr recurse
+;
+
+: gc-sweep
+    scheme-memsize nextfree !
+    0 scheme-memsize 1- do
+        nextfrees i + @ 0<> if
+            nextfree @ nextfrees i + !
+            i nextfree !
+        then
+    -1 +loop
+;
+
+\ Following a GC, this gives the amount of free memory
+: gc-count-marked
+    0
+    scheme-memsize 0 do
+        nextfrees i + @ 0= if 1+ then
+    loop
+;
+
+\ Debugging word - helps spot memory that is retained
+: gc-zero-unmarked
+    scheme-memsize 0 do
+        nextfrees i + @ 0<> if
+            0 car-cells i + !
+            0 cdr-cells i + !
+        then
+    loop
+;
+
+:noname
+    \ ." GC! "
+
+    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
+        PSP0 i + 1 + @
+        PSP0 i + 2 + @
+
+        gc-mark-obj
+    2 +loop
+
+    gc-sweep
+
+    \ ." (" gc-count-marked . ." pairs marked as used.)" cr
+; is collect-garbage
+
+\ }}}
+
+\ ---- 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
+;
+
+\ }}}
+
+\ ---- Standard Library ---- {{{
+
+    include scheme-primitives.4th
+
+    s" scheme-library.scm" load 2drop
+    
+\ }}}
+
 \ ---- REPL ----
 
 : repl
     cr ." Welcome to scheme.forth.jl!" cr
        ." Use Ctrl-D to exit." cr
 
-    
     empty-parse-str
 
-    gc-enable
+    enable-gc
 
     begin
         cr bold fg green ." > " reset-term
-        read
+        read-console
+
+        2dup EOF character-type objeq? if
+            2drop
+            bold fg blue ." Moriturus te saluto." reset-term cr
+            exit
+        then
 
         global-env obj@ eval