diff --git a/Makefile b/Makefile index 05a185f643..9776027a59 100755 --- a/Makefile +++ b/Makefile @@ -123,7 +123,15 @@ solaris-x86-32: solaris-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 -winnt-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 winnt-x86-64: diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 6c46cb946a..fbd49cedbb 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -7,6 +7,11 @@ 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 diff --git a/core/compiler/test/alien.factor b/core/alien/compiler/compiler-tests.factor similarity index 96% rename from core/compiler/test/alien.factor rename to core/alien/compiler/compiler-tests.factor index 4adb1c234b..c0c3733afa 100755 --- a/core/compiler/test/alien.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,356 +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 ; - -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 +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/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 7452e31cf8..7c12b3ea60 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -7,7 +7,7 @@ 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 ) @@ -136,7 +136,7 @@ SYMBOL: undefined-quot : here-as ( tag -- pointer ) here swap bitor ; : align-here ( -- ) - here 8 mod 4 = [ 0 emit ] when ; + here 8 mod 4 = [ heap-size drop 0 emit ] when ; : emit-fixnum ( n -- ) tag-fixnum emit ; @@ -177,6 +177,7 @@ GENERIC: ' ( obj -- ptr ) [ dup bignum-bits neg shift swap bignum-radix bitand ] [ ] unfold nip ; +USE: continuations : emit-bignum ( n -- ) dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq dup length 1+ emit-fixnum @@ -214,10 +215,6 @@ 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 -- ) @@ -385,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 @@ -400,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 @@ -411,28 +412,23 @@ M: curry ' [ >le write ] curry each ] if ; -: 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 - architecture get boot-image-name resource-path + build-image write-image - ] with-variable ; + ] with-scope ; : make-images ( -- ) 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 967840a3dc..66ede8b054 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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" } @@ -622,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 cc328e9760..4f5bf6d69e 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -38,7 +38,7 @@ vocabs.loader system ; [ "resource:core/bootstrap/stage2.factor" - dup ?resource-path exists? [ + dup resource-exists? [ run-file ] [ "Cannot find " write write "." print diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 151429bf69..345676e106 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -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/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.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/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 9eaf2d1263..0000000000 --- a/core/compiler/test/redefine.factor +++ /dev/null @@ -1,287 +0,0 @@ -USING: compiler definitions generic assocs inference math -namespaces parser tools.test words kernel sequences arrays io -effects tools.test 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 ] must-infer-as - -[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test - -[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test - -{ 0 6 } [ b ] must-infer-as - -\ 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 ] must-infer-as - -[ 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 - -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 - -[ f ] [ \ bx \ ax compiled-usage key? ] 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 ] 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 deleted file mode 100755 index 6f5cb33c1a..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 ] 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 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 679938b7f3..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 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 100% rename from core/compiler/test/stack-trace.factor rename to core/compiler/tests/stack-trace.factor 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/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 2977d02c6f..7cf15394ef 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -169,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.factor b/core/continuations/continuations.factor index b6ca056691..81f78f491d 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -98,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 ; 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)