Merge branch 'master' of git://factorcode.org/git/factor

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:

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: <int>
+DEFER: *char
+
+: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
+
 TUPLE: c-type
 boxer prep unboxer
 getter setter

core/alien/compiler/compiler-tests.factor

@@ -1,356 +1,356 @@
-IN: temporary
+IN: temporary
-USING: alien alien.c-types alien.syntax compiler kernel
+USING: alien alien.c-types alien.syntax compiler kernel
-namespaces namespaces tools.test sequences inference words
+namespaces namespaces tools.test sequences inference words
-arrays parser quotations continuations inference.backend effects
+arrays parser quotations continuations inference.backend effects
-namespaces.private io io.streams.string memory system threads
+namespaces.private io io.streams.string memory system threads
-tools.test ;
+tools.test ;
-
+
-FUNCTION: void ffi_test_0 ;
+FUNCTION: void ffi_test_0 ;
-[ ] [ ffi_test_0 ] unit-test
+[ ] [ ffi_test_0 ] unit-test
-
+
-FUNCTION: int ffi_test_1 ;
+FUNCTION: int ffi_test_1 ;
-[ 3 ] [ ffi_test_1 ] unit-test
+[ 3 ] [ ffi_test_1 ] unit-test
-
+
-FUNCTION: int ffi_test_2 int x int y ;
+FUNCTION: int ffi_test_2 int x int y ;
-[ 5 ] [ 2 3 ffi_test_2 ] unit-test
+[ 5 ] [ 2 3 ffi_test_2 ] unit-test
-[ "hi" 3 ffi_test_2 ] must-fail
+[ "hi" 3 ffi_test_2 ] must-fail
-
+
-FUNCTION: int ffi_test_3 int x int y int z int t ;
+FUNCTION: int ffi_test_3 int x int y int z int t ;
-[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
+[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
-
+
-FUNCTION: float ffi_test_4 ;
+FUNCTION: float ffi_test_4 ;
-[ 1.5 ] [ ffi_test_4 ] unit-test
+[ 1.5 ] [ ffi_test_4 ] unit-test
-
+
-FUNCTION: double ffi_test_5 ;
+FUNCTION: double ffi_test_5 ;
-[ 1.5 ] [ ffi_test_5 ] unit-test
+[ 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 ;
+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
+[ 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
+[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
-[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
+[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
-
+
-C-STRUCT: foo
+C-STRUCT: foo
-    { "int" "x" }
+    { "int" "x" }
-    { "int" "y" }
+    { "int" "y" }
-;
+;
-
+
-: make-foo ( x y -- foo )
+: make-foo ( x y -- foo )
-    "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+    "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
-
+
-FUNCTION: int ffi_test_11 int a foo b int c ;
+FUNCTION: int ffi_test_11 int a foo b int c ;
-
+
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+[ 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 ;
+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
+[ 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 ;
+FUNCTION: foo ffi_test_14 int x int y ;
-
+
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
-
+
-FUNCTION: char* ffi_test_15 char* x char* y ;
+FUNCTION: char* ffi_test_15 char* x char* y ;
-
+
-[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
+[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
-[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
+[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
-[ 1 2 ffi_test_15 ] must-fail
+[ 1 2 ffi_test_15 ] must-fail
-
+
-C-STRUCT: bar
+C-STRUCT: bar
-    { "long" "x" }
+    { "long" "x" }
-    { "long" "y" }
+    { "long" "y" }
-    { "long" "z" }
+    { "long" "z" }
-;
+;
-
+
-FUNCTION: bar ffi_test_16 long x long y long z ;
+FUNCTION: bar ffi_test_16 long x long y long z ;
-
+
-[ 11 6 -7 ] [
+[ 11 6 -7 ] [
-    11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+    11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
-] unit-test
+] unit-test
-
+
-C-STRUCT: tiny
+C-STRUCT: tiny
-    { "int" "x" }
+    { "int" "x" }
-;
+;
-
+
-FUNCTION: tiny ffi_test_17 int x ;
+FUNCTION: tiny ffi_test_17 int x ;
-
+
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
-
+
-[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
+[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
-
+
-: indirect-test-1
+: indirect-test-1
-    "int" { } "cdecl" alien-indirect ;
+    "int" { } "cdecl" alien-indirect ;
-
+
-{ 1 1 } [ indirect-test-1 ] must-infer-as
+{ 1 1 } [ indirect-test-1 ] must-infer-as
-
+
-[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
-
+
-[ -1 indirect-test-1 ] must-fail
+[ -1 indirect-test-1 ] must-fail
-
+
-: indirect-test-2
+: indirect-test-2
-    "int" { "int" "int" } "cdecl" alien-indirect data-gc ;
+    "int" { "int" "int" } "cdecl" alien-indirect data-gc ;
-
+
-{ 3 1 } [ indirect-test-2 ] must-infer-as
+{ 3 1 } [ indirect-test-2 ] must-infer-as
-
+
-[ 5 ]
+[ 5 ]
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
-unit-test
+unit-test
-
+
-: indirect-test-3
+: indirect-test-3
-    "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+    "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
-    data-gc ;
+    data-gc ;
-
+
-<< "f-stdcall" f "stdcall" add-library >>
+<< "f-stdcall" f "stdcall" add-library >>
-
+
-[ f ] [ "f-stdcall" load-library ] unit-test
+[ f ] [ "f-stdcall" load-library ] unit-test
-[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
+[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
-
+
-: ffi_test_18 ( w x y z -- int )
+: ffi_test_18 ( w x y z -- int )
-    "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+    "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
-    alien-invoke data-gc ;
+    alien-invoke data-gc ;
-
+
-[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
+[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
-
+
-: ffi_test_19 ( x y z -- bar )
+: ffi_test_19 ( x y z -- bar )
-    "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+    "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
-    alien-invoke data-gc ;
+    alien-invoke data-gc ;
-
+
-[ 11 6 -7 ] [
+[ 11 6 -7 ] [
-    11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+    11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
-] unit-test
+] unit-test
-
+
-FUNCTION: double ffi_test_6 float x float y ;
+FUNCTION: double ffi_test_6 float x float y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
+[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
-[ "a" "b" ffi_test_6 ] must-fail
+[ "a" "b" ffi_test_6 ] must-fail
-
+
-FUNCTION: double ffi_test_7 double x double y ;
+FUNCTION: double ffi_test_7 double x double y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
+[ 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 ;
+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
+[ 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 ;
+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
+[ -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,
+FUNCTION: void ffi_test_20 double x1, double x2, double x3,
-    double y1, double y2, double y3,
+    double y1, double y2, double y3,
-    double z1, double z2, double z3 ;
+    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
+[ ] [ 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
+! Make sure XT doesn't get clobbered in stack frame
-
+
-: ffi_test_31
+: ffi_test_31
-    "void"
+    "void"
-    f "ffi_test_31"
+    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" }
+    { "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 ;
+    alien-invoke code-gc 3 ;
-
+
-[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
-
+
-FUNCTION: longlong ffi_test_21 long x long y ;
+FUNCTION: longlong ffi_test_21 long x long y ;
-
+
-[ 121932631112635269 ]
+[ 121932631112635269 ]
-[ 123456789 987654321 ffi_test_21 ] unit-test
+[ 123456789 987654321 ffi_test_21 ] unit-test
-
+
-FUNCTION: long ffi_test_22 long x longlong y longlong z ;
+FUNCTION: long ffi_test_22 long x longlong y longlong z ;
-
+
-[ 987655432 ]
+[ 987655432 ]
-[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
+[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
-
+
-[ 1111 f 123456789 ffi_test_22 ] must-fail
+[ 1111 f 123456789 ffi_test_22 ] must-fail
-
+
-C-STRUCT: rect
+C-STRUCT: rect
-    { "float" "x" }
+    { "float" "x" }
-    { "float" "y" }
+    { "float" "y" }
-    { "float" "w" }
+    { "float" "w" }
-    { "float" "h" }
+    { "float" "h" }
-;
+;
-
+
-: <rect>
+: <rect>
-    "rect" <c-object>
+    "rect" <c-object>
-    [ set-rect-h ] keep
+    [ set-rect-h ] keep
-    [ set-rect-w ] keep
+    [ set-rect-w ] keep
-    [ set-rect-y ] keep
+    [ set-rect-y ] keep
-    [ set-rect-x ] keep ;
+    [ set-rect-x ] keep ;
-
+
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+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 <rect> 7 8 9 ffi_test_12 ] unit-test
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
-
+
-[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
+[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
-
+
-FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
+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
+[ 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
+! Test odd-size structs
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
-
+
-FUNCTION: test-struct-1 ffi_test_24 ;
+FUNCTION: test-struct-1 ffi_test_24 ;
-
+
-[ B{ 1 } ] [ ffi_test_24 ] unit-test
+[ B{ 1 } ] [ ffi_test_24 ] unit-test
-
+
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
-
+
-FUNCTION: test-struct-2 ffi_test_25 ;
+FUNCTION: test-struct-2 ffi_test_25 ;
-
+
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
-
+
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
-
+
-FUNCTION: test-struct-3 ffi_test_26 ;
+FUNCTION: test-struct-3 ffi_test_26 ;
-
+
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
-
+
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
-
+
-FUNCTION: test-struct-4 ffi_test_27 ;
+FUNCTION: test-struct-4 ffi_test_27 ;
-
+
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
-
+
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
-
+
-FUNCTION: test-struct-5 ffi_test_28 ;
+FUNCTION: test-struct-5 ffi_test_28 ;
-
+
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
-
+
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
-
+
-FUNCTION: test-struct-6 ffi_test_29 ;
+FUNCTION: test-struct-6 ffi_test_29 ;
-
+
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
-
+
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
-
+
-FUNCTION: test-struct-7 ffi_test_30 ;
+FUNCTION: test-struct-7 ffi_test_30 ;
-
+
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
-
+
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
-
+
-FUNCTION: double ffi_test_32 test-struct-8 x int y ;
+FUNCTION: double ffi_test_32 test-struct-8 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-8" <c-object>
+    "test-struct-8" <c-object>
-    1.0 over set-test-struct-8-x
+    1.0 over set-test-struct-8-x
-    2.0 over set-test-struct-8-y
+    2.0 over set-test-struct-8-y
-    3 ffi_test_32
+    3 ffi_test_32
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
-
+
-FUNCTION: double ffi_test_33 test-struct-9 x int y ;
+FUNCTION: double ffi_test_33 test-struct-9 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-9" <c-object>
+    "test-struct-9" <c-object>
-    1.0 over set-test-struct-9-x
+    1.0 over set-test-struct-9-x
-    2.0 over set-test-struct-9-y
+    2.0 over set-test-struct-9-y
-    3 ffi_test_33
+    3 ffi_test_33
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
-
+
-FUNCTION: double ffi_test_34 test-struct-10 x int y ;
+FUNCTION: double ffi_test_34 test-struct-10 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-10" <c-object>
+    "test-struct-10" <c-object>
-    1.0 over set-test-struct-10-x
+    1.0 over set-test-struct-10-x
-    2 over set-test-struct-10-y
+    2 over set-test-struct-10-y
-    3 ffi_test_34
+    3 ffi_test_34
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
-
+
-FUNCTION: double ffi_test_35 test-struct-11 x int y ;
+FUNCTION: double ffi_test_35 test-struct-11 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-11" <c-object>
+    "test-struct-11" <c-object>
-    1 over set-test-struct-11-x
+    1 over set-test-struct-11-x
-    2 over set-test-struct-11-y
+    2 over set-test-struct-11-y
-    3 ffi_test_35
+    3 ffi_test_35
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
-
+
-: make-struct-12
+: make-struct-12
-    "test-struct-12" <c-object>
+    "test-struct-12" <c-object>
-    [ set-test-struct-12-x ] keep ;
+    [ set-test-struct-12-x ] keep ;
-
+
-FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
-
+
-[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
-
+
-! Test callbacks
+! Test callbacks
-
+
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+: callback-1 "void" { } "cdecl" [ ] alien-callback ;
-
+
-[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
-
+
-[ t ] [ callback-1 alien? ] unit-test
+[ t ] [ callback-1 alien? ] unit-test
-
+
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
+: callback_test_1 "void" { } "cdecl" alien-indirect ;
-
+
-[ ] [ callback-1 callback_test_1 ] unit-test
+[ ] [ callback-1 callback_test_1 ] unit-test
-
+
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
-
+
-[ ] [ callback-2 callback_test_1 ] unit-test
+[ ] [ callback-2 callback_test_1 ] unit-test
-
+
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
-
+
-[ t ] [ 
+[ t ] [ 
-    namestack*
+    namestack*
-    3 "x" set callback-3 callback_test_1
+    3 "x" set callback-3 callback_test_1
-    namestack* eq?
+    namestack* eq?
-] unit-test
+] unit-test
-
+
-[ 5 ] [ 
+[ 5 ] [ 
-    [
+    [
-        3 "x" set callback-3 callback_test_1 "x" get
+        3 "x" set callback-3 callback_test_1 "x" get
-    ] with-scope
+    ] with-scope
-] unit-test
+] unit-test
-
+
-: callback-4
+: callback-4
-    "void" { } "cdecl" [ "Hello world" write ] alien-callback
+    "void" { } "cdecl" [ "Hello world" write ] alien-callback
-    data-gc ;
+    data-gc ;
-
+
-[ "Hello world" ] [ 
+[ "Hello world" ] [ 
-    [ callback-4 callback_test_1 ] string-out
+    [ callback-4 callback_test_1 ] string-out
-] unit-test
+] unit-test
-
+
-: callback-5
+: callback-5
-    "void" { } "cdecl" [ data-gc ] alien-callback ;
+    "void" { } "cdecl" [ data-gc ] alien-callback ;
-
+
-[ "testing" ] [
+[ "testing" ] [
-    "testing" callback-5 callback_test_1
+    "testing" callback-5 callback_test_1
-] unit-test
+] unit-test
-
+
-: callback-5a
+: callback-5a
-    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
+    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
-
+
-! Hack; if we're on ARM, we probably don't have much RAM, so
+! Hack; if we're on ARM, we probably don't have much RAM, so
-! skip this test.
+! skip this test.
-cpu "arm" = [
+cpu "arm" = [
-    [ "testing" ] [
+    [ "testing" ] [
-        "testing" callback-5a callback_test_1
+        "testing" callback-5a callback_test_1
-    ] unit-test
+    ] unit-test
-] unless
+] unless
-
+
-: callback-6
+: callback-6
-    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
-
+
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
-
+
-: callback-7
+: callback-7
-    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
-
+
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
-
+
-[ f ] [ namespace global eq? ] unit-test
+[ f ] [ namespace global eq? ] unit-test
-
+
-: callback-8
+: callback-8
-    "void" { } "cdecl" [
+    "void" { } "cdecl" [
-        [ continue ] callcc0
+        [ continue ] callcc0
-    ] alien-callback ;
+    ] alien-callback ;
-
+
-[ ] [ callback-8 callback_test_1 ] unit-test
+[ ] [ callback-8 callback_test_1 ] unit-test

core/compiler/compiler-tests.factor

@@ -1,21 +1,7 @@
-USING: io.files tools.test sequences namespaces kernel
+IN: temporary
-compiler.units ;
+USING: tools.browser tools.test kernel sequences vocabs ;
-
+
-{
+"compiler.test" child-vocabs empty? [
-    "templates-early"
+    "compiler.test" load-children
-    "simple"
+    "compiler.test" test
-    "intrinsics"
+] when
-    "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

core/compiler/test/generic.factor

@@ -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

core/compiler/test/ifte.factor

@@ -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

core/compiler/test/simple.factor

@@ -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

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

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

core/inference/known-words/known-words.factor

@@ -414,64 +414,81 @@ t over set-effect-terminated?
 \ <displaced-alien> make-flushable
 
 \ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-cell make-flushable
 
 \ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-cell make-flushable
 
 \ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-8 make-flushable
 
 \ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-8 make-flushable
 
 \ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-4 make-flushable
 
 \ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-4 make-flushable
 
 \ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-signed-2 make-flushable
 
 \ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-2 make-flushable
 
 \ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-signed-1 make-flushable
 
 \ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-1 make-flushable
 
 \ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
+\ alien-float make-flushable
 
 \ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
+\ alien-double make-flushable
 
 \ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
+\ alien-cell make-flushable
 
 \ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
 
 \ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
+\ alien>char-string make-flushable
 
 \ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
+\ string>char-alien make-flushable
 
 \ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
+\ alien>u16-string make-flushable
 
 \ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
+\ string>u16-alien make-flushable
 
 \ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
 \ alien-address make-flushable

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 )

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

core/optimizer/optimizer-tests.factor

@@ -1,302 +1,303 @@
-USING: arrays compiler generic hashtables inference kernel
+USING: arrays compiler generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
+kernel.private math optimizer prettyprint sequences sbufs
-strings tools.test vectors words sequences.private quotations
+strings tools.test vectors words sequences.private quotations
-optimizer.backend classes inference.dataflow tuples.private
+optimizer.backend classes inference.dataflow tuples.private
-continuations growable ;
+continuations growable ;
-IN: temporary
+IN: temporary
-
+
-[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
+[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
-    H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
+    H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
-] unit-test
+] unit-test
-
+
-[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
+[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
-    H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
+    H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
-] unit-test
+] unit-test
-
+
-! Test method inlining
+! Test method inlining
-[ f ] [ fixnum { } min-class ] unit-test
+[ f ] [ fixnum { } min-class ] unit-test
-
+
-[ string ] [
+[ string ] [
-    \ string
+    \ string
-    [ integer string array reversed sbuf
+    [ integer string array reversed sbuf
-    slice vector quotation ]
+    slice vector quotation ]
-    sort-classes min-class
+    sort-classes min-class
-] unit-test
+] unit-test
-
+
-[ fixnum ] [
+[ fixnum ] [
-    \ fixnum
+    \ fixnum
-    [ fixnum integer object ]
+    [ fixnum integer object ]
-    sort-classes min-class
+    sort-classes min-class
-] unit-test
+] unit-test
-
+
-[ integer ] [
+[ integer ] [
-    \ fixnum
+    \ fixnum
-    [ integer float object ]
+    [ integer float object ]
-    sort-classes min-class
+    sort-classes min-class
-] unit-test
+] unit-test
-
+
-[ object ] [
+[ object ] [
-    \ word
+    \ word
-    [ integer float object ]
+    [ integer float object ]
-    sort-classes min-class
+    sort-classes min-class
-] unit-test
+] unit-test
-
+
-[ reversed ] [
+[ reversed ] [
-    \ reversed
+    \ reversed
-    [ integer reversed slice ]
+    [ integer reversed slice ]
-    sort-classes min-class
+    sort-classes min-class
-] unit-test
+] unit-test
-
+
-GENERIC: xyz ( obj -- obj )
+GENERIC: xyz ( obj -- obj )
-M: array xyz xyz ;
+M: array xyz xyz ;
-
+
-[ t ] [ \ xyz compiled? ] unit-test
+[ t ] [ \ xyz compiled? ] unit-test
-
+
-! Test predicate inlining
+! Test predicate inlining
-: pred-test-1
+: pred-test-1
-    dup fixnum? [
+    dup fixnum? [
-        dup integer? [ "integer" ] [ "nope" ] if
+        dup integer? [ "integer" ] [ "nope" ] if
-    ] [
+    ] [
-        "not a fixnum"
+        "not a fixnum"
-    ] if ;
+    ] if ;
-
+
-[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
+[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
-
+
-TUPLE: pred-test ;
+TUPLE: pred-test ;
-
+
-: pred-test-2
+: pred-test-2
-    dup tuple? [
+    dup tuple? [
-        dup pred-test? [ "pred-test" ] [ "nope" ] if
+        dup pred-test? [ "pred-test" ] [ "nope" ] if
-    ] [
+    ] [
-        "not a tuple"
+        "not a tuple"
-    ] if ;
+    ] if ;
-
+
-[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
-
+
-: pred-test-3
+: pred-test-3
-    dup pred-test? [
+    dup pred-test? [
-        dup tuple? [ "pred-test" ] [ "nope" ] if
+        dup tuple? [ "pred-test" ] [ "nope" ] if
-    ] [
+    ] [
-        "not a tuple"
+        "not a tuple"
-    ] if ;
+    ] if ;
-
+
-[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
-
+
-: inline-test
+: inline-test
-    "nom" = ;
+    "nom" = ;
-
+
-[ t ] [ "nom" inline-test ] unit-test
+[ t ] [ "nom" inline-test ] unit-test
-[ f ] [ "shayin" inline-test ] unit-test
+[ f ] [ "shayin" inline-test ] unit-test
-[ f ] [ 3 inline-test ] unit-test
+[ f ] [ 3 inline-test ] unit-test
-
+
-: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
+: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
-
+
-[ ] [ 1000000 fixnum-declarations . ] unit-test
+[ ] [ 1000000 fixnum-declarations . ] unit-test
-
+
-! regression
+! regression
-
+
-: literal-not-branch 0 not [ ] [ ] if ;
+: literal-not-branch 0 not [ ] [ ] if ;
-
+
-[ ] [ literal-not-branch ] unit-test
+[ ] [ literal-not-branch ] unit-test
-
+
-! regression
+! regression
-
+
-: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
+: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
-: bad-kill-2 bad-kill-1 drop ;
+: bad-kill-2 bad-kill-1 drop ;
-
+
-[ 3 ] [ t bad-kill-2 ] unit-test
+[ 3 ] [ t bad-kill-2 ] unit-test
-
+
-! regression
+! regression
-: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
+: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
-: the-test ( -- x y ) 2 dup (the-test) ;
+: the-test ( -- x y ) 2 dup (the-test) ;
-
+
-[ 2 0 ] [ the-test ] unit-test
+[ 2 0 ] [ the-test ] unit-test
-
+
-! regression
+! regression
-: (double-recursion) ( start end -- )
+: (double-recursion) ( start end -- )
-    < [
+    < [
-        6 1 (double-recursion)
+        6 1 (double-recursion)
-        3 2 (double-recursion)
+        3 2 (double-recursion)
-    ] when ; inline
+    ] when ; inline
-
+
-: double-recursion 0 2 (double-recursion) ;
+: double-recursion 0 2 (double-recursion) ;
-
+
-[ ] [ double-recursion ] unit-test
+[ ] [ double-recursion ] unit-test
-
+
-! regression
+! regression
-: double-label-1 ( a b c -- d )
+: double-label-1 ( a b c -- d )
-    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
+    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
-
+
-: double-label-2 ( a -- b )
+: double-label-2 ( a -- b )
-    dup array? [ ] [ ] if 0 t double-label-1 ;
+    dup array? [ ] [ ] if 0 t double-label-1 ;
-
+
-[ 0 ] [ 10 double-label-2 ] unit-test
+[ 0 ] [ 10 double-label-2 ] unit-test
-
+
-! regression
+! regression
-GENERIC: void-generic ( obj -- * )
+GENERIC: void-generic ( obj -- * )
-: breakage "hi" void-generic ;
+: breakage "hi" void-generic ;
-[ t ] [ \ breakage compiled? ] unit-test
+[ t ] [ \ breakage compiled? ] unit-test
-[ breakage ] must-fail
+[ breakage ] must-fail
-
+
-! regression
+! regression
-: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
+: 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-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
-: test-2 ( -- ) 5 test-1 ;
+: test-2 ( -- ) 5 test-1 ;
-
+
-[ f ] [ f test-2 ] unit-test
+[ f ] [ f test-2 ] unit-test
-
+
-: branch-fold-regression-0 ( m -- n )
+: branch-fold-regression-0 ( m -- n )
-    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
+    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
-
+
-: branch-fold-regression-1 ( -- m )
+: branch-fold-regression-1 ( -- m )
-    10 branch-fold-regression-0 ;
+    10 branch-fold-regression-0 ;
-
+
-[ 10 ] [ branch-fold-regression-1 ] unit-test
+[ 10 ] [ branch-fold-regression-1 ] unit-test
-
+
-! another regression
+! another regression
-: constant-branch-fold-0 "hey" ; foldable
+: constant-branch-fold-0 "hey" ; foldable
-: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
+: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
-[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
-
+
-! another regression
+! another regression
-: foo f ;
+: foo f ;
-: bar foo 4 4 = and ;
+: bar foo 4 4 = and ;
-[ f ] [ bar ] unit-test
+[ f ] [ bar ] unit-test
-
+
-! ensure identities are working in some form
+! ensure identities are working in some form
-[ t ] [
+[ t ] [
-    [ { number } declare 0 + ] dataflow optimize
+    [ { number } declare 0 + ] dataflow optimize
-    [ #push? ] node-exists? not
+    [ #push? ] node-exists? not
-] unit-test
+] unit-test
-
+
-! compiling <tuple> with a non-literal class failed
+! compiling <tuple> with a non-literal class failed
-: <tuple>-regression <tuple> ;
+: <tuple>-regression <tuple> ;
-
+
-[ t ] [ \ <tuple>-regression compiled? ] unit-test
+[ t ] [ \ <tuple>-regression compiled? ] unit-test
-
+
-GENERIC: foozul ( a -- b )
+GENERIC: foozul ( a -- b )
-M: reversed foozul ;
+M: reversed foozul ;
-M: integer foozul ;
+M: integer foozul ;
-M: slice foozul ;
+M: slice foozul ;
-
+
-[ reversed ] [ reversed \ foozul specific-method ] unit-test
+[ reversed ] [ reversed \ foozul specific-method ] unit-test
-
+
-! regression
+! regression
-: constant-fold-2 f ; foldable
+: constant-fold-2 f ; foldable
-: constant-fold-3 4 ; foldable
+: constant-fold-3 4 ; foldable
-
+
-[ f t ] [
+[ f t ] [
-    [ constant-fold-2 constant-fold-3 4 = ] compile-call
+    [ constant-fold-2 constant-fold-3 4 = ] compile-call
-] unit-test
+] unit-test
-
+
-: constant-fold-4 f ; foldable
+: constant-fold-4 f ; foldable
-: constant-fold-5 f ; foldable
+: constant-fold-5 f ; foldable
-
+
-[ f ] [
+[ f ] [
-    [ constant-fold-4 constant-fold-5 or ] compile-call
+    [ constant-fold-4 constant-fold-5 or ] compile-call
-] unit-test
+] unit-test
-
+
-[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
-
+
-[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
-[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
+[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
-[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
-
+
-[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
+[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
-[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
+[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
-[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
-[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
-
+
-[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
+[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
-[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
+[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
-
+
-[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
-[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 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 [ dup bitand ] compile-call ] unit-test
-
+
-[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
-[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
-[ -1 ] [ 5 [ -1 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 [ dup bitor ] compile-call ] unit-test
-
+
-[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap 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 bitxor ] compile-call ] unit-test
-[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
-[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
-
+
-[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
-
+
-[ f ] [ 5 [ dup < ] compile-call ] unit-test
+[ f ] [ 5 [ dup < ] compile-call ] unit-test
-[ t ] [ 5 [ dup <= ] compile-call ] unit-test
+[ t ] [ 5 [ dup <= ] compile-call ] unit-test
-[ f ] [ 5 [ dup > ] compile-call ] unit-test
+[ f ] [ 5 [ dup > ] compile-call ] unit-test
-[ t ] [ 5 [ dup >= ] compile-call ] unit-test
+[ t ] [ 5 [ dup >= ] compile-call ] unit-test
-
+
-[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
+[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
-[ t ] [ 5 [ dup = ] compile-call ] unit-test
+[ t ] [ 5 [ dup = ] compile-call ] unit-test
-[ t ] [ 5 [ dup number= ] compile-call ] unit-test
+[ t ] [ 5 [ dup number= ] compile-call ] unit-test
-[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
+[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
-
+
-GENERIC: detect-number ( obj -- obj )
+GENERIC: detect-number ( obj -- obj )
-M: number detect-number ;
+M: number detect-number ;
-
+
-[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
+[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
-
+
-! Regression
+! Regression
-[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
+[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
-
+
-! Regression
+! Regression
-USE: sorting
+USE: sorting
-USE: sorting.private
+USE: sorting.private
-
+
-: old-binsearch ( elt quot seq -- elt quot i )
+: old-binsearch ( elt quot seq -- elt quot i )
-    dup length 1 <= [
+    dup length 1 <= [
-        slice-from
+        slice-from
-    ] [
+    ] [
-        [ midpoint swap call ] 3keep roll dup zero?
+        [ midpoint swap call ] 3keep roll dup zero?
-        [ drop dup slice-from swap midpoint@ + ]
+        [ drop dup slice-from swap midpoint@ + ]
-        [ partition old-binsearch ] if
+        [ partition old-binsearch ] if
-    ] if ; inline
+    ] if ; inline
-
+
-[ 10 ] [
+[ 10 ] [
-    10 20 >vector <flat-slice>
+    10 20 >vector <flat-slice>
-    [ [ - ] swap old-binsearch ] compile-call 2nip
+    [ [ - ] swap old-binsearch ] compile-call 2nip
-] unit-test
+] unit-test
-
+
-! Regression
+! Regression
-TUPLE: silly-tuple a b ;
+TUPLE: silly-tuple a b ;
-
+
-[ 1 2 { silly-tuple-a silly-tuple-b } ] [
+[ 1 2 { silly-tuple-a silly-tuple-b } ] [
-    T{ silly-tuple f 1 2 }
+    T{ silly-tuple f 1 2 }
-    [
+    [
-        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
+        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
-    ] compile-call
+    ] compile-call
-] unit-test
+] unit-test
-
+
-! Regression
+! Regression
-: empty-compound ;
+: empty-compound ;
-
+
-: node-successor-f-bug ( x -- * )
+: node-successor-f-bug ( x -- * )
-    [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
+    [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
-
+
-[ t ] [ \ node-successor-f-bug compiled? ] unit-test
+[ t ] [ \ node-successor-f-bug compiled? ] unit-test
-
+
-: construct-empty-bug construct-empty ;
+: construct-empty-bug construct-empty ;
-
+
-[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
+[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
-
+
-! Make sure we have sane heuristics
+! Make sure we have sane heuristics
-: should-inline? method method-word flat-length 10 <= ;
+: should-inline? method method-word flat-length 10 <= ;
-
+
-[ t ] [ \ fixnum \ shift should-inline? ] unit-test
+[ t ] [ \ fixnum \ shift should-inline? ] unit-test
-[ f ] [ \ array \ equal? should-inline? ] unit-test
+[ f ] [ \ array \ equal? should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
+[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test

core/parser/parser.factor

@@ -18,7 +18,7 @@ TUPLE: lexer text line line-text line-length column ;
 
 : <lexer> ( 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

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

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

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
+    ] { } make try-process ;
-    wait-for-process zero? [ "Upload failed" throw ] unless ;
 
 : new-images ( -- )
     make-images compute-checksums upload-images ;

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
+
   ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

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 ;
+

extra/builder/test/test.factor

@@ -8,27 +8,17 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader
 IN: builder.test
 
 : do-load ( -- )
-  [
+  [ try-everything ] "../load-everything-time" log-runtime
-    [ load-everything ]
+  dup empty?
-    [ require-all-error-vocabs "../load-everything-log" log-object ]
+    [ drop ]
-    recover
+    [ "../load-everything-log" log-object ]
-  ]
+  if ;
-  "../load-everything-time" log-runtime ;
 
 : do-tests ( -- )
-  "" child-vocabs
+  run-all-tests keys
-  [ vocab-source-loaded? ] subset
-  [ vocab-tests-path ] map
-  [ dup [ ?resource-path exists? ] when ] subset
-  [ dup run-test ] { } map>assoc
-  [ second empty? not ] subset
   dup empty?
   [ drop ]
-  [
+  [ "../failing-tests" log-object ]
-    "../failing-tests" <file-writer>
-      [ [ nl failures. ] assoc-each ]
-    with-stream
-  ]
   if ;
 
 : do-all ( -- ) do-load do-tests ;

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." ;
 

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 
+ [ "this should propogate" throw ] future ?future 
-! ] must-fail
+] 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 
+] unit-test 
+
+! Race condition with futures
+[ 3 3 ] [
+    [ 3 ] future
+    dup ?future swap ?future
+] unit-test

extra/concurrency/concurrency.factor

@@ -264,12 +264,19 @@ PRIVATE>
     #! so the server continuation gets its new self updated.
     self swap call ;
 
+TUPLE: future status value processes ;
+
 : 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 ).
+    [
+        [
+            t 
+        ] compose
+    ] spawn drop
     [ self send ] compose spawn ;
 
 : ?future ( future -- result )

extra/concurrency/distributed/tags.txt

@@ -1 +1,2 @@
+enterprise
 extensions

extra/cpu/8080/emulator/tags.txt

@@ -1 +1 @@
-emulator
+emulators

extra/cpu/8080/tags.txt

@@ -1 +1 @@
-emulator
+emulators

extra/cryptlib/tags.txt

@@ -1 +1,2 @@
+enterprise
 bindings

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 ;

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

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
+words assocs definitions generic quotations effects slots
-slots continuations tuples debugger combinators
+continuations tuples debugger combinators vocabs help.stylesheet
-vocabs help.stylesheet help.topics help.crossref help.markup
+help.topics help.crossref help.markup sorting classes
-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

extra/http/server/tags.txt

@@ -1,2 +1,3 @@
+enterprise
 network
 web

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:"

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 -- )

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 <int> *char 1 = ; foldable
-
 : munge ( i -- i' )
     little-endian? [ BIN: 11000 bitxor ] unless ; inline
 

extra/ldap/tags.txt

@@ -1 +1,2 @@
+enterprise
 network

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

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: - <string> ; foldable
+
 : (write-message) ( msg word-name level multi? -- )
     [
-        "[" write 20 CHAR: - <string> write "] " write
+        "[" write multiline-header write "] " write
     ] [
         "[" write now (timestamp>rfc3339) "] " write
     ] if

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 } ;

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 )
 
-: <method> { 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' )
+: make-method-def ( quot classes generic -- quot )
-    [ method-def ] assoc-map ;
+    [
+        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 ;
+
+: <method-word> ( 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 <word>
+    dup rot define
+    dup xref ;
+
+: <method> ( quot classes generic -- method )
+    [ <method-word> ] 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 [
-    [ [ >r multi-predicate r> ] assoc-map ] keep argument-count
+        [
+            >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 )
+M: standard-combination method-prologue drop [ ] ;
-    >r congruify-methods sorted-methods r> multi-dispatch-quot ;
 
-M: standard-combination perform-combination
+M: standard-combination generic-prologue drop [ ] ;
-    drop [ methods method-defs ] keep standard-combination ;
+
+: 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
+M: hook-combination method-prologue
-    hook-combination-var [ get ] curry swap methods
+    drop [ drop ] ;
-    [ method-defs [ [ drop ] swap append ] assoc-map ] keep
-    standard-combination append ;
 
-: make-generic ( word -- )
+M: hook-combination generic-prologue
-    dup dup "multi-combination" word-prop perform-combination
+    hook-combination-var [ get ] curry ;
-    define ;
 
-: init-methods ( word -- )
+: update-generic ( word -- )
-    dup "multi-methods" word-prop
+    dup make-generic define ;
-    H{ } assoc-like
-    "multi-methods" set-word-prop ;
 
 : define-generic ( word combination -- )
-    dupd "multi-combination" set-word-prop
+    over "multi-combination" word-prop over = [
-    dup init-methods
+        2drop
-    make-generic ;
+    ] [
+        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>
+    [ <method> ] 2keep
     [ set-at ] with-methods ;
 
-: forget-method ( classes word -- )
+: forget-method ( classes generic -- )
     [ delete-at ] with-methods ;
 
-: parse-method ( -- method classes word method-spec )
+: method>spec ( method -- spec )
-    parse-definition 2 cut
+    dup method-classes swap method-generic add* ;
-    over >r
+
-    >r first2 swap r> <method> -rot
+: parse-method ( -- quot classes generic )
-    r> first2 swap add* >array ;
+    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 <method>
+    scan-word 1array scan-word parse-definition
-    -rot add-method ; parsing
+    -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 ;

extra/openssl/tags.txt

@@ -1,2 +1,3 @@
+enterprise
 network
 bindings

extra/smtp/tags.txt

@@ -1 +1,2 @@
+enterprise
 network

extra/tools/deploy/backend/backend.factor

@@ -22,7 +22,10 @@ IN: tools.deploy.backend
         +stdout+ +stderr+ set
     ] H{ } make-assoc <process-stream>
     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.

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 ;

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
+        "==== NOTHING TO TEST" print
-    ] if ;
+    ] 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 ;

extra/xml-rpc/tags.txt

@@ -1 +1,2 @@
+enterprise
 web

extra/xml/tags.txt

@@ -1 +1,2 @@
+enterprise
 web

misc/integration/deploy-size-test.factor

@@ -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 <file-writer>
-    [ deploy ] with-stream
-    dup file-length 1024 /f
-    2array
-] parallel-map .

misc/integration/macosx-deploy.factor

@@ -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 <file-writer>
-    [ deploy.app ] with-stream
-] parallel-each

misc/integration/macosx.sh

@@ -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 </dev/null
-
-EXE=Factor.app/Contents/MacOS/factor
-
-bash misc/integration/test.sh \
-	$EXE \
-	$CPU \
-	$TARGET \
-	yes \
-	yes \
-	yes \
-	"" \
-	"" \
-	""
-
-echo "Testing deployment"
-$EXE "misc/integration/macosx-deploy.factor" -run=none </dev/null

misc/integration/test.sh

@@ -1,93 +0,0 @@
-EXE=$1
-CPU=$2
-TARGET=$3
-LOAD_P=$4
-TEST_P=$5
-BENCHMARK_P=$6
-MAKE_FLAGS=$7
-BOOT_FLAGS=$8
-VARIANT=$9
-
-PREFIX=misc/integration/results-$CPU$VARIANT
-
-mkdir -p $PREFIX
-
-VM_LOG=$PREFIX/vm.log
-BOOT_LOG=$PREFIX/boot.log
-LOAD_LOG=$PREFIX/load.log
-TEST_LOG=$PREFIX/test.log
-BENCHMARK_LOG=$PREFIX/benchmark.log
-
-echo "Output files:"
-echo "VM compilation:  $VM_LOG"
-echo "Bootstrap:       $BOOT_LOG"
-echo "Load everything: $LOAD_LOG"
-echo "Unit tests:      $TEST_LOG"
-echo "Benchmarks:      $BENCHMARK_LOG"
-
-IMAGE=factor.image
-
-echo
-echo
-echo
-
-echo "Compiling VM"
-${MAKE-make} clean $TARGET $MAKE_FLAGS >$VM_LOG </dev/null
-
-if [ "$?" -ne 0 ]; then
-	echo "VM compile failed"
-	exit 1
-fi
-
-echo "Bootstrap"
-rm -f $IMAGE
-
-$EXE -i=boot.$CPU.image \
-	-no-user-init \
-	$BOOT_FLAGS \
-	-output-image=$IMAGE >$BOOT_LOG </dev/null
-
-if [ ! -e "factor.image" ]; then
-	echo "Bootstrap failed"
-	exit 1
-fi
-
-# Load all modules; run tests
-if [ "$LOAD_P" = "yes" ]; then
-	echo "Testing loading of all modules"
-
-	echo "USE: tools.browser load-everything USE: memory save USE: system 123 exit" \
-		>/tmp/factor-$$
-
-	$EXE -i=$IMAGE \
-		/tmp/factor-$$ \
-		-run=none \
-		>$LOAD_LOG </dev/null
-
-	if [ "$?" -ne 123 ]; then
-		echo "Load-everything failed"
-		exit 1
-	fi
-
-	# Check for parser notes
-	grep "automatically using" $LOAD_LOG
-
-	if [ "$?" -eq 0 ]; then
-		echo "Missing USE: declarations"
-		# exit 1
-	fi
-fi
-
-# Run unit tests
-if [ "$TEST_P" = "yes" ]; then
-	echo "Running all unit tests"
-
-	$EXE -i=$IMAGE "-e=test-all" -run=none >$TEST_LOG </dev/null
-fi
-
-# Run benchmarks
-if [ "$BENCHMARK_P" = "yes" ]; then
-	echo "Running all benchmarks"
-
-	$EXE -i=$IMAGE "-run=benchmark" >$BENCHMARK_LOG </dev/null
-fi

misc/integration/unix-arm.sh

@@ -1,10 +0,0 @@
-bash misc/integration/test.sh \
-	./factor \
-	ppc \
-	$1-arm \
-	no \
-	yes \
-	yes \
-	"" \
-	"" \
-	""

misc/integration/unix-ppc.sh

@@ -1,10 +0,0 @@
-bash misc/integration/test.sh \
-	./factor \
-	ppc \
-	$1-ppc \
-	yes \
-	yes \
-	yes \
-	"" \
-	"" \
-	""

misc/integration/unix-x86.32.sh

@@ -1,21 +0,0 @@
-bash misc/integration/test.sh \
-	./factor \
-	x86.32 \
-	$1-x86 \
-	yes \
-	yes \
-	yes \
-	"" \
-	"" \
-	"" || exit 1
-
-bash misc/integration/test.sh \
-	./factor \
-	x86.32 \
-	$1-x86 \
-	yes \
-	yes \
-	yes \
-	"" \
-	"-no-sse2" \
-	"-no-sse2"

misc/integration/unix-x86.64.sh

@@ -1,10 +0,0 @@
-bash misc/integration/test.sh \
-	./factor \
-	x86.64 \
-	$1-amd64 \
-	yes \
-	yes \
-	yes \
-	"" \
-	"" \
-	""

misc/integration/x11-deploy.factor

@@ -1,8 +0,0 @@
-USING: tools.deploy sequences io.files io kernel ;
-
-"." resource-path cd
-
-"mkdir deploy-log" run-process
-
-"factory" "deploy-log/" over append
-<file-writer> [ deploy ] with-stream

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();