\ ------ 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
: 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 @ + !
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
;
: 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 !