X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=3c5c6a95c90f863d54bc4e351c4e88e79a127acc;hb=13e038552e84df8c480b101b09e4c5a650bad2d0;hp=3e7b827ad54adfe6a7a507f53bbadecb508ad821;hpb=52243a65c93217c43cad6146bf38708fab52c7fd;p=scheme.forth.jl.git

diff --git a/scheme.4th b/scheme.4th
index 3e7b827..3c5c6a9 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -35,15 +35,15 @@ 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 N allot
+create nextfrees scheme-memsize allot
 :noname
-    N 0 do
+    scheme-memsize 0 do
         i 1+ nextfrees i + !
     loop
 ; execute
@@ -53,7 +53,15 @@ variable nextfree
 
 : inc-nextfree
     nextfrees nextfree @ + @
-    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 @ + !
@@ -143,6 +151,7 @@ false gc-enabled !
     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
 ;
@@ -157,23 +166,20 @@ false gc-enabled !
 
 : gc-mark-obj ( obj -- )
 
-    pairlike? if
-        pairlike-marked? if 2drop exit then
-            
-        mark-pairlike
+    pairlike? invert if 2drop exit then
+    pairlike-marked? if 2drop exit then
 
-        2dup
+    mark-pairlike
 
-        car recurse
-        cdr recurse
-    else
-        2drop
-    then
+    drop pair-type 2dup
+
+    car recurse
+    cdr recurse
 ;
 
 : gc-sweep
-    N nextfree !
-    0 N 1- do
+    scheme-memsize nextfree !
+    0 scheme-memsize 1- do
         nextfrees i + @ 0<> if
             nextfree @ nextfrees i + !
             i nextfree !