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
exit
then
+ nextchar [char] ) = if
+ inc-parse-idx
+ except-message: ." unmatched closing parenthesis." recoverable-exception throw
+ then
+
\ Anything else is parsed as a symbol
readsymbol charlist>symbol
\ }}}
-\ ---- Eval ---- {{{
+\ ---- Syntax ---- {{{
: self-evaluating? ( obj -- obj bool )
boolean-type istype? if true exit then
\ }}}
-\ ---- Analyze ----
+\ ---- Analyze ---- {{{
: evaluate-eproc ( eproc env --- res )
then
;
-: application-executor ( operator-proc arg-procs env -- res )
- 2rot 2over ( aprocs env fproc env )
- evaluate-eproc ( aprocs env proc )
-
- -2rot 2swap ( proc env aprocs )
- evaluate-operand-eprocs ( proc vals )
-
- 2swap ( vals proc )
-
+: apply ( vals proc )
dup case
primitive-proc-type of
drop execute
['] evaluate-eproc goto
endof
+ continuation-type of
+ \ TODO: Apply continuation
+ endof
+
except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
endcase
;
+: application-executor ( operator-proc arg-procs env -- res )
+ 2rot 2over ( aprocs env fproc env )
+ evaluate-eproc ( aprocs env proc )
+
+ -2rot 2swap ( proc env aprocs )
+ evaluate-operand-eprocs ( proc vals )
+
+ 2swap ( vals proc )
+
+ ['] apply goto
+;
+
: analyze-application ( exp -- eproc )
2dup operator analyze
2swap operands operand-eproc-list
; is analyze
+\ }}}
\ ---- Macro Expansion ---- {{{
: 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
ok-symbol ( port res )
begin
+ \ DEBUG
+ \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
+
2over read-port ( port res obj )
+ \ DEBUG
+ \ 2dup print cr
+
2dup EOF character-type objeq? if
2drop 2swap close-port
exit
include scheme-primitives.4th
+ enable-gc
+
s" scheme-library.scm" load 2drop
+
+ disable-gc
\ }}}
throw false
endcase
until
+
+ disable-gc
;
forth definitions