X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme.4th;h=e5ac9cd9297bb6b2a4908bdefbf47ad09b8c87b1;hb=632cf90c6a97b1ee01a13ab424051f0a99c4a150;hp=16939d3d3d685b1f8e550a02d2a6bdbb196fe2d6;hpb=3055ae2e3d57ec91a4187a6c5cf8f05357d60810;p=scheme.forth.jl.git diff --git a/src/scheme.4th b/src/scheme.4th index 16939d3..e5ac9cd 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 @@ -10,6 +11,8 @@ include float.4th include debugging.4th defer read +defer expand +defer analyze defer eval defer print @@ -36,7 +39,7 @@ make-type pair-type make-type symbol-type make-type primitive-proc-type make-type compound-proc-type -make-type fileport-type +make-type port-type : istype? ( obj type -- obj bool ) over = ; @@ -51,33 +54,21 @@ variable nextexception 1 nextexception +! does> @ ; -make-exception recoverable-exception -make-exception unrecoverable-exception - -: display-exception-msg ( addr count -- ) +: except-message: bold fg red ." Exception: " - type - reset-term ; - -: throw" immediate - [compile] s" - - ['] rot , ['] dup , +; - [compile] if - ['] -rot , - ['] display-exception-msg , - [compile] then +make-exception recoverable-exception +make-exception unrecoverable-exception - ['] throw , -; +: throw reset-term throw ; \ }}} \ ---- List-structured memory ---- {{{ -10000 constant scheme-memsize +20000 constant scheme-memsize create car-cells scheme-memsize allot create car-type-cells scheme-memsize allot @@ -103,7 +94,7 @@ variable nextfree then nextfree @ scheme-memsize >= if - unrecoverable-exception throw s" Out of memory!" + except-message: ." Out of memory!" unrecoverable-exception throw then ; @@ -173,36 +164,9 @@ variable nextfree R> R> ; -\ }}} - -\ ---- Port I/O ---- {{{ - -: fileport>fid ( fileport -- fid ) - drop ; - -: fid>fileport ( fid -- fileport ) - fileport-type ; - -: open-input-file ( addr n -- fileport ) - r/o open-file drop fid>fileport -; - -: close-port ( fileport -- ) - fileport>fid close-file drop -; - -objvar console-i/o-port -0 fileport-type console-i/o-port obj! - -objvar current-input-port -console-i/o-port obj@ current-input-port obj! - -: read-port ( fileport -- obj ) - current-input-port obj! - read ; - -: read-console ( -- obj ) - console-i/o-port obj@ read-port ; +: 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 ; \ }}} @@ -304,7 +268,126 @@ create-symbol ok ok-symbol create-symbol if if-symbol create-symbol lambda lambda-symbol create-symbol λ λ-symbol -create-symbol begin begin-symbol +create-symbol eof eof-symbol +create-symbol no-match no-match-symbol + +\ Symbol to be bound to welcome message procedure by library +create-symbol welcome welcome-symbol + +\ }}} + +\ ---- Port I/O ---- {{{ + +( Ports are pairs with the fid in the car and the peek buffer in the cdr. ) + +: fileport>fid ( fileport -- fid ) + drop pair-type car drop ; + +: get-last-peek ( fileport -- char/nil ) + drop pair-type cdr ; + +: set-last-peek ( char/nil fileport -- ) + drop pair-type set-cdr! +; + +: fid>fileport ( fid -- fileport ) + fixnum-type nil cons drop port-type ; + +: open-input-file ( addr n -- fileport ) + r/o open-file drop fid>fileport +; + +: close-port ( fileport -- ) + fileport>fid close-file drop +; + +objvar console-i/o-port +0 fixnum-type nil cons drop port-type console-i/o-port obj! + +objvar current-input-port +console-i/o-port obj@ current-input-port obj! + +: read-char ( port -- char ) + 2dup get-last-peek nil? if + 2drop + 2dup console-i/o-port obj@ objeq? if + 2drop + key character-type + else + fileport>fid pad 1 rot read-file 0= if + eof-symbol + else + pad @ character-type + then + then + else + nil 2rot set-cdr! + then +; + +: peek-char ( port -- char ) + 2dup get-last-peek nil? if + 2drop 2dup read-char + 2dup 2rot set-last-peek + else + 2swap 2drop + then +; + +variable read-line-buffer-span +variable read-line-buffer-offset + +( Hack to save original read-line while we transition to new one. ) +: orig-read-line immediate + ['] read-line , ; + +: read-line ( port -- string ) + + 2dup get-last-peek + nil? if + 2drop + 0 read-line-buffer-offset ! + else + 2over nil 2swap set-last-peek + 2dup drop '\n' = if + 2drop nil nil cons exit + else + drop pad ! + 1 read-line-buffer-offset ! + then + then + + 2dup console-i/o-port obj@ objeq? if + 2drop + pad read-line-buffer-offset @ + 200 expect cr + span @ read-line-buffer-offset @ + read-line-buffer-span ! + else + pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line + drop swap read-line-buffer-offset @ + read-line-buffer-span ! + then + + nil + + begin + read-line-buffer-span @ 0> + while + pad read-line-buffer-span @ 1- + @ character-type 2swap cons + -1 read-line-buffer-span +! + repeat + + nil? if + nil cons drop string-type + else + drop string-type + then +; + +: read-port ( fileport -- obj ) + current-input-port obj! + read ; + +: read-console ( -- obj ) + console-i/o-port obj@ read-port ; \ }}} @@ -383,24 +466,30 @@ objvar vals hide vars hide vals +objvar var + : lookup-var ( var env -- val ) + 2over var obj! get-vars-vals if 2swap 2drop car else - recoverable-exception throw" Tried to read unbound variable." + except-message: ." tried to read unbound variable '" var obj@ print ." '." recoverable-exception throw then ; : set-var ( var val env -- ) >R >R 2swap R> R> ( val var env ) + 2over var obj! get-vars-vals if 2swap 2drop ( val vals ) set-car! else - recoverable-exception throw" Tried to set unbound variable." + except-message: ." tried to set unbound variable '" var obj@ print ." '." recoverable-exception throw then ; +hide var + objvar env : define-var ( var val env -- ) @@ -448,11 +537,11 @@ global-env obj! : ensure-arg-count ( args n -- ) dup 0= if drop nil objeq? false = if - recoverable-exception throw" Too many arguments for primitive procedure." + except-message: ." Too many arguments for primitive procedure." recoverable-exception throw then else -rot nil? if - recoverable-exception throw" Too few arguments for primitive procedure." + except-message: ." Too few arguments for primitive procedure." recoverable-exception throw then cdr rot 1- recurse @@ -462,17 +551,17 @@ global-env obj! : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- ) dup 0= if drop nil objeq? false = if - recoverable-exception throw" Too many arguments for primitive procedure." + except-message: ." Too many arguments for primitive procedure." recoverable-exception throw then else -rot nil? if - recoverable-exception throw" Too few arguments for primitive procedure." + except-message: ." Too few arguments for primitive procedure." recoverable-exception throw then 2dup cdr 2swap car ( ... t1 n args' arg1 ) 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 ) istype? false = if - recoverable-exception throw" Incorrect type for primitive procedure." + except-message: ." Incorrect type for primitive procedure." recoverable-exception throw then 2drop recurse @@ -542,7 +631,7 @@ global-env obj! : ensure-arg-type ( arg type -- arg ) istype? false = if - recoverable-exception throw" Incorrect argument type for primitive procedure." + except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw then ; @@ -556,6 +645,12 @@ objvar macro-table ( Look up macro in macro table. Returns nil if no macro is found. ) : lookup-macro ( name_symbol -- proc ) + + symbol-type istype? invert if + \ Early exit if argument is not a symbol + 2drop nil exit + then + macro-table obj@ begin @@ -645,7 +740,7 @@ parse-idx-stack parse-idx-sp ! parse-str 160 expect cr span @ parse-str-span ! else - parse-str 160 current-input-port obj@ fileport>fid read-line + parse-str 160 current-input-port obj@ fileport>fid orig-read-line drop swap parse-str-span ! parse-str-span @ 0= and if append-eof then @@ -989,35 +1084,51 @@ parse-idx-stack parse-idx-sp ! ; : readstring ( -- charlist ) - nextchar [char] " = if - inc-parse-idx - delim? false = if - bold fg red - ." No delimiter following right double quote. Aborting." cr - reset-term abort + nil nil + + begin + nextchar [char] " <> + while + nextchar [char] \ = if + inc-parse-idx + nextchar case + [char] n of '\n' endof + [char] " of [char] " endof + [char] \ + endcase + else + nextchar then + inc-parse-idx character-type + nil cons - dec-parse-idx + ( firstchar prevchar thischar ) - 0 nil-type exit - then + 2swap nil? if + 2drop 2swap 2drop 2dup ( thischar thischar ) + else + ( firstchar thischar prevchar ) + 2over 2swap set-cdr! ( firstchar thischar ) + then + repeat - nextchar [char] \ = if - inc-parse-idx - nextchar case - [char] n of '\n' endof - [char] " of [char] " endof - [char] \ - endcase - else - nextchar + \ Discard previous character + 2drop + + inc-parse-idx + delim? false = if + bold fg red + ." No delimiter following right double quote. Aborting." cr + reset-term abort then - inc-parse-idx character-type - recurse + dec-parse-idx - cons + nil? if + nil cons + then + drop string-type ; : readsymbol ( -- charlist ) @@ -1106,7 +1217,6 @@ parse-idx-stack parse-idx-sp ! inc-parse-idx readstring - drop string-type nextchar [char] " <> if bold red ." Missing closing double-quote." reset-term cr @@ -1205,129 +1315,27 @@ 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 - recoverable-exception throw" no arguments to unquote." - then - - 2dup cdr - nil? false = if - recoverable-exception throw" too many arguments to unquote." - 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 - recoverable-exception throw" no arguments to quasiquote." - then - - 2dup cdr ( env args args-cdr ) - nil? false = if - recoverable-exception throw" too many arguments to quasiquote." - then - - 2drop car ( env arg ) - - eval-quasiquote-item -; - : variable? ( obj -- obj bool ) symbol-type istype? ; : definition? ( obj -- obj bool ) define-symbol tagged-list? ; -: make-lambda ( params body -- lambda-exp ) - lambda-symbol -2rot cons cons ; - -( Handles iterative expansion of defines in - terms of nested lambdas. Most Schemes only - handle one iteration of expansion! ) -: definition-var-val ( obj -- var val ) - - cdr 2dup cdr 2swap car ( val var ) - - begin - symbol-type istype? false = - while - 2dup cdr 2swap car ( val formals var' ) - -2rot 2swap ( var' formals val ) - make-lambda nil cons ( var' val' ) - 2swap ( val' var' ) - repeat +: definition-var ( obj -- var ) + cdr car ; - 2swap car -; +: definition-val ( obj -- val ) + cdr cdr car ; : eval-definition ( obj env -- res ) - 2dup 2rot ( env env obj ) - definition-var-val ( env env var val ) - 2rot eval ( env var val ) + 2swap + 2over 2over + definition-val 2swap + eval - 2rot ( var val env ) + 2swap definition-var 2swap + + 2rot define-var ok-symbol @@ -1421,12 +1429,6 @@ hide env : lambda-body ( obj -- body ) cdr cdr ; -: begin? ( obj -- obj bool ) - begin-symbol tagged-list? ; - -: begin-actions ( obj -- actions ) - cdr ; - : eval-sequence ( explist env -- finalexp env ) ( Evaluates all bar the final expressions in an an expression list. The final expression @@ -1497,7 +1499,7 @@ hide env : flatten-proc-args ( argvals argnames -- argvals' argnames' ) nil? if 2over nil? false = if - recoverable-exception throw" Too many arguments for compound procedure." + except-message: ." Too many arguments for compound procedure." recoverable-exception throw else 2drop then @@ -1514,7 +1516,7 @@ hide env 2over nil? if - recoverable-exception throw" Too few arguments for compound procedure." + except-message: ." Too few arguments for compound procedure." recoverable-exception throw else cdr then @@ -1549,27 +1551,20 @@ hide env R> drop ['] eval goto-deferred \ Tail call optimization endof - recoverable-exception throw" Object not applicable." + except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw endcase ; -( Simply evaluates the given procedure with expbody as its argument. ) -: macro-expand ( proc expbody -- result ) - 2swap - 2dup procedure-body ( expbody proc procbody ) - -2rot 2dup procedure-params ( procbody expbody proc argnames ) - -2rot procedure-env ( procbody argnames expbody procenv ) - - -2rot 2swap - flatten-proc-args - 2swap 2rot - - extend-env eval-sequence eval -; - :noname ( obj env -- result ) 2swap + \ --- 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 + ) + self-evaluating? if 2swap 2drop exit @@ -1581,11 +1576,6 @@ hide env exit then - quasiquote? if - 2swap eval-quasiquote - exit - then - variable? if 2swap lookup-var exit @@ -1628,45 +1618,406 @@ hide env exit then - begin? if - begin-actions 2swap - eval-sequence - ['] eval goto-deferred - then - application? if 2over 2over ( env exp env exp ) operator ( env exp env opname ) - 2dup lookup-macro nil? false = if - \ Macro function evaluation + 2swap eval ( env exp proc ) - ( env exp env opname mproc ) - 2swap 2drop -2rot 2drop cdr ( env mproc body ) + -2rot ( proc env exp ) + operands 2swap ( proc operands env ) + list-of-vals ( proc argvals ) - macro-expand + apply + exit + then - 2swap - ['] eval goto-deferred - else - \ Regular function application + except-message: ." tried to evaluate object with unknown type." recoverable-exception throw +; is eval - 2drop ( env exp env opname ) +\ }}} - 2swap eval ( env exp proc ) +\ ---- Analyze ---- - -2rot ( proc env exp ) - operands 2swap ( proc operands env ) - list-of-vals ( proc argvals ) +: evaluate-eproc ( eproc env --- res ) - apply - exit - then + >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 + + .s cr \ DEBUG + + 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 - recoverable-exception throw" Tried to evaluate object with unknown type." -; is eval + 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 +; + +: 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 + analyze-self-evaluating + exit + then + + quote? if + analyze-quoted + exit + then + + variable? if + analyze-variable + exit + then + + definition? if + analyze-definition + exit + then + + assignment? if + analyze-assignment + exit + then + + if? if + analyze-if + 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 + + +\ ---- Macro Expansion ---- {{{ + +( Simply evaluates the given procedure with expbody as its argument. ) +: macro-eval ( proc expbody -- result ) + 2swap + 2dup procedure-body ( expbody proc procbody ) + -2rot 2dup procedure-params ( procbody expbody proc argnames ) + -2rot procedure-env ( procbody argnames expbody procenv ) + + -2rot 2swap + flatten-proc-args + 2swap 2rot + + extend-env eval-sequence eval +; + +: expand-macro ( exp -- result ) + pair-type istype? invert if exit then + 2dup car symbol-type istype? invert if 2drop exit then + + lookup-macro nil? if + 2drop exit then + + 2over cdr macro-eval + + 2dup no-match-symbol objeq? if + 2drop exit + else + 2swap 2drop + then + + R> drop ['] expand goto-deferred +; + +: expand-definition ( exp -- result ) + define-symbol 2swap + + 2dup definition-var + 2swap definition-val expand + nil ( define var val' nil ) + + cons cons cons ; + +: expand-assignment ( exp -- result ) + set!-symbol 2swap + + 2dup assignment-var + 2swap assignment-val expand + nil ( define var val' nil ) + + cons cons cons ; + +: expand-list ( exp -- res ) + nil? if exit then + + 2dup car expand + 2swap cdr recurse + + cons ; + +: macro-definition-nameparams + cdr car ; + +: expand-define-macro ( exp -- res ) + define-macro-symbol 2swap + 2dup macro-definition-nameparams + 2swap macro-definition-body expand-list + + cons cons ; + +: expand-lambda ( exp -- res ) + lambda-symbol 2swap + 2dup lambda-parameters + 2swap lambda-body expand-list + + cons cons ; + +: expand-if ( exp -- res ) + if-symbol 2swap + + 2dup if-predicate expand + 2swap 2dup if-consequent expand + 2swap if-alternative none? if + 2drop nil + else + expand nil cons + then + + cons cons cons ; + +: expand-application ( exp -- res ) + 2dup operator expand + 2swap operands expand-list + + cons ; + +:noname ( exp -- result ) + expand-macro + + self-evaluating? if exit then + + quote? if exit then + + definition? if expand-definition exit then + + assignment? if expand-assignment exit then + + macro-definition? if expand-define-macro exit then + + lambda? if expand-lambda exit then + + if? if expand-if exit then + + application? if expand-application exit then + +; is expand \ }}} @@ -1762,8 +2113,9 @@ hide env primitive-proc-type istype? if printprim exit then compound-proc-type istype? if printcomp exit then none-type istype? if printnone exit then + port-type istype? if printport exit then - recoverable-exception throw" Tried to print object with unknown type." + except-message: ." tried to print object with unknown type." recoverable-exception throw ; is print \ }}} @@ -1790,6 +2142,7 @@ variable gc-stack-depth string-type istype? if true exit then symbol-type istype? if true exit then compound-proc-type istype? if true exit then + port-type istype? if true exit then false ; @@ -1856,6 +2209,7 @@ variable gc-stack-depth symbol-table obj@ gc-mark-obj macro-table obj@ gc-mark-obj + console-i/o-port obj@ gc-mark-obj global-env obj@ gc-mark-obj depth gc-stack-depth @ do @@ -1874,24 +2228,6 @@ variable gc-stack-depth \ ---- Loading files ---- {{{ -: charlist>cstr ( charlist addr -- n ) - - dup 2swap ( origaddr addr charlist ) - - begin - nil? false = - while - 2dup cdr 2swap car - drop ( origaddr addr charlist char ) - -rot 2swap ( origaddr charlist addr char ) - over ! - 1+ -rot ( origaddr nextaddr charlist ) - repeat - - 2drop ( origaddr finaladdr ) - swap - -; - : load ( addr n -- finalResult ) open-input-file @@ -1909,6 +2245,8 @@ variable gc-stack-depth 2swap 2drop ( port obj ) + expand + global-env obj@ eval ( port res ) again ; @@ -1919,7 +2257,7 @@ variable gc-stack-depth include scheme-primitives.4th - s" scheme-library.scm" load 2drop + \ s" scheme-library.scm" load 2drop \ }}} @@ -1937,6 +2275,8 @@ variable gc-stack-depth true exit then + expand + global-env obj@ eval fg cyan ." ; " print reset-term @@ -1945,13 +2285,13 @@ variable gc-stack-depth ; : repl - cr ." Welcome to scheme.forth.jl!" cr - ." Use Ctrl-D to exit." cr - empty-parse-str enable-gc + \ Display welcome message + \ welcome-symbol nil cons global-env obj@ eval 2drop + begin ['] repl-body catch case