From: Tim Vaughan Date: Mon, 1 May 2017 06:19:24 +0000 (+1200) Subject: Improving error reporting. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=5eea24f47ad60b69af59a76c7285ec232c29009c;p=scheme.forth.jl.git Improving error reporting. --- diff --git a/src/scheme.4th b/src/scheme.4th index 2ce481c..6e2c492 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -51,27 +51,15 @@ 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 ; \ }}} @@ -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 ; @@ -1327,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 @@ -1390,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 ) @@ -1606,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 @@ -1623,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 @@ -1658,7 +1652,7 @@ hide env R> drop ['] eval goto-deferred \ Tail call optimization endof - recoverable-exception throw" Object not applicable." + except-message: ." object not applicable." recoverable-exception throw endcase ; @@ -1781,7 +1775,7 @@ hide env then 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 \ }}} @@ -1880,7 +1874,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 \ }}}