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/compiler/compiler-tests.factor b/core/compiler/compiler-tests.factor old mode 100644 new mode 100755 index bd9b26ce6d..7e4e79437d --- a/core/compiler/compiler-tests.factor +++ b/core/compiler/compiler-tests.factor @@ -1,21 +1,7 @@ -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 +IN: temporary +USING: tools.browser tools.test kernel sequences vocabs ; + +"compiler.test" child-vocabs empty? [ + "compiler.test" load-children + "compiler.test" test +] when diff --git a/core/compiler/test/curry.factor b/core/compiler/test/curry/curry-tests.factor similarity index 100% rename from core/compiler/test/curry.factor rename to core/compiler/test/curry/curry-tests.factor diff --git a/core/compiler/test/curry/curry.factor b/core/compiler/test/curry/curry.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/float.factor b/core/compiler/test/float/float-tests.factor similarity index 100% rename from core/compiler/test/float.factor rename to core/compiler/test/float/float-tests.factor diff --git a/core/compiler/test/float/float.factor b/core/compiler/test/float/float.factor new file mode 100644 index 0000000000..e69de29bb2 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/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics-tests.factor similarity index 100% rename from core/compiler/test/intrinsics.factor rename to core/compiler/test/intrinsics/intrinsics-tests.factor diff --git a/core/compiler/test/intrinsics/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine/redefine-tests.factor similarity index 100% rename from core/compiler/test/redefine.factor rename to core/compiler/test/redefine/redefine-tests.factor diff --git a/core/compiler/test/redefine/redefine.factor b/core/compiler/test/redefine/redefine.factor new file mode 100644 index 0000000000..e69de29bb2 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/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor new file mode 100755 index 0000000000..3f4f6451a3 --- /dev/null +++ b/core/compiler/test/simple/simple-tests.factor @@ -0,0 +1,227 @@ +USING: compiler tools.test kernel kernel.private +combinators.private math.private math combinators strings +alien arrays ; +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 + +: 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/simple/simple.factor b/core/compiler/test/simple/simple.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace-tests.factor similarity index 100% rename from core/compiler/test/stack-trace.factor rename to core/compiler/test/stack-trace/stack-trace-tests.factor diff --git a/core/compiler/test/stack-trace/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early/templates-early-tests.factor similarity index 100% rename from core/compiler/test/templates-early.factor rename to core/compiler/test/templates-early/templates-early-tests.factor diff --git a/core/compiler/test/templates-early/templates-early.factor b/core/compiler/test/templates-early/templates-early.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates/templates-tests.factor similarity index 100% rename from core/compiler/test/templates.factor rename to core/compiler/test/templates/templates-tests.factor diff --git a/core/compiler/test/templates/templates.factor b/core/compiler/test/templates/templates.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/tuples.factor b/core/compiler/test/tuples/tuples-tests.factor similarity index 100% rename from core/compiler/test/tuples.factor rename to core/compiler/test/tuples/tuples-tests.factor diff --git a/core/compiler/test/tuples/tuples.factor b/core/compiler/test/tuples/tuples.factor new file mode 100644 index 0000000000..e69de29bb2 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/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 3bd90a3aca..17cc3d3cf8 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -263,3 +263,13 @@ cell-bits 32 = [ \ fixnum-shift inlined? ] unit-test ] when + +[ t ] [ + [ B{ 1 0 } *short 0 number= ] + \ number= inlined? +] unit-test + +[ t ] [ + [ B{ 1 0 } *short 0 = ] + \ number= inlined? +] unit-test diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 6be3899acd..69e331a9bf 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -414,64 +414,81 @@ t over set-effect-terminated? \ make-flushable \ alien-signed-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-cell make-flushable \ set-alien-signed-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-cell make-flushable \ set-alien-unsigned-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-8 make-flushable \ set-alien-signed-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-8 make-flushable \ set-alien-unsigned-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-4 make-flushable \ set-alien-signed-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-4 make-flushable \ set-alien-unsigned-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-2 make-flushable \ set-alien-signed-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-2 make-flushable \ set-alien-unsigned-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-1 make-flushable \ set-alien-signed-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-1 make-flushable \ set-alien-unsigned-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-float make-flushable \ set-alien-float { float c-ptr integer } { } "inferred-effect" set-word-prop \ alien-double { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-double make-flushable \ set-alien-double { float c-ptr integer } { } "inferred-effect" set-word-prop \ alien-cell { c-ptr integer } { simple-c-ptr } "inferred-effect" set-word-prop +\ alien-cell make-flushable \ set-alien-cell { c-ptr c-ptr integer } { } "inferred-effect" set-word-prop \ alien>char-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>char-string make-flushable \ string>char-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>char-alien make-flushable \ alien>u16-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>u16-string make-flushable \ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>u16-alien make-flushable \ alien-address { alien } { integer } "inferred-effect" set-word-prop \ alien-address make-flushable diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index ad2bacc789..b1b56ca1a1 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -54,7 +54,9 @@ M: pair (bitfield-quot) ( spec -- quot ) \ bitfield [ bitfield-quot ] 1 define-transform -\ flags [ flags [ ] curry ] 1 define-transform +\ flags [ + [ 0 , [ , \ bitor , ] each ] [ ] make +] 1 define-transform ! Tuple operations : [get-slots] ( slots -- quot ) diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor old mode 100644 new mode 100755 index c382d3352d..a10c0566f8 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,4 +1,4 @@ -USING: math math.bitfields tools.test kernel ; +USING: math math.bitfields tools.test kernel words ; IN: temporary [ 0 ] [ { } bitfield ] unit-test @@ -6,3 +6,12 @@ IN: temporary [ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test [ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test [ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test + +: a 1 ; inline +: b 2 ; inline + +: foo { a b } flags ; + +[ 3 ] [ foo ] unit-test +[ 3 ] [ { a b } flags ] unit-test +[ t ] [ \ foo compiled? ] unit-test diff --git a/core/compiler/test/optimizer.factor b/core/optimizer/optimizer-tests.factor similarity index 95% rename from core/compiler/test/optimizer.factor rename to core/optimizer/optimizer-tests.factor index 7ee4ebfd1c..232eb5a83a 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,302 +1,303 @@ -USING: arrays compiler generic hashtables inference kernel -kernel.private math optimizer prettyprint sequences sbufs -strings tools.test vectors words sequences.private quotations -optimizer.backend classes inference.dataflow tuples.private -continuations growable ; -IN: temporary - -[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* -] unit-test - -[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* -] unit-test - -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - -GENERIC: xyz ( obj -- obj ) -M: array xyz xyz ; - -[ t ] [ \ xyz compiled? ] unit-test - -! Test predicate inlining -: pred-test-1 - dup fixnum? [ - dup integer? [ "integer" ] [ "nope" ] if - ] [ - "not a fixnum" - ] if ; - -[ 1 "integer" ] [ 1 pred-test-1 ] unit-test - -TUPLE: pred-test ; - -: pred-test-2 - dup tuple? [ - dup pred-test? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test - -: pred-test-3 - dup pred-test? [ - dup tuple? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test - -: inline-test - "nom" = ; - -[ t ] [ "nom" inline-test ] unit-test -[ f ] [ "shayin" inline-test ] unit-test -[ f ] [ 3 inline-test ] unit-test - -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; - -[ ] [ 1000000 fixnum-declarations . ] unit-test - -! regression - -: literal-not-branch 0 not [ ] [ ] if ; - -[ ] [ literal-not-branch ] unit-test - -! regression - -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; - -[ 3 ] [ t bad-kill-2 ] unit-test - -! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- x y ) 2 dup (the-test) ; - -[ 2 0 ] [ the-test ] unit-test - -! regression -: (double-recursion) ( start end -- ) - < [ - 6 1 (double-recursion) - 3 2 (double-recursion) - ] when ; inline - -: double-recursion 0 2 (double-recursion) ; - -[ ] [ double-recursion ] unit-test - -! regression -: double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline - -: double-label-2 ( a -- b ) - dup array? [ ] [ ] if 0 t double-label-1 ; - -[ 0 ] [ 10 double-label-2 ] unit-test - -! regression -GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test -[ breakage ] must-fail - -! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - -: branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline - -: branch-fold-regression-1 ( -- m ) - 10 branch-fold-regression-0 ; - -[ 10 ] [ branch-fold-regression-1 ] unit-test - -! another regression -: constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test - -! another regression -: foo f ; -: bar foo 4 4 = and ; -[ f ] [ bar ] unit-test - -! ensure identities are working in some form -[ t ] [ - [ { number } declare 0 + ] dataflow optimize - [ #push? ] node-exists? not -] unit-test - -! compiling with a non-literal class failed -: -regression ; - -[ t ] [ \ -regression compiled? ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ reversed ] [ reversed \ foozul specific-method ] unit-test - -! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable - -[ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-call -] unit-test - -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable - -[ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-call -] unit-test - -[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test -[ 0 ] [ 5 [ dup - ] compile-call ] unit-test - -[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test - -[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test - -[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test - -[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test - -[ f ] [ 5 [ dup < ] compile-call ] unit-test -[ t ] [ 5 [ dup <= ] compile-call ] unit-test -[ f ] [ 5 [ dup > ] compile-call ] unit-test -[ t ] [ 5 [ dup >= ] compile-call ] unit-test - -[ t ] [ 5 [ dup eq? ] compile-call ] unit-test -[ t ] [ 5 [ dup = ] compile-call ] unit-test -[ t ] [ 5 [ dup number= ] compile-call ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test - -GENERIC: detect-number ( obj -- obj ) -M: number detect-number ; - -[ 10 f [ 0 + detect-number ] compile-call ] must-fail - -! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test - -! Regression -USE: sorting -USE: sorting.private - -: old-binsearch ( elt quot seq -- elt quot i ) - dup length 1 <= [ - slice-from - ] [ - [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if - ] if ; inline - -[ 10 ] [ - 10 20 >vector - [ [ - ] swap old-binsearch ] compile-call 2nip -] unit-test - -! Regression -TUPLE: silly-tuple a b ; - -[ 1 2 { silly-tuple-a silly-tuple-b } ] [ - T{ silly-tuple f 1 2 } - [ - { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-call -] unit-test - -! Regression -: empty-compound ; - -: node-successor-f-bug ( x -- * ) - [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; - -[ t ] [ \ node-successor-f-bug compiled? ] unit-test - -: construct-empty-bug construct-empty ; - -[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test - -! Make sure we have sane heuristics -: should-inline? method method-word flat-length 10 <= ; - -[ t ] [ \ fixnum \ shift should-inline? ] unit-test -[ f ] [ \ array \ equal? should-inline? ] unit-test -[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test -[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +USING: arrays compiler generic hashtables inference kernel +kernel.private math optimizer prettyprint sequences sbufs +strings tools.test vectors words sequences.private quotations +optimizer.backend classes inference.dataflow tuples.private +continuations growable ; +IN: temporary + +[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* +] unit-test + +[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +GENERIC: xyz ( obj -- obj ) +M: array xyz xyz ; + +[ t ] [ \ xyz compiled? ] unit-test + +! Test predicate inlining +: pred-test-1 + dup fixnum? [ + dup integer? [ "integer" ] [ "nope" ] if + ] [ + "not a fixnum" + ] if ; + +[ 1 "integer" ] [ 1 pred-test-1 ] unit-test + +TUPLE: pred-test ; + +: pred-test-2 + dup tuple? [ + dup pred-test? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test + +: pred-test-3 + dup pred-test? [ + dup tuple? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test + +: inline-test + "nom" = ; + +[ t ] [ "nom" inline-test ] unit-test +[ f ] [ "shayin" inline-test ] unit-test +[ f ] [ 3 inline-test ] unit-test + +: fixnum-declarations >fixnum 24 shift 1234 bitxor ; + +[ ] [ 1000000 fixnum-declarations . ] unit-test + +! regression + +: literal-not-branch 0 not [ ] [ ] if ; + +[ ] [ literal-not-branch ] unit-test + +! regression + +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-2 bad-kill-1 drop ; + +[ 3 ] [ t bad-kill-2 ] unit-test + +! regression +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; + +[ 2 0 ] [ the-test ] unit-test + +! regression +: (double-recursion) ( start end -- ) + < [ + 6 1 (double-recursion) + 3 2 (double-recursion) + ] when ; inline + +: double-recursion 0 2 (double-recursion) ; + +[ ] [ double-recursion ] unit-test + +! regression +: double-label-1 ( a b c -- d ) + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + +: double-label-2 ( a -- b ) + dup array? [ ] [ ] if 0 t double-label-1 ; + +[ 0 ] [ 10 double-label-2 ] unit-test + +! regression +GENERIC: void-generic ( obj -- * ) +: breakage "hi" void-generic ; +[ t ] [ \ breakage compiled? ] unit-test +[ breakage ] must-fail + +! regression +: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline +: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline +: test-2 ( -- ) 5 test-1 ; + +[ f ] [ f test-2 ] unit-test + +: branch-fold-regression-0 ( m -- n ) + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + +: branch-fold-regression-1 ( -- m ) + 10 branch-fold-regression-0 ; + +[ 10 ] [ branch-fold-regression-1 ] unit-test + +! another regression +: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! another regression +: foo f ; +: bar foo 4 4 = and ; +[ f ] [ bar ] unit-test + +! ensure identities are working in some form +[ t ] [ + [ { number } declare 0 + ] dataflow optimize + [ #push? ] node-exists? not +] unit-test + +! compiling with a non-literal class failed +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ reversed ] [ reversed \ foozul specific-method ] unit-test + +! regression +: constant-fold-2 f ; foldable +: constant-fold-3 4 ; foldable + +[ f t ] [ + [ constant-fold-2 constant-fold-3 4 = ] compile-call +] unit-test + +: constant-fold-4 f ; foldable +: constant-fold-5 f ; foldable + +[ f ] [ + [ constant-fold-4 constant-fold-5 or ] compile-call +] unit-test + +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test + +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test + +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test + +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test + +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test + +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test + +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test + +GENERIC: detect-number ( obj -- obj ) +M: number detect-number ; + +[ 10 f [ 0 + detect-number ] compile-call ] must-fail + +! Regression +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test + +! Regression +USE: sorting +USE: sorting.private + +: old-binsearch ( elt quot seq -- elt quot i ) + dup length 1 <= [ + slice-from + ] [ + [ midpoint swap call ] 3keep roll dup zero? + [ drop dup slice-from swap midpoint@ + ] + [ partition old-binsearch ] if + ] if ; inline + +[ 10 ] [ + 10 20 >vector + [ [ - ] swap old-binsearch ] compile-call 2nip +] unit-test + +! Regression +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-call +] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test + +: construct-empty-bug construct-empty ; + +[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method method-word flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index d54bf1c1f4..486c589134 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -18,7 +18,7 @@ TUPLE: lexer text line line-text line-length column ; : ( text -- lexer ) 0 { set-lexer-text set-lexer-line } lexer construct - dup lexer-text empty? [ dup next-line ] unless ; + dup next-line ; : location ( -- loc ) file get lexer get lexer-line 2dup and diff --git a/extra/asn1/tags.txt b/extra/asn1/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/asn1/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index 54bc73f4a1..f57e92e5e0 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -9,6 +9,6 @@ IN: benchmark.bootstrap2 "-i=" my-boot-image-name append , "-output-image=foo.image" , "-no-user-init" , - ] { } make run-process drop ; + ] { } make try-process ; MAIN: bootstrap-benchmark diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index deed045221..df559f49da 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -23,3 +23,7 @@ bootstrap.image sequences io ; "Boot image up to date" print drop ] if ; + +: download-my-image ( -- ) my-arch download-image ; + +MAIN: download-my-image diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor old mode 100644 new mode 100755 index a9f5d1dcd4..3b5ab4cb77 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -16,8 +16,7 @@ bootstrap.image sequences io namespaces io.launcher math ; : upload-images ( -- ) [ "scp" , boot-image-names % "checksums.txt" , destination , - ] { } make run-process - wait-for-process zero? [ "Upload failed" throw ] unless ; + ] { } make try-process ; : new-images ( -- ) make-images compute-checksums upload-images ; diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100755 new mode 100644 index 5e992ccc81..1c5f5ff3fd --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,8 +1,8 @@ -USING: kernel io io.files io.launcher hashtables tools.deploy.backend +USING: kernel io io.files io.launcher hashtables system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client - combinators ; + combinators bootstrap.image bootstrap.image.download ; IN: builder @@ -59,8 +59,12 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: build-status + : build ( -- ) + "running" build-status set-global + datestamp >stamp "/builds/factor" cd @@ -70,7 +74,6 @@ VAR: stamp "pull" "--no-summary" "git://factorcode.org/git/factor.git" - ! "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status @@ -82,6 +85,11 @@ VAR: stamp ] if + { + "git" "pull" "--no-summary" + "http://dharmatech.onigirihouse.com/factor.git" "master" + } run-process drop + "/builds/" stamp> append make-directory "/builds/" stamp> append cd @@ -94,6 +102,8 @@ VAR: stamp { "make" "clean" } run-process drop + ! "vm" build-status set-global + `{ { +arguments+ { "make" ,[ target ] } } { +stdout+ "../compile-log" } @@ -107,14 +117,17 @@ VAR: stamp "builder: vm compile" throw ] if - [ "http://factorcode.org/images/latest/" boot-image-name append download ] + [ my-arch download-image ] + [ ] [ "builder: image download" email-string ] - recover + cleanup + + ! "bootstrap" build-status set-global `{ { +arguments+ { ,[ factor-binary ] - ,[ "-i=" boot-image-name append ] + ,[ "-i=" my-boot-image-name append ] "-no-user-init" } } { +stdout+ "../boot-log" } @@ -128,6 +141,8 @@ VAR: stamp "builder: bootstrap" throw ] if + ! "test" build-status set-global + `{ ,[ factor-binary ] "-run=builder.test" } run-process drop "../load-everything-log" exists? @@ -138,6 +153,8 @@ VAR: stamp [ "builder: failing tests" "../failing-tests" email-file ] when + ! "ready" build-status set-global + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor new file mode 100644 index 0000000000..672de1e47d --- /dev/null +++ b/extra/builder/server/server.factor @@ -0,0 +1,68 @@ + +USING: kernel continuations namespaces threads match bake concurrency builder ; + +IN: builder.server + +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ [ build ] in-thread ] +! } + +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ +! [ [ build ] [ drop ] recover "idle" build-status set-global ] in-thread +! ] +! } + +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build-server ( -- ) + receive + { + { + "start" + [ + build-status get "idle" = + build-status get f = + or + [ + [ [ build ] [ drop ] recover "idle" build-status set-global ] + in-thread + ] + when + ] + } + + { + { ?from ?tag "status" } + [ `{ ?tag ,[ build-status get ] } ?from send ] + } + } + match-cond + build-server ; + diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index fb9c62e2aa..c887c668e6 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -8,27 +8,17 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test : do-load ( -- ) - [ - [ load-everything ] - [ require-all-error-vocabs "../load-everything-log" log-object ] - recover - ] - "../load-everything-time" log-runtime ; + [ try-everything ] "../load-everything-time" log-runtime + dup empty? + [ drop ] + [ "../load-everything-log" log-object ] + if ; : do-tests ( -- ) - "" child-vocabs - [ vocab-source-loaded? ] subset - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - [ dup run-test ] { } map>assoc - [ second empty? not ] subset + run-all-tests keys dup empty? [ drop ] - [ - "../failing-tests" - [ [ nl failures. ] assoc-each ] - with-stream - ] + [ "../failing-tests" log-object ] if ; : do-all ( -- ) do-load do-tests ; diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index f04811b72a..16a2e65a90 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers" ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" { $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" { $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" +"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" { $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } "Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index b6f62d1779..1a19ce7096 100755 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -112,9 +112,9 @@ SYMBOL: value ! The following unit test blocks forever if the ! exception does not propogate. Uncomment when ! this is fixed (via a timeout). -! [ -! [ "this should propogate" throw ] future ?future -! ] must-fail +[ + [ "this should propogate" throw ] future ?future +] must-fail [ ] [ [ "this should not propogate" throw ] future drop @@ -127,4 +127,10 @@ SYMBOL: value [ f ] [ [ "testing unregistering on error" throw ] spawn 100 sleep process-pid get-process -] unit-test \ No newline at end of file +] unit-test + +! Race condition with futures +[ 3 3 ] [ + [ 3 ] future + dup ?future swap ?future +] unit-test \ No newline at end of file diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index cf44ab125c..a8e0bc6eeb 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,19 +264,31 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; -: future ( quot -- future ) - #! Spawn a process to call the quotation and immediately return - #! a 'future' on the stack. The future can later be queried with - #! ?future. If the quotation has completed the result will be returned. - #! If not, the process will block until the quotation completes. - #! 'quot' must have stack effect ( -- X ). - [ self send ] compose spawn ; +TUPLE: future value processes ; -: ?future ( future -- result ) +: notify-future ( value future -- ) + tuck set-future-value + dup future-processes [ schedule-thread ] each + f swap set-future-processes ; + +: future ( quot -- future ) + #! Spawn a process to call the quotation and immediately return. + \ future construct-empty [ + [ + >r [ t 2array ] compose [ f 2array ] recover r> + notify-future + ] 2curry spawn drop + ] keep ; + + : ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. - process-mailbox mailbox-get ; + dup future-value [ + first2 [ throw ] unless + ] [ + dup [ future-processes push stop ] curry callcc0 ?future + ] ?if ; : parallel-map ( seq quot -- newseq ) #! Spawn a process to apply quot to each element of seq, diff --git a/extra/concurrency/distributed/tags.txt b/extra/concurrency/distributed/tags.txt index f4274299b1..50cfa263f6 100644 --- a/extra/concurrency/distributed/tags.txt +++ b/extra/concurrency/distributed/tags.txt @@ -1 +1,2 @@ +enterprise extensions diff --git a/extra/cpu/8080/emulator/tags.txt b/extra/cpu/8080/emulator/tags.txt index 86069f7680..ff94650b8e 100644 --- a/extra/cpu/8080/emulator/tags.txt +++ b/extra/cpu/8080/emulator/tags.txt @@ -1 +1 @@ -emulator +emulators diff --git a/extra/cpu/8080/tags.txt b/extra/cpu/8080/tags.txt index 86069f7680..ff94650b8e 100644 --- a/extra/cpu/8080/tags.txt +++ b/extra/cpu/8080/tags.txt @@ -1 +1 @@ -emulator +emulators diff --git a/extra/cryptlib/tags.txt b/extra/cryptlib/tags.txt index bb863cf9a0..b88f9848cd 100644 --- a/extra/cryptlib/tags.txt +++ b/extra/cryptlib/tags.txt @@ -1 +1,2 @@ +enterprise bindings diff --git a/extra/db/authors.txt b/extra/db/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/db/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/db/summary.txt b/extra/db/summary.txt new file mode 100644 index 0000000000..daebf38da6 --- /dev/null +++ b/extra/db/summary.txt @@ -0,0 +1 @@ +Relational database abstraction layer diff --git a/extra/db/tags.txt b/extra/db/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/db/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/editors/emacs/emacs.factor b/extra/editors/emacs/emacs.factor index 31e0761043..966c4f368e 100755 --- a/extra/editors/emacs/emacs.factor +++ b/extra/editors/emacs/emacs.factor @@ -8,7 +8,7 @@ IN: editors.emacs "--no-wait" , "+" swap number>string append , , - ] { } make run-process drop ; + ] { } make try-process ; : emacs ( word -- ) where first2 emacsclient ; diff --git a/extra/editors/textmate/textmate.factor b/extra/editors/textmate/textmate.factor index 0145ccae81..12d45aa192 100755 --- a/extra/editors/textmate/textmate.factor +++ b/extra/editors/textmate/textmate.factor @@ -5,6 +5,6 @@ IN: editors.textmate : textmate-location ( file line -- ) [ "mate" , "-a" , "-l" , number>string , , ] { } make - run-process drop ; + try-process ; [ textmate-location ] edit-hook set-global diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/furnace/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/help/help.factor b/extra/help/help.factor index aefbf2aba2..77b9f699aa 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel namespaces parser prettyprint sequences -words assocs definitions generic quotations effects -slots continuations tuples debugger combinators -vocabs help.stylesheet help.topics help.crossref help.markup -sorting classes ; +words assocs definitions generic quotations effects slots +continuations tuples debugger combinators vocabs help.stylesheet +help.topics help.crossref help.markup sorting classes +vocabs.loader ; IN: help GENERIC: word-help* ( word -- content ) @@ -96,6 +96,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; article-content print-content nl ; : about ( vocab -- ) + dup require dup vocab [ ] [ "No such vocabulary: " swap append throw ] ?if diff --git a/extra/http/server/tags.txt b/extra/http/server/tags.txt index ebb39bcce3..b0881a9ec0 100644 --- a/extra/http/server/tags.txt +++ b/extra/http/server/tags.txt @@ -1,2 +1,3 @@ +enterprise network web diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 4979f135ac..e414d98d65 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -116,6 +116,15 @@ HELP: run-detached "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: process-failed +{ $values { "code" "an exit status" } } +{ $description "Throws a " { $link process-failed } " error." } +{ $error-description "Thrown by " { $link try-process } " if the process exited with a non-zero status code." } ; + +HELP: try-process +{ $values { "desc" "a launch descriptor" } } +{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ; + HELP: kill-process { $values { "process" process } } { $description "Kills a running process. Does nothing if the process has already exited." } ; @@ -175,6 +184,7 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } +{ $subsection try-process } "Stopping processes:" { $subsection kill-process } "Redirecting standard input and output to a pipe:" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index f2ed59a591..3f0df4ed18 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads -continuations ; +continuations math ; IN: io.launcher ! Non-blocking process exit notification facility @@ -84,6 +84,15 @@ HOOK: run-process* io-backend ( desc -- handle ) : run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; +TUPLE: process-failed code ; + +: process-failed ( code -- * ) + \ process-failed construct-boa throw ; + +: try-process ( desc -- ) + run-process wait-for-process dup zero? + [ drop ] [ process-failed ] if ; + HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor old mode 100644 new mode 100755 index c28686d2f2..06e257a610 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -9,8 +9,6 @@ TUPLE: select-mx read-fdset write-fdset ; ! Factor's bit-arrays are an array of bytes, OS X expects ! FD_SET to be an array of cells, so we have to account for ! byte order differences on big endian platforms -: little-endian? 1 *char 1 = ; foldable - : munge ( i -- i' ) little-endian? [ BIN: 11000 bitxor ] unless ; inline diff --git a/extra/ldap/tags.txt b/extra/ldap/tags.txt index 992ae12982..80d57bb287 100644 --- a/extra/ldap/tags.txt +++ b/extra/ldap/tags.txt @@ -1 +1,2 @@ +enterprise network diff --git a/extra/logging/analysis/analysis-docs.factor b/extra/logging/analysis/analysis-docs.factor new file mode 100644 index 0000000000..2919f2bcd4 --- /dev/null +++ b/extra/logging/analysis/analysis-docs.factor @@ -0,0 +1,31 @@ +USING: help.markup help.syntax assocs logging math ; +IN: logging.analysis + +HELP: analyze-entries +{ $values { "entries" "a sequence of log entries" } { "word-names" "a sequence of strings" } { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } } +{ $description "Analyzes log entries:" + { $list + { "Errors (entries with level " { $link ERROR } " or " { $link CRITICAL } ") are collected into the " { $snippet "errors" } " sequence." } + { "All logging words are tallied into " { $snippet "word-histogram" } " - for example, this can tell you about HTTP server hit counts." } + { "All words listed in " { $snippet "word-names" } " have their messages tallied into " { $snippet "message-histogram" } " - for example, this can tell you about popular URLs on an HTTP server." } + } +} ; + +HELP: analysis. +{ $values { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } } +{ $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ; + +HELP: analyze-log +{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } } +{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; + +ARTICLE: "logging.analysis" "Log analysis" +"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logger.insomniac" } " vocabulary to e-mail daily reports." +$nl +"Print log file summary:" +{ $subsection analyze-log } +"Factors:" +{ $subsection analyze-entries } +{ $subsection analysis. } ; + +ABOUT: "logging.analysis" diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index df53a8e70b..b530c09b22 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -11,6 +11,7 @@ SYMBOL: message-histogram : analyze-entry ( entry -- ) dup second ERROR eq? [ dup errors get push ] when + dup second CRITICAL eq? [ dup errors get push ] when 1 over third word-histogram get at+ dup third word-names get member? [ 1 over 1 tail message-histogram get at+ @@ -65,5 +66,5 @@ SYMBOL: message-histogram "==== ERRORS:" print nl errors. ; -: log-analysis ( lines word-names -- ) +: analyze-log ( lines word-names -- ) >r parse-log r> analyze-entries analysis. ; diff --git a/extra/logging/analysis/tags.txt b/extra/logging/analysis/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/analysis/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor new file mode 100644 index 0000000000..64ac3b4ff6 --- /dev/null +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -0,0 +1,44 @@ +USING: help.markup help.syntax assocs strings logging +logging.analysis smtp ; +IN: logging.insomniac + +HELP: insomniac-smtp-host +{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ; + +HELP: insomniac-smtp-port +{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ; + +HELP: insomniac-sender +{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; + +HELP: insomniac-recipients +{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; + +HELP: ?analyze-log +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } } +{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." } +{ $see-also analyze-log } ; + +HELP: email-log-report +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } +{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; + +HELP: schedule-insomniac +{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } +{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ; + +ARTICLE: "logging.insomniac" "Automating log analysis and rotation" +"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." +$nl +"Required configuration parameters:" +{ $subsection insomniac-sender } +{ $subsection insomniac-recipients } +"Optional configuration parameters:" +{ $subsection insomniac-smtp-host } +{ $subsection insomniac-smtp-port } +"E-mailing a one-off report:" +{ $subsection email-log-report } +"E-mailing reports and rotating logs on a daily basis:" +{ $subsection schedule-insomniac } ; + +ABOUT: "logging.insomniac" diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index b065dec9d3..d79eca3495 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,19 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces raptor.cron ; +kernel io.files io.streams.string namespaces raptor.cron assocs ; IN: logging.insomniac -SYMBOL: insomniac-config - SYMBOL: insomniac-smtp-host SYMBOL: insomniac-smtp-port SYMBOL: insomniac-sender SYMBOL: insomniac-recipients -: ?log-analysis ( service word-names -- string/f ) +: ?analyze-log ( service word-names -- string/f ) >r log-path 1 log# dup exists? [ - file-lines r> [ log-analysis ] string-out + file-lines r> [ analyze-log ] string-out ] [ r> 2drop f ] if ; @@ -31,7 +29,7 @@ SYMBOL: insomniac-recipients : (email-log-report) ( service word-names -- ) [ over >r - ?log-analysis dup [ + ?analyze-log dup [ r> email-subject insomniac-recipients get insomniac-sender get @@ -39,11 +37,12 @@ SYMBOL: insomniac-recipients ] [ r> 2drop ] if ] with-insomniac-smtp ; +\ (email-log-report) NOTICE add-error-logging + : email-log-report ( service word-names -- ) - (email-log-report) ; + "logging.insomniac" [ (email-log-report) ] with-logging ; -\ email-log-report NOTICE add-error-logging - -: schedule-insomniac ( service word-names -- ) - { 25 } { 6 } f f f -rot - [ email-log-report ] 2curry schedule ; +: schedule-insomniac ( alist -- ) + { 25 } { 6 } f f f -rot [ + [ email-log-report ] assoc-each rotate-logs + ] 2curry schedule ; diff --git a/extra/logging/insomniac/tags.txt b/extra/logging/insomniac/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/insomniac/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor new file mode 100644 index 0000000000..3b112e0166 --- /dev/null +++ b/extra/logging/logging-docs.factor @@ -0,0 +1,130 @@ +IN: logging +USING: help.markup help.syntax assocs math calendar +logging.server strings words quotations ; + +HELP: DEBUG +{ $description "Log level for debug messages." } ; + +HELP: NOTICE +{ $description "Log level for ordinary messages." } ; + +HELP: ERROR +{ $description "Log level for error messages." } ; + +HELP: CRITICAL +{ $description "Log level for critical errors which require immediate attention." } ; + +ARTICLE: "logging.levels" "Log levels" +"Several log levels are supported, from lowest to highest:" +{ $subsection DEBUG } +{ $subsection NOTICE } +{ $subsection ERROR } +{ $subsection CRITICAL } ; + +ARTICLE: "logging.files" "Log files" +"Each application that wishes to use logging must choose a log service name; the following combinator should wrap the top level of the application:" +{ $subsection with-logging } +"Log messages are written to " { $snippet "log-root/service/1.log" } ", where" +{ $list + { { $snippet "log-root" } " is the Factor source directory by default, but can be overriden with the " { $link log-root } " variable" } + { { $snippet "service" } " is the service name" } +} +"You can get the log path for a service:" +{ $subsection log-path } +{ $subsection log# } +"New log entries are always sent to " { $snippet "1.log" } " but " { $link "logging.rotation" } " moves " { $snippet "1.log" } " to " { $snippet "2.log" } ", " { $snippet "2.log" } " to " { $snippet "3.log" } ", and so on." ; + +HELP: log-message +{ $values { "msg" string } { "word" word } { "level" "a log level" } } +{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; + +HELP: add-logging +{ $values { "word" word } } +{ $description "Causes the word to log a message every time it is called." } ; + +HELP: add-input-logging +{ $values { "word" word } } +{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ; + +HELP: add-output-logging +{ $values { "word" word } } +{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ; + +HELP: add-error-logging +{ $values { "word" word } } +{ $description "Causes the word to log its input values and any errors it throws." +$nl +"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller." +$nl +"If called from a logging context, its input values are logged, and if it throws an error, the error is logged and the word returns normally. Any inputs are popped from the stack and " { $link f } " is pushed in place of each output." } ; + +HELP: log-error +{ $values { "error" "an error" } { "word" word } } +{ $description "Logs an error." } ; + +HELP: log-critical +{ $values { "critical" "an critical" } { "word" word } } +{ $description "Logs a critical error." } ; + +HELP: LOG: +{ $syntax "LOG: name level" } +{ $values { "name" "a new word name" } { "level" "a log level" } } +{ $description "Creates a word with stack effect " { $snippet "( object -- )" } " which logs its input and does nothing else." } ; + +ARTICLE: "logging.messages" "Logging messages" +"Logging messages explicitly:" +{ $subsection log-message } +{ $subsection log-error } +{ $subsection log-critical } +"A utility for defining words which just log and do nothing else:" +{ $subsection POSTPONE: LOG: } +"Annotating words to log; this uses the " { $link "tools.annotations" } " feature:" +{ $subsection add-input-logging } +{ $subsection add-output-logging } +{ $subsection add-error-logging } ; + +HELP: rotate-logs +{ $description "Rotates all logs. The highest numbered log file in each log directory is deleted, and each file is renamed so that its number increments by one. Subsequent logging calls will create a new #1 log file. This keeps log files from getting too large and makes them easier to search." } ; + +HELP: close-logs +{ $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ; + +HELP: with-logging +{ $values { "service" "a log service name" } { "quot" quotation } } +{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ; + +ARTICLE: "logging.rotation" "Log rotation" +"Log files should be rotated periodically to prevent unbounded growth." +{ $subsection rotate-logs } +{ $subsection close-logs } +"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ; + +ARTICLE: "logging.server" "Log implementation" +"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion." +$nl +"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (log-message) } +"The " { $link rotate-logs } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (rotate-logs) } +"The " { $link close-logs } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (close-logs) } ; + +ARTICLE: "logging" "Logging framework" +"The " { $vocab-link "logging" } " vocabulary implements a comprehensive logging framework suitable for server-side production applications." +{ $subsection "logging.files" } +{ $subsection "logging.levels" } +{ $subsection "logging.messages" } +{ $subsection "logging.rotation" } +{ $subsection "logging.parser" } +{ $subsection "logging.analysis" } +{ $subsection "logging.insomniac" } +{ $subsection "logging.server" } ; + +ABOUT: "logging" + +! A workaround for circular dependency prohibition +USING: threads vocabs.loader ; +[ + yield + "logging.insomniac" require +] in-thread diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 71ea247567..d4f0bd1fbf 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -39,8 +39,8 @@ SYMBOL: log-service : rotate-logs ( -- ) { } "rotate-logs" send-to-log-server ; -: close-log-files ( -- ) - { } "close-log-files" send-to-log-server ; +: close-logs ( -- ) + { } "close-logs" send-to-log-server ; : with-logging ( service quot -- ) log-service swap with-variable ; inline @@ -56,7 +56,7 @@ SYMBOL: log-service [ dup first string? ] } && nip ; -: inputs>message ( obj -- inputs>message ) +: stack>message ( obj -- inputs>message ) dup one-string? [ first ] [ H{ { string-limit f } @@ -77,9 +77,9 @@ PRIVATE> : add-logging ( word level -- ) [ call-logging-quot ] (define-logging) ; -: log-inputs ( n word level -- ) +: log-stack ( n word level -- ) log-service get [ - >r >r [ ndup ] keep narray inputs>message + >r >r [ ndup ] keep narray stack>message r> r> log-message ] [ 3drop @@ -88,11 +88,19 @@ PRIVATE> : input# stack-effect effect-in length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-inputs ] 3curry swap compose ; + over input# -rot [ log-stack ] 3curry swap compose ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; +: output# stack-effect effect-out length ; + +: output-logging-quot ( quot word level -- quot' ) + over output# -rot [ log-stack ] 3curry compose ; + +: add-output-logging ( word level -- ) + [ output-logging-quot ] (define-logging) ; + : (log-error) ( object word level -- ) log-service get [ >r >r [ print-error ] string-out r> r> log-message @@ -100,9 +108,9 @@ PRIVATE> 2drop rethrow ] if ; -: log-error ( object word -- ) ERROR (log-error) ; +: log-error ( error word -- ) ERROR (log-error) ; -: log-critical ( object word -- ) CRITICAL (log-error) ; +: log-critical ( error word -- ) CRITICAL (log-error) ; : error-logging-quot ( quot word -- quot' ) dup stack-effect effect-in length @@ -118,5 +126,5 @@ PRIVATE> CREATE dup reset-generic dup scan-word - [ >r >r 1array inputs>message r> r> log-message ] 2curry + [ >r >r 1array stack>message r> r> log-message ] 2curry define ; parsing diff --git a/extra/logging/parser/parser-docs.factor b/extra/logging/parser/parser-docs.factor new file mode 100644 index 0000000000..ee995749be --- /dev/null +++ b/extra/logging/parser/parser-docs.factor @@ -0,0 +1,21 @@ +IN: logging.parser +USING: help.markup help.syntax assocs logging math calendar ; + +HELP: parse-log +{ $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } } +{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where" + { $list + { { $snippet "timestamp" } " is a " { $link timestamp } } + { { $snippet "level" } " is a log level; see " { $link "logger.levels" } } + { { $snippet "word-name" } " is a string" } + { { $snippet "message" } " is a string" } + } +} ; + +ARTICLE: "logging.parser" "Log file parser" +"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs." +$nl +"There is only one primary entry point:" +{ $subsection parse-log } ; + +ABOUT: "logging.parser" diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index f1cb7aa17e..f9bf97a442 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -2,13 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: parser-combinators memoize kernel sequences logging arrays words strings vectors io io.files -namespaces combinators combinators.lib logging.server ; +namespaces combinators combinators.lib logging.server +calendar ; IN: logging.parser : string-of satisfy [ >string ] <@ ; +SYMBOL: multiline + : 'date' - [ CHAR: ] eq? not ] string-of + multiline-header token [ drop multiline ] <@ + [ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|> "[" "]" surrounded-by ; : 'log-level' @@ -41,7 +45,7 @@ MEMO: 'log-line' ( -- parser ) first malformed eq? ; : multiline? ( line -- ? ) - first first CHAR: - = ; + first multiline eq? ; : malformed-line "Warning: malformed log line:" print diff --git a/extra/logging/parser/tags.txt b/extra/logging/parser/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/parser/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/server/server-docs.factor b/extra/logging/server/server-docs.factor new file mode 100644 index 0000000000..08b99dd1cc --- /dev/null +++ b/extra/logging/server/server-docs.factor @@ -0,0 +1,4 @@ +IN: logging.server +USING: help.syntax ; + +ABOUT: "logging.server" diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index cddcea8d70..198ae47a79 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -25,9 +25,11 @@ SYMBOL: log-files : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; +: multiline-header 20 CHAR: - ; foldable + : (write-message) ( msg word-name level multi? -- ) [ - "[" write 20 CHAR: - write "] " write + "[" write multiline-header write "] " write ] [ "[" write now (timestamp>rfc3339) "] " write ] if @@ -50,11 +52,11 @@ SYMBOL: log-files : try-dispose ( stream -- ) [ dispose ] curry [ error. ] recover ; -: close-log-file ( service -- ) +: close-log ( service -- ) log-files get delete-at* [ try-dispose ] [ drop ] if ; -: (close-log-files) ( -- ) +: (close-logs) ( -- ) log-files get dup values [ try-dispose ] each clear-assoc ; @@ -73,13 +75,13 @@ SYMBOL: log-files [ 1- log# ] 2keep log# ?rename-file ; : rotate-log ( service -- ) - dup close-log-file + dup close-log log-path dup delete-oldest keep-logs 1 [a,b] [ advance-log ] with each ; : (rotate-logs) ( -- ) - (close-log-files) + (close-logs) log-root directory [ drop rotate-log ] assoc-each ; : log-server-loop @@ -87,9 +89,9 @@ SYMBOL: log-files receive unclip { { "log-message" [ (log-message) ] } { "rotate-logs" [ drop (rotate-logs) ] } - { "close-log-files" [ drop (close-log-files) ] } + { "close-logs" [ drop (close-logs) ] } } case - ] [ error. (close-log-files) ] recover + ] [ error. (close-logs) ] recover log-server-loop ; : log-server ( -- ) diff --git a/extra/logging/server/tags.txt b/extra/logging/server/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/server/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/summary.txt b/extra/logging/summary.txt index dbf29c2112..42246bbd3e 100755 --- a/extra/logging/summary.txt +++ b/extra/logging/summary.txt @@ -1 +1 @@ -AOP Logging framework with support for log rotation and machine-readable logs +Logging framework with support for log rotation and machine-readable logs diff --git a/extra/logging/tags.txt b/extra/logging/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index a0769dffda..1c68cbe540 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -84,3 +84,15 @@ METHOD: hook-test { hashtable number } assoc-size ; [ fixnum ] [ 3 hook-test ] unit-test 5.0 some-var set [ 0 ] [ H{ } hook-test ] unit-test + +MIXIN: busted + +TUPLE: busted-1 ; +TUPLE: busted-2 ; INSTANCE: busted-2 busted +TUPLE: busted-3 ; + +GENERIC: busted-sort + +METHOD: busted-sort { busted-1 busted-2 } ; +METHOD: busted-sort { busted-2 busted-3 } ; +METHOD: busted-sort { busted busted } ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 827d64b95f..9a74cc65e8 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -3,12 +3,12 @@ USING: kernel math sequences vectors classes combinators arrays words assocs parser namespaces definitions prettyprint prettyprint.backend quotations arrays.lib -debugger io compiler.units ; +debugger io compiler.units kernel.private effects ; IN: multi-methods -TUPLE: method loc def ; +GENERIC: generic-prologue ( combination -- quot ) -: { set-method-def } \ method construct ; +GENERIC: method-prologue ( combination -- quot ) : maximal-element ( seq quot -- n elt ) dupd [ @@ -25,6 +25,7 @@ TUPLE: method loc def ; [ { { [ 2dup eq? ] [ 0 ] } + { [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] } { [ 2dup class< ] [ -1 ] } { [ 2dup swap class< ] [ 1 ] } { [ t ] [ 0 ] } @@ -54,8 +55,37 @@ TUPLE: method loc def ; : methods ( word -- alist ) "multi-methods" word-prop >alist ; -: method-defs ( methods -- methods' ) - [ method-def ] assoc-map ; +: make-method-def ( quot classes generic -- quot ) + [ + swap [ declare ] curry % + "multi-combination" word-prop method-prologue % + % + ] [ ] make ; + +TUPLE: method word def classes generic loc ; + +PREDICATE: word method-body "multi-method" word-prop >boolean ; + +M: method-body stack-effect + "multi-method" word-prop method-generic stack-effect ; + +: method-word-name ( classes generic -- string ) + [ + word-name % + "-(" % [ "," % ] [ word-name % ] interleave ")" % + ] "" make ; + +: ( quot classes generic -- word ) + #! We xref here because the "multi-method" word-prop isn't + #! set yet so crossref? yields f. + [ make-method-def ] 2keep + method-word-name f + dup rot define + dup xref ; + +: ( quot classes generic -- method ) + [ ] 3keep f \ method construct-boa + dup method-word over "multi-method" set-word-prop ; TUPLE: no-method arguments generic ; @@ -68,8 +98,11 @@ TUPLE: no-method arguments generic ; ] if ; : multi-dispatch-quot ( methods generic -- quot ) - >r - [ [ >r multi-predicate r> ] assoc-map ] keep argument-count + >r [ + [ + >r multi-predicate r> method-word 1quotation + ] assoc-map + ] keep argument-count r> [ no-method ] 2curry swap reverse alist>quot ; @@ -98,36 +131,36 @@ M: no-method error. methods congruify-methods sorted-methods keys [ niceify-method ] map stack. ; -GENERIC: perform-combination ( word combination -- quot ) - TUPLE: standard-combination ; -: standard-combination ( methods generic -- quot ) - >r congruify-methods sorted-methods r> multi-dispatch-quot ; +M: standard-combination method-prologue drop [ ] ; -M: standard-combination perform-combination - drop [ methods method-defs ] keep standard-combination ; +M: standard-combination generic-prologue drop [ ] ; + +: make-generic ( generic -- quot ) + dup "multi-combination" word-prop generic-prologue swap + [ methods congruify-methods sorted-methods ] keep + multi-dispatch-quot append ; TUPLE: hook-combination var ; -M: hook-combination perform-combination - hook-combination-var [ get ] curry swap methods - [ method-defs [ [ drop ] swap append ] assoc-map ] keep - standard-combination append ; +M: hook-combination method-prologue + drop [ drop ] ; -: make-generic ( word -- ) - dup dup "multi-combination" word-prop perform-combination - define ; +M: hook-combination generic-prologue + hook-combination-var [ get ] curry ; -: init-methods ( word -- ) - dup "multi-methods" word-prop - H{ } assoc-like - "multi-methods" set-word-prop ; +: update-generic ( word -- ) + dup make-generic define ; : define-generic ( word combination -- ) - dupd "multi-combination" set-word-prop - dup init-methods - make-generic ; + over "multi-combination" word-prop over = [ + 2drop + ] [ + dupd "multi-combination" set-word-prop + dup H{ } clone "multi-methods" set-word-prop + update-generic + ] if ; : define-standard-generic ( word -- ) T{ standard-combination } define-generic ; @@ -146,29 +179,31 @@ M: hook-combination perform-combination : with-methods ( word quot -- ) over >r >r "multi-methods" word-prop - r> call r> make-generic ; inline + r> call r> update-generic ; inline -: add-method ( method classes word -- ) +: define-method ( quot classes generic -- ) + >r [ bootstrap-word ] map r> + [ ] 2keep [ set-at ] with-methods ; -: forget-method ( classes word -- ) +: forget-method ( classes generic -- ) [ delete-at ] with-methods ; -: parse-method ( -- method classes word method-spec ) - parse-definition 2 cut - over >r - >r first2 swap r> -rot - r> first2 swap add* >array ; +: method>spec ( method -- spec ) + dup method-classes swap method-generic add* ; + +: parse-method ( -- quot classes generic ) + parse-definition dup 2 tail over second rot first ; : METHOD: location - >r parse-method >r add-method r> r> + >r parse-method [ define-method ] 2keep add* r> remember-definition ; parsing ! For compatibility : M: - scan-word 1array scan-word parse-definition - -rot add-method ; parsing + scan-word 1array scan-word parse-definition + -rot define-method ; parsing ! Definition protocol. We qualify core generics here USE: qualified @@ -202,7 +237,7 @@ PREDICATE: array method-spec unclip generic? >r [ class? ] all? r> and ; syntax:M: method-spec where - dup unclip method method-loc [ ] [ second where ] ?if ; + dup unclip method [ method-loc ] [ second where ] ?if ; syntax:M: method-spec set-where unclip method set-method-loc ; @@ -211,11 +246,11 @@ syntax:M: method-spec definer drop \ METHOD: \ ; ; syntax:M: method-spec definition - unclip method method-def ; + unclip method dup [ method-def ] when ; syntax:M: method-spec synopsis* dup definer. unclip pprint* pprint* ; syntax:M: method-spec forget* - unclip [ delete-at ] with-methods ; + unclip forget-method ; diff --git a/extra/openssl/tags.txt b/extra/openssl/tags.txt index 59ccdd65e6..93e252c19e 100644 --- a/extra/openssl/tags.txt +++ b/extra/openssl/tags.txt @@ -1,2 +1,3 @@ +enterprise network bindings diff --git a/extra/smtp/tags.txt b/extra/smtp/tags.txt index 992ae12982..80d57bb287 100644 --- a/extra/smtp/tags.txt +++ b/extra/smtp/tags.txt @@ -1 +1,2 @@ +enterprise network diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index c295f6369d..2439ef8636 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -22,7 +22,10 @@ IN: tools.deploy.backend +stdout+ +stderr+ set ] H{ } make-assoc dup duplex-stream-out dispose - copy-lines ; + dup copy-lines + process-stream-process wait-for-process zero? [ + "Deployment failed" throw + ] unless ; : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 1bbf198ea0..eb1a4af4a7 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -8,10 +8,10 @@ QUALIFIED: unix IN: tools.deploy.macosx : touch ( path -- ) - { "touch" } swap add run-process drop ; + { "touch" } swap add try-process ; : rm ( path -- ) - { "rm" "-rf" } swap add run-process drop ; + { "rm" "-rf" } swap add try-process ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 192a248161..0b5e436e44 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -61,9 +61,14 @@ M: expected-error summary dup vocab-source-loaded? [ vocab-tests-path dup [ dup ?resource-path exists? [ - [ "temporary" forget-vocab ] with-compilation-unit + [ + "temporary" forget-vocab + ] with-compilation-unit dup run-file - [ dup forget-source ] with-compilation-unit + [ + dup forget-source + "temporary" forget-vocab + ] with-compilation-unit ] when ] when ] when drop ; @@ -81,7 +86,7 @@ M: expected-error summary "Traceback" swap third write-object ; : test-failures. ( assoc -- ) - dup [ + [ nl dup empty? [ drop @@ -90,15 +95,15 @@ M: expected-error summary "==== FAILING TESTS:" print [ swap vocab-heading. - [ nl failure. nl ] each + [ failure. nl ] each ] assoc-each ] if ] [ - drop "==== NOTHING TO TEST" print - ] if ; + "==== NOTHING TO TEST" print + ] if* ; : run-tests ( prefix -- failures ) - child-vocabs dup empty? [ f ] [ + child-vocabs dup empty? [ drop f ] [ [ dup run-test ] { } map>assoc [ second empty? not ] subset ] if ; diff --git a/extra/xml-rpc/tags.txt b/extra/xml-rpc/tags.txt index c0772185a0..7698983a7f 100644 --- a/extra/xml-rpc/tags.txt +++ b/extra/xml-rpc/tags.txt @@ -1 +1,2 @@ +enterprise web diff --git a/extra/xml/tags.txt b/extra/xml/tags.txt index c0772185a0..7698983a7f 100644 --- a/extra/xml/tags.txt +++ b/extra/xml/tags.txt @@ -1 +1,2 @@ +enterprise web diff --git a/misc/factor.el b/misc/factor.el index a5ba44357f..19b7f28e22 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -131,10 +131,30 @@ (comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name))) (comint-send-string "*factor*" " run-file\n")) +;; (defun factor-send-region (start end) +;; (interactive "r") +;; (comint-send-region "*factor*" start end) +;; (comint-send-string "*factor*" "\n")) + +(defun factor-send-string (str) + (let ((n (length (split-string str "\n")))) + (save-excursion + (set-buffer "*factor*") + (goto-char (point-max)) + (if (> n 1) (newline)) + (insert str) + (comint-send-input)))) + (defun factor-send-region (start end) (interactive "r") - (comint-send-region "*factor*" start end) - (comint-send-string "*factor*" "\n")) + (let ((str (buffer-substring start end)) + (n (count-lines start end))) + (save-excursion + (set-buffer "*factor*") + (goto-char (point-max)) + (if (> n 1) (newline)) + (insert str) + (comint-send-input)))) (defun factor-see () (interactive) @@ -153,6 +173,10 @@ (comint-send-string "*factor*" "\\ ") (comint-send-string "*factor*" (thing-at-point 'sexp)) (comint-send-string "*factor*" " edit\n")) + +(defun factor-clear () + (interactive) + (factor-send-string "clear")) (defun factor-comment-line () (interactive) diff --git a/misc/integration/deploy-size-test.factor b/misc/integration/deploy-size-test.factor deleted file mode 100644 index 91cdaba293..0000000000 --- a/misc/integration/deploy-size-test.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: tools.deploy sequences io.files io.launcher io -kernel concurrency prettyprint ; - -"." resource-path cd - -"deploy-log" make-directory - -{ - "automata.ui" - "boids.ui" - "bunny" - "color-picker" - "gesture-logger" - "golden-section" - "hello-world" - "hello-ui" - "lsys.ui" - "maze" - "nehe" - "tetris" - "catalyst-talk" -} [ - dup - "deploy-log/" over append - [ deploy ] with-stream - dup file-length 1024 /f - 2array -] parallel-map . diff --git a/misc/integration/macosx-deploy.factor b/misc/integration/macosx-deploy.factor deleted file mode 100644 index f1e6e7fe06..0000000000 --- a/misc/integration/macosx-deploy.factor +++ /dev/null @@ -1,24 +0,0 @@ -USING: tools.deploy.app sequences io.files io.launcher io -kernel concurrency ; - -"." resource-path cd - -"deploy-log" make-directory - -{ - "automata.ui" - "boids.ui" - "bunny" - "color-picker" - "gesture-logger" - "golden-section" - "hello-ui" - "lsys.ui" - "maze" - "nehe" - "tetris" - "catalyst-talk" -} [ - "deploy-log/" over append - [ deploy.app ] with-stream -] parallel-each diff --git a/misc/integration/macosx.sh b/misc/integration/macosx.sh deleted file mode 100644 index dafe9524c6..0000000000 --- a/misc/integration/macosx.sh +++ /dev/null @@ -1,43 +0,0 @@ -CPU=$1 - -if [ "$CPU" = "x86.32" ]; then - TARGET="macosx-x86" -elif [ "$CPU" = "ppc" ]; then - TARGET="macosx-ppc" - CPU = "macosx-ppc" -else - echo "Specify a CPU" - exit 1 -fi - -EXE=factor - -bash misc/integration/test.sh \ - $EXE \ - $CPU \ - $TARGET \ - no \ - no \ - no \ - "X11=1" \ - "-ui-backend=x11" \ - "-x11" || exit 1 - -echo "Testing deployment" -$EXE "misc/integration/x11-deploy.factor" -run=none $VM_LOG $BOOT_LOG /tmp/factor-$$ - - $EXE -i=$IMAGE \ - /tmp/factor-$$ \ - -run=none \ - >$LOAD_LOG $TEST_LOG $BENCHMARK_LOG [ deploy ] with-stream diff --git a/vm/debug.c b/vm/debug.c index 5b4320b5e9..01e1ab0f43 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -38,6 +38,9 @@ void print_array(F_ARRAY* array, CELL nesting) CELL length = array_capacity(array); CELL i; + if(length > 10) + length = 10; + for(i = 0; i < length; i++) { printf(" "); @@ -201,7 +204,7 @@ void dump_objects(F_FIXNUM type) if(type == -1 || type_of(obj) == type) { printf("%lx ",obj); - print_nested_obj(obj,3); + print_nested_obj(obj,1); printf("\n"); } } @@ -210,6 +213,36 @@ void dump_objects(F_FIXNUM type) gc_off = false; } +CELL obj; +CELL look_for; + +void find_references_step(CELL *scan) +{ + if(look_for == *scan) + { + printf("%lx ",obj); + print_nested_obj(obj,1); + printf("\n"); + } +} + +void find_references(CELL look_for_) +{ + look_for = look_for_; + + begin_scan(); + + CELL obj_; + while((obj_ = next_object()) != F) + { + obj = obj_; + do_slots(obj_,find_references_step); + } + + /* end scan */ + gc_off = false; +} + void factorbug(void) { reset_stdio();