+: list-of-vals ( args env -- vals )
+ 2swap
+
+ 2dup nooperands? if
+ 2swap 2drop
+ else
+ 2over 2over first-operand 2swap eval
+ -2rot rest-operands 2swap recurse
+ cons
+ then
+;
+
+: procedure-params ( proc -- params )
+ drop pair-type car ;
+
+: procedure-body ( proc -- body )
+ drop pair-type cdr car ;
+
+: procedure-env ( proc -- body )
+ drop pair-type cdr cdr car ;
+
+: apply ( proc args )
+ 2swap dup case
+ primitive-proc-type of
+ drop execute
+ endof
+
+ compound-proc-type of
+ 2dup procedure-body ( args proc body )
+ -2rot 2dup procedure-params ( body args proc params )
+ -2rot procedure-env ( body params args procenv )
+
+ extend-env ( body env )
+
+ 2swap ( env body )
+
+ begin
+ 2dup cdr 2dup nil objeq? false =
+ while
+ -2rot car 2over ( nextbody env exp env )
+ eval
+ 2drop \ discard result
+ 2swap ( env nextbody )
+ repeat
+
+ 2drop ( env body )
+ car 2swap ( exp env )
+
+ R> drop ['] eval goto-deferred \ Tail call optimization
+ endof
+
+ bold fg red ." Object not applicable. Aboring." reset-term cr
+ abort
+ endcase
+;
+
+:noname ( obj env -- result )
+ 2swap
+
+ self-evaluating? if
+ 2swap 2drop
+ exit
+ then
+
+ quote? if
+ quote-body
+ 2swap 2drop
+ exit
+ then
+
+ variable? if
+ 2swap lookup-var
+ exit
+ then
+
+ definition? if
+ 2swap eval-definition
+ exit
+ then
+
+ assignment? if
+ 2swap eval-assignment
+ exit
+ then
+
+ if? if
+ 2over 2over
+ if-predicate
+ 2swap eval
+
+ true? if
+ if-consequent
+ else
+ if-alternative
+ then
+
+ 2swap
+ ['] eval goto-deferred
+ then
+
+ lambda? if
+ 2dup lambda-parameters
+ 2swap lambda-body
+ 2rot make-procedure
+ exit
+ then
+
+ application? if
+ 2over 2over
+ operator 2swap eval
+ -2rot
+ operands 2swap list-of-vals
+
+ apply
+ exit
+ then
+
+ bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
+ abort
+; is eval
+
+\ }}}
+
+\ ---- Print ---- {{{
+
+: printfixnum ( fixnumobj -- ) drop 0 .R ;
+
+: printrealnum ( realnumobj -- ) drop float-print ;
+
+: printbool ( numobj -- )
+ drop if
+ ." #t"
+ else
+ ." #f"
+ then
+;
+
+: printchar ( charobj -- )
+ drop
+ case
+ 9 of ." #\tab" endof
+ bl of ." #\space" endof
+ '\n' of ." #\newline" endof
+
+ dup ." #\" emit
+ endcase
+;
+
+: (printstring) ( stringobj -- )
+ nil-type istype? if 2drop exit then
+
+ 2dup car drop dup
+ case
+ '\n' of ." \n" drop endof
+ [char] \ of ." \\" drop endof
+ [char] " of [char] \ emit [char] " emit drop endof
+ emit
+ endcase
+
+ cdr recurse
+;
+: printstring ( stringobj -- )
+ [char] " emit
+ (printstring)
+ [char] " emit ;
+
+: printsymbol ( symbolobj -- )
+ nil-type istype? if 2drop exit then
+
+ 2dup car drop emit
+ cdr recurse
+;
+
+: printnil ( nilobj -- )
+ 2drop ." ()" ;
+
+: printpair ( pairobj -- )
+ 2dup
+ car print
+ cdr
+ nil-type istype? if 2drop exit then
+ pair-type istype? if space recurse exit then
+ ." . " print
+;
+
+: printprim ( primobj -- )
+ 2drop ." <primitive procedure>" ;
+
+: printcomp ( primobj -- )
+ 2drop ." <compound procedure>" ;
+
+:noname ( obj -- )
+ fixnum-type istype? if printfixnum exit then
+ realnum-type istype? if printrealnum exit then
+ boolean-type istype? if printbool exit then
+ character-type istype? if printchar exit then
+ string-type istype? if printstring exit then
+ symbol-type istype? if printsymbol exit then
+ nil-type istype? if printnil exit then
+ pair-type istype? if ." (" printpair ." )" exit then
+ primitive-proc-type istype? if printprim exit then
+ compound-proc-type istype? if printcomp exit then
+
+ bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
+ abort
+; is print
+
+\ }}}
+
+\ ---- Garbage Collection ---- {{{
+
+variable gc-enabled
+false gc-enabled !
+
+variable gc-stack-depth
+
+: enable-gc
+ depth gc-stack-depth !
+ true gc-enabled ! ;
+
+: 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
+ 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
+;
+
+: gc-mark-obj ( obj -- )
+
+ 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
+;
+
+\ Following a GC, this gives the amount of free memory
+: gc-count-marked
+ 0
+ scheme-memsize 0 do
+ nextfrees i + @ 0= if 1+ then
+ loop
+;
+
+\ Debugging word - helps spot memory that is retained
+: gc-zero-unmarked
+ scheme-memsize 0 do
+ nextfrees i + @ 0<> if
+ 0 car-cells i + !
+ 0 cdr-cells i + !
+ then
+ loop
+;
+
+:noname
+ \ ." GC! "
+
+ gc-unmark
+
+ symbol-table obj@ gc-mark-obj
+ global-env obj@ gc-mark-obj
+
+ depth gc-stack-depth @ do
+ PSP0 i + 1 + @
+ PSP0 i + 2 + @
+
+ gc-mark-obj
+ 2 +loop
+
+ gc-sweep
+
+ \ ." (" gc-count-marked . ." pairs marked as used.)" cr
+; is collect-garbage
+
+\ }}}
+
+\ ---- REPL ----