X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=3c4744e59f464c61d47dfe44ab6ce61899b4f421;hb=41a8ffdeecfc1bf848f83a9ccbf97f73a2e8e739;hp=bac32831cd66c30a1ddccafd5b7c54d99a72e89a;hpb=5d741836f2b7b3af569d43c9c29e20a55565102b;p=scheme.forth.jl.git

diff --git a/scheme.4th b/scheme.4th
index bac3283..3c4744e 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -3,9 +3,10 @@ scheme definitions
 
 include term-colours.4th
 include defer-is.4th
-include throw-catch.4th
 include float.4th
 
+include debugging.4th
+
 defer read
 defer eval
 defer print
@@ -16,7 +17,7 @@ variable nexttype
 0 nexttype !
 : make-type
     create nexttype @ ,
-    nexttype @ 1+ nexttype !
+    1 nexttype +!
     does> @ ;
 
 make-type fixnum-type
@@ -34,15 +35,34 @@ make-type compound-proc-type
 
 \ ------ Cons cell 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
+1000 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 @ + @
+
+    dup scheme-memsize < if
+        nextfree !
+    else
+        bold fg red
+        ." Out of memory! Aborting."
+        reset-term abort
+    then
+;
+
 : cons ( car-obj cdr-obj -- pair-obj )
     cdr-type-cells nextfree @ + !
     cdr-cells nextfree @ + !
@@ -50,8 +70,7 @@ variable nextfree
     car-cells nextfree @ + !
 
     nextfree @ pair-type
-
-    1 nextfree +!
+    inc-nextfree
 ;
 
 : car ( pair-obj -- car-obj )
@@ -114,6 +133,64 @@ variable nextfree
 
 \ }}}
 
+\ ---- Garbage Collection ---- {{{
+
+variable gc-enabled
+false gc-enabled !
+
+: gc-enable
+    true gc-enabled ! ;
+
+: 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 !
+;
+
+: gc-mark-obj ( obj -- )
+
+    pairlike? if
+        pairlike-marked? if 2drop exit then
+            
+        mark-pairlike
+
+        2dup
+
+        car recurse
+        cdr recurse
+    else
+        2drop
+    then
+;
+
+: gc-sweep
+    scheme-memsize nextfree !
+    0 scheme-memsize 1- do
+        nextfrees i + @ 0<> if
+            nextfree @ nextfrees i + !
+            i nextfree !
+        then
+    -1 +loop ;
+
+\ }}}
+
 \ ---- Pre-defined symbols ---- {{{
 
 objvar symbol-table
@@ -341,6 +418,8 @@ global-env obj!
     bl word
     count
 
+    \ 2dup ." Defining primitive " type ." ..." cr
+
     (create-symbol)
     drop symbol-type
     
@@ -513,16 +592,16 @@ parse-idx-stack parse-idx-sp !
 ;
 
 : realnum? ( -- bool )
-    \ Record starting parse idx:
-    \ Want to detect whether any characters were eaten.
-    parse-idx @
-
     push-parse-idx
 
     minus? plus? or if
         inc-parse-idx
     then
 
+    \ Record starting parse idx:
+    \ Want to detect whether any characters (following +/-) were eaten.
+    parse-idx @
+
     begin digit? while
             inc-parse-idx
     repeat
@@ -541,6 +620,10 @@ parse-idx-stack parse-idx-sp !
             inc-parse-idx
         then
 
+        digit? invert if
+            drop pop-parse-idx false exit
+        then
+
         begin digit? while
                 inc-parse-idx
         repeat
@@ -836,7 +919,7 @@ parse-idx-stack parse-idx-sp !
 
     eof? if
         inc-parse-idx
-        bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
+        bold fg blue ." Moriturus te saluto." reset-term cr
         quit
     then
 
@@ -1217,12 +1300,15 @@ parse-idx-stack parse-idx-sp !
     cr ." Welcome to scheme.forth.jl!" cr
        ." Use Ctrl-D to exit." cr
 
+    
     empty-parse-str
 
     begin
         cr bold fg green ." > " reset-term
         read
+
         global-env obj@ eval
+
         fg cyan ." ; " print reset-term
     again
 ;