X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme.4th;h=8d361fc0fa73f36b091dd8cbd8ec9be7d09962de;hb=3f10b9976a9b02716a433666d972e30c6b81fd92;hp=5ee0dbd16a6549f8f1c588b272951ea0425a2671;hpb=2899e37fdb0ecf89bb949cfcc0a9db2cac54677f;p=scheme.forth.jl.git diff --git a/src/scheme.4th b/src/scheme.4th index 5ee0dbd..8d361fc 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -51,33 +51,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 +91,7 @@ variable nextfree then nextfree @ scheme-memsize >= if - unrecoverable-exception throw s" Out of memory!" + except-message: ." Out of memory!" unrecoverable-exception throw then ; @@ -275,6 +263,7 @@ 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 @@ -471,24 +460,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 -- ) @@ -536,11 +531,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 @@ -550,17 +545,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 @@ -630,7 +625,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 ; @@ -644,6 +639,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 @@ -1321,12 +1322,12 @@ parse-idx-stack parse-idx-sp ! cdr ( env args ) nil? if - recoverable-exception throw" no arguments to unquote." + except-message: ." no arguments to unquote." recoverable-exception throw then 2dup cdr nil? false = if - recoverable-exception throw" too many arguments to unquote." + except-message: ." too many arguments to unquote." recoverable-exception throw then 2drop car 2swap eval @@ -1384,12 +1385,12 @@ defer eval-quasiquote-item 2swap cdr ( env args ) nil? if - recoverable-exception throw" no arguments to quasiquote." + except-message: ." no arguments to quasiquote." recoverable-exception throw then 2dup cdr ( env args args-cdr ) nil? false = if - recoverable-exception throw" too many arguments to quasiquote." + except-message: ." too many arguments to quasiquote." recoverable-exception throw then 2drop car ( env arg ) @@ -1403,34 +1404,21 @@ defer eval-quasiquote-item : 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 @@ -1600,7 +1588,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 @@ -1617,7 +1605,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 @@ -1652,27 +1640,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 @@ -1742,34 +1723,87 @@ hide env 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 ) + + -2rot ( proc env exp ) + operands 2swap ( proc operands env ) + list-of-vals ( proc argvals ) - ( env exp env opname mproc ) - 2swap 2drop -2rot 2drop cdr ( env mproc body ) + apply + exit + then - macro-expand + except-message: ." tried to evaluate object with unknown type." recoverable-exception throw +; is eval - 2swap - ['] eval goto-deferred - else - \ Regular function application +\ }}} - 2drop ( env exp env opname ) +\ ---- Macro Expansion ---- {{{ - 2swap eval ( env exp proc ) +( 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 +; - -2rot ( proc env exp ) - operands 2swap ( proc operands env ) - list-of-vals ( proc argvals ) +defer expand - apply - exit - then +: expand-quasiquote ; +: expand-definition ; +: expand-assignment ; +: expand-define-macro ; +: expand-if ; +: expand-lambda ; +: expand-begin ; +: expand-application ; + +: 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 - recoverable-exception throw" Tried to evaluate object with unknown type." -; is eval + R> drop ['] expand goto-deferred +; + +:noname ( exp -- result ) + + expand-macro + + quasiquote? if expand-quasiquote exit then + + definition? if expand-definition exit then + + assignment? if expand-assignment exit then + + macro-definition? if expand-define-macro exit then + + if? if expand-if exit then + + lambda? if expand-lambda exit then + + begin? if expand-begin exit then + + application? if expand-application exit then + +; is expand \ }}} @@ -1867,7 +1901,7 @@ hide env 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 \ }}} @@ -1894,6 +1928,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 ; @@ -1996,6 +2031,8 @@ variable gc-stack-depth 2swap 2drop ( port obj ) + expand + global-env obj@ eval ( port res ) again ; @@ -2006,7 +2043,9 @@ variable gc-stack-depth include scheme-primitives.4th - s" scheme-library.scm" load 2drop + s" scheme-derived-forms.scm" load 2drop + +\ s" scheme-library.scm" load 2drop \ }}} @@ -2024,6 +2063,8 @@ variable gc-stack-depth true exit then + expand + global-env obj@ eval fg cyan ." ; " print reset-term @@ -2032,13 +2073,12 @@ variable gc-stack-depth ; : repl - empty-parse-str 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