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

diff --git a/scheme.4th b/scheme.4th
index 8d28269..08b4bcd 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -11,6 +11,8 @@ defer read
 defer eval
 defer print
 
+defer collect-garbage
+
 \ ------ Types ------
 
 variable nexttype
@@ -30,12 +32,14 @@ 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 scheme-memsize
 
-1000 constant scheme-memsize
 create car-cells scheme-memsize allot
 create car-type-cells scheme-memsize allot
 create cdr-cells scheme-memsize allot
@@ -53,11 +57,14 @@ variable nextfree
 
 : inc-nextfree
     nextfrees nextfree @ + @
+    nextfree !
 
-    dup scheme-memsize < if
-        nextfree !
-    else
-        bold fg red
+    nextfree @ scheme-memsize >= if
+        collect-garbage
+    then
+
+    nextfree @ scheme-memsize >= if
+        fg red bold
         ." Out of memory! Aborting."
         reset-term abort
     then
@@ -133,73 +140,37 @@ 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 ! ;
-
-: 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 !
+: open-input-file ( addr n -- fileport )
+    r/o open-file drop fid>fileport
 ;
 
-: gc-unmark ( -- )
-    scheme-memsize 0 do
-        1 nextfrees i + !
-    loop
+: close-port ( fileport -- )
+    fileport>fid close-file drop
 ;
 
-defer gc-mark-trace
-: gc-mark-obj ( obj -- )
+objvar console-i/o-port
+0 fileport-type console-i/o-port obj!
 
-    gc-mark-trace
+objvar current-input-port
+console-i/o-port obj@ current-input-port obj!
 
-    pairlike? invert if 2drop exit then
-    pairlike-marked? if 2drop exit then
+: read-port ( fileport -- obj )
+    current-input-port obj!
+    read ;
 
-    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
-;
+: read-console ( -- obj )
+    console-i/o-port obj@ read-port ;
 
 \ }}}
 
-   
-
 \ ---- Pre-defined symbols ---- {{{
 
 objvar symbol-table
@@ -264,7 +235,7 @@ objvar symbol-table
 ;
 
 
-: (create-symbol) ( addr n -- symbol-obj )
+: cstr>charlist ( addr n -- symbol-obj )
     dup 0= if
         2drop nil
     else
@@ -280,7 +251,7 @@ objvar symbol-table
     bl word
     count
 
-    (create-symbol)
+    cstr>charlist
     drop symbol-type
 
     2dup
@@ -300,6 +271,7 @@ create-symbol ok        ok-symbol
 create-symbol if        if-symbol
 create-symbol lambda    lambda-symbol
 create-symbol λ         λ-symbol
+create-symbol begin     begin-symbol
 
 \ }}}
 
@@ -421,61 +393,6 @@ global-env obj!
 
 \ }}}
 
-\ ---- Primitives ---- {{{
-
-: make-primitive ( cfa -- )
-    bl word
-    count
-
-    \ 2dup ." Defining primitive " type ." ..." cr
-
-    (create-symbol)
-    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
-
-\ }}}
-
 \ ---- Read ---- {{{
 
 variable parse-idx
@@ -504,13 +421,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 ! ;
 
@@ -527,12 +455,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?
@@ -750,7 +682,7 @@ parse-idx-stack parse-idx-sp !
     realnum-type
 ;
 
-: readbool ( -- bool-atom )
+: readbool ( -- bool-obj )
     inc-parse-idx
     
     nextchar [char] f = if
@@ -764,7 +696,7 @@ parse-idx-stack parse-idx-sp !
     boolean-type
 ;
 
-: readchar ( -- char-atom )
+: readchar ( -- char-obj )
     inc-parse-idx
     inc-parse-idx
 
@@ -927,9 +859,9 @@ parse-idx-stack parse-idx-sp !
     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
@@ -1076,6 +1008,35 @@ parse-idx-stack parse-idx-sp !
     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
+    2dup nil objeq? if 2swap exit then
+
+    begin
+        2dup cdr ( env explist nextexplist )
+        2dup nil objeq? 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)
     pair-type istype? ;
 
@@ -1128,19 +1089,7 @@ parse-idx-stack parse-idx-sp !
 
                 extend-env ( body env )
 
-                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
-
-                2drop ( env body )
-                car 2swap ( exp env )
+                eval-sequence
 
                 R> drop ['] eval goto-deferred  \ Tail call optimization
             endof
@@ -1201,6 +1150,10 @@ parse-idx-stack parse-idx-sp !
         exit
     then
 
+    begin? if
+        \ TODO
+    then
+
     application? if
         2over 2over
         operator 2swap eval
@@ -1303,35 +1256,70 @@ parse-idx-stack parse-idx-sp !
 
 \ }}}
 
-\ ---- DEBUGGING ---- {{{
+\ ---- Garbage Collection ---- {{{
 
-false value debug-mode
+variable gc-enabled
+false gc-enabled !
 
-:noname
-    debug-mode if
-        ." Object: " 2dup cr print cr
-        ." Pairlike: " pairlike? if
-            ." TRUE"
-            pairlike-marked? if
-                ."  (Marked)"
-            else
-                ."  (Unmarked)"
-            then
-        else
-            ." FALSE"
-        then
-        cr ." [paused]"
-        key drop cr
-    then
-; is gc-mark-trace
+variable gc-stack-depth
 
-: gc-mark-sweep
-    gc-unmark
-    symbol-table obj@ gc-mark-obj
-    global-env obj@ gc-mark-obj
-    gc-sweep
+: 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
@@ -1339,6 +1327,7 @@ false value debug-mode
     loop
 ;
 
+\ Debugging word - helps spot memory that is retained
 : gc-zero-unmarked
     scheme-memsize 0 do
         nextfrees i + @ 0<> if
@@ -1348,8 +1337,134 @@ false value debug-mode
     loop
 ;
 
+:noname
+    \ ." GC! "
+
+    gc-unmark
+
+    symbol-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
+
+\ }}}
+
+\ ---- 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 )
+
+    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
+
+\ }}}
 
 \ ---- REPL ----
 
@@ -1357,12 +1472,18 @@ false value debug-mode
     cr ." Welcome to scheme.forth.jl!" cr
        ." Use Ctrl-D to exit." cr
 
-    
     empty-parse-str
 
+    enable-gc
+
     begin
         cr bold fg green ." > " reset-term
-        read
+        read-console
+
+        2dup EOF character-type objeq? if
+            bold fg blue ." Moriturus te saluto." reset-term cr
+            exit
+        then
 
         global-env obj@ eval