+ 2rot ( var val env )
+ define-var
+
+ ok-symbol
+;
+
+: eval-assignment ( obj env -- res )
+ 2swap
+ 2over 2over ( env obj env obj )
+ assignment-val 2swap ( env obj valexp env )
+ eval ( env obj val )
+
+ 2swap assignment-var 2swap ( env var val )
+
+ 2rot ( var val env )
+ set-var
+
+ ok-symbol
+;
+
+: if? ( obj -- obj bool )
+ if-symbol tagged-list? ;
+
+: if-predicate ( ifobj -- pred )
+ cdr car ;
+
+: if-consequent ( ifobj -- conseq )
+ cdr cdr car ;
+
+: if-alternative ( ifobj -- alt|false )
+ cdr cdr cdr
+ 2dup nil objeq? if
+ 2drop false
+ else
+ car
+ then ;
+
+: false? ( boolobj -- boolean )
+ boolean-type istype? if
+ false boolean-type objeq?
+ else
+ 2drop false
+ then
+;
+
+: true? ( boolobj -- bool )
+ false? invert ;
+
+: lambda? ( obj -- obj bool )
+ lambda-symbol tagged-list? ;
+
+: lambda-parameters ( obj -- params )
+ cdr car ;
+
+: lambda-body ( obj -- body )
+ cdr cdr ;
+
+: make-procedure ( params body env -- proc )
+ nil
+ cons cons cons
+ drop compound-proc-type
+;
+
+: application? ( obj -- obj bool)
+ pair-type istype? ;
+
+: operator ( obj -- operator )
+ car ;
+
+: operands ( obj -- operands )
+ cdr ;
+
+: nooperands? ( operands -- bool )
+ nil objeq? ;
+
+: first-operand ( operands -- operand )
+ car ;
+
+: rest-operands ( operands -- other-operands )
+ cdr ;
+
+: 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
+
+\ }}}
+
+\ ---- DEBUGGING ---- {{{
+
+false value debug-mode
+
+:noname
+ debug-mode if
+ ." Object: " 2dup cr print cr
+ ." Pairlike: " pairlike? if
+ ." TRUE"
+ pairlike-marked? if
+ ." (Marked)"
+ else
+ ." (Unmarked)"
+ then
+ else
+ ." FALSE"
+ then
+ cr ." [paused]"
+ key drop cr
+ then
+; is gc-mark-trace
+
+: gc-mark-sweep
+ gc-unmark
+ symbol-table obj@ gc-mark-obj
+ global-env obj@ gc-mark-obj
+ gc-sweep
+;
+
+: gc-count-marked
+ 0
+ scheme-memsize 0 do
+ nextfrees i + @ 0= if 1+ then
+ loop
+;
+
+: gc-zero-unmarked
+ scheme-memsize 0 do
+ nextfrees i + @ 0<> if
+ 0 car-cells i + !
+ 0 cdr-cells i + !
+ then
+ loop
+;
+
+\ }}}
+
+
+\ ---- REPL ----