throw is primitive in CFactor, working on test suite

diff --git a/Makefile b/Makefile
index 249cb0ef0a603699b81016283a800bea7194f451..54450585aedb2dcc27ae95e41e95d6f6ceb42921 100644 (file)
--- a/Makefile
+++ b/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
 

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 21e3ac3c57cfcc5c0a8d35f9a5735148e834ef3b..2b8a806a7d3eff5f0b2be9748e8be88327abea83 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -7,7 +7,9 @@ FFI:
 \r
 - compiled? messy\r
 - compiler: drop literal peephole optimization\r
-- compiler: arithmetic-type { ... } execute\r
+- compiling when*\r
+- compiling unless*\r
+- eliminate uses of 2dip\r
 - getenv/setenv: if literal arg, compile as a load/store\r
 - inline words\r
 \r

diff --git a/factor/FactorScanner.java b/factor/FactorScanner.java
index 64e6618e3f36d340255d6d45e119c6bb3bf126d1..8999db4288d8fa14cae28885665cdf222ff073a7 100644 (file)
--- a/factor/FactorScanner.java
+++ b/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;

diff --git a/factor/FactorWord.java b/factor/FactorWord.java
index 0872672ffeab73ab698afbbaea7d2d8a148a6640..c2a00a6608950d13768cf95d3fcf96e86ef01134 100644 (file)
--- a/factor/FactorWord.java
+++ b/factor/FactorWord.java
@@ -198,7 +198,6 @@ public class FactorWord implements FactorExternalizable, FactorObject
        //{{{ toString() method
        public String toString()
        {
-               return name == null ? "#<unnamed>"
-                       : FactorReader.charsToEscapes(name);
+               return name == null ? "#<unnamed>" : name;
        } //}}}
 }

diff --git a/factor/parser/CharLiteral.java b/factor/parser/CharLiteral.java
index f2b2e1c6ae25d3c9191e7fa64aae4b2cd4396d50..385d25af04aedf669aeabf0b39319184986ff211 100644 (file)
--- a/factor/parser/CharLiteral.java
+++ b/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);
-               if(word.length() != 1)
-                       reader.error("Bad character literal: " + word);
-               reader.append(new Character(word.charAt(0)));
+               FactorScanner scanner = reader.getScanner();
+               scanner.skipWhitespace();
+               char ch = scanner.readNonEOFEscaped();
+               reader.append(new Character(ch));
        }
 }

diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index 8a8d044dfe723427cb83807b0a1c61ca8f13e61c..641fe58fac5f8f5534f4ecb0b2959d3fcbad5174 100644 (file)
--- a/library/compiler/compiler.factor
+++ b/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 [
-        nip
-    ] [
-        drop word-xt
-    ] ifte ;
+    dup compiled-xts get assoc [ nip ] [ 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? [
-        drop
-    ] [
-        t over "compiled" set-word-property compile-words cons@
+    dup compiled? [ drop ] [
+        t over "compiled" set-word-property
+        compile-words unique@
     ] 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 ( -- )

diff --git a/library/compiler/ifte.factor b/library/compiler/ifte.factor
index f91ad58ed2d1286afc89798aec17a1e8951d5620..84ae87e4867c53a3982d2b7340b79711971a46dd 100644 (file)
--- a/library/compiler/ifte.factor
+++ b/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

diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index cae355d0c8ea9b01015f3d334e99001c6ed858d2..9fedfa7f9eb8a80cc89a717a2a9a7316d4a9b070 100644 (file)
--- a/library/cross-compiler.factor
+++ b/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 ;

diff --git a/library/errors.factor b/library/errors.factor
index d68c5a812b5f8ac5c8bc65823a88ac49e96ebb72..b0597d82cca26d5f69028cf2f486b1559d02ea0f 100644 (file)
--- a/library/errors.factor
+++ b/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 ;

diff --git a/library/platform/jvm/errors.factor b/library/platform/jvm/errors.factor
index 7c03e4723388a58dc6e0cfe29af697d42654a4b2..9b19d45b13fe94c6dc8589e79127ef58d57eef19 100644 (file)
--- a/library/platform/jvm/errors.factor
+++ b/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 ;

diff --git a/library/platform/native/init-stage2.factor b/library/platform/native/init-stage2.factor
index 4c9c08f9948bdef8c2a802c49476602b7d72f909..e69d25f0fad55d557dbd36401eb582b460701f5d 100644 (file)
--- a/library/platform/native/init-stage2.factor
+++ b/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

diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor
index 63d719254c347dc8f39112b2b309f353c3250606..56864b9b93e97634e99e5fd5e44cd36fc20c9a8f 100644 (file)
--- a/library/platform/native/primitives.factor
+++ b/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

diff --git a/library/test/combinators.factor b/library/test/combinators.factor
index 2a733d55a32035ebd3e2a6126f238bc1344104cb..5d977e495b24ca81fffe04a75babc3829651c2db 100644 (file)
--- a/library/test/combinators.factor
+++ b/library/test/combinators.factor
@@ -5,21 +5,17 @@ USE: math
 USE: stack
 USE: test
 
-[   ] [ 3 [ ] cond ] unit-test
-[ t ] [ 4 [ [ 1 = ] [ ] [ 4 = ] [ drop t ] [ 2 = ] [ ] ] cond ] unit-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
 
-[ 0 1 2 3 4 ] [ 5 [ ] times* ] unit-test
-[ ] [ 0 [ ] times* ] unit-test
+[ 6 ] [ 2 [ sq ] keep + ] unit-test
 
-[ #{ 1 1 } ] [ #{ 2 3 } #{ 1 0 } 2times-succ ] unit-test
-[ #{ 1 2 } ] [ #{ 2 3 } #{ 1 1 } 2times-succ ] 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
+[   ] [ 3 [ ] cond ] unit-test
+[ t ] [ 4 [ [ 1 = ] [ ] [ 4 = ] [ drop t ] [ 2 = ] [ ] ] cond ] unit-test
 
-[ #{ 0 0 } #{ 0 1 } #{ 1 0 } #{ 1 1 } ]
-[ #{ 2 2 } [ ] 2times* ] unit-test
+[ 0 ] [ f [ sq ] [ 0 ] ifte* ] unit-test
+[ 4 ] [ 2 [ sq ] [ 0 ] ifte* ] 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
+[ 0 ] [ f [ 0 ] unless* ] unit-test
+[ t ] [ t [ "Hello" ] unless* ] unit-test

diff --git a/library/test/files.factor b/library/test/files.factor
index fad63a77d4cd6b3e681b978ace7cfd58923e7ad8..0a76f11be902cdc7d17c590ab6156df54666e391 100644 (file)
--- a/library/test/files.factor
+++ b/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.

diff --git a/library/test/stream.factor b/library/test/stream.factor
new file mode 100644 (file)
index 0000000..6e7f3af
--- /dev/null
+++ b/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

diff --git a/library/test/test.factor b/library/test/test.factor
index 91fea93009e414f7a0dc1f7718086d70695d094b..c2908d4a17b14aa53b82ac12f3777f7bb5ca9a7f 100644 (file)
--- a/library/test/test.factor
+++ b/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"

diff --git a/library/test/x86-compiler/ifte.factor b/library/test/x86-compiler/ifte.factor
index f0f9bca13b230d02c1a65b1834f04acc8f598068..cd128f6fde6c77ba91f07d17200b00a035136309 100644 (file)
--- a/library/test/x86-compiler/ifte.factor
+++ b/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

diff --git a/native/error.c b/native/error.c
index 2cf1a4607769c7a20396ecec244ca4ba1408a907..942e763ebca352bca86f884aa5e5ee9f8bcb7aa9 100644 (file)
--- a/native/error.c
+++ b/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));

diff --git a/native/error.h b/native/error.h
index 95113e9d4e3d05f04ded3c61ba415b122741109a..24f1e56d1a8ee074c434f9e4ad8af40ec3225498 100644 (file)
--- a/native/error.h
+++ b/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);

diff --git a/native/primitives.c b/native/primitives.c
index 9d9fea979dc211f3787dab28c6d33f6a37d7c0ee..eb78b59241a7fcc59dd2077606d759842d6d398a 100644 (file)
--- a/native/primitives.c
+++ b/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)

diff --git a/native/primitives.h b/native/primitives.h
index fcaddc66ee1bd273e0eb4fe84adede44e7612a65..ea9414b4d834b39076a8fcf72cca1bf3d0672f31 100644 (file)
--- a/native/primitives.h
+++ b/native/primitives.h
@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 194
+#define PRIMITIVE_COUNT 195
 
 CELL primitive_to_xt(CELL primitive);