X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme.4th;h=bb65be27e77a60d5f537157c1c45ef426e39f401;hb=ace5f5fbaf83906bb9f2b8293a6a366757eac615;hp=669665a2e80c7a0667a4ad3ec86a8f91774ac24d;hpb=0dadd5f58d2c204c7f621ccd3c42f75a3fd790a8;p=scheme.forth.jl.git diff --git a/src/scheme.4th b/src/scheme.4th index 669665a..bb65be2 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 ; @@ -471,24 +459,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 +530,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 +544,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 +624,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 +638,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 +1321,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 +1384,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 ) @@ -1600,7 +1600,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 +1617,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,7 +1652,7 @@ 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 ; @@ -1673,6 +1673,13 @@ hide env :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,33 +1749,17 @@ hide env 2over 2over ( env exp env exp ) operator ( env exp env opname ) - 2dup lookup-macro nil? false = if - \ Macro function evaluation - - ( env exp env opname mproc ) - 2swap 2drop -2rot 2drop cdr ( env mproc body ) - - macro-expand - - 2swap - ['] eval goto-deferred - else - \ Regular function application - - 2drop ( env exp env opname ) - - 2swap eval ( env exp proc ) + 2swap eval ( env exp proc ) - -2rot ( proc env exp ) - operands 2swap ( proc operands env ) - list-of-vals ( proc argvals ) + -2rot ( proc env exp ) + operands 2swap ( proc operands env ) + list-of-vals ( proc argvals ) - apply - exit - then + apply + exit then - recoverable-exception throw" Tried to evaluate object with unknown type." + except-message: ." tried to evaluate object with unknown type." recoverable-exception throw ; is eval \ }}} @@ -1867,7 +1858,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 \ }}} @@ -1955,7 +1946,7 @@ variable gc-stack-depth ; :noname - ." GC! " + \ ." GC! " gc-unmark @@ -2007,7 +1998,7 @@ variable gc-stack-depth include scheme-primitives.4th - s" scheme-library.scm" load 2drop +\ s" scheme-library.scm" load 2drop \ }}} @@ -2033,13 +2024,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