From c70b0cecf5e19bce567296655add654fc7adaee6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Oct 2004 20:07:48 +0000 Subject: [PATCH] throw is primitive in CFactor, working on test suite --- Makefile | 6 +-- TODO.FACTOR.txt | 4 +- factor/FactorScanner.java | 52 +++++++++++++++++++--- factor/FactorWord.java | 3 +- factor/parser/CharLiteral.java | 8 ++-- library/compiler/compiler.factor | 35 ++++++++------- library/compiler/ifte.factor | 4 +- library/cross-compiler.factor | 2 + library/errors.factor | 2 - library/platform/jvm/errors.factor | 9 ++++ library/platform/native/init-stage2.factor | 5 ++- library/platform/native/primitives.factor | 2 + library/test/combinators.factor | 24 +++++----- library/test/files.factor | 8 ++++ library/test/stream.factor | 23 ++++++++++ library/test/test.factor | 1 + library/test/x86-compiler/ifte.factor | 4 ++ native/error.c | 5 +++ native/error.h | 1 + native/primitives.c | 3 +- native/primitives.h | 2 +- 21 files changed, 148 insertions(+), 55 deletions(-) create mode 100644 library/test/stream.factor diff --git a/Makefile b/Makefile index 249cb0ef0a..54450585ae 100644 --- 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 21e3ac3c57..2b8a806a7d 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/factor/FactorScanner.java b/factor/FactorScanner.java index 64e6618e3f..8999db4288 100644 --- 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 0872672ffe..c2a00a6608 100644 --- 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 ? "#" - : FactorReader.charsToEscapes(name); + return name == null ? "#" : name; } //}}} } diff --git a/factor/parser/CharLiteral.java b/factor/parser/CharLiteral.java index f2b2e1c6ae..385d25af04 100644 --- 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 8a8d044dfe..641fe58fac 100644 --- 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 f91ad58ed2..84ae87e486 100644 --- 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 cae355d0c8..9fedfa7f9e 100644 --- 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 d68c5a812b..b0597d82cc 100644 --- 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 7c03e47233..9b19d45b13 100644 --- 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 4c9c08f994..e69d25f0fa 100644 --- 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- CLI switch diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor index 63d719254c..56864b9b93 100644 --- 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 2a733d55a3..5d977e495b 100644 --- a/library/test/combinators.factor +++ b/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 [ ] times* ] unit-test +[ 0 ] [ f [ sq ] [ 0 ] ifte* ] unit-test +[ 4 ] [ 2 [ sq ] [ 0 ] ifte* ] 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 - -[ #{ 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 +[ 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 fad63a77d4..0a76f11be9 100644 --- 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 index 0000000000..6e7f3af1e9 --- /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 + +[ + "" +] [ + [ + [ + "stdio" get [ + [ "<" 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 91fea93009..c2908d4a17 100644 --- 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 f0f9bca13b..cd128f6fde 100644 --- 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 2cf1a46077..942e763ebc 100644 --- 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 95113e9d4e..24f1e56d1a 100644 --- 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 9d9fea979d..eb78b59241 100644 --- 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 fcaddc66ee..ea9414b4d8 100644 --- 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);