throw is primitive in CFactor, working on test suite

Makefile

@@ -1,11 +1,11 @@
-CC = gcc34
+CC = gcc
 
 # On FreeBSD, to use SDL and other libc_r libs:
-# CFLAGS = -g -Wall -export-dynamic -pthread
+CFLAGS = -g -Wall -export-dynamic -pthread
 # On PowerPC G5:
 # CFLAGS = -mcpu=970 -mtune=970 -mpowerpc64 -ffast-math -O3
 # On Pentium 4:
-CFLAGS = -march=pentium4 -ffast-math -Os -fomit-frame-pointer -export-dynamic -pthread
+# CFLAGS = -march=pentium4 -ffast-math -Os -fomit-frame-pointer -export-dynamic -pthread
 # Add -fomit-frame-pointer if you don't care about debugging
 # CFLAGS = -Os -g -Wall
 

TODO.FACTOR.txt

@@ -7,7 +7,9 @@ FFI:
 
 - compiled? messy
 - compiler: drop literal peephole optimization
-- compiler: arithmetic-type { ... } execute
+- compiling when*
+- compiling unless*
+- eliminate uses of 2dip
 - getenv/setenv: if literal arg, compile as a load/store
 - inline words
 

factor/FactorScanner.java

@@ -121,8 +121,45 @@ public class FactorScanner
 			nextLine();
 	} //}}}
 
+	//{{{ isEOL() method
+	private boolean isEOL()
+	{
+		return position >= line.length();
+	} //}}}
+	
+	//{{{ skipWhitespace() method
+	/**
+	 * The Factor parser is so much nicer in Factor than Java!
+	 */
+	public void skipWhitespace() throws FactorParseException
+	{
+		for(;;)
+		{
+			if(isEOL())
+				return;
+
+			char ch = line.charAt(position++);
+
+			int type = readtable.getCharacterType(ch);
+
+			switch(type)
+			{
+			case ReadTable.INVALID:
+				error("Invalid character in input: " + ch);
+				break;
+			case ReadTable.WHITESPACE:
+				break;
+			default:
+				position--;
+				return;
+			}
+		}
+	} //}}}
+	
 	//{{{ next() method
 	/**
+	 * Read a word name. Note that no escaping of characters is done.
+	 *
 	 * @param readNumbers If true, will return either a Number or a
 	 * String. Otherwise, only Strings are returned.
 	 * @param start If true, dispatches will be handled by their parsing
@@ -143,7 +180,7 @@ public class FactorScanner
 
 		for(;;)
 		{
-			if(position == line.length())
+			if(position >= line.length())
 			{
 				// EOL
 				if(buf.length() != 0)
@@ -174,10 +211,8 @@ public class FactorScanner
 					return word(readNumbers,base);
 				}
 			case ReadTable.CONSTITUENT:
-				buf.append(ch);
-				break;
 			case ReadTable.SINGLE_ESCAPE:
-				buf.append(escape());
+				buf.append(ch);
 				break;
 			}
 		}
@@ -199,6 +234,9 @@ public class FactorScanner
 	} //}}}
 
 	//{{{ readUntil() method
+	/**
+	 * Characters are escaped.
+	 */
 	public String readUntil(char start, char end, boolean escapesAllowed)
 		throws IOException, FactorParseException
 	{
@@ -206,7 +244,7 @@ public class FactorScanner
 
 		for(;;)
 		{
-			if(position == line.length())
+			if(isEOL())
 			{
 				error("Expected " + end + " before EOL");
 				break;
@@ -252,7 +290,7 @@ public class FactorScanner
 	//{{{ readNonEOF() method
 	public char readNonEOF() throws FactorParseException, IOException
 	{
-		if(position == line.length())
+		if(isEOL())
 		{
 			error("Unexpected EOL");
 			return '\0';
@@ -279,7 +317,7 @@ public class FactorScanner
 	//{{{ atEndOfWord() method
 	public boolean atEndOfWord() throws IOException
 	{
-		if(position == line.length())
+		if(isEOL())
 			return true;
 		if(line == null)
 			return true;

factor/FactorWord.java

@@ -198,7 +198,6 @@ public class FactorWord implements FactorExternalizable, FactorObject
 	//{{{ toString() method
 	public String toString()
 	{
-		return name == null ? "#<unnamed>"
+		return name == null ? "#<unnamed>" : name;
-			: FactorReader.charsToEscapes(name);
 	} //}}}
 }

factor/parser/CharLiteral.java

@@ -47,9 +47,9 @@ public class CharLiteral extends FactorParsingDefinition
 	public void eval(FactorInterpreter interp, FactorReader reader)
 		throws IOException, FactorParseException
 	{
-		String word = (String)reader.nextNonEOL(false,false);
+		FactorScanner scanner = reader.getScanner();
-		if(word.length() != 1)
+		scanner.skipWhitespace();
-			reader.error("Bad character literal: " + word);
+		char ch = scanner.readNonEOFEscaped();
-		reader.append(new Character(word.charAt(0)));
+		reader.append(new Character(ch));
 	}
 }

library/compiler/compiler.factor

@@ -37,6 +37,7 @@ USE: namespaces
 USE: parser
 USE: prettyprint
 USE: stack
+USE: stdio
 USE: strings
 USE: unparser
 USE: vectors
@@ -62,11 +63,7 @@ SYMBOL: compiled-xts
     compiled-xts off ;
 
 : compiled-xt ( word -- xt )
-    dup compiled-xts get assoc dup [
+    dup compiled-xts get assoc [ nip ] [ word-xt ] ifte* ;
-        nip
-    ] [
-        drop word-xt
-    ] ifte ;
 
 ! "fixup-xts" is a list of [ where word relative ] pairs; the xt
 ! of word when its done compiling will be written to the offset,
@@ -74,13 +71,24 @@ SYMBOL: compiled-xts
 
 SYMBOL: deferred-xts
 
+! Words being compiled are consed onto this list. When a word
+! is encountered that has not been previously compiled, it is
+! consed onto this list. Compilation stops when the list is
+! empty.
+
+SYMBOL: compile-words
+
 : defer-xt ( word where relative -- )
     #! After word is compiled, put its XT at where, relative.
     3list deferred-xts cons@ ;
 
 : compiled? ( word -- ? )
     #! This is a hack.
-    dup "compiled" word-property swap primitive? or ;
+    dup "compiled" word-property [
+        drop t
+    ] [
+        primitive?
+    ] ifte ;
 
 : fixup-deferred-xt ( word where relative -- )
     rot dup compiled? [
@@ -95,18 +103,10 @@ SYMBOL: deferred-xts
     ] each
     deferred-xts off ;
 
-! Words being compiled are consed onto this list. When a word
-! is encountered that has not been previously compiled, it is
-! consed onto this list. Compilation stops when the list is
-! empty.
-
-SYMBOL: compile-words
-
 : postpone-word ( word -- )
-    dup compiled? [
+    dup compiled? [ drop ] [
-        drop
+        t over "compiled" set-word-property
-    ] [
+        compile-words unique@
-        t over "compiled" set-word-property compile-words cons@
     ] ifte ;
 
 ! During compilation, these two variables store pending
@@ -206,6 +206,7 @@ SYMBOL: compile-callstack
 
 : (compile) ( word -- )
     #! Should be called inside the with-compiler scope.
+    dup . flush
     intern dup save-xt word-parameter compile-quot RET ;
 
 : compile-postponed ( -- )

library/compiler/ifte.factor

@@ -60,7 +60,7 @@ USE: lists
     tail? [ RET f ] [ JUMP ] ifte swap branch-target ;
 
 : end-if ( fixup -- )
-    tail? [ drop RET ] [ branch-target ] ifte ;
+    tail? [ RET ] when [ branch-target ] when* ;
 
 : compile-ifte ( compile-time: true false -- )
     pop-literal pop-literal  commit-literals
@@ -79,7 +79,7 @@ USE: lists
 : compile-unless ( compile-time: false -- )
     pop-literal  commit-literals
     compile-t-test >r
-    ( t -- ) compile-quot
+    ( f -- ) compile-quot
     r> end-if ;
 
 [ compile-ifte ] \ ifte "compiling" set-word-property

library/cross-compiler.factor

@@ -26,6 +26,7 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 USE: combinators
+USE: errors
 USE: kernel
 USE: lists
 USE: math
@@ -382,6 +383,7 @@ IN: image
         alien-1
         set-alien-1
         heap-stats
+        throw
     ] [
         swap succ tuck primitive,
     ] each drop ;

library/errors.factor

@@ -70,5 +70,3 @@ USE: vectors
     #! 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 -- ) dup save-error rethrow ;

library/platform/jvm/errors.factor

@@ -27,8 +27,17 @@
 
 IN: errors
 USE: kernel
+USE: stack
 USE: strings
 
+DEFER: save-error
+DEFER: rethrow
+
+: throw ( error -- )
+    #! Throw an error that will be caught by a surrounding
+    #! catch block.
+    dup save-error rethrow ;
+
 : catchstack* ( -- cs )
     interpreter
     "factor.FactorInterpreter" "catchstack" jvar-get ;

library/platform/native/init-stage2.factor

@@ -28,6 +28,7 @@
 IN: init
 USE: ansi
 USE: combinators
+USE: compiler
 USE: errors
 USE: httpd-responder
 USE: kernel
@@ -35,6 +36,7 @@ USE: lists
 USE: namespaces
 USE: parser
 USE: random
+USE: stack
 USE: streams
 USE: styles
 USE: words
@@ -44,7 +46,7 @@ USE: words
 : init-error-handler ( -- )
     [ 1 exit* ] >c ( last resort )
     [ default-error-handler 1 exit* ] >c
-    [ throw ] 5 setenv ( kernel calls on error ) ;
+    [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) ;
 
 : warm-boot ( -- )
     #! A fully bootstrapped image has this as the boot
@@ -53,6 +55,7 @@ USE: words
 
     init-error-handler
     init-random
+    init-assembler
 
     ! Some flags are *on* by default, unless user specifies
     ! -no-<flag> CLI switch

library/platform/native/primitives.factor

@@ -28,6 +28,7 @@
 USE: combinators
 USE: alien
 USE: compiler
+USE: errors
 USE: files
 USE: io-internals
 USE: kernel
@@ -235,6 +236,7 @@ USE: words
     [ alien-1                | " alien off -- n " ]
     [ set-alien-1            | " n alien off -- " ]
     [ heap-stats             | " -- instances bytes " ]
+    [ throw                  | " error -- " ]
 ] [
     unswons "stack-effect" set-word-property
 ] each

library/test/combinators.factor

@@ -5,21 +5,17 @@ USE: math
 USE: stack
 USE: test
 
+[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
+[ 6 ] [ [ 2 2 + ] 1 1 2slip + + ] unit-test
+[ 6 ] [ [ 2 1 + ] 1 1 1 3slip + + + ] unit-test
+
+[ 6 ] [ 2 [ sq ] keep + ] unit-test
+
 [   ] [ 3 [ ] cond ] unit-test
 [ t ] [ 4 [ [ 1 = ] [ ] [ 4 = ] [ drop t ] [ 2 = ] [ ] ] cond ] unit-test
 
-[ 0 1 2 3 4 ] [ 5 [ ] times* ] unit-test
+[ 0 ] [ f [ sq ] [ 0 ] ifte* ] unit-test
-[ ] [ 0 [ ] times* ] unit-test
+[ 4 ] [ 2 [ sq ] [ 0 ] ifte* ] unit-test
 
-[ #{ 1 1 } ] [ #{ 2 3 } #{ 1 0 } 2times-succ ] unit-test
+[ 0 ] [ f [ 0 ] unless* ] unit-test
-[ #{ 1 2 } ] [ #{ 2 3 } #{ 1 1 } 2times-succ ] unit-test
+[ t ] [ t [ "Hello" ] unless* ] unit-test
-[ #{ 2 0 } ] [ #{ 3 3 } #{ 1 2 } 2times-succ ] unit-test
-[ #{ 2 1 } ] [ #{ 3 3 } #{ 2 0 } 2times-succ ] unit-test
-[ #{ 2 0 } ] [ #{ 2 2 } #{ 1 1 } 2times-succ ] unit-test
-
-[ #{ 0 0 } #{ 0 1 } #{ 1 0 } #{ 1 1 } ]
-[ #{ 2 2 } [ ] 2times* ] unit-test
-
-[ #{ 0 0 } #{ 0 1 } #{ 0 2 } #{ 1 0 } #{ 1 1 } #{ 1 2 } 
-  #{ 2 0 } #{ 2 1 } #{ 2 2 } ]
-[ #{ 3 3 } [ ] 2times* ] unit-test

library/test/files.factor

@@ -1,5 +1,6 @@
 IN: scratchpad
 USE: files
+USE: lists
 USE: test
 
 [ "txt" ] [ "foo.txt" file-extension ] unit-test
@@ -7,3 +8,10 @@ USE: test
 [ "txt" ] [ "foo.bar.txt" file-extension ] unit-test
 [ "text/plain" ] [ "foo.bar.txt" mime-type ] unit-test
 [ "text/html" ] [ "index.html" mime-type ] unit-test
+
+! Some tests to ensure these words simply work, since we can't
+! really test them
+
+[ t ] [ cwd directory list? ] unit-test
+
+cwd directory.

library/test/stream.factor

@@ -0,0 +1,23 @@
+IN: scratchpad
+USE: namespaces
+USE: streams
+USE: stdio
+USE: test
+
+
+[ "xyzzy" ] [ [ "xyzzy" write ] with-string ] unit-test
+
+[
+    "<xyzzy>"
+] [
+    [
+        [
+            "stdio" get <extend-stream> [
+                [ "<" write write ">" write ] "fwrite" set
+                [ "<" write write ">" print ] "fprint" set
+            ] extend "stdio" set
+            
+            "xyzzy" write
+        ] with-scope
+    ] with-string
+] unit-test

library/test/test.factor

@@ -89,6 +89,7 @@ USE: unparser
         "math/bignum"
         "math/bitops"
         "math/gcd"
+        "math/math-combinators"
         "math/rational"
         "math/float"
         "math/complex"

library/test/x86-compiler/ifte.factor

@@ -80,6 +80,10 @@ DEFER: countdown-b
 [ 64 f ] [ f 4 dummy-when-4 ] unit-test
 [ f t ] [ t f dummy-when-4 ] unit-test
 
+: dummy-when-5 f [ dup fixnum* ] when ; compiled
+
+[ f ] [ f dummy-when-5 ] unit-test
+
 : dummy-unless-1 t [ ] unless ; compiled
 
 [ ] [ dummy-unless-1 ] unit-test

native/error.c

@@ -35,6 +35,11 @@ void throw_error(CELL error)
 	siglongjmp(toplevel,1);
 }
 
+void primitive_throw(void)
+{
+	throw_error(dpop());
+}
+
 void general_error(CELL error, CELL tagged)
 {
 	CELL c = cons(error,cons(tagged,F));

native/error.h

@@ -20,4 +20,5 @@ void fix_stacks(void);
 void throw_error(CELL object);
 void general_error(CELL error, CELL tagged);
 void type_error(CELL type, CELL tagged);
+void primitive_throw(void);
 void range_error(CELL tagged, CELL index, CELL max);

native/primitives.c

@@ -194,7 +194,8 @@ XT primitives[] = {
 	primitive_set_alien_2,
 	primitive_alien_1,
 	primitive_set_alien_1,
-	primitive_heap_stats
+	primitive_heap_stats,
+	primitive_throw
 };
 
 CELL primitive_to_xt(CELL primitive)

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 194
+#define PRIMITIVE_COUNT 195
 
 CELL primitive_to_xt(CELL primitive);