X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme.4th;h=a32ee45a8d10b5c315fc3f8aceab42bafe3ecd8d;hb=6cb6a8d3e4449a1cf70ac4cbb0b88cf2c38d6434;hp=ec97f09761c26f8603c14001277cd08b6f5e7dd8;hpb=724ff46a1b082bef48b310a85d5a82037c2a914c;p=scheme.forth.jl.git diff --git a/src/scheme.4th b/src/scheme.4th index ec97f09..a32ee45 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -3,6 +3,7 @@ scheme definitions include term-colours.4th include defer-is.4th +include goto.4th include catch-throw.4th include integer.4th include float.4th @@ -11,6 +12,7 @@ include debugging.4th defer read defer expand +defer analyze defer eval defer print @@ -162,6 +164,10 @@ variable nextfree R> R> ; +: 2pick ( an bn an-1 bn-1 ... a0 b0 n -- an bn an-1 bn-1 ... a0 b0 an bn ) + 2* 1+ dup + >R pick R> pick ; + \ }}} \ ---- Pre-defined symbols ---- {{{ @@ -1309,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? ; @@ -1612,119 +1529,274 @@ hide env 2swap ; -: apply ( proc argvals -- result ) - 2swap dup case - primitive-proc-type of - drop execute - endof +\ }}} + +\ ---- Analyze ---- + +: evaluate-eproc ( eproc env --- res ) + + >R >R + + begin + nil? invert + while + 2dup car + 2swap cdr + repeat + + 2drop \ get rid of null + + R> R> 2swap + + \ Final element of eproc list is primitive procedure + drop \ dump type signifier + + goto \ jump straight to primitive procedure (executor) +; + +: self-evaluating-executor ( exp env -- exp ) + 2drop ; + +: analyze-self-evaluating ( exp --- eproc ) + ['] self-evaluating-executor primitive-proc-type + nil cons cons +; + +: quote-executor ( exp env -- exp ) + 2drop ; + +: analyze-quoted ( exp -- eproc ) + quote-body + + ['] quote-executor primitive-proc-type + nil cons cons +; + +: variable-executor ( var env -- val ) + lookup-var ; + +: analyze-variable ( exp -- eproc ) + ['] variable-executor primitive-proc-type + nil cons cons +; + +: definition-executor ( var val-eproc env -- ok ) + 2swap 2over ( var env val-eproc env ) + evaluate-eproc 2swap ( var val env ) + define-var + ok-symbol +; + +: analyze-definition ( exp -- eproc ) + 2dup definition-var + 2swap definition-val analyze + + ['] definition-executor primitive-proc-type + nil cons cons cons +; + +: assignment-executor ( var val-eproc env -- ok ) + 2swap 2over ( var env val-eproc env ) + evaluate-eproc 2swap ( var val env ) + set-var + ok-symbol +; + +: analyze-assignment ( exp -- eproc ) + 2dup assignment-var + 2swap assignment-val analyze ( var val-eproc ) + + ['] assignment-executor primitive-proc-type + nil cons cons cons +; + +: if-executor ( cproc aproc pproc env -- res ) + 2swap 2over ( cproc aproc env pproc env -- res ) + evaluate-eproc + + true? if + 2swap 2drop + else + 2rot 2drop + then + + evaluate-eproc +; + +: analyze-if ( exp -- eproc ) + 2dup if-predicate analyze + 2swap 2dup if-consequent analyze + 2swap if-alternative analyze + + ['] if-executor primitive-proc-type + 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 +; - compound-proc-type of +: 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 ( body argvals proc argnames ) - -2rot procedure-env ( body argnames argvals procenv ) + -2rot 2dup procedure-params ( bproc argvals proc argnames ) + -2rot procedure-env ( bproc argnames argvals procenv ) -2rot 2swap flatten-proc-args 2swap 2rot - extend-env ( body env ) - - eval-sequence + extend-env ( bproc env ) - R> drop ['] eval goto-deferred \ Tail call optimization - endof + ['] evaluate-eproc goto + endof - except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw - endcase + except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw + endcase ; -:noname ( obj env -- result ) - 2swap +: analyze-application ( exp -- eproc ) + 2dup operator analyze + 2swap operands operand-eproc-list - \ --- DEBUG --- - ( - fg yellow ." Evaluating: " bold 2dup print reset-term - space fg green ." PS: " bold depth . reset-term - space fg blue ." RS: " bold RSP@ RSP0 - . reset-term cr - ) + ['] application-executor primitive-proc-type + nil cons cons cons +; + +:noname ( exp --- eproc ) self-evaluating? if - 2swap 2drop + analyze-self-evaluating exit then quote? if - quote-body - 2swap 2drop - exit - then - - quasiquote? if - 2swap eval-quasiquote + analyze-quoted exit then - + variable? if - 2swap lookup-var + analyze-variable exit then definition? if - 2swap eval-definition + analyze-definition exit then - assignment? if - 2swap eval-assignment - exit - then +\ macro-definition? if +\ analyze-macro-definition +\ exit +\ then - macro-definition? if - 2swap eval-define-macro + assignment? if + analyze-assignment exit then if? if - 2over 2over - if-predicate - 2swap eval - - true? if - if-consequent - else - if-alternative - then - - 2swap - ['] eval goto-deferred + analyze-if + exit then lambda? if - 2dup lambda-parameters - 2swap lambda-body - 2rot make-procedure + analyze-lambda exit then application? if - - 2over 2over ( env exp env exp ) - operator ( env exp env opname ) - - 2swap eval ( env exp proc ) - - -2rot ( proc env exp ) - operands 2swap ( proc operands env ) - list-of-vals ( proc argvals ) - - apply + analyze-application exit then - except-message: ." tried to evaluate object with unknown type." recoverable-exception throw -; is eval + + except-message: ." tried to analyze unknown expression type." recoverable-exception throw + +; is analyze -\ }}} \ ---- Macro Expansion ---- {{{ @@ -1760,33 +1832,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 @@ -1856,8 +1901,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 @@ -1874,6 +1917,10 @@ hide env \ }}} +:noname ( exp env -- res ) + 2swap expand analyze 2swap evaluate-eproc +; is eval + \ ---- Print ---- {{{ : printfixnum ( fixnum -- ) drop 0 .R ; @@ -2098,8 +2145,6 @@ variable gc-stack-depth 2swap 2drop ( port obj ) - expand - global-env obj@ eval ( port res ) again ; @@ -2110,7 +2155,7 @@ variable gc-stack-depth include scheme-primitives.4th - s" scheme-library.scm" load 2drop + \ s" scheme-library.scm" load 2drop \ }}} @@ -2128,8 +2173,6 @@ variable gc-stack-depth true exit then - expand - global-env obj@ eval fg cyan ." ; " print reset-term @@ -2143,7 +2186,7 @@ variable gc-stack-depth enable-gc \ Display welcome message - welcome-symbol nil cons global-env obj@ eval 2drop + \ welcome-symbol nil cons global-env obj@ eval 2drop begin ['] repl-body catch