X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme.4th;h=e5ac9cd9297bb6b2a4908bdefbf47ad09b8c87b1;hb=632cf90c6a97b1ee01a13ab424051f0a99c4a150;hp=7d9e2c40f55c5688863a38b14f0f7e7d8129ee82;hpb=84e8f70df686212cbf4c4d38b282651a3735f840;p=scheme.forth.jl.git diff --git a/src/scheme.4th b/src/scheme.4th index 7d9e2c4..e5ac9cd 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -1315,95 +1315,6 @@ parse-idx-stack parse-idx-sp ! : quote-body ( quote-obj -- quote-body-obj ) cdr car ; -: quasiquote? ( obj -- obj bool ) - quasiquote-symbol tagged-list? ; - -: unquote? ( obj -- obj bool ) - unquote-symbol tagged-list? ; - -: unquote-splicing? ( obj -- obj bool ) - unquote-splicing-symbol tagged-list? ; - -: eval-unquote ( env obj -- res ) - cdr ( env args ) - - nil? if - except-message: ." no arguments to unquote." recoverable-exception throw - then - - 2dup cdr - nil? false = if - except-message: ." too many arguments to unquote." recoverable-exception throw - then - - 2drop car 2swap eval -; - -( Create a new list from elements of l1 consed on to l2 ) -: join-lists ( l2 l1 -- l3 ) - nil? if 2drop exit then - - 2dup car - -2rot cdr - recurse cons -; - -defer eval-quasiquote-item -: eval-quasiquote-pair ( env obj -- res ) - 2over 2over ( env obj env obj ) - - cdr eval-quasiquote-item - - -2rot car ( cdritem env objcar ) - - unquote-splicing? if - eval-unquote ( cdritems caritem ) - - 2swap nil? if - 2drop - else - 2swap join-lists - then - else - eval-quasiquote-item ( cdritems caritem ) - 2swap cons - then - -; - -:noname ( env obj ) - nil? if - 2swap 2drop exit - then - - unquote? if - eval-unquote exit - then - - pair-type istype? if - eval-quasiquote-pair exit - then - - 2swap 2drop -; is eval-quasiquote-item - -: eval-quasiquote ( obj env -- res ) - 2swap cdr ( env args ) - - nil? if - except-message: ." no arguments to quasiquote." recoverable-exception throw - then - - 2dup cdr ( env args args-cdr ) - nil? false = if - except-message: ." too many arguments to quasiquote." recoverable-exception throw - then - - 2drop car ( env arg ) - - eval-quasiquote-item -; - : variable? ( obj -- obj bool ) symbol-type istype? ; @@ -1665,11 +1576,6 @@ hide env exit then - quasiquote? if - 2swap eval-quasiquote - exit - then - variable? if 2swap lookup-var exit @@ -1734,7 +1640,10 @@ hide env \ ---- Analyze ---- -: evaluate-eproc ( env eproc --- res ) +: evaluate-eproc ( eproc env --- res ) + + >R >R + begin nil? invert while @@ -1744,21 +1653,26 @@ hide env 2drop \ get rid of null + R> R> 2swap + \ Final element of eproc list is primitive procedure drop \ dump type signifier + + .s cr \ DEBUG + goto \ jump straight to primitive procedure (executor) ; -: self-evaluating-executor ( env exp -- exp ) - 2swap 2drop ; +: self-evaluating-executor ( exp env -- exp ) + 2drop ; : analyze-self-evaluating ( exp --- eproc ) ['] self-evaluating-executor primitive-proc-type nil cons cons ; -: quote-executor ( env exp -- exp ) - 2swap 2drop ; +: quote-executor ( exp env -- exp ) + 2drop ; : analyze-quoted ( exp -- eproc ) quote-body @@ -1767,16 +1681,16 @@ hide env nil cons cons ; -: variable-executor ( env var -- val ) - 2swap lookup-var ; +: variable-executor ( var env -- val ) + lookup-var ; : analyze-variable ( exp -- eproc ) ['] variable-executor primitive-proc-type nil cons cons ; -: definition-executor ( env var val-eproc -- ok ) - 2rot 2dup 2rot ( var env env val-eproc ) +: definition-executor ( var val-eproc env -- ok ) + 2swap 2over ( var env val-eproc env ) evaluate-eproc 2swap ( var val env ) define-var ok-symbol @@ -1790,8 +1704,8 @@ hide env nil cons cons cons ; -: assignment-executor ( env var val-eproc -- ok ) - 2rot 2dup 2rot ( var env env val-eproc ) +: assignment-executor ( var val-eproc env -- ok ) + 2swap 2over ( var env val-eproc env ) evaluate-eproc 2swap ( var val env ) set-var ok-symbol @@ -1805,14 +1719,17 @@ hide env nil cons cons cons ; -: if-executor ( env pproc cproc aproc -- res ) - 2rot 3 2pick 2swap ( env cproc aproc env pproc ) +: if-executor ( cproc aproc pproc env -- res ) + 2swap 2over ( cproc aproc env pproc env -- res ) evaluate-eproc + true? if - 2drop evaluate-eproc + 2swap 2drop else - 2swap 2drop evaluate-eproc + 2rot 2drop then + + evaluate-eproc ; : analyze-if ( exp -- eproc ) @@ -1824,6 +1741,119 @@ hide env nil cons cons cons cons ; +: sequence-executor ( eproc-list env -- res ) + 2swap + + begin + 2dup cdr ( env elist elist-rest) + nil? invert + while + + -2rot car 2over ( elist-rest env elist-head env ) + evaluate-eproc ( elist-rest env head-res ) + 2drop 2swap ( env elist-rest ) + repeat + + 2drop car 2swap + ['] evaluate-eproc goto +; + + +: (analyze-sequence) ( explist -- eproc-list ) + nil? if exit then + + 2dup car analyze + 2swap cdr recurse + + cons +; + +: analyze-sequence ( explist -- eproc ) + (analyze-sequence) + ['] sequence-executor primitive-proc-type + nil cons cons +; + +: lambda-executor ( params bproc env -- res ) + make-procedure + ( Although this is packaged up as a regular compound procedure, + the "body" element contains an _eproc_ to be evaluated in an + environment resulting from extending env with the parameter + bindings. ) +; + +: analyze-lambda ( exp -- eproc ) + 2dup lambda-parameters + 2swap lambda-body + + nil? if + except-message: ." encountered lambda with an empty body." recoverable-exception throw + then + + analyze-sequence + + ['] lambda-executor primitive-proc-type + nil cons cons cons +; + +: operand-eproc-list ( operands -- eprocs ) + nil? invert if + 2dup car analyze + 2swap cdr recurse + cons + then +; + +: evaluate-operand-eprocs ( env aprocs -- vals ) + nil? if + 2swap 2drop + else + 2over 2over car 2swap evaluate-eproc ( env aprocs thisval ) + -2rot cdr recurse ( thisval restvals ) + cons + 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 ) + + dup case + primitive-proc-type of + drop execute + endof + + compound-proc-type of + 2dup procedure-body ( argvals proc body ) + -2rot 2dup procedure-params ( bproc argvals proc argnames ) + -2rot procedure-env ( bproc argnames argvals procenv ) + + -2rot 2swap + flatten-proc-args + 2swap 2rot + + extend-env ( bproc env ) + + ['] evaluate-eproc goto + endof + + except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw + endcase +; + +: analyze-application ( exp -- eproc ) + 2dup operator analyze + 2swap operands operand-eproc-list + + ['] application-executor primitive-proc-type + nil cons cons cons +; + :noname ( exp --- eproc ) self-evaluating? if @@ -1856,6 +1886,19 @@ hide env exit then + lambda? if + analyze-lambda + exit + then + + application? if + analyze-application + exit + then + + + except-message: ." tried to analyze unknown expression type." recoverable-exception throw + ; is analyze @@ -1893,33 +1936,6 @@ hide env R> drop ['] expand goto-deferred ; -: expand-quasiquote-item ( exp -- result ) - nil? if exit then - - unquote? if - unquote-symbol 2swap cdr car expand nil cons cons - exit - then - - unquote-splicing? if - unquote-splicing-symbol 2swap cdr car expand nil cons cons - exit - then - - pair-type istype? if - 2dup car recurse - 2swap cdr recurse - cons - then -; - -: expand-quasiquote ( exp -- result ) - quasiquote-symbol 2swap cdr - - expand-quasiquote-item - - cons ; - : expand-definition ( exp -- result ) define-symbol 2swap @@ -1989,8 +2005,6 @@ hide env quote? if exit then - quasiquote? if expand-quasiquote exit then - definition? if expand-definition exit then assignment? if expand-assignment exit then