started working on catch/throw

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
+	// we need to call the 'boot' word from the init vocabulary.
-	// vocabulary
+	private static final String INIT_VOCAB = "init";
-	private static final String KERNEL_VOCAB = "kernel";
+
+	// 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(
+				/* callframe = createCompiledCallframe(
-					(FactorWord)obj);
+					(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;
 	} //}}}
 }

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 ;

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:
     #! : <subclass>
     #!      <superclass> [
     #!          ....
     #!      ] 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

library/platform/jvm/errors.factor

@@ -26,6 +26,12 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: errors
+USE: strings
 
-: throw ( obj -- )
+: catchstack* ( -- cs )
-    [ "java.lang.Object" ] "factor.FactorLib" "error" jinvoke-static ;
+    "factor.FactorInterpreter" "catchstack" jvar-get ;
+
+: set-catchstack* ( cs -- )
+    "factor.FactorInterpreter" "catchstack" jvar-set ;
+
+: error>str ( error -- str ) >str ;

library/platform/native/.kernel.factor.marks

@@ -1 +1 @@
-!a;771;771
+!a;2200;2200

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"

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 ;

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
+: catchstack* ( -- cs ) 6 getenv ;
-! error? --> top of catch stack, save error continuation,
+: catchstack ( -- cs ) catchstack* clone ;
-! restore the continuation there
+: set-catchstack* ( cs -- ) 6 setenv ;
-! restore continuation of 'catch' so that the catch is not in
+: set-catchstack ( cs -- ) clone set-catchstack* ;
-! 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.
 
 : kernel-error? ( obj -- ? )
     dup cons? [ car fixnum? ] [ drop f ] ifte ;
@@ -62,31 +60,21 @@ USE: unparser
         "Underflow"
     ] ?nth ;
 
-: kernel-error% ( error -- )
+: kernel-error>str ( error -- )
-    car error# % ": " % unparse % ;
+    <% car error# % ": " % unparse % %> ;
 
 : error>str ( error -- str )
     dup kernel-error? [
-        <% kernel-error% %>
+        kernel-error>str
     ] [
         unparse
     ] ifte ;
 
-: default-error-handler ( error -- )
+DEFER: >c
-    #! Print the error and return to the top level.
+DEFER: throw
-    "Uncaught exception." print
+DEFER: default-error-handler
-    "-------------------" print
-    "Datastack:" print
-    .s
-    "Callstack:" print
-    .r
-    "Namestack:" print
-    .n
-    terpri
-    "ERROR: " write error>str print
-    suspend ;
 
-: throw ( error -- )
+: init-errors ( -- )
-    #! Throw an error. If no catch handlers are installed, the
+    64 <vector> set-catchstack*
-    #! default-error-handler is called.
+    [ default-error-handler ] >c
-    default-error-handler ;
+    [ throw ] 5 setenv ( kernel calls on error ) ;

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 -- )
-    <filebw> [ [ >little-endian ] vector-each ] with-stream ;
+    <filebw> [ [ write-word ] vector-each ] with-stream ;
 
 : with-image ( quot -- image )
     <namespace> [

library/platform/native/init.factor

@@ -49,16 +49,6 @@ USE: vocabularies
 USE: words
 USE: unparser
 
-: init-namespaces ( -- )
-    64 <vector> set-namestack* global >n ;
-
-: init-stdio ( -- )
-    stdin stdout <native-stream> <ansi-stream> "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

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 <vector> set-datastack
-    0 <vector> set-namestack
-    global >n
     0 <vector> set-callstack ;
 
 !!! HACK

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 <vector> set-namestack* global >n ;
+
 : namespace-buckets 23 ;
 
 : <namespace> ( -- n )

library/platform/native/stream.factor

@@ -42,3 +42,6 @@ USE: namespaces
         ( -- string )
         [ "in" get read-line-8 ] "freadln" set
     ] extend ;
+
+: init-stdio ( -- )
+    stdin stdout <native-stream> "stdio" set ;

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;
+	env.dt = tag_boolean(typep(CONS_TYPE,env.dt));
-	case CONS_TYPE:
-		env.dt = T;
-		break;
-	default:
-		env.dt = F;
-		break;
-	}
 }
 
 void primitive_cons(void)