Primitives are now GC-safe.

[scheme.forth.jl.git] / scheme.4th

diff --git a/scheme.4th b/scheme.4th
index 89b3160..74a5b45 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -11,8 +11,6 @@ defer read
 defer eval
 defer print
 
-defer collect-garbage
-
 \ ------ Types ------
 
 variable nexttype
@@ -37,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 @ + !
@@ -53,10 +70,7 @@ variable nextfree
     car-cells nextfree @ + !
 
     nextfree @ pair-type
-
-    1 nextfree +!
-
-    collect-garbage
+    inc-nextfree
 ;
 
 : car ( pair-obj -- car-obj )
@@ -124,20 +138,63 @@ variable nextfree
 variable gc-enabled
 false gc-enabled !
 
-: gc-enable
+: enable-gc
     true gc-enabled ! ;
 
-: gc-disable
+: disable-gc
     false gc-enabled ! ;
 
 : gc-enabled?
     gc-enabled @ ;
 
-:noname 
-    gc-enabled? if
-        .s ." GC!" cr
-    then
-; is collect-garbage
+: 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
+;
+
+defer gc-mark-trace
+: gc-mark-obj ( obj -- )
+
+    gc-mark-trace
+
+    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
+;
 
 \ }}}
 
@@ -1244,6 +1301,54 @@ parse-idx-stack parse-idx-sp !
 
 \ }}}
 
+\ ---- DEBUGGING ---- {{{
+
+false value debug-mode
+
+: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
+
+: gc-mark-sweep
+    gc-unmark
+    symbol-table obj@ gc-mark-obj
+    global-env obj@ gc-mark-obj
+    gc-sweep
+;
+
+: gc-count-marked
+    0
+    scheme-memsize 0 do
+        nextfrees i + @ 0= if 1+ then
+    loop
+;
+
+: gc-zero-unmarked
+    scheme-memsize 0 do
+        nextfrees i + @ 0<> if
+            0 car-cells i + !
+            0 cdr-cells i + !
+        then
+    loop
+;
+
+\ }}}
+
+
 \ ---- REPL ----
 
 : repl
@@ -1253,8 +1358,6 @@ parse-idx-stack parse-idx-sp !
     
     empty-parse-str
 
-    gc-enable
-
     begin
         cr bold fg green ." > " reset-term
         read