X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;ds=sidebyside;f=scheme.4th;h=1f2111ab41158161e4c76f1066a396611d920fe1;hb=9f67194788cd9f6b8b576e31ecb7f3059648a659;hp=9a2a3ca1779e9fab029a6b6ef80893a09e621795;hpb=ce188b101cbb79f55249d3eb6ff06e44ef065096;p=scheme.forth.jl.git diff --git a/scheme.4th b/scheme.4th index 9a2a3ca..1f2111a 100644 --- a/scheme.4th +++ b/scheme.4th @@ -20,7 +20,7 @@ include defer-is.4th \ ------ 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 @@ -817,11 +817,23 @@ defer eval : 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? ; @@ -933,6 +945,15 @@ defer eval 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 @@ -940,7 +961,28 @@ defer eval 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 @@ -992,8 +1034,8 @@ defer eval then lambda? if - 2dup lambda-body - 2swap lambda-parameters + 2dup lambda-parameters + 2swap lambda-body 2rot make-procedure exit then