From c90c1d66dad8b15b1f68e315b1a99b0596c948cf Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 24 May 2006 08:29:25 +0000 Subject: [PATCH] CL-style (but more limited) restarts, better undefined word handling in the parser --- TODO.FACTOR.txt | 1 - library/bootstrap/boot-stage1.factor | 13 ++--- library/errors.factor | 23 ++++++++- library/math/parse-numbers.factor | 20 ++++---- library/syntax/early-parser.factor | 48 ++++++++++++++++++ library/syntax/early-parser.facts | 75 ++++++++++++++++++++++++++++ library/syntax/parse-stream.factor | 3 +- library/syntax/parser.factor | 72 ++++++++------------------ library/syntax/parser.facts | 74 --------------------------- library/test/parse-number.factor | 60 +++++++++++----------- library/tools/debugger.factor | 24 +++++++-- library/tools/listener.factor | 6 ++- native/error.c | 6 +-- native/error.h | 42 ++++++++-------- native/float.c | 5 +- 15 files changed, 265 insertions(+), 207 deletions(-) create mode 100644 library/syntax/early-parser.factor create mode 100644 library/syntax/early-parser.facts diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 46b3f2cbd5..99bfe0237d 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -57,7 +57,6 @@ - focus is not top-level window aware - display lists - saving the image should save window configuration -- fix up the min thumb size hack - variable width word wrap - new gesture style diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index a3ce1efe68..3586848cd3 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -11,9 +11,8 @@ vectors words ; : parse-resource* ( path -- ) [ parse-resource ] catch [ - dup error. - "Try again? [yn]" print flush readln "yY" subseq? - [ drop parse-resource* ] [ rethrow ] if + { { "Parse file again" t } } condition drop + parse-resource* ] when* ; : if-arch ( arch seq -- ) @@ -80,7 +79,7 @@ vectors words ; "/library/io/files.factor" "/library/io/binary.factor" - "/library/syntax/parser.factor" + "/library/syntax/early-parser.factor" "/library/generic/generic.factor" "/library/generic/standard-combination.factor" @@ -92,6 +91,7 @@ vectors words ; "/library/syntax/prettyprint.factor" "/library/syntax/see.factor" + "/library/syntax/parser.factor" "/library/tools/interpreter.factor" @@ -104,9 +104,9 @@ vectors words ; "/library/tools/describe.factor" "/library/tools/debugger.factor" - - "/library/syntax/parse-stream.factor" + "/library/syntax/parse-stream.factor" + "/library/tools/memory.factor" "/library/tools/listener.factor" "/library/tools/walker.factor" @@ -260,6 +260,7 @@ vectors words ; "/library/math/ratio.facts" "/library/math/trig-hyp.facts" "/library/math/vectors.facts" + "/library/syntax/early-parser.facts" "/library/syntax/parse-stream.facts" "/library/syntax/parser.facts" "/library/syntax/parse-syntax.facts" diff --git a/library/errors.factor b/library/errors.factor index 27ff485d97..8632753c13 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: kernel-internals -USING: sequences ; +USING: generic sequences ; : >c ( continuation -- ) catchstack* push ; : c> ( -- continuation ) catchstack* pop ; @@ -24,4 +24,25 @@ USING: kernel ; [ >c drop call c> drop ] [ drop (continue-with) rot drop swap call ] ifcc ; inline +TUPLE: condition restarts cc ; + +C: condition ( error restarts cc -- condition ) + [ set-condition-cc ] keep + [ set-condition-restarts ] keep + [ set-delegate ] keep ; + +: condition ( error restarts -- value ) + [ throw ] callcc1 2nip ; + +GENERIC: compute-restarts + +M: object compute-restarts drop { } ; + +M: tuple compute-restarts delegate compute-restarts ; + +M: condition compute-restarts + [ delegate compute-restarts ] keep + [ condition-cc ] keep + condition-restarts [ swap add ] map-with append ; + GENERIC: error. ( error -- ) diff --git a/library/math/parse-numbers.factor b/library/math/parse-numbers.factor index 870d9b86bd..1a90d2270b 100644 --- a/library/math/parse-numbers.factor +++ b/library/math/parse-numbers.factor @@ -1,34 +1,34 @@ -! Copyright (C) 2004, 2005 Slava Pestov. +! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: math USING: errors generic kernel math-internals namespaces sequences strings ; -: not-a-number "Not a number" throw ; - DEFER: base> : string>ratio ( "a/b" radix -- a/b ) - >r "/" split1 r> tuck base> >r base> r> / ; + >r "/" split1 r> tuck base> >r base> r> + 2dup and [ / ] [ 2drop f ] if ; GENERIC: digit> ( ch -- n ) M: digit digit> CHAR: 0 - ; M: letter digit> CHAR: a - 10 + ; M: LETTER digit> CHAR: A - 10 + ; -M: object digit> not-a-number ; +M: object digit> drop f ; : digit+ ( num digit base -- num ) - 2dup < [ rot * + ] [ not-a-number ] if ; + pick pick and + [ 2dup < [ rot * + ] [ 3drop f ] if ] [ 3drop f ] if ; -: (string>integer) ( base str -- num ) +: (string>integer) ( radix str -- num ) dup empty? [ - not-a-number + 2drop f ] [ 0 [ digit> pick digit+ ] reduce nip ] if ; -: string>integer ( string -- n ) - swap "-" ?head >r (string>integer) r> [ neg ] when ; +: string>integer ( string radix -- n ) + swap "-" ?head >r (string>integer) dup r> and [ neg ] when ; : base> ( string radix -- n ) { diff --git a/library/syntax/early-parser.factor b/library/syntax/early-parser.factor new file mode 100644 index 0000000000..8f6a174bf9 --- /dev/null +++ b/library/syntax/early-parser.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2005, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: parser +USING: arrays errors generic hashtables kernel math namespaces +sequences strings vectors words ; + +SYMBOL: use +SYMBOL: in + +SYMBOL: file +SYMBOL: line-number + +SYMBOL: line-text +SYMBOL: column + +: check-vocab ( name -- vocab ) + dup vocab + [ ] [ " is not a vocabulary name" append throw ] ?if ; + +: use+ ( string -- ) check-vocab use get push ; + +: add-use ( seq -- ) [ use+ ] each ; + +: set-use ( seq -- ) [ check-vocab ] map >vector use set ; + +: set-in ( name -- ) dup ensure-vocab dup in set use+ ; + +: parsing? ( word -- ? ) + dup word? [ "parsing" word-prop ] [ drop f ] if ; + +: save-location ( word -- ) + dup set-word + dup line-number get "line" set-word-prop + file get "file" set-word-prop ; + +: create-in in get create dup save-location ; + +: create-constructor ( class -- word ) + word-name in get constructor-word dup save-location ; + +TUPLE: parse-error file line col text ; + +C: parse-error ( error -- error ) + file get over set-parse-error-file + line-number get over set-parse-error-line + column get over set-parse-error-col + line-text get over set-parse-error-text + [ set-delegate ] keep ; diff --git a/library/syntax/early-parser.facts b/library/syntax/early-parser.facts new file mode 100644 index 0000000000..2768869181 --- /dev/null +++ b/library/syntax/early-parser.facts @@ -0,0 +1,75 @@ +USING: help kernel parser sequences ; + +IN: help : $parsing-note + drop "This word should only be called from parsing words." $notes ; + +HELP: use f +{ $description "A variable holding the current vocabulary search path as a sequence of hashtables." } +{ $see-also in use+ set-use POSTPONE: USING: POSTPONE: USE: } ; + +HELP: in f +{ $description "A variable holding the current vocabulary for new definitions." } +{ $see-also use set-in POSTPONE: IN: } ; + +HELP: check-vocab "( name -- vocab )" +{ $values { "name" "a string" } { "vocab" "a hashtable" } } +{ $description "Outputs a named vocabulary." } +{ $errors "Throws an error if the vocabulary does not exist." } ; + +HELP: use+ "( vocab -- )" +{ $values { "vocab" "a string" } } +{ $description "Adds a new vocabulary at the front of the search path. Subsequent word lookups by the parser will search this vocabulary first." } +$parsing-note +{ $errors "Throws an error if the vocabulary does not exist." } +{ $see-also in use add-use set-use POSTPONE: USE: } ; + +HELP: set-use "( seq -- )" +{ $values { "seq" "a sequence of strings" } } +{ $description "Sets the vocabulary search path. Later vocabularies take precedence." } +{ $errors "Throws an error if one of the vocabularies does not exist." } +$parsing-note +{ $see-also in use use+ add-use file-vocabs } ; + +HELP: add-use "( seq -- )" +{ $values { "seq" "a sequence of strings" } } +{ $description "Adds multiple vocabularies to the search path, with later vocabularies taking precedence." } +{ $errors "Throws an error if one of the vocabularies does not exist." } +$parsing-note +{ $see-also in use use+ set-use POSTPONE: USING: } ; + +HELP: set-in "( name -- )" +{ $values { "name" "a string" } } +{ $description "Sets the current vocabulary where new words will be defined, creating the vocabulary first if it does not exist." } +$parsing-note +{ $see-also in use POSTPONE: IN: } ; + +HELP: parsing? "( obj -- ? )" +{ $values { "obj" "an object" } { "?" "a boolean" } } +{ $description "Tests if an object is a parsing word." } +{ $notes "Outputs " { $link f } " if the object is not a word." } ; + +HELP: file f +{ $description "Variable stores the file name being parsed. This is the input parameter to " { $link parse-stream } "." } ; + +HELP: line-number f +{ $description "Variable holds the line number being parsed." } ; + +HELP: line-text f +{ $description "Variable holds the text of the line being parsed." } ; + +HELP: column f +{ $description "Variable holds the column number being parsed." } ; + +HELP: save-location "( word -- )" +{ $values { "word" "a word" } } +{ $description "Sets the " { $snippet "\"file\"" } " and " { $snippet "\"line\"" } " word properties to the current parser location." } +$parsing-note ; + +HELP: create-in "( string -- word )" +{ $values { "string" "a word name" } { "word" "a new word" } } +{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." } +$parsing-note ; + +HELP: create-constructor "( word -- constructor )" +{ $values { "class" "a word" } { "constructor" "a new word" } } +{ $description "Creates a new word in the current vocabulary, named by surrounding " { $snippet "word" } " with angle brackets." } ; diff --git a/library/syntax/parse-stream.factor b/library/syntax/parse-stream.factor index 138ffca672..739d7f8368 100644 --- a/library/syntax/parse-stream.factor +++ b/library/syntax/parse-stream.factor @@ -7,7 +7,8 @@ words ; : file-vocabs ( -- ) "scratchpad" set-in { "syntax" "scratchpad" } set-use ; -: with-parser ( quot -- ) [ rethrow ] recover ; +: with-parser ( quot -- ) + [ [ rethrow ] recover ] with-scope ; : parse-lines ( lines -- quot ) [ diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 9e45ae358d..2443c141c8 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -1,41 +1,8 @@ ! Copyright (C) 2005, 2006 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! See http://factorcode.org/license.txt for BSD license. IN: parser -USING: errors generic hashtables kernel math namespaces -sequences strings vectors words ; - -SYMBOL: use -SYMBOL: in - -: check-vocab ( name -- vocab ) - dup vocab - [ ] [ " is not a vocabulary name" append throw ] ?if ; - -: use+ ( string -- ) check-vocab use get push ; - -: add-use ( seq -- ) [ use+ ] each ; - -: set-use ( seq -- ) [ check-vocab ] map >vector use set ; - -: set-in ( name -- ) dup ensure-vocab dup in set use+ ; - -: parsing? ( word -- ? ) - dup word? [ "parsing" word-prop ] [ drop f ] if ; - -SYMBOL: file -SYMBOL: line-number - -SYMBOL: line-text -SYMBOL: column - -TUPLE: parse-error file line col text ; - -C: parse-error ( error -- error ) - file get over set-parse-error-file - line-number get over set-parse-error-line - column get over set-parse-error-col - line-text get over set-parse-error-text - [ set-delegate ] keep ; +USING: arrays errors generic hashtables kernel math namespaces +prettyprint sequences strings vectors words ; : skip ( i seq quot -- n | quot: elt -- ? ) over >r find* drop dup -1 = @@ -55,24 +22,29 @@ C: parse-error ( error -- error ) column [ line-text get (scan) dup ] change 2dup = [ 2drop f ] [ line-text get subseq ] if ; -: save-location ( word -- ) - dup set-word - dup line-number get "line" set-word-prop - file get "file" set-word-prop ; - -: create-in in get create dup save-location ; - -: create-constructor ( class -- word ) - word-name in get constructor-word dup save-location ; - : CREATE ( -- word ) scan create-in ; SYMBOL: string-mode +: do-what-i-mean ( string -- restarts ) + all-words [ word-name = ] subset-with natural-sort [ + [ "Use the word " swap synopsis append ] keep 2array + ] map ; + +: word-not-found ( str -- word ) + "No word named " + over + " found in current vocabulary search path" append3 + swap do-what-i-mean condition ; + : scan-word ( -- obj ) scan dup [ dup ";" = not string-mode get and [ - dup use get hash-stack [ ] [ string>number ] ?if + dup use get hash-stack [ ] [ + dup string>number [ ] [ + word-not-found dup word-vocabulary use+ + ] ?if + ] ?if ] unless ] when ; @@ -118,11 +90,11 @@ SYMBOL: string-mode global [ { - "scratchpad" "syntax" "alien" "arrays" "compiler" + "scratchpad" "syntax" "arrays" "compiler" "errors" "generic" "hashtables" "help" "inference" "inspector" "io" "jedit" "kernel" "listener" "math" - "memory" "namespaces" "optimizer" "parser" "prettyprint" - "queues" "sequences" "shells" "strings" "styles" "test" + "memory" "namespaces" "parser" "prettyprint" + "sequences" "shells" "strings" "styles" "test" "threads" "vectors" "walker" "words" } set-use "scratchpad" set-in diff --git a/library/syntax/parser.facts b/library/syntax/parser.facts index bda1fa0527..783b72ee18 100644 --- a/library/syntax/parser.facts +++ b/library/syntax/parser.facts @@ -1,65 +1,5 @@ USING: help kernel parser sequences ; -IN: help : $parsing-note - drop "This word should only be called from parsing words." $notes ; - -HELP: use f -{ $description "A variable holding the current vocabulary search path as a sequence of hashtables." } -{ $see-also in use+ set-use POSTPONE: USING: POSTPONE: USE: } ; - -HELP: in f -{ $description "A variable holding the current vocabulary for new definitions." } -{ $see-also use set-in POSTPONE: IN: } ; - -HELP: check-vocab "( name -- vocab )" -{ $values { "name" "a string" } { "vocab" "a hashtable" } } -{ $description "Outputs a named vocabulary." } -{ $errors "Throws an error if the vocabulary does not exist." } ; - -HELP: use+ "( vocab -- )" -{ $values { "vocab" "a string" } } -{ $description "Adds a new vocabulary at the front of the search path. Subsequent word lookups by the parser will search this vocabulary first." } -$parsing-note -{ $errors "Throws an error if the vocabulary does not exist." } -{ $see-also in use add-use set-use POSTPONE: USE: } ; - -HELP: set-use "( seq -- )" -{ $values { "seq" "a sequence of strings" } } -{ $description "Sets the vocabulary search path. Later vocabularies take precedence." } -{ $errors "Throws an error if one of the vocabularies does not exist." } -$parsing-note -{ $see-also in use use+ add-use file-vocabs } ; - -HELP: add-use "( seq -- )" -{ $values { "seq" "a sequence of strings" } } -{ $description "Adds multiple vocabularies to the search path, with later vocabularies taking precedence." } -{ $errors "Throws an error if one of the vocabularies does not exist." } -$parsing-note -{ $see-also in use use+ set-use POSTPONE: USING: } ; - -HELP: set-in "( name -- )" -{ $values { "name" "a string" } } -{ $description "Sets the current vocabulary where new words will be defined, creating the vocabulary first if it does not exist." } -$parsing-note -{ $see-also in use POSTPONE: IN: } ; - -HELP: parsing? "( obj -- ? )" -{ $values { "obj" "an object" } { "?" "a boolean" } } -{ $description "Tests if an object is a parsing word." } -{ $notes "Outputs " { $link f } " if the object is not a word." } ; - -HELP: file f -{ $description "Variable stores the file name being parsed. This is the input parameter to " { $link parse-stream } "." } ; - -HELP: line-number f -{ $description "Variable holds the line number being parsed." } ; - -HELP: line-text f -{ $description "Variable holds the text of the line being parsed." } ; - -HELP: column f -{ $description "Variable holds the column number being parsed." } ; - HELP: skip "( i seq quot -- n )" { $values { "n" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } } { $description "Variant of " { $link find* } " that outputs the length of the sequence instead of -1 if no elements satisfy the predicate." } ; @@ -82,20 +22,6 @@ HELP: scan "( -- token )" { $description "Reads the next token from the line currently being parsed. This is the key word that the Factor parser is built on." } $parsing-note ; -HELP: save-location "( word -- )" -{ $values { "word" "a word" } } -{ $description "Sets the " { $snippet "\"file\"" } " and " { $snippet "\"line\"" } " word properties to the current parser location." } -$parsing-note ; - -HELP: create-in "( string -- word )" -{ $values { "string" "a word name" } { "word" "a new word" } } -{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." } -$parsing-note ; - -HELP: create-constructor "( word -- constructor )" -{ $values { "class" "a word" } { "constructor" "a new word" } } -{ $description "Creates a new word in the current vocabulary, named by surrounding " { $snippet "word" } " with angle brackets." } ; - HELP: CREATE "( -- word )" { $values { "word" "a word" } } { $description "Reads the next token from the line currently being parsed, and creates a word with that name in the current vocabulary." } diff --git a/library/test/parse-number.factor b/library/test/parse-number.factor index 3cbca5b183..3e8a9cd79c 100644 --- a/library/test/parse-number.factor +++ b/library/test/parse-number.factor @@ -1,116 +1,112 @@ IN: temporary USING: errors kernel math parser sequences test ; -: parse-number ( str -- num ) - #! Convert a string to a number; return f on error. - [ string>number ] catch [ drop f ] when ; - [ f ] -[ f parse-number ] +[ f string>number ] unit-test [ f ] -[ "12345abcdef" parse-number ] +[ "12345abcdef" string>number ] unit-test [ t ] -[ "-12" parse-number 0 < ] +[ "-12" string>number 0 < ] unit-test [ f ] -[ "--12" parse-number ] +[ "--12" string>number ] unit-test [ f ] -[ "-" parse-number ] +[ "-" string>number ] unit-test [ f ] -[ "e" parse-number ] +[ "e" string>number ] unit-test [ "100.0" ] -[ "1.0e2" parse-number number>string ] +[ "1.0e2" string>number number>string ] unit-test [ "-100.0" ] -[ "-1.0e2" parse-number number>string ] +[ "-1.0e2" string>number number>string ] unit-test [ "0.01" ] -[ "1.0e-2" parse-number number>string ] +[ "1.0e-2" string>number number>string ] unit-test [ "-0.01" ] -[ "-1.0e-2" parse-number number>string ] +[ "-1.0e-2" string>number number>string ] unit-test [ f ] -[ "-1e-2e4" parse-number ] +[ "-1e-2e4" string>number ] unit-test [ "3.14" ] -[ "3.14" parse-number number>string ] +[ "3.14" string>number number>string ] unit-test [ f ] -[ "." parse-number ] +[ "." string>number ] unit-test [ f ] -[ ".e" parse-number ] +[ ".e" string>number ] unit-test [ "101.0" ] -[ "1.01e2" parse-number number>string ] +[ "1.01e2" string>number number>string ] unit-test [ "-101.0" ] -[ "-1.01e2" parse-number number>string ] +[ "-1.01e2" string>number number>string ] unit-test [ "1.01" ] -[ "101.0e-2" parse-number number>string ] +[ "101.0e-2" string>number number>string ] unit-test [ "-1.01" ] -[ "-101.0e-2" parse-number number>string ] +[ "-101.0e-2" string>number number>string ] unit-test [ 5 ] -[ "10/2" parse-number ] +[ "10/2" string>number ] unit-test [ -5 ] -[ "-10/2" parse-number ] +[ "-10/2" string>number ] unit-test [ -5 ] -[ "10/-2" parse-number ] +[ "10/-2" string>number ] unit-test [ 5 ] -[ "-10/-2" parse-number ] +[ "-10/-2" string>number ] unit-test [ 5.0 ] -[ "10.0/2" parse-number ] +[ "10.0/2" string>number ] unit-test [ f ] -[ "1e1/2" parse-number ] +[ "1e1/2" string>number ] unit-test [ f ] -[ "e/2" parse-number ] +[ "e/2" string>number ] unit-test [ "33/100" ] -[ "66/200" parse-number number>string ] +[ "66/200" string>number number>string ] unit-test -[ "12" bin> ] unit-test-fails -[ "fdsf" bin> ] unit-test-fails +[ f ] [ "12" bin> ] unit-test +[ f ] [ "fdsf" bin> ] unit-test [ 3 ] [ "11" bin> ] unit-test [ t ] [ diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 817694c606..e39edbbbf1 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -7,6 +7,7 @@ sequences-internals strings vectors words ; SYMBOL: error SYMBOL: error-continuation +SYMBOL: restarts : expired-error. ( obj -- ) "Object did not survive image save/load: " write third . ; @@ -23,9 +24,6 @@ SYMBOL: error-continuation "Object type: " write dup fourth class . "Expected type: " write third type>class . ; -: float-format-error. ( list -- ) - "Invalid floating point literal format: " write third . ; - : signal-error. ( obj -- ) "Operating system signal " write third . ; @@ -67,7 +65,6 @@ M: kernel-error error. ( error -- ) [ io-error. ] [ undefined-word-error. ] [ type-check-error. ] - [ float-format-error. ] [ signal-error. ] [ negative-array-size-error. ] [ c-string-error. ] @@ -114,6 +111,8 @@ M: parse-error error. ( error -- ) M: bounds-error summary drop "Sequence index out of bounds" ; +M: condition error. delegate error. ; + M: tuple error. ( error -- ) describe ; M: object error. ( error -- ) . ; @@ -127,7 +126,20 @@ M: object error. ( error -- ) . ; : :get ( var -- value ) error-continuation get continuation-name hash-stack ; +: :res ( n -- ) restarts get nth first3 continue-with ; + +: restarts. ( -- ) + restarts get dup empty? [ + drop + ] [ + "The following restarts are available:" print + dup length [ + number>string write " :res " write first print + ] 2each + ] if ; + : debug-help ( -- ) + restarts. ":s :r :c show stacks at time of error" print ":get ( var -- value ) accesses variables at time of error" print ":error starts the inspector with the error" print @@ -144,7 +156,9 @@ M: object error. ( error -- ) . ; : try ( quot -- ) [ print-error terpri debug-help ] recover ; : save-error ( error continuation -- ) - error-continuation set-global error set-global ; + error-continuation set-global + dup error set-global + compute-restarts restarts set-global ; : error-handler ( error -- ) dup continuation save-error rethrow ; diff --git a/library/tools/listener.factor b/library/tools/listener.factor index f6a711e4d8..1373a7b5a1 100644 --- a/library/tools/listener.factor +++ b/library/tools/listener.factor @@ -15,7 +15,7 @@ SYMBOL: error-hook [ drop terpri debug-help ] error-hook set-global : bye ( -- ) quit-flag on ; - +help : (read-multiline) ( quot depth -- quot ? ) >r readln dup [ (parse) depth r> dup >r <= [ @@ -28,7 +28,9 @@ SYMBOL: error-hook ] if ; : read-multiline ( -- quot ? ) - [ f depth (read-multiline) >r >quotation r> ] with-parser ; + [ + f depth (read-multiline) >r >quotation r> in get + ] with-parser in set ; : listen-try [ diff --git a/native/error.c b/native/error.c index 80a0efcd16..48e546bfe8 100644 --- a/native/error.c +++ b/native/error.c @@ -48,10 +48,10 @@ void primitive_die(void) factorbug(); } -void general_error(CELL error, CELL arg1, CELL arg2, bool keep_stacks) +void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks) { - CELL thrown = make_array_4(userenv[ERROR_ENV],error,arg1,arg2); - throw_error(thrown,keep_stacks); + throw_error(make_array_4(userenv[ERROR_ENV], + tag_fixnum(error),arg1,arg2),keep_stacks); } /* It is not safe to access 'ds' from a signal handler, so we just not diff --git a/native/error.h b/native/error.h index b9bdafa785..88d1b84b7d 100644 --- a/native/error.h +++ b/native/error.h @@ -1,22 +1,24 @@ -#define ERROR_EXPIRED (0<<3) -#define ERROR_IO (1<<3) -#define ERROR_UNDEFINED_WORD (2<<3) -#define ERROR_TYPE (3<<3) -#define ERROR_FLOAT_FORMAT (4<<3) -#define ERROR_SIGNAL (5<<3) -#define ERROR_NEGATIVE_ARRAY_SIZE (6<<3) -#define ERROR_C_STRING (7<<3) -#define ERROR_FFI (8<<3) -#define ERROR_HEAP_SCAN (9<<3) -#define ERROR_UNDEFINED_SYMBOL (10<<3) -#define ERROR_USER_INTERRUPT (11<<3) -#define ERROR_DS_UNDERFLOW (12<<3) -#define ERROR_DS_OVERFLOW (13<<3) -#define ERROR_RS_UNDERFLOW (14<<3) -#define ERROR_RS_OVERFLOW (15<<3) -#define ERROR_CS_UNDERFLOW (16<<3) -#define ERROR_CS_OVERFLOW (17<<3) -#define ERROR_OBJECTIVE_C (18<<3) +typedef enum +{ + ERROR_EXPIRED + ERROR_IO + ERROR_UNDEFINED_WORD + ERROR_TYPE + ERROR_SIGNAL + ERROR_NEGATIVE_ARRAY_SIZE + ERROR_C_STRING + ERROR_FFI + ERROR_HEAP_SCAN + ERROR_UNDEFINED_SYMBOL + ERROR_USER_INTERRUPT + ERROR_DS_UNDERFLOW + ERROR_DS_OVERFLOW + ERROR_RS_UNDERFLOW + ERROR_RS_OVERFLOW + ERROR_CS_UNDERFLOW + ERROR_CS_OVERFLOW + ERROR_OBJECTIVE_C +} F_ERRORTYPE; /* Are we throwing an error? */ bool throwing; @@ -32,7 +34,7 @@ void fatal_error(char* msg, CELL tagged); void critical_error(char* msg, CELL tagged); void throw_error(CELL error, bool keep_stacks); void early_error(CELL error); -void general_error(CELL error, CELL arg1, CELL arg2, bool keep_stacks); +void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks); void signal_error(int signal); void type_error(CELL type, CELL tagged); void primitive_throw(void); diff --git a/native/float.c b/native/float.c index b84fc0b87b..1fa5e254c8 100644 --- a/native/float.c +++ b/native/float.c @@ -44,8 +44,9 @@ void primitive_str_to_float(void) end = c_str; f = strtod(c_str,&end); if(end != c_str + string_capacity(str)) - general_error(ERROR_FLOAT_FORMAT,tag_object(str),F,true); - drepl(tag_float(f)); + drepl(F); + else + drepl(tag_float(f)); } void primitive_float_to_str(void)