From 4f4e27b8c75caafa9578727fb881354abac0af00 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 17 Jul 2004 22:35:09 +0000 Subject: [PATCH] started working on catch/throw --- factor/.FactorInterpreter.java.marks | Bin 45 -> 45 bytes factor/FactorInterpreter.java | 25 +++-- library/errors.factor | 95 ++++++++++++++++++ library/namespaces.factor | 12 +-- library/platform/jvm/errors.factor | 10 +- library/platform/native/.kernel.factor.marks | 2 +- library/platform/native/boot.factor | 1 + library/platform/native/cross-compiler.factor | 2 + library/platform/native/errors.factor | 52 ++++------ library/platform/native/image.factor | 17 +++- library/platform/native/init.factor | 12 +-- library/platform/native/kernel.factor | 35 ++++++- library/platform/native/namespaces.factor | 4 + library/platform/native/stream.factor | 3 + native/cons.c | 14 +-- 15 files changed, 206 insertions(+), 78 deletions(-) create mode 100644 library/errors.factor diff --git a/factor/.FactorInterpreter.java.marks b/factor/.FactorInterpreter.java.marks index 7e2cd992ac14653a36b850883b6c621f3fb76934..67054ae34bb883861392bdccfeeef9dfb2e70582 100644 GIT binary patch literal 45 lcmY#Pv^F%dv@n8@T#5|Vh9;KA1`ra=H8n6cv^E5hTmZ&%2uA<_ literal 45 kcmY#Pv^F#{H#dTiT#5|Vh9(vU1`ra$wKOmUa)Bfl0L3>5LjV8( diff --git a/factor/FactorInterpreter.java b/factor/FactorInterpreter.java index e92f860421..20b360041b 100644 --- a/factor/FactorInterpreter.java +++ b/factor/FactorInterpreter.java @@ -38,9 +38,11 @@ public class FactorInterpreter implements FactorObject, Runnable { public static final String VERSION = "0.60.6"; - // we need to call two words (boot and break) from the kernel - // vocabulary - private static final String KERNEL_VOCAB = "kernel"; + // we need to call the 'boot' word from the init vocabulary. + private static final String INIT_VOCAB = "init"; + + // we need to call the 'throw' word from the errors vocabulary. + private static final String ERRORS_VOCAB = "errors"; // command line arguments are stored here. public Cons args; @@ -58,6 +60,7 @@ public class FactorInterpreter implements FactorObject, Runnable public FactorArray callstack = new FactorArray(); public FactorArray datastack = new FactorArray(); public FactorArray namestack = new FactorArray(); + public FactorArray catchstack = new FactorArray(); /** * Maps vocabulary names to vocabularies. @@ -118,6 +121,7 @@ public class FactorInterpreter implements FactorObject, Runnable this.callstack = (FactorArray)interp.callstack.clone(); this.datastack = (FactorArray)interp.datastack.clone(); this.namestack = (FactorArray)interp.namestack.clone(); + this.catchstack = (FactorArray)interp.catchstack.clone(); this.vocabularies = interp.vocabularies; this.use = interp.use; this.in = interp.in; @@ -439,7 +443,7 @@ public class FactorInterpreter implements FactorObject, Runnable call(parser.parse()); } else - eval(searchVocabulary(KERNEL_VOCAB,"boot")); + eval(searchVocabulary(INIT_VOCAB,"boot")); //XXX messy @@ -509,15 +513,13 @@ public class FactorInterpreter implements FactorObject, Runnable datastack.push(error); try { - eval(searchVocabulary(KERNEL_VOCAB,"break")); + eval(searchVocabulary(ERRORS_VOCAB,"throw")); return false; } catch(Throwable e2) { - System.err.println("Exception when calling break:"); + System.err.println("Exception when calling throw:"); e.printStackTrace(); - System.err.println("Factor callstack:"); - System.err.println(callstack); topLevel(); @@ -578,8 +580,8 @@ public class FactorInterpreter implements FactorObject, Runnable catch(Exception e) { callstack.push(callframe); - callframe = createCompiledCallframe( - (FactorWord)obj); + /* callframe = createCompiledCallframe( + (FactorWord)obj); */ while(compiledExceptions != null) { callstack.push(compiledExceptions.car); @@ -752,6 +754,9 @@ public class FactorInterpreter implements FactorObject, Runnable datastack.top = 0; namestack.top = 0; namestack.push(global); + catchstack.top = 0; + catchstack.push(searchVocabulary(ERRORS_VOCAB, + "default-error-handler")); callframe = null; } //}}} } diff --git a/library/errors.factor b/library/errors.factor new file mode 100644 index 0000000000..5490e82ae9 --- /dev/null +++ b/library/errors.factor @@ -0,0 +1,95 @@ +!:folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2004 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: errors +USE: arithmetic +USE: combinators +USE: continuations +USE: inspector +USE: kernel +USE: lists +USE: namespaces +USE: stack +USE: stdio +USE: strings +USE: unparser +USE: vectors + +: catchstack ( -- cs ) catchstack* clone ; +: set-catchstack ( cs -- ) clone set-catchstack* ; + +: >c ( catch -- ) + #! Push a catch block on the catchstack. Use the catch word + #! instead of invoking this word directly. + catchstack* vector-push ; + +: c> ( catch -- ) + #! Pop a catch block from the catchstack. Use the catch word + #! instead of invoking this word directly. + catchstack* vector-pop ; + +: default-error-handler ( error -- ) + #! Print the error and return to the top level. + "Uncaught exception." print + "-------------------" print + terpri + "Datastack:" print + .s + terpri + "Callstack:" print + .r + terpri + "Namestack:" print + .n + terpri + "ERROR: " write error>str print + suspend ; + +: save-error ( -- ) + #! Save the stacks for most-mortem inspection after an + #! error. + datastack "error-datastack" set + callstack dup vector-pop drop "error-callstack" set + namestack "error-namestack" set + catchstack "error-catchstack" set ; + +: catch ( try catch -- ) + #! Call the try quotation, restore the datastack to its + #! state before the try quotation, push the error (or f if + #! no error occurred) and call the catch quotation. + [ >c drop call f c> call ] callcc1 ( c> drop ) + ( try catch error ) rot drop swap ( error catch ) call ; + +: rethrow ( error -- ) + #! Use rethrow when passing an error on from a catch block. + #! For convinience, this word is a no-op if error is f. + [ c> call ] when* ; + +: throw ( error -- ) + #! Throw an error. If no catch handlers are installed, the + #! default-error-handler is called. + save-error rethrow ; diff --git a/library/namespaces.factor b/library/namespaces.factor index 47b72c4d43..40baaf6833 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -76,18 +76,18 @@ USE: vectors #! Push the current namespace. namestack* vector-peek ; inline -: bind ( namespace quot -- ) - #! Execute a quotation with a new namespace on the namespace - #! stack. Compiles if the quotation compiles. - swap namespace-of >n call n> drop ; inline - : extend ( object code -- object ) #! Used in code like this: #! : #! [ #! .... #! ] extend ; - over [ bind ] dip ; inline + swap namespace-of >n call n> ; inline + +: bind ( namespace quot -- ) + #! Execute a quotation with a new namespace on the namespace + #! stack. Compiles if the quotation compiles. + extend drop ; inline : lazy ( var [ a ] -- value ) #! If the value of the variable is f, set the value to the diff --git a/library/platform/jvm/errors.factor b/library/platform/jvm/errors.factor index 7d169d1312..fafed7b4ea 100644 --- a/library/platform/jvm/errors.factor +++ b/library/platform/jvm/errors.factor @@ -26,6 +26,12 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: errors +USE: strings -: throw ( obj -- ) - [ "java.lang.Object" ] "factor.FactorLib" "error" jinvoke-static ; +: catchstack* ( -- cs ) + "factor.FactorInterpreter" "catchstack" jvar-get ; + +: set-catchstack* ( cs -- ) + "factor.FactorInterpreter" "catchstack" jvar-set ; + +: error>str ( error -- str ) >str ; diff --git a/library/platform/native/.kernel.factor.marks b/library/platform/native/.kernel.factor.marks index 8ed047fffb..55b01478ee 100644 --- a/library/platform/native/.kernel.factor.marks +++ b/library/platform/native/.kernel.factor.marks @@ -1 +1 @@ -!a;771;771 +!a;2200;2200 diff --git a/library/platform/native/boot.factor b/library/platform/native/boot.factor index 2bbc3add0f..e50aaef56b 100644 --- a/library/platform/native/boot.factor +++ b/library/platform/native/boot.factor @@ -49,6 +49,7 @@ primitives, "/library/combinators.factor" "/library/cons.factor" "/library/continuations.factor" + "/library/errors.factor" "/library/format.factor" "/library/hashtables.factor" "/library/init.factor" diff --git a/library/platform/native/cross-compiler.factor b/library/platform/native/cross-compiler.factor index 9d4be75976..22aca7d357 100644 --- a/library/platform/native/cross-compiler.factor +++ b/library/platform/native/cross-compiler.factor @@ -169,4 +169,6 @@ IN: cross-compiler "/library/platform/native/boot.factor" run-resource ] with-image + ! Uncomment this on sparc and powerpc. + ! "big-endian" on "native/factor.image" write-image ; diff --git a/library/platform/native/errors.factor b/library/platform/native/errors.factor index f6ed93f57f..2ee3e41af2 100644 --- a/library/platform/native/errors.factor +++ b/library/platform/native/errors.factor @@ -27,25 +27,23 @@ IN: errors USE: arithmetic +USE: combinators USE: continuations -USE: inspector +USE: kernel USE: lists +USE: namespaces USE: stack USE: stdio USE: strings USE: unparser +USE: vectors ! This is a very lightweight exception handling system. -! catch stack -! error? --> top of catch stack, save error continuation, -! restore the continuation there -! restore continuation of 'catch' so that the catch is not in -! scope -- it can throw up. -! if top level catches error, it prints a message. -! -! The kernel throws errors as lists. The first element is an -! integer. +: catchstack* ( -- cs ) 6 getenv ; +: catchstack ( -- cs ) catchstack* clone ; +: set-catchstack* ( cs -- ) 6 setenv ; +: set-catchstack ( cs -- ) clone set-catchstack* ; : kernel-error? ( obj -- ? ) dup cons? [ car fixnum? ] [ drop f ] ifte ; @@ -62,31 +60,21 @@ USE: unparser "Underflow" ] ?nth ; -: kernel-error% ( error -- ) - car error# % ": " % unparse % ; +: kernel-error>str ( error -- ) + <% car error# % ": " % unparse % %> ; -: error>str ( error -- str ) +: error>str ( error -- str ) dup kernel-error? [ - <% kernel-error% %> + kernel-error>str ] [ unparse ] ifte ; - -: default-error-handler ( error -- ) - #! Print the error and return to the top level. - "Uncaught exception." print - "-------------------" print - "Datastack:" print - .s - "Callstack:" print - .r - "Namestack:" print - .n - terpri - "ERROR: " write error>str print - suspend ; -: throw ( error -- ) - #! Throw an error. If no catch handlers are installed, the - #! default-error-handler is called. - default-error-handler ; +DEFER: >c +DEFER: throw +DEFER: default-error-handler + +: init-errors ( -- ) + 64 set-catchstack* + [ default-error-handler ] >c + [ throw ] 5 setenv ( kernel calls on error ) ; diff --git a/library/platform/native/image.factor b/library/platform/native/image.factor index 383a525c95..67bcc58a06 100644 --- a/library/platform/native/image.factor +++ b/library/platform/native/image.factor @@ -288,14 +288,27 @@ IN: cross-compiler : byte2 ( num -- byte ) 8 shift> HEX: ff bitand ; : byte3 ( num -- byte ) HEX: ff bitand ; -: >little-endian ( word -- word ) +: write-little-endian ( word -- ) dup byte3 >char write dup byte2 >char write dup byte1 >char write byte0 >char write ; +: write-big-endian ( word -- ) + dup byte0 >char write + dup byte1 >char write + dup byte2 >char write + byte3 >char write ; + +: write-word ( word -- ) + "big-endian" get [ + write-big-endian + ] [ + write-little-endian + ] ifte ; + : write-image ( image file -- ) - [ [ >little-endian ] vector-each ] with-stream ; + [ [ write-word ] vector-each ] with-stream ; : with-image ( quot -- image ) [ diff --git a/library/platform/native/init.factor b/library/platform/native/init.factor index 27af501d0e..d5febf2702 100644 --- a/library/platform/native/init.factor +++ b/library/platform/native/init.factor @@ -49,16 +49,6 @@ USE: vocabularies USE: words USE: unparser -: init-namespaces ( -- ) - 64 set-namestack* global >n ; - -: init-stdio ( -- ) - stdin stdout "stdio" set ; - -: init-error-handler ( -- ) - #! The kernel calls this quotation when an error is raised. - [ throw ] 5 setenv ; - IN: kernel : boot ( -- ) @@ -70,7 +60,7 @@ IN: kernel t "interactive" set init-stdio - init-error-handler + init-errors init-search-path init-scratchpad init-styles diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor index 162560b90e..39892cf058 100644 --- a/library/platform/native/kernel.factor +++ b/library/platform/native/kernel.factor @@ -1,6 +1,37 @@ +!:folding=none:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2004 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: namespaces +DEFER: init-namespaces + IN: kernel USE: arithmetic USE: combinators +USE: errors USE: lists USE: logic USE: namespaces @@ -52,9 +83,9 @@ USE: words ] cond ; : toplevel ( -- ) + init-namespaces + init-errors 0 set-datastack - 0 set-namestack - global >n 0 set-callstack ; !!! HACK diff --git a/library/platform/native/namespaces.factor b/library/platform/native/namespaces.factor index a8246555b7..8904283e71 100644 --- a/library/platform/native/namespaces.factor +++ b/library/platform/native/namespaces.factor @@ -35,6 +35,7 @@ USE: stack USE: vectors DEFER: namespace +DEFER: >n : namestack* ( -- ns ) 3 getenv ; : set-namestack* ( ns -- ) 3 setenv ; @@ -42,6 +43,9 @@ DEFER: namespace : global ( -- g ) 4 getenv ; : set-global ( g -- ) 4 setenv ; +: init-namespaces ( -- ) + 64 set-namestack* global >n ; + : namespace-buckets 23 ; : ( -- n ) diff --git a/library/platform/native/stream.factor b/library/platform/native/stream.factor index 4a540ee80d..a97c8b0f65 100644 --- a/library/platform/native/stream.factor +++ b/library/platform/native/stream.factor @@ -42,3 +42,6 @@ USE: namespaces ( -- string ) [ "in" get read-line-8 ] "freadln" set ] extend ; + +: init-stdio ( -- ) + stdin stdout "stdio" set ; diff --git a/native/cons.c b/native/cons.c index 058a77ee4f..0617f82650 100644 --- a/native/cons.c +++ b/native/cons.c @@ -10,18 +10,8 @@ CELL cons(CELL car, CELL cdr) void primitive_consp(void) { - switch(TAG(env.dt)) - { - case EMPTY_TYPE: - check_non_empty(env.dt); - break; - case CONS_TYPE: - env.dt = T; - break; - default: - env.dt = F; - break; - } + check_non_empty(env.dt); + env.dt = tag_boolean(typep(CONS_TYPE,env.dt)); } void primitive_cons(void)