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

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/asn1/tags.txt

@@ -0,0 +1 @@
+enterprise

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,19 +264,31 @@ PRIVATE>
     #! so the server continuation gets its new self updated.
     self swap call ;
 
-: future ( quot -- future )
+TUPLE: future value processes ;
-    #! 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 ;
 
-: ?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,

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/db/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/db/summary.txt

@@ -0,0 +1 @@
+Relational database abstraction layer

extra/db/tags.txt

@@ -0,0 +1 @@
+enterprise

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/furnace/tags.txt

@@ -0,0 +1 @@
+enterprise

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

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

extra/logging/analysis/tags.txt

@@ -0,0 +1 @@
+enterprise

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"

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 ( alist -- )
-
+    { 25 } { 6 } f f f <when> -rot [
-: schedule-insomniac ( service word-names -- )
+        [ email-log-report ] assoc-each rotate-logs
-    { 25 } { 6 } f f f <when> -rot
+    ] 2curry schedule ;
-    [ email-log-report ] 2curry schedule ;

extra/logging/insomniac/tags.txt

@@ -0,0 +1 @@
+enterprise

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

extra/logging/logging.factor

@@ -39,8 +39,8 @@ SYMBOL: log-service
 : rotate-logs ( -- )
     { } "rotate-logs" send-to-log-server ;
 
-: close-log-files ( -- )
+: close-logs ( -- )
-    { } "close-log-files" send-to-log-server ;
+    { } "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

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"

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/parser/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/logging/server/server-docs.factor

@@ -0,0 +1,4 @@
+IN: logging.server
+USING: help.syntax ;
+
+ABOUT: "logging.server"

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

extra/logging/server/tags.txt

@@ -0,0 +1 @@
+enterprise

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

extra/logging/tags.txt

@@ -0,0 +1 @@
+enterprise

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/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)
+  (let ((str (buffer-substring start end))
-  (comint-send-string "*factor*" "\n"))
+        (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)

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