make-type symbol-type
make-type primitive-proc-type
make-type compound-proc-type
+make-type continuation-type
make-type port-type
: istype? ( obj type -- obj bool )
over = ;
make-exception recoverable-exception
make-exception unrecoverable-exception
-: throw reset-term throw ;
+: throw reset-term cr throw ;
\ }}}
create cdr-cells scheme-memsize allot
create cdr-type-cells scheme-memsize allot
+variable gc-enabled
+false gc-enabled !
+
+: gc-enabled?
+ gc-enabled @ ;
+
create nextfrees scheme-memsize allot
:noname
scheme-memsize 0 do
nextfree !
nextfree @ scheme-memsize >= if
- collect-garbage
+ gc-enabled? if
+ collect-garbage
+ then
then
nextfree @ scheme-memsize >= if
['] evaluate-eproc goto
endof
+ continuation-type of
+ \ TODO: Apply continuation
+ endof
+
except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
endcase
;
: printcomp ( primobj -- )
2drop ." <compound procedure>" ;
+: printcont ( primobj --)
+ 2drop ." <continuation>" ;
+
: printnone ( noneobj -- )
2drop ." Unspecified return value" ;
pair-type istype? if ." (" printpair ." )" exit then
primitive-proc-type istype? if printprim exit then
compound-proc-type istype? if printcomp exit then
+ continuation-type istype? if printcont exit then
none-type istype? if printnone exit then
port-type istype? if printport exit then
\ ---- Garbage Collection ---- {{{
-variable gc-enabled
-false gc-enabled !
-
variable gc-stack-depth
: enable-gc
: 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
;
:noname
- ." GC! "
-
- trace
+ \ ." GC! "
gc-unmark
gc-sweep
- ." (" gc-count-marked . ." pairs marked as used.)" cr
+ \ ." (" gc-count-marked . ." pairs marked as used.)" cr
; is collect-garbage
\ }}}
begin
\ DEBUG
- bold fg blue ." READ from " 2over drop . ." ==> " reset-term
+ \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2over read-port ( port res obj )
\ DEBUG
- 2dup print cr
+ \ 2dup print cr
2dup EOF character-type objeq? if
2drop 2swap close-port
include scheme-primitives.4th
+ enable-gc
+
s" scheme-library.scm" load 2drop
+
+ disable-gc
\ }}}
enable-gc
\ Display welcome message
- \ welcome-symbol nil cons global-env obj@ eval 2drop
+ welcome-symbol nil cons global-env obj@ eval 2drop
begin
['] repl-body catch
throw false
endcase
until
+
+ disable-gc
;
forth definitions