Merge branch 'master' into unicode

Makefile

@@ -63,8 +63,9 @@ default:
 	@echo "macosx-ppc"
 	@echo "solaris-x86-32"
 	@echo "solaris-x86-64"
-	@echo "windows-ce-arm"
+	@echo "wince-arm"
-	@echo "windows-nt-x86-32"
+	@echo "winnt-x86-32"
+	@echo "winnt-x86-64"
 	@echo ""
 	@echo "Additional modifiers:"
 	@echo ""
@@ -122,10 +123,21 @@ solaris-x86-32:
 solaris-x86-64:
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
 
-windows-nt-x86-32:
+freetype6.dll:
+	wget http://factorcode.org/dlls/freetype6.dll
+	chmod 755 freetype6.dll
+
+zlib1.dll:
+	wget http://factorcode.org/dlls/zlib1.dll
+	chmod 755 zlib1.dll
+
+winnt-x86-32: freetype6.dll zlib1.dll
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
 
-windows-ce-arm:
+winnt-x86-64:
+	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
+
+wince-arm:
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
 
 macosx.app: factor
@@ -151,7 +163,7 @@ clean:
 	rm -f factor*.dll libfactor*.*
 
 vm/resources.o:
-	windres vm/factor.rs vm/resources.o
+	$(WINDRES) vm/factor.rs vm/resources.o
 
 .c.o:
 	$(CC) -c $(CFLAGS) -o $@ $<

core/alien/alien-tests.factor

@@ -14,7 +14,7 @@ prettyprint ;
 ! Testing the various bignum accessor
 10 <byte-array> "dump" set
 
-[ "dump" get alien-address ] unit-test-fails
+[ "dump" get alien-address ] must-fail
 
 [ 123 ] [
     123 "dump" get 0 set-alien-signed-1
@@ -61,9 +61,9 @@ cell 8 = [
 [ ] [ 0 F{ 1 2 3 } <displaced-alien> drop ] unit-test
 [ ] [ 0 ?{ t f t } <displaced-alien> drop ] unit-test
 
-[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] unit-test-fails
+[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
 
-[ 1 1 <displaced-alien> ] unit-test-fails
+[ 1 1 <displaced-alien> ] must-fail
 
 [ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
 

core/alien/c-types/c-types-docs.factor

@@ -34,6 +34,10 @@ HELP: stack-size
 { $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
 { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
 
+HELP: byte-length
+{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
+{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
+
 HELP: c-getter
 { $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
 { $description "Outputs a quotation which reads values of this C type from a C structure." }

core/alien/c-types/c-types-tests.factor

@@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE
 
 [
     0 B{ 1 2 3 4 } <displaced-alien> <void*>
-] unit-test-fails
+] must-fail

core/alien/c-types/c-types.factor

@@ -1,11 +1,17 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays generator.registers assocs
+USING: bit-arrays byte-arrays float-arrays arrays
-kernel kernel.private libc math namespaces parser sequences
+generator.registers assocs kernel kernel.private libc math
-strings words assocs splitting math.parser cpu.architecture
+namespaces parser sequences strings words assocs splitting
-alien alien.accessors quotations system compiler.units ;
+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
@@ -107,6 +113,14 @@ M: string stack-size c-type stack-size ;
 
 M: c-type stack-size c-type-size ;
 
+GENERIC: byte-length ( seq -- n ) flushable
+
+M: bit-array byte-length length 7 + -3 shift ;
+
+M: byte-array byte-length length ;
+
+M: float-array byte-length length "double" heap-size * ;
+
 : c-getter ( name -- quot )
     c-type c-type-getter [
         [ "Cannot read struct fields with type" throw ]
@@ -205,6 +219,9 @@ M: long-long-type box-return ( type -- )
     over [ <c-object> tuck 0 ] over c-setter append swap
     >r >r constructor-word r> r> add* define-inline ;
 
+: c-bool> ( int -- ? )
+    zero? not ;
+
 : >c-array ( seq type word -- )
     >r >r dup length dup r> <c-array> dup -roll r>
     [ execute ] 2curry 2each ; inline

core/alien/compiler/compiler-tests.factor

@@ -1,346 +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.inference ;
+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 ] unit-test-fails
+[ "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 ] unit-test-fails
+[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
-[ 1 2 3 4 5 6 "a" ffi_test_9 ] unit-test-fails
+[ 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 ] unit-test-fails
+[ 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
-
+
-[ t ] [ [ [ alien-indirect ] infer ] catch inference-error? ] unit-test
+[ [ 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 ] unit-test-effect
+{ 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 ] unit-test-fails
+[ -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 ] unit-test-effect
+{ 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 ] unit-test-fails
+[ "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 ] unit-test-fails
+[ 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 ] unit-test-fails
+[ 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
-
+
-! Test callbacks
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
-
+
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+: make-struct-12
-
+    "test-struct-12" <c-object>
-[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+    [ set-test-struct-12-x ] keep ;
-
+
-[ t ] [ callback-1 alien? ] unit-test
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
-
+
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
-
+
-[ ] [ callback-1 callback_test_1 ] unit-test
+! Test callbacks
-
+
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ;
+: callback-1 "void" { } "cdecl" [ ] alien-callback ;
-
+
-[ ] [ callback-2 callback_test_1 ] unit-test
+[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
-
+
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+[ t ] [ callback-1 alien? ] unit-test
-
+
-[ t ] [ 
+: callback_test_1 "void" { } "cdecl" alien-indirect ;
-    namestack*
+
-    3 "x" set callback-3 callback_test_1
+[ ] [ callback-1 callback_test_1 ] unit-test
-    namestack* eq?
+
-] unit-test
+: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
-
+
-[ 5 ] [ 
+[ ] [ callback-2 callback_test_1 ] unit-test
-    [
+
-        3 "x" set callback-3 callback_test_1 "x" get
+: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
-    ] with-scope
+
-] unit-test
+[ t ] [ 
-
+    namestack*
-: callback-4
+    3 "x" set callback-3 callback_test_1
-    "void" { } "cdecl" [ "Hello world" write ] alien-callback
+    namestack* eq?
-    data-gc ;
+] unit-test
-
+
-[ "Hello world" ] [ 
+[ 5 ] [ 
-    [ callback-4 callback_test_1 ] string-out
+    [
-] unit-test
+        3 "x" set callback-3 callback_test_1 "x" get
-
+    ] with-scope
-: callback-5
+] unit-test
-    "void" { } "cdecl" [ data-gc ] alien-callback ;
+
-
+: callback-4
-[ "testing" ] [
+    "void" { } "cdecl" [ "Hello world" write ] alien-callback
-    "testing" callback-5 callback_test_1
+    data-gc ;
-] unit-test
+
-
+[ "Hello world" ] [ 
-: callback-5a
+    [ callback-4 callback_test_1 ] string-out
-    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
+] unit-test
-
+
-! Hack; if we're on ARM, we probably don't have much RAM, so
+: callback-5
-! skip this test.
+    "void" { } "cdecl" [ data-gc ] alien-callback ;
-cpu "arm" = [
+
-    [ "testing" ] [
+[ "testing" ] [
-        "testing" callback-5a callback_test_1
+    "testing" callback-5 callback_test_1
-    ] unit-test
+] unit-test
-] unless
+
-
+: callback-5a
-: callback-6
+    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
-    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+
-
+! Hack; if we're on ARM, we probably don't have much RAM, so
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+! skip this test.
-
+cpu "arm" = [
-: callback-7
+    [ "testing" ] [
-    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+        "testing" callback-5a callback_test_1
-
+    ] unit-test
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+] unless
-
+
-[ f ] [ namespace global eq? ] unit-test
+: callback-6
-
+    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
-: callback-8
+
-    "void" { } "cdecl" [
+[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
-        [ continue ] callcc0
+
-    ] alien-callback ;
+: callback-7
-
+    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
-[ ] [ callback-8 callback_test_1 ] unit-test
+
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+
+[ f ] [ namespace global eq? ] unit-test
+
+: callback-8
+    "void" { } "cdecl" [
+        [ continue ] callcc0
+    ] alien-callback ;
+
+[ ] [ callback-8 callback_test_1 ] unit-test

core/alien/compiler/compiler.factor

@@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
 inference.state inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
-kernel.private threads continuations.private libc combinators ;
+kernel.private threads continuations.private libc combinators
+compiler.errors continuations ;
 IN: alien.compiler
 
 ! Common protocol for alien-invoke/alien-callback/alien-indirect
@@ -207,9 +208,21 @@ M: alien-invoke-error summary
     swap alien-node-parameters parameter-sizes drop
     number>string 3append ;
 
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+    drop "Library not found" ;
+
+: no-such-library ( name -- )
+    \ no-such-library +linkage+ (inference-error) ;
+
 : (alien-invoke-dlsym) ( node -- symbol dll )
     dup alien-invoke-function
-    swap alien-invoke-library load-library ;
+    swap alien-invoke-library [
+        load-library
+    ] [
+        2drop no-such-library
+    ] recover ;
 
 TUPLE: no-such-symbol ;
 
@@ -217,7 +230,7 @@ M: no-such-symbol summary
     drop "Symbol not found" ;
 
 : no-such-symbol ( -- )
-    \ no-such-symbol inference-error ;
+    \ no-such-symbol +linkage+ (inference-error) ;
 
 : alien-invoke-dlsym ( node -- symbol dll )
     dup (alien-invoke-dlsym) 2dup dlsym [

core/arrays/arrays-tests.factor

@@ -2,10 +2,10 @@ USING: arrays kernel sequences sequences.private growable
 tools.test vectors layouts system math vectors.private ;
 IN: temporary
 
-[ -2 { "a" "b" "c" } nth ] unit-test-fails
+[ -2 { "a" "b" "c" } nth ] must-fail
-[ 10 { "a" "b" "c" } nth ] unit-test-fails
+[ 10 { "a" "b" "c" } nth ] must-fail
-[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails
+[ "hi" -2 { "a" "b" "c" } set-nth ] must-fail
-[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails
+[ "hi" 10 { "a" "b" "c" } set-nth ] must-fail
 [ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test
 [ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test
 [ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
@@ -17,5 +17,5 @@ IN: temporary
 [ { "a" "b" "c" "d" "e" } ]
 [ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test
 
-[ -1 f <array> ] unit-test-fails
+[ -1 f <array> ] must-fail
-[ cell-bits cell log2 - 2^ f <array> ] unit-test-fails
+[ cell-bits cell log2 - 2^ f <array> ] must-fail

core/bit-arrays/bit-arrays-tests.factor

@@ -51,4 +51,4 @@ IN: temporary
 
 [ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
 
-[ -10 ?{ } resize-bit-array ] unit-test-fails
+[ -10 ?{ } resize-bit-array ] must-fail

core/bootstrap/image/image-tests.factor

@@ -1,6 +1,5 @@
 IN: temporary
-USING: bootstrap.image bootstrap.image.private
+USING: bootstrap.image bootstrap.image.private tools.test ;
-tools.test.inference ;
 
 \ ' must-infer
 \ write-image must-infer

core/bootstrap/image/image.factor

@@ -7,9 +7,26 @@ strings sbufs vectors words quotations assocs system layouts
 splitting growable classes tuples words.private
 io.binary io.files vocabs vocabs.loader source-files
 definitions debugger float-arrays quotations.private
-combinators.private combinators ;
+sequences.private combinators ;
 IN: bootstrap.image
 
+: my-arch ( -- arch )
+    cpu dup "ppc" = [ os "-" rot 3append ] when ;
+
+: boot-image-name ( arch -- string )
+    "boot." swap ".image" 3append ;
+
+: my-boot-image-name ( -- string )
+    my-arch boot-image-name ;
+
+: images ( -- seq )
+    {
+        "x86.32"
+        "x86.64"
+        "linux-ppc" "macosx-ppc"
+        ! "arm"
+    } ;
+
 <PRIVATE
 
 ! Constants
@@ -119,7 +136,7 @@ SYMBOL: undefined-quot
 : here-as ( tag -- pointer ) here swap bitor ;
 
 : align-here ( -- )
-    here 8 mod 4 = [ 0 emit ] when ;
+    here 8 mod 4 = [ heap-size drop 0 emit ] when ;
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
@@ -160,6 +177,7 @@ GENERIC: ' ( obj -- ptr )
     [ dup bignum-bits neg shift swap bignum-radix bitand ]
     [ ] unfold nip ;
 
+USE: continuations
 : emit-bignum ( n -- )
     dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
     dup length 1+ emit-fixnum
@@ -197,13 +215,10 @@ M: f '
 :  1,  1 >bignum '  1-offset fixup ;
 : -1, -1 >bignum ' -1-offset fixup ;
 
-! Beginning of the image
-
-: begin-image ( -- ) emit-header t, 0, 1, -1, ;
-
 ! Words
 
 : emit-word ( word -- )
+    dup subwords [ emit-word ] each
     [
         dup hashcode ' ,
         dup word-name ' ,
@@ -224,7 +239,7 @@ M: f '
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
 
 : transfer-word ( word -- word )
-    dup target-word [ ] [ word-name no-word ] ?if ;
+    dup target-word swap or ;
 
 : fixup-word ( word -- offset )
     transfer-word dup objects get at
@@ -248,7 +263,7 @@ M: wrapper '
     emit-seq ;
 
 : pack-string ( string -- newstr )
-    dup length 1+ bootstrap-cell align 0 pad-right ;
+    dup length bootstrap-cell align 0 pad-right ;
 
 : emit-string ( string -- ptr )
     string type-number object tag-number [
@@ -285,17 +300,20 @@ M: float-array ' float-array emit-dummy-array ;
     ] emit-object ;
 
 : emit-tuple ( obj -- pointer )
-    objects get [
+    [
         [ tuple>array unclip transfer-word , % ] { } make
         tuple type-number dup emit-array
-    ] cache ; inline
+    ]
+    ! Hack
+    over class word-name "tombstone" =
+    [ objects get swap cache ] [ call ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tombstone '
     delegate
     "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first emit-tuple ;
+    word-def first objects get [ emit-tuple ] cache ;
 
 M: array '
     array type-number object tag-number emit-array ;
@@ -313,41 +331,6 @@ M: quotation '
         ] emit-object
     ] cache ;
 
-! Vectors and sbufs
-
-M: vector '
-    dup length swap underlying '
-    tuple type-number tuple tag-number [
-        4 emit-fixnum
-        vector ' emit
-        f ' emit
-        emit ! array ptr
-        emit-fixnum ! length
-    ] emit-object ;
-
-M: sbuf '
-    dup length swap underlying '
-    tuple type-number tuple tag-number [
-        4 emit-fixnum
-        sbuf ' emit
-        f ' emit
-        emit ! array ptr
-        emit-fixnum ! length
-    ] emit-object ;
-
-! Hashes
-
-M: hashtable '
-    [ hash-array ' ] keep
-    tuple type-number tuple tag-number [
-        5 emit-fixnum
-        hashtable ' emit
-        f ' emit
-        dup hash-count emit-fixnum
-        hash-deleted emit-fixnum
-        emit ! array ptr
-    ] emit-object ;
-
 ! Curries
 
 M: curry '
@@ -399,7 +382,10 @@ M: curry '
 : fixup-header ( -- )
     heap-size data-heap-size-offset fixup ;
 
-: end-image ( -- )
+: build-image ( -- image )
+    800000 <vector> image set
+    20000 <hashtable> objects set
+    emit-header t, 0, 1, -1,
     "Serializing words..." print flush
     emit-words
     "Serializing JIT data..." print flush
@@ -414,7 +400,8 @@ M: curry '
     fixup-header
     "Image length: " write image get length .
     "Object cache size: " write objects get assoc-size .
-    \ word global delete-at ;
+    \ word global delete-at
+    image get ;
 
 ! Image output
 
@@ -425,37 +412,23 @@ M: curry '
         [ >le write ] curry each
     ] if ;
 
-: image-name
+: write-image ( image -- )
-    "boot." architecture get ".image" 3append resource-path ;
+    "Writing image to " write
-
+    architecture get boot-image-name resource-path
-: write-image ( image filename -- )
+    dup write "..." print flush
-    "Writing image to " write dup write "..." print flush
     <file-writer> [ (write-image) ] with-stream ;
 
-: prepare-image ( -- )
-    bootstrapping? on
-    load-help? off
-    800000 <vector> image set
-    20000 <hashtable> objects set ;
-
 PRIVATE>
 
 : make-image ( arch -- )
-    architecture [
+    [
-        prepare-image
+        architecture set
-        begin-image
+        bootstrapping? on
+        load-help? off
         "resource:/core/bootstrap/stage1.factor" run-file
-        end-image
+        build-image
-        image get image-name write-image
+        write-image
-    ] with-variable ;
+    ] with-scope ;
-
-: my-arch ( -- arch )
-    cpu dup "ppc" = [ os "-" rot 3append ] when ;
 
 : make-images ( -- )
-    {
+    images [ make-image ] each ;
-        "x86.32"
-        "x86.64"
-        "linux-ppc" "macosx-ppc"
-        ! "arm"
-    } [ make-image ] each ;

core/bootstrap/layouts/layouts.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math words kernel alien byte-arrays
 hashtables vectors strings sbufs arrays bit-arrays
@@ -8,7 +8,7 @@ BIN: 111 tag-mask set
 8 num-tags set
 3 tag-bits set
 
-20 num-types set
+19 num-types set
 
 H{
     { fixnum      BIN: 000 }
@@ -27,11 +27,10 @@ tag-numbers get H{
     { float-array 10 }
     { callstack 11 }
     { string 12 }
-    { curry 13 }
+    { bit-array 13 }
     { quotation 14 }
     { dll 15 }
     { alien 16 }
     { word 17 }
     { byte-array 18 }
-    { bit-array 19 }
 } union type-numbers set

core/bootstrap/primitives.factor

@@ -118,11 +118,11 @@ H{ } clone update-map set
 H{ } clone typemap set
 num-types get f <array> builtins set
 
-! These symbols are needed by the code that executes below
+! Forward definitions
-{
+"object" "kernel" create t "class" set-word-prop
-    { "object" "kernel" }
+"object" "kernel" create union-class "metaclass" set-word-prop
-    { "null" "kernel" }
+
-} [ create drop ] assoc-each
+"null" "kernel" create drop
 
 "fixnum" "math" create "fixnum?" "math" create { } define-builtin
 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@@ -295,23 +295,6 @@ define-builtin
 "float-array?" "float-arrays" create
 { } define-builtin
 
-"curry" "kernel" create
-"curry?" "kernel" create
-{
-    {
-        { "object" "kernel" }
-        "obj"
-        { "curry-obj" "kernel" }
-        f
-    }
-    {
-        { "object" "kernel" }
-        "obj"
-        { "curry-quot" "kernel" }
-        f
-    }
-} define-builtin
-
 "callstack" "kernel" create "callstack?" "kernel" create
 { } define-builtin
 
@@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class
     }
 } define-tuple-class
 
+"curry" "kernel" create
+{
+    {
+        { "object" "kernel" }
+        "obj"
+        { "curry-obj" "kernel" }
+        f
+    } {
+        { "object" "kernel" }
+        "quot"
+        { "curry-quot" "kernel" }
+        f
+    }
+} define-tuple-class
+
+"compose" "kernel" create
+{
+    {
+        { "object" "kernel" }
+        "first"
+        { "compose-first" "kernel" }
+        f
+    } {
+        { "object" "kernel" }
+        "second"
+        { "compose-second" "kernel" }
+        f
+    }
+} define-tuple-class
+
 ! Primitive words
 : make-primitive ( word vocab n -- )
-    >r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
+    >r create dup reset-word r>
+    [ do-primitive ] curry [ ] like define ;
 
 {
     { "(execute)" "words.private" }
     { "(call)" "kernel.private" }
-    { "uncurry" "kernel.private" }
     { "bignum>fixnum" "math.private" }
     { "float>fixnum" "math.private" }
     { "fixnum>bignum" "math.private" }
@@ -553,8 +566,6 @@ builtins get num-tags get tail f union-class define-class
     { "millis" "system" }
     { "type" "kernel.private" }
     { "tag" "kernel.private" }
-    { "cwd" "io.files" }
-    { "cd" "io.files" }
     { "modify-code-heap" "compiler.units" }
     { "dlopen" "alien" }
     { "dlsym" "alien" }
@@ -624,7 +635,6 @@ builtins get num-tags get tail f union-class define-class
     { "become" "kernel.private" }
     { "(sleep)" "threads.private" }
     { "<float-array>" "float-arrays" }
-    { "curry" "kernel" }
     { "<tuple-boa>" "tuples.private" }
     { "class-hash" "kernel.private" }
     { "callstack>array" "kernel" }

core/bootstrap/stage1.factor

@@ -32,12 +32,13 @@ vocabs.loader system ;
 
     "io.streams.c" require
     "vocabs.loader" require
+    
     "syntax" require
     "bootstrap.layouts" require
 
     [
         "resource:core/bootstrap/stage2.factor"
-        dup ?resource-path exists? [
+        dup resource-exists? [
             run-file
         ] [
             "Cannot find " write write "." print

core/bootstrap/stage2.factor

@@ -1,31 +1,70 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init command-line namespaces words debugger io
 kernel.private math memory continuations kernel io.files
 io.backend system parser vocabs sequences prettyprint
 vocabs.loader combinators splitting source-files strings
 definitions assocs compiler.errors compiler.units
-math.parser ;
+math.parser generic ;
 IN: bootstrap.stage2
 
+SYMBOL: bootstrap-time
+
+: default-image-name ( -- string )
+    vm file-name windows? [ "." split1 drop ] when
+    ".image" append ;
+
+: do-crossref ( -- )
+    "Cross-referencing..." print flush
+    H{ } clone crossref set-global
+    xref-words
+    xref-generics
+    xref-sources ;
+
+: load-components ( -- )
+    "exclude" "include"
+    [ get-global " " split [ empty? not ] subset ] 2apply
+    seq-diff
+    [ "bootstrap." swap append require ] each ;
+
+: compile-remaining ( -- )
+    "Compiling remaining words..." print flush
+    vocabs [
+        words "compile" "compiler" lookup execute
+    ] each ;
+
+: count-words ( pred -- )
+    all-words swap subset length number>string write ;
+
+: print-report ( time -- )
+    1000 /i
+    60 /mod swap
+    "Bootstrap completed in " write number>string write
+    " minutes and " write number>string write " seconds." print
+
+    [ compiled? ] count-words " compiled words" print
+    [ symbol? ] count-words " symbol words" print
+    [ ] count-words " words total" print
+
+    "Bootstrapping is complete." print
+    "Now, you can run Factor:" print
+    vm write " -i=" write "output-image" get print flush ;
+
 ! Wrap everything in a catch which starts a listener so
 ! you can see what went wrong, instead of dealing with a
 ! fep
 [
-    vm file-name windows? [ "." split1 drop ] when
+    ! We time bootstrap
-    ".image" append "output-image" set-global
+    millis >r
 
-    "math tools help compiler ui ui.tools io" "include" set-global
+    default-image-name "output-image" set-global
+
+    "math help compiler tools ui ui.tools io" "include" set-global
     "" "exclude" set-global
 
     parse-command-line
 
-    "-no-crossref" cli-args member? [
+    "-no-crossref" cli-args member? [ do-crossref ] unless
-        "Cross-referencing..." print flush
-        H{ } clone crossref set-global
-        xref-words
-        xref-sources
-    ] unless
 
     ! Set dll paths
     wince? [ "windows.ce" require ] when
@@ -39,19 +78,12 @@ IN: bootstrap.stage2
     ] if
 
     [
-        "exclude" "include"
+        load-components
-        [ get-global " " split [ empty? not ] subset ] 2apply
-        seq-diff
-        [ "bootstrap." swap append require ] each
 
         run-bootstrap-init
 
-        "Compiling remaining words..." print flush
-
         "bootstrap.compiler" vocab [
-            vocabs [
+            compile-remaining
-                words "compile" "compiler" lookup execute
-            ] each
         ] when
     ] with-compiler-errors
     :errors
@@ -73,19 +105,13 @@ IN: bootstrap.stage2
             ] [ print-error 1 exit ] recover
         ] set-boot-quot
 
-        : count-words ( pred -- )
+        millis r> - dup bootstrap-time set-global
-            all-words swap subset length number>string write ;
+        print-report
-
-        [ compiled? ] count-words " compiled words" print
-        [ symbol? ] count-words " symbol words" print
-        [ ] count-words " words total" print
-
-        "Bootstrapping is complete." print
-        "Now, you can run Factor:" print
-        vm write " -i=" write "output-image" get print flush
 
         "output-image" get resource-path save-image-and-exit
     ] if
 ] [
-    print-error :c "listener" vocab-main execute
+    print-error :c restarts.
+    "listener" vocab-main execute
+    1 exit
 ] recover

core/byte-arrays/byte-arrays-tests.factor

@@ -5,4 +5,4 @@ USING: tools.test byte-arrays ;
 
 [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
 
-[ -10 B{ } resize-byte-array ] unit-test-fails
+[ -10 B{ } resize-byte-array ] must-fail

core/classes/classes-tests.factor

@@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ;
 [ f ] [ union-1 union-class? ] unit-test
 [ t ] [ union-1 predicate-class? ] unit-test
 [ "union-1" ] [ 8 generic-update-test ] unit-test
-[ -7 generic-update-test ] unit-test-fails
+[ -7 generic-update-test ] must-fail
 
 ! Test mixins
 MIXIN: sequence-mixin
@@ -169,10 +169,14 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
 UNION: forget-class-bug-1 integer ;
 UNION: forget-class-bug-2 forget-class-bug-1 dll ;
 
-FORGET: forget-class-bug-1
+[
-FORGET: forget-class-bug-2
+    \ forget-class-bug-1 forget
+    \ forget-class-bug-2 forget
+] with-compilation-unit
 
-[ t ] [ integer dll class-or interned? ] unit-test
+[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
+
+[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
 
 DEFER: mixin-forget-test-g
 
@@ -191,7 +195,7 @@ DEFER: mixin-forget-test-g
 ] unit-test
 
 [ { } ] [ { } mixin-forget-test-g ] unit-test
-[ H{ } mixin-forget-test-g ] unit-test-fails
+[ H{ } mixin-forget-test-g ] must-fail
 
 [ ] [
     {
@@ -205,7 +209,7 @@ DEFER: mixin-forget-test-g
     parse-stream drop
 ] unit-test
 
-[ { } mixin-forget-test-g ] unit-test-fails
+[ { } mixin-forget-test-g ] must-fail
 [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
 
 ! Method flattening interfered with mixin update

core/classes/classes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: classes
 USING: arrays definitions assocs kernel
@@ -20,7 +20,9 @@ PREDICATE: class tuple-class
 
 : classes ( -- seq ) class<map get keys ;
 
-: type>class ( n -- class ) builtins get nth ;
+: type>class ( n -- class ) builtins get-global nth ;
+
+: bootstrap-type>class ( n -- class ) builtins get nth ;
 
 : predicate-word ( word -- predicate )
     [ word-name "?" append ] keep word-vocabulary create ;

core/classes/union/union.factor

@@ -1,19 +1,34 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays ;
+generic.standard namespaces arrays math quotations ;
 IN: classes.union
 
 PREDICATE: class union-class
     "metaclass" word-prop union-class eq? ;
 
 ! Union classes for dispatch on multiple classes.
+: small-union-predicate-quot ( members -- quot )
+    dup empty? [
+        drop [ drop f ]
+    ] [
+        unclip first "predicate" word-prop swap
+        [ >r "predicate" word-prop [ dup ] swap append r> ]
+        assoc-map alist>quot
+    ] if ;
+
+: big-union-predicate-quot ( members -- quot )
+    [ small-union-predicate-quot ] [ dup ]
+    class-hash-dispatch-quot ;
+
 : union-predicate-quot ( members -- quot )
-    0 (dispatch#) [
+    [ [ drop t ] ] { } map>assoc
-        [ [ drop t ] ] { } map>assoc
+    dup length 4 <= [
-        object bootstrap-word [ drop f ] 2array add*
+        small-union-predicate-quot
-        single-combination
+    ] [
-    ] with-variable ;
+        flatten-methods
+        big-union-predicate-quot
+    ] if ;
 
 : define-union-predicate ( class -- )
     dup predicate-word

core/combinators/combinators-docs.factor

@@ -1,6 +1,6 @@
 USING: arrays help.markup help.syntax strings sbufs vectors
 kernel quotations generic generic.standard classes
-math assocs sequences combinators.private ;
+math assocs sequences sequences.private ;
 IN: combinators
 
 ARTICLE: "combinators-quot" "Quotation construction utilities"

core/combinators/combinators-tests.factor

@@ -38,7 +38,7 @@ namespaces combinators words ;
 ! Interpreted
 [ "two" ] [ 2 \ case-test-1 word-def call ] unit-test
 
-[ "x" case-test-1 ] unit-test-fails
+[ "x" case-test-1 ] must-fail
 
 : case-test-2
     {

core/combinators/combinators.factor

@@ -4,12 +4,6 @@ IN: combinators
 USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors ;
 
-<PRIVATE
-
-: dispatch ( n array -- ) array-nth (call) ;
-
-PRIVATE>
-
 TUPLE: no-cond ;
 
 : no-cond ( -- * ) \ no-cond construct-empty throw ;

core/compiler/compiler-tests.factor

@@ -1,21 +0,0 @@
-USING: io.files tools.test sequences namespaces kernel
-compiler.units ;
-
-{
-    "templates-early"
-    "simple"
-    "intrinsics"
-    "float"
-    "generic"
-    "ifte"
-    "templates"
-    "optimizer"
-    "redefine"
-    "stack-trace"
-    "alien"
-    "curry"
-    "tuples"
-}
-[ "resource:core/compiler/test/" swap ".factor" 3append ] map
-[ run-test ] map
-[ failures get push-all ] each

core/compiler/compiler.factor

@@ -26,7 +26,7 @@ IN: compiler
     >r dupd save-effect r>
     f pick compiler-error
     over compiled-unxref
-    over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
+    over crossref? [ compiled-xref ] [ 2drop ] if ;
 
 : compile-succeeded ( word -- effect dependencies )
     [

core/compiler/errors/errors-docs.factor

@@ -1,14 +1,15 @@
 IN: compiler.errors
 USING: help.markup help.syntax vocabs.loader words io
-quotations ;
+quotations compiler.errors.private ;
 
 ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"The compiler saves compile warnings and errors in a global variable:"
+"The compiler saves various notifications in a global variable:"
 { $subsection compiler-errors }
-"The warnings and errors can be viewed later:"
+"These notifications can be viewed later:"
-{ $subsection :warnings }
 { $subsection :errors }
-"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:"
+{ $subsection :warnings }
+{ $subsection :linkage }
+"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
 { $link with-compiler-errors } ;
 
 HELP: compiler-errors
@@ -16,7 +17,7 @@ HELP: compiler-errors
 
 HELP: compiler-error
 { $values { "error" "an error" } { "word" word } }
-{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ;
+{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
 
 HELP: compiler-error.
 { $values { "error" "an error" } { "word" word } }
@@ -25,24 +26,18 @@ HELP: compiler-error.
 HELP: compiler-errors.
 { $values { "errors" "an assoc mapping words to errors" } }
 { $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
-
-HELP: (:errors)
-{ $values { "seq" "an alist" } }
-{ $description "Outputs all serious compiler errors from the most recent compile."  } ;
-
 HELP: :errors
 { $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
 
-HELP: (:warnings)
-{ $values { "seq" "an alist" } }
-{ $description "Outputs all ignorable compiler warnings from the most recent compile."  } ;
-
 HELP: :warnings
 { $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
 
-{ :errors (:errors) :warnings (:warnings) } related-words
+HELP: :linkage
+{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
+
+{ :errors :warnings } related-words
 
 HELP: with-compiler-errors
 { $values { "quot" quotation } }
-{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." }
+{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
 { $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;

core/compiler/errors/errors.factor

@@ -4,51 +4,66 @@ USING: kernel namespaces assocs prettyprint io sequences
 sorting continuations debugger math math.parser ;
 IN: compiler.errors
 
+SYMBOL: +error+
+SYMBOL: +warning+
+SYMBOL: +linkage+
+
+GENERIC: compiler-error-type ( error -- ? )
+
+M: object compiler-error-type drop +error+ ;
+
+<PRIVATE
+
 SYMBOL: compiler-errors
 
 SYMBOL: with-compiler-errors?
 
-: compiler-error ( error word -- )
-    with-compiler-errors? get [
-        compiler-errors get pick
-        [ set-at ] [ delete-at drop ] if
-    ] [ 2drop ] if ;
-
 : compiler-error. ( error word -- )
     nl
     "While compiling " write pprint ": " print
     nl
     print-error ;
 
-: compiler-errors. ( assoc -- )
+: errors-of-type ( type -- assoc )
-    >alist sort-keys [ swap compiler-error. ] assoc-each ;
-
-GENERIC: compiler-warning? ( error -- ? )
-
-M: object compiler-warning? drop f ;
-
-: (:errors) ( -- assoc )
     compiler-errors get-global
-    [ nip compiler-warning? not ] assoc-subset ;
+    swap [ >r nip compiler-error-type r> eq? ] curry
+    assoc-subset ;
 
-: :errors (:errors) compiler-errors. ;
+: compiler-errors. ( type -- )
+    errors-of-type >alist sort-keys
+    [ swap compiler-error. ] assoc-each ;
 
-: (:warnings) ( -- seq )
+: (compiler-report) ( what type word -- )
-    compiler-errors get-global
+    over errors-of-type assoc-empty? [ 3drop ] [
-    [ nip compiler-warning? ] assoc-subset ;
-
-: :warnings (:warnings) compiler-errors. ;
-
-: (compiler-report) ( what assoc -- )
-    length dup zero? [ 2drop ] [
         [
-            ":" % over % " - print " % # " compiler " % % "." %
+            ":" %
+            %
+            " - print " %
+            errors-of-type assoc-size #
+            " " %
+            %
+            "." %
         ] "" make print
     ] if ;
 
 : compiler-report ( -- )
-    "errors" (:errors) (compiler-report)
+    "semantic errors" +error+ "errors" (compiler-report)
-    "warnings" (:warnings) (compiler-report) ;
+    "semantic warnings" +warning+ "warnings" (compiler-report)
+    "linkage errors" +linkage+ "linkage" (compiler-report) ;
+
+PRIVATE>
+
+: compiler-error ( error word -- )
+    with-compiler-errors? get [
+        compiler-errors get pick
+        [ set-at ] [ delete-at drop ] if
+    ] [ 2drop ] if ;
+
+: :errors +error+ compiler-errors. ;
+
+: :warnings +warning+ compiler-errors. ;
+
+: :linkage +linkage+ compiler-errors. ;
 
 : with-compiler-errors ( quot -- )
     with-compiler-errors? get "quiet" get or [ call ] [

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/redefine.factor

@@ -1,252 +0,0 @@
-USING: compiler definitions generic assocs inference math
-namespaces parser tools.test words kernel sequences arrays io
-effects tools.test.inference compiler.units inference.state ;
-IN: temporary
-
-DEFER: x-1
-DEFER: x-2
-
-[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [
-    "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval
-    "IN: temporary : x-2 3 x-1 ;" eval
-
-    [ t ] [
-        { x-2 } compile
-
-        \ x-2 word-xt
-
-        { x-1 } compile
-
-        \ x-2 word-xt =
-    ] unit-test
-] with-variable
-
-DEFER: b
-DEFER: c
-
-[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test
-
-[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
-
-{ 0 4 } [ b ] unit-test-effect
-
-[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
-
-[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
-
-{ 0 6 } [ b ] unit-test-effect
-
-\ b word-xt "b-xt" set
-
-[ ] [ "IN: temporary : c b ;" eval ] unit-test
-
-[ t ] [ "b-xt" get \ b word-xt = ] unit-test
-
-\ c word-xt "c-xt" set
-
-[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test
-
-[ t ] [ "c-xt" get \ c word-xt = ] unit-test
-
-[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test
-
-[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
-
-{ 0 4 } [ c ] unit-test-effect
-
-[ f ] [ "c-xt" get \ c word-xt = ] unit-test
-
-[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test
-
-[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : e d d ;" eval ] unit-test
-
-[ 3 3 ] [ "USE: temporary e" eval ] unit-test
-
-[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test
-
-[ 4 4 ] [ "USE: temporary e" eval ] unit-test
-
-DEFER: x-3
-
-[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test
-
-DEFER: x-4
-
-[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test
-
-[ t ] [ \ x-4 compiled? ] unit-test
-
-[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test
-
-[ f ] [ \ x-3 compiled? ] unit-test
-
-[ f ] [ \ x-4 compiled? ] unit-test
-
-[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test
-
-[ t ] [ \ x-3 compiled? ] unit-test
-
-[ t ] [ \ x-4 compiled? ] unit-test
-
-[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
-
-[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test
-
-DEFER: g-test-1
-
-DEFER: g-test-3
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test
-
-[ 25 ] [ 5 g-test-1 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test
-
-[ 5 ] [ 5 g-test-1 ] unit-test
-
-[ t ] [
-    \ g-test-3 word-xt
-
-    "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
-
-    \ g-test-3 word-xt =
-] unit-test
-
-DEFER: g-test-5
-
-[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test
-
-[ 6 ] [ g-test-5 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test
-
-[ 13 ] [ g-test-5 ] unit-test
-
-DEFER: g-test-6
-
-[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test
-
-DEFER: g-test-7
-
-[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test
-
-[ 133 ] [ g-test-7 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test
-
-[ 138 ] [ g-test-7 ] unit-test
-
-USE: macros
-
-DEFER: macro-test-3
-
-[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) <array> >quotation ;" eval ] unit-test
-
-[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test
-
-[ 625 ] [ 5 macro-test-3 ] unit-test
-
-[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test
-
-[ 8 ] [ 5 macro-test-3 ] unit-test
-
-USE: hints
-
-DEFER: hints-test-2
-
-[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test
-
-[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test
-
-[ 8 ] [ hints-test-2 ] unit-test
-
-[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test
-
-[ 10 ] [ hints-test-2 ] unit-test
-
-DEFER: inline-then-not-inline-test-1
-DEFER: inline-then-not-inline-test-2
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-2 inline-then-not-inline-test-1 ;" eval ] unit-test
-
-[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test
-
-\ inline-then-not-inline-test-2 word-xt "a" set
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test
-
-[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
-
-[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
-
-DEFER: generic-then-not-generic-test-1
-DEFER: generic-then-not-generic-test-2
-
-[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test
-
-[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test
-
-[ 9 ] [ generic-then-not-generic-test-2 ] unit-test
-
-[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
-
-[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
-
-DEFER: foldable-test-1
-DEFER: foldable-test-2
-
-[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
-
-[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
-
-[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test
-
-[ 3 ] [ foldable-test-2 ] unit-test
-
-[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
-
-[ 4 ] [ foldable-test-2 ] unit-test
-
-DEFER: flushable-test-2
-
-[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
-
-[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
-
-[ V{ } ] [ flushable-test-2 ] unit-test
-
-[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
-
-[ V{ 3 } ] [ flushable-test-2 ] unit-test
-
-: ax ;
-: bx ax ;
-[ \ bx forget ] with-compilation-unit
-
-[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test
-
-DEFER: defer-redefine-test-2
-
-[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test
-
-[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
-
-[ defer-redefine-test-2 ] unit-test-fails
-
-[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
-
-[ 2 1 ] [ defer-redefine-test-2 ] unit-test

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 ] unit-test-fails
-[ [ drop ] compile-call ] unit-test-fails
-
-! Regression
-
-[ ] [ [ callstack ] compile-call drop ] unit-test
-
-! Regression
-
-: empty ;
-
-[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test

core/compiler/tests/intrinsics.factor

@@ -4,7 +4,7 @@ math.private sequences strings tools.test words continuations
 sequences.private hashtables.private byte-arrays strings.private
 system random layouts vectors.private sbufs.private
 strings.private slots.private alien alien.accessors
-alien.c-types alien.syntax namespaces libc combinators.private ;
+alien.c-types alien.syntax namespaces libc sequences.private ;
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test
@@ -422,11 +422,11 @@ cell 8 = [
 
 [
     B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
-] unit-test-fails
+] must-fail
 
 [
     B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
-] unit-test-fails
+] must-fail
 
 [
     4 5

core/compiler/tests/simple.factor

@@ -0,0 +1,229 @@
+USING: compiler tools.test kernel kernel.private
+sequences.private math.private math combinators strings
+alien arrays memory ;
+IN: temporary
+
+! Test empty word
+[ ] [ [ ] compile-call ] unit-test
+
+! Test literals
+[ 1 ] [ [ 1 ] compile-call ] unit-test
+[ 31 ] [ [ 31 ] compile-call ] unit-test
+[ 255 ] [ [ 255 ] compile-call ] unit-test
+[ -1 ] [ [ -1 ] compile-call ] unit-test
+[ 65536 ] [ [ 65536 ] compile-call ] unit-test
+[ -65536 ] [ [ -65536 ] compile-call ] unit-test
+[ "hey" ] [ [ "hey" ] compile-call ] unit-test
+
+! Calls
+: no-op ;
+
+[ ] [ [ no-op ] compile-call ] unit-test
+[ 3 ] [ [ no-op 3 ] compile-call ] unit-test
+[ 3 ] [ [ 3 no-op ] compile-call ] unit-test
+
+: bar 4 ;
+
+[ 4 ] [ [ bar no-op ] compile-call ] unit-test
+[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
+[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
+
+[ ] [ no-op ] unit-test
+
+! Conditionals
+
+[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
+[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
+
+[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
+[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
+
+[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
+[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
+
+[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
+[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
+[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
+[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
+
+[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
+
+! Labels
+
+: recursive ( ? -- ) [ f recursive ] when ; inline
+
+[ ] [ t [ recursive ] compile-call ] unit-test
+
+[ ] [ t recursive ] unit-test
+
+! Make sure error reporting works
+
+[ [ dup ] compile-call ] must-fail
+[ [ drop ] compile-call ] must-fail
+
+! Regression
+
+[ ] [ [ callstack ] compile-call drop ] unit-test
+
+! Regression
+
+: empty ;
+
+[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
+
+: dummy-if-1 t [ ] [ ] if ;
+
+[ ] [ dummy-if-1 ] unit-test
+
+: dummy-if-2 f [ ] [ ] if ;
+
+[ ] [ dummy-if-2 ] unit-test
+
+: dummy-if-3 t [ 1 ] [ 2 ] if ;
+
+[ 1 ] [ dummy-if-3 ] unit-test
+
+: dummy-if-4 f [ 1 ] [ 2 ] if ;
+
+[ 2 ] [ dummy-if-4 ] unit-test
+
+: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
+
+[ 1 ] [ dummy-if-5 ] unit-test
+
+: dummy-if-6
+    dup 1 fixnum<= [
+        drop 1
+    ] [
+        1 fixnum- dup 1 fixnum- fixnum+
+    ] if ;
+
+[ 17 ] [ 10 dummy-if-6 ] unit-test
+
+: dead-code-rec
+    t [
+        3.2
+    ] [
+        dead-code-rec
+    ] if ;
+
+[ 3.2 ] [ dead-code-rec ] unit-test
+
+: one-rec [ f one-rec ] [ "hi" ] if ;
+
+[ "hi" ] [ t one-rec ] unit-test
+
+: after-if-test
+    t [ ] [ ] if 5 ;
+
+[ 5 ] [ after-if-test ] unit-test
+
+DEFER: countdown-b
+
+: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ;
+: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ;
+
+[ ] [ 10 countdown-b ] unit-test
+
+: dummy-when-1 t [ ] when ;
+
+[ ] [ dummy-when-1 ] unit-test
+
+: dummy-when-2 f [ ] when ;
+
+[ ] [ dummy-when-2 ] unit-test
+
+: dummy-when-3 dup [ dup fixnum* ] when ;
+
+[ 16 ] [ 4 dummy-when-3 ] unit-test
+[ f ] [ f dummy-when-3 ] unit-test
+
+: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
+
+[ 64 f ] [ f 4 dummy-when-4 ] unit-test
+[ f t ] [ t f dummy-when-4 ] unit-test
+
+: dummy-when-5 f [ dup fixnum* ] when ;
+
+[ f ] [ f dummy-when-5 ] unit-test
+
+: dummy-unless-1 t [ ] unless ;
+
+[ ] [ dummy-unless-1 ] unit-test
+
+: dummy-unless-2 f [ ] unless ;
+
+[ ] [ dummy-unless-2 ] unit-test
+
+: dummy-unless-3 dup [ drop 3 ] unless ;
+
+[ 3 ] [ f dummy-unless-3 ] unit-test
+[ 4 ] [ 4 dummy-unless-3 ] unit-test
+
+! Test cond expansion
+[ "even" ] [
+    [
+        2 {
+            { [ dup 2 mod 0 = ] [ drop "even" ] }
+            { [ dup 2 mod 1 = ] [ drop "odd" ] }
+        } cond
+    ] compile-call
+] unit-test
+
+[ "odd" ] [
+    [
+        3 {
+            { [ dup 2 mod 0 = ] [ drop "even" ] }
+            { [ dup 2 mod 1 = ] [ drop "odd" ] }
+        } cond
+    ] compile-call
+] unit-test
+
+[ "neither" ] [
+    [
+        3 {
+            { [ dup string? ] [ drop "string" ] }
+            { [ dup float? ] [ drop "float" ] }
+            { [ dup alien? ] [ drop "alien" ] }
+            { [ t ] [ drop "neither" ] }
+        } cond
+    ] compile-call
+] unit-test
+
+[ 3 ] [
+    [
+        3 {
+            { [ dup fixnum? ] [ ] }
+            { [ t ] [ drop t ] }
+        } cond
+    ] compile-call
+] unit-test
+
+GENERIC: single-combination-test
+
+M: object single-combination-test drop ;
+M: f single-combination-test nip ;
+M: array single-combination-test drop ;
+M: integer single-combination-test drop ;
+
+[ 2 3 ] [ 2 3 t single-combination-test ] unit-test
+[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
+[ 2 f ] [ 2 3 f single-combination-test ] unit-test
+
+DEFER: single-combination-test-2
+
+: single-combination-test-4
+    dup [ single-combination-test-2 ] when ;
+
+: single-combination-test-3
+    drop 3 ;
+
+GENERIC: single-combination-test-2
+M: object single-combination-test-2 single-combination-test-3 ;
+M: f single-combination-test-2 single-combination-test-4 ;
+
+[ 3 ] [ t single-combination-test-2 ] unit-test
+[ 3 ] [ 3 single-combination-test-2 ] unit-test
+[ f ] [ f single-combination-test-2 ] unit-test

core/compiler/tests/stack-trace.factor

@@ -10,7 +10,7 @@ words splitting ;
 : foo 3 throw 7 ;
 : bar foo 4 ;
 : baz bar 5 ;
-[ 3 ] [ [ baz ] catch ] unit-test
+[ baz ] [ 3 = ] must-fail-with
 [ t ] [
     symbolic-stack-trace
     [ word? ] subset
@@ -22,11 +22,11 @@ words splitting ;
 : stack-trace-contains? symbolic-stack-trace memq? ;
 
 [ t ] [
-    [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains?
+    [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
 ] unit-test
     
 [ t f ] [
-    [ { "hi" } bleh ] catch drop
+    [ { "hi" } bleh ] ignore-errors
     \ + stack-trace-contains?
     \ > stack-trace-contains?
 ] unit-test
@@ -34,6 +34,6 @@ words splitting ;
 : quux [ t [ "hi" throw ] when ] times ;
 
 [ t ] [
-    [ 10 quux ] catch drop
+    [ 10 quux ] ignore-errors
     \ (each-integer) stack-trace-contains?
 ] unit-test

core/compiler/tests/templates.factor

@@ -2,7 +2,7 @@
 USING: arrays compiler kernel kernel.private math
 hashtables.private math.private namespaces sequences
 sequences.private tools.test namespaces.private slots.private
-combinators.private byte-arrays alien alien.accessors layouts
+sequences.private byte-arrays alien alien.accessors layouts
 words definitions compiler.units ;
 IN: temporary
 

core/compiler/units/units-docs.factor

@@ -28,9 +28,7 @@ HELP: redefine-error
 
 HELP: remember-definition
 { $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } }
-{ $description "Saves the location of a definition and associates this definition with the current source file."
+{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
-$nl
-"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ;
 
 HELP: old-definitions
 { $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ;
@@ -38,11 +36,6 @@ HELP: old-definitions
 HELP: new-definitions
 { $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ;
 
-HELP: forward-error
-{ $values { "word" word } }
-{ $description "Throws a " { $link forward-error } "." }
-{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ;
-
 HELP: with-compilation-unit
 { $values { "quot" quotation } }
 { $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." }

core/compiler/units/units.factor

@@ -26,11 +26,6 @@ TUPLE: redefine-error def ;
     over new-definitions get first key? [ dup redefine-error ] when
     new-definitions get second (remember-definition) ;
 
-TUPLE: forward-error word ;
-
-: forward-error ( word -- )
-    \ forward-error construct-boa throw ;
-
 : forward-reference? ( word -- ? )
     dup old-definitions get assoc-stack
     [ new-definitions get assoc-stack not ]

core/continuations/continuations-docs.factor

@@ -23,10 +23,9 @@ $nl
 "Two words raise an error in the innermost error handler for the current dynamic extent:"
 { $subsection throw }
 { $subsection rethrow }
-"A set of words establish an error handler:"
+"Two words for establishing an error handler:"
 { $subsection cleanup }
 { $subsection recover }
-{ $subsection catch }
 "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
 { $subsection "errors-restartable" }
 { $subsection "errors-post-mortem" } ;
@@ -147,12 +146,7 @@ HELP: throw
 { $values { "error" object } }
 { $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
 
-HELP: catch
+{ cleanup recover } related-words
-{ $values { "try" quotation } { "error/f" object } }
-{ $description "Calls the " { $snippet "try" } " quotation. If an error is thrown in the dynamic extent of the quotation, restores the data stack and pushes the error. If the quotation returns successfully, outputs " { $link f } " without restoring the data stack." }
-{ $notes "This word cannot differentiate between the case of " { $link f } " being thrown, and no error being thrown. You should never throw " { $link f } ", and you should also use other error handling combinators where possible." } ;
-
-{ catch cleanup recover } related-words
 
 HELP: cleanup
 { $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
@@ -166,7 +160,7 @@ HELP: rethrow
 { $values { "error" object } }
 { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
 { $notes
-    "This word is intended to be used in conjunction with " { $link recover } " or " { $link catch } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
+    "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
 }
 { $examples
     "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:"
@@ -175,7 +169,7 @@ HELP: rethrow
 
 HELP: throw-restarts
 { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
-{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." }
+{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
 { $examples
     "Try invoking one of the two restarts which are offered after the below code throws an error:"
     { $code

core/continuations/continuations-tests.factor

@@ -25,13 +25,11 @@ IN: temporary
 [ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test
 [ t ] [ callcc-namespace-test ] unit-test
 
-[ f ] [ [ ] catch ] unit-test
+[ 5 throw ] [ 5 = ] must-fail-with
-
-[ 5 ] [ [ 5 throw ] catch ] unit-test
 
 [ t ] [
-    [ "Hello" throw ] catch drop
+    [ "Hello" throw ] ignore-errors
-    global [ error get ] bind
+    error get-global
     "Hello" =
 ] unit-test
 
@@ -41,13 +39,13 @@ IN: temporary
 
 "!!! The following error is part of the test" print
 
-[ [ "2 car" ] eval ] catch print-error
+[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test
 
-[ f throw ] unit-test-fails
+[ f throw ] must-fail
 
 ! Weird PowerPC bug.
 [ ] [
-    [ "4" throw ] catch drop
+    [ "4" throw ] ignore-errors
     data-gc
     data-gc
 ] unit-test
@@ -56,10 +54,10 @@ IN: temporary
 [ f ] [ { "A" "B" } kernel-error? ] unit-test
 
 ! ! See how well callstack overflow is handled
-! [ clear drop ] unit-test-fails
+! [ clear drop ] must-fail
 ! 
 ! : callstack-overflow callstack-overflow f ;
-! [ callstack-overflow ] unit-test-fails
+! [ callstack-overflow ] must-fail
 
 : don't-compile-me { } [ ] each ;
 
@@ -84,24 +82,20 @@ SYMBOL: error-counter
     [ 1 ] [ always-counter get ] unit-test
     [ 0 ] [ error-counter get ] unit-test
 
-    [ "a" ] [
+    [
-        [
+        [ "a" throw ]
-            [ "a" throw ]
+        [ always-counter inc ]
-            [ always-counter inc ]
+        [ error-counter inc ] cleanup
-            [ error-counter inc ] cleanup
+    ] [ "a" = ] must-fail-with
-        ] catch
-    ] unit-test
 
     [ 2 ] [ always-counter get ] unit-test
     [ 1 ] [ error-counter get ] unit-test
 
-    [ "a" ] [
+    [
-        [
+        [ ]
-            [ ]
+        [ always-counter inc "a" throw ]
-            [ always-counter inc "a" throw ]
+        [ error-counter inc ] cleanup
-            [ error-counter inc ] cleanup
+    ] [ "a" = ] must-fail-with
-        ] catch
-    ] unit-test
 
     [ 3 ] [ always-counter get ] unit-test
     [ 1 ] [ error-counter get ] unit-test

core/continuations/continuations.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays vectors kernel kernel.private sequences
 namespaces math splitting sorting quotations assocs ;
@@ -17,9 +17,6 @@ SYMBOL: restarts
 
 : c> ( -- continuation ) catchstack* pop ;
 
-: (catch) ( quot -- newquot )
-    [ swap >c call c> drop ] curry ; inline
-
 : dummy ( -- obj )
     #! Optimizing compiler assumes stack won't be messed with
     #! in-transit. To ensure that a value is actually reified
@@ -101,7 +98,7 @@ PRIVATE>
 : continue-with ( obj continuation -- )
     [
         walker-hook [ >r 2array r> ] when* (continue-with)
-    ] 2curry (throw) ;
+    ] 2 (throw) ;
 
 : continue ( continuation -- )
     f swap continue-with ;
@@ -120,11 +117,8 @@ PRIVATE>
     catchstack* empty? [ die ] when
     dup save-error c> continue-with ;
 
-: catch ( try -- error/f )
-    (catch) [ f ] compose callcc1 ; inline
-
 : recover ( try recovery -- )
-    >r (catch) r> ifcc ; inline
+    >r [ swap >c call c> drop ] curry r> ifcc ; inline
 
 : cleanup ( try cleanup-always cleanup-error -- )
     over >r compose [ dip rethrow ] curry

core/cpu/architecture/architecture.factor

@@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- )
 ! Test if vreg is 'f' or not
 HOOK: %jump-t compiler-backend ( label -- )
 
-HOOK: %call-dispatch compiler-backend ( -- label )
+HOOK: %dispatch compiler-backend ( -- )
-
-HOOK: %jump-dispatch compiler-backend ( -- )
 
 HOOK: %dispatch-label compiler-backend ( word -- )
 

core/cpu/ppc/architecture/architecture.factor

@@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ;
 M: ppc-backend %jump-t ( label -- )
     0 "flag" operand f v>operand CMPI BNE ;
 
-: (%dispatch) ( len -- )
+M: ppc-backend %dispatch ( -- )
-    0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
+    [
-    "offset" operand "n" operand 1 SRAWI
+        %epilogue-later
-    11 11 "offset" operand ADD
+        0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
-    11 dup rot cells LWZ ;
+        "offset" operand "n" operand 1 SRAWI
-
+        11 11 "offset" operand ADD
-M: ppc-backend %call-dispatch ( word-table# -- )
+        11 dup 6 cells LWZ
-    [ 7 (%dispatch) (%call) <label> dup B ] H{
+        (%jump)
-        { +input+ { { f "n" } } }
+    ] H{
-        { +scratch+ { { f "offset" } } }
-    } with-template ;
-
-M: ppc-backend %jump-dispatch ( -- )
-    [ %epilogue-later 6 (%dispatch) (%jump) ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "offset" } } }
     } with-template ;

core/cpu/ppc/ppc.factor

@@ -13,3 +13,7 @@ namespaces alien.c-types kernel system combinators ;
 } cond
 
 T{ ppc-backend } compiler-backend set-global
+
+macosx? [
+    4 "double" c-type set-c-type-align
+] when

core/cpu/x86/32/32.factor

@@ -261,6 +261,10 @@ windows? [
     cell "ulonglong" c-type set-c-type-align
 ] unless
 
+windows? [
+    4 "double" c-type set-c-type-align
+] unless
+
 T{ x86-backend f 4 } compiler-backend set-global
 
 : sse2? "Intrinsic" throw ;

core/cpu/x86/64/64.factor

@@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
 cpu.x86.allot cpu.architecture kernel kernel.private math
 namespaces sequences generator.registers generator.fixup system
-alien alien.compiler alien.structs slots splitting assocs ;
+alien alien.accessors alien.compiler alien.structs slots
+splitting assocs ;
 IN: cpu.x86.64
 
 PREDICATE: x86-backend amd64-backend

core/cpu/x86/architecture/architecture.factor

@@ -77,26 +77,29 @@ M: x86-backend %jump-label ( label -- ) JMP ;
 M: x86-backend %jump-t ( label -- )
     "flag" operand f v>operand CMP JNE ;
 
-: (%dispatch) ( n -- operand )
+: code-alignment ( -- n )
-    ! Load jump table base. We use a temporary register
+    building get length dup cell align swap - ;
-    ! since on AMD64 we have to load a 64-bit immediate. On
-    ! x86, this is redundant.
-    ! Untag and multiply to get a jump table offset
-    "n" operand fixnum>slot@
-    ! Add jump table base
-    "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
-    "n" operand "offset" operand ADD
-    "n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
 
-M: x86-backend %call-dispatch ( word-table# -- )
+: align-code ( n -- )
-    [ 5 (%dispatch) CALL <label> dup JMP ] H{
+    0 <repetition> % ;
-        { +input+ { { f "n" } } }
-        { +scratch+ { { f "offset" } } }
-        { +clobber+ { "n" } }
-    } with-template ;
 
-M: x86-backend %jump-dispatch ( -- )
+M: x86-backend %dispatch ( -- )
-    [ %epilogue-later 0 (%dispatch) JMP ] H{
+    [
+        %epilogue-later
+        ! Load jump table base. We use a temporary register
+        ! since on AMD64 we have to load a 64-bit immediate. On
+        ! x86, this is redundant.
+        ! Untag and multiply to get a jump table offset
+        "n" operand fixnum>slot@
+        ! Add jump table base
+        "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
+        "n" operand "offset" operand ADD
+        "n" operand HEX: 7f [+] JMP
+        ! Fix up the displacement above
+        code-alignment dup bootstrap-cell 8 = 15 9 ? +
+        building get dup pop* push
+        align-code
+    ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "offset" } } }
         { +clobber+ { "n" } }

core/debugger/debugger.factor

@@ -87,7 +87,32 @@ TUPLE: assert got expect ;
 
 : depth ( -- n ) datastack length ;
 
-: assert-depth ( quot -- ) depth slip depth swap assert= ;
+: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
+    2dup [ length ] 2apply min tuck tail >r tail r> ;
+
+TUPLE: relative-underflow stack ;
+
+: relative-underflow ( before after -- * )
+    trim-datastacks nip \ relative-underflow construct-boa throw ;
+
+M: relative-underflow summary
+    drop "Too many items removed from data stack" ;
+
+TUPLE: relative-overflow stack ;
+
+M: relative-overflow summary
+    drop "Superfluous items pushed to data stack" ;
+
+: relative-overflow ( before after -- * )
+    trim-datastacks drop \ relative-overflow construct-boa throw ;
+
+: assert-depth ( quot -- )
+    >r datastack r> swap slip >r datastack r>
+    2dup [ length ] compare sgn {
+        { -1 [ relative-underflow ] }
+        { 0 [ 2drop ] }
+        { 1 [ relative-overflow ] }
+    } case ; inline
 
 : expired-error. ( obj -- )
     "Object did not survive image save/load: " write third . ;
@@ -222,9 +247,6 @@ M: redefine-error error.
     "Re-definition of " write
     redefine-error-def . ;
 
-M: forward-error error.
-    "Forward reference to " write forward-error-word . ;
-
 M: undefined summary
     drop "Calling a deferred word before it has been defined" ;
 

core/definitions/definitions-docs.factor

@@ -52,9 +52,7 @@ $nl
 $nl
 "If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image."
 $nl
-"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used."
+"Since this is undesirable, the parser explicitly raises a " { $link no-word } " error if a source file refers to a word which is in the dictionary, but defined after it is used."
-{ $subsection forward-error }
-"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image."
 $nl
 "The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case."
 { $subsection redefine-error } ;

core/definitions/definitions-tests.factor

@@ -6,12 +6,14 @@ TUPLE: combination-1 ;
 
 M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
 
+M: combination-1 make-default-method 2drop [ "No method" throw ] ;
+
 SYMBOL: generic-1
 
 [
     generic-1 T{ combination-1 } define-generic
 
-    [ ] <method> object \ generic-1 define-method
+    [ ] object \ generic-1 define-method
 ] with-compilation-unit
 
 [ ] [
@@ -20,7 +22,7 @@ SYMBOL: generic-1
     ] with-compilation-unit
 ] unit-test
 
-GENERIC: some-generic
+GENERIC: some-generic ( a -- b )
 
 USE: arrays
 

core/dlists/dlists.factor

@@ -144,6 +144,11 @@ PRIVATE>
 : dlist-delete ( obj dlist -- obj/f )
     >r [ eq? ] curry r> delete-node-if ;
 
+: dlist-delete-all ( dlist -- )
+    f over set-dlist-front
+    f over set-dlist-back
+    0 swap set-dlist-length ;
+
 : dlist-each ( dlist quot -- )
     [ dlist-node-obj ] swap compose dlist-each-node ; inline
 

core/effects/effects.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces sequences strings words assocs
 combinators ;
@@ -41,13 +41,13 @@ M: integer (stack-picture) drop "object" ;
         ")" %
     ] "" make ;
 
-: stack-effect ( word -- effect/f )
+GENERIC: stack-effect ( word -- effect/f )
-    dup symbol? [
+
-        drop 0 1 <effect>
+M: symbol stack-effect drop 0 1 <effect> ;
-    ] [
+
-        { "declared-effect" "inferred-effect" }
+M: word stack-effect
-        swap word-props [ at ] curry map [ ] find nip
+    { "declared-effect" "inferred-effect" }
-    ] if ;
+    swap word-props [ at ] curry map [ ] find nip ;
 
 M: effect clone
     [ effect-in clone ] keep effect-out clone <effect> ;

core/float-arrays/float-arrays-docs.factor

@@ -32,7 +32,7 @@ HELP: <float-array> ( n initial -- float-array )
 
 HELP: >float-array
 { $values { "seq" "a sequence" } { "float-array" float-array } }
-{ $description "Outputs a freshly-allocated float array whose elements have the same boolean values as a given sequence." }
+{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." }
 { $errors "Throws an error if the sequence contains elements other than real numbers." } ;
 
 HELP: 1float-array

core/float-arrays/float-arrays-tests.factor

@@ -7,4 +7,4 @@ USING: float-arrays tools.test ;
 
 [ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
 
-[ -10 F{ } resize-float-array ] unit-test-fails
+[ -10 F{ } resize-float-array ] must-fail

core/generator/generator.factor

@@ -3,8 +3,9 @@
 USING: arrays assocs classes combinators cpu.architecture
 effects generator.fixup generator.registers generic hashtables
 inference inference.backend inference.dataflow io kernel
-kernel.private layouts math namespaces optimizer prettyprint
+kernel.private layouts math namespaces optimizer
-quotations sequences system threads words vectors ;
+optimizer.specializers prettyprint quotations sequences system
+threads words vectors ;
 IN: generator
 
 SYMBOL: compile-queue
@@ -55,13 +56,16 @@ GENERIC: generate-node ( node -- next )
 : generate-nodes ( node -- )
     [ node@ generate-node ] iterate-nodes end-basic-block ;
 
+: init-generate-nodes ( -- )
+    init-templates
+    %save-word-xt
+    %prologue-later
+    current-label-start define-label
+    current-label-start resolve-label ;
+    
 : generate ( word label node -- )
     [
-        init-templates
+        init-generate-nodes
-        %save-word-xt
-        %prologue-later
-        current-label-start define-label
-        current-label-start resolve-label
         [ generate-nodes ] with-node-iterator
     ] generate-1 ;
 
@@ -154,22 +158,36 @@ M: #if generate-node
         ] generate-1
     ] keep ;
 
+: tail-dispatch? ( node -- ? )
+    #! Is the dispatch a jump to a tail call to a word?
+    dup #call? swap node-successor #return? and ;
+
 : dispatch-branches ( node -- )
     node-children [
-        compiling-word get dispatch-branch %dispatch-label
+        dup tail-dispatch? [
+            node-param
+        ] [
+            compiling-word get dispatch-branch
+        ] if %dispatch-label
     ] each ;
 
+: generate-dispatch ( node -- )
+    %dispatch dispatch-branches init-templates ;
+
 M: #dispatch generate-node
     #! The order here is important, dispatch-branches must
     #! run after %dispatch, so that each branch gets the
     #! correct register state
     tail-call? [
-        %jump-dispatch dispatch-branches
+        generate-dispatch iterate-next
     ] [
-        0 frame-required
+        compiling-word get gensym [
-        %call-dispatch >r dispatch-branches r> resolve-label
+            rot [
-    ] if
+                init-generate-nodes
-    init-templates iterate-next ;
+                generate-dispatch
+            ] generate-1
+        ] keep generate-call
+    ] if ;
 
 ! #call
 : define-intrinsics ( word intrinsics -- )

core/generic/generic-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax generic.math generic.standard
 words classes definitions kernel alien combinators sequences 
-math ;
+math quotations ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
@@ -107,10 +107,6 @@ HELP: make-generic
 { $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
 $low-level-note ;
 
-HELP: init-methods
-{ $values { "word" word } }
-{ $description "Prepare to define a generic word." } ;
-
 HELP: define-generic
 { $values { "word" word } { "combination" "a method combination" } }
 { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
@@ -125,16 +121,12 @@ HELP: method
 { $description "Looks up a method definition." }
 { $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
 
-{ method method-def method-loc define-method POSTPONE: M: } related-words
+{ method define-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "def" "a quotation" } { "method" "a new method definition" } }
 { $description "Creates a new  "{ $link method } " instance." } ;
 
-HELP: sort-methods
-{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
 HELP: methods
 { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
 { $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
@@ -154,7 +146,7 @@ HELP: with-methods
 $low-level-note ;
 
 HELP: define-method
-{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } }
+{ $values { "method" quotation } { "class" class } { "generic" generic } }
 { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
 
 HELP: implementors

core/generic/generic-tests.factor

@@ -16,7 +16,7 @@ M: word   class-of drop "word"   ;
 
 [ "fixnum" ] [ 5 class-of ] unit-test
 [ "word" ] [ \ class-of class-of ] unit-test
-[ 3.4 class-of ] unit-test-fails
+[ 3.4 class-of ] must-fail
 
 [ "Hello world" ] [ 4 foobar foobar ] unit-test
 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
@@ -90,7 +90,7 @@ M: number union-containment drop 2 ;
 "IN: temporary GENERIC: unhappy ( x -- x )" eval
 [
     "IN: temporary M: dictionary unhappy ;" eval
-] unit-test-fails
+] must-fail
 [ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
 
 GENERIC# complex-combination 1 ( a b -- c )
@@ -155,9 +155,7 @@ M: string my-hook "a string" ;
 
 [ "an integer" ] [ 3 my-var set my-hook ] unit-test
 [ "a string" ] [ my-hook my-var set my-hook ] unit-test
-[ T{ no-method f 1.0 my-hook } ] [
+[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
-    1.0 my-var set [ my-hook ] catch
-] unit-test
 
 GENERIC: tag-and-f ( x -- x x )
 
@@ -176,6 +174,9 @@ M: f tag-and-f 4 ;
 ! define-class hashing issue
 TUPLE: debug-combination ;
 
+M: debug-combination make-default-method
+    2drop [ "Oops" throw ] ;
+
 M: debug-combination perform-combination
     drop
     order [ dup class-hashes ] { } map>assoc sort-keys
@@ -200,3 +201,40 @@ TUPLE: redefinition-test-tuple ;
         redefinition-test-generic ,
     ] { } make all-equal?
 ] unit-test
+
+! Issues with forget
+GENERIC: generic-forget-test-1
+
+M: integer generic-forget-test-1 / ;
+
+[ t ] [
+    \ / usage [ word? ] subset
+    [ word-name "generic-forget-test-1/integer" = ] contains?
+] unit-test
+
+[ ] [
+    [ \ generic-forget-test-1 forget ] with-compilation-unit
+] unit-test
+
+[ f ] [
+    \ / usage [ word? ] subset
+    [ word-name "generic-forget-test-1/integer" = ] contains?
+] unit-test
+
+GENERIC: generic-forget-test-2
+
+M: sequence generic-forget-test-2 = ;
+
+[ t ] [
+    \ = usage [ word? ] subset
+    [ word-name "generic-forget-test-2/sequence" = ] contains?
+] unit-test
+
+[ ] [
+    [ { sequence generic-forget-test-2 } forget ] with-compilation-unit
+] unit-test
+
+[ f ] [
+    \ = usage [ word? ] subset
+    [ word-name "generic-forget-test-2/sequence" = ] contains?
+] unit-test

core/generic/generic.factor

@@ -1,16 +1,11 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words kernel sequences namespaces assocs hashtables
 definitions kernel.private classes classes.private
-quotations arrays vocabs ;
+quotations arrays vocabs effects ;
 IN: generic
 
-PREDICATE: word generic "combination" word-prop >boolean ;
+! Method combination protocol
-
-M: generic definer drop f f ;
-
-M: generic definition drop f ;
-
 GENERIC: perform-combination ( word combination -- quot )
 
 M: object perform-combination
@@ -22,27 +17,22 @@ M: object perform-combination
     #! the method will throw an error. We don't want that.
     nip [ "Invalid method combination" throw ] curry [ ] like ;
 
+GENERIC: method-prologue ( class combination -- quot )
+
+M: object method-prologue 2drop [ ] ;
+
+GENERIC: make-default-method ( generic combination -- method )
+
+PREDICATE: word generic "combination" word-prop >boolean ;
+
+M: generic definer drop f f ;
+
+M: generic definition drop f ;
+
 : make-generic ( word -- )
     dup dup "combination" word-prop perform-combination define ;
 
-: init-methods ( word -- )
+TUPLE: method word def specializer generic loc ;
-     dup "methods" word-prop
-     H{ } assoc-like
-     "methods" set-word-prop ;
-
-: define-generic ( word combination -- )
-    dupd "combination" set-word-prop
-    dup init-methods make-generic ;
-
-TUPLE: method loc def ;
-
-: <method> ( def -- method )
-    { set-method-def } \ method construct ;
-
-M: f method-def ;
-M: f method-loc ;
-M: quotation method-def ;
-M: quotation method-loc drop f ;
 
 : method ( class generic -- method/f )
     "methods" word-prop at ;
@@ -53,12 +43,10 @@ PREDICATE: pair method-spec
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
-: sort-methods ( assoc -- newassoc )
-    [ keys sort-classes ] keep
-    [ dupd at method-def 2array ] curry map ;
-
 : methods ( word -- assoc )
-    "methods" word-prop sort-methods ;
+    "methods" word-prop
+    [ keys sort-classes ] keep
+    [ dupd at method-word ] curry { } map>assoc ;
 
 TUPLE: check-method class generic ;
 
@@ -71,22 +59,52 @@ TUPLE: check-method class generic ;
     swap [ "methods" word-prop swap call ] keep make-generic ;
     inline
 
-: define-method ( method class generic -- )
+: method-word-name ( class word -- string )
-    >r bootstrap-word r> check-method
+    word-name "/" rot word-name 3append ;
+
+: make-method-def ( quot word combination -- quot )
+    "combination" word-prop method-prologue swap append ;
+
+PREDICATE: word method-body "method" word-prop >boolean ;
+
+M: method-body stack-effect
+    "method" word-prop method-generic stack-effect ;
+
+: <method-word> ( quot class generic -- word )
+    [ make-method-def ] 2keep
+    method-word-name f <word>
+    dup rot define
+    dup xref ;
+
+: <method> ( quot class generic -- method )
+    check-method
+    [ <method-word> ] 3keep f \ method construct-boa
+    dup method-word over "method" set-word-prop ;
+
+: define-method ( quot class generic -- )
+    >r bootstrap-word r>
+    [ <method> ] 2keep
     [ set-at ] with-methods ;
 
+: define-default-method ( generic combination -- )
+    dupd make-default-method object bootstrap-word pick <method>
+    "default-method" set-word-prop ;
+
 ! Definition protocol
 M: method-spec where
-    dup first2 method method-loc [ ] [ second where ] ?if ;
+    dup first2 method [ method-loc ] [ second where ] ?if ;
 
 M: method-spec set-where first2 method set-method-loc ;
 
 M: method-spec definer drop \ M: \ ; ;
 
-M: method-spec definition first2 method method-def ;
+M: method-spec definition
+    first2 method dup [ method-def ] when ;
 
 : forget-method ( class generic -- )
-    check-method [ delete-at ] with-methods ;
+    check-method
+    [ delete-at* ] with-methods
+    [ method-word forget ] [ drop ] if ;
 
 M: method-spec forget* first2 forget-method ;
 
@@ -109,3 +127,28 @@ M: class forget* ( class -- )
 
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;
+
+: define-generic ( word combination -- )
+    over "combination" word-prop over = [
+        2drop
+    ] [
+        2dup "combination" set-word-prop
+        over H{ } clone "methods" set-word-prop
+        dupd define-default-method
+        make-generic
+    ] if ;
+
+GENERIC: subwords ( word -- seq )
+
+M: word subwords drop f ;
+
+M: generic subwords
+    dup "methods" word-prop values
+    swap "default-method" word-prop add
+    [ method-word ] map ;
+
+M: generic forget-word
+    dup subwords [ forget-word ] each (forget-word) ;
+
+: xref-generics ( -- )
+    all-words [ subwords [ xref ] each ] each ;

core/generic/math/math.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic hashtables kernel kernel.private
 math namespaces sequences words quotations layouts combinators
-combinators.private classes definitions ;
+sequences.private classes definitions ;
 IN: generic.math
 
 PREDICATE: class math-class ( object -- ? )
@@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ;
 : no-math-method ( left right generic -- * )
     \ no-math-method construct-boa throw ;
 
+: default-math-method ( generic -- quot )
+    [ no-math-method ] curry [ ] like ;
+
 : applicable-method ( generic class -- quot )
-    over method method-def
+    over method
-    [ ] [ [ no-math-method ] curry [ ] like ] ?if ;
+    [ method-word word-def ]
+    [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )
     object bootstrap-word applicable-method ;
@@ -57,7 +61,7 @@ TUPLE: no-math-method left right generic ;
 : math-vtable* ( picker max quot -- quot )
     [
         rot , \ tag ,
-        [ >r [ type>class ] map r> map % ] { } make ,
+        [ >r [ bootstrap-type>class ] map r> map % ] { } make ,
         \ dispatch ,
     ] [ ] make ; inline
 
@@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ;
 
 TUPLE: math-combination ;
 
+M: math-combination make-default-method
+    drop default-math-method ;
+
 M: math-combination perform-combination
     drop
     \ over [

core/generic/standard/standard.factor

@@ -2,12 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel kernel.private slots.private math
 namespaces sequences vectors words quotations definitions
-hashtables layouts combinators combinators.private generic
+hashtables layouts combinators sequences.private generic
 classes classes.private ;
 IN: generic.standard
 
 TUPLE: standard-combination # ;
 
+M: standard-combination method-prologue
+    standard-combination-# object
+    <array> swap add* [ declare ] curry ;
+
 C: <standard-combination> standard-combination
 
 SYMBOL: (dispatch#)
@@ -31,10 +35,10 @@ TUPLE: no-method object generic ;
 : no-method ( object generic -- * )
     \ no-method construct-boa throw ;
 
-: error-method ( word -- method )
+: error-method ( word --  quot )
     picker swap [ no-method ] curry append ;
 
-: empty-method ( word -- method )
+: empty-method ( word -- quot )
     [
         picker % [ delegate dup ] %
         unpicker over add ,
@@ -65,13 +69,15 @@ TUPLE: no-method object generic ;
     ] if ;
 
 : default-method ( word -- pair )
-    empty-method object bootstrap-word swap 2array ;
+    "default-method" word-prop method-word
+    object bootstrap-word swap 2array ;
 
 : method-alist>quot ( alist base-class -- quot )
     bootstrap-word swap simplify-alist
     class-predicates alist>quot ;
 
 : small-generic ( methods -- def )
+    [ 1quotation ] assoc-map
     object method-alist>quot ;
 
 : hash-methods ( methods -- buckets )
@@ -83,12 +89,15 @@ TUPLE: no-method object generic ;
         ] if
     ] distribute-buckets ;
 
+: class-hash-dispatch-quot ( methods quot picker -- quot )
+    >r >r hash-methods r> map
+    hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
+
 : big-generic ( methods -- quot )
-    hash-methods [ small-generic ] map
+    [ small-generic ] picker class-hash-dispatch-quot ;
-    hash-dispatch-quot picker [ class-hash ] rot 3append ;
 
 : vtable-class ( n -- class )
-    type>class [ hi-tag bootstrap-word ] unless* ;
+    bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
 
 : group-methods ( assoc -- vtable )
     #! Input is a predicate -> method association.
@@ -100,7 +109,8 @@ TUPLE: no-method object generic ;
 
 : build-type-vtable ( alist-seq -- alist-seq )
     dup length [
-        vtable-class swap simplify-alist
+        vtable-class
+        swap [ word-def ] assoc-map simplify-alist
         class-predicates alist>quot
     ] 2map ;
 
@@ -137,30 +147,35 @@ TUPLE: no-method object generic ;
 : standard-methods ( word -- alist )
     dup methods swap default-method add* ;
 
+M: standard-combination make-default-method
+    standard-combination-# (dispatch#)
+    [ empty-method ] with-variable ;
+
 M: standard-combination perform-combination
     standard-combination-# (dispatch#) [
         [ standard-methods ] keep "inline" word-prop
         [ small-generic ] [ single-combination ] if
     ] with-variable ;
 
-: default-hook-method ( word -- pair )
-    error-method object bootstrap-word swap 2array ;
-
-: hook-methods ( word -- methods )
-    dup methods [ [ drop ] swap append ] assoc-map
-    swap default-hook-method add* ;
-
 TUPLE: hook-combination var ;
 
 C: <hook-combination> hook-combination
 
-M: hook-combination perform-combination
+M: hook-combination method-prologue
+    2drop [ drop ] ;
+
+: with-hook ( combination quot -- quot' )
     0 (dispatch#) [
-        [
+        swap slip
-            hook-combination-var [ get ] curry %
+        hook-combination-var [ get ] curry
-            hook-methods single-combination %
+        swap append
-        ] [ ] make
+    ] with-variable ; inline
-    ] with-variable ;
+
+M: hook-combination make-default-method
+    [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+    [ standard-methods single-combination ] with-hook ;
 
 : define-simple-generic ( word -- )
     T{ standard-combination f 0 } define-generic ;

core/growable/growable-tests.factor

@@ -9,16 +9,16 @@ IN: temporary
 
 ! overflow bugs
 [ "hi" most-positive-fixnum 2 * 2 + V{ } clone set-nth ]
-unit-test-fails
+must-fail
 
 [ most-positive-fixnum 2 * 2 + { 1 } clone nth ]
-unit-test-fails
+must-fail
 
 [ most-positive-fixnum 2 * 2 + V{ } clone lengthen ]
-unit-test-fails
+must-fail
 
 [ most-positive-fixnum 2 * 2 + V{ } clone set-length ]
-unit-test-fails
+must-fail
 
 [ ] [
     10 V{ } [ set-length ] keep

core/hashtables/hashtables-tests.factor

@@ -127,9 +127,9 @@ H{ } "x" set
 ! Another crash discovered by erg
 [ ] [
     H{ } clone
-    [ 1 swap set-at ] catch drop
+    [ 1 swap set-at ] ignore-errors
-    [ 2 swap set-at ] catch drop
+    [ 2 swap set-at ] ignore-errors
-    [ 3 swap set-at ] catch drop
+    [ 3 swap set-at ] ignore-errors
     drop
 ] unit-test
 

core/heaps/heaps-tests.factor

@@ -5,8 +5,8 @@ USING: arrays kernel math namespaces tools.test
 heaps heaps.private ;
 IN: temporary
 
-[ <min-heap> heap-pop ] unit-test-fails
+[ <min-heap> heap-pop ] must-fail
-[ <max-heap> heap-pop ] unit-test-fails
+[ <max-heap> heap-pop ] must-fail
 
 [ t ] [ <min-heap> heap-empty? ] unit-test
 [ f ] [ <min-heap> 1 t pick heap-push heap-empty? ] unit-test

core/inference/backend/backend-docs.factor

@@ -1,6 +1,6 @@
 USING: help.syntax help.markup words effects inference.dataflow
 inference.state inference.backend kernel sequences
-kernel.private combinators combinators.private ;
+kernel.private combinators sequences.private ;
 
 HELP: literal-expected
 { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }

core/inference/backend/backend.factor

@@ -9,9 +9,13 @@ IN: inference.backend
 : recursive-label ( word -- label/f )
     recursive-state get at ;
 
+: inline? ( word -- ? )
+    dup "method" word-prop
+    [ method-generic inline? ] [ "inline" word-prop ] ?if ;
+
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys
-    [ dup word? [ "inline" word-prop ] when not ] find drop
+    [ dup word? [ inline? ] when not ] find drop
     [ head-slice ] when* ;
 
 : inline-recursive-label ( word -- label/f )
@@ -20,24 +24,24 @@ IN: inference.backend
 : recursive-quotation? ( quot -- ? )
     local-recursive-state [ first eq? ] with contains? ;
 
-TUPLE: inference-error rstate major? ;
+TUPLE: inference-error rstate type ;
 
-M: inference-error compiler-warning?
+M: inference-error compiler-error-type
-    inference-error-major? not ;
+    inference-error-type ;
 
-: (inference-error) ( ... class important? -- * )
+: (inference-error) ( ... class type -- * )
     >r construct-boa r>
     recursive-state get {
         set-delegate
-        set-inference-error-major?
+        set-inference-error-type
         set-inference-error-rstate
     } \ inference-error construct throw ; inline
 
 : inference-error ( ... class -- * )
-    t (inference-error) ; inline
+    +error+ (inference-error) ; inline
 
 : inference-warning ( ... class -- * )
-    f (inference-error) ; inline
+    +warning+ (inference-error) ; inline
 
 TUPLE: literal-expected ;
 
@@ -157,7 +161,7 @@ TUPLE: too-many-r> ;
     meta-d get push-all ;
 
 : if-inline ( word true false -- )
-    >r >r dup "inline" word-prop r> r> if ; inline
+    >r >r dup inline? r> r> if ; inline
 
 : consume/produce ( effect node -- )
     over effect-in over consume-values
@@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ;
     #merge node, ; inline
 
 : make-call-node ( word effect -- )
-    swap dup "inline" word-prop
+    swap dup inline?
     over dup recursive-label eq? not and [
         meta-d get clone -rot
         recursive-label #call-label [ consume/produce ] keep
@@ -366,6 +370,7 @@ TUPLE: effect-error word effect ;
             init-inference
             dependencies off
             dup word-def over dup infer-quot-recursive
+            end-infer
             finish-word
             current-effect
         ] with-scope

core/inference/class/class-tests.factor

@@ -263,3 +263,23 @@ 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 number } declare number= ]
+    \ number= inlined?
+] unit-test
+
+[ t ] [
+    [ B{ 1 0 } *short 0 = ]
+    \ number= inlined?
+] unit-test
+
+[ t ] [
+    [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
+    \ number= inlined?
+] unit-test

core/inference/class/class.factor

@@ -73,17 +73,27 @@ SYMBOL: value-intervals
 ! Current value --> class mapping
 SYMBOL: value-classes
 
+: value-interval* ( value -- interval/f )
+    value-intervals get at ;
+
 : set-value-interval* ( interval value -- )
     value-intervals get set-at ;
 
+: intersect-value-interval ( interval value -- )
+    [ value-interval* interval-intersect ] keep
+    set-value-interval* ;
+
 M: interval-constraint apply-constraint
     dup interval-constraint-interval
-    swap interval-constraint-value set-value-interval* ;
+    swap interval-constraint-value intersect-value-interval ;
 
 : set-class-interval ( class value -- )
     >r "interval" word-prop dup
     [ r> set-value-interval* ] [ r> 2drop ] if ;
 
+: value-class* ( value -- class )
+    value-classes get at object or ;
+
 : set-value-class* ( class value -- )
     over [
         dup value-intervals get at [
@@ -93,9 +103,12 @@ M: interval-constraint apply-constraint
     ] when
     value-classes get set-at ;
 
+: intersect-value-class ( class value -- )
+    [ value-class* class-and ] keep set-value-class* ;
+
 M: class-constraint apply-constraint
     dup class-constraint-class
-    swap class-constraint-value set-value-class* ;
+    swap class-constraint-value intersect-value-class ;
 
 : set-value-literal* ( literal value -- )
     over class over set-value-class*
@@ -127,16 +140,10 @@ M: literal-constraint constraint-satisfied?
     dup literal-constraint-value value-literal*
     [ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
 
-: value-class* ( value -- class )
-    value-classes get at object or ;
-
 M: class-constraint constraint-satisfied?
     dup class-constraint-value value-class*
     swap class-constraint-class class< ;
 
-: value-interval* ( value -- interval/f )
-    value-intervals get at ;
-
 M: pair apply-constraint
     first2 2dup constraints get set-at
     constraint-satisfied? [ apply-constraint ] [ drop ] if ;
@@ -159,13 +166,10 @@ M: pair constraint-satisfied?
     2drop ;
 
 : intersect-classes ( classes values -- )
-    [ [ value-class* class-and ] keep set-value-class* ] 2each ;
+    [ intersect-value-class ] 2each ;
 
 : intersect-intervals ( intervals values -- )
-    [
+    [ intersect-value-interval ] 2each ;
-        [ value-interval* interval-intersect ] keep
-        set-value-interval*
-    ] 2each ;
 
 : predicate-constraints ( class #call -- )
     [
@@ -181,20 +185,14 @@ M: pair constraint-satisfied?
         [ swap predicate-constraints ] [ 2drop ] if
     ] if* ;
 
-: default-output-classes ( word -- classes )
-    "inferred-effect" word-prop {
-        { [ dup not ] [ drop f ] }
-        { [ dup effect-out [ class? ] all? not ] [ drop f ] }
-        { [ t ] [ effect-out ] }
-    } cond ;
-
 : compute-output-classes ( node word -- classes intervals )
-    dup node-param "output-classes" word-prop dup
+    dup node-param "output-classes" word-prop
-    [ call ] [ 2drop f f ] if ;
+    dup [ call ] [ 2drop f f ] if ;
 
 : output-classes ( node -- classes intervals )
-    dup compute-output-classes
+    dup compute-output-classes >r
-    >r [ ] [ node-param default-output-classes ] ?if r> ;
+    [ ] [ node-param "default-output-classes" word-prop ] ?if
+    r> ;
 
 M: #call infer-classes-before
     dup compute-constraints
@@ -220,7 +218,8 @@ M: #dispatch child-constraints
     ] make-constraints ;
 
 M: #declare infer-classes-before
-    dup node-param swap node-in-d [ set-value-class* ] 2each ;
+    dup node-param swap node-in-d
+    [ intersect-value-class ] 2each ;
 
 DEFER: (infer-classes)
 

core/inference/dataflow/dataflow.factor

@@ -256,6 +256,28 @@ SYMBOL: node-stack
         ] iterate-nodes drop
     ] with-node-iterator ; inline
 
+: change-children ( node quot -- )
+    over [
+        >r dup node-children dup r>
+        [ map swap set-node-children ] curry
+        [ 2drop ] if
+    ] [
+        2drop
+    ] if ; inline
+
+: (transform-nodes) ( prev node quot -- )
+    dup >r call dup [
+        dup rot set-node-successor
+        dup node-successor r> (transform-nodes)
+    ] [
+        r> drop f swap set-node-successor drop
+    ] if ; inline
+
+: transform-nodes ( node quot -- new-node )
+    over [
+        [ call dup dup node-successor ] keep (transform-nodes)
+    ] [ drop ] if ; inline
+
 : node-literal? ( node value -- ? )
     dup value? >r swap node-literals key? r> or ;
 

core/inference/inference-docs.factor

@@ -73,6 +73,12 @@ $nl
 { $subsection infer-quot-value }
 "The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
 
+ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph"
+"The dataflow graph used by " { $link "compiler" } " can be obtained:"
+{ $subsection dataflow }
+"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
+$nl ;
+
 ARTICLE: "inference" "Stack effect inference"
 "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
 $nl
@@ -80,14 +86,15 @@ $nl
 { $subsection infer. }
 "Instead of printing the inferred information, it can be returned as objects on the stack:"
 { $subsection infer }
-"The dataflow graph used by " { $link "compiler" } " can be obtained:"
+"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
-{ $subsection dataflow }
+$nl
 "The following articles describe the implementation of the stack effect inference algorithm:"
 { $subsection "inference-simple" }
 { $subsection "inference-combinators" }
 { $subsection "inference-branches" }
 { $subsection "inference-recursive" } 
 { $subsection "inference-limitations" } 
+{ $subsection "dataflow-graphs" }
 { $subsection "compiler-transforms" } ;
 
 ABOUT: "inference"

core/inference/inference-tests.factor

@@ -4,23 +4,23 @@ math.parser math.private namespaces namespaces.private parser
 sequences strings vectors words quotations effects tools.test
 continuations generic.standard sorting assocs definitions
 prettyprint io inspector tuples classes.union classes.predicate
-debugger threads.private io.streams.string combinators.private
+debugger threads.private io.streams.string io.timeouts
-tools.test.inference ;
+sequences.private ;
 IN: temporary
 
-{ 0 2 } [ 2 "Hello" ] unit-test-effect
+{ 0 2 } [ 2 "Hello" ] must-infer-as
-{ 1 2 } [ dup ] unit-test-effect
+{ 1 2 } [ dup ] must-infer-as
 
-{ 1 2 } [ [ dup ] call ] unit-test-effect
+{ 1 2 } [ [ dup ] call ] must-infer-as
-[ [ call ] infer ] unit-test-fails
+[ [ call ] infer ] must-fail
 
-{ 2 4 } [ 2dup ] unit-test-effect
+{ 2 4 } [ 2dup ] must-infer-as
 
-{ 1 0 } [ [ ] [ ] if ] unit-test-effect
+{ 1 0 } [ [ ] [ ] if ] must-infer-as
-[ [ if ] infer ] unit-test-fails
+[ [ if ] infer ] must-fail
-[ [ [ ] if ] infer ] unit-test-fails
+[ [ [ ] if ] infer ] must-fail
-[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
+[ [ [ 2 ] [ ] if ] infer ] must-fail
-{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect
+{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
 
 { 4 3 } [
     [
@@ -28,21 +28,21 @@ IN: temporary
     ] [
         -rot
     ] if
-] unit-test-effect
+] must-infer-as
 
-{ 1 1 } [ dup [ ] when ] unit-test-effect
+{ 1 1 } [ dup [ ] when ] must-infer-as
-{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect
+{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
-{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect
+{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as
 
-{ 1 0 } [ [ drop ] when* ] unit-test-effect
+{ 1 0 } [ [ drop ] when* ] must-infer-as
-{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect
+{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
 
 { 0 1 }
-[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect
+[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
 
 [
     [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
-] unit-test-fails
+] must-fail
 
 ! Test inference of termination of control flow
 : termination-test-1
@@ -50,37 +50,37 @@ IN: temporary
 
 : termination-test-2 [ termination-test-1 ] [ 3 ] if ;
 
-{ 1 1 } [ termination-test-2 ] unit-test-effect
+{ 1 1 } [ termination-test-2 ] must-infer-as
 
 : infinite-loop infinite-loop ;
 
-[ [ infinite-loop ] infer ] unit-test-fails
+[ [ infinite-loop ] infer ] must-fail
 
 : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
-[ [ no-base-case-1 ] infer ] unit-test-fails
+[ [ no-base-case-1 ] infer ] must-fail
 
 : simple-recursion-1 ( obj -- obj )
     dup [ simple-recursion-1 ] [ ] if ;
 
-{ 1 1 } [ simple-recursion-1 ] unit-test-effect
+{ 1 1 } [ simple-recursion-1 ] must-infer-as
 
 : simple-recursion-2 ( obj -- obj )
     dup [ ] [ simple-recursion-2 ] if ;
 
-{ 1 1 } [ simple-recursion-2 ] unit-test-effect
+{ 1 1 } [ simple-recursion-2 ] must-infer-as
 
 : bad-recursion-2 ( obj -- obj )
     dup [ dup first swap second bad-recursion-2 ] [ ] if ;
 
-[ [ bad-recursion-2 ] infer ] unit-test-fails
+[ [ bad-recursion-2 ] infer ] must-fail
 
 : funny-recursion ( obj -- obj )
     dup [ funny-recursion 1 ] [ 2 ] if drop ;
 
-{ 1 1 } [ funny-recursion ] unit-test-effect
+{ 1 1 } [ funny-recursion ] must-infer-as
 
 ! Simple combinators
-{ 1 2 } [ [ first ] keep second ] unit-test-effect
+{ 1 2 } [ [ first ] keep second ] must-infer-as
 
 ! Mutual recursion
 DEFER: foe
@@ -103,8 +103,8 @@ DEFER: foe
         2drop f
     ] if ;
 
-{ 2 1 } [ fie ] unit-test-effect
+{ 2 1 } [ fie ] must-infer-as
-{ 2 1 } [ foe ] unit-test-effect
+{ 2 1 } [ foe ] must-infer-as
 
 : nested-when ( -- )
     t [
@@ -113,7 +113,7 @@ DEFER: foe
         ] when
     ] when ;
 
-{ 0 0 } [ nested-when ] unit-test-effect
+{ 0 0 } [ nested-when ] must-infer-as
 
 : nested-when* ( obj -- )
     [
@@ -122,11 +122,11 @@ DEFER: foe
         ] when*
     ] when* ;
 
-{ 1 0 } [ nested-when* ] unit-test-effect
+{ 1 0 } [ nested-when* ] must-infer-as
 
 SYMBOL: sym-test
 
-{ 0 1 } [ sym-test ] unit-test-effect
+{ 0 1 } [ sym-test ] must-infer-as
 
 : terminator-branch
     dup [
@@ -135,7 +135,7 @@ SYMBOL: sym-test
         "foo" throw
     ] if ;
 
-{ 1 1 } [ terminator-branch ] unit-test-effect
+{ 1 1 } [ terminator-branch ] must-infer-as
 
 : recursive-terminator ( obj -- )
     dup [
@@ -144,7 +144,7 @@ SYMBOL: sym-test
         "Hi" throw
     ] if ;
 
-{ 1 0 } [ recursive-terminator ] unit-test-effect
+{ 1 0 } [ recursive-terminator ] must-infer-as
 
 GENERIC: potential-hang ( obj -- obj )
 M: fixnum potential-hang dup [ potential-hang ] when ;
@@ -157,24 +157,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
 M: f iterate drop ;
 M: real iterate drop ;
 
-{ 1 0 } [ iterate ] unit-test-effect
+{ 1 0 } [ iterate ] must-infer-as
 
 ! Regression
 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
-{ 3 0 } [ dog ] unit-test-effect
+{ 3 0 } [ dog ] must-infer-as
 
 ! Regression
 DEFER: monkey
 : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
 : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
-{ 3 0 } [ friend ] unit-test-effect
+{ 3 0 } [ friend ] must-infer-as
 
 ! Regression -- same as above but we infer the second word first
 DEFER: blah2
 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
 : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
-{ 3 0 } [ blah2 ] unit-test-effect
+{ 3 0 } [ blah2 ] must-infer-as
 
 ! Regression
 DEFER: blah4
@@ -182,7 +182,7 @@ DEFER: blah4
     dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
 : blah4 ( a b c -- )
     dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
-{ 3 0 } [ blah4 ] unit-test-effect
+{ 3 0 } [ blah4 ] must-infer-as
 
 ! Regression
 : bad-combinator ( obj quot -- )
@@ -192,14 +192,14 @@ DEFER: blah4
         [ swap slip ] keep swap bad-combinator
     ] if ; inline
 
-[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
+[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
 
 ! Regression
 : bad-input#
     dup string? [ 2array throw ] unless
     over string? [ 2array throw ] unless ;
 
-{ 2 2 } [ bad-input# ] unit-test-effect
+{ 2 2 } [ bad-input# ] must-infer-as
 
 ! Regression
 
@@ -207,18 +207,18 @@ DEFER: blah4
 DEFER: do-crap
 : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
 : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
-[ [ do-crap ] infer ] unit-test-fails
+[ [ do-crap ] infer ] must-fail
 
 ! This one does not
 DEFER: do-crap*
 : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
 : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
-[ [ do-crap* ] infer ] unit-test-fails
+[ [ do-crap* ] infer ] must-fail
 
 ! Regression
 : too-deep ( a b -- c )
     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
-{ 2 1 } [ too-deep ] unit-test-effect
+{ 2 1 } [ too-deep ] must-infer-as
 
 ! Error reporting is wrong
 MATH: xyz
@@ -226,7 +226,7 @@ M: fixnum xyz 2array ;
 M: float xyz
     [ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
 
-[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
+[ [ xyz ] infer ] [ inference-error? ] must-fail-with
 
 ! Doug Coleman discovered this one while working on the
 ! calendar library
@@ -258,17 +258,17 @@ DEFER: C
         [ dup B C ]
     } dispatch ;
 
-{ 1 0 } [ A ] unit-test-effect
+{ 1 0 } [ A ] must-infer-as
-{ 1 0 } [ B ] unit-test-effect
+{ 1 0 } [ B ] must-infer-as
-{ 1 0 } [ C ] unit-test-effect
+{ 1 0 } [ C ] must-infer-as
 
 ! I found this bug by thinking hard about the previous one
 DEFER: Y
 : X ( a b -- c d ) dup [ swap Y ] [ ] if ;
 : Y ( a b -- c d ) X ;
 
-{ 2 2 } [ X ] unit-test-effect
+{ 2 2 } [ X ] must-infer-as
-{ 2 2 } [ Y ] unit-test-effect
+{ 2 2 } [ Y ] must-infer-as
 
 ! This one comes from UI code
 DEFER: #1
@@ -277,78 +277,66 @@ DEFER: #1
 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
 : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
 
-[ \ #4 word-def infer ] unit-test-fails
+[ \ #4 word-def infer ] must-fail
-[ [ #1 ] infer ] unit-test-fails
+[ [ #1 ] infer ] must-fail
 
 ! Similar
 DEFER: bar
 : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
 : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
 
-[ [ foo ] infer ] unit-test-fails
+[ [ foo ] infer ] must-fail
 
-[ 1234 infer ] unit-test-fails
+[ 1234 infer ] must-fail
 
 ! This used to hang
-[ t ] [
+[ [ [ dup call ] dup call ] infer ]
-    [ [ [ dup call ] dup call ] infer ] catch
+[ inference-error? ] must-fail-with
-    inference-error?
-] unit-test
 
 : m dup call ; inline
 
-[ t ] [
+[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
-    [ [ [ m ] m ] infer ] catch inference-error?
-] unit-test
 
 : m' dup curry call ; inline
 
-[ t ] [
+[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
-    [ [ [ m' ] m' ] infer ] catch inference-error?
-] unit-test
 
 : m'' [ dup curry ] ; inline
 
 : m''' m'' call call ; inline
 
-[ t ] [
+[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
-    [ [ [ m''' ] m''' ] infer ] catch inference-error?
-] unit-test
 
 : m-if t over if ; inline
 
-[ t ] [
+[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
-    [ [ [ m-if ] m-if ] infer ] catch inference-error?
-] unit-test
 
 ! This doesn't hang but it's also an example of the
 ! undedicable case
-[ t ] [
+[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
-    [ [ [ [ drop 3 ] swap call ] dup call ] infer ] catch
+[ inference-error? ] must-fail-with
-    inference-error?
-] unit-test
 
 ! This form should not have a stack effect
 
 : bad-recursion-1 ( a -- b )
     dup [ drop bad-recursion-1 5 ] [ ] if ;
 
-[ [ bad-recursion-1 ] infer ] unit-test-fails
+[ [ bad-recursion-1 ] infer ] must-fail
 
 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
-[ [ bad-bin ] infer ] unit-test-fails
+[ [ bad-bin ] infer ] must-fail
 
-[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test
+[ [ r> ] infer ] [ inference-error? ] must-fail-with
 
 ! Regression
-[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test
+[ [ get-slots ] infer ] [ inference-error? ] must-fail-with
 
 ! Test some curry stuff
-{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect
+{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
 
-{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect
+{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
 
-[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
+[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
 
 ! Test number protocol
 \ bitor must-infer
@@ -393,7 +381,7 @@ DEFER: bar
 \ assoc-like must-infer
 \ assoc-clone-like must-infer
 \ >alist must-infer
-{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
+{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
 
 ! Test some random library words
 \ 1quotation must-infer
@@ -416,10 +404,10 @@ DEFER: bar
 \ define-predicate-class must-infer
 
 ! Test words with continuations
-{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect
+{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
-{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect
+{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
-{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
+{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
-{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
+{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
 
 \ dispose must-infer
 
@@ -459,16 +447,16 @@ DEFER: bar
 : fooxxx ( a b -- c ) over [ foo ] when ; inline
 : barxxx fooxxx ;
 
-[ [ barxxx ] infer ] unit-test-fails
+[ [ barxxx ] infer ] must-fail
 
 ! A typo
-{ 1 0 } [ { [ ] } dispatch ] unit-test-effect
+{ 1 0 } [ { [ ] } dispatch ] must-infer-as
 
 DEFER: inline-recursive-2
 : inline-recursive-1 ( -- ) inline-recursive-2 ;
 : inline-recursive-2 ( -- ) inline-recursive-1 ;
 
-{ 0 0 } [ inline-recursive-1 ] unit-test-effect
+{ 0 0 } [ inline-recursive-1 ] must-infer-as
 
 ! Hooks
 SYMBOL: my-var
@@ -477,22 +465,22 @@ HOOK: my-hook my-var ( -- x )
 M: integer my-hook "an integer" ;
 M: string my-hook "a string" ;
 
-{ 0 1 } [ my-hook ] unit-test-effect
+{ 0 1 } [ my-hook ] must-infer-as
 
 DEFER: deferred-word
 
 : calls-deferred-word [ deferred-word ] [ 3 ] if ;
 
-{ 1 1 } [ calls-deferred-word ] unit-test-effect
+{ 1 1 } [ calls-deferred-word ] must-infer-as
 
 USE: inference.dataflow
 
-{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect
+{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
 
 { 1 0 }
 [
     [ [ iterate-next ] iterate-nodes ] with-node-iterator
-] unit-test-effect
+] must-infer-as
 
 : nilpotent ( quot -- )
     t [ [ call ] keep nilpotent ] [ drop ] if ; inline
@@ -502,11 +490,11 @@ USE: inference.dataflow
 
 { 0 1 }
 [ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
-unit-test-effect
+must-infer-as
 
-{ 0 0 } [ [ ] semisimple ] unit-test-effect
+{ 0 0 } [ [ ] semisimple ] must-infer-as
 
-{ 1 0 } [ [ drop ] each-node ] unit-test-effect
+{ 1 0 } [ [ drop ] each-node ] must-infer-as
 
 DEFER: an-inline-word
 
@@ -522,9 +510,9 @@ DEFER: an-inline-word
 : an-inline-word ( obj quot -- )
     >r normal-word r> call ; inline
 
-{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect
+{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
 
-{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect
+{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
 
 TUPLE: custom-error ;
 
@@ -548,4 +536,9 @@ TUPLE: custom-error ;
 
 ! This was a false trigger of the undecidable quotation
 ! recursion bug
-{ 2 1 } [ find-last-sep ] unit-test-effect
+{ 2 1 } [ find-last-sep ] must-infer-as
+
+! Regression
+: missing->r-check >r ;
+
+[ [ missing->r-check ] infer ] must-fail

core/inference/inference.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: inference.backend inference.state inference.dataflow
 inference.known-words inference.transforms inference.errors
-sequences prettyprint io effects kernel namespaces quotations
+kernel io effects namespaces sequences quotations vocabs
-words vocabs ;
+generic words ;
 IN: inference
 
 GENERIC: infer ( quot -- effect )
@@ -28,4 +28,7 @@ M: callable dataflow-with
     ] with-infer nip ;
 
 : forget-errors ( -- )
-    all-words [ f "no-effect" set-word-prop ] each ;
+    all-words [
+        dup subwords [ f "no-effect" set-word-prop ] each
+        f "no-effect" set-word-prop
+    ] each ;

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

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.accessors arrays bit-arrays byte-arrays
-classes combinators.private continuations.private effects
+classes sequences.private continuations.private effects
 float-arrays generic hashtables hashtables.private
 inference.state inference.backend inference.dataflow io
 io.backend io.files io.files.private io.streams.c kernel
@@ -126,15 +126,11 @@ M: object infer-call
     pop-d pop-d swap <curried> push-d
 ] "infer" set-word-prop
 
-\ curry { object object } { curry } <effect> "inferred-effect" set-word-prop
-
 \ compose [
     2 ensure-values
     pop-d pop-d swap <composed> push-d
 ] "infer" set-word-prop
 
-\ compose { object object } { curry } <effect> "inferred-effect" set-word-prop
-
 ! Variadic tuple constructor
 \ <tuple-boa> [
     \ <tuple-boa>
@@ -142,440 +138,461 @@ M: object infer-call
     make-call-node
 ] "infer" set-word-prop
 
-! We need this for default-output-classes
-\ <tuple-boa> 2 { tuple } <effect> "inferred-effect" set-word-prop
-
 ! Non-standard control flow
-\ (throw) { callable } { } <effect>
+\ (throw) [
-t over set-effect-terminated?
+    \ (throw)
-"inferred-effect" set-word-prop
+    peek-d value-literal 2 + { } <effect>
+    t over set-effect-terminated?
+    make-call-node
+] "infer" set-word-prop
+
+:  set-primitive-effect ( word effect -- )
+    2dup effect-out "default-output-classes" set-word-prop
+    dupd [ make-call-node ] 2curry "infer" set-word-prop ;
 
 ! Stack effects for all primitives
-\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
 \ fixnum< make-foldable
 
-\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
 \ fixnum<= make-foldable
 
-\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
 \ fixnum> make-foldable
 
-\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
 \ fixnum>= make-foldable
 
-\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
+\ eq? { object object } { object } <effect> set-primitive-effect
 \ eq? make-foldable
 
-\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
+\ rehash-string { string } { } <effect> set-primitive-effect
 
-\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
 \ bignum>fixnum make-foldable
 
-\ float>fixnum { float } { fixnum } <effect> "inferred-effect" set-word-prop
+\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
 \ bignum>fixnum make-foldable
 
-\ fixnum>bignum { fixnum } { bignum } <effect> "inferred-effect" set-word-prop
+\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
 \ fixnum>bignum make-foldable
 
-\ float>bignum { float } { bignum } <effect> "inferred-effect" set-word-prop
+\ float>bignum { float } { bignum } <effect> set-primitive-effect
 \ float>bignum make-foldable
 
-\ fixnum>float { fixnum } { float } <effect> "inferred-effect" set-word-prop
+\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
 \ fixnum>float make-foldable
 
-\ bignum>float { bignum } { float } <effect> "inferred-effect" set-word-prop
+\ bignum>float { bignum } { float } <effect> set-primitive-effect
 \ bignum>float make-foldable
 
-\ <ratio> { integer integer } { ratio } <effect> "inferred-effect" set-word-prop
+\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
 \ <ratio> make-foldable
 
-\ string>float { string } { float } <effect> "inferred-effect" set-word-prop
+\ string>float { string } { float } <effect> set-primitive-effect
 \ string>float make-foldable
 
-\ float>string { float } { string } <effect> "inferred-effect" set-word-prop
+\ float>string { float } { string } <effect> set-primitive-effect
 \ float>string make-foldable
 
-\ float>bits { real } { integer } <effect> "inferred-effect" set-word-prop
+\ float>bits { real } { integer } <effect> set-primitive-effect
 \ float>bits make-foldable
 
-\ double>bits { real } { integer } <effect> "inferred-effect" set-word-prop
+\ double>bits { real } { integer } <effect> set-primitive-effect
 \ double>bits make-foldable
 
-\ bits>float { integer } { float } <effect> "inferred-effect" set-word-prop
+\ bits>float { integer } { float } <effect> set-primitive-effect
 \ bits>float make-foldable
 
-\ bits>double { integer } { float } <effect> "inferred-effect" set-word-prop
+\ bits>double { integer } { float } <effect> set-primitive-effect
 \ bits>double make-foldable
 
-\ <complex> { real real } { complex } <effect> "inferred-effect" set-word-prop
+\ <complex> { real real } { complex } <effect> set-primitive-effect
 \ <complex> make-foldable
 
-\ fixnum+ { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum+ make-foldable
 
-\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum+fast make-foldable
 
-\ fixnum- { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum- make-foldable
 
-\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-fast make-foldable
 
-\ fixnum* { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum* make-foldable
 
-\ fixnum*fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum*fast make-foldable
 
-\ fixnum/i { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum/i make-foldable
 
-\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-mod make-foldable
 
-\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
 \ fixnum/mod make-foldable
 
-\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-bitand make-foldable
 
-\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-bitor make-foldable
 
-\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-bitxor make-foldable
 
-\ fixnum-bitnot { fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-bitnot make-foldable
 
-\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum-shift make-foldable
 
-\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-shift-fast make-foldable
 
-\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum= make-foldable
 
-\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum+ make-foldable
 
-\ bignum- { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum- make-foldable
 
-\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum* make-foldable
 
-\ bignum/i { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum/i make-foldable
 
-\ bignum-mod { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-mod make-foldable
 
-\ bignum/mod { bignum bignum } { bignum bignum } <effect> "inferred-effect" set-word-prop
+\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
 \ bignum/mod make-foldable
 
-\ bignum-bitand { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-bitand make-foldable
 
-\ bignum-bitor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-bitor make-foldable
 
-\ bignum-bitxor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-bitxor make-foldable
 
-\ bignum-bitnot { bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
 \ bignum-bitnot make-foldable
 
-\ bignum-shift { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-shift make-foldable
 
-\ bignum< { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum< make-foldable
 
-\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum<= make-foldable
 
-\ bignum> { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum> make-foldable
 
-\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum>= make-foldable
 
-\ bignum-bit? { bignum integer } { object } <effect> "inferred-effect" set-word-prop
+\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
 \ bignum-bit? make-foldable
 
-\ bignum-log2 { bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
 \ bignum-log2 make-foldable
 
-\ byte-array>bignum { byte-array } { bignum } <effect> "inferred-effect" set-word-prop
+\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
 \ byte-array>bignum make-foldable
 
-\ float= { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float= { float float } { object } <effect> set-primitive-effect
 \ float= make-foldable
 
-\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float+ { float float } { float } <effect> set-primitive-effect
 \ float+ make-foldable
 
-\ float- { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float- { float float } { float } <effect> set-primitive-effect
 \ float- make-foldable
 
-\ float* { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float* { float float } { float } <effect> set-primitive-effect
 \ float* make-foldable
 
-\ float/f { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float/f { float float } { float } <effect> set-primitive-effect
 \ float/f make-foldable
 
-\ float< { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float< { float float } { object } <effect> set-primitive-effect
 \ float< make-foldable
 
-\ float-mod { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float-mod { float float } { float } <effect> set-primitive-effect
 \ float-mod make-foldable
 
-\ float<= { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float<= { float float } { object } <effect> set-primitive-effect
 \ float<= make-foldable
 
-\ float> { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float> { float float } { object } <effect> set-primitive-effect
 \ float> make-foldable
 
-\ float>= { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float>= { float float } { object } <effect> set-primitive-effect
 \ float>= make-foldable
 
-\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
+\ <word> { object object } { word } <effect> set-primitive-effect
 \ <word> make-flushable
 
-\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
+\ word-xt { word } { integer } <effect> set-primitive-effect
 \ word-xt make-flushable
 
-\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ getenv { fixnum } { object } <effect> set-primitive-effect
 \ getenv make-flushable
 
-\ setenv { object fixnum } { } <effect> "inferred-effect" set-word-prop
+\ setenv { object fixnum } { } <effect> set-primitive-effect
 
-\ (stat) { string } { object object object object } <effect> "inferred-effect" set-word-prop
+\ (stat) { string } { object object object object } <effect> set-primitive-effect
 
-\ (directory) { string } { array } <effect> "inferred-effect" set-word-prop
+\ (directory) { string } { array } <effect> set-primitive-effect
 
-\ data-gc { } { } <effect> "inferred-effect" set-word-prop
+\ data-gc { } { } <effect> set-primitive-effect
 
-\ code-gc { } { } <effect> "inferred-effect" set-word-prop
+\ code-gc { } { } <effect> set-primitive-effect
 
-\ gc-time { } { integer } <effect> "inferred-effect" set-word-prop
+\ gc-time { } { integer } <effect> set-primitive-effect
 
-\ save-image { string } { } <effect> "inferred-effect" set-word-prop
+\ save-image { string } { } <effect> set-primitive-effect
 
-\ save-image-and-exit { string } { } <effect> "inferred-effect" set-word-prop
+\ save-image-and-exit { string } { } <effect> set-primitive-effect
 
 \ exit { integer } { } <effect>
 t over set-effect-terminated?
-"inferred-effect" set-word-prop
+set-primitive-effect
 
-\ data-room { } { integer array } <effect> "inferred-effect" set-word-prop
+\ data-room { } { integer array } <effect> set-primitive-effect
 \ data-room make-flushable
 
-\ code-room { } { integer integer } <effect> "inferred-effect" set-word-prop
+\ code-room { } { integer integer } <effect> set-primitive-effect
 \ code-room  make-flushable
 
-\ os-env { string } { object } <effect> "inferred-effect" set-word-prop
+\ os-env { string } { object } <effect> set-primitive-effect
 
-\ millis { } { integer } <effect> "inferred-effect" set-word-prop
+\ millis { } { integer } <effect> set-primitive-effect
 \ millis make-flushable
 
-\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop
+\ type { object } { fixnum } <effect> set-primitive-effect
 \ type make-foldable
 
-\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop
+\ tag { object } { fixnum } <effect> set-primitive-effect
 \ tag make-foldable
 
-\ class-hash { object } { fixnum } <effect> "inferred-effect" set-word-prop
+\ class-hash { object } { fixnum } <effect> set-primitive-effect
 \ class-hash make-foldable
 
-\ cwd { } { string } <effect> "inferred-effect" set-word-prop
+\ cwd { } { string } <effect> set-primitive-effect
 
-\ cd { string } { } <effect> "inferred-effect" set-word-prop
+\ cd { string } { } <effect> set-primitive-effect
 
-\ dlopen { string } { dll } <effect> "inferred-effect" set-word-prop
+\ dlopen { string } { dll } <effect> set-primitive-effect
 
-\ dlsym { string object } { c-ptr } <effect> "inferred-effect" set-word-prop
+\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
 
-\ dlclose { dll } { } <effect> "inferred-effect" set-word-prop
+\ dlclose { dll } { } <effect> set-primitive-effect
 
-\ <byte-array> { integer } { byte-array } <effect> "inferred-effect" set-word-prop
+\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
 \ <byte-array> make-flushable
 
-\ <bit-array> { integer } { bit-array } <effect> "inferred-effect" set-word-prop
+\ <bit-array> { integer } { bit-array } <effect> set-primitive-effect
 \ <bit-array> make-flushable
 
-\ <float-array> { integer float } { float-array } <effect> "inferred-effect" set-word-prop
+\ <float-array> { integer float } { float-array } <effect> set-primitive-effect
 \ <float-array> make-flushable
 
-\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "inferred-effect" set-word-prop
+\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
 \ <displaced-alien> make-flushable
 
-\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-cell make-flushable
 
-\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-cell make-flushable
 
-\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-8 make-flushable
 
-\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-8 make-flushable
 
-\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-4 make-flushable
 
-\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-4 make-flushable
 
-\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-2 make-flushable
 
-\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-2 make-flushable
 
-\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-1 make-flushable
 
-\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-1 make-flushable
 
-\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
+\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-float make-flushable
 
-\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
+\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-double make-flushable
 
-\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
+\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
+\ alien-cell make-flushable
 
-\ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
+\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
+\ alien>char-string make-flushable
 
-\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
+\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
+\ string>char-alien make-flushable
 
-\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
+\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
+\ alien>u16-string make-flushable
 
-\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
+\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
+\ string>u16-alien make-flushable
 
-\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-address { alien } { integer } <effect> set-primitive-effect
 \ alien-address make-flushable
 
-\ slot { object fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ slot { object fixnum } { object } <effect> set-primitive-effect
 \ slot make-flushable
 
-\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
+\ set-slot { object object fixnum } { } <effect> set-primitive-effect
 
-\ string-nth { fixnum string } { fixnum } <effect> "inferred-effect" set-word-prop
+\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
 \ string-nth make-flushable
 
-\ set-string-nth { fixnum fixnum string } { } <effect> "inferred-effect" set-word-prop
+\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
 
-\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
+\ resize-array { integer array } { array } <effect> set-primitive-effect
 \ resize-array make-flushable
 
-\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
+\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
 \ resize-byte-array make-flushable
 
-\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
+\ resize-bit-array { integer bit-array } { bit-array } <effect> set-primitive-effect
 \ resize-bit-array make-flushable
 
-\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
+\ resize-float-array { integer float-array } { float-array } <effect> set-primitive-effect
 \ resize-float-array make-flushable
 
-\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
+\ resize-string { integer string } { string } <effect> set-primitive-effect
 \ resize-string make-flushable
 
-\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
+\ <array> { integer object } { array } <effect> set-primitive-effect
 \ <array> make-flushable
 
-\ begin-scan { } { } <effect> "inferred-effect" set-word-prop
+\ begin-scan { } { } <effect> set-primitive-effect
 
-\ next-object { } { object } <effect> "inferred-effect" set-word-prop
+\ next-object { } { object } <effect> set-primitive-effect
 
-\ end-scan { } { } <effect> "inferred-effect" set-word-prop
+\ end-scan { } { } <effect> set-primitive-effect
 
-\ size { object } { fixnum } <effect> "inferred-effect" set-word-prop
+\ size { object } { fixnum } <effect> set-primitive-effect
 \ size make-flushable
 
-\ die { } { } <effect> "inferred-effect" set-word-prop
+\ die { } { } <effect> set-primitive-effect
 
-\ fopen { string string } { alien } <effect> "inferred-effect" set-word-prop
+\ fopen { string string } { alien } <effect> set-primitive-effect
 
-\ fgetc { alien } { object } <effect> "inferred-effect" set-word-prop
+\ fgetc { alien } { object } <effect> set-primitive-effect
 
-\ fwrite { string alien } { } <effect> "inferred-effect" set-word-prop
+\ fwrite { string alien } { } <effect> set-primitive-effect
 
-\ fread { integer string } { object } <effect> "inferred-effect" set-word-prop
+\ fread { integer string } { object } <effect> set-primitive-effect
 
-\ fflush { alien } { } <effect> "inferred-effect" set-word-prop
+\ fflush { alien } { } <effect> set-primitive-effect
 
-\ fclose { alien } { } <effect> "inferred-effect" set-word-prop
+\ fclose { alien } { } <effect> set-primitive-effect
 
-\ expired? { object } { object } <effect> "inferred-effect" set-word-prop
+\ expired? { object } { object } <effect> set-primitive-effect
 \ expired? make-flushable
 
-\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop
+\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
 \ <wrapper> make-foldable
 
-\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
+\ (clone) { object } { object } <effect> set-primitive-effect
 \ (clone) make-flushable
 
-\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
+\ <string> { integer integer } { string } <effect> set-primitive-effect
 \ <string> make-flushable
 
-\ array>quotation { array } { quotation } <effect> "inferred-effect" set-word-prop
+\ array>quotation { array } { quotation } <effect> set-primitive-effect
 \ array>quotation make-flushable
 
-\ quotation-xt { quotation } { integer } <effect> "inferred-effect" set-word-prop
+\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
 \ quotation-xt make-flushable
 
-\ <tuple> { word integer } { quotation } <effect> "inferred-effect" set-word-prop
+\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
 \ <tuple> make-flushable
 
-\ (>tuple) { array } { tuple } <effect> "inferred-effect" set-word-prop
+\ (>tuple) { array } { tuple } <effect> set-primitive-effect
 \ (>tuple) make-flushable
 
-\ tuple>array { tuple } { array } <effect> "inferred-effect" set-word-prop
+\ tuple>array { tuple } { array } <effect> set-primitive-effect
 \ tuple>array make-flushable
 
-\ datastack { } { array } <effect> "inferred-effect" set-word-prop
+\ datastack { } { array } <effect> set-primitive-effect
 \ datastack make-flushable
 
-\ retainstack { } { array } <effect> "inferred-effect" set-word-prop
+\ retainstack { } { array } <effect> set-primitive-effect
 \ retainstack make-flushable
 
-\ callstack { } { callstack } <effect> "inferred-effect" set-word-prop
+\ callstack { } { callstack } <effect> set-primitive-effect
 \ callstack make-flushable
 
-\ callstack>array { callstack } { array } <effect> "inferred-effect" set-word-prop
+\ callstack>array { callstack } { array } <effect> set-primitive-effect
 \ callstack>array make-flushable
 
-\ (sleep) { integer } { } <effect> "inferred-effect" set-word-prop
+\ (sleep) { integer } { } <effect> set-primitive-effect
 
-\ become { array array } { } <effect> "inferred-effect" set-word-prop
+\ become { array array } { } <effect> set-primitive-effect
 
-\ innermost-frame-quot { callstack } { quotation } <effect> "inferred-effect" set-word-prop
+\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
 
-\ innermost-frame-scan { callstack } { fixnum } <effect> "inferred-effect" set-word-prop
+\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
 
-\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop
+\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
 
-\ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop
+\ (os-envs) { } { array } <effect> set-primitive-effect
 
 \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop

core/inference/transforms/transforms-tests.factor

@@ -1,6 +1,6 @@
 IN: temporary
 USING: sequences inference.transforms tools.test math kernel
-quotations tools.test.inference inference ;
+quotations inference ;
 
 : compose-n-quot <repetition> >quotation ;
 : compose-n compose-n-quot call ;
@@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ;
 : set-slots-test-2
     { set-a-tuple-x set-a-tuple-x } set-slots ;
 
-[ [ set-slots-test-2 ] infer ] unit-test-fails
+[ [ set-slots-test-2 ] infer ] must-fail

core/inference/transforms/transforms.factor

@@ -54,6 +54,10 @@ M: pair (bitfield-quot) ( spec -- quot )
 
 \ bitfield [ bitfield-quot ] 1 define-transform
 
+\ flags [
+    [ 0 , [ , \ bitor , ] each ] [ ] make
+] 1 define-transform
+
 ! Tuple operations
 : [get-slots] ( slots -- quot )
     [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;
@@ -89,5 +93,3 @@ M: duplicated-slots-error summary
         \ construct-empty 1 1 <effect> make-call-node
     ] if
 ] "infer" set-word-prop
-
-\ construct-empty 1 1 <effect> "inferred-effect" set-word-prop

core/io/crc32/crc32-docs.factor

@@ -2,16 +2,16 @@ USING: help.markup help.syntax math ;
 IN: io.crc32
 
 HELP: crc32
-{ $values { "seq" "a sequence" } { "n" integer } }
+{ $values { "seq" "a sequence of bytes" } { "n" integer } }
 { $description "Computes the CRC32 checksum of a sequence of bytes." } ;
 
-HELP: file-crc32
+HELP: lines-crc32
-{ $values { "path" "a pathname string" } { "n" integer } }
+{ $values { "lines" "a sequence of strings" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a file's contents." } ;
+{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
 
 ARTICLE: "io.crc32" "CRC32 checksum calculation"
 "The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
 { $subsection crc32 }
-{ $subsection file-crc32 } ;
+{ $subsection lines-crc32 } ;
 
 ABOUT: "io.crc32"

core/io/crc32/crc32.factor

@@ -23,8 +23,6 @@ IN: io.crc32
 : crc32 ( seq -- n )
     >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
 
-: file-crc32 ( path -- n ) file-contents crc32 ;
-
 : lines-crc32 ( seq -- n )
     HEX: ffffffff tuck [
         [ (crc32) ] each CHAR: \n (crc32)

core/io/files/files-docs.factor

@@ -52,12 +52,27 @@ HELP: <file-appender>
 { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
 { $errors "Throws an error if the file cannot be opened for writing." } ;
 
-HELP: cwd ( -- path )
+HELP: with-file-in
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file is unreadable." } ;
+
+HELP: with-file-out
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
+HELP: with-file-appender
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
+HELP: cwd
 { $values { "path" "a pathname string" } }
 { $description "Outputs the current working directory of the Factor process." }
 { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
 
-HELP: cd ( path -- )
+HELP: cd
 { $values { "path" "a pathname string" } }
 { $description "Changes the current working directory of the Factor process." }
 { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;

core/io/files/files-tests.factor

@@ -2,7 +2,8 @@ IN: temporary
 USING: tools.test io.files io threads kernel continuations ;
 
 [ "passwd" ] [ "/etc/passwd" file-name ] unit-test
-[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test
+[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
+[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
 
 [ ] [
     "test-foo.txt" resource-path <file-writer> [

core/io/files/files.factor

@@ -1,10 +1,14 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.files
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
 system combinators splitting sbufs ;
 
+HOOK: cd io-backend ( path -- )
+
+HOOK: cwd io-backend ( -- path )
+
 HOOK: <file-reader> io-backend ( path -- stream )
 
 HOOK: <file-writer> io-backend ( path -- stream )
@@ -25,12 +29,15 @@ HOOK: root-directory? io-backend ( path -- ? )
 
 M: object root-directory? ( path -- ? ) path-separator? ;
 
-: trim-path-separators ( str -- newstr )
+: right-trim-separators ( str -- newstr )
     [ path-separator? ] right-trim ;
 
+: left-trim-separators ( str -- newstr )
+    [ path-separator? ] left-trim ;
+
 : path+ ( str1 str2 -- str )
-    >r trim-path-separators "/" r>
+    >r right-trim-separators "/" r>
-    [ path-separator? ] left-trim 3append ;
+    left-trim-separators 3append ;
 
 : stat ( path -- directory? permissions length modified )
     normalize-pathname (stat) ;
@@ -57,7 +64,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
     normalize-directory dup (directory) fixup-directory ;
 
 : last-path-separator ( path -- n ? )
-    [ length 2 [-] ] keep [ path-separator? ] find-last* ;
+    [ length 1- ] keep [ path-separator? ] find-last* ;
 
 TUPLE: no-parent-directory path ;
 
@@ -65,7 +72,7 @@ TUPLE: no-parent-directory path ;
     \ no-parent-directory construct-boa throw ;
 
 : parent-directory ( path -- parent )
-    trim-path-separators {
+    right-trim-separators {
         { [ dup empty? ] [ drop "/" ] }
         { [ dup root-directory? ] [ ] }
         { [ dup [ path-separator? ] contains? not ] [ drop "." ] }
@@ -76,7 +83,11 @@ TUPLE: no-parent-directory path ;
     } cond ;
 
 : file-name ( path -- string )
-    dup last-path-separator [ 1+ tail ] [ drop ] if ;
+    right-trim-separators {
+        { [ dup empty? ] [ drop "/" ] }
+        { [ dup last-path-separator ] [ 1+ tail ] }
+        { [ t ] [ drop ] }
+    } cond ;
 
 : resource-path ( path -- newpath )
     \ resource-path get [ image parent-directory ] unless*
@@ -85,8 +96,11 @@ TUPLE: no-parent-directory path ;
 : ?resource-path ( path -- newpath )
     "resource:" ?head [ resource-path ] when ;
 
+: resource-exists? ( path -- ? )
+    ?resource-path exists? ;
+
 : make-directories ( path -- )
-    normalize-pathname trim-path-separators {
+    normalize-pathname right-trim-separators {
         { [ dup "." = ] [ ] }
         { [ dup root-directory? ] [ ] }
         { [ dup empty? ] [ ] }
@@ -162,3 +176,12 @@ PRIVATE>
 
 : file-contents ( path -- str )
     dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;
+
+: with-file-in ( path quot -- )
+    >r <file-reader> r> with-stream ; inline
+
+: with-file-out ( path quot -- )
+    >r <file-writer> r> with-stream ; inline
+
+: with-file-appender ( path quot -- )
+    >r <file-appender> r> with-stream ; inline

core/io/io-docs.factor

@@ -22,8 +22,7 @@ $nl
 { $subsection make-block-stream }
 { $subsection make-cell-stream }
 { $subsection stream-write-table }
-"Optional word for network streams:"
+{ $see-also "io.timeouts" } ;
-{ $subsection set-timeout } ;
 
 ARTICLE: "stdio" "The default stream"
 "Various words take an implicit stream parameter from a variable to reduce stack shuffling."
@@ -73,11 +72,6 @@ ARTICLE: "streams" "Streams"
 
 ABOUT: "streams"
 
-HELP: set-timeout
-{ $values { "n" "an integer" } { "stream" "a stream" } }
-{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
-{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
-
 HELP: stream-readln
 { $values { "stream" "an input stream" } { "str" string } }
 { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }

core/io/io.factor

@@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
     continuations assocs io.styles sbufs ;
 IN: io
 
-GENERIC: set-timeout ( n stream -- )
 GENERIC: stream-readln ( stream -- str )
 GENERIC: stream-read1 ( stream -- ch/f )
 GENERIC: stream-read ( n stream -- str/f )

core/io/streams/c/c.factor

@@ -74,3 +74,10 @@ M: object <file-writer>
 
 M: object <file-appender>
     "ab" fopen <c-writer> <plain-writer> ;
+
+: show ( msg -- )
+    #! A word which directly calls primitives. It is used to
+    #! print stuff from contexts where the I/O system would
+    #! otherwise not work (tools.deploy.shaker, the I/O
+    #! multiplexer thread).
+    "\r\n" append stdout-handle fwrite stdout-handle fflush ;

core/io/streams/duplex/duplex-tests.factor

@@ -28,13 +28,13 @@ M: unclosable-stream dispose
 [ t ] [
     <unclosable-stream> <closing-stream> [
         <duplex-stream>
-        [ dup dispose ] catch 2drop
+        [ dup dispose ] [ 2drop ] recover
     ] keep closing-stream-closed?
 ] unit-test
 
 [ t ] [
     <closing-stream> [ <unclosable-stream>
         <duplex-stream>
-        [ dup dispose ] catch 2drop
+        [ dup dispose ] [ 2drop ] recover
     ] keep closing-stream-closed?
 ] unit-test

core/io/streams/duplex/duplex.factor

@@ -74,8 +74,3 @@ M: duplex-stream dispose
         [ dup duplex-stream-out dispose ]
         [ dup duplex-stream-in dispose ] [ ] cleanup
     ] unless drop ;
-
-M: duplex-stream set-timeout
-    2dup
-    duplex-stream-in set-timeout
-    duplex-stream-out set-timeout ;

core/kernel/kernel-docs.factor

@@ -532,7 +532,7 @@ HELP: compose
         "compose call"
         "append call"
     }
-    "However, " { $link compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
+    "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
 } ;
 
 HELP: 3compose

core/kernel/kernel-tests.factor

@@ -7,25 +7,22 @@ IN: temporary
 [ t ] [ [ \ = \ = ] all-equal? ] unit-test
 
 ! Don't leak extra roots if error is thrown
-[ ] [ 10000 [ [ 3 throw ] catch drop ] times ] unit-test
+[ ] [ 10000 [ [ 3 throw ] ignore-errors ] times ] unit-test
 
-[ ] [ 10000 [ [ -1 f <array> ] catch drop ] times ] unit-test
+[ ] [ 10000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
 
 ! Make sure we report the correct error on stack underflow
-[ { "kernel-error" 11 f f } ]
+[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with
-[ [ clear drop ] catch ] unit-test
 
 [ ] [ :c ] unit-test
 
-[ { "kernel-error" 13 f f } ]
+[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with
-[ [ { } set-retainstack r> ] catch ] unit-test
 
 [ ] [ :c ] unit-test
 
 : overflow-d 3 overflow-d ;
 
-[ { "kernel-error" 12 f f } ]
+[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
-[ [ overflow-d ] catch ] unit-test
 
 [ ] [ :c ] unit-test
 
@@ -33,24 +30,17 @@ IN: temporary
 
 : overflow-d-alt (overflow-d-alt) overflow-d-alt ;
 
-[ { "kernel-error" 12 f f } ]
+[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
-[ [ overflow-d-alt ] catch ] unit-test
 
 [ ] [ [ :c ] string-out drop ] unit-test
 
 : overflow-r 3 >r overflow-r ;
 
-[ { "kernel-error" 14 f f } ]
+[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
-[ [ overflow-r ] catch ] unit-test
 
 [ ] [ :c ] unit-test
 
-! : overflow-c overflow-c 3 ;
+[ -7 <byte-array> ] must-fail
-! 
-! [ { "kernel-error" 16 f f } ]
-! [ [ overflow-c ] catch ] unit-test
-
-[ -7 <byte-array> ] unit-test-fails
 
 [ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test
 [ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test
@@ -61,27 +51,27 @@ IN: temporary
 [ 4 ] [ 4 6 or ] unit-test
 [ 6 ] [ f 6 or ] unit-test
 
-[ slip ] unit-test-fails
+[ slip ] must-fail
 [ ] [ :c ] unit-test
 
-[ 1 slip ] unit-test-fails
+[ 1 slip ] must-fail
 [ ] [ :c ] unit-test
 
-[ 1 2 slip ] unit-test-fails
+[ 1 2 slip ] must-fail
 [ ] [ :c ] unit-test
 
-[ 1 2 3 slip ] unit-test-fails
+[ 1 2 3 slip ] must-fail
 [ ] [ :c ] unit-test
 
 
 [ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
 
-[ [ ] keep ] unit-test-fails
+[ [ ] keep ] must-fail
 
 [ 6 ] [ 2 [ sq ] keep + ] unit-test
 
-[ [ ] 2keep ] unit-test-fails
+[ [ ] 2keep ] must-fail
-[ 1 [ ] 2keep ] unit-test-fails
+[ 1 [ ] 2keep ] must-fail
 [ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test
 
 [ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test
@@ -100,13 +90,13 @@ IN: temporary
 
 [ ] [ callstack set-callstack ] unit-test
 
-[ 3drop datastack ] unit-test-fails
+[ 3drop datastack ] must-fail
 [ ] [ :c ] unit-test
 
 ! Doesn't compile; important
 : foo 5 + 0 [ ] each ;
 
-[ drop foo ] unit-test-fails
+[ drop foo ] must-fail
 [ ] [ :c ] unit-test
 
 ! Regression
@@ -117,4 +107,4 @@ IN: temporary
 : loop ( obj obj -- )
     H{ } values swap >r dup length swap r> 0 -roll (loop) ;
 
-[ loop ] unit-test-fails
+[ loop ] must-fail

core/kernel/kernel.factor

@@ -17,7 +17,7 @@ IN: kernel
 : clear ( -- ) { } set-datastack ;
 
 ! Combinators
-: call ( callable -- ) uncurry (call) ;
+GENERIC: call ( callable -- )
 
 DEFER: if
 
@@ -70,6 +70,10 @@ DEFER: if
     [ 2nip call ] if ; inline
 
 ! Quotation building
+USE: tuples.private
+
+: curry ( obj quot -- curry )
+    \ curry 4 <tuple-boa> ;
 
 : 2curry ( obj1 obj2 quot -- curry )
     curry curry ; inline
@@ -81,12 +85,10 @@ DEFER: if
     swapd [ swapd call ] 2curry ; inline
 
 : compose ( quot1 quot2 -- curry )
-    ! Not inline because this is treated as a primitive by
+    \ compose 4 <tuple-boa> ;
-    ! the compiler
-    [ slip call ] 2curry ;
 
 : 3compose ( quot1 quot2 quot3 -- curry )
-    [ 2slip slip call ] 3curry ; inline
+    compose compose ; inline
 
 ! Object protocol
 
@@ -155,7 +157,7 @@ GENERIC: construct-boa ( ... class -- tuple )
 
 ! Error handling -- defined early so that other files can
 ! throw errors before continuations are loaded
-: throw ( error -- * ) 5 getenv [ die ] or curry (throw) ;
+: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
 
 <PRIVATE
 

core/listener/listener-tests.factor

@@ -22,7 +22,7 @@ IN: temporary
             [
                 "\\ + 1 2 3 4" parse-interactive
                 "cont" get continue-with
-            ] catch
+            ] ignore-errors
             "USE: debugger :1" eval
         ] callcc1
     ] unit-test
@@ -36,7 +36,7 @@ IN: temporary
 
 [
     "USE: vocabs.loader.test.c" parse-interactive
-] unit-test-fails
+] must-fail
 
 [ ] [
     [

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/math/bitfields/bitfields.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math sequences words ;
 IN: math.bitfields
@@ -13,3 +13,6 @@ M: pair (bitfield) ( value accum pair -- newaccum )
 
 : bitfield ( values... bitspec -- n )
     0 [ (bitfield) ] reduce ;
+
+: flags ( values -- n )
+    0 [ dup word? [ execute ] when bitor ] reduce ;

core/math/integers/integers-tests.factor

@@ -121,8 +121,8 @@ unit-test
 
 ! We don't care if this fails or returns 0 (its CPU-specific)
 ! as long as it doesn't crash
-[ ] [ [ 0 0 /i ] catch clear ] unit-test
+[ ] [ [ 0 0 /i drop ] ignore-errors ] unit-test
-[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test
+[ ] [ [ 100000000000000000 0 /i drop ] ignore-errors ] unit-test
 
 [ -2 ] [ 1 bitnot ] unit-test
 [ -2 ] [ 1 >bignum bitnot ] unit-test

core/math/parser/parser-docs.factor

@@ -25,14 +25,10 @@ $nl
 ABOUT: "number-strings"
 
 HELP: digits>integer
-{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "n" integer } }
+{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
 { $description "Converts a sequence of digits (with most significant digit first) into an integer." }
 { $notes "This is one of the factors of " { $link string>number } "." } ;
 
-HELP: valid-digits?
-{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "?" "a boolean" } }
-{ $description "Tests if this sequence of integers represents a valid integer in the given radix." } ;
-
 HELP: >digit
 { $values { "n" "an integer between 0 and 35" } { "ch" "a character" } }
 { $description "Outputs a character representation of a digit." }
@@ -43,11 +39,6 @@ HELP: digit>
 { $description "Converts a character representation of a digit to an integer." }
 { $notes "This is one of the factors of " { $link string>number } "." } ;
 
-HELP: string>integer
-{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "an integer or " { $link f } } }
-{ $description "Creates an integer from a string representation." }
-{ $notes "The " { $link base> } " word is more general." } ;
-
 HELP: base>
 { $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } }
 { $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10."

core/math/parser/parser-tests.factor

@@ -95,16 +95,6 @@ unit-test
 
 [ f ] [ "\0." string>number ] unit-test
 
-! [ t ] [
+[ 1 1 >base ] must-fail
-!     { "1.0/0.0" "-1.0/0.0" "0.0/0.0" }
+[ 1 0 >base ] must-fail
-!     [ dup string>number number>string = ] all?
+[ 1 -1 >base ] must-fail
-! ] unit-test
-! 
-! [ t ] [
-!     { 1.0/0.0 -1.0/0.0 0.0/0.0 }
-!     [ dup number>string string>number = ] all?
-! ] unit-test
-
-[ 1 1 >base ] unit-test-fails
-[ 1 0 >base ] unit-test-fails
-[ 1 -1 >base ] unit-test-fails

core/math/parser/parser.factor

@@ -4,12 +4,6 @@ USING: kernel math.private namespaces sequences strings arrays
 combinators splitting math assocs ;
 IN: math.parser
 
-DEFER: base>
-
-: string>ratio ( str radix -- a/b )
-    >r "/" split1 r> tuck base> >r base> r>
-    2dup and [ / ] [ 2drop f ] if ;
-
 : digit> ( ch -- n )
     H{
         { CHAR: 0 0 }
@@ -36,30 +30,57 @@ DEFER: base>
         { CHAR: f 15 }
     } at ;
 
-: digits>integer ( radix seq -- n )
-    0 rot [ swapd * + ] curry reduce ;
-
-: valid-digits? ( radix seq -- ? )
-    {
-        { [ dup empty? ] [ 2drop f ] }
-        { [ f over memq? ] [ 2drop f ] }
-        { [ t ] [ swap [ < ] curry all? ] }
-    } cond ;
-
 : string>digits ( str -- digits )
     [ digit> ] { } map-as ;
 
-: string>integer ( str radix -- n/f )
+: digits>integer ( seq radix -- n )
-    swap "-" ?head >r
+    0 swap [ swapd * + ] curry reduce ;
-    string>digits 2dup valid-digits?
+
-    [ digits>integer r> [ neg ] when ] [ r> 3drop f ] if ;
+DEFER: base>
+
+<PRIVATE
+
+SYMBOL: radix
+SYMBOL: negative?
+
+: sign negative? get "-" "+" ? ;
+
+: with-radix ( radix quot -- )
+    radix swap with-variable ; inline
+
+: (base>) ( str -- n ) radix get base> ;
+
+: whole-part ( str -- m n )
+    sign split1 >r (base>) r>
+    dup [ (base>) ] [ drop 0 swap ] if ;
+
+: string>ratio ( str -- a/b )
+    "/" split1 (base>) >r whole-part r>
+    3dup and and [ / + ] [ 3drop f ] if ;
+
+: valid-digits? ( seq -- ? )
+    {
+        { [ dup empty? ] [ drop f ] }
+        { [ f over memq? ] [ drop f ] }
+        { [ t ] [ radix get [ < ] curry all? ] }
+    } cond ;
+
+: string>integer ( str -- n/f )
+    string>digits dup valid-digits?
+    [ radix get digits>integer ] [ drop f ] if ;
+
+PRIVATE>
 
 : base> ( str radix -- n/f )
-    {
+    [
-        { [ CHAR: / pick member? ] [ string>ratio ] }
+        "-" ?head dup negative? set >r
-        { [ CHAR: . pick member? ] [ drop string>float ] }
+        {
-        { [ t ] [ string>integer ] }
+            { [ CHAR: / over member? ] [ string>ratio ] }
-    } cond ;
+            { [ CHAR: . over member? ] [ string>float ] }
+            { [ t ] [ string>integer ] }
+        } cond
+        r> [ dup [ neg ] when ] when
+    ] with-radix ;
 
 : string>number ( str -- n/f ) 10 base> ;
 : bin> ( str -- n/f ) 2 base> ;
@@ -74,8 +95,16 @@ DEFER: base>
     dup >r /mod >digit , dup 0 >
     [ r> integer, ] [ r> 2drop ] if ;
 
+PRIVATE>
+
 GENERIC# >base 1 ( n radix -- str )
 
+<PRIVATE
+
+: (>base) ( n -- str ) radix get >base ;
+
+PRIVATE>
+
 M: integer >base
     [
         over 0 < [
@@ -87,10 +116,15 @@ M: integer >base
 
 M: ratio >base
     [
-        over numerator over >base %
+        [
-        CHAR: / ,
+            dup 0 < dup negative? set [ "-" % neg ] when
-        swap denominator swap >base %
+            1 /mod
-    ] "" make ;
+            >r dup zero? [ drop ] [ (>base) % sign % ] if r>
+            dup numerator (>base) %
+            "/" %
+            denominator (>base) %
+        ] "" make
+    ] with-radix ;
 
 : fix-float ( str -- newstr )
     {

core/memory/memory-tests.factor

@@ -4,7 +4,7 @@ IN: temporary
 
 TUPLE: testing x y z ;
 
-[ save-image-and-exit ] unit-test-fails
+[ save-image-and-exit ] must-fail
 
 [ ] [
     num-types get [

core/optimizer/backend/backend.factor

@@ -4,7 +4,7 @@ USING: arrays generic assocs inference inference.class
 inference.dataflow inference.backend inference.state io kernel
 math namespaces sequences vectors words quotations hashtables
 combinators classes generic.math continuations optimizer.def-use
-optimizer.pattern-match generic.standard ;
+optimizer.pattern-match generic.standard optimizer.specializers ;
 IN: optimizer.backend
 
 SYMBOL: class-substitutions
@@ -52,13 +52,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
 DEFER: optimize-nodes
 
 : optimize-children ( node -- )
-    [
+    [ optimize-nodes ] change-children ;
-        dup node-children dup [
-            [ optimize-nodes ] map swap set-node-children
-        ] [
-            2drop
-        ] if
-    ] when* ;
 
 : optimize-node ( node -- node )
     dup [
@@ -76,39 +70,17 @@ DEFER: optimize-nodes
 
 M: f set-node-successor 2drop ;
 
-: (optimize-nodes) ( prev node -- )
-    optimize-node [
-        dup rot set-node-successor
-        dup node-successor (optimize-nodes)
-    ] [
-        f swap set-node-successor
-    ] if* ;
-
 : optimize-nodes ( node -- newnode )
     [
         class-substitutions [ clone ] change
         literal-substitutions [ clone ] change
-        dup [
+        [ optimize-node ] transform-nodes
-            optimize-node
+        optimizer-changed get
-            dup dup node-successor (optimize-nodes)
-        ] when optimizer-changed get
     ] with-scope optimizer-changed set ;
 
-: prune-if ( node quot -- successor/t )
-    over >r call [ r> node-successor t ] [ r> drop t f ] if ;
-    inline
-
 ! Generic nodes
 M: node optimize-node* drop t f ;
 
-M: #shuffle optimize-node* 
-    [
-        dup node-in-d empty? swap node-out-d empty? and
-    ] prune-if ;
-
-M: #push optimize-node* 
-    [ node-out-d empty? ] prune-if ;
-
 : cleanup-inlining ( node -- newnode changed? )
     node-successor [ node-successor t ] [ t f ] if* ;
 
@@ -118,12 +90,6 @@ M: #return optimize-node* cleanup-inlining ;
 ! #values
 M: #values optimize-node* cleanup-inlining ;
 
-! #>r
-M: #>r optimize-node* [ node-in-d empty? ] prune-if ;
-
-! #r>
-M: #r> optimize-node* [ node-in-r empty? ] prune-if ;
-
 ! Some utilities for splicing in dataflow IR subtrees
 : follow ( key assoc -- value )
     2dup at* [ swap follow nip ] [ 2drop ] if ;
@@ -194,10 +160,8 @@ M: node remember-method*
 
 ! Constant branch folding
 : fold-branch ( node branch# -- node )
-    over drop-inputs >r
     over node-children nth
-    swap node-successor over substitute-node
+    swap node-successor over substitute-node ;
-    r> [ set-node-successor ] keep ;
 
 ! #if
 : known-boolean-value? ( node value -- value ? )
@@ -213,12 +177,18 @@ M: node remember-method*
     ] if ;
 
 M: #if optimize-node*
-    dup dup node-in-d first known-boolean-value?
+    dup dup node-in-d first known-boolean-value? [
-    [ 0 1 ? fold-branch t ] [ 2drop t f ] if ;
+        over drop-inputs >r
+        0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+        t
+    ] [ 2drop t f ] if ;
 
 M: #dispatch optimize-node*
     dup dup node-in-d first 2dup node-literal? [
-        node-literal fold-branch t
+        "Optimizing #dispatch" print
+        node-literal
+        over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
     ] [
         3drop t f
     ] if ;
@@ -245,11 +215,33 @@ M: #dispatch optimize-node*
 : dispatching-class ( node word -- class )
     [ dispatch# node-class# ] keep specific-method ;
 
+! A heuristic to avoid excessive inlining
+DEFER: (flat-length)
+
+: word-flat-length ( word -- n )
+    dup get over inline? not or
+    [ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
+
+: (flat-length) ( seq -- n )
+    [
+        {
+            { [ dup quotation? ] [ (flat-length) 1+ ] }
+            { [ dup array? ] [ (flat-length) ] }
+            { [ dup word? ] [ word-flat-length ] }
+            { [ t ] [ drop 1 ] }
+        } cond
+    ] map sum ;
+
+: flat-length ( seq -- n )
+    [ word-def (flat-length) ] with-scope ;
+
 : will-inline-method ( node word -- method-spec/t quot/t )
     #! t indicates failure
     tuck dispatching-class dup [
         swap [ 2array ] 2keep
-        method method-def
+        method method-word
+        dup flat-length 10 >=
+        [ 1quotation ] [ word-def ] if
     ] [
         2drop t t
     ] if ;
@@ -300,9 +292,19 @@ M: #dispatch optimize-node*
     #! Make #shuffle -> #push -> #return -> successor
     dupd literal-quot splice-quot ;
 
-: optimize-predicate ( #call -- node )
+: evaluate-predicate ( #call -- ? )
     dup node-param "predicating" word-prop >r
-    dup node-class-first r> class< 1array inline-literals ;
+    node-class-first r> class< ;
+
+: optimize-predicate ( #call -- node )
+    dup evaluate-predicate swap
+    dup node-successor #if? [
+        dup drop-inputs >r
+        node-successor swap 0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+    ] [
+        swap 1array inline-literals
+    ] if ;
 
 : optimizer-hooks ( node -- conditions )
     node-param "optimizer-hooks" word-prop ;
@@ -355,7 +357,7 @@ M: #dispatch optimize-node*
 
 : optimistic-inline? ( #call -- ? )
     dup node-param "specializer" word-prop dup [
-        >r node-input-classes r> length tail*
+        >r node-input-classes r> specialized-length tail*
         [ types length 1 = ] all?
     ] [
         2drop f

core/optimizer/def-use/def-use-tests.factor

@@ -8,7 +8,7 @@ namespaces assocs kernel sequences math tools.test words ;
 ] unit-test
 
 : kill-set ( quot -- seq )
-    dataflow compute-def-use dead-literals keys
+    dataflow compute-def-use compute-dead-literals keys
     [ value-literal ] map ;
 
 : subset? [ member? ] curry all? ;

core/optimizer/def-use/def-use.factor

@@ -70,19 +70,66 @@ M: #branch node-def-use
     #! #values node.
     dup branch-def-use (node-def-use) ;
 
-: dead-literals ( -- values )
+! : dead-literals ( -- values )
+!     def-use get [ >r value? r> empty? and ] assoc-subset ;
+! 
+! : kill-node* ( node values -- )
+!     [ swap remove-all ] curry modify-values ;
+! 
+! : kill-node ( node values -- )
+!     dup assoc-empty?
+!     [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
+! 
+! : kill-values ( node -- )
+!     #! Remove literals which are not actually used anywhere.
+!     dead-literals kill-node ;
+
+: compute-dead-literals ( -- values )
     def-use get [ >r value? r> empty? and ] assoc-subset ;
 
-: kill-node* ( node values -- )
+DEFER: kill-nodes
-    [ swap remove-all ] curry modify-values ;
+SYMBOL: dead-literals
 
-: kill-node ( node values -- )
+GENERIC: kill-node* ( node -- node/t )
-    dup assoc-empty?
-    [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
 
-: kill-values ( node -- )
+M: node kill-node* drop t ;
+
+: prune-if ( node quot -- successor/t )
+    over >r call [ r> node-successor ] [ r> drop t ] if ;
+    inline
+
+M: #shuffle kill-node* 
+    [
+        dup node-in-d empty? swap node-out-d empty? and
+    ] prune-if ;
+
+M: #push kill-node* 
+    [ node-out-d empty? ] prune-if ;
+
+M: #>r kill-node* [ node-in-d empty? ] prune-if ;
+
+M: #r> kill-node* [ node-in-r empty? ] prune-if ;
+
+: kill-node ( node -- node )
+    dup [
+        dup [ dead-literals get swap remove-all ] modify-values
+        dup kill-node* dup t eq? [
+            drop dup [ kill-nodes ] change-children
+        ] [
+            nip kill-node
+        ] if
+    ] when ;
+
+: kill-nodes ( node -- newnode )
+    [ kill-node ] transform-nodes ;
+
+: kill-values ( node -- new-node )
     #! Remove literals which are not actually used anywhere.
-    dead-literals kill-node ;
+    compute-dead-literals dup assoc-empty? [ drop ] [
+        dead-literals [ kill-nodes ] with-variable
+    ] if ;
+
+!
 
 : sole-consumer ( #call -- node/f )
     node-out-d first used-by