diff --git a/Makefile b/Makefile index 5e1a9d6220..05a185f643 100755 --- a/Makefile +++ b/Makefile @@ -65,6 +65,7 @@ default: @echo "solaris-x86-64" @echo "wince-arm" @echo "winnt-x86-32" + @echo "winnt-x86-64" @echo "" @echo "Additional modifiers:" @echo "" @@ -125,6 +126,9 @@ solaris-x86-64: winnt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 +winnt-x86-64: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 + wince-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm @@ -151,7 +155,7 @@ clean: rm -f factor*.dll libfactor*.* vm/resources.o: - windres vm/factor.rs vm/resources.o + $(WINDRES) vm/factor.rs vm/resources.o .c.o: $(CC) -c $(CFLAGS) -o $@ $< diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index d5133753c1..74c94c8edf 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -14,7 +14,7 @@ prettyprint ; ! Testing the various bignum accessor 10 "dump" set -[ "dump" get alien-address ] unit-test-fails +[ "dump" get alien-address ] must-fail [ 123 ] [ 123 "dump" get 0 set-alien-signed-1 @@ -61,9 +61,9 @@ cell 8 = [ [ ] [ 0 F{ 1 2 3 } drop ] unit-test [ ] [ 0 ?{ t f t } drop ] unit-test -[ 0 B{ 1 2 3 } alien-address ] unit-test-fails +[ 0 B{ 1 2 3 } alien-address ] must-fail -[ 1 1 ] unit-test-fails +[ 1 1 ] must-fail [ f ] [ 0 B{ 1 2 3 } pinned-c-ptr? ] unit-test diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 3148b85782..719068e031 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } -] unit-test-fails +] must-fail diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor index 3ff81fda72..e07f192197 100755 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -2,10 +2,10 @@ USING: arrays kernel sequences sequences.private growable tools.test vectors layouts system math vectors.private ; IN: temporary -[ -2 { "a" "b" "c" } nth ] unit-test-fails -[ 10 { "a" "b" "c" } nth ] unit-test-fails -[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails -[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails +[ -2 { "a" "b" "c" } nth ] must-fail +[ 10 { "a" "b" "c" } nth ] must-fail +[ "hi" -2 { "a" "b" "c" } set-nth ] must-fail +[ "hi" 10 { "a" "b" "c" } set-nth ] must-fail [ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test [ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test [ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test @@ -17,5 +17,5 @@ IN: temporary [ { "a" "b" "c" "d" "e" } ] [ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test -[ -1 f ] unit-test-fails -[ cell-bits cell log2 - 2^ f ] unit-test-fails +[ -1 f ] must-fail +[ cell-bits cell log2 - 2^ f ] must-fail diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index f605eba24c..5f89b90608 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -51,4 +51,4 @@ IN: temporary [ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test -[ -10 ?{ } resize-bit-array ] unit-test-fails +[ -10 ?{ } resize-bit-array ] must-fail diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 1a9bdd599a..9dd56c6524 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -8,25 +8,63 @@ definitions assocs compiler.errors compiler.units math.parser generic ; IN: bootstrap.stage2 +SYMBOL: bootstrap-time + +: default-image-name ( -- string ) + vm file-name windows? [ "." split1 drop ] when + ".image" append ; + +: do-crossref ( -- ) + "Cross-referencing..." print flush + H{ } clone crossref set-global + xref-words + xref-generics + xref-sources ; + +: load-components ( -- ) + "exclude" "include" + [ get-global " " split [ empty? not ] subset ] 2apply + seq-diff + [ "bootstrap." swap append require ] each ; + +: compile-remaining ( -- ) + "Compiling remaining words..." print flush + vocabs [ + words "compile" "compiler" lookup execute + ] each ; + +: count-words ( pred -- ) + all-words swap subset length number>string write ; + +: print-report ( time -- ) + 1000 /i + 60 /mod swap + "Bootstrap completed in " write number>string write + " minutes and " write number>string write " seconds." print + + [ compiled? ] count-words " compiled words" print + [ symbol? ] count-words " symbol words" print + [ ] count-words " words total" print + + "Bootstrapping is complete." print + "Now, you can run Factor:" print + vm write " -i=" write "output-image" get print flush ; + ! Wrap everything in a catch which starts a listener so ! you can see what went wrong, instead of dealing with a ! fep [ - vm file-name windows? [ "." split1 drop ] when - ".image" append "output-image" set-global + ! We time bootstrap + millis >r + + default-image-name "output-image" set-global "math help compiler tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line - "-no-crossref" cli-args member? [ - "Cross-referencing..." print flush - H{ } clone crossref set-global - xref-words - xref-generics - xref-sources - ] unless + "-no-crossref" cli-args member? [ do-crossref ] unless ! Set dll paths wince? [ "windows.ce" require ] when @@ -40,19 +78,12 @@ IN: bootstrap.stage2 ] if [ - "exclude" "include" - [ get-global " " split [ empty? not ] subset ] 2apply - seq-diff - [ "bootstrap." swap append require ] each + load-components run-bootstrap-init - "Compiling remaining words..." print flush - "bootstrap.compiler" vocab [ - vocabs [ - words "compile" "compiler" lookup execute - ] each + compile-remaining ] when ] with-compiler-errors :errors @@ -74,16 +105,8 @@ IN: bootstrap.stage2 ] [ print-error 1 exit ] recover ] set-boot-quot - : count-words ( pred -- ) - all-words swap subset length number>string write ; - - [ compiled? ] count-words " compiled words" print - [ symbol? ] count-words " symbol words" print - [ ] count-words " words total" print - - "Bootstrapping is complete." print - "Now, you can run Factor:" print - vm write " -i=" write "output-image" get print flush + millis r> - dup bootstrap-time set-global + print-report "output-image" get resource-path save-image-and-exit ] if diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index b39551eb86..b5b01c201b 100755 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -5,4 +5,4 @@ USING: tools.test byte-arrays ; [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test -[ -10 B{ } resize-byte-array ] unit-test-fails +[ -10 B{ } resize-byte-array ] must-fail diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 854e6add5a..c7024a7490 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ; [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test [ "union-1" ] [ 8 generic-update-test ] unit-test -[ -7 generic-update-test ] unit-test-fails +[ -7 generic-update-test ] must-fail ! Test mixins MIXIN: sequence-mixin @@ -169,10 +169,14 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; UNION: forget-class-bug-1 integer ; UNION: forget-class-bug-2 forget-class-bug-1 dll ; -FORGET: forget-class-bug-1 -FORGET: forget-class-bug-2 +[ + \ forget-class-bug-1 forget + \ forget-class-bug-2 forget +] with-compilation-unit -[ t ] [ integer dll class-or interned? ] unit-test +[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test + +[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test DEFER: mixin-forget-test-g @@ -191,7 +195,7 @@ DEFER: mixin-forget-test-g ] unit-test [ { } ] [ { } mixin-forget-test-g ] unit-test -[ H{ } mixin-forget-test-g ] unit-test-fails +[ H{ } mixin-forget-test-g ] must-fail [ ] [ { @@ -205,7 +209,7 @@ DEFER: mixin-forget-test-g parse-stream drop ] unit-test -[ { } mixin-forget-test-g ] unit-test-fails +[ { } mixin-forget-test-g ] must-fail [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test ! Method flattening interfered with mixin update diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 208f8c0c84..3cefda7f71 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -38,7 +38,7 @@ namespaces combinators words ; ! Interpreted [ "two" ] [ 2 \ case-test-1 word-def call ] unit-test -[ "x" case-test-1 ] unit-test-fails +[ "x" case-test-1 ] must-fail : case-test-2 { diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index 9416fd1415..dbdbbfc9fa 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -13,7 +13,7 @@ FUNCTION: int ffi_test_1 ; FUNCTION: int ffi_test_2 int x int y ; [ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "hi" 3 ffi_test_2 ] unit-test-fails +[ "hi" 3 ffi_test_2 ] must-fail FUNCTION: int ffi_test_3 int x int y int z int t ; [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test @@ -26,8 +26,8 @@ FUNCTION: double ffi_test_5 ; FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test -[ "a" 2 3 4 5 6 7 ffi_test_9 ] unit-test-fails -[ 1 2 3 4 5 6 "a" ffi_test_9 ] unit-test-fails +[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail C-STRUCT: foo { "int" "x" } @@ -53,7 +53,7 @@ FUNCTION: char* ffi_test_15 char* x char* y ; [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test -[ 1 2 ffi_test_15 ] unit-test-fails +[ 1 2 ffi_test_15 ] must-fail C-STRUCT: bar { "long" "x" } @@ -75,7 +75,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test -[ t ] [ [ [ alien-indirect ] infer ] catch inference-error? ] unit-test +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with : indirect-test-1 "int" { } "cdecl" alien-indirect ; @@ -84,7 +84,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test -[ -1 indirect-test-1 ] unit-test-fails +[ -1 indirect-test-1 ] must-fail : indirect-test-2 "int" { "int" "int" } "cdecl" alien-indirect data-gc ; @@ -120,7 +120,7 @@ unit-test FUNCTION: double ffi_test_6 float x float y ; [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test -[ "a" "b" ffi_test_6 ] unit-test-fails +[ "a" "b" ffi_test_6 ] must-fail FUNCTION: double ffi_test_7 double x double y ; [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test @@ -157,7 +157,7 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ; [ 987655432 ] [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test -[ 1111 f 123456789 ffi_test_22 ] unit-test-fails +[ 1111 f 123456789 ffi_test_22 ] must-fail C-STRUCT: rect { "float" "x" } @@ -177,7 +177,7 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] unit-test-fails +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; @@ -292,7 +292,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; [ ] [ callback-1 callback_test_1 ] unit-test -: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ; +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; [ ] [ callback-2 callback_test_1 ] unit-test diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 1d0ad141c2..679938b7f3 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -422,11 +422,11 @@ cell 8 = [ [ B{ 0 0 0 0 } [ { byte-array } declare ] compile-call -] unit-test-fails +] must-fail [ B{ 0 0 0 0 } [ { c-ptr } declare ] compile-call -] unit-test-fails +] must-fail [ 4 5 diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index b59c0d5f33..7ee4ebfd1c 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private -continuations ; +continuations growable ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -136,7 +136,7 @@ TUPLE: pred-test ; GENERIC: void-generic ( obj -- * ) : breakage "hi" void-generic ; [ t ] [ \ breakage compiled? ] unit-test -[ breakage ] unit-test-fails +[ breakage ] must-fail ! regression : test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline @@ -247,7 +247,7 @@ M: slice foozul ; GENERIC: detect-number ( obj -- obj ) M: number detect-number ; -[ 10 f [ 0 + detect-number ] compile-call ] unit-test-fails +[ 10 f [ 0 + detect-number ] compile-call ] must-fail ! Regression [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test @@ -291,3 +291,12 @@ TUPLE: silly-tuple a b ; : construct-empty-bug construct-empty ; [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method method-word flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 01dd27f8be..ab472668c3 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -92,8 +92,6 @@ DEFER: x-4 [ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test -[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test - DEFER: g-test-1 DEFER: g-test-3 @@ -237,7 +235,7 @@ DEFER: flushable-test-2 : bx ax ; [ \ bx forget ] with-compilation-unit -[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test +[ f ] [ \ bx \ ax compiled-usage key? ] unit-test DEFER: defer-redefine-test-2 @@ -245,8 +243,45 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test -[ defer-redefine-test-2 ] unit-test-fails +[ defer-redefine-test-2 ] must-fail [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test [ 2 1 ] [ defer-redefine-test-2 ] unit-test + +! Cross-referencing issue +: compiled-xref-a ; + +: compiled-xref-c ; inline + +GENERIC: compiled-xref-b ( a -- b ) + +TUPLE: c-1 ; + +M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ; + +TUPLE: c-2 ; + +M: c-2 compiled-xref-b drop 3 ; + +[ t ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test + +[ ] [ + [ + \ compiled-xref-a forget + ] with-compilation-unit +] unit-test + +[ f ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test + +[ ] [ + "IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval +] unit-test + +[ f ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor index 9f831bb1f8..6f5cb33c1a 100755 --- a/core/compiler/test/simple.factor +++ b/core/compiler/test/simple.factor @@ -57,8 +57,8 @@ IN: temporary ! Make sure error reporting works -[ [ dup ] compile-call ] unit-test-fails -[ [ drop ] compile-call ] unit-test-fails +[ [ dup ] compile-call ] must-fail +[ [ drop ] compile-call ] must-fail ! Regression diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace.factor index 59ee3c3d88..71c95b1b61 100755 --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/test/stack-trace.factor @@ -10,7 +10,7 @@ words splitting ; : foo 3 throw 7 ; : bar foo 4 ; : baz bar 5 ; -[ 3 ] [ [ baz ] catch ] unit-test +[ baz ] [ 3 = ] must-fail-with [ t ] [ symbolic-stack-trace [ word? ] subset @@ -22,11 +22,11 @@ words splitting ; : stack-trace-contains? symbolic-stack-trace memq? ; [ t ] [ - [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains? + [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains? ] unit-test [ t f ] [ - [ { "hi" } bleh ] catch drop + [ { "hi" } bleh ] ignore-errors \ + stack-trace-contains? \ > stack-trace-contains? ] unit-test @@ -34,6 +34,6 @@ words splitting ; : quux [ t [ "hi" throw ] when ] times ; [ t ] [ - [ 10 quux ] catch drop + [ 10 quux ] ignore-errors \ (each-integer) stack-trace-contains? ] unit-test diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 51e461c715..2977d02c6f 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -23,10 +23,9 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"A set of words establish an error handler:" +"Two words for establishing an error handler:" { $subsection cleanup } { $subsection recover } -{ $subsection catch } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -147,12 +146,7 @@ HELP: throw { $values { "error" object } } { $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ; -HELP: catch -{ $values { "try" quotation } { "error/f" object } } -{ $description "Calls the " { $snippet "try" } " quotation. If an error is thrown in the dynamic extent of the quotation, restores the data stack and pushes the error. If the quotation returns successfully, outputs " { $link f } " without restoring the data stack." } -{ $notes "This word cannot differentiate between the case of " { $link f } " being thrown, and no error being thrown. You should never throw " { $link f } ", and you should also use other error handling combinators where possible." } ; - -{ catch cleanup recover } related-words +{ cleanup recover } related-words HELP: cleanup { $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } } @@ -166,7 +160,7 @@ HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } { $notes - "This word is intended to be used in conjunction with " { $link recover } " or " { $link catch } " to implement error handlers which perform an action and pass the error to the next outermost error handler." + "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." } { $examples "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:" diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 360f4750c9..b7d580afe5 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -25,13 +25,11 @@ IN: temporary [ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test [ t ] [ callcc-namespace-test ] unit-test -[ f ] [ [ ] catch ] unit-test - -[ 5 ] [ [ 5 throw ] catch ] unit-test +[ 5 throw ] [ 5 = ] must-fail-with [ t ] [ - [ "Hello" throw ] catch drop - global [ error get ] bind + [ "Hello" throw ] ignore-errors + error get-global "Hello" = ] unit-test @@ -41,13 +39,13 @@ IN: temporary "!!! The following error is part of the test" print -[ [ "2 car" ] eval ] catch print-error +[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test -[ f throw ] unit-test-fails +[ f throw ] must-fail ! Weird PowerPC bug. [ ] [ - [ "4" throw ] catch drop + [ "4" throw ] ignore-errors data-gc data-gc ] unit-test @@ -56,10 +54,10 @@ IN: temporary [ f ] [ { "A" "B" } kernel-error? ] unit-test ! ! See how well callstack overflow is handled -! [ clear drop ] unit-test-fails +! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; -! [ callstack-overflow ] unit-test-fails +! [ callstack-overflow ] must-fail : don't-compile-me { } [ ] each ; @@ -84,24 +82,20 @@ SYMBOL: error-counter [ 1 ] [ always-counter get ] unit-test [ 0 ] [ error-counter get ] unit-test - [ "a" ] [ - [ - [ "a" throw ] - [ always-counter inc ] - [ error-counter inc ] cleanup - ] catch - ] unit-test + [ + [ "a" throw ] + [ always-counter inc ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with [ 2 ] [ always-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test - [ "a" ] [ - [ - [ ] - [ always-counter inc "a" throw ] - [ error-counter inc ] cleanup - ] catch - ] unit-test + [ + [ ] + [ always-counter inc "a" throw ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with [ 3 ] [ always-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 6e4ce16bea..b6ca056691 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces math splitting sorting quotations assocs ; @@ -17,9 +17,6 @@ SYMBOL: restarts : c> ( -- continuation ) catchstack* pop ; -: (catch) ( quot -- newquot ) - [ swap >c call c> drop ] curry ; inline - : dummy ( -- obj ) #! Optimizing compiler assumes stack won't be messed with #! in-transit. To ensure that a value is actually reified @@ -120,11 +117,8 @@ PRIVATE> catchstack* empty? [ die ] when dup save-error c> continue-with ; -: catch ( try -- error/f ) - (catch) [ f ] compose callcc1 ; inline - : recover ( try recovery -- ) - >r (catch) r> ifcc ; inline + >r [ swap >c call c> drop ] curry r> ifcc ; inline : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor index afadaac0db..0e0ab3feb6 100755 --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -7,4 +7,4 @@ USING: float-arrays tools.test ; [ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test -[ -10 F{ } resize-float-array ] unit-test-fails +[ -10 F{ } resize-float-array ] must-fail diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3d66241bc3..3883fb6e35 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -3,8 +3,9 @@ USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel -kernel.private layouts math namespaces optimizer prettyprint -quotations sequences system threads words vectors ; +kernel.private layouts math namespaces optimizer +optimizer.specializers prettyprint quotations sequences system +threads words vectors ; IN: generator SYMBOL: compile-queue diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f1e1ebd6d2..e3fdbc7b46 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -16,7 +16,7 @@ M: word class-of drop "word" ; [ "fixnum" ] [ 5 class-of ] unit-test [ "word" ] [ \ class-of class-of ] unit-test -[ 3.4 class-of ] unit-test-fails +[ 3.4 class-of ] must-fail [ "Hello world" ] [ 4 foobar foobar ] unit-test [ "Goodbye cruel world" ] [ 4 foobar ] unit-test @@ -90,7 +90,7 @@ M: number union-containment drop 2 ; "IN: temporary GENERIC: unhappy ( x -- x )" eval [ "IN: temporary M: dictionary unhappy ;" eval -] unit-test-fails +] must-fail [ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) @@ -155,9 +155,7 @@ M: string my-hook "a string" ; [ "an integer" ] [ 3 my-var set my-hook ] unit-test [ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ T{ no-method f 1.0 my-hook } ] [ - 1.0 my-var set [ my-hook ] catch -] unit-test +[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with GENERIC: tag-and-f ( x -- x x ) @@ -203,3 +201,40 @@ TUPLE: redefinition-test-tuple ; redefinition-test-generic , ] { } make all-equal? ] unit-test + +! Issues with forget +GENERIC: generic-forget-test-1 + +M: integer generic-forget-test-1 / ; + +[ t ] [ + \ / usage [ word? ] subset + [ word-name "generic-forget-test-1/integer" = ] contains? +] unit-test + +[ ] [ + [ \ generic-forget-test-1 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ / usage [ word? ] subset + [ word-name "generic-forget-test-1/integer" = ] contains? +] unit-test + +GENERIC: generic-forget-test-2 + +M: sequence generic-forget-test-2 = ; + +[ t ] [ + \ = usage [ word? ] subset + [ word-name "generic-forget-test-2/sequence" = ] contains? +] unit-test + +[ ] [ + [ { sequence generic-forget-test-2 } forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ = usage [ word? ] subset + [ word-name "generic-forget-test-2/sequence" = ] contains? +] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 453d72effb..53f47c09d5 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -102,7 +102,9 @@ M: method-spec definition first2 method dup [ method-def ] when ; : forget-method ( class generic -- ) - check-method [ delete-at ] with-methods ; + check-method + [ delete-at* ] with-methods + [ method-word forget ] [ drop ] if ; M: method-spec forget* first2 forget-method ; @@ -145,5 +147,8 @@ M: generic subwords swap "default-method" word-prop add [ method-word ] map ; +M: generic forget-word + dup subwords [ forget-word ] each (forget-word) ; + : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor index 39d8721726..a220ccc45e 100755 --- a/core/growable/growable-tests.factor +++ b/core/growable/growable-tests.factor @@ -9,16 +9,16 @@ IN: temporary ! overflow bugs [ "hi" most-positive-fixnum 2 * 2 + V{ } clone set-nth ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + { 1 } clone nth ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + V{ } clone lengthen ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + V{ } clone set-length ] -unit-test-fails +must-fail [ ] [ 10 V{ } [ set-length ] keep diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 40d079402c..acb05be720 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -127,9 +127,9 @@ H{ } "x" set ! Another crash discovered by erg [ ] [ H{ } clone - [ 1 swap set-at ] catch drop - [ 2 swap set-at ] catch drop - [ 3 swap set-at ] catch drop + [ 1 swap set-at ] ignore-errors + [ 2 swap set-at ] ignore-errors + [ 3 swap set-at ] ignore-errors drop ] unit-test diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index de661fad92..92b06b866c 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -5,8 +5,8 @@ USING: arrays kernel math namespaces tools.test heaps heaps.private ; IN: temporary -[ heap-pop ] unit-test-fails -[ heap-pop ] unit-test-fails +[ heap-pop ] must-fail +[ heap-pop ] must-fail [ t ] [ heap-empty? ] unit-test [ f ] [ 1 t pick heap-push heap-empty? ] unit-test diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3e3858d45d..b43226166a 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -12,14 +12,14 @@ IN: temporary { 1 2 } [ dup ] unit-test-effect { 1 2 } [ [ dup ] call ] unit-test-effect -[ [ call ] infer ] unit-test-fails +[ [ call ] infer ] must-fail { 2 4 } [ 2dup ] unit-test-effect { 1 0 } [ [ ] [ ] if ] unit-test-effect -[ [ if ] infer ] unit-test-fails -[ [ [ ] if ] infer ] unit-test-fails -[ [ [ 2 ] [ ] if ] infer ] unit-test-fails +[ [ if ] infer ] must-fail +[ [ [ ] if ] infer ] must-fail +[ [ [ 2 ] [ ] if ] infer ] must-fail { 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect { 4 3 } [ @@ -42,7 +42,7 @@ IN: temporary [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer -] unit-test-fails +] must-fail ! Test inference of termination of control flow : termination-test-1 @@ -54,10 +54,10 @@ IN: temporary : infinite-loop infinite-loop ; -[ [ infinite-loop ] infer ] unit-test-fails +[ [ infinite-loop ] infer ] must-fail : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ; -[ [ no-base-case-1 ] infer ] unit-test-fails +[ [ no-base-case-1 ] infer ] must-fail : simple-recursion-1 ( obj -- obj ) dup [ simple-recursion-1 ] [ ] if ; @@ -72,7 +72,7 @@ IN: temporary : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; -[ [ bad-recursion-2 ] infer ] unit-test-fails +[ [ bad-recursion-2 ] infer ] must-fail : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; @@ -192,7 +192,7 @@ DEFER: blah4 [ swap slip ] keep swap bad-combinator ] if ; inline -[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails +[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail ! Regression : bad-input# @@ -207,13 +207,13 @@ DEFER: blah4 DEFER: do-crap : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ; : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ; -[ [ do-crap ] infer ] unit-test-fails +[ [ do-crap ] infer ] must-fail ! This one does not DEFER: do-crap* : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ; : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ; -[ [ do-crap* ] infer ] unit-test-fails +[ [ do-crap* ] infer ] must-fail ! Regression : too-deep ( a b -- c ) @@ -226,7 +226,7 @@ M: fixnum xyz 2array ; M: float xyz [ 3 ] 2apply swapd >r 2array swap r> 2array swap ; -[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test +[ [ xyz ] infer ] [ inference-error? ] must-fail-with ! Doug Coleman discovered this one while working on the ! calendar library @@ -277,78 +277,66 @@ DEFER: #1 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; -[ \ #4 word-def infer ] unit-test-fails -[ [ #1 ] infer ] unit-test-fails +[ \ #4 word-def infer ] must-fail +[ [ #1 ] infer ] must-fail ! Similar DEFER: bar : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ; : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ; -[ [ foo ] infer ] unit-test-fails +[ [ foo ] infer ] must-fail -[ 1234 infer ] unit-test-fails +[ 1234 infer ] must-fail ! This used to hang -[ t ] [ - [ [ [ dup call ] dup call ] infer ] catch - inference-error? -] unit-test +[ [ [ dup call ] dup call ] infer ] +[ inference-error? ] must-fail-with : m dup call ; inline -[ t ] [ - [ [ [ m ] m ] infer ] catch inference-error? -] unit-test +[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with : m' dup curry call ; inline -[ t ] [ - [ [ [ m' ] m' ] infer ] catch inference-error? -] unit-test +[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with : m'' [ dup curry ] ; inline : m''' m'' call call ; inline -[ t ] [ - [ [ [ m''' ] m''' ] infer ] catch inference-error? -] unit-test +[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with : m-if t over if ; inline -[ t ] [ - [ [ [ m-if ] m-if ] infer ] catch inference-error? -] unit-test +[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with ! This doesn't hang but it's also an example of the ! undedicable case -[ t ] [ - [ [ [ [ drop 3 ] swap call ] dup call ] infer ] catch - inference-error? -] unit-test +[ [ [ [ drop 3 ] swap call ] dup call ] infer ] +[ inference-error? ] must-fail-with ! This form should not have a stack effect : bad-recursion-1 ( a -- b ) dup [ drop bad-recursion-1 5 ] [ ] if ; -[ [ bad-recursion-1 ] infer ] unit-test-fails +[ [ bad-recursion-1 ] infer ] must-fail : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ [ bad-bin ] infer ] unit-test-fails +[ [ bad-bin ] infer ] must-fail -[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test +[ [ r> ] infer ] [ inference-error? ] must-fail-with ! Regression -[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test +[ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect { 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect -[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails +[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail ! Test number protocol \ bitor must-infer @@ -459,7 +447,7 @@ DEFER: bar : fooxxx ( a b -- c ) over [ foo ] when ; inline : barxxx fooxxx ; -[ [ barxxx ] infer ] unit-test-fails +[ [ barxxx ] infer ] must-fail ! A typo { 1 0 } [ { [ ] } dispatch ] unit-test-effect diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 152da8c757..f58e557b10 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ; : set-slots-test-2 { set-a-tuple-x set-a-tuple-x } set-slots ; -[ [ set-slots-test-2 ] infer ] unit-test-fails +[ [ set-slots-test-2 ] infer ] must-fail diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor index 962a46413f..44542e05ce 100755 --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -28,13 +28,13 @@ M: unclosable-stream dispose [ t ] [ [ - [ dup dispose ] catch 2drop + [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test [ t ] [ [ - [ dup dispose ] catch 2drop + [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index c294c23738..e37b208ef0 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -7,25 +7,22 @@ IN: temporary [ t ] [ [ \ = \ = ] all-equal? ] unit-test ! Don't leak extra roots if error is thrown -[ ] [ 10000 [ [ 3 throw ] catch drop ] times ] unit-test +[ ] [ 10000 [ [ 3 throw ] ignore-errors ] times ] unit-test -[ ] [ 10000 [ [ -1 f ] catch drop ] times ] unit-test +[ ] [ 10000 [ [ -1 f ] ignore-errors ] times ] unit-test ! Make sure we report the correct error on stack underflow -[ { "kernel-error" 11 f f } ] -[ [ clear drop ] catch ] unit-test +[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with [ ] [ :c ] unit-test -[ { "kernel-error" 13 f f } ] -[ [ { } set-retainstack r> ] catch ] unit-test +[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with [ ] [ :c ] unit-test : overflow-d 3 overflow-d ; -[ { "kernel-error" 12 f f } ] -[ [ overflow-d ] catch ] unit-test +[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -33,24 +30,17 @@ IN: temporary : overflow-d-alt (overflow-d-alt) overflow-d-alt ; -[ { "kernel-error" 12 f f } ] -[ [ overflow-d-alt ] catch ] unit-test +[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] string-out drop ] unit-test : overflow-r 3 >r overflow-r ; -[ { "kernel-error" 14 f f } ] -[ [ overflow-r ] catch ] unit-test +[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test -! : overflow-c overflow-c 3 ; -! -! [ { "kernel-error" 16 f f } ] -! [ [ overflow-c ] catch ] unit-test - -[ -7 ] unit-test-fails +[ -7 ] must-fail [ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test [ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test @@ -61,27 +51,27 @@ IN: temporary [ 4 ] [ 4 6 or ] unit-test [ 6 ] [ f 6 or ] unit-test -[ slip ] unit-test-fails +[ slip ] must-fail [ ] [ :c ] unit-test -[ 1 slip ] unit-test-fails +[ 1 slip ] must-fail [ ] [ :c ] unit-test -[ 1 2 slip ] unit-test-fails +[ 1 2 slip ] must-fail [ ] [ :c ] unit-test -[ 1 2 3 slip ] unit-test-fails +[ 1 2 3 slip ] must-fail [ ] [ :c ] unit-test [ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test -[ [ ] keep ] unit-test-fails +[ [ ] keep ] must-fail [ 6 ] [ 2 [ sq ] keep + ] unit-test -[ [ ] 2keep ] unit-test-fails -[ 1 [ ] 2keep ] unit-test-fails +[ [ ] 2keep ] must-fail +[ 1 [ ] 2keep ] must-fail [ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test [ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test @@ -100,13 +90,13 @@ IN: temporary [ ] [ callstack set-callstack ] unit-test -[ 3drop datastack ] unit-test-fails +[ 3drop datastack ] must-fail [ ] [ :c ] unit-test ! Doesn't compile; important : foo 5 + 0 [ ] each ; -[ drop foo ] unit-test-fails +[ drop foo ] must-fail [ ] [ :c ] unit-test ! Regression @@ -117,4 +107,4 @@ IN: temporary : loop ( obj obj -- ) H{ } values swap >r dup length swap r> 0 -roll (loop) ; -[ loop ] unit-test-fails +[ loop ] must-fail diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 626c2b3e06..4570b1162a 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -22,7 +22,7 @@ IN: temporary [ "\\ + 1 2 3 4" parse-interactive "cont" get continue-with - ] catch + ] ignore-errors "USE: debugger :1" eval ] callcc1 ] unit-test @@ -36,7 +36,7 @@ IN: temporary [ "USE: vocabs.loader.test.c" parse-interactive -] unit-test-fails +] must-fail [ ] [ [ diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 680119a56e..194edb8f7e 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -121,8 +121,8 @@ unit-test ! We don't care if this fails or returns 0 (its CPU-specific) ! as long as it doesn't crash -[ ] [ [ 0 0 /i ] catch clear ] unit-test -[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test +[ ] [ [ 0 0 /i drop ] ignore-errors ] unit-test +[ ] [ [ 100000000000000000 0 /i drop ] ignore-errors ] unit-test [ -2 ] [ 1 bitnot ] unit-test [ -2 ] [ 1 >bignum bitnot ] unit-test diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 62893e2618..7c30012a19 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -105,6 +105,6 @@ unit-test ! [ dup number>string string>number = ] all? ! ] unit-test -[ 1 1 >base ] unit-test-fails -[ 1 0 >base ] unit-test-fails -[ 1 -1 >base ] unit-test-fails +[ 1 1 >base ] must-fail +[ 1 0 >base ] must-fail +[ 1 -1 >base ] must-fail diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index f543c08744..d0dfd2c0be 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -4,7 +4,7 @@ IN: temporary TUPLE: testing x y z ; -[ save-image-and-exit ] unit-test-fails +[ save-image-and-exit ] must-fail [ ] [ num-types get [ diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 9d75346091..788f862849 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -4,7 +4,7 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables combinators classes generic.math continuations optimizer.def-use -optimizer.pattern-match generic.standard ; +optimizer.pattern-match generic.standard optimizer.specializers ; IN: optimizer.backend SYMBOL: class-substitutions @@ -245,18 +245,32 @@ M: #dispatch optimize-node* : dispatching-class ( node word -- class ) [ dispatch# node-class# ] keep specific-method ; -: flat-length ( seq -- n ) +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + dup get over inline? not or + [ drop 1 ] [ dup dup set word-def (flat-length) ] if ; + +: (flat-length) ( seq -- n ) [ - dup quotation? over array? or - [ flat-length ] [ drop 1 ] if + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond ] map sum ; +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + : will-inline-method ( node word -- method-spec/t quot/t ) #! t indicates failure tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 6 >= + dup flat-length 10 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t @@ -363,7 +377,7 @@ M: #dispatch optimize-node* : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ - >r node-input-classes r> length tail* + >r node-input-classes r> specialized-length tail* [ types length 1 = ] all? ] [ 2drop f diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 6828a0948c..5820d8f5b2 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -124,19 +124,19 @@ float-arrays combinators.private combinators ; ] each \ push-all -{ { string array } { sbuf vector } } +{ { string sbuf } { array vector } } "specializer" set-word-prop \ append -{ { string array } { string array } } +{ { string string } { array array } } "specializer" set-word-prop \ subseq -{ fixnum fixnum { string array } } +{ { fixnum fixnum string } { fixnum fixnum array } } "specializer" set-word-prop \ reverse-here -{ { string array } } +{ { string } { array } } "specializer" set-word-prop \ mismatch @@ -147,9 +147,9 @@ float-arrays combinators.private combinators ; \ >string { sbuf } "specializer" set-word-prop -\ >array { { string vector } } "specializer" set-word-prop +\ >array { { string } { vector } } "specializer" set-word-prop -\ >vector { { array vector } } "specializer" set-word-prop +\ >vector { { array } { vector } } "specializer" set-word-prop \ >sbuf { string } "specializer" set-word-prop @@ -163,6 +163,6 @@ float-arrays combinators.private combinators ; \ assoc-stack { vector } "specializer" set-word-prop -\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop +\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop -\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop +\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop diff --git a/core/optimizer/optimizer-docs.factor b/core/optimizer/optimizer-docs.factor old mode 100644 new mode 100755 index ff694650bc..4be1176cda --- a/core/optimizer/optimizer-docs.factor +++ b/core/optimizer/optimizer-docs.factor @@ -2,31 +2,6 @@ USING: help.markup help.syntax quotations words math sequences ; IN: optimizer -ARTICLE: "specializers" "Word specializers" -"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." -$nl -"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is a sequence having the same number of elements as the word has inputs; each element takes one of the following forms and gives the compiler a hint about the corresponding parameter:" -{ $table - { { $snippet { $emphasis "class" } } { "a class word indicates that this parameter is expected to be an instance of the class most of the time." } } - { { $snippet "{ " { $emphasis "classes..." } " }" } { "a sequence of class words indicates that this parameter is expected to be an instance of one of these classes most of the time." } } - { { $snippet "number" } { "the " { $link number } " class word has a special behavior. It will result in a version of the word being generated for every primitive numeric type, where this parameter is assumed to have that type. A fast jump table will then determine which version is chosen at run time." } } - { { $snippet "*" } { "indicates no specialization should be performed on this parameter." } } -} -"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place." -$nl -"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information." -$nl -"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class." -$nl -"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" -{ $code -"\\ append" -"{ { string array } { string array } }" -"\"specializer\" set-word-prop" -} -"The specialized version of a word which will be compiled by the compiler can be inspected:" -{ $subsection specialized-def } ; - ARTICLE: "optimizer" "Optimizer" "The words in the " { $vocab-link "optimizer" } " vocabulary are internal to the compiler and user code has no reason to call them." $nl @@ -43,7 +18,3 @@ HELP: optimize-1 HELP: optimize { $values { "node" "a dataflow graph" } { "newnode" "a dataflow graph" } } { $description "Continues to optimize a dataflow graph until a fixed point is reached." } ; - -HELP: specialized-def -{ $values { "word" word } { "quot" quotation } } -{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor old mode 100644 new mode 100755 index 66e4ac9220..219b27197f --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -1,10 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private math -namespaces sequences vectors words strings layouts combinators -combinators.private classes optimizer.backend optimizer.def-use -optimizer.known-words optimizer.math inference.class -generic.standard ; +USING: kernel namespaces optimizer.backend optimizer.def-use +optimizer.known-words optimizer.math inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) @@ -22,39 +19,3 @@ IN: optimizer : optimize ( node -- newnode ) optimize-1 [ optimize ] when ; - -: simple-specializer ( quot dispatch# classes -- quot ) - swap (dispatch#) [ - object add* swap [ 2array ] curry map - object method-alist>quot - ] with-variable ; - -: dispatch-specializer ( quot dispatch# symbol dispatcher -- quot ) - rot (dispatch#) [ - [ - picker % - , - get swap , - \ dispatch , - ] [ ] make - ] with-variable ; - -: tag-specializer ( quot dispatch# -- quot ) - num-tags \ tag dispatch-specializer ; - -: type-specializer ( quot dispatch# -- quot ) - num-types \ type dispatch-specializer ; - -: make-specializer ( quot dispatch# spec -- quot ) - { - { [ dup number eq? ] [ drop tag-specializer ] } - { [ dup object eq? ] [ drop type-specializer ] } - { [ dup \ * eq? ] [ 2drop ] } - { [ dup array? ] [ simple-specializer ] } - { [ t ] [ 1array simple-specializer ] } - } cond ; - -: specialized-def ( word -- quot ) - dup word-def swap "specializer" word-prop [ - [ length ] keep [ make-specializer ] 2each - ] when* ; diff --git a/core/optimizer/specializers/specializers-docs.factor b/core/optimizer/specializers/specializers-docs.factor new file mode 100755 index 0000000000..de5d5d7a1f --- /dev/null +++ b/core/optimizer/specializers/specializers-docs.factor @@ -0,0 +1,26 @@ +IN: optimizer.specializers +USING: help.markup help.syntax sequences words quotations ; + +ARTICLE: "specializers" "Word specializers" +"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." +$nl +"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint." +$nl +"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place." +$nl +"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information." +$nl +"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class." +$nl +"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" +{ $code +"\\ append" +"{ { string string } { array array } }" +"\"specializer\" set-word-prop" +} +"The specialized version of a word which will be compiled by the compiler can be inspected:" +{ $subsection specialized-def } ; + +HELP: specialized-def +{ $values { "word" word } { "quot" quotation } } +{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor new file mode 100755 index 0000000000..223ce18117 --- /dev/null +++ b/core/optimizer/specializers/specializers.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic hashtables kernel kernel.private math +namespaces sequences vectors words strings layouts combinators +combinators.private classes generic.standard assocs ; +IN: optimizer.specializers + +: (make-specializer) ( class picker -- quot ) + swap "predicate" word-prop append ; + +: make-specializer ( classes -- quot ) + dup length + [ (picker) 2array ] 2map + [ drop object eq? not ] assoc-subset + dup empty? [ drop [ t ] ] [ + [ (make-specializer) ] { } assoc>map + unclip [ swap [ f ] \ if 3array append [ ] like ] reduce + ] if ; + +: tag-specializer ( quot -- newquot ) + [ + [ dup tag ] % + num-tags get swap , + \ dispatch , + ] [ ] make ; + +: specialized-def ( word -- quot ) + dup word-def swap "specializer" word-prop [ + dup { number } = [ + drop tag-specializer + ] [ + dup [ array? ] all? [ 1array ] unless [ + [ make-specializer ] keep + [ declare ] curry pick append + ] { } map>assoc + alist>quot + ] if + ] when* ; + +: specialized-length ( specializer -- n ) + dup [ array? ] all? [ first ] when length ; diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d8d6c9b7bc..ae38925c68 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -136,8 +136,6 @@ ARTICLE: "parser-lexer" "The lexer" { $subsection } "A word to test of the end of input has been reached:" { $subsection still-parsing? } -"A word to get the text of the current line:" -{ $subsection line-text } "A word to advance the lexer to the next line:" { $subsection next-line } "Two generic words to override the lexer's token boundary detection:" @@ -222,10 +220,6 @@ HELP: { $values { "msg" "an error" } { "error" parse-error } } { $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; -HELP: line-text -{ $values { "lexer" lexer } { "str" string } } -{ $description "Outputs the text of the line being parsed." } ; - HELP: skip { $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } } { $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index f503528a24..eb04e329d9 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -93,12 +93,12 @@ IN: temporary ! Funny bug [ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test - [ "IN: temporary : missing-- ( a b ) ;" eval ] unit-test-fails + [ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail ! These should throw errors - [ "HEX: zzz" eval ] unit-test-fails - [ "OCT: 999" eval ] unit-test-fails - [ "BIN: --0" eval ] unit-test-fails + [ "HEX: zzz" eval ] must-fail + [ "OCT: 999" eval ] must-fail + [ "BIN: --0" eval ] must-fail ! Another funny bug [ t ] [ @@ -205,12 +205,10 @@ IN: temporary "a" source-files get delete-at - [ t ] [ - [ - "IN: temporary : x ; : y 3 throw ; this is an error" - "a" parse-stream - ] catch parse-error? - ] unit-test + [ + "IN: temporary : x ; : y 3 throw ; this is an error" + "a" parse-stream + ] [ parse-error? ] must-fail-with [ t ] [ "y" "temporary" lookup >boolean @@ -307,62 +305,50 @@ IN: temporary "killer?" "temporary" lookup >boolean ] unit-test - [ t ] [ - [ - "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" - "removing-the-predicate" parse-stream - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "removing-the-predicate" parse-stream + ] [ [ redefine-error? ] is? ] must-fail-with - [ t ] [ - [ - "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" - "redefining-a-class-1" parse-stream - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "redefining-a-class-1" parse-stream + ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" "redefining-a-class-2" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" - "redefining-a-class-3" parse-stream drop - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "redefining-a-class-3" parse-stream drop + ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-fwd-test ;" "redefining-a-class-3" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] catch [ no-word? ] is? - ] unit-test + [ + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] [ [ no-word? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "redefining-a-class-3" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] catch [ no-word? ] is? - ] unit-test + [ + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] [ [ no-word? ] is? ] must-fail-with - [ t ] [ - [ - "IN: temporary : foo ; TUPLE: foo ;" - "redefining-a-class-4" parse-stream drop - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary : foo ; TUPLE: foo ;" + "redefining-a-class-4" parse-stream drop + ] [ [ redefine-error? ] is? ] must-fail-with ] with-file-vocabs [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d7ad47843..59d18dc734 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -8,12 +8,17 @@ io.files io.streams.string io.streams.lines vocabs source-files classes hashtables compiler.errors compiler.units ; IN: parser -TUPLE: lexer text line column ; +TUPLE: lexer text line line-text line-length column ; -: ( text -- lexer ) 1 0 lexer construct-boa ; +: next-line ( lexer -- ) + 0 over set-lexer-column + dup lexer-line over lexer-text ?nth over set-lexer-line-text + dup lexer-line-text length over set-lexer-line-length + dup lexer-line 1+ swap set-lexer-line ; -: line-text ( lexer -- str ) - dup lexer-line 1- swap lexer-text ?nth ; +: ( text -- lexer ) + 0 { set-lexer-text set-lexer-line } lexer construct + dup lexer-text empty? [ dup next-line ] unless ; : location ( -- loc ) file get lexer get lexer-line 2dup and @@ -50,18 +55,14 @@ t parser-notes set-global "Note: " write dup print ] when drop ; -: next-line ( lexer -- ) - 0 over set-lexer-column - dup lexer-line 1+ swap set-lexer-line ; - : skip ( i seq ? -- n ) over >r [ swap CHAR: \s eq? xor ] curry find* drop - [ r> drop ] [ r> length ] if* ; inline + [ r> drop ] [ r> length ] if* ; : change-column ( lexer quot -- ) swap - [ dup lexer-column swap line-text rot call ] keep + [ dup lexer-column swap lexer-line-text rot call ] keep set-lexer-column ; inline GENERIC: skip-blank ( lexer -- ) @@ -73,20 +74,20 @@ GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if + 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if ] change-column ; : still-parsing? ( lexer -- ? ) dup lexer-line swap lexer-text length <= ; : still-parsing-line? ( lexer -- ? ) - dup lexer-column swap line-text length < ; + dup lexer-column swap lexer-line-length < ; : (parse-token) ( lexer -- str ) [ lexer-column ] keep [ skip-word ] keep [ lexer-column ] keep - line-text subseq ; + lexer-line-text subseq ; : parse-token ( lexer -- str/f ) dup still-parsing? [ @@ -139,9 +140,8 @@ TUPLE: parse-error file line col text ; : ( msg -- error ) file get - lexer get lexer-line - lexer get lexer-column - lexer get line-text + lexer get + { lexer-line lexer-column lexer-line-text } get-slots parse-error construct-boa [ set-delegate ] keep ; @@ -239,22 +239,25 @@ M: no-word summary word-restarts throw-restarts dup word-vocabulary (use+) ; -: check-forward ( str word -- word ) +: check-forward ( str word -- word/f ) dup forward-reference? [ drop - dup use get + use get [ at ] with map [ ] subset [ forward-reference? not ] find nip - [ ] [ no-word ] ?if ] [ nip ] if ; -: search ( str -- word ) - dup use get assoc-stack [ check-forward ] [ no-word ] if* ; +: search ( str -- word/f ) + dup use get assoc-stack check-forward ; : scan-word ( -- word/number/f ) - scan dup [ dup string>number [ ] [ search ] ?if ] when ; + scan dup [ + dup search [ ] [ + dup string>number [ ] [ no-word ] ?if + ] ?if + ] when ; TUPLE: staging-violation word ; diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index f1cc6cd828..d357fb70ff 100644 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -15,4 +15,4 @@ IN: temporary [ [ "hi" ] ] [ "hi" 1quotation ] unit-test -[ 1 \ + curry ] unit-test-fails +[ 1 \ + curry ] must-fail diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 73ae4737ba..40b2fef85e 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -83,8 +83,8 @@ unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test -[ "a" -1 append ] unit-test-fails -[ -1 "a" append ] unit-test-fails +[ "a" -1 append ] must-fail +[ -1 "a" append ] must-fail [ [ ] ] [ 1 [ ] remove ] unit-test [ [ ] ] [ 1 [ 1 ] remove ] unit-test @@ -119,7 +119,7 @@ unit-test [ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test -[ 6 >vector 2 8 pick delete-slice ] unit-test-fails +[ 6 >vector 2 8 pick delete-slice ] must-fail [ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test @@ -173,7 +173,7 @@ unit-test [ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test -[ -1 1 "abc" ] unit-test-fails +[ -1 1 "abc" ] must-fail [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test @@ -195,8 +195,8 @@ unit-test ! Pathological case [ "ihbye" ] [ "hi" "bye" append ] unit-test -[ -10 "hi" "bye" copy ] unit-test-fails -[ 10 "hi" "bye" copy ] unit-test-fails +[ -10 "hi" "bye" copy ] must-fail +[ 10 "hi" "bye" copy ] must-fail [ V{ 1 2 3 5 6 } ] [ 3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep @@ -228,13 +228,13 @@ unit-test [ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test [ 0 ] [ f length ] unit-test -[ f first ] unit-test-fails +[ f first ] must-fail [ 3 ] [ 3 10 nth ] unit-test [ 3 ] [ 3 10 nth-unsafe ] unit-test -[ -3 10 nth ] unit-test-fails -[ 11 10 nth ] unit-test-fails +[ -3 10 nth ] must-fail +[ 11 10 nth ] must-fail -[ -1./0. 0 delete-nth ] unit-test-fails +[ -1./0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 64ae2e376e..7ddf6f02c0 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -38,7 +38,7 @@ uses definitions ; : (xref-source) ( source-file -- pathname uses ) dup source-file-path swap source-file-uses - [ interned? ] subset ; + [ crossref? ] subset ; : xref-source ( source-file -- ) (xref-source) crossref get add-vertex ; diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index 3ca78248ab..2b6107e08b 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,7 +1,7 @@ USING: splitting tools.test ; IN: temporary -[ { 1 2 3 } 0 group ] unit-test-fails +[ { 1 2 3 } 0 group ] must-fail [ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 985c025827..90e74275ff 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -4,7 +4,7 @@ IN: temporary [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test -[ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test +[ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test [ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] "" make ] unit-test @@ -31,7 +31,7 @@ IN: temporary [ t ] [ "abc" "abd" <=> 0 < ] unit-test [ t ] [ "z" "abd" <=> 0 > ] unit-test -[ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test +[ 0 10 "hello" subseq ] must-fail [ "Replacing+spaces+with+plus" ] [ @@ -43,8 +43,8 @@ unit-test [ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test [ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test -[ 1 "" nth ] unit-test-fails -[ -6 "hello" nth ] unit-test-fails +[ 1 "" nth ] must-fail +[ -6 "hello" nth ] must-fail [ t ] [ "hello world" dup >vector >string = ] unit-test @@ -55,8 +55,7 @@ unit-test [ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test ! Random tester found this -[ { "kernel-error" 3 12 -7 } ] -[ [ 2 -7 resize-string ] catch ] unit-test +[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with ! Make sure 24-bit strings work "hello world" "s" set diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index b1b2f86a47..379b10ce88 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -9,4 +9,4 @@ IN: temporary yield [ ] [ 0.3 sleep ] unit-test -[ "hey" sleep ] unit-test-fails +[ "hey" sleep ] must-fail diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index edd2387645..c9656a3b9e 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -55,7 +55,7 @@ C: point "IN: temporary TUPLE: point z y ;" eval -[ "p" get point-x ] unit-test-fails +[ "p" get point-x ] must-fail [ 200 ] [ "p" get point-y ] unit-test [ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test @@ -97,7 +97,7 @@ TUPLE: delegate-clone ; [ f ] [ \ tuple \ delegate-clone class< ] unit-test ! Compiler regression -[ t ] [ [ t length ] catch no-method-object ] unit-test +[ t length ] [ no-method-object t eq? ] must-fail-with [ "" ] [ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test @@ -123,7 +123,7 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ f ] [ \ yo-momma typemap get values memq? ] unit-test - [ f ] [ \ yo-momma interned? ] unit-test + [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit TUPLE: loc-recording ; @@ -204,15 +204,15 @@ SYMBOL: not-a-tuple-class [ "IN: temporary C: not-a-tuple-class" eval -] unit-test-fails +] must-fail [ t ] [ "not-a-tuple-class" "temporary" lookup symbol? ] unit-test ! Missing check -[ not-a-tuple-class construct-boa ] unit-test-fails -[ not-a-tuple-class construct-empty ] unit-test-fails +[ not-a-tuple-class construct-boa ] must-fail +[ not-a-tuple-class construct-empty ] must-fail TUPLE: erg's-reshape-problem a b c d ; @@ -234,8 +234,6 @@ C: erg's-reshape-problem [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test -[ t ] [ - [ - "IN: temporary SYMBOL: not-a-class C: not-a-class" eval - ] catch [ check-tuple? ] is? -] unit-test +[ + "IN: temporary SYMBOL: not-a-class C: not-a-class" eval +] [ [ check-tuple? ] is? ] must-fail-with diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 4c57c238b4..b56cee1b34 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -3,25 +3,25 @@ sequences sequences.private strings tools.test vectors continuations random growable classes ; IN: temporary -[ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test +[ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test [ 3 ] [ [ t f t ] length ] unit-test [ 3 ] [ V{ t f t } length ] unit-test -[ -3 V{ } nth ] unit-test-fails -[ 3 V{ } nth ] unit-test-fails -[ 3 54.3 nth ] unit-test-fails +[ -3 V{ } nth ] must-fail +[ 3 V{ } nth ] must-fail +[ 3 54.3 nth ] must-fail -[ "hey" [ 1 2 ] set-length ] unit-test-fails -[ "hey" V{ 1 2 } set-length ] unit-test-fails +[ "hey" [ 1 2 ] set-length ] must-fail +[ "hey" V{ 1 2 } set-length ] must-fail [ 3 ] [ 3 0 [ set-length ] keep length ] unit-test [ "yo" ] [ "yo" 4 1 [ set-nth ] keep 4 swap nth ] unit-test -[ 1 V{ } nth ] unit-test-fails -[ -1 V{ } set-length ] unit-test-fails +[ 1 V{ } nth ] must-fail +[ -1 V{ } set-length ] must-fail [ V{ } ] [ [ ] >vector ] unit-test [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test @@ -64,8 +64,8 @@ IN: temporary [ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test [ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test [ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test -[ "funny-stack" get pop ] unit-test-fails -[ "funny-stack" get pop ] unit-test-fails +[ "funny-stack" get pop ] must-fail +[ "funny-stack" get pop ] must-fail [ ] [ "funky" "funny-stack" get push ] unit-test [ "funky" ] [ "funny-stack" get pop ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 560affa566..3a8fc37583 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -18,16 +18,6 @@ debugger compiler.units ; [ t ] [ "kernel" f >vocab-link "kernel" vocab = ] unit-test -! This vocab should not exist, but just in case... -[ ] [ [ "core" forget-vocab ] with-compilation-unit ] unit-test - -2 [ - [ T{ no-vocab f "core" } ] - [ [ "core" require ] catch ] unit-test -] times - -[ f ] [ "core" vocab ] unit-test - [ t ] [ "kernel" vocab-files "kernel" vocab vocab-files @@ -59,7 +49,7 @@ IN: temporary 0 "count-me" set-global 2 [ - [ "vocabs.loader.test.a" require ] unit-test-fails + [ "vocabs.loader.test.a" require ] must-fail [ f ] [ "vocabs.loader.test.a" vocab-source-loaded? ] unit-test @@ -73,14 +63,12 @@ IN: temporary [ 2 ] [ "count-me" get-global ] unit-test -[ t ] [ - [ - "IN: vocabs.loader.test.a v-l-t-a-hello" - - "resource:core/vocabs/loader/test/a/a.factor" - parse-stream - ] catch [ no-word? ] is? -] unit-test +[ + "IN: vocabs.loader.test.a v-l-t-a-hello" + + "resource:core/vocabs/loader/test/a/a.factor" + parse-stream +] [ [ no-word? ] is? ] must-fail-with 0 "count-me" set-global @@ -97,7 +85,7 @@ IN: temporary ] with-compilation-unit ] unit-test -[ "vocabs.loader.test.b" require ] unit-test-fails +[ "vocabs.loader.test.b" require ] must-fail [ 1 ] [ "count-me" get-global ] unit-test @@ -131,8 +119,7 @@ IN: temporary [ "kernel" vocab where ] unit-test [ t ] [ - [ "vocabs.loader.test.d" require ] catch - [ :1 ] when + [ "vocabs.loader.test.d" require ] [ :1 ] recover "vocabs.loader.test.d" vocab-source-loaded? ] unit-test diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor old mode 100644 new mode 100755 index cb2cabb369..f16a33f0d5 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -76,7 +76,7 @@ HELP: all-words HELP: forget-vocab { $values { "vocab" string } } -{ $description "Removes a vocabulary. All words in the vocabulary become uninterned." } +{ $description "Removes a vocabulary. All words in the vocabulary are forgotten." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; HELP: load-vocab-hook diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 24e81c70a6..62848e46b2 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -14,9 +14,7 @@ $nl { $subsection lookup } "Words can output their name and vocabulary:" { $subsection word-name } -{ $subsection word-vocabulary } -"Testing if a word object is part of a vocabulary:" -{ $subsection interned? } ; +{ $subsection word-vocabulary } ; ARTICLE: "uninterned-words" "Uninterned words" "A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "." @@ -369,18 +367,6 @@ HELP: delimiter? { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } { $notes "Outputs " { $link f } " if the object is not a word." } ; -HELP: interned -{ $class-description "The class of words defined in the " { $link dictionary } "." } -{ $examples - { $example "\\ + interned? ." "t" } - { $example "gensym interned? ." "f" } -} ; - -HELP: rename-word -{ $values { "word" word } { "newname" string } { "newvocab" string } } -{ $description "Changes the name and vocabulary of a word, and adds it to its new vocabulary." } -{ $side-effects "word" } ; - HELP: make-flushable { $values { "word" word } } { $description "Declares a word as " { $link POSTPONE: flushable } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 35a2421e71..f29d21cd9f 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -54,22 +54,14 @@ GENERIC: testing [ f ] [ \ testing generic? ] unit-test -[ f ] [ gensym interned? ] unit-test - : forgotten ; : another-forgotten ; -[ f ] [ \ forgotten interned? ] unit-test - FORGET: forgotten -[ f ] [ \ another-forgotten interned? ] unit-test - FORGET: another-forgotten : another-forgotten ; -[ t ] [ \ + interned? ] unit-test - ! I forgot remove-crossref calls! : fee ; : foe fee ; @@ -87,8 +79,7 @@ FORGET: foe ] unit-test [ t ] [ - \ * usage [ word? ] subset - [ dup interned? swap method-body? or ] all? + \ * usage [ word? ] subset [ crossref? ] all? ] unit-test DEFER: calls-a-gensym @@ -119,7 +110,7 @@ M: array freakish ; [ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x -[ t ] [ [ x ] catch undefined? ] unit-test +[ x ] [ undefined? ] must-fail-with [ ] [ "no-loc" "temporary" create drop ] unit-test [ f ] [ "no-loc" "temporary" lookup where ] unit-test @@ -150,10 +141,8 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ t ] [ - [ "IN: temporary : undef-test ; << undef-test >>" eval ] catch - [ undefined? ] is? -] unit-test +[ "IN: temporary : undef-test ; << undef-test >>" eval ] +[ [ undefined? ] is? ] must-fail-with [ ] [ "IN: temporary GENERIC: symbol-generic" eval diff --git a/core/words/words.factor b/core/words/words.factor index 93b1185335..bd49a3d855 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: words USING: arrays definitions graphs assocs kernel kernel.private slots.private math namespaces sequences strings vectors sbufs quotations assocs hashtables sorting math.parser words.private -vocabs ; +vocabs combinators ; +IN: words : word ( -- word ) \ word get-global ; @@ -65,13 +65,20 @@ SYMBOL: bootstrapping? : bootstrap-word ( word -- target ) [ target-word ] [ ] if-bootstrapping ; -PREDICATE: word interned dup target-word eq? ; +: crossref? ( word -- ? ) + { + { [ dup "forgotten" word-prop ] [ f ] } + { [ dup "method" word-prop ] [ t ] } + { [ dup word-vocabulary ] [ t ] } + { [ t ] [ f ] } + } cond nip ; GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; -M: interned (quot-uses) dupd set-at ; +M: word (quot-uses) + >r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; @@ -92,6 +99,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) + [ drop crossref? ] assoc-subset 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; @@ -116,9 +124,6 @@ SYMBOL: changed-words [ no-compilation-unit ] unless* set-at ; -: crossref? ( word -- ? ) - dup word-vocabulary swap "method" word-prop or ; - : define ( word def -- ) [ ] like over unxref @@ -194,24 +199,17 @@ M: word where "loc" word-prop ; M: word set-where swap "loc" set-word-prop ; -GENERIC: (forget-word) ( word -- ) +GENERIC: forget-word ( word -- ) -M: interned (forget-word) - dup word-name swap word-vocabulary vocab-words delete-at ; +: (forget-word) ( word -- ) + dup "forgotten" word-prop [ + dup delete-xref + dup delete-compiled-xref + dup word-name over word-vocabulary vocab-words delete-at + dup t "forgotten" set-word-prop + ] unless drop ; -M: word (forget-word) - drop ; - -: rename-word ( word newname newvocab -- ) - pick (forget-word) - pick set-word-vocabulary - over set-word-name - reveal ; - -: forget-word ( word -- ) - dup delete-xref - dup delete-compiled-xref - (forget-word) ; +M: word forget-word (forget-word) ; M: word forget* forget-word ; diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor old mode 100644 new mode 100755 index 79c6dfbaca..6e3c201cf0 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -4,8 +4,6 @@ USING: math kernel hints prettyprint io ; : fib ( m -- n ) dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; -! HINTS: fib { fixnum float } ; -! : ack ( m n -- x ) over zero? [ nip 1+ @@ -17,8 +15,6 @@ USING: math kernel hints prettyprint io ; ] if ] if ; -! HINTS: ack fixnum fixnum ; - : tak ( x y z -- t ) pick pick swap < [ [ rot 1- -rot tak ] 3keep @@ -29,8 +25,6 @@ USING: math kernel hints prettyprint io ; 2nip ] if ; -! HINTS: tak { fixnum float } { fixnum float } { fixnum float } ; - : recursive ( n -- ) 3 over ack . flush dup 27.0 + fib . flush diff --git a/extra/bitfields/bitfields-tests.factor b/extra/bitfields/bitfields-tests.factor index 6c82ec0323..8a3bb1f043 100644 --- a/extra/bitfields/bitfields-tests.factor +++ b/extra/bitfields/bitfields-tests.factor @@ -10,12 +10,12 @@ SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ; [ 855 ] [ 21 852 3 855 swap with-foo-baz foo-baz ] unit-test [ 1 ] [ 21 852 3 1 swap with-foo-bing foo-bing ] unit-test -[ 100 0 0 ] unit-test-fails -[ 0 5000 0 ] unit-test-fails -[ 0 0 10 ] unit-test-fails +[ 100 0 0 ] must-fail +[ 0 5000 0 ] must-fail +[ 0 0 10 ] must-fail -[ 100 0 with-foo-bar ] unit-test-fails -[ 5000 0 with-foo-baz ] unit-test-fails -[ 10 0 with-foo-bing ] unit-test-fails +[ 100 0 with-foo-bar ] must-fail +[ 5000 0 with-foo-baz ] must-fail +[ 10 0 with-foo-bing ] must-fail [ BIN: 00101100000000111111 ] [ BIN: 101 BIN: 1000000001 BIN: 11 ] unit-test diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 4d5440e546..065f7dd5c4 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,5 +10,3 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when - -"vocabs.monitor" require diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index fbb60b2d49..3b0cfc8455 100644 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,14 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; -[ "invalid timestamp" ] [ [ 2004 12 32 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 2 30 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2003 2 29 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 -2 9 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 0 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 24 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 23 60 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 23 59 60 0 0 make-timestamp ] catch ] unit-test +[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor index 01504a0e8a..8ca4574885 100644 --- a/extra/circular/circular-tests.factor +++ b/extra/circular/circular-tests.factor @@ -9,7 +9,7 @@ circular strings ; [ CHAR: t ] [ "test" 0 swap nth ] unit-test [ "test" ] [ "test" >string ] unit-test -[ "test" 5 swap nth ] unit-test-fails +[ "test" 5 swap nth ] must-fail [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test @@ -18,7 +18,7 @@ circular strings ; [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test [ "fob" ] [ "foo" CHAR: b 2 pick set-nth >string ] unit-test -[ "foo" CHAR: b 3 rot set-nth ] unit-test-fails +[ "foo" CHAR: b 3 rot set-nth ] must-fail [ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index deeb105758..20f52b2ea3 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel math math.ranges random sequences -tools.test inference continuations arrays vectors ; +tools.test tools.test.inference continuations arrays vectors ; IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test @@ -8,26 +8,25 @@ IN: temporary [ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test [ 328350 ] [ 100 [ sq ] sigma ] unit-test -: infers? [ infer drop ] curry catch not ; - [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test -{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] infers? ] unit-test + +[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test -{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] infers? ] unit-test +[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] infers? ] unit-test +[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer { { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test { { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] infers? ] unit-test +[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test -[ t ] [ [ [ sq ] 3apply ] infers? ] unit-test +[ [ sq ] 3apply ] must-infer [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test -[ t ] [ [ [ dup 2^ 2array ] 5 napply ] infers? ] unit-test +[ [ dup 2^ 2array ] 5 napply ] must-infer ! && diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index dafbafbc5b..f04811b72a 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -146,7 +146,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions" "A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] spawn" } "Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-link } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:" -{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] catch [ \"Exception caught.\" print ] when" } +{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" } "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: { "concurrency" "futures" } "Futures" diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index a9d4b39854..2f9b6605d7 100644 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -67,15 +67,12 @@ IN: temporary ] unit-test -[ "crash" ] [ +[ [ - [ - "crash" throw - ] spawn-link drop - receive - ] - catch -] unit-test + "crash" throw + ] spawn-link drop + receive +] [ "crash" = ] must-fail-with [ 50 ] [ [ 50 ] future ?future @@ -115,7 +112,7 @@ SYMBOL: value ! this is fixed (via a timeout). ! [ ! [ "this should propogate" throw ] future ?future -! ] unit-test-fails +! ] must-fail [ ] [ [ "this should not propogate" throw ] future drop diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index bc0d01956f..8d842f15d0 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -166,7 +166,7 @@ M: process send ( message process -- ) PRIVATE> : spawn-link ( quot -- process ) - [ catch [ rethrow-linked ] when* ] curry + [ [ rethrow-linked ] recover ] curry [ ((spawn)) ] curry (spawn-link) ; inline db ( handle -- obj ) ! HOOK: db-create db ( str -- ) ! HOOK: db-drop db ( str -- ) GENERIC: db-open ( db -- ) -GENERIC: db-close ( db -- ) TUPLE: statement sql params handle bound? ; diff --git a/unmaintained/mysql/libmysql.factor b/extra/db/mysql/ffi/ffi.factor similarity index 73% rename from unmaintained/mysql/libmysql.factor rename to extra/db/mysql/ffi/ffi.factor index 064c7bffbc..845381a23c 100644 --- a/unmaintained/mysql/libmysql.factor +++ b/extra/db/mysql/ffi/ffi.factor @@ -1,27 +1,18 @@ -! See http://factorcode.org/license.txt -! Copyright (C) 2007 Berlin Brown -! Date: 1/17/2007 -! -! libs/mysql/libmysql.factor -! +! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. ! Adapted from mysql.h and mysql.c ! Tested with MySQL version - 5.0.24a +USING: alien alien.syntax combinators kernel system ; +IN: db.mysql.ffi -IN: mysql -USING: alien kernel ; - -"mysql" { +<< "mysql" { { [ win32? ] [ "libmySQL.dll" "stdcall" ] } { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } -} cond add-library +} cond add-library >> LIBRARY: mysql -! =============================================== -! mysql.c -! =============================================== - FUNCTION: void* mysql_init ( void* mysql ) ; FUNCTION: char* mysql_error ( void* mysql ) ; FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ; @@ -32,4 +23,3 @@ FUNCTION: void mysql_free_result ( void* result ) ; FUNCTION: char** mysql_fetch_row ( void* result ) ; FUNCTION: int mysql_num_fields ( void* result ) ; FUNCTION: ulong mysql_affected_rows ( void* mysql ) ; - diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor new file mode 100644 index 0000000000..59d1b6ff3d --- /dev/null +++ b/extra/db/mysql/lib/lib.factor @@ -0,0 +1,78 @@ +! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for license. +! Adapted from mysql.h and mysql.c +! Tested with MySQL version - 5.0.24a +USING: kernel alien io prettyprint sequences +namespaces arrays math db.mysql.ffi system ; +IN: db.mysql.lib + +SYMBOL: my-conn + +TUPLE: mysql-db handle host user password db port ; +TUPLE: mysql-statement ; +TUPLE: mysql-result-set ; + +: new-mysql ( -- conn ) + f mysql_init ; + +: mysql-error ( mysql -- ) + [ mysql_error throw ] when* ; + +: mysql-connect ( mysql-connection -- ) + new-mysql over set-mysql-db-handle + dup { + mysql-db-handle + mysql-db-host + mysql-db-user + mysql-db-password + mysql-db-db + mysql-db-port + } get-slots f 0 mysql_real_connect mysql-error ; + +! ========================================================= +! Low level mysql utility definitions +! ========================================================= + +: (mysql-query) ( mysql-connection query -- ret ) + >r mysql-db-handle r> mysql_query ; + +! : (mysql-result) ( mysql-connection -- ret ) + ! [ mysql-db-handle mysql_use_result ] keep + ! [ set-mysql-connection-resulthandle ] keep ; + +! : (mysql-affected-rows) ( mysql-connection -- n ) + ! mysql-connection-mysqlconn mysql_affected_rows ; + +! : (mysql-free-result) ( mysql-connection -- ) + ! mysql-connection-resulthandle drop ; + +! : (mysql-row) ( mysql-connection -- row ) + ! mysql-connection-resulthandle mysql_fetch_row ; + +! : (mysql-num-cols) ( mysql-connection -- n ) + ! mysql-connection-resulthandle mysql_num_fields ; + +! : mysql-char*-nth ( index object -- str ) + ! #! Utility based on 'char*-nth' to perform an additional sanity check on the value + ! #! extracted from the array of strings. + ! void*-nth [ alien>char-string ] [ "" ] if* ; + +! : mysql-row>seq ( object n -- seq ) + ! [ swap mysql-char*-nth ] map-with ; + +! : (mysql-result>seq) ( seq -- seq ) + ! my-conn get (mysql-row) dup [ + ! my-conn get (mysql-num-cols) mysql-row>seq + ! over push + ! (mysql-result>seq) + ! ] [ drop ] if + ! ! Perform needed cleanup on fetched results + ! my-conn get (mysql-free-result) ; + +! : mysql-query ( query -- ret ) + ! >r my-conn get r> (mysql-query) drop + ! my-conn get (mysql-result) ; + +! : mysql-command ( query -- n ) + ! mysql-query drop + ! my-conn get (mysql-affected-rows) ; diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor new file mode 100644 index 0000000000..941c25e1fa --- /dev/null +++ b/extra/db/mysql/mysql.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for license. +USING: alien continuations io kernel prettyprint sequences +db db.mysql.ffi ; +IN: db.mysql + +TUPLE: mysql-db handle host user password db port ; +TUPLE: mysql-statement ; +TUPLE: mysql-result-set ; + +M: mysql-db db-open ( mysql-db -- ) + ; + +M: mysql-db dispose ( mysql-db -- ) + mysql-db-handle mysql_close ; + + +M: mysql-db ( str -- statement ) + ; + +M: mysql-db ( str -- statement ) + ; + +M: mysql-statement prepare-statement ( statement -- ) + ; + +M: mysql-statement bind-statement* ( statement -- ) + ; + +M: mysql-statement rebind-statement ( statement -- ) + ; + +M: mysql-statement execute-statement ( statement -- ) + ; + +M: mysql-statement query-results ( query -- result-set ) + ; + +M: mysql-result-set #rows ( result-set -- n ) + ; + +M: mysql-result-set #columns ( result-set -- n ) + ; + +M: mysql-result-set row-column ( result-set n -- obj ) + ; + +M: mysql-result-set advance-row ( result-set -- ? ) + ; + +M: mysql-db begin-transaction ( -- ) + ; + +M: mysql-db commit-transaction ( -- ) + ; + +M: mysql-db rollback-transaction ( -- ) + ; diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index dbaa70c625..23368164a1 100644 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -1,6 +1,5 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -! adapted from libpq-fe.h version 7.4.7 ! tested on debian linux with postgresql 8.1 USING: alien alien.syntax combinators system ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index c5a5155d12..8c6791c767 100644 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -14,7 +14,7 @@ IN: temporary [ ] [ test-db [ - [ "drop table person;" sql-command ] catch drop + [ "drop table person;" sql-command ] ignore-errors "create table person (name varchar(30), country varchar(30));" sql-command @@ -83,7 +83,7 @@ IN: temporary "oops" throw ] with-transaction ] with-db -] unit-test-fails +] must-fail [ 3 ] [ test-db [ diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index f64b8d1104..cd6a099ead 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,42 +1,28 @@ USING: io io.files io.launcher kernel namespaces -prettyprint tools.test db.sqlite db db.sql sequences +prettyprint tools.test db.sqlite db sequences continuations ; IN: temporary -! "sqlite3 -init test.txt test.db" - -IN: scratchpad : test.db "extra/db/sqlite/test.db" resource-path ; -IN: temporary -: (create-db) ( -- str ) - [ - "sqlite3 -init " % - test.db % - " " % - test.db % - ] "" make ; +[ ] [ [ test.db delete-file ] ignore-errors ] unit-test -: create-db ( -- ) (create-db) run-process drop ; +[ ] [ + test.db [ + "create table person (name varchar(30), country varchar(30))" sql-command + "insert into person values('John', 'America')" sql-command + "insert into person values('Jane', 'New Zealand')" sql-command + ] with-sqlite +] unit-test -[ ] [ test.db delete-file ] unit-test -[ ] [ create-db ] unit-test - -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - } -] [ +[ { { "John" "America" } { "Jane" "New Zealand" } } ] [ test.db [ "select * from person" sql-query ] with-sqlite ] unit-test -[ - { { "John" "America" } } -] [ +[ { { "John" "America" } } ] [ test.db [ "select * from person where name = :name and country = :country" [ @@ -52,15 +38,10 @@ IN: temporary ] with-sqlite ] unit-test -[ - { - { "1" "John" "America" } - { "2" "Jane" "New Zealand" } - } -] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ] +[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test -[ -] [ +[ ] [ test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command @@ -83,7 +64,7 @@ IN: temporary "oops" throw ] with-transaction ] with-sqlite -] unit-test-fails +] must-fail [ 3 ] [ test.db [ diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 49462dcc50..73b93d404b 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs classes compiler db db.sql +USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi ; diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index d31c8ebb47..db4f023dad 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -36,7 +36,7 @@ M: dummy-destructor destruct ( obj -- ) dup destroy-always "foo" throw ] with-destructors - ] catch drop dummy-obj-destroyed? + ] ignore-errors dummy-obj-destroyed? ] unit-test [ t ] [ @@ -45,6 +45,6 @@ M: dummy-destructor destruct ( obj -- ) dup destroy-later "foo" throw ] with-destructors - ] catch drop dummy-obj-destroyed? + ] ignore-errors dummy-obj-destroyed? ] unit-test diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 0515646a5f..69b8678749 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,12 +1,13 @@ -USING: alien.syntax kernel math prettyprint system -combinators vocabs.loader hardware-info.backend ; +USING: alien.syntax kernel math prettyprint +combinators vocabs.loader hardware-info.backend system ; IN: hardware-info : kb. ( x -- ) 10 2^ /f . ; : megs. ( x -- ) 20 2^ /f . ; : gigs. ( x -- ) 30 2^ /f . ; -<< { +<< +{ { [ windows? ] [ "hardware-info.windows" ] } { [ linux? ] [ "hardware-info.linux" ] } { [ macosx? ] [ "hardware-info.macosx" ] } diff --git a/extra/hardware-info/windows/backend/backend.factor b/extra/hardware-info/windows/backend/backend.factor deleted file mode 100644 index 516603c441..0000000000 --- a/extra/hardware-info/windows/backend/backend.factor +++ /dev/null @@ -1,6 +0,0 @@ -IN: hardware-info.windows.backend - -TUPLE: wince ; -TUPLE: winnt ; -UNION: windows wince winnt ; - diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 1592bad14c..8923d86b03 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -2,8 +2,8 @@ USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce -TUPLE: wince ; -T{ wince } os set-global +TUPLE: wince-os ; +T{ wince-os } os set-global : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 827b32c2f2..8bdb75fe6a 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,16 +1,15 @@ -USING: alien alien.c-types hardware-info.windows.backend +USING: alien alien.c-types kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 ; IN: hardware-info.windows.nt -TUPLE: winnt ; - -T{ winnt } os set-global +TUPLE: winnt-os ; +T{ winnt-os } os set-global : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; -M: winnt cpus ( -- n ) +M: winnt-os cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) @@ -18,25 +17,25 @@ M: winnt cpus ( -- n ) "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; -M: winnt memory-load ( -- n ) +M: winnt-os memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; -M: winnt physical-mem ( -- n ) +M: winnt-os physical-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPhys ; -M: winnt available-mem ( -- n ) +M: winnt-os available-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPhys ; -M: winnt total-page-file ( -- n ) +M: winnt-os total-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPageFile ; -M: winnt available-page-file ( -- n ) +M: winnt-os available-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPageFile ; -M: winnt total-virtual-mem ( -- n ) +M: winnt-os total-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalVirtual ; -M: winnt available-virtual-mem ( -- n ) +M: winnt-os available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; : computer-name ( -- string ) @@ -54,4 +53,3 @@ M: winnt available-virtual-mem ( -- n ) ] [ [ alien>u16-string ] keep free ] if ; - diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 67d13fc50f..f3a1eb33f5 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 -hardware-info.windows.backend -words combinators vocabs.loader hardware-info.backend ; +words combinators vocabs.loader hardware-info.backend +system ; IN: hardware-info.windows : system-info ( -- SYSTEM_INFO ) @@ -63,7 +63,8 @@ IN: hardware-info.windows : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; +<< { { [ wince? ] [ "hardware-info.windows.ce" ] } { [ winnt? ] [ "hardware-info.windows.nt" ] } -} cond [ require ] when* +} cond [ require ] when* >> diff --git a/extra/help/crossref/crossref-tests.factor b/extra/help/crossref/crossref-tests.factor index d3d21b8815..eb30965f6a 100755 --- a/extra/help/crossref/crossref-tests.factor +++ b/extra/help/crossref/crossref-tests.factor @@ -50,7 +50,7 @@ io.streams.string continuations debugger compiler.units ; [ "IN: azz USE: help.syntax USE: help.markup ARTICLE: \"yyy\" \"YYY\" ; ARTICLE: \"xxx\" \"XXX\" { $subsection \"yyy\" } ; ARTICLE: \"yyy\" \"YYY\" ;" "parent-test" parse-stream drop - ] catch [ :1 ] when + ] [ :1 ] recover ] unit-test [ "xxx" ] [ "yyy" article-parent ] unit-test diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 81e4bea7b3..d6b4ec7ffe 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -32,6 +32,8 @@ $nl { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-stream } } { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } +{ $heading "Stack effect conventions" } +"Stack effect conventions are documented in " { $link "effect-declaration" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index a61be734fc..31e7c5f78a 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -3,7 +3,7 @@ math.functions math.constants ; IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test -[ { 3 4 } [ dup 2array ] undo ] unit-test-fails +[ { 3 4 } [ dup 2array ] undo ] must-fail TUPLE: foo bar baz ; @@ -15,7 +15,7 @@ C: foo [ t ] [ { 3 3 } [ 2same ] matches? ] unit-test [ f ] [ { 3 4 } [ 2same ] matches? ] unit-test -[ [ 2same ] matches? ] unit-test-fails +[ [ 2same ] matches? ] must-fail : something ( array -- num ) { @@ -25,9 +25,9 @@ C: foo [ 5 ] [ { 1 2 2 } something ] unit-test [ 6 ] [ { 2 3 } something ] unit-test -[ { 1 } something ] unit-test-fails +[ { 1 } something ] must-fail -[ 1 2 [ eq? ] undo ] unit-test-fails +[ 1 2 [ eq? ] undo ] must-fail : f>c ( *fahrenheit -- *celsius ) 32 - 1.8 / ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index 6fcdc86423..c9203d9ef8 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -75,5 +75,5 @@ sequences tools.test namespaces ; "b" get buffer-free 100 "b" set -[ 1000 "b" get n>buffer ] unit-test-fails +[ 1000 "b" get n>buffer ] must-fail "b" get buffer-free diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index a01481ecdc..f0547961bc 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,9 +1,9 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ; IN: temporary -[ "mmap-test-file.txt" resource-path delete-file ] catch drop +[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-stream ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test -[ "mmap-test-file.txt" resource-path delete-file ] catch drop +[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index a70f7339d2..3bf0e3f897 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -6,8 +6,8 @@ alien ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup getcwd - [ alien>char-string ] [ (io-error) ] if* ; + MAXPATHLEN dup swap + getcwd [ (io-error) ] unless* ; M: unix-io cd chdir io-error ; diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index fec97baa5a..eb3038e1b5 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,8 +1,8 @@ IN: temporary USING: io.unix.launcher tools.test ; -[ "" tokenize-command ] unit-test-fails -[ " " tokenize-command ] unit-test-fails +[ "" tokenize-command ] must-fail +[ " " tokenize-command ] must-fail [ { "a" } ] [ "a" tokenize-command ] unit-test [ { "abc" } ] [ "abc" tokenize-command ] unit-test [ { "abc" } ] [ "abc " tokenize-command ] unit-test @@ -14,8 +14,8 @@ USING: io.unix.launcher tools.test ; [ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test [ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test [ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] unit-test-fails -[ "'abc def" tokenize-command ] unit-test-fails +[ "'abc def' \"hey" tokenize-command ] must-fail +[ "'abc def" tokenize-command ] must-fail [ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test [ diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 9c4aced03f..55f5f01abc 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,7 +3,7 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs namespaces threads -continuations init math alien.c-types alien ; +continuations init math alien.c-types alien vocabs.loader ; IN: io.unix.linux TUPLE: linux-io ; @@ -134,4 +134,6 @@ M: linux-io init-io ( -- ) T{ linux-io } set-io-backend -[ start-wait-thread ] "io.unix.linux" add-init-hook \ No newline at end of file +[ start-wait-thread ] "io.unix.linux" add-init-hook + +"vocabs.monitor" require \ No newline at end of file diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 8a621f8f48..5a93257949 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -7,7 +7,7 @@ IN: temporary [ [ "unix-domain-socket-test" resource-path delete-file - ] catch drop + ] ignore-errors "unix-domain-socket-test" resource-path [ @@ -36,7 +36,7 @@ yield ! Unix domain datagram sockets [ "unix-domain-datagram-test" resource-path delete-file -] catch drop +] ignore-errors : server-addr "unix-domain-datagram-test" resource-path ; : client-addr "unix-domain-datagram-test-2" resource-path ; @@ -75,7 +75,7 @@ yield [ "unix-domain-datagram-test-2" resource-path delete-file -] catch drop +] ignore-errors client-addr "d" set @@ -110,7 +110,7 @@ client-addr [ "unix-domain-datagram-test-3" resource-path delete-file -] catch drop +] ignore-errors "unix-domain-datagram-test-2" resource-path delete-file @@ -118,29 +118,29 @@ client-addr [ B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send -] unit-test-fails +] must-fail [ ] [ "d" get dispose ] unit-test ! See what happens on send/receive after close -[ "d" get receive ] unit-test-fails +[ "d" get receive ] must-fail -[ B{ 1 2 } server-addr "d" get send ] unit-test-fails +[ B{ 1 2 } server-addr "d" get send ] must-fail ! Invalid parameter tests [ image [ stdio get accept ] with-stream -] unit-test-fails +] must-fail [ image [ stdio get receive ] with-stream -] unit-test-fails +] must-fail [ image [ B{ 1 2 } server-addr stdio get send ] with-stream -] unit-test-fails +] must-fail diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index b957aa2fca..be57a398a2 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USE: vocabs.loader USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files @@ -11,3 +12,5 @@ USE: io.windows.mmap USE: io.backend T{ windows-nt-io } set-io-backend + +"vocabs.monitor" require diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 5b4355986f..44c682e671 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -189,7 +189,7 @@ SYMBOL: line : with-infinite-loop ( quot timeout -- quot timeout ) "looping" print flush - over catch drop dup sleep with-infinite-loop ; + over [ drop ] recover dup sleep with-infinite-loop ; : start-irc ( irc-client -- ) ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ; diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index be512e5052..e8535d0637 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -2,8 +2,8 @@ USING: kernel math math.constants math.functions tools.test prettyprint ; IN: temporary -[ 1 C{ 0 1 } rect> ] unit-test-fails -[ C{ 0 1 } 1 rect> ] unit-test-fails +[ 1 C{ 0 1 } rect> ] must-fail +[ C{ 0 1 } 1 rect> ] must-fail [ f ] [ C{ 5 12.5 } 5 = ] unit-test [ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 439eaace6f..6f4dc42593 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -73,7 +73,7 @@ IN: temporary [ 3 ] [ 5 7 mod-inv ] unit-test [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test -[ 2 10 mod-inv ] unit-test-fails +[ 2 10 mod-inv ] must-fail [ t ] [ 0 0 ^ fp-nan? ] unit-test [ 1 ] [ 10 0 ^ ] unit-test diff --git a/extra/math/vectors/vectors.factor b/extra/math/vectors/vectors.factor index b2a8995df0..2be9cf7f58 100755 --- a/extra/math/vectors/vectors.factor +++ b/extra/math/vectors/vectors.factor @@ -27,20 +27,20 @@ IN: math.vectors : set-axis ( u v axis -- w ) dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ; -HINTS: vneg { float-array array } ; -HINTS: norm-sq { float-array array } ; -HINTS: norm { float-array array } ; -HINTS: normalize { float-array array } ; +HINTS: vneg { float-array } { array } ; +HINTS: norm-sq { float-array } { array } ; +HINTS: norm { float-array } { array } ; +HINTS: normalize { float-array } { array } ; -HINTS: n*v * { float-array array } ; -HINTS: v*n { float-array array } * ; -HINTS: n/v * { float-array array } ; -HINTS: v/n { float-array array } * ; +HINTS: n*v { object float-array } { object array } ; +HINTS: v*n { float-array object } { array object } ; +HINTS: n/v { object float-array } { array } ; +HINTS: v/n { float-array object } { array object } ; -HINTS: v+ { float-array array } { float-array array } ; -HINTS: v- { float-array array } { float-array array } ; -HINTS: v* { float-array array } { float-array array } ; -HINTS: v/ { float-array array } { float-array array } ; -HINTS: vmax { float-array array } { float-array array } ; -HINTS: vmin { float-array array } { float-array array } ; -HINTS: v. { float-array array } { float-array array } ; +HINTS: v+ { float-array float-array } { array array } ; +HINTS: v- { float-array float-array } { array array } ; +HINTS: v* { float-array float-array } { array array } ; +HINTS: v/ { float-array float-array } { array array } ; +HINTS: vmax { float-array float-array } { array array } ; +HINTS: vmin { float-array float-array } { array array } ; +HINTS: v. { float-array float-array } { array array } ; diff --git a/extra/memoize/memoize-tests.factor b/extra/memoize/memoize-tests.factor index f5a7f85edb..dbd2d3a16a 100644 --- a/extra/memoize/memoize-tests.factor +++ b/extra/memoize/memoize-tests.factor @@ -7,4 +7,4 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] unit-test-fails +[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index d2af88d02a..a0769dffda 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -52,7 +52,7 @@ METHOD: beats? { thing thing } f ; : play ( obj1 obj2 -- ? ) beats? 2nip ; -[ { } 3 play ] unit-test-fails +[ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test [ ] [ error get error. ] unit-test [ t ] [ T{ paper } T{ scissors } play ] unit-test diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor old mode 100644 new mode 100755 index 7f831e5351..9a6d052b60 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -4,7 +4,7 @@ USING: namespaces parser kernel sequences words quotations math ; IN: multiline : next-line-text ( -- str ) - lexer get dup next-line line-text ; + lexer get dup next-line lexer-line-text ; : (parse-here) ( -- ) next-line-text dup ";" = @@ -19,7 +19,7 @@ IN: multiline parse-here 1quotation define ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) - lexer get line-text 2dup start + lexer get lexer-line-text 2dup start [ rot dupd >r >r swap subseq % r> r> length + ] [ rot tail % "\n" % 0 lexer get next-line swap (parse-multiline-string) diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor index 0d9748a6f3..48b61b41a3 100644 --- a/extra/ogg/theora/theora.factor +++ b/extra/ogg/theora/theora.factor @@ -6,7 +6,7 @@ IN: ogg.theora << "theora" { - { [ win32? ] [ "libtheora.dll" ] } + { [ win32? ] [ "theora.dll" ] } { [ macosx? ] [ "libtheora.0.dylib" ] } { [ unix? ] [ "libtheora.so" ] } } cond "cdecl" add-library diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor index 26e917ebf4..170d0ea6ef 100644 --- a/extra/ogg/vorbis/vorbis.factor +++ b/extra/ogg/vorbis/vorbis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel system combinators alien alien.syntax ; +USING: kernel system combinators alien alien.syntax ogg ; IN: ogg.vorbis << diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index fc8cec770b..a1f82391a0 100644 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -76,7 +76,7 @@ IN: scratchpad [ "begin1" "begin" token some parse -] unit-test-fails +] must-fail { "begin" } [ "begin" "begin" token some parse diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index 9c0ed5bd81..f6e7c05910 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -95,7 +95,7 @@ IN: regexp-tests [ t ] [ "]" "[]]" f matches? ] unit-test [ f ] [ "]" "[^]]" f matches? ] unit-test -! [ "^" "[^]" f matches? ] unit-test-fails +! [ "^" "[^]" f matches? ] must-fail [ t ] [ "^" "[]^]" f matches? ] unit-test [ t ] [ "]" "[]^]" f matches? ] unit-test diff --git a/extra/roman/roman-tests.factor b/extra/roman/roman-tests.factor index e850411726..a15dcef354 100644 --- a/extra/roman/roman-tests.factor +++ b/extra/roman/roman-tests.factor @@ -28,11 +28,11 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ 1666 ] [ 1666 >roman roman> ] unit-test [ 3444 ] [ 3444 >roman roman> ] unit-test [ 3999 ] [ 3999 >roman roman> ] unit-test -[ 0 >roman ] unit-test-fails -[ 4000 >roman ] unit-test-fails +[ 0 >roman ] must-fail +[ 4000 >roman ] must-fail [ "vi" ] [ "iii" "iii" roman+ ] unit-test [ "viii" ] [ "x" "ii" roman- ] unit-test [ "ix" ] [ "iii" "iii" roman* ] unit-test [ "i" ] [ "iii" "ii" roman/i ] unit-test [ "i" "ii" ] [ "v" "iii" roman/mod ] unit-test -[ "iii" "iii" roman- ] unit-test-fails +[ "iii" "iii" roman- ] must-fail diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 717f463c45..d0bc0a9e52 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -38,7 +38,7 @@ math.functions tools.test strings ; [ f ] [ { "asdf" "bsdf" } singleton? ] unit-test [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test -[ V{ } [ delete-random drop ] keep length ] unit-test-fails +[ V{ } [ delete-random drop ] keep length ] must-fail [ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test [ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test diff --git a/extra/tetris/board/board-tests.factor b/extra/tetris/board/board-tests.factor index 3a870e621e..bd8789c4d6 100644 --- a/extra/tetris/board/board-tests.factor +++ b/extra/tetris/board/board-tests.factor @@ -5,7 +5,7 @@ colors ; [ { { f f } { f f } { f f } } ] [ 2 3 board-rows ] unit-test [ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test [ f ] [ 2 3 { 1 1 } board-block ] unit-test -[ 2 3 { 2 3 } board-block ] unit-test-fails +[ 2 3 { 2 3 } board-block ] must-fail red 1array [ 2 3 dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test [ t ] [ 2 3 { 1 1 } block-free? ] unit-test [ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor index 3976ada845..e7fe7854fa 100644 --- a/extra/tools/interpreter/interpreter-tests.factor +++ b/extra/tools/interpreter/interpreter-tests.factor @@ -99,7 +99,7 @@ IN: temporary [ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test [ { 6 } ] -[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test +[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test [ { "{ 1 2 3 }\n" } ] [ [ [ { 1 2 3 } . ] string-out ] test-interpreter diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor index 17ff7e1acd..cc77f4910d 100755 --- a/extra/tools/test/inference/inference.factor +++ b/extra/tools/test/inference/inference.factor @@ -10,7 +10,6 @@ IN: tools.test.inference : unit-test-effect ( effect quot -- ) >r 1quotation r> [ infer short-effect ] curry unit-test ; -: must-infer ( word -- ) - dup "declared-effect" word-prop - dup effect-in length swap effect-out length 2array - swap 1quotation unit-test-effect ; +: must-infer ( word/quot -- ) + dup word? [ 1quotation ] when + [ infer drop ] curry [ ] swap unit-test ; diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor old mode 100644 new mode 100755 index 32825c965d..147e795861 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -10,7 +10,8 @@ $nl $nl "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" { $subsection unit-test } -{ $subsection unit-test-fails } +{ $subsection must-fail } +{ $subsection must-fail-with } "The following words run test harness files; any test failures are collected and printed at the end:" { $subsection test } { $subsection test-all } ; @@ -21,7 +22,7 @@ HELP: unit-test { $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ; -HELP: unit-test-fails +HELP: must-fail { $values { "quot" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, expecting it to throw an error. If the quotation throws an error, this word returns normally. If the quotation does not throw an error, this word " { $emphasis "does" } " raise an error." } { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 2a26c8639e..9590f32539 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -3,7 +3,7 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time -vocabs.loader source-files compiler.units ; +vocabs.loader source-files compiler.units inspector ; IN: tools.test SYMBOL: failures @@ -30,10 +30,21 @@ SYMBOL: this-test TUPLE: expected-error ; -: unit-test-fails ( quot -- ) - [ f ] append [ [ drop t ] recover ] curry +M: expected-error summary + drop + "The unit test expected the quotation to throw an error" ; + +: must-fail-with ( quot test -- ) + >r [ expected-error construct-empty throw ] compose r> + [ recover ] 2curry [ t ] swap unit-test ; +: must-fail ( quot -- ) + [ drop t ] must-fail-with ; + +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : run-test ( path -- failures ) [ "temporary" forget-vocab ] with-compilation-unit [ diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index eab85209cc..56c90f760f 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -25,7 +25,7 @@ timers [ init-timers ] unless [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test [ ] [ - "i" get [ { "SYMBOL:" } parse-lines ] catch go-to-error + "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover ] unit-test [ t ] [ diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor index 4e3b4e7c93..b75671fa3c 100755 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -4,6 +4,7 @@ USING: kernel io combinators namespaces quotations arrays sequences x11.xlib x11.constants mortar mortar.sugar slot-accessors geom.rect + math.bitfields x x.gc x.widgets x.widgets.button x.widgets.wm.child diff --git a/extra/xml/test/errors.factor b/extra/xml/test/errors.factor index 596f1e6c43..c0a60d8a3f 100644 --- a/extra/xml/test/errors.factor +++ b/extra/xml/test/errors.factor @@ -1,7 +1,7 @@ USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ; : xml-error-test ( expected-error xml-string -- ) - swap 1array >quotation swap [ [ string>xml ] catch nip ] curry unit-test ; + [ string>xml ] curry swap [ = ] curry must-fail-with ; T{ no-entity T{ parsing-error f 1 10 } "nbsp" } " " xml-error-test T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" } diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index ec59d3564e..0198ebacb7 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -17,7 +17,7 @@ SYMBOL: xml-file xml-file get T{ name f "" "this" "http://d.de" } swap at ] unit-test [ t ] [ xml-file get tag-children second contained-tag? ] unit-test -[ t ] [ [ "" string>xml ] catch xml-parse-error? ] unit-test +[ "" string>xml ] [ xml-parse-error? ] must-fail-with [ T{ comment f "This is where the fun begins!" } ] [ xml-file get xml-before [ comment? ] find nip ] unit-test diff --git a/misc/factor.sh b/misc/factor.sh index 032b0b3184..26ebd04531 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -45,7 +45,6 @@ check_gcc_version() { } check_installed_programs() { - ensure_program_installed sudo ensure_program_installed chmod ensure_program_installed uname ensure_program_installed git @@ -100,9 +99,9 @@ find_os() { uname_s=`uname -s` check_ret uname case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=windows-nt;; - *CYGWIN_NT*) OS=windows-nt;; - *CYGWIN*) OS=windows-nt;; + CYGWIN_NT-5.2-WOW64) OS=winnt;; + *CYGWIN_NT*) OS=winnt;; + *CYGWIN*) OS=winnt;; *darwin*) OS=macosx;; *Darwin*) OS=macosx;; *linux*) OS=linux;; @@ -140,7 +139,7 @@ find_word_size() { set_factor_binary() { case $OS in - windows-nt) FACTOR_BINARY=factor-nt;; + winnt) FACTOR_BINARY=factor-nt;; macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; *) FACTOR_BINARY=factor;; esac @@ -197,7 +196,7 @@ git_clone() { git_pull_factorcode() { echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git + git pull git://factorcode.org/git/factor.git master check_ret git } @@ -220,6 +219,7 @@ delete_boot_images() { echo "Deleting old images..." rm $BOOT_IMAGE > /dev/null 2>&1 rm $BOOT_IMAGE.* > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 } get_boot_image() { @@ -228,11 +228,23 @@ get_boot_image() { } maybe_download_dlls() { - if [[ $OS == windows-nt ]] ; then + if [[ $OS == winnt ]] ; then wget http://factorcode.org/dlls/freetype6.dll check_ret wget wget http://factorcode.org/dlls/zlib1.dll check_ret wget + wget http://factorcode.org/dlls/OpenAL32.dll + check_ret wget + wget http://factorcode.org/dlls/alut.dll + check_ret wget + wget http://factorcode.org/dlls/ogg.dll + check_ret wget + wget http://factorcode.org/dlls/theora.dll + check_ret wget + wget http://factorcode.org/dlls/vorbis.dll + check_ret wget + wget http://factorcode.org/dlls/sqlite3.dll + check_ret wget chmod 777 *.dll check_ret chmod fi diff --git a/unmaintained/mysql/load.factor b/unmaintained/mysql/load.factor deleted file mode 100644 index b3872d6259..0000000000 --- a/unmaintained/mysql/load.factor +++ /dev/null @@ -1,11 +0,0 @@ -! License: See http://factor.sf.net/license.txt for BSD license. -! Berlin Brown -! Date: 1/17/2007 -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a -PROVIDE: libs/mysql -{ +files+ { - "libmysql.factor" - "mysql.factor" -} } ; \ No newline at end of file diff --git a/unmaintained/mysql/mysql.factor b/unmaintained/mysql/mysql.factor deleted file mode 100644 index 22a6bc9248..0000000000 --- a/unmaintained/mysql/mysql.factor +++ /dev/null @@ -1,124 +0,0 @@ -! See http://factorcode.org/license.txt for license. -! Copyright (C) 2007 Berlin Brown -! Date: 1/17/2007 -! -! libs/mysql/mysql.factor -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a - -IN: mysql -USING: kernel alien errors io prettyprint - sequences namespaces arrays math tools generic ; - -SYMBOL: my-conn - -TUPLE: mysql-connection mysqlconn host user password db port handle resulthandle ; - -: init-mysql ( -- conn ) - f mysql_init ; - -C: mysql-connection ( host user password db port -- mysql-connection ) - [ set-mysql-connection-port ] keep - [ set-mysql-connection-db ] keep - [ set-mysql-connection-password ] keep - [ set-mysql-connection-user ] keep - [ set-mysql-connection-host ] keep ; - -: (mysql-error) ( mysql-connection -- str ) - mysql-connection-mysqlconn mysql_error ; - -: connect-error-msg ( mysql-connection -- s ) - mysql-connection-mysqlconn mysql_error - [ - "Couldn't connect to mysql database.\n" % - "Message: " % % - ] "" make ; - -: mysql-connect ( mysql-connection -- ) - init-mysql swap - [ set-mysql-connection-mysqlconn ] 2keep - [ mysql-connection-host ] keep - [ mysql-connection-user ] keep - [ mysql-connection-password ] keep - [ mysql-connection-db ] keep - [ mysql-connection-port f 0 mysql_real_connect ] keep - [ set-mysql-connection-handle ] keep - dup mysql-connection-handle - [ connect-error-msg throw ] unless ; - -! ========================================================= -! Low level mysql utility definitions -! ========================================================= - -: (mysql-query) ( mysql-connection query -- ret ) - >r mysql-connection-mysqlconn r> mysql_query ; - -: (mysql-result) ( mysql-connection -- ret ) - [ mysql-connection-mysqlconn mysql_use_result ] keep - [ set-mysql-connection-resulthandle ] keep ; - -: (mysql-affected-rows) ( mysql-connection -- n ) - mysql-connection-mysqlconn mysql_affected_rows ; - -: (mysql-free-result) ( mysql-connection -- ) - mysql-connection-resulthandle drop ; - -: (mysql-row) ( mysql-connection -- row ) - mysql-connection-resulthandle mysql_fetch_row ; - -: (mysql-num-cols) ( mysql-connection -- n ) - mysql-connection-resulthandle mysql_num_fields ; - -: mysql-char*-nth ( index object -- str ) - #! Utility based on 'char*-nth' to perform an additional sanity check on the value - #! extracted from the array of strings. - void*-nth [ alien>char-string ] [ "" ] if* ; - -: mysql-row>seq ( object n -- seq ) - [ swap mysql-char*-nth ] map-with ; - -: (mysql-result>seq) ( seq -- seq ) - my-conn get (mysql-row) dup [ - my-conn get (mysql-num-cols) mysql-row>seq - over push - (mysql-result>seq) - ] [ drop ] if - ! Perform needed cleanup on fetched results - my-conn get (mysql-free-result) ; - -! ========================================================= -! Public Word Definitions -! ========================================================= - -: mysql-close ( mysql-connection -- ) - mysql-connection-mysqlconn mysql_close ; - -: mysql-print-table ( seq -- ) - [ [ write bl ] each "\n" write ] each ; - -: mysql-query ( query -- ret ) - >r my-conn get r> (mysql-query) drop - my-conn get (mysql-result) ; - -: mysql-command ( query -- n ) - mysql-query drop - my-conn get (mysql-affected-rows) ; - -: mysql-error ( -- s ) - #! Get the last mysql error - my-conn get (mysql-error) ; - -: mysql-result>seq ( -- seq ) - V{ } clone (mysql-result>seq) ; - -: with-mysql ( host user password db port quot -- ) - [ - >r my-conn set - my-conn get mysql-connect drop r> - [ my-conn get mysql-close ] cleanup - ] with-scope ; inline - -: with-mysql-catch ( host user password db port quot -- ) - [ with-mysql ] catch [ "Caught: " write print ] when* ; - \ No newline at end of file diff --git a/unmaintained/mysql/test/create_database.sql b/unmaintained/mysql/test/create_database.sql deleted file mode 100644 index 00fd323046..0000000000 --- a/unmaintained/mysql/test/create_database.sql +++ /dev/null @@ -1,17 +0,0 @@ --- --- Create three databases (development / test / production) --- with prefix 'factordb_' -create database factordb_development; -create database factordb_test; -create database factordb_production; - -grant all on factordb_development.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; -grant all on factordb_test.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; -grant all on factordb_production.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; - -grant all on factordb_development.* to 'factoruser'@'*' identified by 'mysqlfactor'; -grant all on factordb_test.* to 'factoruser'@'*' identified by 'mysqlfactor'; -grant all on factordb_production.* to 'factoruser'@'*' identified by 'mysqlfactor'; - --- End of the Script - diff --git a/unmaintained/mysql/test/mysql-example.factor b/unmaintained/mysql/test/mysql-example.factor deleted file mode 100644 index 2476153c8a..0000000000 --- a/unmaintained/mysql/test/mysql-example.factor +++ /dev/null @@ -1,57 +0,0 @@ -! See http://factorcode.org/license.txt for license. -! Simple test for mysql library -! libs/mysql/test/mysql-example.factor - -IN: mysql-example -REQUIRES: libs/mysql ; -USING: sequences mysql modules prettyprint kernel io math tools namespaces test ; - -"Testing..." print nl - -: get-drop-table ( -- s ) - "DROP TABLE if exists DISCUSSION_FORUM" ; - -: get-insert-table ( -- s ) - { - "INSERT INTO DISCUSSION_FORUM(category, full_name, email, title, main_url, keywords, message) " - "VALUES('none', 'John Doe', 'johndoe@test.com', 'The Message', NULL, NULL, 'Testing')" - } "" join ; - -: get-update-table ( -- s ) - "UPDATE DISCUSSION_FORUM set category = 'my-new-category'" ; - -: get-delete-table ( -- s ) - "DELETE FROM DISCUSSION_FORUM where id = 2" ; - -: get-create-table ( -- s ) - { - "create table DISCUSSION_FORUM(" - "id int(11) NOT NULL auto_increment," - "category varchar(128)," - "full_name varchar(128) NOT NULL," - "email varchar(128) NOT NULL," - "title varchar(255) NOT NULL," - "main_url varchar(255)," - "keywords varchar(255)," - "message text NOT NULL," - "created_on DATETIME NOT NULL DEFAULT '0000-00-0000:00:00'," - "PRIMARY KEY (id));" - } "" join ; - -[ "localhost" "factoruser" "mysqlfactor" "factordb_development" 0 [ - get-drop-table mysql-command drop - get-create-table mysql-command drop - get-update-table mysql-command drop - get-delete-table mysql-command drop - - ! Insert multiple records - 20 [ - get-insert-table mysql-command 2drop - ] each - - "select * from discussion_forum order by created_on" mysql-query drop - mysql-result>seq mysql-print-table - -] with-mysql ] time - -"Done" print \ No newline at end of file diff --git a/vm/Config.windows.nt.x86.32 b/vm/Config.windows.nt.x86.32 index 9a020a7bc1..603a7200ae 100644 --- a/vm/Config.windows.nt.x86.32 +++ b/vm/Config.windows.nt.x86.32 @@ -1,3 +1,4 @@ WINDRES=windres include vm/Config.windows.nt include vm/Config.x86.32 +#error "lolllll" diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64 index 1c30e64096..6d3865c2f4 100644 --- a/vm/Config.windows.nt.x86.64 +++ b/vm/Config.windows.nt.x86.64 @@ -1,4 +1,6 @@ -CC=/k/target/bin/x86_64-pc-mingw32-gcc +#WIN64_PATH=/k/MinGW/win64/bin +WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32 +CC=$(WIN64_PATH)-gcc.exe +WINDRES=$(WIN64_PATH)-windres.exe include vm/Config.windows.nt include vm/Config.x86.64 -WINDRES = /k/target/bin/windres diff --git a/vm/os-windows-nt.32.h b/vm/os-windows-nt.32.h new file mode 100644 index 0000000000..9b10671ba0 --- /dev/null +++ b/vm/os-windows-nt.32.h @@ -0,0 +1,2 @@ +#define ESP Esp +#define EIP Eip diff --git a/vm/os-windows-nt.64.h b/vm/os-windows-nt.64.h new file mode 100644 index 0000000000..1f61c2335f --- /dev/null +++ b/vm/os-windows-nt.64.h @@ -0,0 +1,2 @@ +#define ESP Rsp +#define EIP Rip diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 99ac21f62f..cc7b128941 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -42,26 +42,26 @@ long exception_handler(PEXCEPTION_POINTERS pe) PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; - if(in_code_heap_p(c->Eip)) - signal_callstack_top = (void *)c->Esp; + if(in_code_heap_p(c->EIP)) + signal_callstack_top = (void *)c->ESP; else signal_callstack_top = NULL; if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { signal_fault_addr = e->ExceptionInformation[1]; - c->Eip = (CELL)memory_signal_handler_impl; + c->EIP = (CELL)memory_signal_handler_impl; } else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO || e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO) { signal_number = ERROR_DIVIDE_BY_ZERO; - c->Eip = (CELL)divide_by_zero_signal_handler_impl; + c->EIP = (CELL)divide_by_zero_signal_handler_impl; } else { signal_number = 11; - c->Eip = (CELL)misc_signal_handler_impl; + c->EIP = (CELL)misc_signal_handler_impl; } return EXCEPTION_CONTINUE_EXECUTION; diff --git a/vm/platform.h b/vm/platform.h index b0641176bc..66f22bbf96 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -1,11 +1,11 @@ #if defined(__arm__) #define FACTOR_ARM +#elif defined(__amd64__) || defined(__x86_64__) + #define FACTOR_AMD64 #elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #define FACTOR_X86 #elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) #define FACTOR_PPC -#elif defined(__amd64__) || defined(__x86_64__) - #define FACTOR_AMD64 #else #error "Unsupported architecture" #endif @@ -18,6 +18,11 @@ #endif #include "os-windows.h" + #if defined(FACTOR_AMD64) + #include "os-windows-nt.64.h" + #elif defined(FACTOR_X86) + #include "os-windows-nt.32.h" + #endif #else #include "os-unix.h"