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

Factor.app/Contents/Info.plist

@@ -32,7 +32,7 @@
 	<key>CFBundlePackageType</key>
 	<string>APPL</string>
 	<key>NSHumanReadableCopyright</key>
-	<string>Copyright © 2003-2007, Slava Pestov and friends</string>
+	<string>Copyright © 2003-2008, Slava Pestov and friends</string>
 	<key>NSServices</key>
 	<array>
 		<dict>

core/alien/alien-docs.factor

@@ -265,7 +265,7 @@ ARTICLE: "embedding-restrictions" "Embedding API restrictions"
 ARTICLE: "embedding-factor" "What embedding looks like from Factor"
 "Factor code will run inside an embedded instance in the same way it would run in a stand-alone instance."
 $nl
-"One exception is the global " { $link stdio } " stream, which is by default not bound to the terminal where the process is running, to avoid conflicting with any I/O the host process might perform. To initialize the terminal stream, " { $link init-stdio } " must be called explicitly."
+"One exception is that the global " { $link input-stream } " and " { $link output-stream } " streams are not bound by default, to avoid conflicting with any I/O the host process might perform. The " { $link init-stdio } " words must be called explicitly to initialize terminal streams."
 $nl
 "There is a word which can detect when Factor is embedded:"
 { $subsection embedded? }

core/alien/compiler/compiler-tests.factor

@@ -1,375 +1,375 @@
-IN: alien.compiler.tests
+IN: alien.compiler.tests
-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 math ;
+tools.test math ;
-
+
-FUNCTION: void ffi_test_0 ;
+FUNCTION: void ffi_test_0 ;
-[ ] [ ffi_test_0 ] unit-test
+[ ] [ ffi_test_0 ] unit-test
-
+
-FUNCTION: int ffi_test_1 ;
+FUNCTION: int ffi_test_1 ;
-[ 3 ] [ ffi_test_1 ] unit-test
+[ 3 ] [ ffi_test_1 ] unit-test
-
+
-FUNCTION: int ffi_test_2 int x int y ;
+FUNCTION: int ffi_test_2 int x int y ;
-[ 5 ] [ 2 3 ffi_test_2 ] unit-test
+[ 5 ] [ 2 3 ffi_test_2 ] unit-test
-[ "hi" 3 ffi_test_2 ] must-fail
+[ "hi" 3 ffi_test_2 ] must-fail
-
+
-FUNCTION: int ffi_test_3 int x int y int z int t ;
+FUNCTION: int ffi_test_3 int x int y int z int t ;
-[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
+[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
-
+
-FUNCTION: float ffi_test_4 ;
+FUNCTION: float ffi_test_4 ;
-[ 1.5 ] [ ffi_test_4 ] unit-test
+[ 1.5 ] [ ffi_test_4 ] unit-test
-
+
-FUNCTION: double ffi_test_5 ;
+FUNCTION: double ffi_test_5 ;
-[ 1.5 ] [ ffi_test_5 ] unit-test
+[ 1.5 ] [ ffi_test_5 ] unit-test
-
+
-FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
+FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
-[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
+[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
-[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
+[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
-[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
+[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
-
+
-C-STRUCT: foo
+C-STRUCT: foo
-    { "int" "x" }
+    { "int" "x" }
-    { "int" "y" }
+    { "int" "y" }
-;
+;
-
+
-: make-foo ( x y -- foo )
+: make-foo ( x y -- foo )
-    "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+    "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
-
+
-FUNCTION: int ffi_test_11 int a foo b int c ;
+FUNCTION: int ffi_test_11 int a foo b int c ;
-
+
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
-
+
-FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
+FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
-
+
-[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
+[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
-
+
-FUNCTION: foo ffi_test_14 int x int y ;
+FUNCTION: foo ffi_test_14 int x int y ;
-
+
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
-
+
-FUNCTION: char* ffi_test_15 char* x char* y ;
+FUNCTION: char* ffi_test_15 char* x char* y ;
-
+
-[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
+[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
-[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
+[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
-[ 1 2 ffi_test_15 ] must-fail
+[ 1 2 ffi_test_15 ] must-fail
-
+
-C-STRUCT: bar
+C-STRUCT: bar
-    { "long" "x" }
+    { "long" "x" }
-    { "long" "y" }
+    { "long" "y" }
-    { "long" "z" }
+    { "long" "z" }
-;
+;
-
+
-FUNCTION: bar ffi_test_16 long x long y long z ;
+FUNCTION: bar ffi_test_16 long x long y long z ;
-
+
-[ 11 6 -7 ] [
+[ 11 6 -7 ] [
-    11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+    11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
-] unit-test
+] unit-test
-
+
-C-STRUCT: tiny
+C-STRUCT: tiny
-    { "int" "x" }
+    { "int" "x" }
-;
+;
-
+
-FUNCTION: tiny ffi_test_17 int x ;
+FUNCTION: tiny ffi_test_17 int x ;
-
+
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
-
+
-[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
+[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
-
+
-: indirect-test-1
+: indirect-test-1
-    "int" { } "cdecl" alien-indirect ;
+    "int" { } "cdecl" alien-indirect ;
-
+
-{ 1 1 } [ indirect-test-1 ] must-infer-as
+{ 1 1 } [ indirect-test-1 ] must-infer-as
-
+
-[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
-
+
-[ -1 indirect-test-1 ] must-fail
+[ -1 indirect-test-1 ] must-fail
-
+
-: indirect-test-2
+: indirect-test-2
-    "int" { "int" "int" } "cdecl" alien-indirect gc ;
+    "int" { "int" "int" } "cdecl" alien-indirect gc ;
-
+
-{ 3 1 } [ indirect-test-2 ] must-infer-as
+{ 3 1 } [ indirect-test-2 ] must-infer-as
-
+
-[ 5 ]
+[ 5 ]
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
-unit-test
+unit-test
-
+
-: indirect-test-3
+: indirect-test-3
-    "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+    "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
-    gc ;
+    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 gc ;
+    alien-invoke 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 gc ;
+    alien-invoke gc ;
-
+
-[ 11 6 -7 ] [
+[ 11 6 -7 ] [
-    11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+    11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
-] unit-test
+] unit-test
-
+
-FUNCTION: double ffi_test_6 float x float y ;
+FUNCTION: double ffi_test_6 float x float y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
+[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
-[ "a" "b" ffi_test_6 ] must-fail
+[ "a" "b" ffi_test_6 ] must-fail
-
+
-FUNCTION: double ffi_test_7 double x double y ;
+FUNCTION: double ffi_test_7 double x double y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
+[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
-
+
-FUNCTION: double ffi_test_8 double x float y double z float t int w ;
+FUNCTION: double ffi_test_8 double x float y double z float t int w ;
-[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
+[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
-
+
-FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
+FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
-[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
+[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
-
+
-FUNCTION: void ffi_test_20 double x1, double x2, double x3,
+FUNCTION: void ffi_test_20 double x1, double x2, double x3,
-    double y1, double y2, double y3,
+    double y1, double y2, double y3,
-    double z1, double z2, double z3 ;
+    double z1, double z2, double z3 ;
-
+
-[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
+[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
-
+
-! Make sure XT doesn't get clobbered in stack frame
+! Make sure XT doesn't get clobbered in stack frame
-
+
-: ffi_test_31
+: ffi_test_31
-    "void"
+    "void"
-    f "ffi_test_31"
+    f "ffi_test_31"
-    { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+    { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
-    alien-invoke gc 3 ;
+    alien-invoke gc 3 ;
-
+
-[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
-
+
-FUNCTION: longlong ffi_test_21 long x long y ;
+FUNCTION: longlong ffi_test_21 long x long y ;
-
+
-[ 121932631112635269 ]
+[ 121932631112635269 ]
-[ 123456789 987654321 ffi_test_21 ] unit-test
+[ 123456789 987654321 ffi_test_21 ] unit-test
-
+
-FUNCTION: long ffi_test_22 long x longlong y longlong z ;
+FUNCTION: long ffi_test_22 long x longlong y longlong z ;
-
+
-[ 987655432 ]
+[ 987655432 ]
-[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
+[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
-
+
-[ 1111 f 123456789 ffi_test_22 ] must-fail
+[ 1111 f 123456789 ffi_test_22 ] must-fail
-
+
-C-STRUCT: rect
+C-STRUCT: rect
-    { "float" "x" }
+    { "float" "x" }
-    { "float" "y" }
+    { "float" "y" }
-    { "float" "w" }
+    { "float" "w" }
-    { "float" "h" }
+    { "float" "h" }
-;
+;
-
+
-: <rect>
+: <rect>
-    "rect" <c-object>
+    "rect" <c-object>
-    [ set-rect-h ] keep
+    [ set-rect-h ] keep
-    [ set-rect-w ] keep
+    [ set-rect-w ] keep
-    [ set-rect-y ] keep
+    [ set-rect-y ] keep
-    [ set-rect-x ] keep ;
+    [ set-rect-x ] keep ;
-
+
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
-
+
-[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
-
+
-[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
+[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
-
+
-FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
+FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
-
+
-[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
+[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
-
+
-! Test odd-size structs
+! Test odd-size structs
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
-
+
-FUNCTION: test-struct-1 ffi_test_24 ;
+FUNCTION: test-struct-1 ffi_test_24 ;
-
+
-[ B{ 1 } ] [ ffi_test_24 ] unit-test
+[ B{ 1 } ] [ ffi_test_24 ] unit-test
-
+
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
-
+
-FUNCTION: test-struct-2 ffi_test_25 ;
+FUNCTION: test-struct-2 ffi_test_25 ;
-
+
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
-
+
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
-
+
-FUNCTION: test-struct-3 ffi_test_26 ;
+FUNCTION: test-struct-3 ffi_test_26 ;
-
+
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
-
+
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
-
+
-FUNCTION: test-struct-4 ffi_test_27 ;
+FUNCTION: test-struct-4 ffi_test_27 ;
-
+
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
-
+
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
-
+
-FUNCTION: test-struct-5 ffi_test_28 ;
+FUNCTION: test-struct-5 ffi_test_28 ;
-
+
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
-
+
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
-
+
-FUNCTION: test-struct-6 ffi_test_29 ;
+FUNCTION: test-struct-6 ffi_test_29 ;
-
+
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
-
+
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
-
+
-FUNCTION: test-struct-7 ffi_test_30 ;
+FUNCTION: test-struct-7 ffi_test_30 ;
-
+
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
-
+
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
-
+
-FUNCTION: double ffi_test_32 test-struct-8 x int y ;
+FUNCTION: double ffi_test_32 test-struct-8 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-8" <c-object>
+    "test-struct-8" <c-object>
-    1.0 over set-test-struct-8-x
+    1.0 over set-test-struct-8-x
-    2.0 over set-test-struct-8-y
+    2.0 over set-test-struct-8-y
-    3 ffi_test_32
+    3 ffi_test_32
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
-
+
-FUNCTION: double ffi_test_33 test-struct-9 x int y ;
+FUNCTION: double ffi_test_33 test-struct-9 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-9" <c-object>
+    "test-struct-9" <c-object>
-    1.0 over set-test-struct-9-x
+    1.0 over set-test-struct-9-x
-    2.0 over set-test-struct-9-y
+    2.0 over set-test-struct-9-y
-    3 ffi_test_33
+    3 ffi_test_33
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
-
+
-FUNCTION: double ffi_test_34 test-struct-10 x int y ;
+FUNCTION: double ffi_test_34 test-struct-10 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-10" <c-object>
+    "test-struct-10" <c-object>
-    1.0 over set-test-struct-10-x
+    1.0 over set-test-struct-10-x
-    2 over set-test-struct-10-y
+    2 over set-test-struct-10-y
-    3 ffi_test_34
+    3 ffi_test_34
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
-
+
-FUNCTION: double ffi_test_35 test-struct-11 x int y ;
+FUNCTION: double ffi_test_35 test-struct-11 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-11" <c-object>
+    "test-struct-11" <c-object>
-    1 over set-test-struct-11-x
+    1 over set-test-struct-11-x
-    2 over set-test-struct-11-y
+    2 over set-test-struct-11-y
-    3 ffi_test_35
+    3 ffi_test_35
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
-
+
-: make-struct-12
+: make-struct-12
-    "test-struct-12" <c-object>
+    "test-struct-12" <c-object>
-    [ set-test-struct-12-x ] keep ;
+    [ set-test-struct-12-x ] keep ;
-
+
-FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
-
+
-[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
-
+
-FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
-
+
-[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
+[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
-
+
-! Test callbacks
+! Test callbacks
-
+
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+: callback-1 "void" { } "cdecl" [ ] alien-callback ;
-
+
-[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
-
+
-[ t ] [ callback-1 alien? ] unit-test
+[ t ] [ callback-1 alien? ] unit-test
-
+
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
+: callback_test_1 "void" { } "cdecl" alien-indirect ;
-
+
-[ ] [ callback-1 callback_test_1 ] unit-test
+[ ] [ callback-1 callback_test_1 ] unit-test
-
+
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
-
+
-[ ] [ callback-2 callback_test_1 ] unit-test
+[ ] [ callback-2 callback_test_1 ] unit-test
-
+
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
-
+
-[ t ] [ 
+[ t ] [
-    namestack*
+    namestack*
-    3 "x" set callback-3 callback_test_1
+    3 "x" set callback-3 callback_test_1
-    namestack* eq?
+    namestack* eq?
-] unit-test
+] unit-test
-
+
-[ 5 ] [ 
+[ 5 ] [
-    [
+    [
-        3 "x" set callback-3 callback_test_1 "x" get
+        3 "x" set callback-3 callback_test_1 "x" get
-    ] with-scope
+    ] with-scope
-] unit-test
+] unit-test
-
+
-: callback-4
+: callback-4
-    "void" { } "cdecl" [ "Hello world" write ] alien-callback
+    "void" { } "cdecl" [ "Hello world" write ] alien-callback
-    gc ;
+    gc ;
-
+
-[ "Hello world" ] [ 
+[ "Hello world" ] [
-    [ callback-4 callback_test_1 ] with-string-writer
+    [ callback-4 callback_test_1 ] with-string-writer
-] unit-test
+] unit-test
-
+
-: callback-5
+: callback-5
-    "void" { } "cdecl" [ gc ] alien-callback ;
+    "void" { } "cdecl" [ gc ] alien-callback ;
-
+
-[ "testing" ] [
+[ "testing" ] [
-    "testing" callback-5 callback_test_1
+    "testing" callback-5 callback_test_1
-] unit-test
+] unit-test
-
+
-: callback-5a
+: callback-5a
-    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
+    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
-
+
-! Hack; if we're on ARM, we probably don't have much RAM, so
+! Hack; if we're on ARM, we probably don't have much RAM, so
-! skip this test.
+! skip this test.
-! cpu "arm" = [
+! cpu "arm" = [
-!     [ "testing" ] [
+!     [ "testing" ] [
-!         "testing" callback-5a callback_test_1
+!         "testing" callback-5a callback_test_1
-!     ] unit-test
+!     ] unit-test
-! ] unless
+! ] unless
-
+
-: callback-6
+: callback-6
-    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
-
+
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
-
+
-: callback-7
+: callback-7
-    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
-
+
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
-
+
-[ f ] [ namespace global eq? ] unit-test
+[ f ] [ namespace global eq? ] unit-test
-
+
-: callback-8
+: callback-8
-    "void" { } "cdecl" [
+    "void" { } "cdecl" [
-        [ continue ] callcc0
+        [ continue ] callcc0
-    ] alien-callback ;
+    ] alien-callback ;
-
+
-[ ] [ callback-8 callback_test_1 ] unit-test
+[ ] [ callback-8 callback_test_1 ] unit-test
-
+
-: callback-9
+: callback-9
-    "int" { "int" "int" "int" } "cdecl" [
+    "int" { "int" "int" "int" } "cdecl" [
-        + + 1+
+        + + 1+
-    ] alien-callback ;
+    ] alien-callback ;
-
+
-FUNCTION: void ffi_test_36_point_5 ( ) ;
+FUNCTION: void ffi_test_36_point_5 ( ) ;
-
+
-[ ] [ ffi_test_36_point_5 ] unit-test
+[ ] [ ffi_test_36_point_5 ] unit-test
-
+
-FUNCTION: int ffi_test_37 ( void* func ) ;
+FUNCTION: int ffi_test_37 ( void* func ) ;
-
+
-[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test
-
+
-[ 7 ] [ callback-9 ffi_test_37 ] unit-test
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test

core/alien/compiler/compiler.factor

@@ -270,7 +270,7 @@ M: no-such-symbol compiler-error-type
     pop-literal nip >>library
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot f infer-quot
+    dup param-prep-quot recursive-state get infer-quot
     ! Set ABI
     dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
     ! Add node to IR
@@ -278,7 +278,7 @@ M: no-such-symbol compiler-error-type
     ! Magic #: consume exactly the number of inputs
     dup 0 alien-invoke-stack
     ! Quotation which coerces return value to required type
-    return-prep-quot f infer-quot
+    return-prep-quot recursive-state get infer-quot
 ] "infer" set-word-prop
 
 M: #alien-invoke generate-node
@@ -306,13 +306,13 @@ M: alien-indirect-error summary
     pop-parameters >>parameters
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot [ dip ] curry f infer-quot
+    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
     ! Add node to IR
     dup node,
     ! Magic #: consume the function pointer, too
     dup 1 alien-invoke-stack
     ! Quotation which coerces return value to required type
-    return-prep-quot f infer-quot
+    return-prep-quot recursive-state get infer-quot
 ] "infer" set-word-prop
 
 M: #alien-indirect generate-node
@@ -345,7 +345,7 @@ M: alien-callback-error summary
 
 : callback-bottom ( node -- )
     xt>> [ word-xt drop <alien> ] curry
-    f infer-quot ;
+    recursive-state get infer-quot ;
 
 \ alien-callback [
     4 ensure-values

core/alien/strings/strings-docs.factor

@@ -3,14 +3,14 @@ debugger ;
 IN: alien.strings
 
 HELP: string>alien
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } }
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
 { $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
 { $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
 
 { string>alien alien>string malloc-string } related-words
 
 HELP: alien>string
-{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string" string } }
+{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
 { $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
 
 HELP: malloc-string

core/alien/strings/strings.factor

@@ -6,7 +6,7 @@ io.streams.byte-array io.streams.memory io.encodings.utf8
 io.encodings.utf16 system alien strings cpu.architecture ;
 IN: alien.strings
 
-GENERIC# alien>string 1 ( alien encoding -- string/f )
+GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
 
 M: c-ptr alien>string
     >r <memory-stream> r> <decoder>

core/alien/syntax/syntax.factor

@@ -40,7 +40,7 @@ PRIVATE>
 
 : FUNCTION:
     scan "c-library" get scan ";" parse-tokens
-    [ "()" subseq? not ] subset
+    [ "()" subseq? not ] filter
     define-function ; parsing
 
 : TYPEDEF:

core/assocs/assocs-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Daniel Ehrenberg and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel sequences
-sequences.private namespaces classes math ;
+sequences.private namespaces math ;
 IN: assocs
 
 ARTICLE: "alists" "Association lists"
@@ -68,7 +68,7 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
 
 ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
 "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
-{ $subsection subassoc? }
+{ $subsection assoc-subset? }
 { $subsection assoc-intersect }
 { $subsection update }
 { $subsection assoc-union }
@@ -96,7 +96,7 @@ $nl
 { $subsection assoc-each }
 { $subsection assoc-map }
 { $subsection assoc-push-if }
-{ $subsection assoc-subset }
+{ $subsection assoc-filter }
 { $subsection assoc-contains? }
 { $subsection assoc-all? }
 "Three additional combinators:"
@@ -203,7 +203,7 @@ HELP: assoc-push-if
 { $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
 { $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
 
-HELP: assoc-subset
+HELP: assoc-filter
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
 { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
 
@@ -215,7 +215,7 @@ HELP: assoc-all?
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
 { $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
 
-HELP: subassoc?
+HELP: assoc-subset?
 { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
 { $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;
 
@@ -281,7 +281,7 @@ HELP: assoc-union
 
 HELP: assoc-diff
 { $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
-{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." } 
+{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." } 
 ;
 HELP: remove-all
 { $values { "assoc" assoc } { "seq" "a sequence" } { "subseq" "a new sequence" } }

core/assocs/assocs-tests.factor

@@ -3,13 +3,13 @@ USING: kernel math namespaces tools.test vectors sequences
 sequences.private hashtables io prettyprint assocs
 continuations ;
 
-[ t ] [ H{ } dup subassoc? ] unit-test
+[ t ] [ H{ } dup assoc-subset? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
-[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test
+[ t ] [ H{ } H{ { 1 3 } } assoc-subset? ] unit-test
-[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test
+[ t ] [ H{ { 1 3 } } H{ { 1 3 } } assoc-subset? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } assoc-subset? ] unit-test
-[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test
+[ f ] [ H{ { 1 f } } H{ } assoc-subset? ] unit-test
-[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test
+[ t ] [ H{ { 1 f } } H{ { 1 f } } assoc-subset? ] unit-test
 
 ! Test some combinators
 [
@@ -30,10 +30,10 @@ continuations ;
 [ t ] [ H{ { 1 1 } { 2 2 } } [ = ] assoc-all? ] unit-test
 [ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
 
-[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-subset ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
 [ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
     H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
-    [ drop 3 >= ] assoc-subset
+    [ drop 3 >= ] assoc-filter
 ] unit-test
 
 [ 21 ] [

core/assocs/assocs.factor

@@ -50,7 +50,7 @@ M: assoc assoc-find
 : assoc-pusher ( quot -- quot' accum )
     V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
 
-: assoc-subset ( assoc quot -- subassoc )
+: assoc-filter ( assoc quot -- subassoc )
     over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
 
 : assoc-contains? ( assoc quot -- ? )
@@ -98,11 +98,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : assoc-stack ( key seq -- value )
     dup length 1- swap (assoc-stack) ;
 
-: subassoc? ( assoc1 assoc2 -- ? )
+: assoc-subset? ( assoc1 assoc2 -- ? )
     [ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
 
 : assoc= ( assoc1 assoc2 -- ? )
-    2dup subassoc? >r swap subassoc? r> and ;
+    [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
 
 : assoc-hashcode ( n assoc -- code )
     [
@@ -110,7 +110,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     ] { } assoc>map hashcode* ;
 
 : assoc-intersect ( assoc1 assoc2 -- intersection )
-    swap [ nip key? ] curry assoc-subset ;
+    swap [ nip key? ] curry assoc-filter ;
 
 : update ( assoc1 assoc2 -- )
     swap [ swapd set-at ] curry assoc-each ;
@@ -120,10 +120,10 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     [ rot update ] keep [ swap update ] keep ;
 
 : assoc-diff ( assoc1 assoc2 -- diff )
-    swap [ nip key? not ] curry assoc-subset ;
+    [ nip key? not ] curry assoc-filter ;
 
 : remove-all ( assoc seq -- subseq )
-    swap [ key? not ] curry subset ;
+    swap [ key? not ] curry filter ;
 
 : (substitute)
     [ dupd at* [ nip ] [ drop ] if ] curry ; inline

core/bootstrap/compiler/compiler.factor

@@ -5,7 +5,7 @@ namespaces parser kernel kernel.private classes classes.private
 arrays hashtables vectors classes.tuple sbufs inference.dataflow
 hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words generator command-line
-vocabs io prettyprint libc compiler.units ;
+vocabs io prettyprint libc compiler.units math.order ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
@@ -18,6 +18,8 @@ IN: bootstrap.compiler
 
 enable-compiler
 
+: compile-uncompiled [ compiled? not ] filter compile ;
+
 nl
 "Compiling..." write flush
 
@@ -42,38 +44,38 @@ nl
     find-pair-next namestack*
 
     bitand bitor bitxor bitnot
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
-    + 1+ 1- 2/ < <= > >= shift min
+    + 1+ 1- 2/ < <= > >= shift
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     new-sequence nth push pop peek
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     hashcode* = get set
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     . lines
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     malloc calloc free memcpy
-} compile
+} compile-uncompiled
 
-vocabs [ words [ compiled? not ] subset compile "." write flush ] each
+vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

core/bootstrap/image/image-tests.factor

@@ -1,5 +1,22 @@
 IN: bootstrap.image.tests
-USING: bootstrap.image bootstrap.image.private tools.test ;
+USING: bootstrap.image bootstrap.image.private tools.test
+kernel math ;
 
 \ ' must-infer
 \ write-image must-infer
+
+[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
+
+[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
+
+[ f ] [ [ 2drop 0 ] [ 2drop 0.0 ] eql? ] unit-test
+
+[ t ] [ [ 2drop 0 ] [ 2drop 0 ] eql? ] unit-test
+
+[ f ] [ \ + [ 2drop 0 ] eql? ] unit-test
+
+[ f ] [ 3 [ 0 1 2 ] eql? ] unit-test
+
+[ f ] [ 3 3.0 eql? ] unit-test
+
+[ t ] [ 4.0 4.0 eql? ] unit-test

core/bootstrap/image/image.factor

@@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
 vocabs.loader source-files definitions debugger float-arrays
 quotations.private sequences.private combinators
-io.encodings.binary ;
+io.encodings.binary math.order accessors ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
@@ -31,6 +31,43 @@ IN: bootstrap.image
 
 <PRIVATE
 
+! Object cache; we only consider numbers equal if they have the
+! same type
+TUPLE: id obj ;
+
+C: <id> id
+
+M: id hashcode* obj>> hashcode* ;
+
+GENERIC: (eql?) ( obj1 obj2 -- ? )
+
+: eql? ( obj1 obj2 -- ? )
+    [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
+
+M: integer (eql?) = ;
+
+M: sequence (eql?)
+    over sequence? [
+        2dup [ length ] bi@ =
+        [ [ eql? ] 2all? ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+M: object (eql?) = ;
+
+M: id equal?
+    over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+
+SYMBOL: objects
+
+: (objects) <id> objects get ; inline
+
+: lookup-object ( obj -- n/f ) (objects) at ;
+
+: put-object ( n obj -- ) (objects) set-at ;
+
+: cache-object ( obj quot -- value )
+    >r (objects) r> [ obj>> ] prepose cache ; inline
+
 ! Constants
 
 : image-magic HEX: 0f0e0d0c ; inline
@@ -61,9 +98,6 @@ IN: bootstrap.image
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
 
-! Object cache
-SYMBOL: objects
-
 ! Image output format
 SYMBOL: big-endian
 
@@ -187,7 +221,9 @@ GENERIC: ' ( obj -- ptr )
     2tri ;
 
 M: bignum '
-    bignum tag-number dup [ emit-bignum ] emit-object ;
+    [
+        bignum tag-number dup [ emit-bignum ] emit-object
+    ] cache-object ;
 
 ! Fixnums
 
@@ -202,9 +238,11 @@ M: fixnum '
 ! Floats
 
 M: float '
-    float tag-number dup [
+    [
-        align-here double>bits emit-64
+        float tag-number dup [
-    ] emit-object ;
+            align-here double>bits emit-64
+        ] emit-object
+    ] cache-object ;
 
 ! Special objects
 
@@ -243,7 +281,7 @@ M: f '
         ] bi
         \ word type-number object tag-number
         [ emit-seq ] emit-object
-    ] keep objects get set-at ;
+    ] keep put-object ;
 
 : word-error ( word msg -- * )
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
@@ -252,7 +290,7 @@ M: f '
     [ target-word ] keep or ;
 
 : fixup-word ( word -- offset )
-    transfer-word dup objects get at
+    transfer-word dup lookup-object
     [ ] [ "Not in image: " word-error ] ?if ;
 
 : fixup-words ( -- )
@@ -267,12 +305,12 @@ M: wrapper '
     [ emit ] emit-object ;
 
 ! Strings
-: emit-chars ( seq -- )
+: emit-bytes ( seq -- )
     bootstrap-cell <groups>
     big-endian get [ [ be> ] map ] [ [ le> ] map ] if
     emit-seq ;
 
-: pack-string ( string -- newstr )
+: pad-bytes ( seq -- newseq )
     dup length bootstrap-cell align 0 pad-right ;
 
 : emit-string ( string -- ptr )
@@ -280,13 +318,13 @@ M: wrapper '
         dup length emit-fixnum
         f ' emit
         f ' emit
-        pack-string emit-chars
+        pad-bytes emit-bytes
     ] emit-object ;
 
 M: string '
     #! We pool strings so that each string is only written once
     #! to the image
-    objects get [ emit-string ] cache ;
+    [ emit-string ] cache-object ;
 
 : assert-empty ( seq -- )
     length 0 assert= ;
@@ -297,7 +335,11 @@ M: string '
         [ 0 emit-fixnum ] emit-object
     ] bi* ;
 
-M: byte-array ' byte-array emit-dummy-array ;
+M: byte-array '
+    byte-array type-number object tag-number [
+        dup length emit-fixnum
+        pad-bytes emit-bytes
+    ] emit-object ;
 
 M: bit-array ' bit-array emit-dummy-array ;
 
@@ -305,18 +347,18 @@ M: float-array ' float-array emit-dummy-array ;
 
 ! Tuples
 : (emit-tuple) ( tuple -- pointer )
-    [ tuple>array 1 tail-slice ]
+    [ tuple>array rest-slice ]
     [ class transfer-word tuple-layout ] bi prefix [ ' ] map
     tuple type-number dup [ emit-seq ] emit-object ;
 
 : emit-tuple ( tuple -- pointer )
     dup class word-name "tombstone" =
-    [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
+    [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tuple-layout '
-    objects get [
+    [
         [
             {
                 [ layout-hashcode , ]
@@ -328,12 +370,12 @@ M: tuple-layout '
         ] { } make [ ' ] map
         \ tuple-layout type-number
         object tag-number [ emit-seq ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 M: tombstone '
     delegate
     "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first objects get [ emit-tuple ] cache ;
+    word-def first [ emit-tuple ] cache-object ;
 
 ! Arrays
 M: array '
@@ -343,7 +385,7 @@ M: array '
 ! Quotations
 
 M: quotation '
-    objects get [
+    [
         quotation-array '
         quotation type-number object tag-number [
             emit ! array
@@ -351,7 +393,7 @@ M: quotation '
             0 emit ! xt
             0 emit ! code
         ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 ! End of the image
 
@@ -362,8 +404,8 @@ M: quotation '
     [
         {
             dictionary source-files builtins
-            update-map class<-cache class-not-cache
+            update-map class<=-cache
-            classes-intersect-cache class-and-cache
+            class-not-cache classes-intersect-cache class-and-cache
             class-or-cache
         } [ dup get swap bootstrap-word set ] each
     ] H{ } make-assoc
@@ -433,7 +475,7 @@ M: quotation '
     "Writing image to " write
     architecture get boot-image-name resource-path
     [ write "..." print flush ]
-    [ binary <file-writer> [ (write-image) ] with-stream ] bi ;
+    [ binary [ (write-image) ] with-file-writer ] bi ;
 
 PRIVATE>
 

core/bootstrap/primitives.factor

@@ -59,6 +59,7 @@ num-types get f <array> builtins set
     "arrays"
     "bit-arrays"
     "byte-arrays"
+    "byte-vectors"
     "classes.private"
     "classes.tuple"
     "classes.tuple.private"
@@ -157,7 +158,7 @@ num-types get f <array> builtins set
 
 ! Catch-all class for providing a default method.
 "object" "kernel" create
-[ f builtins get [ ] subset union-class define-class ]
+[ f builtins get [ ] filter union-class define-class ]
 [ [ drop t ] "predicate" set-word-prop ]
 bi
 
@@ -452,6 +453,22 @@ tuple
     }
 } define-tuple-class
 
+"byte-vector" "byte-vectors" create
+tuple
+{
+    {
+        { "byte-array" "byte-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    }
+} define-tuple-class
+
 "curry" "kernel" create
 tuple
 {

core/bootstrap/stage2.factor

@@ -22,13 +22,13 @@ SYMBOL: bootstrap-time
     xref-sources ;
 
 : load-components ( -- )
-    "exclude" "include"
+    "include" "exclude"
-    [ get-global " " split [ empty? not ] subset ] bi@
+    [ get-global " " split [ empty? not ] filter ] bi@
     diff
     [ "bootstrap." prepend require ] each ;
 
 : count-words ( pred -- )
-    all-words swap subset length number>string write ;
+    all-words swap filter length number>string write ;
 
 : print-report ( time -- )
     1000 /i
@@ -44,10 +44,6 @@ SYMBOL: bootstrap-time
     "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
-
 ! We time bootstrap
 millis >r
 
@@ -91,7 +87,7 @@ f error-continuation set-global
             parse-command-line
             run-user-init
             "run" get run
-            stdio get [ stream-flush ] when*
+            output-stream get [ stream-flush ] when*
         ] [ print-error 1 exit ] recover
     ] set-boot-quot
 

core/bootstrap/syntax.factor

@@ -16,6 +16,7 @@ IN: bootstrap.syntax
     "?{"
     "BIN:"
     "B{"
+    "BV{"
     "C:"
     "CHAR:"
     "DEFER:"

core/byte-vectors/byte-vectors-docs.factor

@@ -19,7 +19,7 @@ $nl
 ABOUT: "byte-vectors"
 
 HELP: byte-vector
-{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;
 
 HELP: <byte-vector>
 { $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }

core/byte-vectors/byte-vectors.factor

@@ -1,20 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable byte-arrays prettyprint.backend
+sequences.private growable byte-arrays ;
-parser accessors ;
 IN: byte-vectors
 
-TUPLE: byte-vector underlying fill ;
-
-M: byte-vector underlying underlying>> { byte-array } declare ;
-
-M: byte-vector set-underlying (>>underlying) ;
-
-M: byte-vector length fill>> { array-capacity } declare ;
-
-M: byte-vector set-fill (>>fill) ;
-
 <PRIVATE
 
 : byte-array>vector ( byte-array length -- byte-vector )
@@ -43,9 +32,3 @@ M: byte-vector equal?
 M: byte-array new-resizable drop <byte-vector> ;
 
 INSTANCE: byte-vector growable
-
-: BV{ \ } [ >byte-vector ] parse-literal ; parsing
-
-M: byte-vector >pprint-sequence ;
-
-M: byte-vector pprint-delims drop \ BV{ \ } ;

core/checksums/checksums-docs.factor

@@ -0,0 +1,51 @@
+USING: help.markup help.syntax kernel math sequences quotations
+math.private byte-arrays strings ;
+IN: checksums
+
+HELP: checksum
+{ $class-description "The class of checksum algorithms." } ;
+
+HELP: hex-string
+{ $values { "seq" "a sequence" } { "str" "a string" } }
+{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
+{ $examples
+    { $example "USING: checksums io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
+}
+{ $notes "Numbers are zero-padded on the left." } ;
+
+HELP: checksum-stream
+{ $values { "stream" "an input stream" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data read from the stream." }
+{ $side-effects "stream" } ;
+
+HELP: checksum-bytes
+{ $values { "bytes" "a sequence of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a sequence." } ;
+
+HELP: checksum-lines
+{ $values { "lines" "a sequence of sequences of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a sequence." } ;
+
+HELP: checksum-file
+{ $values { "path" "a pathname specifier" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a file." } ;
+
+ARTICLE: "checksums" "Checksums"
+"A " { $emphasis "checksum" } " is a function mapping sequences of bytes to fixed-length strings. While checksums are not one-to-one, a good checksum should have a low probability of collision. Additionally, some checksum algorithms are designed to be hard to reverse, in the sense that finding an input string which hashes to a given checksum string requires a brute-force search."
+$nl
+"Checksums are instances of a class:"
+{ $subsection checksum }
+"Operations on checksums:"
+{ $subsection checksum-bytes }
+{ $subsection checksum-stream }
+{ $subsection checksum-lines }
+"Checksums should implement at least one of " { $link checksum-bytes } " and " { $link checksum-stream } ". Implementing " { $link checksum-lines } " is optional."
+$nl
+"Utilities:"
+{ $subsection checksum-file }
+{ $subsection hex-string }
+"Checksum implementations:"
+{ $subsection "checksums.crc32" }
+{ $vocab-subsection "MD5 checksum" "checksums.md5" }
+{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
+{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } ;

core/checksums/checksums-tests.factor

@@ -0,0 +1,7 @@
+IN: checksums.tests
+USING: checksums tools.test ;
+
+\ checksum-bytes must-infer
+\ checksum-stream must-infer
+\ checksum-lines must-infer
+\ checksum-file must-infer

core/checksums/checksums.factor

@@ -0,0 +1,25 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math.parser io io.streams.byte-array
+io.encodings.binary io.files kernel ;
+IN: checksums
+
+MIXIN: checksum
+
+GENERIC: checksum-bytes ( bytes checksum -- value )
+
+GENERIC: checksum-stream ( stream checksum -- value )
+
+GENERIC: checksum-lines ( lines checksum -- value )
+
+M: checksum checksum-bytes >r binary <byte-reader> r> checksum-stream ;
+
+M: checksum checksum-stream >r contents r> checksum-bytes ;
+
+M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ;
+
+: checksum-file ( path checksum -- value )
+    >r binary <file-reader> r> checksum-stream ;
+
+: hex-string ( seq -- str )
+    [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;

core/checksums/crc32/crc32-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax math ;
+IN: checksums.crc32
+
+HELP: crc32
+{ $class-description "The CRC32 checksum algorithm." } ;
+
+ARTICLE: "checksums.crc32" "CRC32 checksum"
+"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
+{ $subsection crc32 } ;
+
+ABOUT: "checksums.crc32"

core/checksums/crc32/crc32-tests.factor

@@ -0,0 +1,6 @@
+USING: checksums checksums.crc32 kernel math tools.test namespaces ;
+
+[ B{ 0 0 0 0 } ] [ "" crc32 checksum-bytes ] unit-test
+
+[ B{ HEX: cb HEX: f4 HEX: 39 HEX: 26 } ] [ "123456789" crc32 checksum-bytes ] unit-test
+

core/checksums/crc32/crc32.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences sequences.private namespaces
 words io io.binary io.files io.streams.string quotations
-definitions ;
+definitions checksums ;
-IN: io.crc32
+IN: checksums.crc32
 
 : crc32-polynomial HEX: edb88320 ; inline
 
@@ -20,10 +20,20 @@ IN: io.crc32
     mask-byte crc32-table nth-unsafe >bignum
     swap -8 shift bitxor ; inline
 
-: crc32 ( seq -- n )
+SINGLETON: crc32
-    >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
 
-: lines-crc32 ( seq -- n )
+INSTANCE: crc32 checksum
-    HEX: ffffffff tuck [
+
-        [ (crc32) ] each CHAR: \n (crc32)
+: init-crc32 drop >r HEX: ffffffff dup r> ; inline
-    ] reduce bitxor ;
+
+: finish-crc32 bitxor 4 >be ; inline
+
+M: crc32 checksum-bytes
+    init-crc32
+    [ (crc32) ] each
+    finish-crc32 ;
+
+M: crc32 checksum-lines
+    init-crc32
+    [ [ (crc32) ] each CHAR: \n (crc32) ] each
+    finish-crc32 ;

core/classes/algebra/algebra-docs.factor

@@ -1,14 +1,14 @@
-USING: help.markup help.syntax kernel classes ;
+USING: help.markup help.syntax kernel classes words
+checksums checksums.crc32 sequences math ;
 IN: classes.algebra
 
 ARTICLE: "class-operations" "Class operations"
 "Set-theoretic operations on classes:"
 { $subsection class< }
+{ $subsection class<= }
 { $subsection class-and }
 { $subsection class-or }
 { $subsection classes-intersect? }
-"Topological sort:"
-{ $subsection sort-classes }
 { $subsection min-class }
 "Low-level implementation detail:"
 { $subsection class-types }
@@ -17,6 +17,29 @@ ARTICLE: "class-operations" "Class operations"
 { $subsection class-types }
 { $subsection class-tags } ;
 
+ARTICLE: "class-linearization" "Class linearization"
+"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:"
+{ $list
+    "If a generic word defines a method on a mixin class A and another class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both."
+    { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." }
+}
+"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:"
+{ $list
+    "Built-in classes and tuple classes"
+    "Predicate classes"
+    "Union classes"
+    "Mixin classes"
+}
+"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class."
+$nl
+"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used."
+$nl
+"Operations:"
+{ $subsection class< }
+{ $subsection sort-classes }
+"Metaclass order:"
+{ $subsection rank-class } ;
+
 HELP: flatten-builtin-class
 { $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
 { $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
@@ -29,14 +52,14 @@ HELP: class-types
 { $values { "class" class } { "seq" "an increasing sequence of integers" } }
 { $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
 
-HELP: class<
+HELP: class<=
 { $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
 { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
 { $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
 
 HELP: sort-classes
 { $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
-{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
+{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;
 
 HELP: class-or
 { $values { "first" class } { "second" class } { "class" class } }

core/classes/algebra/algebra-tests.factor

@@ -4,9 +4,9 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
-random inference effects kernel.private sbufs ;
+random inference effects kernel.private sbufs math.order ;
 
-: class= [ class< ] 2keep swap class< and ;
+: class= [ class<= ] [ swap class<= ] 2bi and ;
 
 : class-and* >r class-and r> class= ;
 
@@ -38,43 +38,43 @@ UNION: both first-one union-class ;
 
 [ f ] [ number vector class-and sequence classes-intersect? ] unit-test
 
-[ t ] [ \ fixnum \ integer class< ] unit-test
+[ t ] [ \ fixnum \ integer class<= ] unit-test
-[ t ] [ \ fixnum \ fixnum class< ] unit-test
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test
-[ f ] [ \ integer \ fixnum class< ] unit-test
+[ f ] [ \ integer \ fixnum class<= ] unit-test
-[ t ] [ \ integer \ object class< ] unit-test
+[ t ] [ \ integer \ object class<= ] unit-test
-[ f ] [ \ integer \ null class< ] unit-test
+[ f ] [ \ integer \ null class<= ] unit-test
-[ t ] [ \ null \ object class< ] unit-test
+[ t ] [ \ null \ object class<= ] unit-test
 
-[ t ] [ \ generic \ word class< ] unit-test
+[ t ] [ \ generic \ word class<= ] unit-test
-[ f ] [ \ word \ generic class< ] unit-test
+[ f ] [ \ word \ generic class<= ] unit-test
 
-[ f ] [ \ reversed \ slice class< ] unit-test
+[ f ] [ \ reversed \ slice class<= ] unit-test
-[ f ] [ \ slice \ reversed class< ] unit-test
+[ f ] [ \ slice \ reversed class<= ] unit-test
 
 PREDICATE: no-docs < word "documentation" word-prop not ;
 
 UNION: no-docs-union no-docs integer ;
 
-[ t ] [ no-docs no-docs-union class< ] unit-test
+[ t ] [ no-docs no-docs-union class<= ] unit-test
-[ f ] [ no-docs-union no-docs class< ] unit-test
+[ f ] [ no-docs-union no-docs class<= ] unit-test
 
 TUPLE: a ;
 TUPLE: b ;
 UNION: c a b ;
 
-[ t ] [ \ c \ tuple class< ] unit-test
+[ t ] [ \ c \ tuple class<= ] unit-test
-[ f ] [ \ tuple \ c class< ] unit-test
+[ f ] [ \ tuple \ c class<= ] unit-test
 
-[ t ] [ \ tuple-class \ class class< ] unit-test
+[ t ] [ \ tuple-class \ class class<= ] unit-test
-[ f ] [ \ class \ tuple-class class< ] unit-test
+[ f ] [ \ class \ tuple-class class<= ] unit-test
 
 TUPLE: tuple-example ;
 
-[ t ] [ \ null \ tuple-example class< ] unit-test
+[ t ] [ \ null \ tuple-example class<= ] unit-test
-[ f ] [ \ object \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
-[ f ] [ \ object \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
-[ t ] [ \ tuple-example \ tuple class< ] unit-test
+[ t ] [ \ tuple-example \ tuple class<= ] unit-test
-[ f ] [ \ tuple \ tuple-example class< ] unit-test
+[ f ] [ \ tuple \ tuple-example class<= ] unit-test
 
 TUPLE: a1 ;
 TUPLE: b1 ;
@@ -84,57 +84,57 @@ UNION: x1 a1 b1 ;
 UNION: y1 a1 c1 ;
 UNION: z1 b1 c1 ;
 
-[ f ] [ z1 x1 y1 class-and class< ] unit-test
+[ f ] [ z1 x1 y1 class-and class<= ] unit-test
 
-[ t ] [ x1 y1 class-and a1 class< ] unit-test
+[ t ] [ x1 y1 class-and a1 class<= ] unit-test
 
 [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
 
-[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
 
-[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
 
 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
 
 [ f ] [ growable \ hi-tag classes-intersect? ] unit-test
 
 [ t ] [
-    growable tuple sequence class-and class<
+    growable tuple sequence class-and class<=
 ] unit-test
 
 [ t ] [
-    growable assoc class-and tuple class<
+    growable assoc class-and tuple class<=
 ] unit-test
 
-[ t ] [ object \ f \ f class-not class-or class< ] unit-test
+[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
 
 [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
 
 [ f ] [ integer integer class-not classes-intersect? ] unit-test
 
-[ t ] [ array number class-not class< ] unit-test
+[ t ] [ array number class-not class<= ] unit-test
 
-[ f ] [ bignum number class-not class< ] unit-test
+[ f ] [ bignum number class-not class<= ] unit-test
 
 [ vector ] [ vector class-not class-not ] unit-test
 
-[ t ] [ fixnum fixnum bignum class-or class< ] unit-test
+[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
 
-[ f ] [ fixnum class-not integer class-and array class< ] unit-test
+[ f ] [ fixnum class-not integer class-and array class<= ] unit-test
 
-[ f ] [ fixnum class-not integer class< ] unit-test
+[ f ] [ fixnum class-not integer class<= ] unit-test
 
-[ f ] [ number class-not array class< ] unit-test
+[ f ] [ number class-not array class<= ] unit-test
 
-[ f ] [ fixnum class-not array class< ] unit-test
+[ f ] [ fixnum class-not array class<= ] unit-test
 
-[ t ] [ number class-not integer class-not class< ] unit-test
+[ t ] [ number class-not integer class-not class<= ] unit-test
 
 [ t ] [ vector array class-not class-and vector class= ] unit-test
 
 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
 
-[ f ] [ fixnum class-not integer class< ] unit-test
+[ f ] [ fixnum class-not integer class<= ] unit-test
 
 [ t ] [ null class-not object class= ] unit-test
 
@@ -147,7 +147,7 @@ UNION: z1 b1 c1 ;
 [ t ] [
     fixnum class-not
     fixnum fixnum class-not class-or
-    class<
+    class<=
 ] unit-test
 
 ! Test method inlining
@@ -241,3 +241,23 @@ UNION: z1 b1 c1 ;
         =
     ] unit-test
 ] times
+
+SINGLETON: xxx
+UNION: yyy xxx ;
+
+[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
+[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
+
+[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
+[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
+
+TUPLE: xa ;
+TUPLE: xb ;
+TUPLE: xc < xa ;
+TUPLE: xd < xb ;
+TUPLE: xe ;
+TUPLE: xf < xb ;
+TUPLE: xg < xb ;
+TUPLE: xh < xb ;
+
+[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test

core/classes/algebra/algebra.factor

@@ -2,16 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes classes.builtin combinators accessors
 sequences arrays vectors assocs namespaces words sorting layouts
-math hashtables kernel.private sets ;
+math hashtables kernel.private sets math.order ;
 IN: classes.algebra
 
 : 2cache ( key1 key2 assoc quot -- value )
     >r >r 2array r> [ first2 ] r> compose cache ; inline
 
-DEFER: (class<)
+DEFER: (class<=)
 
-: class< ( first second -- ? )
+: class<= ( first second -- ? )
-    class<-cache get [ (class<) ] 2cache ;
+    class<=-cache get [ (class<=) ] 2cache ;
 
 DEFER: (class-not)
 
@@ -45,31 +45,31 @@ TUPLE: anonymous-complement class ;
 
 C: <anonymous-complement> anonymous-complement
 
-: superclass< ( first second -- ? )
+: superclass<= ( first second -- ? )
-    >r superclass r> class< ;
+    >r superclass r> class<= ;
 
-: left-union-class< ( first second -- ? )
+: left-union-class<= ( first second -- ? )
-    >r members r> [ class< ] curry all? ;
+    >r members r> [ class<= ] curry all? ;
 
-: right-union-class< ( first second -- ? )
+: right-union-class<= ( first second -- ? )
-    members [ class< ] with contains? ;
+    members [ class<= ] with contains? ;
 
 : left-anonymous-union< ( first second -- ? )
-    >r members>> r> [ class< ] curry all? ;
+    >r members>> r> [ class<= ] curry all? ;
 
 : right-anonymous-union< ( first second -- ? )
-    members>> [ class< ] with contains? ;
+    members>> [ class<= ] with contains? ;
 
 : left-anonymous-intersection< ( first second -- ? )
-    >r members>> r> [ class< ] curry contains? ;
+    >r members>> r> [ class<= ] curry contains? ;
 
 : right-anonymous-intersection< ( first second -- ? )
-    members>> [ class< ] with all? ;
+    members>> [ class<= ] with all? ;
 
 : anonymous-complement< ( first second -- ? )
-    [ class>> ] bi@ swap class< ;
+    [ class>> ] bi@ swap class<= ;
 
-: (class<) ( first second -- -1/0/1 )  
+: (class<=) ( first second -- -1/0/1 )  
     {
         { [ 2dup eq? ] [ 2drop t ] }
         { [ dup object eq? ] [ 2drop t ] }
@@ -77,13 +77,13 @@ C: <anonymous-complement> anonymous-complement
         { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
         { [ over anonymous-union? ] [ left-anonymous-union< ] }
         { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
-        { [ over members ] [ left-union-class< ] }
+        { [ over members ] [ left-union-class<= ] }
         { [ dup anonymous-union? ] [ right-anonymous-union< ] }
         { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
         { [ over anonymous-complement? ] [ 2drop f ] }
         { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
-        { [ dup members ] [ right-union-class< ] }
+        { [ dup members ] [ right-union-class<= ] }
-        { [ over superclass ] [ superclass< ] }
+        { [ over superclass ] [ superclass<= ] }
         [ 2drop f ]
     } cond ;
 
@@ -94,7 +94,7 @@ C: <anonymous-complement> anonymous-complement
     members>> [ classes-intersect? ] with all? ;
 
 : anonymous-complement-intersect? ( first second -- ? )
-    class>> class< not ;
+    class>> class<= not ;
 
 : union-class-intersect? ( first second -- ? )
     members [ classes-intersect? ] with contains? ;
@@ -103,7 +103,7 @@ C: <anonymous-complement> anonymous-complement
     {
         { [ over tuple eq? ] [ 2drop t ] }
         { [ over builtin-class? ] [ 2drop f ] }
-        { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
+        { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
         [ swap classes-intersect? ]
     } cond ;
 
@@ -145,8 +145,8 @@ C: <anonymous-complement> anonymous-complement
 
 : (class-and) ( first second -- class )
     {
-        { [ 2dup class< ] [ drop ] }
+        { [ 2dup class<= ] [ drop ] }
-        { [ 2dup swap class< ] [ nip ] }
+        { [ 2dup swap class<= ] [ nip ] }
         { [ 2dup classes-intersect? not ] [ 2drop null ] }
         { [ dup members ] [ right-union-and ] }
         { [ dup anonymous-union? ] [ right-anonymous-union-and ] }
@@ -165,8 +165,8 @@ C: <anonymous-complement> anonymous-complement
 
 : (class-or) ( first second -- class )
     {
-        { [ 2dup class< ] [ nip ] }
+        { [ 2dup class<= ] [ nip ] }
-        { [ 2dup swap class< ] [ drop ] }
+        { [ 2dup swap class<= ] [ drop ] }
         { [ dup anonymous-union? ] [ right-anonymous-union-or ] }
         { [ over anonymous-union? ] [ left-anonymous-union-or ] }
         [ 2array <anonymous-union> ]
@@ -180,22 +180,27 @@ C: <anonymous-complement> anonymous-complement
         [ <anonymous-complement> ]
     } cond ;
 
+: class< ( first second -- ? )
+    {
+        { [ 2dup class<= not ] [ 2drop f ] }
+        { [ 2dup swap class<= not ] [ 2drop t ] }
+        [ [ rank-class ] bi@ < ]
+    } cond ;
+
 : largest-class ( seq -- n elt )
-    dup [
+    dup [ [ class< ] with contains? not ] curry find-last
-        [ 2dup class< >r swap class< not r> and ]
+    [ "Topological sort failed" throw ] unless* ;
-        with subset empty?
-    ] curry find [ "Topological sort failed" throw ] unless* ;
 
 : sort-classes ( seq -- newseq )
-    >vector
+    [ [ word-name ] compare ] sort >vector
     [ dup empty? not ]
     [ dup largest-class >r over delete-nth r> ]
     [ ] unfold nip ;
 
 : min-class ( class seq -- class/f )
-    over [ classes-intersect? ] curry subset
+    over [ classes-intersect? ] curry filter
     dup empty? [ 2drop f ] [
-        tuck [ class< ] with all? [ peek ] [ drop f ] if
+        tuck [ class<= ] with all? [ peek ] [ drop f ] if
     ] if ;
 
 : (flatten-class) ( class -- )
@@ -212,7 +217,7 @@ C: <anonymous-complement> anonymous-complement
 
 : flatten-builtin-class ( class -- assoc )
     flatten-class [
-        dup tuple class< [ 2drop tuple tuple ] when
+        dup tuple class<= [ 2drop tuple tuple ] when
     ] assoc-map ;
 
 : class-types ( class -- seq )

core/classes/builtin/builtin.factor

@@ -16,3 +16,5 @@ PREDICATE: builtin-class < class
 M: hi-tag class hi-tag type>class ;
 
 M: object class tag type>class ;
+
+M: builtin-class rank-class drop 0 ;

core/classes/classes-docs.factor

@@ -47,6 +47,7 @@ $nl
 $nl
 "Classes can be inspected and operated upon:"
 { $subsection "class-operations" }
+{ $subsection "class-linearization" }
 { $see-also "class-index" } ;
 
 ABOUT: "classes"
@@ -55,7 +56,7 @@ HELP: class
 { $values { "object" object } { "class" class } }
 { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
 { $class-description "The class of all class words." }
-{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
+{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
 
 HELP: classes
 { $values { "seq" "a sequence of class words" } }
@@ -63,7 +64,7 @@ HELP: classes
 
 HELP: tuple-class
 { $class-description "The class of tuple class words." }
-{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
+{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
 
 HELP: update-map
 { $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;

core/classes/classes-tests.factor

@@ -18,14 +18,14 @@ GENERIC: generic-update-test ( x -- y )
 
 M: union-1 generic-update-test drop "union-1" ;
 
-[ f ] [ bignum union-1 class< ] unit-test
+[ f ] [ bignum union-1 class<= ] unit-test
-[ t ] [ union-1 number class< ] unit-test
+[ t ] [ union-1 number class<= ] unit-test
 [ "union-1" ] [ 1.0 generic-update-test ] unit-test
 
 "IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
 
-[ t ] [ bignum union-1 class< ] unit-test
+[ t ] [ bignum union-1 class<= ] unit-test
-[ f ] [ union-1 number class< ] unit-test
+[ f ] [ union-1 number class<= ] unit-test
 [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
 
 "IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
@@ -52,7 +52,7 @@ M: sequence-mixin collection-size length ;
 
 M: assoc-mixin collection-size assoc-size ;
 
-[ t ] [ array sequence-mixin class< ] unit-test
+[ t ] [ array sequence-mixin class<= ] unit-test
 [ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
 [ 3 ] [ { 1 2 3 } collection-size ] unit-test
 [ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
@@ -67,14 +67,14 @@ MIXIN: mx1
 
 INSTANCE: integer mx1
 
-[ t ] [ integer mx1 class< ] unit-test
+[ t ] [ integer mx1 class<= ] unit-test
-[ t ] [ mx1 integer class< ] unit-test
+[ t ] [ mx1 integer class<= ] unit-test
-[ t ] [ mx1 number class< ] unit-test
+[ t ] [ mx1 number class<= ] unit-test
 
 "IN: classes.tests USE: arrays INSTANCE: array mx1" eval
 
-[ t ] [ array mx1 class< ] unit-test
+[ t ] [ array mx1 class<= ] unit-test
-[ f ] [ mx1 number class< ] unit-test
+[ f ] [ mx1 number class<= ] unit-test
 
 [ \ mx1 forget ] with-compilation-unit
 
@@ -94,14 +94,14 @@ UNION: redefine-bug-1 fixnum ;
 
 UNION: redefine-bug-2 redefine-bug-1 quotation ;
 
-[ t ] [ fixnum redefine-bug-2 class< ] unit-test
+[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
-[ t ] [ quotation redefine-bug-2 class< ] unit-test
+[ t ] [ quotation redefine-bug-2 class<= ] unit-test
 
 [ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
 
-[ t ] [ bignum redefine-bug-1 class< ] unit-test
+[ t ] [ bignum redefine-bug-1 class<= ] unit-test
-[ f ] [ fixnum redefine-bug-2 class< ] unit-test
+[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
-[ t ] [ bignum redefine-bug-2 class< ] unit-test
+[ t ] [ bignum redefine-bug-2 class<= ] unit-test
 
 USE: io.streams.string
 

core/classes/classes.factor

@@ -5,21 +5,21 @@ slots.private namespaces sequences strings words vectors math
 quotations combinators sorting effects graphs vocabs ;
 IN: classes
 
-SYMBOL: class<-cache
+SYMBOL: class<=-cache
 SYMBOL: class-not-cache
 SYMBOL: classes-intersect-cache
 SYMBOL: class-and-cache
 SYMBOL: class-or-cache
 
 : init-caches ( -- )
-    H{ } clone class<-cache set
+    H{ } clone class<=-cache set
     H{ } clone class-not-cache set
     H{ } clone classes-intersect-cache set
     H{ } clone class-and-cache set
     H{ } clone class-or-cache set ;
 
 : reset-caches ( -- )
-    class<-cache get clear-assoc
+    class<=-cache get clear-assoc
     class-not-cache get clear-assoc
     classes-intersect-cache get clear-assoc
     class-and-cache get clear-assoc
@@ -33,7 +33,7 @@ PREDICATE: class < word
 PREDICATE: tuple-class < class
     "metaclass" word-prop tuple-class eq? ;
 
-: classes ( -- seq ) all-words [ class? ] subset ;
+: classes ( -- seq ) all-words [ class? ] filter ;
 
 : predicate-word ( word -- predicate )
     [ word-name "?" append ] keep word-vocabulary create ;
@@ -57,6 +57,8 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;
 
+GENERIC: rank-class ( class -- n )
+
 GENERIC: reset-class ( class -- )
 
 M: word reset-class drop ;

core/classes/mixin/mixin.factor

@@ -9,6 +9,8 @@ PREDICATE: mixin-class < union-class "mixin" word-prop ;
 M: mixin-class reset-class
     { "class" "metaclass" "members" "mixin" } reset-props ;
 
+M: mixin-class rank-class drop 3 ;
+
 : redefine-mixin-class ( class members -- )
     dupd define-union-class
     t "mixin" set-word-prop ;
@@ -31,7 +33,7 @@ TUPLE: check-mixin-class mixin ;
     >r >r check-mixin-class 2dup members memq? r> r> if ; inline
 
 : change-mixin-class ( class mixin quot -- )
-    [ members swap bootstrap-word ] swap compose keep
+    [ members swap bootstrap-word ] prepose keep
     swap redefine-mixin-class ; inline
 
 : add-mixin-instance ( class mixin -- )

core/classes/predicate/predicate.factor

@@ -30,3 +30,5 @@ M: predicate-class reset-class
         "predicate-definition"
         "superclass"
     } reset-props ;
+
+M: predicate-class rank-class drop 1 ;

core/classes/singleton/singleton-docs.factor

@@ -18,7 +18,7 @@ HELP: SINGLETON:
     "Defines a new singleton class. The class word itself is the sole instance of the singleton class."
 }
 { $examples
-    { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+    { $example "USING: classes.singleton kernel io ;" "IN: scratchpad" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
 } ;
 
 HELP: define-singleton-class

core/classes/tuple/tuple-docs.factor

@@ -341,6 +341,7 @@ HELP: new
 { $examples
     { $example
         "USING: kernel prettyprint ;"
+        "IN: scratchpad"
         "TUPLE: employee number name department ;"
         "employee new ."
         "T{ employee f f f f }"

core/classes/tuple/tuple-tests.factor

@@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
 calendar prettyprint io.streams.string splitting inspector
-columns ;
+columns math.order ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -88,7 +88,7 @@ C: <empty> empty
 [ t length ] [ object>> t eq? ] must-fail-with
 
 [ "<constructor-test>" ]
-[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
+[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
 
 TUPLE: size-test a b c d ;
 
@@ -233,8 +233,8 @@ TUPLE: laptop < computer battery ;
 C: <laptop> laptop
 
 [ t ] [ laptop tuple-class? ] unit-test
-[ t ] [ laptop tuple class< ] unit-test
+[ t ] [ laptop tuple class<= ] unit-test
-[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop computer class<= ] unit-test
 [ t ] [ laptop computer classes-intersect? ] unit-test
 
 [ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
@@ -266,8 +266,8 @@ TUPLE: server < computer rackmount ;
 C: <server> server
 
 [ t ] [ server tuple-class? ] unit-test
-[ t ] [ server tuple class< ] unit-test
+[ t ] [ server tuple class<= ] unit-test
-[ t ] [ server computer class< ] unit-test
+[ t ] [ server computer class<= ] unit-test
 [ t ] [ server computer classes-intersect? ] unit-test
 
 [ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
@@ -286,8 +286,8 @@ test-server-slot-values
 [ f ] [ "server" get laptop? ] unit-test
 [ f ] [ "laptop" get server? ] unit-test
 
-[ f ] [ server laptop class< ] unit-test
+[ f ] [ server laptop class<= ] unit-test
-[ f ] [ laptop server class< ] unit-test
+[ f ] [ laptop server class<= ] unit-test
 [ f ] [ laptop server classes-intersect? ] unit-test
 
 [ f ] [ 1 2 <computer> laptop? ] unit-test
@@ -306,9 +306,9 @@ TUPLE: electronic-device ;
 
 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
 
-[ f ] [ electronic-device laptop class< ] unit-test
+[ f ] [ electronic-device laptop class<= ] unit-test
-[ t ] [ server electronic-device class< ] unit-test
+[ t ] [ server electronic-device class<= ] unit-test
-[ t ] [ laptop server class-or electronic-device class< ] unit-test
+[ t ] [ laptop server class-or electronic-device class<= ] unit-test
 
 [ t ] [ "laptop" get electronic-device? ] unit-test
 [ t ] [ "laptop" get computer? ] unit-test
@@ -542,3 +542,15 @@ TUPLE: another-forget-accessors-test ;
 
 ! Missing error check
 [ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+
+TUPLE: subclass-forget-test ;
+
+TUPLE: subclass-forget-test-1 < subclass-forget-test ;
+TUPLE: subclass-forget-test-2 < subclass-forget-test ;
+TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
+
+[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+
+[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
+[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
+[ subclass-forget-test-3 new ] must-fail

core/classes/tuple/tuple.factor

@@ -102,7 +102,7 @@ ERROR: bad-superclass class ;
     dup tuple-predicate-quot define-predicate ;
 
 : superclass-size ( class -- n )
-    superclasses 1 head-slice*
+    superclasses but-last-slice
     [ slot-names length ] map sum ;
 
 : generate-tuple-slots ( class slots -- slot-specs )
@@ -166,7 +166,7 @@ M: tuple-class update-class
     3tri ;
 
 : subclasses ( class -- classes )
-    class-usages keys [ tuple-class? ] subset ;
+    class-usages keys [ tuple-class? ] filter ;
 
 : each-subclass ( class quot -- )
     >r subclasses r> each ; inline
@@ -226,6 +226,8 @@ M: tuple-class reset-class
         } reset-props
     ] bi ;
 
+M: tuple-class rank-class drop 0 ;
+
 M: tuple clone
     (clone) dup delegate clone over set-delegate ;
 

core/classes/union/union.factor

@@ -30,3 +30,5 @@ M: union-class update-class define-union-predicate ;
 
 M: union-class reset-class
     { "class" "metaclass" "members" } reset-props ;
+
+M: union-class rank-class drop 2 ;

core/combinators/combinators-docs.factor

@@ -95,7 +95,7 @@ HELP: case
     "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
     $nl
     "The following two phrases are equivalent:"
-    { $code "{ { X [ Y ] } { Y [ T ] } } case" }
+    { $code "{ { X [ Y ] } { Z [ T ] } } case" }
     { $code "dup X = [ drop Y ] [ dup Z = [ drop T ] [ no-case ] if ] if" }
 }
 { $examples

core/combinators/combinators.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: combinators
 USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors
-hashtables sorting words sets ;
+hashtables sorting words sets math.order ;
+IN: combinators
 
 : cleave ( x seq -- )
     [ call ] with each ;
@@ -150,7 +150,7 @@ M: hashtable hashcode*
         drop
     ] [
         dup length 4 <=
-        over keys [ word? ] contains? or
+        over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
         [
             linear-case-quot
         ] [

core/command-line/command-line.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: command-line
 USING: init continuations debugger hashtables io kernel
 kernel.private namespaces parser sequences strings system
 splitting io.files ;
+IN: command-line
 
 : run-bootstrap-init ( -- )
     "user-init" get [
@@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
     "none" "run" set-global ;
 
 : parse-command-line ( -- )
-    cli-args [ cli-arg ] subset
+    cli-args [ cli-arg ] filter
     "script" get [ script-mode ] when
     ignore-cli-args? [ drop ] [ [ run-file ] each ] if
     "e" get [ eval ] when* ;

core/compiler/compiler.factor

@@ -4,38 +4,55 @@ USING: kernel namespaces arrays sequences io inference.backend
 inference.state generator debugger words compiler.units
 continuations vocabs assocs alien.compiler dlists optimizer
 definitions math compiler.errors threads graphs generic
-inference ;
+inference combinators ;
 IN: compiler
 
 : ripple-up ( word -- )
     compiled-usage [ drop queue-compile ] assoc-each ;
 
 : save-effect ( word effect -- )
-    over "compiled-uses" word-prop [
-        2dup swap "compiled-effect" word-prop =
-        [ over ripple-up ] unless
-    ] when
-    "compiled-effect" set-word-prop ;
-
-: finish-compile ( word effect dependencies -- )
-    >r dupd save-effect r>
-    over compiled-unxref
-    over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
-
-: compile-succeeded ( word -- effect dependencies )
     [
-        [ word-dataflow optimize ] keep dup generate
+        over "compiled-effect" word-prop = [
-    ] computing-dependencies ;
+            dup "compiled-uses" word-prop
+            [ dup ripple-up ] when
+        ] unless drop
+    ]
+    [ "compiled-effect" set-word-prop ] 2bi ;
+
+: compile-begins ( word -- )
+    f swap compiler-error ;
 
 : compile-failed ( word error -- )
-    f pick compiled get set-at
+    [ swap compiler-error ]
-    swap compiler-error ;
+    [
+        drop
+        [ f swap compiled get set-at ]
+        [ f save-effect ]
+        bi
+    ] 2bi ;
+
+: compile-succeeded ( effect word -- )
+    [ swap save-effect ]
+    [ compiled-unxref ]
+    [
+        dup compiled-crossref?
+        [ dependencies get compiled-xref ] [ drop ] if
+    ] tri ;
 
 : (compile) ( word -- )
-    f over compiler-error
+    [
-    [ dup compile-succeeded finish-compile ]
+        H{ } clone dependencies set
-    [ dupd compile-failed f save-effect ]
+
-    recover ;
+        {
+            [ compile-begins ]
+            [
+                [ word-dataflow ] [ compile-failed return ] recover
+                optimize
+            ]
+            [ dup generate ]
+            [ compile-succeeded ]
+        } cleave
+    ] curry with-return ;
 
 : compile-loop ( assoc -- )
     dup assoc-empty? [ drop ] [

core/compiler/errors/errors-docs.factor

@@ -21,19 +21,19 @@ HELP: compiler-error
 
 HELP: compiler-error.
 { $values { "error" "an error" } { "word" word } }
-{ $description "Prints a compiler error to the " { $link stdio } " stream." } ;
+{ $description "Prints a compiler error to " { $link output-stream } "." } ;
 
 HELP: compiler-errors.
 { $values { "type" symbol } }
-{ $description "Prints compiler errors to the " { $link stdio } " stream. The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
+{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
 HELP: :errors
-{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
+{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
 
 HELP: :warnings
-{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
+{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
 
 HELP: :linkage
-{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
+{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
 
 { :errors :warnings } related-words
 

core/compiler/errors/errors.factor

@@ -27,7 +27,7 @@ SYMBOL: with-compiler-errors?
 : errors-of-type ( type -- assoc )
     compiler-errors get-global
     swap [ >r nip compiler-error-type r> eq? ] curry
-    assoc-subset ;
+    assoc-filter ;
 
 : compiler-errors. ( type -- )
     errors-of-type >alist sort-keys

core/compiler/tests/intrinsics.factor

@@ -1,11 +1,11 @@
-IN: compiler.tests
 USING: arrays compiler.units kernel kernel.private math
 math.constants 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
+sbufs.private strings.private slots.private alien math.order
 alien.accessors alien.c-types alien.syntax alien.strings
 namespaces libc sequences.private io.encodings.ascii ;
+IN: compiler.tests
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test

core/compiler/tests/stack-trace.factor

@@ -13,11 +13,11 @@ words splitting sorting ;
 [ baz ] [ 3 = ] must-fail-with
 [ t ] [
     symbolic-stack-trace
-    [ word? ] subset
+    [ word? ] filter
     { baz bar foo throw } tail?
 ] unit-test
 
-: bleh [ 3 + ] map [ 0 > ] subset ;
+: bleh [ 3 + ] map [ 0 > ] filter ;
 
 : stack-trace-contains? symbolic-stack-trace memq? ;
 

core/compiler/units/units.factor

@@ -53,7 +53,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     [ definitions-changed ] with each ;
 
 : changed-vocabs ( assoc -- vocabs )
-    [ drop word? ] assoc-subset
+    [ drop word? ] assoc-filter
     [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
 
 : updated-definitions ( -- assoc )
@@ -73,7 +73,7 @@ SYMBOL: outdated-tuples
 SYMBOL: update-tuples-hook
 
 : call-recompile-hook ( -- )
-    changed-definitions get keys [ word? ] subset
+    changed-definitions get keys [ word? ] filter
     compiled-usages recompile-hook get call ;
 
 : call-update-tuples-hook ( -- )

core/continuations/continuations-docs.factor

@@ -34,7 +34,7 @@ $nl
 { $code
     "<external-resource> ... do stuff ... dispose"
 }
-"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
+"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
 
 ARTICLE: "errors" "Error handling"
 "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."

core/continuations/continuations-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel math namespaces io tools.test sequences vectors
 continuations debugger parser memory arrays words
-kernel.private ;
+kernel.private accessors ;
 IN: continuations.tests
 
 : (callcc1-test)
@@ -39,7 +39,7 @@ IN: continuations.tests
 
 "!!! The following error is part of the test" print
 
-[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test
+[ ] [ [ [ "2 car" ] eval ] try ] unit-test
 
 [ f throw ] must-fail
 
@@ -100,3 +100,22 @@ SYMBOL: error-counter
     [ 3 ] [ always-counter get ] unit-test
     [ 1 ] [ error-counter get ] unit-test
 ] with-scope
+
+TUPLE: dispose-error ;
+
+M: dispose-error dispose 3 throw ;
+
+TUPLE: dispose-dummy disposed? ;
+
+M: dispose-dummy dispose t >>disposed? drop ;
+
+T{ dispose-error } "a" set
+T{ dispose-dummy } "b" set
+
+[ f ] [ "b" get disposed?>> ] unit-test
+
+[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
+
+[ t ] [ "b" get disposed?>> ] unit-test
+
+[ ] [ [ return ] with-return ] unit-test

core/continuations/continuations.factor

@@ -101,6 +101,14 @@ PRIVATE>
 : continue ( continuation -- )
     f swap continue-with ;
 
+SYMBOL: return-continuation
+
+: with-return ( quot -- )
+    [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
+
+: return ( -- )
+    return-continuation get continue ;
+
 GENERIC: compute-restarts ( error -- seq )
 
 <PRIVATE
@@ -138,6 +146,11 @@ SYMBOL: thread-error-hook
 
 GENERIC: dispose ( object -- )
 
+: dispose-each ( seq -- )
+    [
+        [ [ dispose ] curry [ , ] recover ] each
+    ] { } make dup empty? [ drop ] [ peek rethrow ] if ;
+
 : with-disposal ( object quot -- )
     over [ dispose ] curry [ ] cleanup ; inline
 

core/cpu/ppc/architecture/architecture.factor

@@ -4,7 +4,7 @@ USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
 kernel kernel.private math memory namespaces sequences words
 assocs generator generator.registers generator.fixup system
 layouts classes words.private alien combinators
-compiler.constants ;
+compiler.constants math.order ;
 IN: cpu.ppc.architecture
 
 ! PowerPC register assignments

core/cpu/ppc/assembler/assembler.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: generator.fixup generic kernel memory namespaces
+words math math.bitfields math.order io.binary ;
 IN: cpu.ppc.assembler
-USING: generator.fixup generic kernel math memory namespaces
-words math.bitfields io.binary ;
 
 ! See the Motorola or IBM documentation for details. The opcode
 ! names are standard, and the operand order is the same as in

core/cpu/x86/64/64.factor

@@ -181,7 +181,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
 : split-struct ( pairs -- seq )
     [
         [ 8 mod zero? [ t , ] when , ] assoc-each
-    ] { } make { t } split [ empty? not ] subset ;
+    ] { } make { t } split [ empty? not ] filter ;
 
 : flatten-large-struct ( type -- )
     heap-size cell align

core/cpu/x86/architecture/architecture.factor

@@ -3,7 +3,8 @@
 USING: alien alien.c-types alien.compiler arrays
 cpu.x86.assembler cpu.architecture kernel kernel.private math
 memory namespaces sequences words generator generator.registers
-generator.fixup system layouts combinators compiler.constants ;
+generator.fixup system layouts combinators compiler.constants
+math.order ;
 IN: cpu.x86.architecture
 
 HOOK: ds-reg cpu

core/cpu/x86/assembler/assembler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator.fixup io.binary kernel
 combinators kernel.private math namespaces parser sequences
-words system layouts ;
+words system layouts math.order ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86 and AMD64.

core/debugger/debugger-docs.factor

@@ -1,7 +1,7 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
 help generic.standard continuations system debugger.private
-io.files.private ;
+io.files.private listener ;
 IN: debugger
 
 ARTICLE: "errors-assert" "Assertions"
@@ -64,7 +64,7 @@ HELP: :3
 
 HELP: error.
 { $values { "error" "an error" } }
-{ $contract "Print an error to the " { $link stdio } " stream.  You can define methods on this generic word to print human-readable messages for custom errors." }
+{ $contract "Print an error to " { $link output-stream } ". You can define methods on this generic word to print human-readable messages for custom errors." }
 { $notes "Code should call " { $link print-error } " instead, which handles the case where the printing of the error itself throws an error." } ;
 
 HELP: error-help
@@ -75,19 +75,15 @@ HELP: error-help
 
 HELP: print-error
 { $values { "error" "an error" } }
-{ $description "Print an error to the " { $link stdio } " stream." }
+{ $description "Print an error to " { $link output-stream } "." }
 { $notes "This word is called by the listener and other tools which report caught errors to the user." } ;
 
 HELP: restarts.
-{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
+{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
-
-HELP: error-hook
-{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
-{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
 
 HELP: try
 { $values { "quot" "a quotation" } }
-{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
+{ $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." }
 { $examples
     "The following example prints an error and keeps going:"
     { $code

core/debugger/debugger.factor

@@ -1,12 +1,13 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions generic hashtables inspector io kernel
-math namespaces prettyprint sequences assocs sequences.private
+math namespaces prettyprint prettyprint.config sequences assocs
-strings io.styles vectors words system splitting math.parser
+sequences.private strings io.styles vectors words system
-classes.tuple continuations continuations.private combinators
+splitting math.parser classes.tuple continuations
-generic.math io.streams.duplex classes.builtin classes
+continuations.private combinators generic.math
-compiler.units generic.standard vocabs threads threads.private
+classes.builtin classes compiler.units generic.standard vocabs
-init kernel.private libc io.encodings accessors ;
+threads threads.private init kernel.private libc io.encodings
+mirrors accessors math.order ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -63,17 +64,14 @@ M: string error. print ;
     [ global [ "Error in print-error!" print drop ] bind ]
     recover ;
 
-SYMBOL: error-hook
+: print-error-and-restarts ( error -- )
-
-[
     print-error
     restarts.
     nl
-    "Type :help for debugging help." print flush
+    "Type :help for debugging help." print flush ;
-] error-hook set-global
 
 : try ( quot -- )
-    [ error-hook get call ] recover ;
+    [ print-error-and-restarts ] recover ;
 
 ERROR: assert got expect ;
 
@@ -96,10 +94,10 @@ M: relative-overflow summary
 
 : assert-depth ( quot -- )
     >r datastack r> swap slip >r datastack r>
-    2dup [ length ] compare sgn {
+    2dup [ length ] compare {
-        { -1 [ trim-datastacks nip relative-underflow ] }
+        { +lt+ [ trim-datastacks nip relative-underflow ] }
-        { 0 [ 2drop ] }
+        { +eq+ [ 2drop ] }
-        { 1 [ trim-datastacks drop relative-overflow ] }
+        { +gt+ [ trim-datastacks drop relative-overflow ] }
     } case ; inline
 
 : expired-error. ( obj -- )
@@ -208,9 +206,6 @@ M: no-next-method summary
 M: inconsistent-next-method summary
     drop "Executing call-next-method with inconsistent parameters" ;
 
-M: stream-closed-twice summary
-    drop "Attempt to perform I/O on closed stream" ;
-
 M: check-method summary
     drop "Invalid parameters for create-method" ;
 
@@ -240,6 +235,15 @@ M: condition error-help error>> error-help ;
 
 M: assert summary drop "Assertion failed" ;
 
+M: assert error.
+    "Assertion failed" print
+    standard-table-style [
+        15 length-limit set
+        5 line-limit set
+        [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
+        [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
+    ] tabular-output ;
+
 M: immutable summary drop "Sequence is immutable" ;
 
 M: redefine-error error.
@@ -266,8 +270,7 @@ M: double-free summary
 M: realloc-error summary
     drop "Memory reallocation failed" ;
 
-: error-in-thread. ( -- )
+: error-in-thread. ( thread -- )
-    error-thread get-global
     "Error in thread " write
     [
         dup thread-id #
@@ -281,7 +284,7 @@ M: thread error-in-thread ( error thread -- )
         die drop
     ] [
         global [
-            error-in-thread. print-error flush
+            error-thread get-global error-in-thread. print-error flush
         ] bind
     ] if ;
 
@@ -289,6 +292,12 @@ M: encode-error summary drop "Character encoding error" ;
 
 M: decode-error summary drop "Character decoding error" ;
 
+M: no-such-slot summary drop "No such slot" ;
+
+M: immutable-slot summary drop "Slot is immutable" ;
+
+M: bad-create summary drop "Bad parameters to create" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

core/definitions/definitions-tests.factor

@@ -1,6 +1,6 @@
-IN: definitions.tests
 USING: tools.test generic kernel definitions sequences
 compiler.units words ;
+IN: definitions.tests
 
 GENERIC: some-generic ( a -- b )
 

core/dlists/dlists-tests.factor

@@ -79,7 +79,7 @@ IN: dlists.tests
         [ dlist-push-all ] keep
         [ dlist-delete-all ] keep
         dlist>array
-    ] 2keep diff assert-same-elements
+    ] 2keep swap diff assert-same-elements
 ] unit-test
 
 [ ] [

core/dlists/dlists.factor

@@ -153,7 +153,7 @@ PRIVATE>
     drop ;
 
 : dlist-each ( dlist quot -- )
-    [ obj>> ] swap compose dlist-each-node ; inline
+    [ obj>> ] prepose dlist-each-node ; inline
 
 : dlist-slurp ( dlist quot -- )
     over dlist-empty?

core/generator/fixup/fixup.factor

@@ -3,7 +3,7 @@
 USING: arrays generic assocs hashtables
 kernel kernel.private math namespaces sequences words
 quotations strings alien.strings layouts system combinators
-math.bitfields words.private cpu.architecture ;
+math.bitfields words.private cpu.architecture math.order ;
 IN: generator.fixup
 
 : no-stack-frame -1 ; inline

core/generator/registers/registers.factor

@@ -4,7 +4,7 @@ USING: arrays assocs classes classes.private classes.algebra
 combinators cpu.architecture generator.fixup hashtables kernel
 layouts math namespaces quotations sequences system vectors
 words effects alien byte-arrays bit-arrays float-arrays
-accessors sets ;
+accessors sets math.order ;
 IN: generator.registers
 
 SYMBOL: +input+
@@ -181,11 +181,11 @@ INSTANCE: constant value
 
 : %unbox-c-ptr ( dst src -- )
     dup operand-class {
-        { [ dup \ f class< ] [ drop %unbox-f ] }
+        { [ dup \ f class<= ] [ drop %unbox-f ] }
-        { [ dup simple-alien class< ] [ drop %unbox-alien ] }
+        { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
-        { [ dup byte-array class< ] [ drop %unbox-byte-array ] }
+        { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
-        { [ dup bit-array class< ] [ drop %unbox-byte-array ] }
+        { [ dup bit-array class<= ] [ drop %unbox-byte-array ] }
-        { [ dup float-array class< ] [ drop %unbox-byte-array ] }
+        { [ dup float-array class<= ] [ drop %unbox-byte-array ] }
         [ drop %unbox-any-c-ptr ]
     } cond ; inline
 
@@ -314,7 +314,7 @@ M: phantom-retainstack finalize-height
 : (live-locs) ( phantom -- seq )
     #! Discard locs which haven't moved
     [ phantom-locs* ] [ stack>> ] bi zip
-    [ live-loc? ] assoc-subset
+    [ live-loc? ] assoc-filter
     values ;
 
 : live-locs ( -- seq )
@@ -372,7 +372,7 @@ M: value (lazy-load)
 : (compute-free-vregs) ( used class -- vector )
     #! Find all vregs in 'class' which are not in 'used'.
     [ vregs length reverse ] keep
-    [ <vreg> ] curry map diff
+    [ <vreg> ] curry map swap diff
     >vector ;
 
 : compute-free-vregs ( -- )
@@ -484,7 +484,7 @@ M: loc lazy-store
 
 : substitute-vregs ( values vregs -- )
     [ vreg-substitution ] 2map
-    [ substitute-vreg? ] assoc-subset >hashtable
+    [ substitute-vreg? ] assoc-filter >hashtable
     [ >r stack>> r> substitute-here ] curry each-phantom ;
 
 : set-operand ( value var -- )
@@ -569,7 +569,7 @@ M: loc lazy-store
     {
         { f [ drop t ] }
         { known-tag [ class-tag >boolean ] }
-        [ class< ]
+        [ class<= ]
     } case ;
 
 : spec-matches? ( value spec -- ? )
@@ -644,7 +644,7 @@ PRIVATE>
 UNION: immediate fixnum POSTPONE: f ;
 
 : operand-immediate? ( operand -- ? )
-    operand-class immediate class< ;
+    operand-class immediate class<= ;
 
 : phantom-push ( obj -- )
     1 phantom-datastack get adjust-phantom

core/generic/generic-docs.factor

@@ -4,22 +4,22 @@ generic.standard generic.math combinators ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
-"Consider the case where a generic word has methods on two classes, say A and B, which share a non-empty intersection. If the generic word is called on an object which is an instance of both A and B, a choice of method must be made. If A is a subclass of B, the method for A to be called; this makes sense, because we're defining general behavior for instances of B, and refining it for instances of A. Conversely, if B is a subclass of A, then we expect B's method to be called. However, if neither is a subclass of the other, we have an ambiguous situation and undefined behavior will result. Either the method for A or B will be called, and there is no way to predict ahead of time."
+"Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in linear order (" { $link "class-linearization" } ")."
-$nl
-"The generic word system linearly orders all the methods on a generic word by their class. Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in order. If methods are defined on overlapping classes, this order will fail to be unique and the problem described above can occur."
 $nl
 "Here is an example:"
 { $code
     "GENERIC: explain"
-    "M: number explain drop \"an integer\" print ;"
-    "M: sequence explain drop \"a sequence\" print ;"
     "M: object explain drop \"an object\" print ;"
+    "M: number explain drop \"a number\" print ;"
+    "M: sequence explain drop \"a sequence\" print ;"
 }
-"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. As a result, the outcome of calling " { $snippet "bar" } " with an " { $link integer } " on the stack is undefined - either one of the two methods may be called. This situation can lead to subtle bugs. To avoid it, explicitly disambiguate the method order by defining a method on the intersection. If in this case we want integers to behave like numbers, we would also define:"
+"The linear order is the following, from least-specific to most-specific:"
-{ $code "M: integer explain drop \"an integer\" print ;" }
+{ $code "{ object sequence number }" }
-"On the other hand, if we want integers to behave like sequences here, we could define:"
+"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:"
 { $code "M: integer explain drop \"a sequence\" print ;" }
-"The " { $link order } " word can be useful to clarify method dispatch order."
+"Now, the linear order is the following, from least-specific to most-specific:"
+{ $code "{ object sequence number integer }" }
+"The " { $link order } " word can be useful to clarify method dispatch order:"
 { $subsection order } ;
 
 ARTICLE: "generic-introspection" "Generic word introspection"

core/generic/generic-tests.factor

@@ -143,7 +143,7 @@ GENERIC: generic-forget-test-1
 M: integer generic-forget-test-1 / ;
 
 [ t ] [
-    \ / usage [ word? ] subset
+    \ / usage [ word? ] filter
     [ word-name "generic-forget-test-1/integer" = ] contains?
 ] unit-test
 
@@ -152,7 +152,7 @@ M: integer generic-forget-test-1 / ;
 ] unit-test
 
 [ f ] [
-    \ / usage [ word? ] subset
+    \ / usage [ word? ] filter
     [ word-name "generic-forget-test-1/integer" = ] contains?
 ] unit-test
 
@@ -161,7 +161,7 @@ GENERIC: generic-forget-test-2
 M: sequence generic-forget-test-2 = ;
 
 [ t ] [
-    \ = usage [ word? ] subset
+    \ = usage [ word? ] filter
     [ word-name "generic-forget-test-2/sequence" = ] contains?
 ] unit-test
 
@@ -170,7 +170,7 @@ M: sequence generic-forget-test-2 = ;
 ] unit-test
 
 [ f ] [
-    \ = usage [ word? ] subset
+    \ = usage [ word? ] filter
     [ word-name "generic-forget-test-2/sequence" = ] contains?
 ] unit-test
 

core/generic/generic.factor

@@ -35,7 +35,7 @@ PREDICATE: method-spec < pair
 GENERIC: effective-method ( ... generic -- method )
 
 : next-method-class ( class generic -- class/f )
-    order [ class< ] with subset reverse dup length 1 =
+    order [ class<= ] with filter reverse dup length 1 =
     [ drop f ] [ second ] if ;
 
 : next-method ( class generic -- class/f )
@@ -137,7 +137,7 @@ M: method-body forget*
     all-words [
         "methods" word-prop keys
         swap [ key? ] curry contains?
-    ] with subset ;
+    ] with filter ;
 
 : implementors ( class -- seq )
     dup associate implementors* ;

core/generic/math/math.factor

@@ -3,27 +3,27 @@
 USING: arrays generic hashtables kernel kernel.private
 math namespaces sequences words quotations layouts combinators
 sequences.private classes classes.builtin classes.algebra
-definitions ;
+definitions math.order ;
 IN: generic.math
 
 PREDICATE: math-class < class
     dup null bootstrap-word eq? [
         drop f
     ] [
-        number bootstrap-word class<
+        number bootstrap-word class<=
     ] if ;
 
 : last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
 
 : math-precedence ( class -- pair )
     {
-        { [ dup null class< ] [ drop { -1 -1 } ] }
+        { [ dup null class<= ] [ drop { -1 -1 } ] }
         { [ dup math-class? ] [ class-types last/first ] }
         [ drop { 100 100 } ]
     } cond ;
     
 : math-class-max ( class class -- class )
-    [ [ math-precedence ] compare 0 > ] most ;
+    [ [ math-precedence ] compare +gt+ eq? ] most ;
 
 : (math-upgrade) ( max class -- quot )
     dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;

core/generic/standard/engines/engines.factor

@@ -26,8 +26,8 @@ M: method-body engine>quot 1quotation ;
     alist>quot ;
 
 : split-methods ( assoc class -- first second )
-    [ [ nip class< not ] curry assoc-subset ]
+    [ [ nip class<= not ] curry assoc-filter ]
-    [ [ nip class<     ] curry assoc-subset ] 2bi ;
+    [ [ nip class<=     ] curry assoc-filter ] 2bi ;
 
 : convert-methods ( assoc class word -- assoc' )
     over >r >r split-methods dup assoc-empty? [

core/generic/standard/engines/predicate/predicate.factor

@@ -11,14 +11,14 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
     [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
 
 : keep-going? ( assoc -- ? )
-    assumed get swap second first class< ;
+    assumed get swap second first class<= ;
 
 : prune-redundant-predicates ( assoc -- default assoc' )
     {
         { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
         { [ dup length 1 = ] [ first second { } ] }
-        { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
+        { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
-        [ [ first second ] [ 1 tail-slice ] bi ]
+        [ [ first second ] [ rest-slice ] bi ]
     } cond ;
 
 : sort-methods ( assoc -- assoc' )

core/generic/standard/engines/tuple/tuple.factor

@@ -127,8 +127,6 @@ M: echelon-dispatch-engine engine>quot
     1 slot { tuple-layout } declare
     5 slot ; inline
 
-: unclip-last [ 1 head* ] [ peek ] bi ;
-
 M: tuple-dispatch-engine engine>quot
     [
         picker %

core/hashtables/hashtables-tests.factor

@@ -10,7 +10,7 @@ continuations ;
 [ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
 
 [ V{ } ]
-[ 1000 [ dup sq swap "testhash" get at = not ] subset ]
+[ 1000 [ dup sq swap "testhash" get at = not ] filter ]
 unit-test
 
 [ t ]

core/heaps/heaps-docs.factor

@@ -1,4 +1,5 @@
-USING: heaps.private help.markup help.syntax kernel math assocs ;
+USING: heaps.private help.markup help.syntax kernel math assocs
+math.order ;
 IN: heaps
 
 ARTICLE: "heaps" "Heaps"

core/heaps/heaps-tests.factor

@@ -3,7 +3,7 @@
 
 USING: arrays kernel math namespaces tools.test
 heaps heaps.private math.parser random assocs sequences sorting
-accessors ;
+accessors math.order ;
 IN: heaps.tests
 
 [ <min-heap> heap-pop ] must-fail

core/heaps/heaps.factor

@@ -2,7 +2,7 @@
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences arrays assocs sequences.private
-growable accessors ;
+growable accessors math.order ;
 IN: heaps
 
 MIXIN: priority-queue
@@ -92,11 +92,11 @@ M: priority-queue heap-size ( heap -- n )
 
 GENERIC: heap-compare ( pair1 pair2 heap -- ? )
 
-: (heap-compare) drop [ entry-key ] compare 0 ; inline
+: (heap-compare) drop [ entry-key ] compare ; inline
 
-M: min-heap heap-compare (heap-compare) > ;
+M: min-heap heap-compare (heap-compare) +gt+ eq? ;
 
-M: max-heap heap-compare (heap-compare) < ;
+M: max-heap heap-compare (heap-compare) +lt+ eq? ;
 
 : heap-bounds-check? ( m heap -- ? )
     heap-size >= ; inline

core/inference/backend/backend.factor

@@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
 io.streams.string kernel math namespaces parser prettyprint
 sequences strings vectors words quotations effects classes
 continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple accessors ;
+generic.standard.engines.tuple accessors math.order ;
 IN: inference.backend
 
 : recursive-label ( word -- label/f )
@@ -60,7 +60,7 @@ M: object value-literal \ literal-expected inference-warning ;
 : value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
 
 : add-inputs ( seq stack -- n stack )
-    tuck [ length ] compare dup 0 >
+    tuck [ length ] bi@ - dup 0 >
     [ dup value-vector [ swapd push-all ] keep ]
     [ drop 0 swap ] if ;
 
@@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
 
 : balanced? ( in out -- ? )
     [ dup [ length - ] [ 2drop f ] if ] 2map
-    [ ] subset all-equal? ;
+    [ ] filter all-equal? ;
 
 TUPLE: unbalanced-branches-error quots in out ;
 
@@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
     2dup balanced? [
         over supremum -rot
         [ >r dupd r> unify-inputs ] 2map
-        [ ] subset unify-stacks
+        [ ] filter unify-stacks
         rot drop
     ] [
         unbalanced-branches-error

core/inference/class/class-tests.factor

@@ -5,7 +5,7 @@ sequences words inference.class quotations alien
 alien.c-types strings sbufs sequences.private
 slots.private combinators definitions compiler.units
 system layouts vectors optimizer.math.partial accessors
-optimizer.inlining ;
+optimizer.inlining math.order ;
 
 [ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
 

core/inference/class/class.factor

@@ -143,7 +143,7 @@ M: literal-constraint constraint-satisfied?
     [ swap literal>> eql? ] [ 2drop f ] if ;
 
 M: class-constraint constraint-satisfied?
-    [ value>> value-class* ] [ class>> ] bi class< ;
+    [ value>> value-class* ] [ class>> ] bi class<= ;
 
 M: pair apply-constraint
     first2 2dup constraints get set-at
@@ -153,7 +153,7 @@ M: pair constraint-satisfied?
     first constraint-satisfied? ;
 
 : extract-keys ( seq assoc -- newassoc )
-    [ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
+    [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
 
 : annotate-node ( node -- )
     #! Annotate the node with the currently-inferred set of

core/inference/dataflow/dataflow.factor

@@ -300,7 +300,7 @@ SYMBOL: node-stack
     dup in-d>> first node-class ;
 
 : active-children ( node -- seq )
-    children>> [ last-node ] map [ #terminate? not ] subset ;
+    children>> [ last-node ] map [ #terminate? not ] filter ;
 
 DEFER: #tail?
 

core/inference/inference-docs.factor

@@ -135,7 +135,7 @@ HELP: infer
 
 HELP: infer.
 { $values { "quot" "a quotation" } }
-{ $description "Attempts to infer the quotation's stack effect, and prints this data to the " { $link stdio } " stream." }
+{ $description "Attempts to infer the quotation's stack effect, and prints this data to " { $link output-stream } "." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
 { infer infer. } related-words

core/inference/state/state-tests.factor

@@ -1,5 +1,9 @@
 IN: inference.state.tests
-USING: tools.test inference.state words ;
+USING: tools.test inference.state words kernel namespaces ;
+
+: computing-dependencies ( quot -- dependencies )
+    H{ } clone [ dependencies rot with-variable ] keep ;
+    inline
 
 SYMBOL: a
 SYMBOL: b

core/inference/state/state.factor

@@ -36,10 +36,6 @@ SYMBOL: dependencies
         2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
     ] [ 3drop ] if ;
 
-: computing-dependencies ( quot -- dependencies )
-    H{ } clone [ dependencies rot with-variable ] keep ;
-    inline
-
 ! Did the current control-flow path throw an error?
 SYMBOL: terminated?
 

core/inference/transforms/transforms.factor

@@ -32,7 +32,7 @@ IN: inference.transforms
         drop [ no-case ]
     ] [
         dup peek quotation? [
-            dup peek swap 1 head*
+            dup peek swap but-last
         ] [
             [ no-case ] swap
         ] if case>quot

core/inspector/inspector-docs.factor

@@ -108,4 +108,4 @@ HELP: me
 HELP: inspector-hook
 { $var-description "A quotation with stack effect " { $snippet "( obj -- )" } ", called by the inspector to display an overview of an object."
 $nl
-"The default implementation calls " { $link describe } " which outputs on the " { $link stdio } " stream, but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;
+"The default implementation calls " { $link describe } " which outputs on " { $link output-stream } ", but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;

core/inspector/inspector.factor

@@ -96,7 +96,7 @@ SYMBOL: +editable+
 
 : namestack. ( seq -- )
     [
-        [ global eq? not ] subset
+        [ global eq? not ] filter
         [ keys ] map concat prune
     ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
 

core/io/backend/backend-docs.factor

@@ -9,4 +9,4 @@ HELP: init-io
 { $contract "Initializes the I/O system. Called on startup." } ;
 
 HELP: init-stdio
-{ $contract "Initializes the global " { $link stdio } " stream.  Called on startup." } ;
+{ $contract "Initializes the global " { $link input-stream } " and " { $link output-stream } ".  Called on startup." } ;

core/io/backend/backend.factor

@@ -11,8 +11,10 @@ HOOK: init-io io-backend ( -- )
 HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
 
 : init-stdio ( -- )
-    (init-stdio) utf8 <encoder> stderr set-global
+    (init-stdio)
-    utf8 <encoder-duplex> stdio set-global ;
+    [ utf8 <decoder> input-stream set-global ]
+    [ utf8 <encoder> output-stream set-global ]
+    [ utf8 <encoder> error-stream set-global ] tri* ;
 
 HOOK: io-multiplex io-backend ( ms -- )
 

core/io/crc32/crc32-docs.factor

@@ -1,17 +0,0 @@
-USING: help.markup help.syntax math ;
-IN: io.crc32
-
-HELP: crc32
-{ $values { "seq" "a sequence of bytes" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
-
-HELP: lines-crc32
-{ $values { "seq" "a sequence of strings" } { "n" integer } }
-{ $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 lines-crc32 } ;
-
-ABOUT: "io.crc32"

core/io/crc32/crc32-tests.factor

@@ -1,5 +0,0 @@
-USING: io.crc32 kernel math tools.test namespaces ;
-
-[ 0 ] [ "" crc32 ] unit-test
-[ HEX: cbf43926 ] [ "123456789" crc32 ] unit-test
-

core/io/encodings/encodings-docs.factor

@@ -12,8 +12,7 @@ ARTICLE: "io.encodings" "I/O encodings"
 ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
 "The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
 { $subsection <encoder> }
-{ $subsection <decoder> }
+{ $subsection <decoder> } ;
-{ $subsection <encoder-duplex> } ;
 
 HELP: <encoder>
 { $values { "stream" "an output stream" }
@@ -29,16 +28,6 @@ HELP: <decoder>
 { $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
 $low-level-note ;
 
-HELP: <encoder-duplex>
-{ $values { "stream-in" "an input stream" }
-    { "stream-out" "an output stream" }
-    { "encoding" "an encoding descriptor" }
-    { "duplex" "an encoded duplex stream" } }
-{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." }
-$low-level-note ;
-
-{ <encoder> <decoder> <encoder-duplex> } related-words
-
 ARTICLE: "encodings-descriptors" "Encoding descriptors"
 "An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
 { $subsection "io.encodings.binary" }

core/io/encodings/encodings-tests.factor

@@ -2,35 +2,35 @@ USING: io.files io.streams.string io
 tools.test kernel io.encodings.ascii ;
 IN: io.streams.encodings.tests
 
-: <resource-reader> ( resource -- stream )
-    resource-path ascii <file-reader> ;
-    
 [ { } ]
-[ "core/io/test/empty-file.txt" <resource-reader> lines ]
+[ "resource:core/io/test/empty-file.txt" ascii <file-reader> lines ]
 unit-test
 
 : lines-test ( stream -- line1 line2 )
-    [ readln readln ] with-stream ;
+    [ readln readln ] with-input-stream ;
 
 [
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/windows-eol.txt" <resource-reader> lines-test
+    "resource:core/io/test/windows-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test
 
 [
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/mac-os-eol.txt" <resource-reader> lines-test
+    "resource:core/io/test/mac-os-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test
 
 [
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/unix-eol.txt" <resource-reader> lines-test
+    "resource:core/io/test/unix-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test
 
 [

core/io/encodings/encodings.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces growable
 strings io classes continuations combinators io.styles
-io.streams.plain splitting io.streams.duplex byte-arrays
+io.streams.plain splitting byte-arrays sequences.private
-sequences.private accessors ;
+accessors ;
 IN: io.encodings
 
 ! The encoding descriptor protocol
@@ -131,6 +131,3 @@ INSTANCE: encoder plain-writer
     over decoder? [ >r decoder-stream r> ] when <decoder> ;
 
 PRIVATE>
-
-: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
-    tuck reencode >r redecode r> <duplex-stream> ;

core/io/files/files-docs.factor

@@ -184,8 +184,12 @@ HELP: +unknown+
 { $description "A unknown file type." } ;
 
 HELP: <file-reader>
-{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
+{
-    { "stream" "an input stream" } }
+  $values
+  { "path" "a pathname string" }
+  { "encoding" "an encoding descriptor" }
+  { "stream" "an input stream" }
+}
 { $description "Outputs an input stream for reading from the specified pathname using the given encoding." }
 { $errors "Throws an error if the file is unreadable." } ;
 
@@ -201,17 +205,17 @@ HELP: <file-appender>
 
 HELP: with-file-reader
 { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
-{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
+{ $description "Opens a file for reading and calls the quotation using " { $link with-input-stream } "." }
 { $errors "Throws an error if the file is unreadable." } ;
 
 HELP: with-file-writer
 { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
-{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-stream } "." }
+{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-output-stream } "." }
 { $errors "Throws an error if the file cannot be opened for writing." } ;
 
 HELP: with-file-appender
 { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
-{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." }
+{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-output-stream } "." }
 { $errors "Throws an error if the file cannot be opened for writing." } ;
 
 HELP: set-file-lines
@@ -273,7 +277,7 @@ HELP: append-path
 
 HELP: prepend-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
-{ $description "Concatenates two pathnames." } ;
+{ $description "Appends str1 onto str2 to form a pathname." } ;
 
 { append-path prepend-path } related-words
 

core/io/files/files-tests.factor

@@ -135,13 +135,13 @@ strings accessors io.encodings.utf8 ;
 
 [ { { "kernel" t } } ] [
     "core" resource-path [
-        "." directory [ first "kernel" = ] subset
+        "." directory [ first "kernel" = ] filter
     ] with-directory
 ] unit-test
 
 [ { { "kernel" t } } ] [
     "resource:core" [
-        "." directory [ first "kernel" = ] subset
+        "." directory [ first "kernel" = ] filter
     ] with-directory
 ] unit-test
 

core/io/files/files.factor

@@ -3,7 +3,7 @@
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
 system combinators splitting sbufs continuations io.encodings
-io.encodings.binary init accessors ;
+io.encodings.binary init accessors math.order ;
 IN: io.files
 
 HOOK: (file-reader) io-backend ( path -- stream )
@@ -25,13 +25,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
     <file-reader> lines ;
 
 : with-file-reader ( path encoding quot -- )
-    >r <file-reader> r> with-stream ; inline
+    >r <file-reader> r> with-input-stream ; inline
 
 : file-contents ( path encoding -- str )
     <file-reader> contents ;
 
 : with-file-writer ( path encoding quot -- )
-    >r <file-writer> r> with-stream ; inline
+    >r <file-writer> r> with-output-stream ; inline
 
 : set-file-lines ( seq path encoding -- )
     [ [ print ] each ] with-file-writer ;
@@ -40,7 +40,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
     [ write ] with-file-writer ;
 
 : with-file-appender ( path encoding quot -- )
-    >r <file-appender> r> with-stream ; inline
+    >r <file-appender> r> with-output-stream ; inline
 
 ! Pathnames
 : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
@@ -54,7 +54,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
     [ path-separator? ] left-trim ;
 
 : last-path-separator ( path -- n ? )
-    [ length 1- ] keep [ path-separator? ] find-last* ;
+    [ length 1- ] keep [ path-separator? ] find-last-from ;
 
 HOOK: root-directory? io-backend ( path -- ? )
 
@@ -92,7 +92,7 @@ ERROR: no-parent-directory path ;
 : append-path-empty ( path1 path2 -- path' )
     {
         { [ dup head.? ] [
-            1 tail left-trim-separators append-path-empty
+            rest left-trim-separators append-path-empty
         ] }
         { [ dup head..? ] [ drop no-parent-directory ] }
         [ nip ]
@@ -122,7 +122,7 @@ PRIVATE>
         { [ over empty? ] [ append-path-empty ] }
         { [ dup empty? ] [ drop ] }
         { [ dup absolute-path? ] [ nip ] }
-        { [ dup head.? ] [ 1 tail left-trim-separators append-path ] }
+        { [ dup head.? ] [ rest left-trim-separators append-path ] }
         { [ dup head..? ] [
             2 tail left-trim-separators
             >r parent-directory r> append-path
@@ -232,7 +232,7 @@ HOOK: make-directory io-backend ( path -- )
         dup string?
         [ tuck append-path directory? 2array ] [ nip ] if
     ] with map
-    [ first { "." ".." } member? not ] subset ;
+    [ first { "." ".." } member? not ] filter ;
 
 : directory ( path -- seq )
     normalize-directory dup (directory) fixup-directory ;

core/io/io-docs.factor

@@ -5,7 +5,7 @@ IN: io
 ARTICLE: "stream-protocol" "Stream protocol"
 "The stream protocol consists of a large number of generic words, many of which are optional."
 $nl
-"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in a " { $link with-stream } ". This leads more simpler, more reusable and more robust code."
+"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
 $nl
 "All streams must implement the " { $link dispose } " word in addition to the stream protocol."
 $nl
@@ -26,24 +26,24 @@ $nl
 { $subsection stream-write-table }
 { $see-also "io.timeouts" } ;
 
-ARTICLE: "stdio" "The default stream"
+ARTICLE: "stdio" "Default input and output streams"
-"Most I/O code only operates on one stream at a time. The " { $emphasis "default stream" } " is an implicit parameter used by many I/O words designed for this particular use-case. Using this idiom improves code in three ways:"
+"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
 { $list
     { "Code becomes simpler because there is no need to keep a stream around on the stack." }
-    { "Code becomes more robust because " { $link with-stream } " automatically closes the stream if there is an error." }
+    { "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
-    { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-stream } " to specify the source or destination for I/O operations." }
+    { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
 }
 "For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
 { $code
     "USING: continuations kernel io io.files math.parser splitting ;"
-    "\"data.txt\" <file-reader>"
+    "\"data.txt\" utf8 <file-reader>"
     "dup stream-readln number>string over stream-read 16 group"
     "swap dispose"
 }
 "This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
 { $code
     "USING: continuations kernel io io.files math.parser splitting ;"
-    "\"data.txt\" <file-reader> ["
+    "\"data.txt\" utf8 <file-reader> ["
     "    dup stream-readln number>string over stream-read"
     "    16 group"
     "] with-disposal"
@@ -51,17 +51,34 @@ ARTICLE: "stdio" "The default stream"
 "This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
 { $code
     "USING: continuations kernel io io.files math.parser splitting ;"
-    "\"data.txt\" <file-reader> ["
+    "\"data.txt\" utf8 <file-reader> ["
     "    readln number>string read 16 group"
-    "] with-stream"
+    "] with-input-stream"
 }
-"The default stream is stored in a dynamically-scoped variable:"
+"An even better implementation that takes advantage of a utility word:"
-{ $subsection stdio }
+{ $code
-"Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user."
+    "USING: continuations kernel io io.files math.parser splitting ;"
+    "\"data.txt\" utf8 ["
+    "    readln number>string read 16 group"
+    "] with-file-reader"
+}
+"The default input stream is stored in a dynamically-scoped variable:"
+{ $subsection input-stream }
+"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
+$nl
+"Words reading from the default input stream:"
 { $subsection read1 }
 { $subsection read }
 { $subsection read-until }
 { $subsection readln }
+"A pair of combinators for rebinding the " { $link input-stream } " variable:"
+{ $subsection with-input-stream }
+{ $subsection with-input-stream* }
+"The default output stream is stored in a dynamically-scoped variable:"
+{ $subsection output-stream }
+"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
+$nl
+"Words writing to the default input stream:"
 { $subsection flush }
 { $subsection write1 }
 { $subsection write }
@@ -78,9 +95,12 @@ ARTICLE: "stdio" "The default stream"
 { $subsection with-row }
 { $subsection with-cell }
 { $subsection write-cell }
-"A pair of combinators support rebinding the " { $link stdio } " variable:"
+"A pair of combinators for rebinding the " { $link output-stream } " variable:"
-{ $subsection with-stream }
+{ $subsection with-output-stream }
-{ $subsection with-stream* } ;
+{ $subsection with-output-stream* }
+"A pair of combinators for rebinding both default streams at once:"
+{ $subsection with-streams }
+{ $subsection with-streams* } ;
 
 ARTICLE: "stream-utils" "Stream utilities"
 "There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
@@ -204,62 +224,65 @@ HELP: stream-copy
 { $description "Copies the contents of one stream into another, closing both streams when done." } 
 $io-error ;
 
-HELP: stdio
+HELP: input-stream
-{ $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
+{ $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
+
+HELP: output-stream
+{ $var-description "Holds an output stream for various implicit stream operations. Rebound using " { $link with-output-stream } " and " { $link with-output-stream* } "." } ;
 
 HELP: readln
 { $values { "str/f" "a string or " { $link f } } }
-{ $description "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
+{ $description "Reads a line of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
 $io-error ;
 
 HELP: read1
 { $values { "ch/f" "a character or " { $link f } } }
-{ $description "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
+{ $description "Reads a character of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
 $io-error ;
 
 HELP: read
 { $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } }
-{ $description "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
+{ $description "Reads " { $snippet "n" } " characters of input from " { $link input-stream } ". Outputs a truncated string or " { $link f } " on stream exhaustion." }
 $io-error ;
 
 HELP: read-until
 { $values { "seps" string } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } }
-{ $contract "Reads characters from the " { $link stdio } " stream. until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
+{ $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
 $io-error ;
 
 HELP: write1
 { $values { "ch" "a character" } }
-{ $contract "Writes a character of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
 $io-error ;
 
 HELP: write
 { $values { "str" string } }
-{ $description "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $description "Writes a string of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
 $io-error ;
 
 HELP: flush
-{ $description "Waits for any pending output to the " { $link stdio } " stream to complete." }
+{ $description "Waits for any pending output on " { $link output-stream } " to complete." }
 $io-error ;
 
 HELP: nl
-{ $description "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $description "Writes a line terminator to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
 $io-error ;
 
 HELP: format
 { $values { "str" string } { "style" "a hashtable" } }
-{ $description "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
 { $notes "Details are in the documentation for " { $link stream-format } "." }
 $io-error ;
 
 HELP: with-nesting
-{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
+{ $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
 { $notes "Details are in the documentation for " { $link make-block-stream } "." }
 $io-error ;
 
 HELP: tabular-output
 { $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on the " { $link stdio } " stream."
+{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
 $nl
 "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
 { $examples
@@ -279,7 +302,7 @@ $io-error ;
 
 HELP: with-cell
 { $values { "quot" quotation } }
-{ $description "Calls a quotation in a new scope with the " { $link stdio } " stream rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
+{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
 $io-error ;
 
 HELP: write-cell
@@ -288,34 +311,54 @@ HELP: write-cell
 $io-error ;
 
 HELP: with-style
-{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
+{ $values { "style" "a hashtable" } { "quot" quotation } }
 { $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
 { $notes "Details are in the documentation for " { $link make-span-stream } "." }
 $io-error ;
 
 HELP: print
 { $values { "string" string } }
-{ $description "Writes a newline-terminated string to the " { $link stdio } " stream." }
+{ $description "Writes a newline-terminated string to " { $link output-stream } "." }
 $io-error ;
 
-HELP: with-stream
+HELP: with-input-stream
-{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
+{ $values { "stream" "an input stream" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to  " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to  " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
 
-{ with-stream with-stream* } related-words
+HELP: with-output-stream
+{ $values { "stream" "an output stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to  " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
 
-HELP: with-stream*
+HELP: with-streams
-{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
+{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to  " { $snippet "stream" } "." }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to  " { $snippet "input" } " and " { $link output-stream } " rebound to  " { $snippet "output" } ". The stream is closed if the quotation returns or throws an error." } ;
-{ $notes "This word does not close the stream. Compare with " { $link with-stream } "." } ;
+
+HELP: with-streams*
+{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to  " { $snippet "input" } " and " { $link output-stream } " rebound to  " { $snippet "output" } "." }
+{ $notes "This word does not close the stream. Compare with " { $link with-streams } "." } ;
+
+{ with-input-stream with-input-stream* } related-words
+
+{ with-output-stream with-output-stream* } related-words
+
+HELP: with-input-stream*
+{ $values { "stream" "an input stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to  " { $snippet "stream" } "." }
+{ $notes "This word does not close the stream. Compare with " { $link with-input-stream } "." } ;
+
+HELP: with-output-stream*
+{ $values { "stream" "an output stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to  " { $snippet "stream" } "." }
+{ $notes "This word does not close the stream. Compare with " { $link with-output-stream } "." } ;
 
 HELP: bl
-{ $description "Outputs a space character (" { $snippet "\" \"" } ")." }
+{ $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
 $io-error ;
 
 HELP: write-object
 { $values { "str" string } { "obj" "an object" } }
-{ $description "Writes a string to the " { $link stdio } " stream, associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." }
+{ $description "Writes a string to " { $link output-stream } ", associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." }
 $io-error ;
 
 HELP: lines

core/io/io-tests.factor

@@ -8,21 +8,18 @@ IN: io.tests
     "foo" "io.tests" lookup
 ] unit-test
 
-: <resource-reader> ( resource -- stream )
-    resource-path latin1 <file-reader> ;
-
 [
     "This is a line.\rThis is another line.\r"
 ] [
-    "core/io/test/mac-os-eol.txt" <resource-reader>
+    "resource:core/io/test/mac-os-eol.txt" latin1 <file-reader>
-    [ 500 read ] with-stream
+    [ 500 read ] with-input-stream
 ] unit-test
 
 [
     255
 ] [
-    "core/io/test/binary.txt" <resource-reader>
+    "resource:core/io/test/binary.txt" latin1 <file-reader>
-    [ read1 ] with-stream >fixnum
+    [ read1 ] with-input-stream >fixnum
 ] unit-test
 
 ! Make sure we use correct to_c_string form when writing
@@ -36,11 +33,12 @@ IN: io.tests
     }
 ] [
     [
-        "core/io/test/separator-test.txt" <resource-reader> [
+        "resource:core/io/test/separator-test.txt"
+        latin1 <file-reader> [
             "J" read-until 2array ,
             "i" read-until 2array ,
             "X" read-until 2array ,
-        ] with-stream
+        ] with-input-stream
     ] { } make
 ] unit-test
 
@@ -49,12 +47,3 @@ IN: io.tests
         10 [ 65536 read drop ] times
     ] with-file-reader
 ] unit-test
-
-! [ "" ] [ 0 read ] unit-test
-
-! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
-
-! [
-!     "/core/io/test/binary.txt" <resource-reader>
-!     [ 0.2 read ] with-stream
-! ] must-fail