diff --git a/Makefile b/Makefile index aad7fe90eb..9776027a59 100755 --- a/Makefile +++ b/Makefile @@ -63,8 +63,9 @@ default: @echo "macosx-ppc" @echo "solaris-x86-32" @echo "solaris-x86-64" - @echo "windows-ce-arm" - @echo "windows-nt-x86-32" + @echo "wince-arm" + @echo "winnt-x86-32" + @echo "winnt-x86-64" @echo "" @echo "Additional modifiers:" @echo "" @@ -122,10 +123,21 @@ solaris-x86-32: solaris-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 -windows-nt-x86-32: +freetype6.dll: + wget http://factorcode.org/dlls/freetype6.dll + chmod 755 freetype6.dll + +zlib1.dll: + wget http://factorcode.org/dlls/zlib1.dll + chmod 755 zlib1.dll + +winnt-x86-32: freetype6.dll zlib1.dll $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 -windows-ce-arm: +winnt-x86-64: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 + +wince-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm macosx.app: factor @@ -151,7 +163,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-docs.factor b/core/alien/c-types/c-types-docs.factor index f6418295f7..f4aa297a3a 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -34,6 +34,10 @@ HELP: stack-size { $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; +HELP: byte-length +{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } } +{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ; + HELP: c-getter { $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } } { $description "Outputs a quotation which reads values of this C type from a C structure." } 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/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 88df823e5b..fbd49cedbb 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -1,11 +1,17 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays arrays generator.registers assocs -kernel kernel.private libc math namespaces parser sequences -strings words assocs splitting math.parser cpu.architecture -alien alien.accessors quotations system compiler.units ; +USING: bit-arrays byte-arrays float-arrays arrays +generator.registers assocs kernel kernel.private libc math +namespaces parser sequences strings words assocs splitting +math.parser cpu.architecture alien alien.accessors quotations +system compiler.units ; IN: alien.c-types +DEFER: +DEFER: *char + +: little-endian? ( -- ? ) 1 *char 1 = ; foldable + TUPLE: c-type boxer prep unboxer getter setter @@ -107,6 +113,14 @@ M: string stack-size c-type stack-size ; M: c-type stack-size c-type-size ; +GENERIC: byte-length ( seq -- n ) flushable + +M: bit-array byte-length length 7 + -3 shift ; + +M: byte-array byte-length length ; + +M: float-array byte-length length "double" heap-size * ; + : c-getter ( name -- quot ) c-type c-type-getter [ [ "Cannot read struct fields with type" throw ] @@ -205,6 +219,9 @@ M: long-long-type box-return ( type -- ) over [ tuck 0 ] over c-setter append swap >r >r constructor-word r> r> add* define-inline ; +: c-bool> ( int -- ? ) + zero? not ; + : >c-array ( seq type word -- ) >r >r dup length dup r> dup -roll r> [ execute ] 2curry 2each ; inline diff --git a/core/compiler/test/alien.factor b/core/alien/compiler/compiler-tests.factor similarity index 86% rename from core/compiler/test/alien.factor rename to core/alien/compiler/compiler-tests.factor index e737a76e1e..c0c3733afa 100755 --- a/core/compiler/test/alien.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,346 +1,356 @@ -IN: temporary -USING: alien alien.c-types alien.syntax compiler kernel -namespaces namespaces tools.test sequences inference words -arrays parser quotations continuations inference.backend effects -namespaces.private io io.streams.string memory system threads -tools.test.inference ; - -FUNCTION: void ffi_test_0 ; -[ ] [ ffi_test_0 ] unit-test - -FUNCTION: int ffi_test_1 ; -[ 3 ] [ ffi_test_1 ] unit-test - -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 - -FUNCTION: int ffi_test_3 int x int y int z int t ; -[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test - -FUNCTION: float ffi_test_4 ; -[ 1.5 ] [ ffi_test_4 ] unit-test - -FUNCTION: double ffi_test_5 ; -[ 1.5 ] [ ffi_test_5 ] unit-test - -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 - -C-STRUCT: foo - { "int" "x" } - { "int" "y" } -; - -: make-foo ( x y -- foo ) - "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; - -FUNCTION: int ffi_test_11 int a foo b int c ; - -[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test - -FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; - -[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test - -FUNCTION: foo ffi_test_14 int x int y ; - -[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test - -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 - -C-STRUCT: bar - { "long" "x" } - { "long" "y" } - { "long" "z" } -; - -FUNCTION: bar ffi_test_16 long x long y long z ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z -] unit-test - -C-STRUCT: tiny - { "int" "x" } -; - -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 - -: indirect-test-1 - "int" { } "cdecl" alien-indirect ; - -{ 1 1 } [ indirect-test-1 ] unit-test-effect - -[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test - -[ -1 indirect-test-1 ] unit-test-fails - -: indirect-test-2 - "int" { "int" "int" } "cdecl" alien-indirect data-gc ; - -{ 3 1 } [ indirect-test-2 ] unit-test-effect - -[ 5 ] -[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] -unit-test - -: indirect-test-3 - "int" { "int" "int" "int" "int" } "stdcall" alien-indirect - data-gc ; - -<< "f-stdcall" f "stdcall" add-library >> - -[ f ] [ "f-stdcall" load-library ] unit-test -[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test - -: ffi_test_18 ( w x y z -- int ) - "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } - alien-invoke data-gc ; - -[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test - -: ffi_test_19 ( x y z -- bar ) - "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } - alien-invoke data-gc ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z -] 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 - -FUNCTION: double ffi_test_7 double x double y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test - -FUNCTION: double ffi_test_8 double x float y double z float t int w ; -[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test - -FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; -[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test - -FUNCTION: void ffi_test_20 double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3 ; - -[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test - -! Make sure XT doesn't get clobbered in stack frame - -: ffi_test_31 - "void" - f "ffi_test_31" - { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } - alien-invoke code-gc 3 ; - -[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test - -FUNCTION: longlong ffi_test_21 long x long y ; - -[ 121932631112635269 ] -[ 123456789 987654321 ffi_test_21 ] unit-test - -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 - -C-STRUCT: rect - { "float" "x" } - { "float" "y" } - { "float" "w" } - { "float" "h" } -; - -: - "rect" - [ set-rect-h ] keep - [ set-rect-w ] keep - [ set-rect-y ] keep - [ set-rect-x ] keep ; - -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 - -FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; - -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test - -! Test odd-size structs -C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; - -FUNCTION: test-struct-1 ffi_test_24 ; - -[ B{ 1 } ] [ ffi_test_24 ] unit-test - -C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; - -FUNCTION: test-struct-2 ffi_test_25 ; - -[ B{ 1 2 } ] [ ffi_test_25 ] unit-test - -C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; - -FUNCTION: test-struct-3 ffi_test_26 ; - -[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test - -C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; - -FUNCTION: test-struct-4 ffi_test_27 ; - -[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test - -C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; - -FUNCTION: test-struct-5 ffi_test_28 ; - -[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test - -C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; - -FUNCTION: test-struct-6 ffi_test_29 ; - -[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test - -C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; - -FUNCTION: test-struct-7 ffi_test_30 ; - -[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test - -C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; - -FUNCTION: double ffi_test_32 test-struct-8 x int y ; - -[ 9.0 ] [ - "test-struct-8" - 1.0 over set-test-struct-8-x - 2.0 over set-test-struct-8-y - 3 ffi_test_32 -] unit-test - -C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; - -FUNCTION: double ffi_test_33 test-struct-9 x int y ; - -[ 9.0 ] [ - "test-struct-9" - 1.0 over set-test-struct-9-x - 2.0 over set-test-struct-9-y - 3 ffi_test_33 -] unit-test - -C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_34 test-struct-10 x int y ; - -[ 9.0 ] [ - "test-struct-10" - 1.0 over set-test-struct-10-x - 2 over set-test-struct-10-y - 3 ffi_test_34 -] unit-test - -C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_35 test-struct-11 x int y ; - -[ 9.0 ] [ - "test-struct-11" - 1 over set-test-struct-11-x - 2 over set-test-struct-11-y - 3 ffi_test_35 -] unit-test - -! Test callbacks - -: callback-1 "void" { } "cdecl" [ ] alien-callback ; - -[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test - -[ t ] [ callback-1 alien? ] unit-test - -: callback_test_1 "void" { } "cdecl" alien-indirect ; - -[ ] [ callback-1 callback_test_1 ] unit-test - -: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ; - -[ ] [ callback-2 callback_test_1 ] unit-test - -: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; - -[ t ] [ - namestack* - 3 "x" set callback-3 callback_test_1 - namestack* eq? -] unit-test - -[ 5 ] [ - [ - 3 "x" set callback-3 callback_test_1 "x" get - ] with-scope -] unit-test - -: callback-4 - "void" { } "cdecl" [ "Hello world" write ] alien-callback - data-gc ; - -[ "Hello world" ] [ - [ callback-4 callback_test_1 ] string-out -] unit-test - -: callback-5 - "void" { } "cdecl" [ data-gc ] alien-callback ; - -[ "testing" ] [ - "testing" callback-5 callback_test_1 -] unit-test - -: callback-5a - "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; - -! Hack; if we're on ARM, we probably don't have much RAM, so -! skip this test. -cpu "arm" = [ - [ "testing" ] [ - "testing" callback-5a callback_test_1 - ] unit-test -] unless - -: callback-6 - "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; - -[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test - -: callback-7 - "void" { } "cdecl" [ 1000 sleep ] alien-callback ; - -[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test - -[ f ] [ namespace global eq? ] unit-test - -: callback-8 - "void" { } "cdecl" [ - [ continue ] callcc0 - ] alien-callback ; - -[ ] [ callback-8 callback_test_1 ] unit-test +IN: temporary +USING: alien alien.c-types alien.syntax compiler kernel +namespaces namespaces tools.test sequences inference words +arrays parser quotations continuations inference.backend effects +namespaces.private io io.streams.string memory system threads +tools.test ; + +FUNCTION: void ffi_test_0 ; +[ ] [ ffi_test_0 ] unit-test + +FUNCTION: int ffi_test_1 ; +[ 3 ] [ ffi_test_1 ] unit-test + +FUNCTION: int ffi_test_2 int x int y ; +[ 5 ] [ 2 3 ffi_test_2 ] unit-test +[ "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 + +FUNCTION: float ffi_test_4 ; +[ 1.5 ] [ ffi_test_4 ] unit-test + +FUNCTION: double ffi_test_5 ; +[ 1.5 ] [ ffi_test_5 ] unit-test + +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 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail + +C-STRUCT: foo + { "int" "x" } + { "int" "y" } +; + +: make-foo ( x y -- foo ) + "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; + +FUNCTION: int ffi_test_11 int a foo b int c ; + +[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test + +FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; + +[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test + +FUNCTION: foo ffi_test_14 int x int y ; + +[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test + +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 ] must-fail + +C-STRUCT: bar + { "long" "x" } + { "long" "y" } + { "long" "z" } +; + +FUNCTION: bar ffi_test_16 long x long y long z ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z +] unit-test + +C-STRUCT: tiny + { "int" "x" } +; + +FUNCTION: tiny ffi_test_17 int x ; + +[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test + +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with + +: indirect-test-1 + "int" { } "cdecl" alien-indirect ; + +{ 1 1 } [ indirect-test-1 ] must-infer-as + +[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test + +[ -1 indirect-test-1 ] must-fail + +: indirect-test-2 + "int" { "int" "int" } "cdecl" alien-indirect data-gc ; + +{ 3 1 } [ indirect-test-2 ] must-infer-as + +[ 5 ] +[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] +unit-test + +: indirect-test-3 + "int" { "int" "int" "int" "int" } "stdcall" alien-indirect + data-gc ; + +<< "f-stdcall" f "stdcall" add-library >> + +[ f ] [ "f-stdcall" load-library ] unit-test +[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test + +: ffi_test_18 ( w x y z -- int ) + "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } + alien-invoke data-gc ; + +[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test + +: ffi_test_19 ( x y z -- bar ) + "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } + alien-invoke data-gc ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z +] 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 ] must-fail + +FUNCTION: double ffi_test_7 double x double y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test + +FUNCTION: double ffi_test_8 double x float y double z float t int w ; +[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test + +FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; +[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test + +FUNCTION: void ffi_test_20 double x1, double x2, double x3, + double y1, double y2, double y3, + double z1, double z2, double z3 ; + +[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test + +! Make sure XT doesn't get clobbered in stack frame + +: ffi_test_31 + "void" + f "ffi_test_31" + { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } + alien-invoke code-gc 3 ; + +[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + +FUNCTION: longlong ffi_test_21 long x long y ; + +[ 121932631112635269 ] +[ 123456789 987654321 ffi_test_21 ] unit-test + +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 ] must-fail + +C-STRUCT: rect + { "float" "x" } + { "float" "y" } + { "float" "w" } + { "float" "h" } +; + +: + "rect" + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +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 ] must-fail + +FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; + +[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test + +! Test odd-size structs +C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; + +FUNCTION: test-struct-1 ffi_test_24 ; + +[ B{ 1 } ] [ ffi_test_24 ] unit-test + +C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; + +FUNCTION: test-struct-2 ffi_test_25 ; + +[ B{ 1 2 } ] [ ffi_test_25 ] unit-test + +C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; + +FUNCTION: test-struct-3 ffi_test_26 ; + +[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test + +C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; + +FUNCTION: test-struct-4 ffi_test_27 ; + +[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test + +C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; + +FUNCTION: test-struct-5 ffi_test_28 ; + +[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test + +C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; + +FUNCTION: test-struct-6 ffi_test_29 ; + +[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test + +C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; + +FUNCTION: test-struct-7 ffi_test_30 ; + +[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test + +C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; + +FUNCTION: double ffi_test_32 test-struct-8 x int y ; + +[ 9.0 ] [ + "test-struct-8" + 1.0 over set-test-struct-8-x + 2.0 over set-test-struct-8-y + 3 ffi_test_32 +] unit-test + +C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; + +FUNCTION: double ffi_test_33 test-struct-9 x int y ; + +[ 9.0 ] [ + "test-struct-9" + 1.0 over set-test-struct-9-x + 2.0 over set-test-struct-9-y + 3 ffi_test_33 +] unit-test + +C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_34 test-struct-10 x int y ; + +[ 9.0 ] [ + "test-struct-10" + 1.0 over set-test-struct-10-x + 2 over set-test-struct-10-y + 3 ffi_test_34 +] unit-test + +C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_35 test-struct-11 x int y ; + +[ 9.0 ] [ + "test-struct-11" + 1 over set-test-struct-11-x + 2 over set-test-struct-11-y + 3 ffi_test_35 +] unit-test + +C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; + +: make-struct-12 + "test-struct-12" + [ set-test-struct-12-x ] keep ; + +FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; + +[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test + +! Test callbacks + +: callback-1 "void" { } "cdecl" [ ] alien-callback ; + +[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test + +[ t ] [ callback-1 alien? ] unit-test + +: callback_test_1 "void" { } "cdecl" alien-indirect ; + +[ ] [ callback-1 callback_test_1 ] unit-test + +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; + +[ ] [ callback-2 callback_test_1 ] unit-test + +: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; + +[ t ] [ + namestack* + 3 "x" set callback-3 callback_test_1 + namestack* eq? +] unit-test + +[ 5 ] [ + [ + 3 "x" set callback-3 callback_test_1 "x" get + ] with-scope +] unit-test + +: callback-4 + "void" { } "cdecl" [ "Hello world" write ] alien-callback + data-gc ; + +[ "Hello world" ] [ + [ callback-4 callback_test_1 ] string-out +] unit-test + +: callback-5 + "void" { } "cdecl" [ data-gc ] alien-callback ; + +[ "testing" ] [ + "testing" callback-5 callback_test_1 +] unit-test + +: callback-5a + "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; + +! Hack; if we're on ARM, we probably don't have much RAM, so +! skip this test. +cpu "arm" = [ + [ "testing" ] [ + "testing" callback-5a callback_test_1 + ] unit-test +] unless + +: callback-6 + "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; + +[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test + +: callback-7 + "void" { } "cdecl" [ 1000 sleep ] alien-callback ; + +[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test + +[ f ] [ namespace global eq? ] unit-test + +: callback-8 + "void" { } "cdecl" [ + [ continue ] callcc0 + ] alien-callback ; + +[ ] [ callback-8 callback_test_1 ] unit-test diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 51240a66d9..54348e47f9 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs -kernel.private threads continuations.private libc combinators ; +kernel.private threads continuations.private libc combinators +compiler.errors continuations ; IN: alien.compiler ! Common protocol for alien-invoke/alien-callback/alien-indirect @@ -207,9 +208,21 @@ M: alien-invoke-error summary swap alien-node-parameters parameter-sizes drop number>string 3append ; +TUPLE: no-such-library name ; + +M: no-such-library summary + drop "Library not found" ; + +: no-such-library ( name -- ) + \ no-such-library +linkage+ (inference-error) ; + : (alien-invoke-dlsym) ( node -- symbol dll ) dup alien-invoke-function - swap alien-invoke-library load-library ; + swap alien-invoke-library [ + load-library + ] [ + 2drop no-such-library + ] recover ; TUPLE: no-such-symbol ; @@ -217,7 +230,7 @@ M: no-such-symbol summary drop "Symbol not found" ; : no-such-symbol ( -- ) - \ no-such-symbol inference-error ; + \ no-such-symbol +linkage+ (inference-error) ; : alien-invoke-dlsym ( node -- symbol dll ) dup (alien-invoke-dlsym) 2dup dlsym [ 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/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index ea533f0d6f..8c618a8f30 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,6 +1,5 @@ IN: temporary -USING: bootstrap.image bootstrap.image.private -tools.test.inference ; +USING: bootstrap.image bootstrap.image.private tools.test ; \ ' must-infer \ write-image must-infer diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index e9ee569fd6..7c12b3ea60 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -7,9 +7,26 @@ strings sbufs vectors words quotations assocs system layouts splitting growable classes tuples words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger float-arrays quotations.private -combinators.private combinators ; +sequences.private combinators ; IN: bootstrap.image +: my-arch ( -- arch ) + cpu dup "ppc" = [ os "-" rot 3append ] when ; + +: boot-image-name ( arch -- string ) + "boot." swap ".image" 3append ; + +: my-boot-image-name ( -- string ) + my-arch boot-image-name ; + +: images ( -- seq ) + { + "x86.32" + "x86.64" + "linux-ppc" "macosx-ppc" + ! "arm" + } ; + seq dup length 1+ emit-fixnum @@ -197,13 +215,10 @@ M: f ' : 1, 1 >bignum ' 1-offset fixup ; : -1, -1 >bignum ' -1-offset fixup ; -! Beginning of the image - -: begin-image ( -- ) emit-header t, 0, 1, -1, ; - ! Words : emit-word ( word -- ) + dup subwords [ emit-word ] each [ dup hashcode ' , dup word-name ' , @@ -224,7 +239,7 @@ M: f ' [ % dup word-vocabulary % " " % word-name % ] "" make throw ; : transfer-word ( word -- word ) - dup target-word [ ] [ word-name no-word ] ?if ; + dup target-word swap or ; : fixup-word ( word -- offset ) transfer-word dup objects get at @@ -248,7 +263,7 @@ M: wrapper ' emit-seq ; : pack-string ( string -- newstr ) - dup length 1+ bootstrap-cell align 0 pad-right ; + dup length bootstrap-cell align 0 pad-right ; : emit-string ( string -- ptr ) string type-number object tag-number [ @@ -285,17 +300,20 @@ M: float-array ' float-array emit-dummy-array ; ] emit-object ; : emit-tuple ( obj -- pointer ) - objects get [ + [ [ tuple>array unclip transfer-word , % ] { } make tuple type-number dup emit-array - ] cache ; inline + ] + ! Hack + over class word-name "tombstone" = + [ objects get swap cache ] [ call ] if ; M: tuple ' emit-tuple ; M: tombstone ' delegate "((tombstone))" "((empty))" ? "hashtables.private" lookup - word-def first emit-tuple ; + word-def first objects get [ emit-tuple ] cache ; M: array ' array type-number object tag-number emit-array ; @@ -313,41 +331,6 @@ M: quotation ' ] emit-object ] cache ; -! Vectors and sbufs - -M: vector ' - dup length swap underlying ' - tuple type-number tuple tag-number [ - 4 emit-fixnum - vector ' emit - f ' emit - emit ! array ptr - emit-fixnum ! length - ] emit-object ; - -M: sbuf ' - dup length swap underlying ' - tuple type-number tuple tag-number [ - 4 emit-fixnum - sbuf ' emit - f ' emit - emit ! array ptr - emit-fixnum ! length - ] emit-object ; - -! Hashes - -M: hashtable ' - [ hash-array ' ] keep - tuple type-number tuple tag-number [ - 5 emit-fixnum - hashtable ' emit - f ' emit - dup hash-count emit-fixnum - hash-deleted emit-fixnum - emit ! array ptr - ] emit-object ; - ! Curries M: curry ' @@ -399,7 +382,10 @@ M: curry ' : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; -: end-image ( -- ) +: build-image ( -- image ) + 800000 image set + 20000 objects set + emit-header t, 0, 1, -1, "Serializing words..." print flush emit-words "Serializing JIT data..." print flush @@ -414,7 +400,8 @@ M: curry ' fixup-header "Image length: " write image get length . "Object cache size: " write objects get assoc-size . - \ word global delete-at ; + \ word global delete-at + image get ; ! Image output @@ -425,37 +412,23 @@ M: curry ' [ >le write ] curry each ] if ; -: image-name - "boot." architecture get ".image" 3append resource-path ; - -: write-image ( image filename -- ) - "Writing image to " write dup write "..." print flush +: write-image ( image -- ) + "Writing image to " write + architecture get boot-image-name resource-path + dup write "..." print flush [ (write-image) ] with-stream ; -: prepare-image ( -- ) - bootstrapping? on - load-help? off - 800000 image set - 20000 objects set ; - PRIVATE> : make-image ( arch -- ) - architecture [ - prepare-image - begin-image + [ + architecture set + bootstrapping? on + load-help? off "resource:/core/bootstrap/stage1.factor" run-file - end-image - image get image-name write-image - ] with-variable ; - -: my-arch ( -- arch ) - cpu dup "ppc" = [ os "-" rot 3append ] when ; + build-image + write-image + ] with-scope ; : make-images ( -- ) - { - "x86.32" - "x86.64" - "linux-ppc" "macosx-ppc" - ! "arm" - } [ make-image ] each ; + images [ make-image ] each ; diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 9c0d6b9838..e15a7b4d7c 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel alien byte-arrays hashtables vectors strings sbufs arrays bit-arrays @@ -8,7 +8,7 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -20 num-types set +19 num-types set H{ { fixnum BIN: 000 } @@ -27,11 +27,10 @@ tag-numbers get H{ { float-array 10 } { callstack 11 } { string 12 } - { curry 13 } + { bit-array 13 } { quotation 14 } { dll 15 } { alien 16 } { word 17 } { byte-array 18 } - { bit-array 19 } } union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 545d904c9c..66ede8b054 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -118,11 +118,11 @@ H{ } clone update-map set H{ } clone typemap set num-types get f builtins set -! These symbols are needed by the code that executes below -{ - { "object" "kernel" } - { "null" "kernel" } -} [ create drop ] assoc-each +! Forward definitions +"object" "kernel" create t "class" set-word-prop +"object" "kernel" create union-class "metaclass" set-word-prop + +"null" "kernel" create drop "fixnum" "math" create "fixnum?" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop @@ -295,23 +295,6 @@ define-builtin "float-array?" "float-arrays" create { } define-builtin -"curry" "kernel" create -"curry?" "kernel" create -{ - { - { "object" "kernel" } - "obj" - { "curry-obj" "kernel" } - f - } - { - { "object" "kernel" } - "obj" - { "curry-quot" "kernel" } - f - } -} define-builtin - "callstack" "kernel" create "callstack?" "kernel" create { } define-builtin @@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class } } define-tuple-class +"curry" "kernel" create +{ + { + { "object" "kernel" } + "obj" + { "curry-obj" "kernel" } + f + } { + { "object" "kernel" } + "quot" + { "curry-quot" "kernel" } + f + } +} define-tuple-class + +"compose" "kernel" create +{ + { + { "object" "kernel" } + "first" + { "compose-first" "kernel" } + f + } { + { "object" "kernel" } + "second" + { "compose-second" "kernel" } + f + } +} define-tuple-class + ! Primitive words : make-primitive ( word vocab n -- ) - >r create dup reset-word r> [ do-primitive ] curry [ ] like define ; + >r create dup reset-word r> + [ do-primitive ] curry [ ] like define ; { { "(execute)" "words.private" } { "(call)" "kernel.private" } - { "uncurry" "kernel.private" } { "bignum>fixnum" "math.private" } { "float>fixnum" "math.private" } { "fixnum>bignum" "math.private" } @@ -553,8 +566,6 @@ builtins get num-tags get tail f union-class define-class { "millis" "system" } { "type" "kernel.private" } { "tag" "kernel.private" } - { "cwd" "io.files" } - { "cd" "io.files" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } { "dlsym" "alien" } @@ -624,7 +635,6 @@ builtins get num-tags get tail f union-class define-class { "become" "kernel.private" } { "(sleep)" "threads.private" } { "" "float-arrays" } - { "curry" "kernel" } { "" "tuples.private" } { "class-hash" "kernel.private" } { "callstack>array" "kernel" } diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 8af1bfdec9..4f5bf6d69e 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -32,12 +32,13 @@ vocabs.loader system ; "io.streams.c" require "vocabs.loader" require + "syntax" require "bootstrap.layouts" require [ "resource:core/bootstrap/stage2.factor" - dup ?resource-path exists? [ + dup resource-exists? [ run-file ] [ "Cannot find " write write "." print diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 5a5a8d1c67..9dd56c6524 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -1,31 +1,70 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init command-line namespaces words debugger io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser ; +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 - "math tools help compiler ui ui.tools io" "include" set-global + 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-sources - ] unless + "-no-crossref" cli-args member? [ do-crossref ] unless ! Set dll paths wince? [ "windows.ce" require ] when @@ -39,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 @@ -73,19 +105,13 @@ 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 ] [ - print-error :c "listener" vocab-main execute + print-error :c restarts. + "listener" vocab-main execute + 1 exit ] recover 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/classes/classes.factor b/core/classes/classes.factor index a6a1db7045..345676e106 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: classes USING: arrays definitions assocs kernel @@ -20,7 +20,9 @@ PREDICATE: class tuple-class : classes ( -- seq ) classclass ( n -- class ) builtins get nth ; +: type>class ( n -- class ) builtins get-global nth ; + +: bootstrap-type>class ( n -- class ) builtins get nth ; : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 0adbdc080d..332903d36b 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,19 +1,34 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -generic.standard namespaces arrays ; +generic.standard namespaces arrays math quotations ; IN: classes.union PREDICATE: class union-class "metaclass" word-prop union-class eq? ; ! Union classes for dispatch on multiple classes. +: small-union-predicate-quot ( members -- quot ) + dup empty? [ + drop [ drop f ] + ] [ + unclip first "predicate" word-prop swap + [ >r "predicate" word-prop [ dup ] swap append r> ] + assoc-map alist>quot + ] if ; + +: big-union-predicate-quot ( members -- quot ) + [ small-union-predicate-quot ] [ dup ] + class-hash-dispatch-quot ; + : union-predicate-quot ( members -- quot ) - 0 (dispatch#) [ - [ [ drop t ] ] { } map>assoc - object bootstrap-word [ drop f ] 2array add* - single-combination - ] with-variable ; + [ [ drop t ] ] { } map>assoc + dup length 4 <= [ + small-union-predicate-quot + ] [ + flatten-methods + big-union-predicate-quot + ] if ; : define-union-predicate ( class -- ) dup predicate-word diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor old mode 100644 new mode 100755 index 4cea78bc97..d91c920def --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -1,6 +1,6 @@ USING: arrays help.markup help.syntax strings sbufs vectors kernel quotations generic generic.standard classes -math assocs sequences combinators.private ; +math assocs sequences sequences.private ; IN: combinators ARTICLE: "combinators-quot" "Quotation construction utilities" 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/combinators/combinators.factor b/core/combinators/combinators.factor index f532f06293..0ba8b583be 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -4,12 +4,6 @@ IN: combinators USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors ; - - TUPLE: no-cond ; : no-cond ( -- * ) \ no-cond construct-empty throw ; diff --git a/core/compiler/compiler-tests.factor b/core/compiler/compiler-tests.factor deleted file mode 100644 index bd9b26ce6d..0000000000 --- a/core/compiler/compiler-tests.factor +++ /dev/null @@ -1,21 +0,0 @@ -USING: io.files tools.test sequences namespaces kernel -compiler.units ; - -{ - "templates-early" - "simple" - "intrinsics" - "float" - "generic" - "ifte" - "templates" - "optimizer" - "redefine" - "stack-trace" - "alien" - "curry" - "tuples" -} -[ "resource:core/compiler/test/" swap ".factor" 3append ] map -[ run-test ] map -[ failures get push-all ] each diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 1e6d4f8a17..2674734483 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -26,7 +26,7 @@ IN: compiler >r dupd save-effect r> f pick compiler-error over compiled-unxref - over word-vocabulary [ compiled-xref ] [ 2drop ] if ; + over crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index 13fc0d3103..678face309 100755 --- a/core/compiler/errors/errors-docs.factor +++ b/core/compiler/errors/errors-docs.factor @@ -1,14 +1,15 @@ IN: compiler.errors USING: help.markup help.syntax vocabs.loader words io -quotations ; +quotations compiler.errors.private ; ARTICLE: "compiler-errors" "Compiler warnings and errors" -"The compiler saves compile warnings and errors in a global variable:" +"The compiler saves various notifications in a global variable:" { $subsection compiler-errors } -"The warnings and errors can be viewed later:" -{ $subsection :warnings } +"These notifications can be viewed later:" { $subsection :errors } -"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:" +{ $subsection :warnings } +{ $subsection :linkage } +"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:" { $link with-compiler-errors } ; HELP: compiler-errors @@ -16,7 +17,7 @@ HELP: compiler-errors HELP: compiler-error { $values { "error" "an error" } { "word" word } } -{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ; +{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ; HELP: compiler-error. { $values { "error" "an error" } { "word" word } } @@ -25,24 +26,18 @@ HELP: compiler-error. HELP: compiler-errors. { $values { "errors" "an assoc mapping words to errors" } } { $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ; - -HELP: (:errors) -{ $values { "seq" "an alist" } } -{ $description "Outputs all serious compiler errors from the most recent compile." } ; - HELP: :errors { $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ; -HELP: (:warnings) -{ $values { "seq" "an alist" } } -{ $description "Outputs all ignorable compiler warnings from the most recent compile." } ; - HELP: :warnings { $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ; -{ :errors (:errors) :warnings (:warnings) } related-words +HELP: :linkage +{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ; + +{ :errors :warnings } related-words HELP: with-compiler-errors { $values { "quot" quotation } } -{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." } +{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." } { $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index 363c13c478..b7b599e5a9 100755 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -4,51 +4,66 @@ USING: kernel namespaces assocs prettyprint io sequences sorting continuations debugger math math.parser ; IN: compiler.errors +SYMBOL: +error+ +SYMBOL: +warning+ +SYMBOL: +linkage+ + +GENERIC: compiler-error-type ( error -- ? ) + +M: object compiler-error-type drop +error+ ; + +alist sort-keys [ swap compiler-error. ] assoc-each ; - -GENERIC: compiler-warning? ( error -- ? ) - -M: object compiler-warning? drop f ; - -: (:errors) ( -- assoc ) +: errors-of-type ( type -- assoc ) compiler-errors get-global - [ nip compiler-warning? not ] assoc-subset ; + swap [ >r nip compiler-error-type r> eq? ] curry + assoc-subset ; -: :errors (:errors) compiler-errors. ; +: compiler-errors. ( type -- ) + errors-of-type >alist sort-keys + [ swap compiler-error. ] assoc-each ; -: (:warnings) ( -- seq ) - compiler-errors get-global - [ nip compiler-warning? ] assoc-subset ; - -: :warnings (:warnings) compiler-errors. ; - -: (compiler-report) ( what assoc -- ) - length dup zero? [ 2drop ] [ +: (compiler-report) ( what type word -- ) + over errors-of-type assoc-empty? [ 3drop ] [ [ - ":" % over % " - print " % # " compiler " % % "." % + ":" % + % + " - print " % + errors-of-type assoc-size # + " " % + % + "." % ] "" make print ] if ; : compiler-report ( -- ) - "errors" (:errors) (compiler-report) - "warnings" (:warnings) (compiler-report) ; + "semantic errors" +error+ "errors" (compiler-report) + "semantic warnings" +warning+ "warnings" (compiler-report) + "linkage errors" +linkage+ "linkage" (compiler-report) ; + +PRIVATE> + +: compiler-error ( error word -- ) + with-compiler-errors? get [ + compiler-errors get pick + [ set-at ] [ delete-at drop ] if + ] [ 2drop ] if ; + +: :errors +error+ compiler-errors. ; + +: :warnings +warning+ compiler-errors. ; + +: :linkage +linkage+ compiler-errors. ; : with-compiler-errors ( quot -- ) with-compiler-errors? get "quiet" get or [ call ] [ diff --git a/core/compiler/test/generic.factor b/core/compiler/test/generic.factor deleted file mode 100644 index c54dbd753d..0000000000 --- a/core/compiler/test/generic.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: temporary -USING: compiler generic tools.test math kernel words arrays -sequences quotations ; - -GENERIC: single-combination-test - -M: object single-combination-test drop ; -M: f single-combination-test nip ; -M: array single-combination-test drop ; -M: integer single-combination-test drop ; - -[ 2 3 ] [ 2 3 t single-combination-test ] unit-test -[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test -[ 2 f ] [ 2 3 f single-combination-test ] unit-test - -DEFER: single-combination-test-2 - -: single-combination-test-4 - dup [ single-combination-test-2 ] when ; - -: single-combination-test-3 - drop 3 ; - -GENERIC: single-combination-test-2 -M: object single-combination-test-2 single-combination-test-3 ; -M: f single-combination-test-2 single-combination-test-4 ; - -[ 3 ] [ t single-combination-test-2 ] unit-test -[ 3 ] [ 3 single-combination-test-2 ] unit-test -[ f ] [ f single-combination-test-2 ] unit-test diff --git a/core/compiler/test/ifte.factor b/core/compiler/test/ifte.factor deleted file mode 100755 index 802cad5032..0000000000 --- a/core/compiler/test/ifte.factor +++ /dev/null @@ -1,131 +0,0 @@ -IN: temporary -USING: alien strings compiler tools.test math kernel words -math.private combinators ; - -: dummy-if-1 t [ ] [ ] if ; - -[ ] [ dummy-if-1 ] unit-test - -: dummy-if-2 f [ ] [ ] if ; - -[ ] [ dummy-if-2 ] unit-test - -: dummy-if-3 t [ 1 ] [ 2 ] if ; - -[ 1 ] [ dummy-if-3 ] unit-test - -: dummy-if-4 f [ 1 ] [ 2 ] if ; - -[ 2 ] [ dummy-if-4 ] unit-test - -: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ; - -[ 1 ] [ dummy-if-5 ] unit-test - -: dummy-if-6 - dup 1 fixnum<= [ - drop 1 - ] [ - 1 fixnum- dup 1 fixnum- fixnum+ - ] if ; - -[ 17 ] [ 10 dummy-if-6 ] unit-test - -: dead-code-rec - t [ - 3.2 - ] [ - dead-code-rec - ] if ; - -[ 3.2 ] [ dead-code-rec ] unit-test - -: one-rec [ f one-rec ] [ "hi" ] if ; - -[ "hi" ] [ t one-rec ] unit-test - -: after-if-test - t [ ] [ ] if 5 ; - -[ 5 ] [ after-if-test ] unit-test - -DEFER: countdown-b - -: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ; -: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ; - -[ ] [ 10 countdown-b ] unit-test - -: dummy-when-1 t [ ] when ; - -[ ] [ dummy-when-1 ] unit-test - -: dummy-when-2 f [ ] when ; - -[ ] [ dummy-when-2 ] unit-test - -: dummy-when-3 dup [ dup fixnum* ] when ; - -[ 16 ] [ 4 dummy-when-3 ] unit-test -[ f ] [ f dummy-when-3 ] unit-test - -: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ; - -[ 64 f ] [ f 4 dummy-when-4 ] unit-test -[ f t ] [ t f dummy-when-4 ] unit-test - -: dummy-when-5 f [ dup fixnum* ] when ; - -[ f ] [ f dummy-when-5 ] unit-test - -: dummy-unless-1 t [ ] unless ; - -[ ] [ dummy-unless-1 ] unit-test - -: dummy-unless-2 f [ ] unless ; - -[ ] [ dummy-unless-2 ] unit-test - -: dummy-unless-3 dup [ drop 3 ] unless ; - -[ 3 ] [ f dummy-unless-3 ] unit-test -[ 4 ] [ 4 dummy-unless-3 ] unit-test - -! Test cond expansion -[ "even" ] [ - [ - 2 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond - ] compile-call -] unit-test - -[ "odd" ] [ - [ - 3 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond - ] compile-call -] unit-test - -[ "neither" ] [ - [ - 3 { - { [ dup string? ] [ drop "string" ] } - { [ dup float? ] [ drop "float" ] } - { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } - } cond - ] compile-call -] unit-test - -[ 3 ] [ - [ - 3 { - { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } - } cond - ] compile-call -] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor deleted file mode 100755 index 01dd27f8be..0000000000 --- a/core/compiler/test/redefine.factor +++ /dev/null @@ -1,252 +0,0 @@ -USING: compiler definitions generic assocs inference math -namespaces parser tools.test words kernel sequences arrays io -effects tools.test.inference compiler.units inference.state ; -IN: temporary - -DEFER: x-1 -DEFER: x-2 - -[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [ - "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval - "IN: temporary : x-2 3 x-1 ;" eval - - [ t ] [ - { x-2 } compile - - \ x-2 word-xt - - { x-1 } compile - - \ x-2 word-xt = - ] unit-test -] with-variable - -DEFER: b -DEFER: c - -[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test - -[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test - -{ 0 4 } [ b ] unit-test-effect - -[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test - -[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test - -{ 0 6 } [ b ] unit-test-effect - -\ b word-xt "b-xt" set - -[ ] [ "IN: temporary : c b ;" eval ] unit-test - -[ t ] [ "b-xt" get \ b word-xt = ] unit-test - -\ c word-xt "c-xt" set - -[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test - -[ t ] [ "c-xt" get \ c word-xt = ] unit-test - -[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test - -[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test - -{ 0 4 } [ c ] unit-test-effect - -[ f ] [ "c-xt" get \ c word-xt = ] unit-test - -[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test - -[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test - -[ ] [ "IN: temporary : e d d ;" eval ] unit-test - -[ 3 3 ] [ "USE: temporary e" eval ] unit-test - -[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test - -[ 4 4 ] [ "USE: temporary e" eval ] unit-test - -DEFER: x-3 - -[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test - -DEFER: x-4 - -[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test - -[ t ] [ \ x-4 compiled? ] unit-test - -[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test - -[ f ] [ \ x-3 compiled? ] unit-test - -[ f ] [ \ x-4 compiled? ] unit-test - -[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test - -[ t ] [ \ x-3 compiled? ] unit-test - -[ t ] [ \ x-4 compiled? ] unit-test - -[ 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 - -[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test - -[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test - -[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test - -[ 25 ] [ 5 g-test-1 ] unit-test - -[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test - -[ 5 ] [ 5 g-test-1 ] unit-test - -[ t ] [ - \ g-test-3 word-xt - - "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval - - \ g-test-3 word-xt = -] unit-test - -DEFER: g-test-5 - -[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test - -[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test - -[ 6 ] [ g-test-5 ] unit-test - -[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test - -[ 13 ] [ g-test-5 ] unit-test - -DEFER: g-test-6 - -[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test - -DEFER: g-test-7 - -[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test - -[ 133 ] [ g-test-7 ] unit-test - -[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test - -[ 138 ] [ g-test-7 ] unit-test - -USE: macros - -DEFER: macro-test-3 - -[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test - -[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) >quotation ;" eval ] unit-test - -[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test - -[ 625 ] [ 5 macro-test-3 ] unit-test - -[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test - -[ 8 ] [ 5 macro-test-3 ] unit-test - -USE: hints - -DEFER: hints-test-2 - -[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test - -[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test - -[ 8 ] [ hints-test-2 ] unit-test - -[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test - -[ 10 ] [ hints-test-2 ] unit-test - -DEFER: inline-then-not-inline-test-1 -DEFER: inline-then-not-inline-test-2 - -[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test - -[ ] [ "IN: temporary : inline-then-not-inline-test-2 inline-then-not-inline-test-1 ;" eval ] unit-test - -[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test - -\ inline-then-not-inline-test-2 word-xt "a" set - -[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test - -[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test - -[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test - -DEFER: generic-then-not-generic-test-1 -DEFER: generic-then-not-generic-test-2 - -[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test - -[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test - -[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test - -[ 9 ] [ generic-then-not-generic-test-2 ] unit-test - -[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test - -[ 4 ] [ generic-then-not-generic-test-2 ] unit-test - -DEFER: foldable-test-1 -DEFER: foldable-test-2 - -[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test - -[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test - -[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test - -[ 3 ] [ foldable-test-2 ] unit-test - -[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test - -[ 4 ] [ foldable-test-2 ] unit-test - -DEFER: flushable-test-2 - -[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test - -[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test - -[ V{ } ] [ flushable-test-2 ] unit-test - -[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test - -[ V{ 3 } ] [ flushable-test-2 ] unit-test - -: ax ; -: bx ax ; -[ \ bx forget ] with-compilation-unit - -[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test - -DEFER: defer-redefine-test-2 - -[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test - -[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test - -[ defer-redefine-test-2 ] unit-test-fails - -[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test - -[ 2 1 ] [ defer-redefine-test-2 ] unit-test diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor deleted file mode 100755 index 9f831bb1f8..0000000000 --- a/core/compiler/test/simple.factor +++ /dev/null @@ -1,71 +0,0 @@ -USING: compiler tools.test kernel kernel.private -combinators.private ; -IN: temporary - -! Test empty word -[ ] [ [ ] compile-call ] unit-test - -! Test literals -[ 1 ] [ [ 1 ] compile-call ] unit-test -[ 31 ] [ [ 31 ] compile-call ] unit-test -[ 255 ] [ [ 255 ] compile-call ] unit-test -[ -1 ] [ [ -1 ] compile-call ] unit-test -[ 65536 ] [ [ 65536 ] compile-call ] unit-test -[ -65536 ] [ [ -65536 ] compile-call ] unit-test -[ "hey" ] [ [ "hey" ] compile-call ] unit-test - -! Calls -: no-op ; - -[ ] [ [ no-op ] compile-call ] unit-test -[ 3 ] [ [ no-op 3 ] compile-call ] unit-test -[ 3 ] [ [ 3 no-op ] compile-call ] unit-test - -: bar 4 ; - -[ 4 ] [ [ bar no-op ] compile-call ] unit-test -[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test -[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test - -[ ] [ no-op ] unit-test - -! Conditionals - -[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test -[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test -[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test -[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test - -[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test -[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test - -[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test -[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test - -[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test -[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test -[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test -[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test - -! Labels - -: recursive ( ? -- ) [ f recursive ] when ; inline - -[ ] [ t [ recursive ] compile-call ] unit-test - -[ ] [ t recursive ] unit-test - -! Make sure error reporting works - -[ [ dup ] compile-call ] unit-test-fails -[ [ drop ] compile-call ] unit-test-fails - -! Regression - -[ ] [ [ callstack ] compile-call drop ] unit-test - -! Regression - -: empty ; - -[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test diff --git a/core/compiler/test/curry.factor b/core/compiler/tests/curry.factor similarity index 100% rename from core/compiler/test/curry.factor rename to core/compiler/tests/curry.factor diff --git a/core/compiler/test/float.factor b/core/compiler/tests/float.factor similarity index 100% rename from core/compiler/test/float.factor rename to core/compiler/tests/float.factor diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/tests/intrinsics.factor similarity index 99% rename from core/compiler/test/intrinsics.factor rename to core/compiler/tests/intrinsics.factor index 1d0ad141c2..5dfe447443 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -4,7 +4,7 @@ math.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays strings.private system random layouts vectors.private sbufs.private strings.private slots.private alien alien.accessors -alien.c-types alien.syntax namespaces libc combinators.private ; +alien.c-types alien.syntax namespaces libc sequences.private ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test @@ -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/tests/simple.factor b/core/compiler/tests/simple.factor new file mode 100755 index 0000000000..1ed43120d3 --- /dev/null +++ b/core/compiler/tests/simple.factor @@ -0,0 +1,229 @@ +USING: compiler tools.test kernel kernel.private +sequences.private math.private math combinators strings +alien arrays memory ; +IN: temporary + +! Test empty word +[ ] [ [ ] compile-call ] unit-test + +! Test literals +[ 1 ] [ [ 1 ] compile-call ] unit-test +[ 31 ] [ [ 31 ] compile-call ] unit-test +[ 255 ] [ [ 255 ] compile-call ] unit-test +[ -1 ] [ [ -1 ] compile-call ] unit-test +[ 65536 ] [ [ 65536 ] compile-call ] unit-test +[ -65536 ] [ [ -65536 ] compile-call ] unit-test +[ "hey" ] [ [ "hey" ] compile-call ] unit-test + +! Calls +: no-op ; + +[ ] [ [ no-op ] compile-call ] unit-test +[ 3 ] [ [ no-op 3 ] compile-call ] unit-test +[ 3 ] [ [ 3 no-op ] compile-call ] unit-test + +: bar 4 ; + +[ 4 ] [ [ bar no-op ] compile-call ] unit-test +[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test +[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test + +[ ] [ no-op ] unit-test + +! Conditionals + +[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test +[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test + +[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test +[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test + +[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test +[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test + +[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test + +[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test + +! Labels + +: recursive ( ? -- ) [ f recursive ] when ; inline + +[ ] [ t [ recursive ] compile-call ] unit-test + +[ ] [ t recursive ] unit-test + +! Make sure error reporting works + +[ [ dup ] compile-call ] must-fail +[ [ drop ] compile-call ] must-fail + +! Regression + +[ ] [ [ callstack ] compile-call drop ] unit-test + +! Regression + +: empty ; + +[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test + +: dummy-if-1 t [ ] [ ] if ; + +[ ] [ dummy-if-1 ] unit-test + +: dummy-if-2 f [ ] [ ] if ; + +[ ] [ dummy-if-2 ] unit-test + +: dummy-if-3 t [ 1 ] [ 2 ] if ; + +[ 1 ] [ dummy-if-3 ] unit-test + +: dummy-if-4 f [ 1 ] [ 2 ] if ; + +[ 2 ] [ dummy-if-4 ] unit-test + +: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ; + +[ 1 ] [ dummy-if-5 ] unit-test + +: dummy-if-6 + dup 1 fixnum<= [ + drop 1 + ] [ + 1 fixnum- dup 1 fixnum- fixnum+ + ] if ; + +[ 17 ] [ 10 dummy-if-6 ] unit-test + +: dead-code-rec + t [ + 3.2 + ] [ + dead-code-rec + ] if ; + +[ 3.2 ] [ dead-code-rec ] unit-test + +: one-rec [ f one-rec ] [ "hi" ] if ; + +[ "hi" ] [ t one-rec ] unit-test + +: after-if-test + t [ ] [ ] if 5 ; + +[ 5 ] [ after-if-test ] unit-test + +DEFER: countdown-b + +: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ; +: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ; + +[ ] [ 10 countdown-b ] unit-test + +: dummy-when-1 t [ ] when ; + +[ ] [ dummy-when-1 ] unit-test + +: dummy-when-2 f [ ] when ; + +[ ] [ dummy-when-2 ] unit-test + +: dummy-when-3 dup [ dup fixnum* ] when ; + +[ 16 ] [ 4 dummy-when-3 ] unit-test +[ f ] [ f dummy-when-3 ] unit-test + +: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ; + +[ 64 f ] [ f 4 dummy-when-4 ] unit-test +[ f t ] [ t f dummy-when-4 ] unit-test + +: dummy-when-5 f [ dup fixnum* ] when ; + +[ f ] [ f dummy-when-5 ] unit-test + +: dummy-unless-1 t [ ] unless ; + +[ ] [ dummy-unless-1 ] unit-test + +: dummy-unless-2 f [ ] unless ; + +[ ] [ dummy-unless-2 ] unit-test + +: dummy-unless-3 dup [ drop 3 ] unless ; + +[ 3 ] [ f dummy-unless-3 ] unit-test +[ 4 ] [ 4 dummy-unless-3 ] unit-test + +! Test cond expansion +[ "even" ] [ + [ + 2 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-call +] unit-test + +[ "odd" ] [ + [ + 3 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-call +] unit-test + +[ "neither" ] [ + [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + { [ t ] [ drop "neither" ] } + } cond + ] compile-call +] unit-test + +[ 3 ] [ + [ + 3 { + { [ dup fixnum? ] [ ] } + { [ t ] [ drop t ] } + } cond + ] compile-call +] unit-test + +GENERIC: single-combination-test + +M: object single-combination-test drop ; +M: f single-combination-test nip ; +M: array single-combination-test drop ; +M: integer single-combination-test drop ; + +[ 2 3 ] [ 2 3 t single-combination-test ] unit-test +[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test +[ 2 f ] [ 2 3 f single-combination-test ] unit-test + +DEFER: single-combination-test-2 + +: single-combination-test-4 + dup [ single-combination-test-2 ] when ; + +: single-combination-test-3 + drop 3 ; + +GENERIC: single-combination-test-2 +M: object single-combination-test-2 single-combination-test-3 ; +M: f single-combination-test-2 single-combination-test-4 ; + +[ 3 ] [ t single-combination-test-2 ] unit-test +[ 3 ] [ 3 single-combination-test-2 ] unit-test +[ f ] [ f single-combination-test-2 ] unit-test diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/tests/stack-trace.factor similarity index 81% rename from core/compiler/test/stack-trace.factor rename to core/compiler/tests/stack-trace.factor index 59ee3c3d88..71c95b1b61 100755 --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/tests/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/compiler/test/templates-early.factor b/core/compiler/tests/templates-early.factor similarity index 100% rename from core/compiler/test/templates-early.factor rename to core/compiler/tests/templates-early.factor diff --git a/core/compiler/test/templates.factor b/core/compiler/tests/templates.factor similarity index 98% rename from core/compiler/test/templates.factor rename to core/compiler/tests/templates.factor index 08e1c98729..74e5ab80a4 100755 --- a/core/compiler/test/templates.factor +++ b/core/compiler/tests/templates.factor @@ -2,7 +2,7 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private -combinators.private byte-arrays alien alien.accessors layouts +sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units ; IN: temporary diff --git a/core/compiler/test/tuples.factor b/core/compiler/tests/tuples.factor similarity index 100% rename from core/compiler/test/tuples.factor rename to core/compiler/tests/tuples.factor diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor old mode 100644 new mode 100755 index 363b5b5014..99124d40ae --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -28,9 +28,7 @@ HELP: redefine-error HELP: remember-definition { $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } } -{ $description "Saves the location of a definition and associates this definition with the current source file." -$nl -"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ; +{ $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: old-definitions { $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ; @@ -38,11 +36,6 @@ HELP: old-definitions HELP: new-definitions { $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ; -HELP: forward-error -{ $values { "word" word } } -{ $description "Throws a " { $link forward-error } "." } -{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ; - HELP: with-compilation-unit { $values { "quot" quotation } } { $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." } diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 68e1a79185..242ed9854a 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -26,11 +26,6 @@ TUPLE: redefine-error def ; over new-definitions get first key? [ dup redefine-error ] when new-definitions get second (remember-definition) ; -TUPLE: forward-error word ; - -: forward-error ( word -- ) - \ forward-error construct-boa throw ; - : forward-reference? ( word -- ? ) dup old-definitions get assoc-stack [ new-definitions get assoc-stack not ] diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 51e461c715..7cf15394ef 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:" @@ -175,7 +169,7 @@ HELP: rethrow HELP: throw-restarts { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } -{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." } +{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." } { $examples "Try invoking one of the two restarts which are offered after the below code throws an error:" { $code 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..81f78f491d 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 @@ -101,7 +98,7 @@ PRIVATE> : continue-with ( obj continuation -- ) [ walker-hook [ >r 2array r> ] when* (continue-with) - ] 2curry (throw) ; + ] 2 (throw) ; : continue ( continuation -- ) f swap continue-with ; @@ -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/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4da22ff38a..4bb10b23a2 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- ) ! Test if vreg is 'f' or not HOOK: %jump-t compiler-backend ( label -- ) -HOOK: %call-dispatch compiler-backend ( -- label ) - -HOOK: %jump-dispatch compiler-backend ( -- ) +HOOK: %dispatch compiler-backend ( -- ) HOOK: %dispatch-label compiler-backend ( word -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 7444c21a8c..1daf3ac622 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ; M: ppc-backend %jump-t ( label -- ) 0 "flag" operand f v>operand CMPI BNE ; -: (%dispatch) ( len -- ) - 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here - "offset" operand "n" operand 1 SRAWI - 11 11 "offset" operand ADD - 11 dup rot cells LWZ ; - -M: ppc-backend %call-dispatch ( word-table# -- ) - [ 7 (%dispatch) (%call)