\ ------ Cons cell memory ------ {{{
-1000 constant N
+10000 constant N
create car-cells N allot
create car-type-cells N allot
create cdr-cells N allot
: definition? ( obj -- obj bool )
define-symbol tagged-list? ;
+: make-lambda ( params body -- lambda-exp )
+ lambda-symbol -2rot cons cons ;
+
: definition-var ( obj -- var )
- cdr car ;
+ cdr car
+ symbol-type istype? false = if car then
+;
: definition-val ( obj -- val )
- cdr cdr car ;
+ 2dup cdr car symbol-type istype? if
+ 2drop
+ cdr cdr car
+ else
+ cdr 2swap cdr cdr
+ make-lambda
+ then
+;
: assignment? ( obj -- obj bool )
set!-symbol tagged-list? ;
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
endof
compound-proc-type of
- ." Compound procedures not yet implemented."
+ 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 )
+
+ ['] eval goto-prime \ Tail call optimization
+ \ eval \ No tail call optimization
endof
bold fg red ." Object not applicable. Aboring." reset-term cr
then
lambda? if
- 2dup lambda-body
- 2swap lambda-parameters
+ 2dup lambda-parameters
+ 2swap lambda-body
2rot make-procedure
exit
then