diff --git a/Factor.app/Contents/Info.plist b/Factor.app/Contents/Info.plist
index ca0e6d5f8a..a8943d0d32 100644
--- a/Factor.app/Contents/Info.plist
+++ b/Factor.app/Contents/Info.plist
@@ -32,7 +32,7 @@
CFBundlePackageType
APPL
NSHumanReadableCopyright
- Copyright © 2003-2007, Slava Pestov and friends
+ Copyright © 2003-2008, Slava Pestov and friends
NSServices
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 7d13080e3c..0caf0e9a9f 100755
--- a/core/alien/alien-docs.factor
+++ b/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? }
diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor
index 3d0f36e415..5d847e364f 100755
--- a/core/alien/compiler/compiler-tests.factor
+++ b/core/alien/compiler/compiler-tests.factor
@@ -1,375 +1,375 @@
-IN: alien.compiler.tests
-USING: alien alien.c-types alien.syntax compiler kernel
-namespaces namespaces tools.test sequences inference words
-arrays parser quotations continuations inference.backend effects
-namespaces.private io io.streams.string memory system threads
-tools.test math ;
-
-FUNCTION: void ffi_test_0 ;
-[ ] [ ffi_test_0 ] unit-test
-
-FUNCTION: int ffi_test_1 ;
-[ 3 ] [ ffi_test_1 ] unit-test
-
-FUNCTION: int ffi_test_2 int x int y ;
-[ 5 ] [ 2 3 ffi_test_2 ] unit-test
-[ "hi" 3 ffi_test_2 ] must-fail
-
-FUNCTION: int ffi_test_3 int x int y int z int t ;
-[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
-
-FUNCTION: float ffi_test_4 ;
-[ 1.5 ] [ ffi_test_4 ] unit-test
-
-FUNCTION: double ffi_test_5 ;
-[ 1.5 ] [ ffi_test_5 ] unit-test
-
-FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
-[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
-[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
-[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
-
-C-STRUCT: foo
- { "int" "x" }
- { "int" "y" }
-;
-
-: make-foo ( x y -- foo )
- "foo" [ set-foo-y ] keep [ set-foo-x ] keep ;
-
-FUNCTION: int ffi_test_11 int a foo b int c ;
-
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
-
-FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
-
-[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
-
-FUNCTION: foo ffi_test_14 int x int y ;
-
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
-
-FUNCTION: char* ffi_test_15 char* x char* y ;
-
-[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
-[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
-[ 1 2 ffi_test_15 ] must-fail
-
-C-STRUCT: bar
- { "long" "x" }
- { "long" "y" }
- { "long" "z" }
-;
-
-FUNCTION: bar ffi_test_16 long x long y long z ;
-
-[ 11 6 -7 ] [
- 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
-] unit-test
-
-C-STRUCT: tiny
- { "int" "x" }
-;
-
-FUNCTION: tiny ffi_test_17 int x ;
-
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
-
-[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
-
-: indirect-test-1
- "int" { } "cdecl" alien-indirect ;
-
-{ 1 1 } [ indirect-test-1 ] must-infer-as
-
-[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
-
-[ -1 indirect-test-1 ] must-fail
-
-: indirect-test-2
- "int" { "int" "int" } "cdecl" alien-indirect gc ;
-
-{ 3 1 } [ indirect-test-2 ] must-infer-as
-
-[ 5 ]
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
-unit-test
-
-: indirect-test-3
- "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
- gc ;
-
-<< "f-stdcall" f "stdcall" add-library >>
-
-[ f ] [ "f-stdcall" load-library ] unit-test
-[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
-
-: ffi_test_18 ( w x y z -- int )
- "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
- alien-invoke gc ;
-
-[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
-
-: ffi_test_19 ( x y z -- bar )
- "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
- alien-invoke gc ;
-
-[ 11 6 -7 ] [
- 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
-] unit-test
-
-FUNCTION: double ffi_test_6 float x float y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
-[ "a" "b" ffi_test_6 ] must-fail
-
-FUNCTION: double ffi_test_7 double x double y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
-
-FUNCTION: double ffi_test_8 double x float y double z float t int w ;
-[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
-
-FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
-[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
-
-FUNCTION: void ffi_test_20 double x1, double x2, double x3,
- double y1, double y2, double y3,
- double z1, double z2, double z3 ;
-
-[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
-
-! Make sure XT doesn't get clobbered in stack frame
-
-: ffi_test_31
- "void"
- f "ffi_test_31"
- { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
- alien-invoke gc 3 ;
-
-[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
-
-FUNCTION: longlong ffi_test_21 long x long y ;
-
-[ 121932631112635269 ]
-[ 123456789 987654321 ffi_test_21 ] unit-test
-
-FUNCTION: long ffi_test_22 long x longlong y longlong z ;
-
-[ 987655432 ]
-[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
-
-[ 1111 f 123456789 ffi_test_22 ] must-fail
-
-C-STRUCT: rect
- { "float" "x" }
- { "float" "y" }
- { "float" "w" }
- { "float" "h" }
-;
-
-:
- "rect"
- [ set-rect-h ] keep
- [ set-rect-w ] keep
- [ set-rect-y ] keep
- [ set-rect-x ] keep ;
-
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
-
-[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test
-
-[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
-
-FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
-
-[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
-
-! Test odd-size structs
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
-
-FUNCTION: test-struct-1 ffi_test_24 ;
-
-[ B{ 1 } ] [ ffi_test_24 ] unit-test
-
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
-
-FUNCTION: test-struct-2 ffi_test_25 ;
-
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
-
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
-
-FUNCTION: test-struct-3 ffi_test_26 ;
-
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
-
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
-
-FUNCTION: test-struct-4 ffi_test_27 ;
-
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
-
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
-
-FUNCTION: test-struct-5 ffi_test_28 ;
-
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
-
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
-
-FUNCTION: test-struct-6 ffi_test_29 ;
-
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
-
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
-
-FUNCTION: test-struct-7 ffi_test_30 ;
-
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
-
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
-
-FUNCTION: double ffi_test_32 test-struct-8 x int y ;
-
-[ 9.0 ] [
- "test-struct-8"
- 1.0 over set-test-struct-8-x
- 2.0 over set-test-struct-8-y
- 3 ffi_test_32
-] unit-test
-
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
-
-FUNCTION: double ffi_test_33 test-struct-9 x int y ;
-
-[ 9.0 ] [
- "test-struct-9"
- 1.0 over set-test-struct-9-x
- 2.0 over set-test-struct-9-y
- 3 ffi_test_33
-] unit-test
-
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
-
-FUNCTION: double ffi_test_34 test-struct-10 x int y ;
-
-[ 9.0 ] [
- "test-struct-10"
- 1.0 over set-test-struct-10-x
- 2 over set-test-struct-10-y
- 3 ffi_test_34
-] unit-test
-
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
-
-FUNCTION: double ffi_test_35 test-struct-11 x int y ;
-
-[ 9.0 ] [
- "test-struct-11"
- 1 over set-test-struct-11-x
- 2 over set-test-struct-11-y
- 3 ffi_test_35
-] unit-test
-
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
-
-: make-struct-12
- "test-struct-12"
- [ set-test-struct-12-x ] keep ;
-
-FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
-
-[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
-
-FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
-
-[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
-
-! Test callbacks
-
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
-
-[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
-
-[ t ] [ callback-1 alien? ] unit-test
-
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
-
-[ ] [ callback-1 callback_test_1 ] unit-test
-
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
-
-[ ] [ callback-2 callback_test_1 ] unit-test
-
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
-
-[ t ] [
- namestack*
- 3 "x" set callback-3 callback_test_1
- namestack* eq?
-] unit-test
-
-[ 5 ] [
- [
- 3 "x" set callback-3 callback_test_1 "x" get
- ] with-scope
-] unit-test
-
-: callback-4
- "void" { } "cdecl" [ "Hello world" write ] alien-callback
- gc ;
-
-[ "Hello world" ] [
- [ callback-4 callback_test_1 ] with-string-writer
-] unit-test
-
-: callback-5
- "void" { } "cdecl" [ gc ] alien-callback ;
-
-[ "testing" ] [
- "testing" callback-5 callback_test_1
-] unit-test
-
-: callback-5a
- "void" { } "cdecl" [ 8000000 f drop ] alien-callback ;
-
-! Hack; if we're on ARM, we probably don't have much RAM, so
-! skip this test.
-! cpu "arm" = [
-! [ "testing" ] [
-! "testing" callback-5a callback_test_1
-! ] unit-test
-! ] unless
-
-: callback-6
- "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
-
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
-
-: callback-7
- "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
-
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
-
-[ f ] [ namespace global eq? ] unit-test
-
-: callback-8
- "void" { } "cdecl" [
- [ continue ] callcc0
- ] alien-callback ;
-
-[ ] [ callback-8 callback_test_1 ] unit-test
-
-: callback-9
- "int" { "int" "int" "int" } "cdecl" [
- + + 1+
- ] alien-callback ;
-
-FUNCTION: void ffi_test_36_point_5 ( ) ;
-
-[ ] [ ffi_test_36_point_5 ] unit-test
-
-FUNCTION: int ffi_test_37 ( void* func ) ;
-
-[ 1 ] [ callback-9 ffi_test_37 ] unit-test
-
-[ 7 ] [ callback-9 ffi_test_37 ] unit-test
+IN: alien.compiler.tests
+USING: alien alien.c-types alien.syntax compiler kernel
+namespaces namespaces tools.test sequences inference words
+arrays parser quotations continuations inference.backend effects
+namespaces.private io io.streams.string memory system threads
+tools.test math ;
+
+FUNCTION: void ffi_test_0 ;
+[ ] [ ffi_test_0 ] unit-test
+
+FUNCTION: int ffi_test_1 ;
+[ 3 ] [ ffi_test_1 ] unit-test
+
+FUNCTION: int ffi_test_2 int x int y ;
+[ 5 ] [ 2 3 ffi_test_2 ] unit-test
+[ "hi" 3 ffi_test_2 ] must-fail
+
+FUNCTION: int ffi_test_3 int x int y int z int t ;
+[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
+
+FUNCTION: float ffi_test_4 ;
+[ 1.5 ] [ ffi_test_4 ] unit-test
+
+FUNCTION: double ffi_test_5 ;
+[ 1.5 ] [ ffi_test_5 ] unit-test
+
+FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
+[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
+[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
+[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
+
+C-STRUCT: foo
+ { "int" "x" }
+ { "int" "y" }
+;
+
+: make-foo ( x y -- foo )
+ "foo" [ set-foo-y ] keep [ set-foo-x ] keep ;
+
+FUNCTION: int ffi_test_11 int a foo b int c ;
+
+[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+
+FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
+
+[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
+
+FUNCTION: foo ffi_test_14 int x int y ;
+
+[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+
+FUNCTION: char* ffi_test_15 char* x char* y ;
+
+[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
+[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
+[ 1 2 ffi_test_15 ] must-fail
+
+C-STRUCT: bar
+ { "long" "x" }
+ { "long" "y" }
+ { "long" "z" }
+;
+
+FUNCTION: bar ffi_test_16 long x long y long z ;
+
+[ 11 6 -7 ] [
+ 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+] unit-test
+
+C-STRUCT: tiny
+ { "int" "x" }
+;
+
+FUNCTION: tiny ffi_test_17 int x ;
+
+[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+
+[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
+
+: indirect-test-1
+ "int" { } "cdecl" alien-indirect ;
+
+{ 1 1 } [ indirect-test-1 ] must-infer-as
+
+[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+
+[ -1 indirect-test-1 ] must-fail
+
+: indirect-test-2
+ "int" { "int" "int" } "cdecl" alien-indirect gc ;
+
+{ 3 1 } [ indirect-test-2 ] must-infer-as
+
+[ 5 ]
+[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+unit-test
+
+: indirect-test-3
+ "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+ gc ;
+
+<< "f-stdcall" f "stdcall" add-library >>
+
+[ f ] [ "f-stdcall" load-library ] unit-test
+[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
+
+: ffi_test_18 ( w x y z -- int )
+ "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+ alien-invoke gc ;
+
+[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
+
+: ffi_test_19 ( x y z -- bar )
+ "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+ alien-invoke gc ;
+
+[ 11 6 -7 ] [
+ 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+] unit-test
+
+FUNCTION: double ffi_test_6 float x float y ;
+[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
+[ "a" "b" ffi_test_6 ] must-fail
+
+FUNCTION: double ffi_test_7 double x double y ;
+[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
+
+FUNCTION: double ffi_test_8 double x float y double z float t int w ;
+[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
+
+FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
+[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
+
+FUNCTION: void ffi_test_20 double x1, double x2, double x3,
+ double y1, double y2, double y3,
+ double z1, double z2, double z3 ;
+
+[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
+
+! Make sure XT doesn't get clobbered in stack frame
+
+: ffi_test_31
+ "void"
+ f "ffi_test_31"
+ { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+ alien-invoke gc 3 ;
+
+[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+
+FUNCTION: longlong ffi_test_21 long x long y ;
+
+[ 121932631112635269 ]
+[ 123456789 987654321 ffi_test_21 ] unit-test
+
+FUNCTION: long ffi_test_22 long x longlong y longlong z ;
+
+[ 987655432 ]
+[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
+
+[ 1111 f 123456789 ffi_test_22 ] must-fail
+
+C-STRUCT: rect
+ { "float" "x" }
+ { "float" "y" }
+ { "float" "w" }
+ { "float" "h" }
+;
+
+:
+ "rect"
+ [ set-rect-h ] keep
+ [ set-rect-w ] keep
+ [ set-rect-y ] keep
+ [ set-rect-x ] keep ;
+
+FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test
+
+[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
+
+FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
+
+[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
+
+! Test odd-size structs
+C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+
+FUNCTION: test-struct-1 ffi_test_24 ;
+
+[ B{ 1 } ] [ ffi_test_24 ] unit-test
+
+C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+
+FUNCTION: test-struct-2 ffi_test_25 ;
+
+[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+
+C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+
+FUNCTION: test-struct-3 ffi_test_26 ;
+
+[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+
+C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+
+FUNCTION: test-struct-4 ffi_test_27 ;
+
+[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+
+C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+
+FUNCTION: test-struct-5 ffi_test_28 ;
+
+[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+
+C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+
+FUNCTION: test-struct-6 ffi_test_29 ;
+
+[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+
+C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+
+FUNCTION: test-struct-7 ffi_test_30 ;
+
+[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+
+C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+
+FUNCTION: double ffi_test_32 test-struct-8 x int y ;
+
+[ 9.0 ] [
+ "test-struct-8"
+ 1.0 over set-test-struct-8-x
+ 2.0 over set-test-struct-8-y
+ 3 ffi_test_32
+] unit-test
+
+C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+
+FUNCTION: double ffi_test_33 test-struct-9 x int y ;
+
+[ 9.0 ] [
+ "test-struct-9"
+ 1.0 over set-test-struct-9-x
+ 2.0 over set-test-struct-9-y
+ 3 ffi_test_33
+] unit-test
+
+C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+
+FUNCTION: double ffi_test_34 test-struct-10 x int y ;
+
+[ 9.0 ] [
+ "test-struct-10"
+ 1.0 over set-test-struct-10-x
+ 2 over set-test-struct-10-y
+ 3 ffi_test_34
+] unit-test
+
+C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+
+FUNCTION: double ffi_test_35 test-struct-11 x int y ;
+
+[ 9.0 ] [
+ "test-struct-11"
+ 1 over set-test-struct-11-x
+ 2 over set-test-struct-11-y
+ 3 ffi_test_35
+] unit-test
+
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+
+: make-struct-12
+ "test-struct-12"
+ [ set-test-struct-12-x ] keep ;
+
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
+
+[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
+
+! Test callbacks
+
+: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+
+[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+
+[ t ] [ callback-1 alien? ] unit-test
+
+: callback_test_1 "void" { } "cdecl" alien-indirect ;
+
+[ ] [ callback-1 callback_test_1 ] unit-test
+
+: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+
+[ ] [ callback-2 callback_test_1 ] unit-test
+
+: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+
+[ t ] [
+ namestack*
+ 3 "x" set callback-3 callback_test_1
+ namestack* eq?
+] unit-test
+
+[ 5 ] [
+ [
+ 3 "x" set callback-3 callback_test_1 "x" get
+ ] with-scope
+] unit-test
+
+: callback-4
+ "void" { } "cdecl" [ "Hello world" write ] alien-callback
+ gc ;
+
+[ "Hello world" ] [
+ [ callback-4 callback_test_1 ] with-string-writer
+] unit-test
+
+: callback-5
+ "void" { } "cdecl" [ gc ] alien-callback ;
+
+[ "testing" ] [
+ "testing" callback-5 callback_test_1
+] unit-test
+
+: callback-5a
+ "void" { } "cdecl" [ 8000000 f drop ] alien-callback ;
+
+! Hack; if we're on ARM, we probably don't have much RAM, so
+! skip this test.
+! cpu "arm" = [
+! [ "testing" ] [
+! "testing" callback-5a callback_test_1
+! ] unit-test
+! ] unless
+
+: callback-6
+ "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+
+[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+
+: callback-7
+ "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+
+[ f ] [ namespace global eq? ] unit-test
+
+: callback-8
+ "void" { } "cdecl" [
+ [ continue ] callcc0
+ ] alien-callback ;
+
+[ ] [ callback-8 callback_test_1 ] unit-test
+
+: callback-9
+ "int" { "int" "int" "int" } "cdecl" [
+ + + 1+
+ ] alien-callback ;
+
+FUNCTION: void ffi_test_36_point_5 ( ) ;
+
+[ ] [ ffi_test_36_point_5 ] unit-test
+
+FUNCTION: int ffi_test_37 ( void* func ) ;
+
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 3de4c61291..08b52367b0 100755
--- a/core/alien/compiler/compiler.factor
+++ b/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 ] curry
- f infer-quot ;
+ recursive-state get infer-quot ;
\ alien-callback [
4 ensure-values
diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor
index 0dbb4ffd38..27b0122ebe 100644
--- a/core/alien/strings/strings-docs.factor
+++ b/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
diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor
index 463fc11e0d..d69d8e9e8e 100644
--- a/core/alien/strings/strings.factor
+++ b/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 r>
diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor
index f0f495cac9..b2e819f8fb 100755
--- a/core/alien/syntax/syntax.factor
+++ b/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:
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 863fdaecb3..68be9c9b06 100755
--- a/core/assocs/assocs-docs.factor
+++ b/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" } }
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 76f484006d..30f2ec23c4 100755
--- a/core/assocs/assocs-tests.factor
+++ b/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
-[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test
-[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test
-[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test
-[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test
-[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test
+[ t ] [ H{ } dup assoc-subset? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
+[ t ] [ H{ } H{ { 1 3 } } assoc-subset? ] unit-test
+[ t ] [ H{ { 1 3 } } H{ { 1 3 } } assoc-subset? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } assoc-subset? ] unit-test
+[ f ] [ H{ { 1 f } } H{ } assoc-subset? ] 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 ] [
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 4a6ecae4fe..92db38573a 100755
--- a/core/assocs/assocs.factor
+++ b/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
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index da3c634ebd..7ad1c6978b 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/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
-} compile
+ + 1+ 1- 2/ < <= > >= shift
+} 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
diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor
index ae5c66a45c..c432a47ea4 100755
--- a/core/bootstrap/image/image-tests.factor
+++ b/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
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 05d48af2e8..1ff04bacc2 100755
--- a/core/bootstrap/image/image.factor
+++ b/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
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) 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
- ] emit-object ;
+ [
+ float tag-number dup [
+ 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
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
- classes-intersect-cache class-and-cache
+ update-map class<=-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 [ (write-image) ] with-stream ] bi ;
+ [ binary [ (write-image) ] with-file-writer ] bi ;
PRIVATE>
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index dd3a4adf8b..6149e83893 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -59,6 +59,7 @@ num-types get f builtins set
"arrays"
"bit-arrays"
"byte-arrays"
+ "byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
@@ -157,7 +158,7 @@ num-types get f 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
{
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index dfd2e4be6f..2e087ff5bd 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -22,13 +22,13 @@ SYMBOL: bootstrap-time
xref-sources ;
: load-components ( -- )
- "exclude" "include"
- [ get-global " " split [ empty? not ] subset ] bi@
+ "include" "exclude"
+ [ 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
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index 4b74804749..7d703d3093 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -16,6 +16,7 @@ IN: bootstrap.syntax
"?{"
"BIN:"
"B{"
+ "BV{"
"C:"
"CHAR:"
"DEFER:"
diff --git a/extra/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor
similarity index 93%
rename from extra/byte-vectors/byte-vectors-docs.factor
rename to core/byte-vectors/byte-vectors-docs.factor
index f34bc20219..139cbab822 100755
--- a/extra/byte-vectors/byte-vectors-docs.factor
+++ b/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:
{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }
diff --git a/extra/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor
similarity index 100%
rename from extra/byte-vectors/byte-vectors-tests.factor
rename to core/byte-vectors/byte-vectors-tests.factor
diff --git a/extra/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor
similarity index 61%
rename from extra/byte-vectors/byte-vectors.factor
rename to core/byte-vectors/byte-vectors.factor
index a8351dc781..e80b797a8d 100755
--- a/extra/byte-vectors/byte-vectors.factor
+++ b/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
-parser accessors ;
+sequences.private growable byte-arrays ;
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) ;
-
vector ( byte-array length -- byte-vector )
@@ -43,9 +32,3 @@ M: byte-vector equal?
M: byte-array new-resizable drop ;
INSTANCE: byte-vector growable
-
-: BV{ \ } [ >byte-vector ] parse-literal ; parsing
-
-M: byte-vector >pprint-sequence ;
-
-M: byte-vector pprint-delims drop \ BV{ \ } ;
diff --git a/extra/byte-vectors/summary.txt b/core/byte-vectors/summary.txt
similarity index 100%
rename from extra/byte-vectors/summary.txt
rename to core/byte-vectors/summary.txt
diff --git a/extra/byte-vectors/tags.txt b/core/byte-vectors/tags.txt
similarity index 100%
rename from extra/byte-vectors/tags.txt
rename to core/byte-vectors/tags.txt
diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor
new file mode 100644
index 0000000000..c352f02af4
--- /dev/null
+++ b/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" } ;
diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor
new file mode 100644
index 0000000000..1ec675b0cf
--- /dev/null
+++ b/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
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
new file mode 100644
index 0000000000..08a13297d1
--- /dev/null
+++ b/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 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 r> checksum-stream ;
+
+: hex-string ( seq -- str )
+ [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;
diff --git a/core/io/crc32/authors.txt b/core/checksums/crc32/authors.txt
similarity index 100%
rename from core/io/crc32/authors.txt
rename to core/checksums/crc32/authors.txt
diff --git a/core/checksums/crc32/crc32-docs.factor b/core/checksums/crc32/crc32-docs.factor
new file mode 100644
index 0000000000..0f277bcd16
--- /dev/null
+++ b/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"
diff --git a/core/checksums/crc32/crc32-tests.factor b/core/checksums/crc32/crc32-tests.factor
new file mode 100644
index 0000000000..6fe4b995ee
--- /dev/null
+++ b/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
+
diff --git a/core/io/crc32/crc32.factor b/core/checksums/crc32/crc32.factor
similarity index 59%
rename from core/io/crc32/crc32.factor
rename to core/checksums/crc32/crc32.factor
index afe7e4bfb7..e1f0b9417b 100755
--- a/core/io/crc32/crc32.factor
+++ b/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 ;
-IN: io.crc32
+definitions checksums ;
+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 )
- >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
+SINGLETON: crc32
-: lines-crc32 ( seq -- n )
- HEX: ffffffff tuck [
- [ (crc32) ] each CHAR: \n (crc32)
- ] reduce bitxor ;
+INSTANCE: crc32 checksum
+
+: init-crc32 drop >r HEX: ffffffff dup r> ; inline
+
+: 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 ;
diff --git a/core/io/crc32/summary.txt b/core/checksums/crc32/summary.txt
similarity index 100%
rename from core/io/crc32/summary.txt
rename to core/checksums/crc32/summary.txt
diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor
index 87c72048f4..810bdbe10f 100755
--- a/core/classes/algebra/algebra-docs.factor
+++ b/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 } }
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index dba97c16f5..dfe4a0fbc9 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/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 \ fixnum class< ] unit-test
-[ f ] [ \ integer \ fixnum class< ] unit-test
-[ t ] [ \ integer \ object class< ] unit-test
-[ f ] [ \ integer \ null class< ] unit-test
-[ t ] [ \ null \ object class< ] unit-test
+[ t ] [ \ fixnum \ integer class<= ] unit-test
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test
+[ f ] [ \ integer \ fixnum class<= ] unit-test
+[ t ] [ \ integer \ object class<= ] unit-test
+[ f ] [ \ integer \ null class<= ] unit-test
+[ t ] [ \ null \ object class<= ] unit-test
-[ t ] [ \ generic \ word class< ] unit-test
-[ f ] [ \ word \ generic class< ] unit-test
+[ t ] [ \ generic \ word class<= ] unit-test
+[ f ] [ \ word \ generic class<= ] unit-test
-[ f ] [ \ reversed \ slice class< ] unit-test
-[ f ] [ \ slice \ reversed class< ] unit-test
+[ f ] [ \ reversed \ slice 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
-[ f ] [ no-docs-union no-docs class< ] unit-test
+[ t ] [ no-docs no-docs-union 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
-[ f ] [ \ tuple \ c class< ] unit-test
+[ t ] [ \ c \ tuple class<= ] unit-test
+[ f ] [ \ tuple \ c class<= ] unit-test
-[ t ] [ \ tuple-class \ class class< ] unit-test
-[ f ] [ \ class \ tuple-class class< ] unit-test
+[ t ] [ \ tuple-class \ class class<= ] unit-test
+[ f ] [ \ class \ tuple-class class<= ] unit-test
TUPLE: tuple-example ;
-[ t ] [ \ null \ 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
-[ f ] [ \ tuple \ 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
+[ t ] [ \ tuple-example \ tuple 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
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index f2941e3cef..4160f4e9d2 100755
--- a/core/classes/algebra/algebra.factor
+++ b/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<-cache get [ (class<) ] 2cache ;
+: class<= ( first second -- ? )
+ class<=-cache get [ (class<=) ] 2cache ;
DEFER: (class-not)
@@ -45,31 +45,31 @@ TUPLE: anonymous-complement class ;
C: anonymous-complement
-: superclass< ( first second -- ? )
- >r superclass r> class< ;
+: superclass<= ( first second -- ? )
+ >r superclass r> class<= ;
-: left-union-class< ( first second -- ? )
- >r members r> [ class< ] curry all? ;
+: left-union-class<= ( first second -- ? )
+ >r members r> [ class<= ] curry all? ;
-: right-union-class< ( first second -- ? )
- members [ class< ] with contains? ;
+: right-union-class<= ( first second -- ? )
+ 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
{ [ 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< ] }
- { [ over superclass ] [ superclass< ] }
+ { [ dup members ] [ right-union-class<= ] }
+ { [ over superclass ] [ superclass<= ] }
[ 2drop f ]
} cond ;
@@ -94,7 +94,7 @@ C: 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
{
{ [ 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
: (class-and) ( first second -- class )
{
- { [ 2dup class< ] [ drop ] }
- { [ 2dup swap class< ] [ nip ] }
+ { [ 2dup class<= ] [ drop ] }
+ { [ 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
: (class-or) ( first second -- class )
{
- { [ 2dup class< ] [ nip ] }
- { [ 2dup swap class< ] [ drop ] }
+ { [ 2dup class<= ] [ nip ] }
+ { [ 2dup swap class<= ] [ drop ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
[ 2array ]
@@ -180,22 +180,27 @@ C: 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 [
- [ 2dup class< >r swap class< not r> and ]
- with subset empty?
- ] curry find [ "Topological sort failed" throw ] unless* ;
+ dup [ [ class< ] with contains? not ] curry find-last
+ [ "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
: 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 )
diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
index 1c2871b031..8e992b852e 100644
--- a/core/classes/builtin/builtin.factor
+++ b/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 ;
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index dd3782e877..744944c281 100755
--- a/core/classes/classes-docs.factor
+++ b/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." } ;
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index ae19f38d14..bb9fbd0167 100755
--- a/core/classes/classes-tests.factor
+++ b/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
-[ t ] [ union-1 number class< ] unit-test
+[ f ] [ bignum union-1 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
-[ f ] [ union-1 number class< ] unit-test
+[ t ] [ bignum union-1 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 ] [ mx1 integer class< ] unit-test
-[ t ] [ mx1 number class< ] unit-test
+[ t ] [ integer mx1 class<= ] unit-test
+[ t ] [ mx1 integer class<= ] unit-test
+[ t ] [ mx1 number class<= ] unit-test
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
-[ t ] [ array mx1 class< ] unit-test
-[ f ] [ mx1 number class< ] unit-test
+[ t ] [ array mx1 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 ] [ quotation redefine-bug-2 class< ] unit-test
+[ t ] [ fixnum 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
-[ f ] [ fixnum redefine-bug-2 class< ] unit-test
-[ t ] [ bignum redefine-bug-2 class< ] unit-test
+[ t ] [ bignum redefine-bug-1 class<= ] unit-test
+[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
+[ t ] [ bignum redefine-bug-2 class<= ] unit-test
USE: io.streams.string
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 4f43b86f64..594b2005b8 100755
--- a/core/classes/classes.factor
+++ b/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 ;
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index 33b0fc32fa..6f888ceca1 100755
--- a/core/classes/mixin/mixin.factor
+++ b/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 -- )
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 4729a6dd5e..4e4d1701e4 100755
--- a/core/classes/predicate/predicate.factor
+++ b/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 ;
diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor
index a8dae809ec..f647b006d9 100644
--- a/core/classes/singleton/singleton-docs.factor
+++ b/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
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index cdfdee9717..9f8ce83240 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/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 }"
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 2932187152..fb9530b1c5 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/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
[ t length ] [ object>> t eq? ] must-fail-with
[ "" ]
-[ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test
+[ "IN: classes.tuple.test TUPLE: constructor-test ; C: 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
[ t ] [ laptop tuple-class? ] unit-test
-[ t ] [ laptop tuple class< ] unit-test
-[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop tuple class<= ] unit-test
+[ t ] [ laptop computer class<= ] unit-test
[ t ] [ laptop computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 3 hours "laptop" set ] unit-test
@@ -266,8 +266,8 @@ TUPLE: server < computer rackmount ;
C: server
[ t ] [ server tuple-class? ] unit-test
-[ t ] [ server tuple class< ] unit-test
-[ t ] [ server computer class< ] unit-test
+[ t ] [ server tuple class<= ] unit-test
+[ t ] [ server computer class<= ] unit-test
[ t ] [ server computer classes-intersect? ] unit-test
[ ] [ "PowerPC" 64 "1U" "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 ] [ laptop server class< ] unit-test
+[ f ] [ server laptop class<= ] unit-test
+[ f ] [ laptop server class<= ] unit-test
[ f ] [ laptop server classes-intersect? ] unit-test
[ f ] [ 1 2 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
-[ t ] [ server electronic-device class< ] unit-test
-[ t ] [ laptop server class-or electronic-device class< ] unit-test
+[ f ] [ electronic-device laptop class<= ] unit-test
+[ t ] [ server 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
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index c14205e1d9..5ebcc7a286 100755
--- a/core/classes/tuple/tuple.factor
+++ b/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 ;
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 09f8f88ced..760844afb9 100755
--- a/core/classes/union/union.factor
+++ b/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 ;
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index 54c62c44fa..61752ac7d6 100755
--- a/core/combinators/combinators-docs.factor
+++ b/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
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index e3d0f88680..d33edfab30 100755
--- a/core/combinators/combinators.factor
+++ b/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
] [
diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor
index 246bf2dabe..84020abca0 100644
--- a/core/command-line/command-line.factor
+++ b/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* ;
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 806ea914bb..ef00e94dd5 100755
--- a/core/compiler/compiler.factor
+++ b/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
- ] computing-dependencies ;
+ over "compiled-effect" word-prop = [
+ 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 ]
- [ dupd compile-failed f save-effect ]
- recover ;
+ [
+ H{ } clone dependencies set
+
+ {
+ [ compile-begins ]
+ [
+ [ word-dataflow ] [ compile-failed return ] recover
+ optimize
+ ]
+ [ dup generate ]
+ [ compile-succeeded ]
+ } cleave
+ ] curry with-return ;
: compile-loop ( assoc -- )
dup assoc-empty? [ drop ] [
diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor
index dd71eb704f..d86587662b 100755
--- a/core/compiler/errors/errors-docs.factor
+++ b/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
diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor
index b7b599e5a9..e7dc5156e4 100755
--- a/core/compiler/errors/errors.factor
+++ b/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
diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index 7d473871fe..6fb6afe0c6 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/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
diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor
index f54ac62204..9ee774d81d 100755
--- a/core/compiler/tests/stack-trace.factor
+++ b/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? ;
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 65e57a8912..a31cd8de16 100755
--- a/core/compiler/units/units.factor
+++ b/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 ( -- )
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index b1db09b6bc..472136da8e 100755
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -34,7 +34,7 @@ $nl
{ $code
" ... 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."
diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor
index 8b396763e1..28581820fd 100755
--- a/core/continuations/continuations-tests.factor
+++ b/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
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index cf67280cca..78effb043a 100755
--- a/core/continuations/continuations.factor
+++ b/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 )
>
: 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
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 7e7ff8a334..f0ca47a1ba 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/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
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 3ad7d4f7b5..cabd81dad6 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/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.
diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor
index ca6aa59cc4..9dd23c6011 100755
--- a/core/debugger/debugger-docs.factor
+++ b/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." } ;
-
-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." } ;
+{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
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
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 827a5c4e8d..df7d33f41c 100755
--- a/core/debugger/debugger.factor
+++ b/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
-strings io.styles vectors words system splitting math.parser
-classes.tuple continuations continuations.private combinators
-generic.math io.streams.duplex classes.builtin classes
-compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings accessors ;
+math namespaces prettyprint prettyprint.config sequences assocs
+sequences.private strings io.styles vectors words system
+splitting math.parser classes.tuple continuations
+continuations.private combinators generic.math
+classes.builtin classes compiler.units generic.standard vocabs
+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
-] error-hook set-global
+ "Type :help for debugging help." print flush ;
: 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 {
- { -1 [ trim-datastacks nip relative-underflow ] }
- { 0 [ 2drop ] }
- { 1 [ trim-datastacks drop relative-overflow ] }
+ 2dup [ length ] compare {
+ { +lt+ [ trim-datastacks nip relative-underflow ] }
+ { +eq+ [ 2drop ] }
+ { +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-thread get-global
+: error-in-thread. ( thread -- )
"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" ;
+
array
- ] 2keep diff assert-same-elements
+ ] 2keep swap diff assert-same-elements
] unit-test
[ ] [
diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor
index e79907f11f..d9aa6b1c19 100755
--- a/core/dlists/dlists.factor
+++ b/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?
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index ad6cd3051c..06895cd8ac 100755
--- a/core/generator/fixup/fixup.factor
+++ b/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
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index 6a1d9ec0f4..c5e1ea54a6 100755
--- a/core/generator/registers/registers.factor
+++ b/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 simple-alien class< ] [ drop %unbox-alien ] }
- { [ dup byte-array class< ] [ drop %unbox-byte-array ] }
- { [ dup bit-array class< ] [ drop %unbox-byte-array ] }
- { [ dup float-array class< ] [ drop %unbox-byte-array ] }
+ { [ dup \ f class<= ] [ drop %unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
+ { [ dup bit-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
- [ ] curry map diff
+ [ ] 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
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 1024c377a8..39293bfec9 100755
--- a/core/generic/generic-docs.factor
+++ b/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."
-$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."
+"Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in linear order (" { $link "class-linearization" } ")."
$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:"
-{ $code "M: integer explain drop \"an integer\" print ;" }
-"On the other hand, if we want integers to behave like sequences here, we could define:"
+"The linear order is the following, from least-specific to most-specific:"
+{ $code "{ object sequence number }" }
+"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"
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index bbd7186a11..600f422274 100755
--- a/core/generic/generic-tests.factor
+++ b/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
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 6c59d76d07..d35ba01e52 100755
--- a/core/generic/generic.factor
+++ b/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* ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 884ab8027e..1c1368a6c2 100755
--- a/core/generic/math/math.factor
+++ b/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 ;
diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor
index 1f0b80e016..20e22fde82 100644
--- a/core/generic/standard/engines/engines.factor
+++ b/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< ] curry assoc-subset ] 2bi ;
+ [ [ nip class<= not ] curry assoc-filter ]
+ [ [ nip class<= ] curry assoc-filter ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [
diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
index 5335074dea..b1bfc659df 100644
--- a/core/generic/standard/engines/predicate/predicate.factor
+++ b/core/generic/standard/engines/predicate/predicate.factor
@@ -11,14 +11,14 @@ C: 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 ] }
- [ [ first second ] [ 1 tail-slice ] bi ]
+ { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
+ [ [ first second ] [ rest-slice ] bi ]
} cond ;
: sort-methods ( assoc -- assoc' )
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 7639d1d499..51ea4f8225 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/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 %
diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor
index f4e76aa68e..4e80ed1f6e 100755
--- a/core/hashtables/hashtables-tests.factor
+++ b/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 ]
diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor
index f9224eafeb..d1003ac2f8 100755
--- a/core/heaps/heaps-docs.factor
+++ b/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"
diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor
index b22d8818c1..d55b547b8f 100755
--- a/core/heaps/heaps-tests.factor
+++ b/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
[ heap-pop ] must-fail
diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor
index 02a8b8d88b..57f0e0ac72 100755
--- a/core/heaps/heaps.factor
+++ b/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
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index f60748a5ac..5896429ccf 100755
--- a/core/inference/backend/backend.factor
+++ b/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 ] 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
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 0c4ff82798..e6ce2cfa0b 100755
--- a/core/inference/class/class-tests.factor
+++ b/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
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 6d5b708f34..933710aaca 100755
--- a/core/inference/class/class.factor
+++ b/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
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index bb66a5386c..d7e3e78308 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/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?
diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor
index e32c94ed37..d79c82ed65 100755
--- a/core/inference/inference-docs.factor
+++ b/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
diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor
index 84d72bdd9b..c63786dc9e 100644
--- a/core/inference/state/state-tests.factor
+++ b/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
diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor
index a426f410e2..6f0eecf2d9 100755
--- a/core/inference/state/state.factor
+++ 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?
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 624dcbbf98..0040629edd 100755
--- a/core/inference/transforms/transforms.factor
+++ b/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
diff --git a/core/inspector/inspector-docs.factor b/core/inspector/inspector-docs.factor
index 84ae34480d..ab1c38b0b7 100644
--- a/core/inspector/inspector-docs.factor
+++ b/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." } ;
diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor
index c9bfbfad54..0ab016b0fa 100755
--- a/core/inspector/inspector.factor
+++ b/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 ;
diff --git a/core/io/backend/backend-docs.factor b/core/io/backend/backend-docs.factor
index 8bf761e2a6..48b49ed32b 100644
--- a/core/io/backend/backend-docs.factor
+++ b/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." } ;
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 44b1eea349..0760063f0d 100755
--- a/core/io/backend/backend.factor
+++ b/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 stderr set-global
- utf8 stdio set-global ;
+ (init-stdio)
+ [ utf8 input-stream set-global ]
+ [ utf8 output-stream set-global ]
+ [ utf8 error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( ms -- )
diff --git a/core/io/crc32/crc32-docs.factor b/core/io/crc32/crc32-docs.factor
deleted file mode 100644
index 7f85ee2b4e..0000000000
--- a/core/io/crc32/crc32-docs.factor
+++ /dev/null
@@ -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"
diff --git a/core/io/crc32/crc32-tests.factor b/core/io/crc32/crc32-tests.factor
deleted file mode 100644
index 5eafae23cb..0000000000
--- a/core/io/crc32/crc32-tests.factor
+++ /dev/null
@@ -1,5 +0,0 @@
-USING: io.crc32 kernel math tools.test namespaces ;
-
-[ 0 ] [ "" crc32 ] unit-test
-[ HEX: cbf43926 ] [ "123456789" crc32 ] unit-test
-
diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor
index 8a176ce4ec..92471acb5d 100644
--- a/core/io/encodings/encodings-docs.factor
+++ b/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 }
-{ $subsection }
-{ $subsection } ;
+{ $subsection } ;
HELP:
{ $values { "stream" "an output stream" }
@@ -29,16 +28,6 @@ HELP:
{ $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:
-{ $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 ;
-
-{ } 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" }
diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor
index 397d1ea89c..e6b180fde2 100755
--- a/core/io/encodings/encodings-tests.factor
+++ b/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 -- stream )
- resource-path ascii ;
-
[ { } ]
-[ "core/io/test/empty-file.txt" lines ]
+[ "resource:core/io/test/empty-file.txt" ascii 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" lines-test
+ "resource:core/io/test/windows-eol.txt"
+ ascii lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
- "core/io/test/mac-os-eol.txt" lines-test
+ "resource:core/io/test/mac-os-eol.txt"
+ ascii lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
- "core/io/test/unix-eol.txt" lines-test
+ "resource:core/io/test/unix-eol.txt"
+ ascii lines-test
] unit-test
[
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 4559cec666..0f6e58bdc9 100755
--- a/core/io/encodings/encodings.factor
+++ b/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
-sequences.private accessors ;
+io.streams.plain splitting byte-arrays sequences.private
+accessors ;
IN: io.encodings
! The encoding descriptor protocol
@@ -131,6 +131,3 @@ INSTANCE: encoder plain-writer
over decoder? [ >r decoder-stream r> ] when ;
PRIVATE>
-
-: ( stream-in stream-out encoding -- duplex )
- tuck reencode >r redecode r> ;
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index ba17223a29..dd550070a4 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -184,8 +184,12 @@ HELP: +unknown+
{ $description "A unknown file type." } ;
HELP:
-{ $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:
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
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index 5efbb9496d..a463fd2e40 100755
--- a/core/io/files/files-tests.factor
+++ b/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
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 061e6386da..76c7b144d0 100755
--- a/core/io/files/files.factor
+++ b/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 )
lines ;
: with-file-reader ( path encoding quot -- )
- >r r> with-stream ; inline
+ >r r> with-input-stream ; inline
: file-contents ( path encoding -- str )
contents ;
: with-file-writer ( path encoding quot -- )
- >r r> with-stream ; inline
+ >r 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 r> with-stream ; inline
+ >r 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 ;
diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index fd40950e62..ddea4da556 100755
--- a/core/io/io-docs.factor
+++ b/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"
-"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:"
+ARTICLE: "stdio" "Default input and output streams"
+"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 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 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-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\" "
+ "\"data.txt\" utf8 "
"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\" ["
+ "\"data.txt\" utf8 ["
" 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\" ["
+ "\"data.txt\" utf8 ["
" readln number>string read 16 group"
- "] with-stream"
+ "] with-input-stream"
}
-"The default stream is stored in a dynamically-scoped variable:"
-{ $subsection stdio }
-"Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user."
+"An even better implementation that takes advantage of a utility word:"
+{ $code
+ "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:"
-{ $subsection with-stream }
-{ $subsection with-stream* } ;
+"A pair of combinators for rebinding the " { $link output-stream } " variable:"
+{ $subsection with-output-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
-{ $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
+HELP: input-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" } }
-{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
+{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $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
-{ $values { "stream" "an input or output stream" } { "quot" "a 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." } ;
+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" } ". 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*
-{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
-{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } "." }
-{ $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" } ". The stream is closed if the quotation returns or throws an error." } ;
+
+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
diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor
index b7d1cf81c8..50a798d290 100755
--- a/core/io/io-tests.factor
+++ b/core/io/io-tests.factor
@@ -8,21 +8,18 @@ IN: io.tests
"foo" "io.tests" lookup
] unit-test
-: ( resource -- stream )
- resource-path latin1 ;
-
[
"This is a line.\rThis is another line.\r"
] [
- "core/io/test/mac-os-eol.txt"
- [ 500 read ] with-stream
+ "resource:core/io/test/mac-os-eol.txt" latin1
+ [ 500 read ] with-input-stream
] unit-test
[
255
] [
- "core/io/test/binary.txt"
- [ read1 ] with-stream >fixnum
+ "resource:core/io/test/binary.txt" latin1
+ [ 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:core/io/test/separator-test.txt"
+ latin1 [
"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 write flush ] unit-test
-
-! [
-! "/core/io/test/binary.txt"
-! [ 0.2 read ] with-stream
-! ] must-fail
diff --git a/core/io/io.factor b/core/io/io.factor
index ef9eae7902..e28fd28fb3 100755
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -30,39 +30,52 @@ GENERIC: stream-write-table ( table-cells style stream -- )
[ 2dup (stream-copy) ] [ dispose dispose ] [ ]
cleanup ;
-! Default stream
-SYMBOL: stdio
+! Default streams
+SYMBOL: input-stream
+SYMBOL: output-stream
+SYMBOL: error-stream
-! Default error stream
-SYMBOL: stderr
+: readln ( -- str/f ) input-stream get stream-readln ;
+: read1 ( -- ch/f ) input-stream get stream-read1 ;
+: read ( n -- str/f ) input-stream get stream-read ;
+: read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ;
-: readln ( -- str/f ) stdio get stream-readln ;
-: read1 ( -- ch/f ) stdio get stream-read1 ;
-: read ( n -- str/f ) stdio get stream-read ;
-: read-until ( seps -- str/f sep/f ) stdio get stream-read-until ;
+: write1 ( ch -- ) output-stream get stream-write1 ;
+: write ( str -- ) output-stream get stream-write ;
+: flush ( -- ) output-stream get stream-flush ;
-: write1 ( ch -- ) stdio get stream-write1 ;
-: write ( str -- ) stdio get stream-write ;
-: flush ( -- ) stdio get stream-flush ;
+: nl ( -- ) output-stream get stream-nl ;
+: format ( str style -- ) output-stream get stream-format ;
-: nl ( -- ) stdio get stream-nl ;
-: format ( str style -- ) stdio get stream-format ;
+: with-input-stream* ( stream quot -- )
+ input-stream swap with-variable ; inline
-: with-stream* ( stream quot -- )
- stdio swap with-variable ; inline
+: with-input-stream ( stream quot -- )
+ [ with-input-stream* ] curry with-disposal ; inline
-: with-stream ( stream quot -- )
- [ with-stream* ] curry with-disposal ; inline
+: with-output-stream* ( stream quot -- )
+ output-stream swap with-variable ; inline
+
+: with-output-stream ( stream quot -- )
+ [ with-output-stream* ] curry with-disposal ; inline
+
+: with-streams* ( input output quot -- )
+ [ output-stream set input-stream set ] prepose with-scope ; inline
+
+: with-streams ( input output quot -- )
+ [ [ with-streams* ] 3curry ]
+ [ [ drop dispose dispose ] 3curry ] 3bi
+ [ ] cleanup ; inline
: tabular-output ( style quot -- )
- swap >r { } make r> stdio get stream-write-table ; inline
+ swap >r { } make r> output-stream get stream-write-table ; inline
: with-row ( quot -- )
{ } make , ; inline
: with-cell ( quot -- )
- H{ } stdio get make-cell-stream
- [ swap with-stream ] keep , ; inline
+ H{ } output-stream get make-cell-stream
+ [ swap with-output-stream ] keep , ; inline
: write-cell ( str -- )
[ write ] with-cell ; inline
@@ -71,13 +84,14 @@ SYMBOL: stderr
swap dup assoc-empty? [
drop call
] [
- stdio get make-span-stream swap with-stream
+ output-stream get make-span-stream swap with-output-stream
] if ; inline
: with-nesting ( style quot -- )
- >r stdio get make-block-stream r> with-stream ; inline
+ >r output-stream get make-block-stream
+ r> with-output-stream ; inline
-: print ( string -- ) stdio get stream-print ;
+: print ( string -- ) output-stream get stream-print ;
: bl ( -- ) " " write ;
@@ -85,9 +99,9 @@ SYMBOL: stderr
presented associate format ;
: lines ( stream -- seq )
- [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
+ [ [ readln dup ] [ ] [ drop ] unfold ] with-input-stream ;
: contents ( stream -- str )
[
[ 65536 read dup ] [ ] [ drop ] unfold concat f like
- ] with-stream ;
+ ] with-input-stream ;
diff --git a/core/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor
index 741725af41..7b27621343 100644
--- a/core/io/streams/byte-array/byte-array-docs.factor
+++ b/core/io/streams/byte-array/byte-array-docs.factor
@@ -25,10 +25,10 @@ HELP:
HELP: with-byte-reader
{ $values { "encoding" "an encoding descriptor" }
{ "quot" quotation } { "byte-array" byte-array } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream for reading from a byte array using an encoding." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
HELP: with-byte-writer
{ $values { "encoding" "an encoding descriptor" }
{ "quot" quotation }
{ "byte-array" byte-array } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an output stream writing data to a byte array using an encoding." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;
diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor
index 2a8441ff23..28d789d66f 100644
--- a/core/io/streams/byte-array/byte-array.factor
+++ b/core/io/streams/byte-array/byte-array.factor
@@ -1,16 +1,16 @@
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces io.encodings.private ;
+sequences io namespaces io.encodings.private accessors ;
IN: io.streams.byte-array
: ( encoding -- stream )
512 swap ;
: with-byte-writer ( encoding quot -- byte-array )
- >r r> [ stdio get ] compose with-stream*
- dup encoder? [ encoder-stream ] when >byte-array ; inline
+ >r r> [ output-stream get ] compose with-output-stream*
+ dup encoder? [ stream>> ] when >byte-array ; inline
: ( byte-array encoding -- stream )
>r >byte-vector dup reverse-here r> ;
: with-byte-reader ( byte-array encoding quot -- )
- >r r> with-stream ; inline
+ >r r> with-input-stream* ; inline
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index 372acbe0c1..91732f3211 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io io.encodings
sequences math generic threads.private classes io.backend
-io.streams.duplex io.files continuations byte-arrays ;
+io.files continuations byte-arrays ;
IN: io.streams.c
TUPLE: c-writer handle ;
diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor
deleted file mode 100755
index c9691af5ba..0000000000
--- a/core/io/streams/duplex/duplex-docs.factor
+++ /dev/null
@@ -1,19 +0,0 @@
-USING: help.markup help.syntax io continuations ;
-IN: io.streams.duplex
-
-ARTICLE: "io.streams.duplex" "Duplex streams"
-"Duplex streams combine an input stream and an output stream into a bidirectional stream."
-{ $subsection duplex-stream }
-{ $subsection } ;
-
-ABOUT: "io.streams.duplex"
-
-HELP: duplex-stream
-{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
-
-HELP:
-{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
-{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
-
-HELP: stream-closed-twice
-{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
diff --git a/core/io/streams/string/string-docs.factor b/core/io/streams/string/string-docs.factor
index 5b09baa56d..b87e5ca591 100644
--- a/core/io/streams/string/string-docs.factor
+++ b/core/io/streams/string/string-docs.factor
@@ -17,7 +17,7 @@ HELP:
HELP: with-string-writer
{ $values { "quot" quotation } { "str" string } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ;
HELP:
{ $values { "str" string } { "stream" "an input stream" } }
@@ -26,4 +26,4 @@ HELP:
HELP: with-string-reader
{ $values { "str" string } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ;
diff --git a/core/io/streams/string/string-tests.factor b/core/io/streams/string/string-tests.factor
index ca117534da..3512ac871d 100644
--- a/core/io/streams/string/string-tests.factor
+++ b/core/io/streams/string/string-tests.factor
@@ -35,7 +35,7 @@ unit-test
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,
- ] with-stream
+ ] with-input-stream
] { } make
] unit-test
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
index b7ff37a971..d43599776b 100755
--- a/core/io/streams/string/string.factor
+++ b/core/io/streams/string/string.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
-io.encodings io.encodings.private ;
+io.encodings io.encodings.private math.order ;
IN: io.streams.string
M: growable dispose drop ;
@@ -15,7 +15,7 @@ M: growable stream-flush drop ;
512 ;
: with-string-writer ( quot -- str )
- swap [ stdio get ] compose with-stream*
+ swap [ output-stream get ] compose with-output-stream*
>string ; inline
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
@@ -56,7 +56,7 @@ M: null decode-char drop stream-read1 ;
>sbuf dup reverse-here null ;
: with-string-reader ( str quot -- )
- >r r> with-stream ; inline
+ >r r> with-input-stream ; inline
INSTANCE: growable plain-writer
@@ -67,15 +67,14 @@ INSTANCE: growable plain-writer
] unless ;
: map-last ( seq quot -- seq )
- swap dup length
- [ zero? rot [ call ] keep swap ] 2map nip ; inline
+ >r dup length [ zero? ] r> compose 2map ; inline
: format-table ( table -- seq )
flip [ format-column ] map-last
flip [ " " join ] map ;
M: plain-writer stream-write-table
- [ drop format-table [ print ] each ] with-stream* ;
+ [ drop format-table [ print ] each ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop ;
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 4578e2a93f..0ef8919713 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -1,7 +1,7 @@
USING: generic help.markup help.syntax math memory
-namespaces sequences kernel.private layouts sorting classes
+namespaces sequences kernel.private layouts classes
kernel.private vectors combinators quotations strings words
-assocs arrays ;
+assocs arrays math.order ;
IN: kernel
ARTICLE: "shuffle-words" "Shuffle words"
@@ -241,7 +241,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
-ARTICLE: "equality" "Equality and comparison testing"
+ARTICLE: "equality" "Equality"
"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
$nl
"Identity comparison:"
@@ -250,15 +250,8 @@ $nl
{ $subsection = }
"Custom value comparison methods:"
{ $subsection equal? }
+"Utility class:"
{ $subsection identity-tuple }
-"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
-{ $subsection <=> }
-{ $subsection compare }
-"Utilities for comparing objects:"
-{ $subsection after? }
-{ $subsection before? }
-{ $subsection after=? }
-{ $subsection before=? }
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
@@ -393,29 +386,6 @@ HELP: identity-tuple
{ $unchecked-example "T{ foo } dup clone = ." "f" }
} ;
-HELP: <=>
-{ $values { "obj1" object } { "obj2" object } { "n" real } }
-{ $contract
- "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
- $nl
- "The output value is one of the following:"
- { $list
- { "positive - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
- { "zero - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
- { "negative - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
- }
- "The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically."
-} ;
-
-{ <=> compare natural-sort sort-keys sort-values } related-words
-
-HELP: compare
-{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } }
-{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
-{ $examples
- { $example "USING: kernel prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" }
-} ;
-
HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 95f0d60720..a72e25b9e0 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -133,8 +133,6 @@ M: identity-tuple equal? 2drop f ;
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline
-GENERIC: <=> ( obj1 obj2 -- n )
-
GENERIC: clone ( obj -- cloned )
M: object clone ;
@@ -158,6 +156,9 @@ M: callstack clone (clone) ;
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
+: prepose ( quot1 quot2 -- curry )
+ swap compose ; inline
+
: 3compose ( quot1 quot2 quot3 -- curry )
compose compose ; inline
@@ -176,8 +177,6 @@ M: callstack clone (clone) ;
: either? ( x y quot -- ? ) bi@ or ; inline
-: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
-
: most ( x y quot -- z )
>r 2dup r> call [ drop ] [ nip ] if ; inline
diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor
index 879862c926..19fe03202c 100755
--- a/core/layouts/layouts.factor
+++ b/core/layouts/layouts.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel assocs classes
-kernel.private ;
+math.order kernel.private ;
IN: layouts
SYMBOL: tag-mask
diff --git a/core/listener/listener-docs.factor b/core/listener/listener-docs.factor
index 755c79ac68..beea9005b4 100755
--- a/core/listener/listener-docs.factor
+++ b/core/listener/listener-docs.factor
@@ -32,14 +32,14 @@ HELP: listener-hook
HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
-{ $description "Reads a Factor expression which possibly spans more than one line from " { $link stdio } " stream. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
+{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
HELP: listen
-{ $description "Prompts for an expression on the " { $link stdio } " stream and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
-{ $errors "If the expression input by the user throws an error, the error is printed to the " { $link stdio } " stream and the word returns normally." } ;
+{ $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
+{ $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ;
HELP: listener
-{ $description "Prompts for expressions on the " { $link stdio } " stream and evaluates them until end of file is reached." } ;
+{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
HELP: bye
{ $description "Exits the current listener." }
diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor
index 2c05c049a7..24449049e0 100755
--- a/core/listener/listener-tests.factor
+++ b/core/listener/listener-tests.factor
@@ -51,6 +51,6 @@ IN: listener.tests
[
[ ] [
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
- drop
+ drop
] unit-test
] with-file-vocabs
diff --git a/core/listener/listener.factor b/core/listener/listener.factor
index ddb29bb768..e00e64f4bc 100755
--- a/core/listener/listener.factor
+++ b/core/listener/listener.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
-io.streams.duplex vectors words generic system combinators
-continuations debugger definitions compiler.units accessors ;
+vectors words generic system combinators continuations debugger
+definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
@@ -35,10 +35,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
M: object stream-read-quot
V{ } clone read-quot-loop ;
-M: duplex-stream stream-read-quot
- duplex-stream-in stream-read-quot ;
-
-: read-quot ( -- quot/f ) stdio get stream-read-quot ;
+: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
: bye ( -- ) quit-flag on ;
@@ -46,9 +43,13 @@ M: duplex-stream stream-read-quot
"( " in get " )" 3append
H{ { background { 1 0.7 0.7 1 } } } format bl flush ;
+SYMBOL: error-hook
+
+[ print-error-and-restarts ] error-hook set-global
+
: listen ( -- )
listener-hook get call prompt.
- [ read-quot [ try ] [ bye ] if* ]
+ [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup parse-error? [
error-hook get call
diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor
index 30abd9cad6..5cd6f067a9 100755
--- a/core/math/floats/floats.factor
+++ b/core/math/floats/floats.factor
@@ -6,8 +6,6 @@ IN: math.floats.private
M: fixnum >float fixnum>float ;
M: bignum >float bignum>float ;
-M: float zero? dup 0.0 float= swap -0.0 float= or ;
-
M: float >fixnum float>fixnum ;
M: float >bignum float>bignum ;
M: float >float ;
@@ -22,4 +20,7 @@ M: float + float+ ;
M: float - float- ;
M: float * float* ;
M: float / float/f ;
+M: float /f float/f ;
M: float mod float-mod ;
+
+M: real abs dup 0 < [ neg ] when ;
diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor
index fe8e5bddc8..db50d262ad 100755
--- a/core/math/integers/integers-tests.factor
+++ b/core/math/integers/integers-tests.factor
@@ -1,5 +1,5 @@
-USING: kernel math namespaces prettyprint
-math.private continuations tools.test sequences ;
+USING: kernel math math.functions namespaces prettyprint
+math.private continuations tools.test sequences random ;
IN: math.integers.tests
[ "-8" ] [ -8 unparse ] unit-test
@@ -191,3 +191,31 @@ unit-test
[ f ] [ -128 power-of-2? ] unit-test
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test
+
+: ratio>float [ >bignum ] bi@ /f ;
+
+[ 5. ] [ 5 1 ratio>float ] unit-test
+[ 4. ] [ 4 1 ratio>float ] unit-test
+[ 2. ] [ 2 1 ratio>float ] unit-test
+[ .5 ] [ 1 2 ratio>float ] unit-test
+[ .75 ] [ 3 4 ratio>float ] unit-test
+[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
+[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
+[ 0.4 ] [ 6 15 ratio>float ] unit-test
+
+[ HEX: 3fe553522d230931 ]
+[ 61967020039 92984792073 ratio>float double>bits ] unit-test
+
+: random-integer
+ 32 random-bits
+ 1 random zero? [ neg ] when
+ 1 random zero? [ >bignum ] when ;
+
+[ t ] [
+ 1000 [
+ drop
+ random-integer
+ random-integer
+ [ >float / ] [ /f ] 2bi 0.1 ~
+ ] all?
+] unit-test
diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor
index 70a6d2e087..6563a1cd11 100755
--- a/core/math/integers/integers.factor
+++ b/core/math/integers/integers.factor
@@ -1,4 +1,5 @@
! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2008, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences
sequences.private math math.private combinators ;
@@ -22,6 +23,8 @@ M: fixnum + fixnum+ ;
M: fixnum - fixnum- ;
M: fixnum * fixnum* ;
M: fixnum /i fixnum/i ;
+M: fixnum /f >r >float r> >float float/f ;
+
M: fixnum mod fixnum-mod ;
M: fixnum /mod fixnum/mod ;
@@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ;
M: bignum bit? bignum-bit? ;
M: bignum (log2) bignum-log2 ;
-M: integer zero? 0 number= ;
+! Converting ratios to floats. Based on FLOAT-RATIO from
+! sbcl/src/code/float.lisp, which has the following license:
+
+! "The software is in the public domain and is
+! provided with absolutely no warranty."
+
+! First step: pre-scaling
+: twos ( x -- y ) dup 1- bitxor log2 ; inline
+
+: scale-denonimator ( den -- scaled-den scale' )
+ dup twos neg [ shift ] keep ; inline
+
+: pre-scale ( num den -- scale shifted-num scaled-den )
+ 2dup [ log2 ] bi@ -
+ tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
+ -rot ; inline
+
+! Second step: loop
+: shift-mantissa ( scale mantissa -- scale' mantissa' )
+ [ 1+ ] [ 2/ ] bi* ; inline
+
+: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
+ [ 2dup /i log2 53 > ]
+ [ >r shift-mantissa r> ]
+ [ ] while /mod ; inline
+
+! Third step: post-scaling
+: unscaled-float ( mantissa -- n )
+ 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
+
+: scale-float ( scale mantissa -- float' )
+ >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
+
+: post-scale ( scale mantissa -- n )
+ 2/ dup log2 52 > [ shift-mantissa ] when
+ unscaled-float scale-float ; inline
+
+! Main word
+: /f-abs ( m n -- f )
+ over zero? [
+ 2drop 0.0
+ ] [
+ dup zero? [
+ 2drop 1.0/0.0
+ ] [
+ pre-scale
+ /f-loop over odd?
+ [ zero? [ 1+ ] unless ] [ drop ] if
+ post-scale
+ ] if
+ ] if ; inline
+
+M: bignum /f ( m n -- f )
+ [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;
diff --git a/core/math/intervals/intervals-docs.factor b/core/math/intervals/intervals-docs.factor
index 7eb20090ab..59fb0df18e 100644
--- a/core/math/intervals/intervals-docs.factor
+++ b/core/math/intervals/intervals-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax math ;
+USING: help.markup help.syntax math math.order ;
IN: math.intervals
ARTICLE: "math-intervals-new" "Creating intervals"
diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor
index 5204d7d45a..ba728e67c0 100755
--- a/core/math/intervals/intervals-tests.factor
+++ b/core/math/intervals/intervals-tests.factor
@@ -1,5 +1,5 @@
-USING: math.intervals kernel sequences words math arrays
-prettyprint tools.test random vocabs combinators ;
+USING: math.intervals kernel sequences words math math.order
+arrays prettyprint tools.test random vocabs combinators ;
IN: math.intervals.tests
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 77d60e67f8..324d628fd1 100755
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
-USING: kernel sequences arrays math combinators ;
+USING: kernel sequences arrays math combinators math.order ;
IN: math.intervals
TUPLE: interval from to ;
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index c8a763b5f7..b15f09e49d 100755
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -79,28 +79,6 @@ HELP: >=
{ $values { "x" real } { "y" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
-HELP: before?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
-{ $notes "Implemented using " { $link <=> } "." } ;
-
-HELP: after?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
-{ $notes "Implemented using " { $link <=> } "." } ;
-
-HELP: before=?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
-{ $notes "Implemented using " { $link <=> } "." } ;
-
-HELP: after=?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
-{ $notes "Implemented using " { $link <=> } "." } ;
-
-{ before? after? before=? after=? } related-words
-
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
@@ -275,19 +253,6 @@ HELP: recip
{ $description "Computes a number's multiplicative inverse." }
{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
-HELP: max
-{ $values { "x" real } { "y" real } { "z" real } }
-{ $description "Outputs the greatest of two real numbers." } ;
-
-HELP: min
-{ $values { "x" real } { "y" real } { "z" real } }
-{ $description "Outputs the smallest of two real numbers." } ;
-
-HELP: between?
-{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
-{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
-
HELP: rem
{ $values { "x" integer } { "y" integer } { "z" integer } }
{ $description
@@ -333,10 +298,6 @@ HELP: times
{ $description "Calls the quotation " { $snippet "n" } " times." }
{ $notes "If you need to pass the current index to the quotation, use " { $link each } "." } ;
-HELP: [-]
-{ $values { "x" real } { "y" real } { "z" real } }
-{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
-
HELP: fp-nan?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
diff --git a/core/math/math.factor b/core/math/math.factor
index 14cbe68351..0218ded6ff 100755
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -17,15 +17,11 @@ MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
-: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline
-: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline
-: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline
-: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline
-
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable
MATH: / ( x y -- z ) foldable
+MATH: /f ( x y -- z ) foldable
MATH: /i ( x y -- z ) foldable
MATH: mod ( x y -- z ) foldable
@@ -38,6 +34,8 @@ GENERIC# shift 1 ( x n -- y ) foldable
GENERIC: bitnot ( x -- y ) foldable
GENERIC# bit? 1 ( x n -- ? ) foldable
+GENERIC: abs ( x -- y ) foldable
+
(log2)
] if ; foldable
-GENERIC: zero? ( x -- ? ) foldable
-
-M: object zero? drop f ;
-
+: zero? ( x -- ? ) 0 number= ; inline
: 1+ ( x -- y ) 1 + ; inline
: 1- ( x -- y ) 1 - ; inline
: 2/ ( x -- y ) -1 shift ; inline
: sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline
+: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: ?1+ [ 1+ ] [ 0 ] if* ; inline
-: /f ( x y -- z ) >r >float r> >float float/f ; inline
-
-: max ( x y -- z ) [ > ] most ; inline
-: min ( x y -- z ) [ < ] most ; inline
-
-: between? ( x y z -- ? )
- pick >= [ >= ] [ 2drop f ] if ; inline
-
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
-: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
-
-: [-] ( x y -- z ) - 0 max ; inline
-
: 2^ ( n -- 2^n ) 1 swap shift ; inline
: even? ( n -- ? ) 1 bitand zero? ;
@@ -96,13 +80,6 @@ M: number equal? number= ;
M: real hashcode* nip >fixnum ;
-M: real <=> - ;
-
-! real and sequence overlap. we disambiguate:
-M: integer hashcode* nip >fixnum ;
-
-M: integer <=> - ;
-
GENERIC: fp-nan? ( x -- ? )
M: object fp-nan?
@@ -161,7 +138,7 @@ PRIVATE>
iterate-prep (each-integer) ; inline
: times ( n quot -- )
- [ drop ] swap compose each-integer ; inline
+ [ drop ] prepose each-integer ; inline
: find-integer ( n quot -- i )
iterate-prep (find-integer) ; inline
diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor
new file mode 100644
index 0000000000..23ea1058ad
--- /dev/null
+++ b/core/math/order/order-docs.factor
@@ -0,0 +1,94 @@
+USING: help.markup help.syntax kernel math quotations
+math.private words ;
+IN: math.order
+
+HELP: <=>
+{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } }
+{ $contract
+ "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
+ $nl
+ "The output value is one of the following:"
+ { $list
+ { { $link +lt+ } " - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
+ { { $link +eq+ } " - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
+ { { $link +gt+ } " - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
+ }
+} ;
+
+HELP: +lt+
+{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ;
+
+HELP: +eq+
+{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ;
+
+HELP: +gt+
+{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
+
+HELP: invert-comparison
+{ $values { "symbol" symbol }
+ { "new-symbol" symbol } }
+{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
+{ $examples
+ { $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
+
+HELP: compare
+{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
+{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
+{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" }
+} ;
+
+HELP: max
+{ $values { "x" real } { "y" real } { "z" real } }
+{ $description "Outputs the greatest of two real numbers." } ;
+
+HELP: min
+{ $values { "x" real } { "y" real } { "z" real } }
+{ $description "Outputs the smallest of two real numbers." } ;
+
+HELP: between?
+{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
+{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
+
+HELP: before?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: before=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+{ before? after? before=? after=? } related-words
+
+HELP: [-]
+{ $values { "x" real } { "y" real } { "z" real } }
+{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
+
+ARTICLE: "math.order" "Ordered objects"
+"Some classes have an intrinsic order amongst instances:"
+{ $subsection <=> }
+{ $subsection compare }
+{ $subsection invert-comparison }
+"The above words return one of the following symbols:"
+{ $subsection +lt+ }
+{ $subsection +eq+ }
+{ $subsection +gt+ }
+"Utilities for comparing objects:"
+{ $subsection after? }
+{ $subsection before? }
+{ $subsection after=? }
+{ $subsection before=? } ;
+
+ABOUT: "math.order"
diff --git a/core/math/order/order-tests.factor b/core/math/order/order-tests.factor
new file mode 100644
index 0000000000..665537be5d
--- /dev/null
+++ b/core/math/order/order-tests.factor
@@ -0,0 +1,9 @@
+USING: kernel math.order tools.test ;
+IN: math.order.tests
+
+[ +lt+ ] [ "ab" "abc" <=> ] unit-test
+[ +gt+ ] [ "abc" "ab" <=> ] unit-test
+[ +lt+ ] [ 3 4 <=> ] unit-test
+[ +eq+ ] [ 4 4 <=> ] unit-test
+[ +gt+ ] [ 4 3 <=> ] unit-test
+
diff --git a/core/math/order/order.factor b/core/math/order/order.factor
new file mode 100644
index 0000000000..76fe058ffa
--- /dev/null
+++ b/core/math/order/order.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math ;
+IN: math.order
+
+SYMBOL: +lt+
+SYMBOL: +eq+
+SYMBOL: +gt+
+
+: invert-comparison ( symbol -- new-symbol )
+ #! Can't use case, index or nth here
+ dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
+
+GENERIC: <=> ( obj1 obj2 -- symbol )
+
+M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
+
+GENERIC: before? ( obj1 obj2 -- ? )
+GENERIC: after? ( obj1 obj2 -- ? )
+GENERIC: before=? ( obj1 obj2 -- ? )
+GENERIC: after=? ( obj1 obj2 -- ? )
+
+M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
+M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
+M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
+M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
+
+M: real before? ( obj1 obj2 -- ? ) < ;
+M: real after? ( obj1 obj2 -- ? ) > ;
+M: real before=? ( obj1 obj2 -- ? ) <= ;
+M: real after=? ( obj1 obj2 -- ? ) >= ;
+
+: min ( x y -- z ) [ before? ] most ; inline
+: max ( x y -- z ) [ after? ] most ; inline
+
+: between? ( x y z -- ? )
+ pick after=? [ after=? ] [ 2drop f ] if ; inline
+
+: [-] ( x y -- z ) - 0 max ; inline
+
+: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline
diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor
index baa6634a9f..15234ee310 100755
--- a/core/math/parser/parser-tests.factor
+++ b/core/math/parser/parser-tests.factor
@@ -98,3 +98,9 @@ unit-test
[ 1 1 >base ] must-fail
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail
+
+[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
+
+[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
+
+[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor
index 1a1a080564..d1b8e6fd37 100755
--- a/core/math/parser/parser.factor
+++ b/core/math/parser/parser.factor
@@ -140,9 +140,9 @@ M: ratio >base
M: float >base
drop {
+ { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
- { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
[ float>string fix-float ]
} cond ;
diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor
index dc4315fb39..60de841568 100755
--- a/core/mirrors/mirrors-docs.factor
+++ b/core/mirrors/mirrors-docs.factor
@@ -30,6 +30,7 @@ HELP:
{ $examples
{ $example
"USING: assocs mirrors prettyprint ;"
+ "IN: scratchpad"
"TUPLE: circle center radius ;"
"C: circle"
"{ 100 50 } 15 >alist ."
@@ -37,10 +38,6 @@ HELP:
}
} ;
-HELP: >mirror<
-{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
-
HELP: make-mirror
{ $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ;
diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor
index 11e5772000..45970c8bae 100755
--- a/core/mirrors/mirrors-tests.factor
+++ b/core/mirrors/mirrors-tests.factor
@@ -1,4 +1,4 @@
-USING: mirrors tools.test assocs kernel arrays ;
+USING: mirrors tools.test assocs kernel arrays accessors ;
IN: mirrors.tests
TUPLE: foo bar baz ;
@@ -14,3 +14,15 @@ C: foo
[ 3 ] [
3 "baz" 1 2 [ set-at ] keep foo-baz
] unit-test
+
+[ 3 "hi" 1 2 set-at ] [
+ [ no-such-slot? ]
+ [ name>> "hi" = ]
+ [ object>> foo? ] tri and and
+] must-fail-with
+
+[ 3 "numerator" 1/2 set-at ] [
+ [ immutable-slot? ]
+ [ name>> "numerator" = ]
+ [ object>> 1/2 = ] tri and and
+] must-fail-with
diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor
index 02afaf07fc..0a49163075 100755
--- a/core/mirrors/mirrors.factor
+++ b/core/mirrors/mirrors.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple math vectors
-quotations sorting prettyprint ;
+quotations sorting prettyprint accessors ;
IN: mirrors
: all-slots ( class -- slots )
@@ -16,33 +16,32 @@ TUPLE: mirror object slots ;
: ( object -- mirror )
dup object-slots mirror boa ;
-: >mirror< ( mirror -- obj slots )
- dup mirror-object swap mirror-slots ;
+ERROR: no-such-slot object name ;
-: mirror@ ( slot-name mirror -- obj slot-spec )
- >mirror< swapd slot-named ;
+ERROR: immutable-slot object name ;
M: mirror at*
- mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
+ [ nip object>> ] [ slots>> slot-named ] 2bi
+ dup [ offset>> slot t ] [ 2drop f f ] if ;
M: mirror set-at ( val key mirror -- )
- mirror@ dup [
- dup slot-spec-writer [
- slot-spec-offset set-slot
+ [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
+ dup writer>> [
+ nip offset>> set-slot
] [
- "Immutable slot" throw
+ drop immutable-slot
] if
] [
- "No such slot" throw
+ drop no-such-slot
] if ;
M: mirror delete-at ( key mirror -- )
f -rot set-at ;
M: mirror >alist ( mirror -- alist )
- >mirror<
- [ [ slot-spec-offset slot ] with map ] keep
- [ slot-spec-name ] map swap zip ;
+ [ slots>> [ name>> ] map ]
+ [ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
+ zip ;
M: mirror assoc-size mirror-slots length ;
@@ -50,7 +49,7 @@ INSTANCE: mirror assoc
: sort-assoc ( assoc -- alist )
>alist
- [ dup first unparse-short swap ] { } map>assoc
+ [ [ first unparse-short ] keep ] { } map>assoc
sort-keys values ;
GENERIC: make-mirror ( obj -- assoc )
diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor
index 971477cd4d..1da3bc45db 100755
--- a/core/namespaces/namespaces-docs.factor
+++ b/core/namespaces/namespaces-docs.factor
@@ -87,7 +87,7 @@ HELP: +@
{ $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
{ $side-effects "variable" }
{ $examples
- { $example "USING: namespaces prettyprint ;" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" }
+ { $example "USING: namespaces prettyprint ;" "IN: scratchpad" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" }
} ;
HELP: inc
diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor
index 8dc065c04a..4c11e2389f 100644
--- a/core/namespaces/namespaces-tests.factor
+++ b/core/namespaces/namespaces-tests.factor
@@ -1,5 +1,5 @@
-IN: namespaces.tests
USING: kernel namespaces tools.test words ;
+IN: namespaces.tests
H{ } clone "test-namespace" set
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
index 9630f9dc70..9b70ccdd9d 100755
--- a/core/optimizer/backend/backend.factor
+++ b/core/optimizer/backend/backend.factor
@@ -87,7 +87,7 @@ M: node optimize-node* drop t f ;
: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
[ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
- [ = not ] assoc-subset >hashtable ;
+ [ = not ] assoc-filter >hashtable ;
: cleanup-inlining ( #return/#values -- newnode changed? )
dup node-successor [
diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor
index 976156db77..7ab0ffc806 100755
--- a/core/optimizer/control/control.factor
+++ b/core/optimizer/control/control.factor
@@ -75,7 +75,7 @@ USE: prettyprint
M: #call-label collect-label-info*
node-param label-info get at
node-stack get over third tail
- [ [ #label? ] subset [ node-param ] map ] keep
+ [ [ #label? ] filter [ node-param ] map ] keep
[ node-successor #tail? ] all? 2array
swap second push ;
@@ -91,7 +91,7 @@ SYMBOL: potential-loops
: remove-non-tail-calls ( -- )
label-info get
- [ nip second [ second ] all? ] assoc-subset
+ [ nip second [ second ] all? ] assoc-filter
[ first ] assoc-map
potential-loops set ;
@@ -154,9 +154,9 @@ SYMBOL: potential-loops
node-literal t
] [
node-class {
- { [ dup null class< ] [ drop f f ] }
- { [ dup \ f class-not class< ] [ drop t t ] }
- { [ dup \ f class< ] [ drop f t ] }
+ { [ dup null class<= ] [ drop f f ] }
+ { [ dup \ f class-not class<= ] [ drop t t ] }
+ { [ dup \ f class<= ] [ drop f t ] }
[ drop f f ]
} cond
] if ;
diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor
index 914018437a..f49ab7fcba 100755
--- a/core/optimizer/def-use/def-use-tests.factor
+++ b/core/optimizer/def-use/def-use-tests.factor
@@ -1,6 +1,6 @@
IN: optimizer.def-use.tests
USING: inference inference.dataflow optimizer optimizer.def-use
-namespaces assocs kernel sequences math tools.test words ;
+namespaces assocs kernel sequences math tools.test words sets ;
[ 3 { 1 1 1 } ] [
[ 1 2 3 ] dataflow compute-def-use drop
@@ -11,10 +11,6 @@ namespaces assocs kernel sequences math tools.test words ;
dataflow compute-def-use drop compute-dead-literals keys
[ value-literal ] map ;
-: subset? [ member? ] curry all? ;
-
-: set= 2dup subset? >r swap subset? r> and ;
-
[ { [ + ] } ] [
[ [ 1 2 3 ] [ + ] over drop drop ] kill-set
] unit-test
diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor
index 66bffd9767..a2e9f88135 100755
--- a/core/optimizer/def-use/def-use.factor
+++ b/core/optimizer/def-use/def-use.factor
@@ -56,7 +56,7 @@ UNION: #killable
: purge-invariants ( stacks -- seq )
#! Output a sequence of values which are not present in the
#! same position in each sequence of the stacks sequence.
- unify-lengths flip [ all-eq? not ] subset concat ;
+ unify-lengths flip [ all-eq? not ] filter concat ;
M: #label node-def-use
[
@@ -75,7 +75,7 @@ M: #branch node-def-use
dup branch-def-use (node-def-use) ;
: compute-dead-literals ( -- values )
- def-use get [ >r value? r> empty? and ] assoc-subset ;
+ def-use get [ >r value? r> empty? and ] assoc-filter ;
DEFER: kill-nodes
SYMBOL: dead-literals
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index 33c8244b4c..393264e459 100755
--- a/core/optimizer/inlining/inlining.factor
+++ b/core/optimizer/inlining/inlining.factor
@@ -77,7 +77,7 @@ DEFER: (flat-length)
float real
complex number
object
- } [ class< ] with find nip ;
+ } [ class<= ] with find nip ;
: inlining-math-method ( #call word -- quot/f )
swap node-input-classes
@@ -111,7 +111,7 @@ DEFER: (flat-length)
: comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes
#! are disjoint, return t.
- 2dup class< >r classes-intersect? not r> or ;
+ 2dup class<= >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
@@ -132,7 +132,7 @@ DEFER: (flat-length)
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
- node-class-first r> class< ;
+ node-class-first r> class<= ;
: optimize-predicate ( #call -- node )
#! If the predicate is followed by a branch we fold it
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 91d0c1c0de..d1dbefe26b 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -4,7 +4,7 @@ IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
inference.class kernel assocs math math.private kernel.private
sequences words parser vectors strings sbufs io namespaces
-assocs quotations sequences.private io.binary io.crc32
+assocs quotations sequences.private io.binary
io.streams.string layouts splitting math.intervals
math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend
@@ -60,7 +60,8 @@ sequences.private combinators ;
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
- [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
+ [ literalize [ t ] ] { } map>assoc
+ [ drop f ] suffix [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot f splice-quot ;
@@ -125,8 +126,6 @@ sequences.private combinators ;
\ >sbuf { string } "specializer" set-word-prop
-\ crc32 { string } "specializer" set-word-prop
-
\ split, { string string } "specializer" set-word-prop
\ memq? { array } "specializer" set-word-prop
diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor
index ab8a1f3eda..72e64d5b95 100755
--- a/core/optimizer/math/math.factor
+++ b/core/optimizer/math/math.factor
@@ -96,7 +96,7 @@ optimizer.math.partial generic.standard system accessors ;
: math-closure ( class -- newclass )
{ null fixnum bignum integer rational float real number }
- [ class< ] with find nip number or ;
+ [ class<= ] with find nip number or ;
: fits? ( interval class -- ? )
"interval" word-prop dup
@@ -108,7 +108,7 @@ optimizer.math.partial generic.standard system accessors ;
dup r> at swap or ;
: won't-overflow? ( interval node -- ? )
- node-in-d [ value-class* fixnum class< ] all?
+ node-in-d [ value-class* fixnum class<= ] all?
swap fixnum fits? and ;
: post-process ( class interval node -- classes intervals )
@@ -214,7 +214,7 @@ optimizer.math.partial generic.standard system accessors ;
: twiddle-interval ( i1 -- i2 )
dup [
node get node-in-d
- [ value-class* integer class< ] all?
+ [ value-class* integer class<= ] all?
[ integral-closure ] when
] when ;
@@ -293,7 +293,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
! Removing overflow checks
: remove-overflow-check? ( #call -- ? )
dup out-d>> first node-class
- [ fixnum class< ] [ null eq? not ] bi and ;
+ [ fixnum class<= ] [ null eq? not ] bi and ;
{
{ + [ fixnum+fast ] }
@@ -356,7 +356,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
dup #call? [ node-param eq? ] [ 2drop f ] if ;
: coerced-to-fixnum? ( #call -- ? )
- dup dup node-in-d [ node-class integer class< ] with all?
+ dup dup node-in-d [ node-class integer class<= ] with all?
[ \ >fixnum consumed-by? ] [ drop f ] if ;
{
@@ -377,7 +377,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
: convert-rem-to-and? ( #call -- ? )
dup node-in-d {
- { [ 2dup first node-class integer class< not ] [ f ] }
+ { [ 2dup first node-class integer class<= not ] [ f ] }
{ [ 2dup second node-literal integer? not ] [ f ] }
{ [ 2dup second node-literal power-of-2? not ] [ f ] }
[ t ]
diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor
index bbe1d0a83f..8b5e25deb1 100644
--- a/core/optimizer/math/partial/partial.factor
+++ b/core/optimizer/math/partial/partial.factor
@@ -85,7 +85,7 @@ PREDICATE: math-partial < word
: define-math-ops ( op -- )
{ fixnum bignum float }
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
- [ nip ] assoc-subset
+ [ nip ] assoc-filter
[ word-def peek ] assoc-map % ;
SYMBOL: math-ops
@@ -155,7 +155,7 @@ SYMBOL: fast-math-ops
[ drop math-class-max swap specific-method >boolean ] if ;
: (derived-ops) ( word assoc -- words )
- swap [ rot first eq? nip ] curry assoc-subset values ;
+ swap [ rot first eq? nip ] curry assoc-filter values ;
: derived-ops ( word -- words )
[ 1array ]
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index 14dcd62c61..6f4ae2c1d5 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -1,9 +1,9 @@
USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
-strings tools.test vectors words sequences.private quotations
-optimizer.backend classes classes.algebra inference.dataflow
-classes.tuple.private continuations growable optimizer.inlining
-namespaces hints ;
+kernel.private math optimizer generator prettyprint sequences
+sbufs strings tools.test vectors words sequences.private
+quotations optimizer.backend classes classes.algebra
+inference.dataflow classes.tuple.private continuations growable
+optimizer.inlining namespaces hints ;
IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@@ -349,3 +349,10 @@ USE: sequences.private
1 2 3.0 3 counter-example ;
[ 2 4 6.0 0 ] [ counter-example' ] unit-test
+
+: member-test { + - * / /i } member? ;
+
+\ member-test must-infer
+[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
+[ t ] [ \ + member-test ] unit-test
+[ f ] [ \ append member-test ] unit-test
diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor
index 5beb2555f0..51fa254a25 100755
--- a/core/optimizer/pattern-match/pattern-match.factor
+++ b/core/optimizer/pattern-match/pattern-match.factor
@@ -12,7 +12,7 @@ SYMBOL: @
@ get [ eq? ] [ @ set t ] if* ;
: match-class ( value spec -- ? )
- >r node get swap node-class r> class< ;
+ >r node get swap node-class r> class<= ;
: value-match? ( value spec -- ? )
{
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index b33a9e8fc2..c3702e9805 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -12,7 +12,7 @@ IN: optimizer.specializers
: make-specializer ( classes -- quot )
dup length
[ (picker) 2array ] 2map
- [ drop object eq? not ] assoc-subset
+ [ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 23363c30ad..418278baee 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -5,7 +5,7 @@ quotations namespaces compiler.units assocs ;
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
-"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, a message is printed to the " { $link stdio } " stream. Except when debugging suspected name clashes, these messages can be ignored."
+"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, we say that the old word has been " { $emphasis "shadowed" } "."
$nl
"Here is an example where shadowing occurs:"
{ $code
@@ -13,18 +13,18 @@ $nl
"USING: sequences io ;"
""
": append"
- " \"foe::append calls sequences::append\" print append ;"
+ " \"foe::append calls sequences:append\" print append ;"
""
"IN: fee"
""
": append"
- " \"fee::append calls fee::append\" print append ;"
+ " \"fee::append calls fee:append\" print append ;"
""
"IN: fox"
"USE: foe"
""
": append"
- " \"fox::append calls foe::append\" print append ;"
+ " \"fox::append calls foe:append\" print append ;"
""
"\"1234\" \"5678\" append print"
""
@@ -33,12 +33,13 @@ $nl
}
"When placed in a source file and run, the above code produces the following output:"
{ $code
- "foe::append calls sequences::append"
+ "foe:append calls sequences:append"
"12345678"
- "fee::append calls foe::append"
- "foe::append calls sequences::append"
+ "fee:append calls foe:append"
+ "foe:append calls sequences:append"
"12345678"
-} ;
+}
+"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
@@ -51,9 +52,11 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors"
ARTICLE: "vocabulary-search" "Vocabulary search path"
"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
$nl
-"For a source file the vocabulary search path starts off with two vocabularies:"
-{ $code "syntax\nscratchpad" }
-"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words. The " { $vocab-link "scratchpad" } " vocabulary is the default vocabulary for new word definitions."
+"For a source file the vocabulary search path starts off with one vocabulary:"
+{ $code "syntax" }
+"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words."
+$nl
+"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. However, when loading source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error."
$nl
"At the interactive listener, the default search path contains many more vocabularies. Details on the default search path and parser invocation are found in " { $link "parser" } "."
$nl
@@ -213,7 +216,7 @@ HELP: save-location
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
HELP: parser-notes
-{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on the " { $link stdio } " stream, this variable should be switched off, to prevent parser notes from polluting the output." } ;
+{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
HELP: parser-notes?
{ $values { "?" "a boolean" } }
@@ -294,6 +297,10 @@ HELP: use
HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
+HELP: current-vocab
+{ $values { "str" "a vocabulary" } }
+{ $description "Returns the vocabulary stored in the " { $link in } " symbol. Throws an error if the current vocabulary is " { $link f } "." } ;
+
HELP: (use+)
{ $values { "vocab" "an assoc mapping strings to words" } }
{ $description "Adds an assoc at the front of the search path." }
@@ -323,7 +330,7 @@ HELP: set-in
$parsing-note ;
HELP: create-in
-{ $values { "string" "a word name" } { "word" "a new word" } }
+{ $values { "str" "a word name" } { "word" "a new word" } }
{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." }
$parsing-note ;
@@ -451,7 +458,7 @@ HELP: bootstrap-syntax
HELP: with-file-vocabs
{ $values { "quot" quotation } }
-{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of the " { $snippet "syntax" } " vocabulary together with the " { $snippet "scratchpad" } " vocabulary." } ;
+{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of just the " { $snippet "syntax" } " vocabulary." } ;
HELP: parse-fresh
{ $values { "lines" "a sequence of strings" } { "quot" quotation } }
@@ -500,7 +507,7 @@ HELP: bootstrap-file
HELP: eval>string
{ $values { "str" string } { "output" string } }
-{ $description "Evaluates the Factor code in " { $snippet "str" } " with the " { $link stdio } " stream rebound to a string output stream, then outputs the resulting string." } ;
+{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
HELP: staging-violation
{ $values { "word" word } }
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index ab193e1c02..9c3c1d9f6c 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -3,6 +3,7 @@ io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting classes.tuple compiler.units debugger vocabs
vocabs.loader accessors ;
+
IN: parser.tests
[
@@ -429,3 +430,8 @@ must-fail-with
[
"USE: this-better-not-exist" eval
] must-fail
+
+[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with
+
+[ 92 ] [ "CHAR: \\" eval ] unit-test
+[ 92 ] [ "CHAR: \\\\" eval ] unit-test
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 7639ebaa69..76c831cf13 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -63,7 +63,7 @@ t parser-notes set-global
: skip ( i seq ? -- n )
over >r
- [ swap CHAR: \s eq? xor ] curry find* drop
+ [ swap CHAR: \s eq? xor ] curry find-from drop
[ r> drop ] [ r> length ] if* ;
: change-lexer-column ( lexer quot -- )
@@ -132,7 +132,7 @@ name>char-hook global [
"{" ?head-slice [
CHAR: } over index cut-slice
>r >string name>char-hook get call r>
- 1 tail-slice
+ rest-slice
] [
6 cut-slice >r hex> r>
] if ;
@@ -146,7 +146,7 @@ name>char-hook global [
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
- >r cut-slice >r % r> 1 tail-slice r>
+ >r cut-slice >r % r> rest-slice r>
dup CHAR: " = [
drop slice-from
] [
@@ -207,7 +207,7 @@ SYMBOL: in
: add-use ( seq -- ) [ use+ ] each ;
: set-use ( seq -- )
- [ vocab-words ] map [ ] subset >vector use set ;
+ [ vocab-words ] map [ ] filter >vector use set ;
: check-vocab-string ( name -- name )
dup string?
@@ -233,8 +233,16 @@ PREDICATE: unexpected-eof < unexpected
: parse-tokens ( end -- seq )
100 swap (parse-tokens) >array ;
-: create-in ( string -- word )
- in get create dup set-word dup save-location ;
+ERROR: no-current-vocab ;
+
+M: no-current-vocab summary ( obj -- )
+ drop "Current vocabulary is f, use IN:" ;
+
+: current-vocab ( -- str )
+ in get [ no-current-vocab ] unless* ;
+
+: create-in ( str -- word )
+ current-vocab create dup set-word dup save-location ;
: CREATE ( -- word ) scan create-in ;
@@ -243,7 +251,7 @@ PREDICATE: unexpected-eof < unexpected
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
: create-class-in ( word -- word )
- in get create
+ current-vocab create
dup save-class-location
dup predicate-word dup set-word save-location ;
@@ -262,7 +270,7 @@ M: no-word-error summary
: no-word ( name -- newword )
dup no-word-error boa
- swap words-named [ forward-reference? not ] subset
+ swap words-named [ forward-reference? not ] filter
word-restarts throw-restarts
dup word-vocabulary (use+) ;
@@ -270,7 +278,7 @@ M: no-word-error summary
dup forward-reference? [
drop
use get
- [ at ] with map [ ] subset
+ [ at ] with map [ ] filter
[ forward-reference? not ] find nip
] [
nip
@@ -337,6 +345,11 @@ M: invalid-slot-name summary
[ >r tuple parse-tuple-slots r> prefix ]
} case 3dup check-slot-shadowing ;
+ERROR: not-in-a-method-error ;
+
+M: not-in-a-method-error summary
+ drop "call-next-method can only be called in a method definition" ;
+
ERROR: staging-violation word ;
M: staging-violation summary
@@ -408,14 +421,17 @@ ERROR: bad-number ;
SYMBOL: current-class
SYMBOL: current-generic
-: (M:)
- CREATE-METHOD
+: with-method-definition ( quot -- parsed )
[
+ >r
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
- parse-definition
- ] with-scope ;
+ r> call
+ ] with-scope ; inline
+
+: (M:)
+ CREATE-METHOD [ parse-definition ] with-method-definition ;
: scan-object ( -- object )
scan-word dup parsing?
@@ -440,8 +456,7 @@ SYMBOL: bootstrap-syntax
: with-file-vocabs ( quot -- )
[
- "scratchpad" in set
- { "syntax" "scratchpad" } set-use
+ f in set { "syntax" } set-use
bootstrap-syntax get [ use get push ] when*
call
] with-scope ; inline
@@ -506,10 +521,10 @@ SYMBOL: interactive-vocabs
] if ;
: filter-moved ( assoc1 assoc2 -- seq )
- assoc-diff [
+ swap assoc-diff [
drop where dup [ first ] when
file get source-file-path =
- ] assoc-subset keys ;
+ ] assoc-filter keys ;
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
@@ -524,7 +539,7 @@ SYMBOL: interactive-vocabs
: reset-removed-classes ( -- )
removed-classes
- filter-moved [ class? ] subset [ reset-class ] each ;
+ filter-moved [ class? ] filter [ reset-class ] each ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor
index c9933d5be2..f992b9ca01 100755
--- a/core/prettyprint/backend/backend.factor
+++ b/core/prettyprint/backend/backend.factor
@@ -1,10 +1,11 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays bit-arrays generic hashtables io
-assocs kernel math namespaces sequences strings sbufs io.styles
-vectors words prettyprint.config prettyprint.sections quotations
-io io.files math.parser effects classes.tuple
-classes.tuple.private classes float-arrays ;
+USING: arrays byte-arrays byte-vectors bit-arrays generic
+hashtables io assocs kernel math namespaces sequences strings
+sbufs io.styles vectors words prettyprint.config
+prettyprint.sections quotations io io.files math.parser effects
+classes.tuple math.order classes.tuple.private classes
+float-arrays ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
@@ -140,6 +141,7 @@ M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ;
+M: byte-vector pprint-delims drop \ BV{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
@@ -152,6 +154,7 @@ GENERIC: >pprint-sequence ( obj -- seq )
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
+M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor
index 7cc141be22..f7f0f7ee44 100755
--- a/core/prettyprint/prettyprint-docs.factor
+++ b/core/prettyprint/prettyprint-docs.factor
@@ -135,7 +135,7 @@ ARTICLE: "prettyprint" "The prettyprinter"
$nl
"Prettyprinter words are found in the " { $vocab-link "prettyprint" } " vocabulary."
$nl
-"The key words to print an object to the " { $link stdio } " stream; the first two emit a trailing newline, the second two do not:"
+"The key words to print an object to " { $link output-stream } "; the first two emit a trailing newline, the second two do not:"
{ $subsection . }
{ $subsection short. }
{ $subsection pprint }
@@ -161,17 +161,17 @@ ABOUT: "prettyprint"
HELP: with-pprint
{ $values { "obj" object } { "quot" quotation } }
-{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to the " { $link stdio } " stream." } ;
+{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ;
HELP: pprint
{ $values { "obj" object } }
-{ $description "Prettyprints an object to the " { $link stdio } " stream. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
{ pprint pprint* with-pprint } related-words
HELP: .
{ $values { "obj" object } }
-{ $description "Prettyprints an object to the " { $link stdio } " stream with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
HELP: unparse
{ $values { "obj" object } { "str" "Factor source string" } }
@@ -179,11 +179,11 @@ HELP: unparse
HELP: pprint-short
{ $values { "obj" object } }
-{ $description "Prettyprints an object to the " { $link stdio } " stream. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
HELP: short.
{ $values { "obj" object } }
-{ $description "Prettyprints an object to the " { $link stdio } " stream with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
+{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
HELP: .b
{ $values { "n" "an integer" } }
@@ -242,8 +242,16 @@ HELP: definer
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
{ $contract "Outputs the parsing words which delimit the definition." }
{ $examples
- { $example "USING: definitions prettyprint ;" ": foo ; \\ foo definer . ." ";\nPOSTPONE: :" }
- { $example "USING: definitions prettyprint ;" "SYMBOL: foo \\ foo definer . ." "f\nPOSTPONE: SYMBOL:" }
+ { $example "USING: definitions prettyprint ;"
+ "IN: scratchpad"
+ ": foo ; \\ foo definer . ."
+ ";\nPOSTPONE: :"
+ }
+ { $example "USING: definitions prettyprint ;"
+ "IN: scratchpad"
+ "SYMBOL: foo \\ foo definer . ."
+ "f\nPOSTPONE: SYMBOL:"
+ }
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index e94670992c..0faae398e9 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -114,7 +114,7 @@ unit-test
[ parse-fresh drop ] with-compilation-unit
[
"prettyprint.tests" lookup see
- ] with-string-writer "\n" split 1 head*
+ ] with-string-writer "\n" split but-last
] keep =
] with-scope ;
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index 981c8dcfd0..4974e1df3c 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -45,7 +45,7 @@ sets ;
] if ;
: vocabs. ( in use -- )
- dupd remove [ { "syntax" "scratchpad" } member? not ] subset
+ dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ;
: with-use ( obj quot -- )
diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor
index ceb37c2fe4..842a36a13b 100755
--- a/core/prettyprint/sections/sections-docs.factor
+++ b/core/prettyprint/sections/sections-docs.factor
@@ -15,7 +15,7 @@ HELP: line-limit?
HELP: do-indent
-{ $description "Outputs the current indent nesting to the " { $link stdio } " stream." } ;
+{ $description "Outputs the current indent nesting to " { $link output-stream } "." } ;
HELP: fresh-line
{ $values { "n" "the current column position" } }
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index 803f6e2459..11fa4da28e 100644
--- a/core/prettyprint/sections/sections.factor
+++ b/core/prettyprint/sections/sections.factor
@@ -15,9 +15,9 @@ SYMBOL: pprinter-stack
SYMBOL: pprinter-in
SYMBOL: pprinter-use
-TUPLE: pprinter last-newline line-count end-printing indent ;
+TUPLE: pprinter last-newline line-count indent ;
-: ( -- pprinter ) 0 1 f 0 pprinter boa ;
+: ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
@@ -34,7 +34,7 @@ TUPLE: pprinter last-newline line-count end-printing indent ;
] [
pprinter get (>>last-newline)
line-limit? [
- "..." write pprinter get end-printing>> continue
+ "..." write pprinter get return
] when
pprinter get [ 1+ ] change-line-count drop
nl do-indent
@@ -171,7 +171,7 @@ M: block section-fits? ( section -- ? )
line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
- swap sections>> [ line-break? not ] subset
+ swap sections>> [ line-break? not ] filter
unclip pprint-section [
dup rot call pprint-section
] with each ; inline
@@ -275,16 +275,15 @@ M: colon unindent-first-line? drop t ;
[
dup style>> [
[
- >r pprinter get (>>end-printing) r>
short-section
- ] curry callcc0
+ ] curry with-return
] with-nesting
] if-nonempty
] with-variable ;
! Long section layout algorithm
: chop-break ( seq -- seq )
- dup peek line-break? [ 1 head-slice* chop-break ] when ;
+ dup peek line-break? [ but-last-slice chop-break ] when ;
SYMBOL: prev
SYMBOL: next
@@ -310,7 +309,7 @@ M: f section-end-group? drop f ;
2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after
] with each
- ] { } make { t } split [ empty? not ] subset ;
+ ] { } make { t } split [ empty? not ] filter ;
: break-group? ( seq -- ? )
[ first section-fits? ] [ peek section-fits? not ] bi and ;
diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor
index c0f15a9388..2a0f5d289f 100755
--- a/core/quotations/quotations.factor
+++ b/core/quotations/quotations.factor
@@ -50,14 +50,14 @@ M: curry nth
INSTANCE: curry immutable-sequence
M: compose length
- dup compose-first length
- swap compose-second length + ;
+ [ compose-first length ]
+ [ compose-second length ] bi + ;
M: compose nth
2dup compose-first length < [
compose-first
] [
- [ compose-first length - ] keep compose-second
+ [ compose-first length - ] [ compose-second ] bi
] if nth ;
INSTANCE: compose immutable-sequence
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 0dea0f43d9..8b15f5b980 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -1,5 +1,5 @@
-USING: arrays bit-arrays help.markup help.syntax
-sequences.private vectors strings sbufs kernel math ;
+USING: arrays bit-arrays help.markup help.syntax math
+sequences.private vectors strings sbufs kernel math.order ;
IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
@@ -94,6 +94,9 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection tail }
{ $subsection head* }
{ $subsection tail* }
+"Removing the first or last element:"
+{ $subsection rest }
+{ $subsection but-last }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip }
{ $subsection cut }
@@ -105,6 +108,8 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection }
{ $subsection head-slice }
{ $subsection tail-slice }
+{ $subsection but-last-slice }
+{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
"Taking a sequence apart into a head and a tail:"
@@ -127,7 +132,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection unfold }
"Filtering:"
{ $subsection push-if }
-{ $subsection subset } ;
+{ $subsection filter } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
@@ -153,17 +158,17 @@ ARTICLE: "sequences-tests" "Testing sequences"
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
{ $subsection index }
-{ $subsection index* }
+{ $subsection index-from }
{ $subsection last-index }
-{ $subsection last-index* }
+{ $subsection last-index-from }
"Finding the start of a subsequence:"
{ $subsection start }
{ $subsection start* }
"Finding the index of an element satisfying a predicate:"
{ $subsection find }
-{ $subsection find* }
+{ $subsection find-from }
{ $subsection find-last }
-{ $subsection find-last* } ;
+{ $subsection find-last-from } ;
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
@@ -500,9 +505,9 @@ HELP: find
{ $snippet "( elt -- ? )" } }
{ "i" "the index of the first match, or f" }
{ "elt" "the first matching element, or " { $link f } } }
-{ $description "A simpler variant of " { $link find* } " where the starting index is 0." } ;
+{ $description "A simpler variant of " { $link find-from } " where the starting index is 0." } ;
-HELP: find*
+HELP: find-from
{ $values { "n" "a starting index" }
{ "seq" sequence }
{ "quot" "a quotation with stack effect "
@@ -513,9 +518,9 @@ HELP: find*
HELP: find-last
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
-{ $description "A simpler variant of " { $link find-last* } " where the starting index is one less than the length of the sequence." } ;
+{ $description "A simpler variant of " { $link find-last-from } " where the starting index is one less than the length of the sequence." } ;
-HELP: find-last*
+HELP: find-last-from
{ $values { "n" "a starting index" } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
@@ -530,9 +535,9 @@ HELP: all?
HELP: push-if
{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
{ $description "Adds the element at the end of the sequence if the quotation yields a true value." }
-{ $notes "This word is a factor of " { $link subset } "." } ;
+{ $notes "This word is a factor of " { $link filter } "." } ;
-HELP: subset
+HELP: filter
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
@@ -562,9 +567,9 @@ HELP: index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
-{ index index* last-index last-index* member? memq? } related-words
+{ index index-from last-index last-index-from member? memq? } related-words
-HELP: index*
+HELP: index-from
{ $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ;
@@ -572,7 +577,7 @@ HELP: last-index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } "; the sequence is traversed back to front. If no element is found, outputs " { $link f } "." } ;
-HELP: last-index*
+HELP: last-index-from
{ $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } ", traversing the sequence backwards starting from the " { $snippet "i" } "th element and finishing at the first. If no element is found, outputs " { $link f } "." } ;
@@ -834,6 +839,17 @@ HELP: tail-slice
{ $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
+HELP: but-last-slice
+{ $values { "seq" sequence } { "slice" "a slice" } }
+{ $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." }
+{ $errors "Throws an error on an empty sequence." } ;
+
+HELP: rest-slice
+{ $values { "seq" sequence } { "slice" "a slice" } }
+{ $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." }
+{ $notes "Equivalent to " { $snippet "1 tail" } }
+{ $errors "Throws an error on an empty sequence." } ;
+
HELP: head-slice*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." }
@@ -854,6 +870,16 @@ HELP: tail
{ $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
{ $errors "Throws an error if the index is out of bounds." } ;
+HELP: but-last
+{ $values { "seq" sequence } { "headseq" "a new sequence" } }
+{ $description "Outputs a new sequence consisting of the input sequence with the last item removed." }
+{ $errors "Throws an error on an empty sequence." } ;
+
+HELP: rest
+{ $values { "seq" sequence } { "tailseq" "a new sequence" } }
+{ $description "Outputs a new sequence consisting of the input sequence with the first item removed." }
+{ $errors "Throws an error on an empty sequence." } ;
+
HELP: head*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "headseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." }
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index 100184798c..2479c125a2 100755
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -27,7 +27,7 @@ IN: sequences.tests
[ "hello world" "aeiou" [ member? ] curry find ] unit-test
[ 4 CHAR: o ]
-[ 3 "hello world" "aeiou" [ member? ] curry find* ] unit-test
+[ 3 "hello world" "aeiou" [ member? ] curry find-from ] unit-test
[ f ] [ 3 [ ] member? ] unit-test
[ f ] [ 3 [ 1 2 ] member? ] unit-test
@@ -39,18 +39,18 @@ IN: sequences.tests
[ 4 ] [ CHAR: x "tuvwxyz" >vector index ] unit-test
-[ f ] [ CHAR: x 5 "tuvwxyz" >vector index* ] unit-test
+[ f ] [ CHAR: x 5 "tuvwxyz" >vector index-from ] unit-test
-[ f ] [ CHAR: a 0 "tuvwxyz" >vector index* ] unit-test
+[ f ] [ CHAR: a 0 "tuvwxyz" >vector index-from ] unit-test
[ f ] [ [ "Hello" { } 0.75 ] [ string? ] all? ] unit-test
[ t ] [ [ ] [ ] all? ] unit-test
[ t ] [ [ "hi" t 0.5 ] [ ] all? ] unit-test
-[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test
-[ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] subset ] unit-test
+[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] filter ] unit-test
+[ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] filter ] unit-test
-[ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry subset ] unit-test
+[ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test
[ "hello world how are you" ]
[ { "hello" "world" "how" "are" "you" } " " join ]
@@ -169,9 +169,9 @@ unit-test
[ 3 "a" ] [ { "a" "b" "c" "a" "d" } [ "a" = ] find-last ] unit-test
-[ f f ] [ 100 { 1 2 3 } [ 1 = ] find* ] unit-test
-[ f f ] [ 100 { 1 2 3 } [ 1 = ] find-last* ] unit-test
-[ f f ] [ -1 { 1 2 3 } [ 1 = ] find* ] unit-test
+[ f f ] [ 100 { 1 2 3 } [ 1 = ] find-from ] unit-test
+[ f f ] [ 100 { 1 2 3 } [ 1 = ] find-last-from ] unit-test
+[ f f ] [ -1 { 1 2 3 } [ 1 = ] find-from ] unit-test
[ 0 ] [ { "a" "b" "c" } { "A" "B" "C" } mismatch ] unit-test
@@ -187,9 +187,6 @@ unit-test
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
-[ -1 ] [ "ab" "abc" <=> ] unit-test
-[ 1 ] [ "abc" "ab" <=> ] unit-test
-
[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
V{ } clone "cache-test" set
1 "cache-test" get [ sq ] cache-nth
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 924d9a05cb..8d0e3eec18 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel kernel.private slots.private math math.private
+math.order ;
IN: sequences
-USING: kernel kernel.private slots.private math math.private ;
MIXIN: sequence
@@ -36,7 +37,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
: set-third ( third seq -- ) 2 swap set-nth ; inline
: set-fourth ( fourth seq -- ) 3 swap set-nth ; inline
-: push ( elt seq -- ) dup length swap set-nth ;
+: push ( elt seq -- ) [ length ] [ set-nth ] bi ;
: bounds-check? ( n seq -- ? )
length 1- 0 swap between? ; inline
@@ -100,13 +101,13 @@ M: integer nth-unsafe drop ;
INSTANCE: integer immutable-sequence
: first2-unsafe
- [ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline
+ [ 0 swap nth-unsafe 1 ] [ nth-unsafe ] bi ; inline
: first3-unsafe
- [ first2-unsafe ] keep 2 swap nth-unsafe ; inline
+ [ first2-unsafe 2 ] [ nth-unsafe ] bi ; inline
: first4-unsafe
- [ first3-unsafe ] keep 3 swap nth-unsafe ; inline
+ [ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- )
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
@@ -179,7 +180,7 @@ M: reversed length reversed-seq length ;
INSTANCE: reversed virtual-sequence
-: reverse ( seq -- newseq ) [ ] keep like ;
+: reverse ( seq -- newseq ) [ ] [ like ] bi ;
! A slice of another sequence.
TUPLE: slice from to seq ;
@@ -201,7 +202,7 @@ ERROR: slice-error reason ;
M: slice virtual-seq slice-seq ;
-M: slice virtual@ [ slice-from + ] keep slice-seq ;
+M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ;
M: slice length dup slice-to swap slice-from - ;
@@ -209,10 +210,14 @@ M: slice length dup slice-to swap slice-from - ;
: tail-slice ( seq n -- slice ) (tail) ;
+: rest-slice ( seq -- slice ) 1 tail-slice ;
+
: head-slice* ( seq n -- slice ) from-end head-slice ;
: tail-slice* ( seq n -- slice ) from-end tail-slice ;
+: but-last-slice ( seq -- slice ) 1 head-slice* ;
+
INSTANCE: slice virtual-sequence
! One element repeated many times
@@ -248,16 +253,20 @@ INSTANCE: repetition immutable-sequence
PRIVATE>
: subseq ( from to seq -- subseq )
- [ check-slice prepare-subseq (copy) ] keep like ;
+ [ check-slice prepare-subseq (copy) ] [ like ] bi ;
: head ( seq n -- headseq ) (head) subseq ;
: tail ( seq n -- tailseq ) (tail) subseq ;
+: rest ( seq -- tailseq ) 1 tail ;
+
: head* ( seq n -- headseq ) from-end head ;
: tail* ( seq n -- tailseq ) from-end tail ;
+: but-last ( seq -- headseq ) 1 head* ;
+
: copy ( src i dst -- )
pick length >r 3dup check-copy spin 0 r>
(copy) drop ; inline
@@ -267,11 +276,12 @@ M: sequence clone-like
M: immutable-sequence clone-like like ;
-: push-all ( src dest -- ) [ length ] keep copy ;
+: push-all ( src dest -- ) [ length ] [ copy ] bi ;
: ((append)) ( seq1 seq2 accum -- accum )
- [ >r over length r> copy ] keep
- [ 0 swap copy ] keep ; inline
+ [ >r over length r> copy ]
+ [ 0 swap copy ]
+ [ ] tri ; inline
: (append) ( seq1 seq2 exemplar -- newseq )
>r over length over length + r>
@@ -279,8 +289,8 @@ M: immutable-sequence clone-like like ;
: (3append) ( seq1 seq2 seq3 exemplar -- newseq )
>r pick length pick length pick length + + r> [
- [ >r pick length pick length + r> copy ] keep
- ((append))
+ [ >r pick length pick length + r> copy ]
+ [ ((append)) ] bi
] new-like ; inline
: append ( seq1 seq2 -- newseq ) over (append) ;
@@ -323,7 +333,7 @@ M: immutable-sequence clone-like like ;
: (find) ( seq quot quot' -- i elt )
pick >r >r (each) r> call r> finish-find ; inline
-: (find*) ( n seq quot quot' -- i elt )
+: (find-from) ( n seq quot quot' -- i elt )
>r >r 2dup bounds-check? [
r> r> (find)
] [
@@ -332,7 +342,7 @@ M: immutable-sequence clone-like like ;
: (monotonic) ( seq quot -- ? )
[ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
- swap compose curry ; inline
+ prepose curry ; inline
: (interleave) ( n elt between quot -- )
roll zero? [ nip ] [ swapd 2slip ] if call ; inline
@@ -373,14 +383,14 @@ PRIVATE>
: 2all? ( seq1 seq2 quot -- ? )
(2each) all-integers? ; inline
-: find* ( n seq quot -- i elt )
- [ (find-integer) ] (find*) ; inline
+: find-from ( n seq quot -- i elt )
+ [ (find-integer) ] (find-from) ; inline
: find ( seq quot -- i elt )
[ find-integer ] (find) ; inline
-: find-last* ( n seq quot -- i elt )
- [ nip find-last-integer ] (find*) ; inline
+: find-last-from ( n seq quot -- i elt )
+ [ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt )
[ >r 1- r> find-last-integer ] (find) ; inline
@@ -394,7 +404,7 @@ PRIVATE>
: pusher ( quot -- quot accum )
V{ } clone [ [ push-if ] 2curry ] keep ; inline
-: subset ( seq quot -- subseq )
+: filter ( seq quot -- subseq )
over >r pusher >r each r> r> like ; inline
: monotonic? ( seq quot -- ? )
@@ -414,14 +424,14 @@ PRIVATE>
: index ( obj seq -- n )
[ = ] with find drop ;
-: index* ( obj i seq -- n )
- rot [ = ] curry find* drop ;
+: index-from ( obj i seq -- n )
+ rot [ = ] curry find-from drop ;
: last-index ( obj seq -- n )
[ = ] with find-last drop ;
-: last-index* ( obj i seq -- n )
- rot [ = ] curry find-last* drop ;
+: last-index-from ( obj i seq -- n )
+ rot [ = ] curry find-last-from drop ;
: contains? ( seq quot -- ? )
find drop >boolean ; inline
@@ -433,7 +443,7 @@ PRIVATE>
[ eq? ] with contains? ;
: remove ( obj seq -- newseq )
- [ = not ] with subset ;
+ [ = not ] with filter ;
: cache-nth ( i seq quot -- elt )
2over ?nth dup [
@@ -472,7 +482,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: move ( to from seq -- )
2over number=
- [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
+ [ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
: (delete) ( elt store scan seq -- elt store scan seq )
2dup length < [
@@ -497,9 +507,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
[ 0 swap copy ] keep
] new-like ;
-: peek ( seq -- elt ) dup length 1- swap nth ;
+: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
-: pop* ( seq -- ) dup length 1- swap set-length ;
+: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
: move-backward ( shift from to seq -- )
2over number= [
@@ -519,7 +529,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: (open-slice) ( shift from to seq ? -- )
[
- >r >r 1- r> 1- r> move-forward
+ >r [ 1- ] bi@ r> move-forward
] [
>r >r over - r> r> move-backward
] if ;
@@ -544,7 +554,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
copy ;
: pop ( seq -- elt )
- dup length 1- swap [ nth ] 2keep set-length ;
+ [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
@@ -609,7 +619,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
] if ;
: cut-slice ( seq n -- before after )
- [ head-slice ] 2keep tail-slice ;
+ [ head-slice ] [ tail-slice ] 2bi ;
: midpoint@ ( seq -- n ) length 2/ ; inline
@@ -634,10 +644,10 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
] if ; inline
: cut ( seq n -- before after )
- [ head ] 2keep tail ;
+ [ head ] [ tail ] 2bi ;
: cut* ( seq n -- before after )
- [ head* ] 2keep tail* ;
+ [ head* ] [ tail* ] 2bi ;
: start* ( subseq seq n -- i )
pick length pick length swap - 1+
- [ (start) ] find*
+ [ (start) ] find-from
swap >r 3drop r> ;
: start ( subseq seq -- i ) 0 start* ; inline
@@ -662,10 +672,16 @@ PRIVATE>
tuck tail-slice >r tail-slice r> ;
: unclip ( seq -- rest first )
- dup 1 tail swap first ;
+ [ rest ] [ first ] bi ;
+
+: unclip-last ( seq -- butfirst last )
+ [ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first )
- dup 1 tail-slice swap first ;
+ [ rest-slice ] [ first ] bi ;
+
+: unclip-last-slice ( seq -- butfirst last )
+ [ but-last-slice ] [ peek ] bi ;
: ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot ;
@@ -680,7 +696,7 @@ PRIVATE>
[ 1+ head ] [ 0 head ] if* ; inline
: trim ( seq quot -- newseq )
- [ left-trim ] keep right-trim ; inline
+ [ left-trim ] [ right-trim ] bi ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
: product ( seq -- n ) 1 [ * ] binary-reduce ;
diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor
index 8b6859260d..f4e2557a71 100644
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@@ -2,7 +2,7 @@ USING: kernel help.markup help.syntax sequences ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
-"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
+"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. All of these operations use hashtables internally to achieve linear running time."
$nl
"Remove duplicates:"
{ $subsection prune }
@@ -12,8 +12,14 @@ $nl
{ $subsection diff }
{ $subsection intersect }
{ $subsection union }
+{ $subsection subset? }
+{ $subsection set= }
+"A word used to implement the above:"
+{ $subsection unique }
{ $see-also member? memq? contains? all? "assocs-sets" } ;
+ABOUT: "sets"
+
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }
@@ -39,9 +45,9 @@ HELP: all-unique?
HELP: diff
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
-{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality."
+{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " but not " { $snippet "seq2" } ", comparing elements for equality."
} { $examples
- { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 1 }" }
} ;
HELP: intersect
@@ -59,3 +65,11 @@ HELP: union
} ;
{ diff intersect union } related-words
+
+HELP: subset?
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
+
+HELP: set=
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;
diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor
index 4f8c8cd103..86ee100da5 100644
--- a/core/sets/sets-tests.factor
+++ b/core/sets/sets-tests.factor
@@ -11,7 +11,7 @@ IN: sets.tests
[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
[ { } ] [ { } { } diff ] unit-test
-[ { 4 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
[ V{ } ] [ { } { } union ] unit-test
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
diff --git a/core/sets/sets.factor b/core/sets/sets.factor
index 31c39c6105..b0d26e0f30 100644
--- a/core/sets/sets.factor
+++ b/core/sets/sets.factor
@@ -22,10 +22,16 @@ IN: sets
dup length [ (all-unique?) ] curry all? ;
: intersect ( seq1 seq2 -- newseq )
- unique [ key? ] curry subset ;
+ unique [ key? ] curry filter ;
: diff ( seq1 seq2 -- newseq )
- swap unique [ key? not ] curry subset ;
+ unique [ key? not ] curry filter ;
: union ( seq1 seq2 -- newseq )
append prune ;
+
+: subset? ( seq1 seq2 -- ? )
+ unique [ key? ] curry all? ;
+
+: set= ( seq1 seq2 -- ? )
+ [ unique ] bi@ = ;
diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor
index 2ec8f3d0d1..90f468a185 100755
--- a/core/slots/deprecated/deprecated.factor
+++ b/core/slots/deprecated/deprecated.factor
@@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
- ] 2map [ ] subset nip ;
+ ] 2map [ ] filter nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;
diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor
index 4fa5c7974d..5827a711c8 100644
--- a/core/sorting/sorting-docs.factor
+++ b/core/sorting/sorting-docs.factor
@@ -1,5 +1,6 @@
-USING: sorting help.markup help.syntax kernel words math
-sequences ;
+USING: help.markup help.syntax kernel words math
+sequences math.order ;
+IN: sorting
ARTICLE: "sequences-sorting" "Sorting and binary search"
"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- n )" } " that order the two given elements and output a value whose sign denotes the result:"
@@ -61,3 +62,5 @@ HELP: binsearch*
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
$nl
"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
+
+{ <=> compare natural-sort sort-keys sort-values } related-words
diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor
index 732aeb045d..a56c41b620 100755
--- a/core/sorting/sorting-tests.factor
+++ b/core/sorting/sorting-tests.factor
@@ -1,5 +1,5 @@
-USING: sorting sequences kernel math random tools.test
-vectors ;
+USING: sorting sequences kernel math math.order random
+tools.test vectors ;
IN: sorting.tests
[ [ ] ] [ [ ] natural-sort ] unit-test
@@ -19,10 +19,10 @@ unit-test
[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
-[ f ] [ 3 { } [ - ] binsearch ] unit-test
-[ 0 ] [ 3 { 3 } [ - ] binsearch ] unit-test
-[ 1 ] [ 2 { 1 2 3 } [ - ] binsearch ] unit-test
-[ 3 ] [ 4 { 1 2 3 4 5 6 } [ - ] binsearch ] unit-test
-[ 1 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test
-[ 3 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test
-[ 10 ] [ 10 20 >vector [ - ] binsearch ] unit-test
+[ f ] [ 3 { } [ <=> ] binsearch ] unit-test
+[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test
+[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test
+[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test
+[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
+[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
+[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test
diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor
index 5f81b17187..dac1c08e46 100755
--- a/core/sorting/sorting.factor
+++ b/core/sorting/sorting.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences vectors
-sequences sequences.private growable ;
+USING: arrays kernel math sequences vectors math.order
+sequences sequences.private growable math.order ;
IN: sorting
DEFER: sort
@@ -17,7 +17,7 @@ DEFER: sort
dup slice-from 1+ swap set-slice-from ; inline
: smallest ( iter1 iter2 quot -- elt )
- >r over this over this r> call 0 <
+ >r over this over this r> call +lt+ eq?
-rot ? [ this ] keep next ; inline
: (merge) ( iter1 iter2 quot accum -- )
@@ -58,13 +58,13 @@ PRIVATE>
[ midpoint@ ] keep nth-unsafe ; inline
: partition ( seq n -- slice )
- 1 < swap halves ? ; inline
+ +gt+ eq? not swap halves ? ; inline
: (binsearch) ( elt quot seq -- i )
dup length 1 <= [
slice-from 2nip
] [
- [ midpoint swap call ] 3keep roll dup zero?
+ [ midpoint swap call ] 3keep roll dup +eq+ eq?
[ drop dup slice-from swap midpoint@ + 2nip ]
[ partition (binsearch) ] if
] if ; inline
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 5703b631f4..36a1806e12 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -3,8 +3,8 @@
USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
-continuations debugger io.files io.crc32 vocabs hashtables
-graphs compiler.units io.encodings.utf8 accessors ;
+continuations debugger io.files checksums checksums.crc32 vocabs
+hashtables graphs compiler.units io.encodings.utf8 accessors ;
IN: source-files
SYMBOL: source-files
@@ -15,11 +15,11 @@ checksum
uses definitions ;
: record-checksum ( lines source-file -- )
- >r lines-crc32 r> set-source-file-checksum ;
+ >r crc32 checksum-lines r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses )
dup source-file-path
- swap source-file-uses [ crossref? ] subset ;
+ swap source-file-uses [ crossref? ] filter ;
: xref-source ( source-file -- )
(xref-source) crossref get add-vertex ;
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index f840ca15ad..9f6ae75d32 100755
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -1,42 +1,72 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces strings arrays vectors sequences
-sets ;
+sets math.order accessors ;
IN: splitting
-TUPLE: groups seq n sliced? ;
+TUPLE: abstract-groups seq n ;
-: check-groups 0 <= [ "Invalid group count" throw ] when ;
+: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
+
+: construct-groups ( seq n class -- groups )
+ >r check-groups r> boa ; inline
+
+GENERIC: group@ ( n groups -- from to seq )
+
+M: abstract-groups nth group@ subseq ;
+
+M: abstract-groups set-nth group@ 0 swap copy ;
+
+M: abstract-groups like drop { } like ;
+
+INSTANCE: abstract-groups sequence
+
+TUPLE: groups < abstract-groups ;
: ( seq n -- groups )
- dup check-groups f groups boa ; inline
-
-: ( seq n -- groups )
- t over set-groups-sliced? ;
+ groups construct-groups ; inline
M: groups length
- dup groups-seq length swap groups-n [ + 1- ] keep /i ;
+ [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
M: groups set-length
- [ groups-n * ] keep groups-seq set-length ;
+ [ n>> * ] [ seq>> ] bi set-length ;
-: group@ ( n groups -- from to seq )
- [ groups-n [ * dup ] keep + ] keep
- groups-seq [ length min ] keep ;
+M: groups group@
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
-M: groups nth
- [ group@ ] keep
- groups-sliced? [ ] [ subseq ] if ;
+TUPLE: sliced-groups < groups ;
-M: groups set-nth
- group@ 0 swap copy ;
+: ( seq n -- groups )
+ sliced-groups construct-groups ; inline
-M: groups like drop { } like ;
+M: sliced-groups nth group@ ;
-INSTANCE: groups sequence
+TUPLE: clumps < abstract-groups ;
+
+: ( seq n -- groups )
+ clumps construct-groups ; inline
+
+M: clumps length
+ [ seq>> length ] [ n>> ] bi - 1+ ;
+
+M: clumps set-length
+ [ n>> + 1- ] [ seq>> ] bi set-length ;
+
+M: clumps group@
+ [ n>> over + ] [ seq>> ] bi ;
+
+TUPLE: sliced-clumps < groups ;
+
+: ( seq n -- groups )
+ sliced-clumps construct-groups ; inline
+
+M: sliced-clumps nth group@ ;
: group ( seq n -- array ) { } like ;
+: clump ( seq n -- array ) { } like ;
+
: ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ;
@@ -61,7 +91,7 @@ INSTANCE: groups sequence
dup [ swap ] when ;
: (split) ( separators n seq -- )
- 3dup rot [ member? ] curry find* drop
+ 3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1+ swap (split) ]
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline
@@ -74,7 +104,7 @@ INSTANCE: groups sequence
1array
] [
"\n" split [
- 1 head-slice* [
+ but-last-slice [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split suffix concat
diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor
index 961c8cdf6e..44e1d8859f 100755
--- a/core/strings/strings-tests.factor
+++ b/core/strings/strings-tests.factor
@@ -1,4 +1,4 @@
-USING: continuations kernel math namespaces strings
+USING: continuations kernel math math.order namespaces strings
strings.private sbufs tools.test sequences vectors arrays memory
prettyprint io.streams.null ;
IN: strings.tests
@@ -31,6 +31,8 @@ IN: strings.tests
[ t ] [ "abc" "abd" before? ] unit-test
[ t ] [ "z" "abd" after? ] unit-test
+[ "abc" ] [ "abc" "abd" min ] unit-test
+[ "z" ] [ "z" "abd" max ] unit-test
[ 0 10 "hello" subseq ] must-fail
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index a2d15d2981..b72ed9a2cb 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -190,7 +190,7 @@ HELP: delimiter
HELP: parsing
{ $syntax ": foo ... ; parsing" }
{ $description "Declares the most recently defined word as a parsing word." }
-{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "<< : hello \"Hello parser!\" print ; parsing >>\n: world hello ;" "Hello parser!" } } ;
+{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "IN: scratchpad" "<< : hello \"Hello parser!\" print ; parsing >>\n: world hello ;" "Hello parser!" } } ;
HELP: inline
{ $syntax ": foo ... ; inline" }
@@ -338,7 +338,7 @@ HELP: SYMBOL:
{ $syntax "SYMBOL: word" }
{ $values { "word" "a new word to define" } }
{ $description "Defines a new symbol word in the current vocabulary. Symbols push themselves on the stack when executed, and are used to identify variables (see " { $link "namespaces" } ") as well as for storing crufties in word properties (see " { $link "word-props" } ")." }
-{ $examples { $example "USE: prettyprint" "SYMBOL: foo\nfoo ." "foo" } } ;
+{ $examples { $example "USE: prettyprint" "IN: scratchpad" "SYMBOL: foo\nfoo ." "foo" } } ;
{ define-symbol POSTPONE: SYMBOL: } related-words
@@ -472,6 +472,7 @@ HELP: HOOK:
{ $examples
{ $example
"USING: io namespaces ;"
+ "IN: scratchpad"
"SYMBOL: transport"
"TUPLE: land-transport ;"
"TUPLE: air-transport ;"
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 566f5471f4..2e1c46fac1 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays byte-arrays
+USING: alien arrays bit-arrays byte-arrays byte-vectors
definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
@@ -79,6 +79,7 @@ IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
+ "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
@@ -189,8 +190,12 @@ IN: bootstrap.syntax
] define-syntax
"call-next-method" [
- current-class get literalize parsed
- current-generic get literalize parsed
- \ (call-next-method) parsed
+ current-class get current-generic get
+ 2dup [ word? ] both? [
+ [ literalize parsed ] bi@
+ \ (call-next-method) parsed
+ ] [
+ not-in-a-method-error
+ ] if
] define-syntax
] with-compilation-unit
diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor
index 3f9ff54ac8..7d8791d493 100755
--- a/core/threads/threads-docs.factor
+++ b/core/threads/threads-docs.factor
@@ -116,10 +116,13 @@ $nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
HELP: sleep
-{ $values { "ms" "a non-negative integer" } }
-{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds."
+{ $values { "dt" "a duration" } }
+{ $description "Suspends the current thread for the given duration."
$nl
-"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." }
+{ $examples
+ { $code "USING: threads calendar ;" "10 seconds sleep" }
+} ;
HELP: interrupt
{ $values { "thread" thread } }
diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor
index 0ac607f0ed..0e33ccd94c 100755
--- a/core/threads/threads-tests.factor
+++ b/core/threads/threads-tests.factor
@@ -1,5 +1,6 @@
USING: namespaces io tools.test threads kernel
-concurrency.combinators math ;
+concurrency.combinators concurrency.promises locals math
+words ;
IN: threads.tests
3 "x" set
@@ -27,3 +28,16 @@ yield
"i" tget
] parallel-map
] unit-test
+
+[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
+
+:: spawn-namespace-test ( -- )
+ [let | p [ ] g [ gensym ] |
+ [
+ g "x" set
+ [ "x" get p fulfill ] "B" spawn drop
+ ] with-scope
+ p ?promise g eq?
+ ] ;
+
+[ t ] [ spawn-namespace-test ] unit-test
diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index 2f9c3a73de..a1c7e208dc 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -1,17 +1,18 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
-IN: threads
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators init boxes accessors ;
+dlists assocs system combinators init boxes accessors
+math.order ;
+IN: threads
SYMBOL: initial-thread
TUPLE: thread
name quot exit-handler
id
-continuation state
+continuation state runnable
mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
@@ -90,9 +91,11 @@ PRIVATE>
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
+DEFER: stop
+
r check-registered dup r> sleep-queue heap-push*
>>sleep-entry drop ;
@@ -110,36 +113,57 @@ PRIVATE>
[ ] while
drop ;
+: start ( namestack thread -- )
+ [
+ set-self
+ set-namestack
+ V{ } set-catchstack
+ { } set-retainstack
+ { } set-datastack
+ self quot>> [ call stop ] call-clear
+ ] 2 (throw) ;
+
+DEFER: next
+
+: no-runnable-threads ( -- * )
+ ! We should never be in a state where the only threads
+ ! are sleeping; the I/O wait thread is always runnable.
+ ! However, if it dies, we handle this case
+ ! semi-gracefully.
+ !
+ ! And if sleep-time outputs f, there are no sleeping
+ ! threads either... so WTF.
+ sleep-time [ die 0 ] unless* (sleep) next ;
+
+: (next) ( arg thread -- * )
+ f >>state
+ dup set-self
+ dup runnable>> [
+ continuation>> box> continue-with
+ ] [
+ t >>runnable start
+ ] if ;
+
: next ( -- * )
expire-sleep-loop
run-queue dup dlist-empty? [
- ! We should never be in a state where the only threads
- ! are sleeping; the I/O wait thread is always runnable.
- ! However, if it dies, we handle this case
- ! semi-gracefully.
- !
- ! And if sleep-time outputs f, there are no sleeping
- ! threads either... so WTF.
- drop sleep-time [ die 0 ] unless* (sleep) next
+ drop no-runnable-threads
] [
- pop-back
- dup array? [ first2 ] [ f swap ] if dup set-self
- f >>state
- continuation>> box>
- continue-with
+ pop-back dup array? [ first2 ] [ f swap ] if (next)
] if ;
PRIVATE>
: stop ( -- )
- self dup exit-handler>> call
- unregister-thread next ;
+ self [ exit-handler>> call ] [ unregister-thread ] bi next ;
: suspend ( quot state -- obj )
[
- self continuation>> >box
- self (>>state)
- self swap call next
+ >r
+ >r self swap call
+ r> self (>>state)
+ r> self continuation>> >box
+ next
] callcc1 2nip ; inline
: yield ( -- ) [ resume ] f suspend drop ;
@@ -152,7 +176,7 @@ M: integer sleep-until
M: f sleep-until
drop [ drop ] "interrupt" suspend drop ;
-GENERIC: sleep ( ms -- )
+GENERIC: sleep ( dt -- )
M: real sleep
millis + >integer sleep-until ;
@@ -165,16 +189,7 @@ M: real sleep
] when drop ;
: (spawn) ( thread -- )
- [
- resume-now [
- dup set-self
- dup register-thread
- V{ } set-catchstack
- { } set-retainstack
- >r { } set-datastack r>
- quot>> [ call stop ] call-clear
- ] 1 (throw)
- ] "spawn" suspend 2drop ;
+ [ register-thread ] [ namestack swap resume-with ] bi ;
: spawn ( quot name -- thread )
[ (spawn) ] keep ;
@@ -183,8 +198,8 @@ M: real sleep
>r [ [ ] [ ] while ] curry r> spawn ;
: in-thread ( quot -- )
- >r datastack namestack r>
- [ >r set-namestack set-datastack r> call ] 3curry
+ >r datastack r>
+ [ >r set-datastack r> call ] 2curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
@@ -198,6 +213,7 @@ GENERIC: error-in-thread ( error thread -- )
initial-thread global
[ drop f "Initial" ] cache
>>continuation
+ t >>runnable
f >>state
dup register-thread
set-self ;
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 24a00189e4..edd82b2596 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -76,14 +76,14 @@ SYMBOL: load-vocab-hook ! ( name -- )
: words-named ( str -- seq )
dictionary get values
[ vocab-words at ] with map
- [ ] subset ;
+ [ ] filter ;
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or
[ 2drop t ] [ swap CHAR: . suffix head? ] if ;
: child-vocabs ( vocab -- seq )
- vocab-name vocabs [ child-vocab? ] with subset ;
+ vocab-name vocabs [ child-vocab? ] with filter ;
TUPLE: vocab-link name ;
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index f259378f7e..14e6197683 100755
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -197,7 +197,7 @@ HELP: execute ( word -- )
{ $values { "word" word } }
{ $description "Executes a word." }
{ $examples
- { $example "USING: kernel io words ;" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
+ { $example "USING: kernel io words ;" "IN: scratchpad" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
} ;
HELP: word-props ( word -- props )
@@ -278,7 +278,7 @@ HELP: reset-generic
$low-level-note
{ $side-effects "word" } ;
-HELP:
+HELP: ( name vocab -- word )
{ $values { "name" string } { "vocab" string } { "word" word } }
{ $description "Allocates an uninterned word with the specified name and vocabulary, and a blank word property hashtable. User code should call " { $link gensym } " to create uninterned words and " { $link create } " to create interned words." } ;
@@ -300,7 +300,7 @@ HELP: word
HELP: set-word
{ $values { "word" word } }
-{ $description "Sets the recently defined word. Usually you would call " { $link save-location } " on a newly-defined word instead, which will in turn call this word." } ;
+{ $description "Sets the recently defined word." } ;
HELP: lookup
{ $values { "name" string } { "vocab" string } { "word" "a word or " { $link f } } }
diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor
index 694e54cf96..2a164ab11d 100755
--- a/core/words/words-tests.factor
+++ b/core/words/words-tests.factor
@@ -68,7 +68,7 @@ FORGET: another-forgotten
: foe fee ;
: fie foe ;
-[ t ] [ \ fee usage [ word? ] subset empty? ] unit-test
+[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test
[ t ] [ \ foe usage empty? ] unit-test
[ f ] [ \ foe crossref get key? ] unit-test
@@ -80,7 +80,7 @@ FORGET: foe
] unit-test
[ t ] [
- \ * usage [ word? ] subset [ crossref? ] all?
+ \ * usage [ word? ] filter [ crossref? ] all?
] unit-test
DEFER: calls-a-gensym
diff --git a/core/words/words.factor b/core/words/words.factor
index 3466544eef..138b1ef928 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs
-quotations assocs hashtables sorting words.private vocabs ;
+quotations assocs hashtables sorting words.private vocabs
+math.order ;
IN: words
: word ( -- word ) \ word get-global ;
@@ -101,7 +102,7 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
- [ drop compiled-crossref? ] assoc-subset
+ [ drop compiled-crossref? ] assoc-filter
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
@@ -121,7 +122,7 @@ SYMBOL: +called+
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
- compiled-usage [ nip +inlined+ eq? ] assoc-subset update
+ compiled-usage [ nip +inlined+ eq? ] assoc-filter update
] with each keys ;
[ asn-syntax read-ber ] with-stream
+ "\u000002\u000001\u000006" [ asn-syntax read-ber ] with-input-stream
] unit-test
[ "testing" ] [
- "\u000004\u000007testing" [ asn-syntax read-ber ] with-stream
+ "\u000004\u000007testing" [ asn-syntax read-ber ] with-input-stream
] unit-test
[ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [
"0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus"
- [ asn-syntax read-ber ] with-stream
+ [ asn-syntax read-ber ] with-input-stream
] unit-test
[
diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor
index 32e3602f8f..50102d1929 100644
--- a/extra/asn1/asn1.factor
+++ b/extra/asn1/asn1.factor
@@ -98,7 +98,7 @@ DEFER: read-ber
SYMBOL: end
-: (read-array) ( stream -- )
+: (read-array) ( -- )
elements get element-id [
elements get element-syntax read-ber
dup end = [ drop ] [ , (read-array) ] if
@@ -106,7 +106,7 @@ SYMBOL: end
: read-array ( -- array ) [ (read-array) ] { } make ;
-: set-case ( -- )
+: set-case ( -- object )
elements get element-newobj
elements get element-objtype {
{ "boolean" [ "\0" = not ] }
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 92fb9aac81..247be44bad 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -38,7 +38,7 @@ IN: assocs.lib
: insert ( value variable -- ) namespace insert-at ;
: generate-key ( assoc -- str )
- >r 256 random-bits >hex r>
+ >r 32 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key )
diff --git a/extra/bank/authors.txt b/extra/bank/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/bank/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/extra/bank/bank-tests.factor b/extra/bank/bank-tests.factor
new file mode 100644
index 0000000000..2aa31f1e85
--- /dev/null
+++ b/extra/bank/bank-tests.factor
@@ -0,0 +1,34 @@
+USING: accessors arrays bank calendar kernel math math.functions namespaces tools.test tools.walker ;
+IN: bank.tests
+
+SYMBOL: my-account
+[
+ "Alex's Take Over the World Fund" 0.07 1 2007 11 1 6101.94 open-account my-account set
+ [ 6137 ] [ my-account get 2007 12 2 process-to-date balance>> round >integer ] unit-test
+ [ 6137 ] [ my-account get 2007 12 2 process-to-date balance>> round >integer ] unit-test
+] with-scope
+
+[
+ "Petty Cash" 0.07 1 2006 12 1 10962.18 open-account my-account set
+ [ 11027 ] [ my-account get 2007 1 2 process-to-date balance>> round >integer ] unit-test
+] with-scope
+
+[
+ "Saving to buy a pony" 0.0725 1 2008 3 3 11106.24 open-account my-account set
+ [ 8416 ] [
+ my-account get [
+ 2008 3 11 -750 "Need to buy food" ,
+ 2008 3 25 -500 "Going to a party" ,
+ 2008 4 8 -800 "Losing interest in the pony..." ,
+ 2008 4 8 -700 "Buying a rocking horse" ,
+ ] { } make inserting-transactions balance>> round >integer
+ ] unit-test
+] with-scope
+
+[
+ [ 6781 ] [
+ "..." 0.07 1 2007 4 10 4398.50 open-account
+ 2007 10 26 2000 "..." 1array inserting-transactions
+ 2008 4 10 process-to-date dup balance>> swap unpaid-interest>> + round >integer
+ ] unit-test
+] with-scope
diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor
new file mode 100644
index 0000000000..abe3250ecf
--- /dev/null
+++ b/extra/bank/bank.factor
@@ -0,0 +1,67 @@
+USING: accessors calendar kernel math math.order money sequences ;
+IN: bank
+
+TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ;
+
+: ( name interest-rate interest-payment-day opening-date -- account )
+ V{ } clone 0 pick account boa ;
+
+TUPLE: transaction date amount description ;
+C: transaction
+
+: >>transaction ( account transaction -- account )
+ over transactions>> push ;
+
+: total ( transactions -- balance )
+ 0 [ amount>> + ] reduce ;
+
+: balance>> ( account -- balance ) transactions>> total ;
+
+: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
+ >r [ ] keep r> "Account Opened" >>transaction ;
+
+: daily-rate ( yearly-rate day -- daily-rate )
+ days-in-year / ;
+
+: daily-rate>> ( account date -- rate )
+ [ interest-rate>> ] dip daily-rate ;
+
+: transactions-on-date ( account date -- transactions )
+ [ before? ] curry filter ;
+
+: balance-on-date ( account date -- balance )
+ transactions-on-date total ;
+
+: pay-interest ( account date -- )
+ over unpaid-interest>> "Interest Credit"
+ >>transaction 0 >>unpaid-interest drop ;
+
+: interest-payment-day? ( account date -- ? )
+ day>> swap interest-payment-day>> = ;
+
+: ?pay-interest ( account date -- )
+ 2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
+
+: unpaid-interest+ ( account amount -- account )
+ over unpaid-interest>> + >>unpaid-interest ;
+
+: accumulate-interest ( account date -- )
+ [ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
+ >>interest-last-paid drop ;
+
+: process-day ( account date -- )
+ 2dup accumulate-interest ?pay-interest ;
+
+: each-day ( quot start end -- )
+ 2dup before? [
+ >r dup >r over >r swap call r> r> 1 days time+ r> each-day
+ ] [
+ 3drop
+ ] if ;
+
+: process-to-date ( account date -- account )
+ over interest-last-paid>> 1 days time+
+ [ dupd process-day ] spin each-day ;
+
+: inserting-transactions ( account transactions -- account )
+ [ [ date>> process-to-date ] keep >>transaction ] each ;
diff --git a/extra/bank/summary.txt b/extra/bank/summary.txt
new file mode 100644
index 0000000000..efd88787a5
--- /dev/null
+++ b/extra/bank/summary.txt
@@ -0,0 +1 @@
+Bank account simulator for compound interest calculated daily and paid monthly
diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor
index be4620bff6..6e63877989 100644
--- a/extra/benchmark/binary-trees/binary-trees.factor
+++ b/extra/benchmark/binary-trees/binary-trees.factor
@@ -1,5 +1,5 @@
USING: kernel math accessors prettyprint io locals sequences
-math.ranges ;
+math.ranges math.order ;
IN: benchmark.binary-trees
TUPLE: tree-node item left right ;
diff --git a/extra/benchmark/crc32/crc32.factor b/extra/benchmark/crc32/crc32.factor
index ec424e89c9..0e5482da30 100755
--- a/extra/benchmark/crc32/crc32.factor
+++ b/extra/benchmark/crc32/crc32.factor
@@ -1,10 +1,10 @@
-USING: io.crc32 io.encodings.ascii io.files kernel math ;
+USING: checksums checksums.crc32 io.encodings.ascii io.files kernel math ;
IN: benchmark.crc32
: crc32-primes-list ( -- )
10 [
- "extra/math/primes/list/list.factor" resource-path
- ascii file-contents crc32 drop
+ "resource:extra/math/primes/list/list.factor"
+ crc32 checksum-file drop
] times ;
MAIN: crc32-primes-list
diff --git a/extra/benchmark/dispatch1/dispatch1.factor b/extra/benchmark/dispatch1/dispatch1.factor
index 3317348f45..1c8701f73f 100644
--- a/extra/benchmark/dispatch1/dispatch1.factor
+++ b/extra/benchmark/dispatch1/dispatch1.factor
@@ -65,7 +65,7 @@ TUPLE: x30 ;
M: x30 g ;
: my-classes ( -- seq )
- "benchmark.dispatch1" words [ tuple-class? ] subset ;
+ "benchmark.dispatch1" words [ tuple-class? ] filter ;
: a-bunch-of-objects ( -- seq )
my-classes [ new ] map ;
diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor
index a2f096695b..727d288765 100755
--- a/extra/benchmark/dispatch5/dispatch5.factor
+++ b/extra/benchmark/dispatch5/dispatch5.factor
@@ -65,7 +65,7 @@ TUPLE: x30 ;
INSTANCE: x30 g
: my-classes ( -- seq )
- "benchmark.dispatch5" words [ tuple-class? ] subset ;
+ "benchmark.dispatch5" words [ tuple-class? ] filter ;
: a-bunch-of-objects ( -- seq )
my-classes [ new ] map ;
diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor
index 215b677e16..d449c0fc5b 100755
--- a/extra/benchmark/fasta/fasta.factor
+++ b/extra/benchmark/fasta/fasta.factor
@@ -81,7 +81,7 @@ HINTS: random fixnum ;
write-description
[let | k! [ 0 ] alu [ ] |
[| len | k len alu make-repeat-fasta k! ] split-lines
- ] with-locals ; inline
+ ] ; inline
: fasta ( n out -- )
homo-sapiens make-cumulative
@@ -103,7 +103,7 @@ HINTS: random fixnum ;
drop
] with-file-writer
- ] with-locals ;
+ ] ;
: run-fasta 2500000 reverse-complement-in fasta ;
diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor
index e06b81f6de..6bd2d69cfa 100644
--- a/extra/benchmark/knucleotide/knucleotide.factor
+++ b/extra/benchmark/knucleotide/knucleotide.factor
@@ -56,7 +56,7 @@ IN: benchmark.knucleotide
drop ;
: knucleotide ( -- )
- "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
+ "resource:extra/benchmark/knucleotide/knucleotide-input.txt"
ascii [ read-input ] with-file-reader
process-input ;
diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor
index b890fdc8e8..b9b139d7e3 100755
--- a/extra/benchmark/mandel/mandel.factor
+++ b/extra/benchmark/mandel/mandel.factor
@@ -1,5 +1,5 @@
IN: benchmark.mandel
-USING: arrays io kernel math namespaces sequences
+USING: arrays io kernel math math.order namespaces sequences
byte-arrays byte-vectors math.functions math.parser io.files
colors.hsv io.encodings.binary ;
diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor
index 3043725acd..8a259c1217 100644
--- a/extra/benchmark/md5/md5.factor
+++ b/extra/benchmark/md5/md5.factor
@@ -1,7 +1,7 @@
-USING: crypto.md5 io.files kernel ;
+USING: checksums checksums.md5 io.files kernel ;
IN: benchmark.md5
: md5-primes-list ( -- )
- "extra/math/primes/list/list.factor" resource-path file>md5 drop ;
+ "resource:extra/math/primes/list/list.factor" md5 checksum-file drop ;
MAIN: md5-primes-list
diff --git a/extra/benchmark/partial-sums/partial-sums.factor b/extra/benchmark/partial-sums/partial-sums.factor
index b4bb1fa8d2..8eb883241b 100644
--- a/extra/benchmark/partial-sums/partial-sums.factor
+++ b/extra/benchmark/partial-sums/partial-sums.factor
@@ -3,7 +3,8 @@ prettyprint words hints ;
IN: benchmark.partial-sums
: summing ( n quot -- y )
- [ + ] compose 0.0 -rot 1 -rot (each-integer) ; inline
+ [ >float ] swap [ + ] 3compose
+ 0.0 -rot 1 -rot (each-integer) ; inline
: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing ;
diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor
index c66de87cb5..883124105b 100755
--- a/extra/benchmark/reverse-complement/reverse-complement-tests.factor
+++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor
@@ -1,13 +1,13 @@
IN: benchmark.reverse-complement.tests
-USING: tools.test benchmark.reverse-complement crypto.md5
+USING: tools.test benchmark.reverse-complement
+checksums checksums.md5
io.files kernel ;
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [
- "extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
- "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
- [ resource-path ] bi@
+ "resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
+ "resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
reverse-complement
- "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
- resource-path file>md5str
+ "resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
+ md5 checksum-file hex-string
] unit-test
diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor
index d83b720187..5fdaf49d8f 100755
--- a/extra/benchmark/reverse-complement/reverse-complement.factor
+++ b/extra/benchmark/reverse-complement/reverse-complement.factor
@@ -32,13 +32,11 @@ HINTS: do-line vector string ;
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
: reverse-complement ( infile outfile -- )
- ascii [
- swap ascii [
- swap [
- 500000 (reverse-complement)
- ] with-stream
- ] with-disposal
- ] with-disposal ;
+ ascii [
+ ascii [
+ 500000 (reverse-complement)
+ ] with-file-reader
+ ] with-file-writer ;
: reverse-complement-in
"reverse-complement-in.txt" temp-file ;
diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor
index 897d83ea0e..d5ff5673c2 100644
--- a/extra/benchmark/sha1/sha1.factor
+++ b/extra/benchmark/sha1/sha1.factor
@@ -1,7 +1,7 @@
-USING: crypto.sha1 io.files kernel ;
+USING: checksums checksums.sha1 io.files kernel ;
IN: benchmark.sha1
: sha1-primes-list ( -- )
- "extra/math/primes/list/list.factor" resource-path file>sha1 drop ;
+ "resource:extra/math/primes/list/list.factor" sha1 checksum-file drop ;
MAIN: sha1-primes-list
diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor
index 25212c7264..6defd94290 100755
--- a/extra/benchmark/sockets/sockets.factor
+++ b/extra/benchmark/sockets/sockets.factor
@@ -1,6 +1,6 @@
USING: io.sockets io kernel math threads io.encodings.ascii
-debugger tools.time prettyprint concurrency.count-downs
-namespaces arrays continuations ;
+io.streams.duplex debugger tools.time prettyprint
+concurrency.count-downs namespaces arrays continuations ;
IN: benchmark.sockets
SYMBOL: counter
@@ -10,7 +10,7 @@ SYMBOL: counter
: server-addr "127.0.0.1" 7777 ;
: server-loop ( server -- )
- dup accept [
+ dup accept drop [
[
read1 CHAR: x = [
"server" get dispose
@@ -30,17 +30,17 @@ SYMBOL: counter
] ignore-errors ;
: simple-client ( -- )
- server-addr ascii [
+ server-addr ascii [
CHAR: b write1 flush
number-of-requests
[ CHAR: a dup write1 flush read1 assert= ] times
counter get count-down
- ] with-stream ;
+ ] with-client ;
: stop-server ( -- )
- server-addr ascii [
+ server-addr ascii [
CHAR: x write1
- ] with-stream ;
+ ] with-client ;
: clients ( n -- )
dup pprint " clients: " write [
diff --git a/extra/bit-vectors/bit-vectors-docs.factor b/extra/bit-vectors/bit-vectors-docs.factor
index 9ceb2df342..41f32b4cdb 100755
--- a/extra/bit-vectors/bit-vectors-docs.factor
+++ b/extra/bit-vectors/bit-vectors-docs.factor
@@ -3,7 +3,7 @@ bit-vectors.private combinators ;
IN: bit-vectors
ARTICLE: "bit-vectors" "Bit vectors"
-"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
+"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
$nl
"Bit vectors form a class:"
{ $subsection bit-vector }
@@ -19,7 +19,7 @@ $nl
ABOUT: "bit-vectors"
HELP: bit-vector
-{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
+{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP:
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor
index fca0568adf..7fcec00e98 100644
--- a/extra/bitfields/bitfields.factor
+++ b/extra/bitfields/bitfields.factor
@@ -93,7 +93,7 @@ M: check< summary drop "Number exceeds upper bound" ;
>r keys r> define-slots ;
: filter-pad ( slots -- slots )
- [ drop padding-name? not ] assoc-subset ;
+ [ drop padding-name? not ] assoc-filter ;
: define-bitfield ( classname slots -- )
[
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index 4ea20629c1..40ce7adb35 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -3,6 +3,7 @@ USING: kernel namespaces
math
math.constants
math.functions
+ math.order
math.vectors
math.trig
combinators arrays sequences random vars
@@ -116,7 +117,7 @@ over boid-vel -rot relative-position angle-between ;
<--&& ;
: cohesion-neighborhood ( self -- boids )
- boids> [ within-cohesion-neighborhood? ] with subset ;
+ boids> [ within-cohesion-neighborhood? ] with filter ;
: cohesion-force ( self -- force )
dup cohesion-neighborhood
@@ -136,7 +137,7 @@ over boid-vel -rot relative-position angle-between ;
<--&& ;
: separation-neighborhood ( self -- boids )
- boids> [ within-separation-neighborhood? ] with subset ;
+ boids> [ within-separation-neighborhood? ] with filter ;
: separation-force ( self -- force )
dup separation-neighborhood
@@ -156,7 +157,7 @@ over boid-vel -rot relative-position angle-between ;
<--&& ;
: alignment-neighborhood ( self -- boids )
-boids> [ within-alignment-neighborhood? ] with subset ;
+boids> [ within-alignment-neighborhood? ] with filter ;
: alignment-force ( self -- force )
alignment-neighborhood
diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor
index 4326fcf61b..9dd4fd04b2 100755
--- a/extra/bootstrap/help/help.factor
+++ b/extra/bootstrap/help/help.factor
@@ -11,7 +11,7 @@ IN: bootstrap.help
[ drop ] load-vocab-hook [
vocabs
- [ vocab-docs-loaded? not ] subset
+ [ vocab-docs-loaded? not ] filter
[ load-docs ] each
] with-variable ;
diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor
index a186954ef0..46aca6cc6b 100644
--- a/extra/bootstrap/image/download/download.factor
+++ b/extra/bootstrap/image/download/download.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download
-USING: http.client crypto.md5 splitting assocs kernel io.files
-bootstrap.image sequences io ;
+USING: http.client checksums checksums.md5 splitting assocs
+kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ;
@@ -12,7 +12,7 @@ bootstrap.image sequences io ;
: need-new-image? ( image -- ? )
dup exists?
- [ dup file>md5str swap download-checksums at = not ]
+ [ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ]
[ drop t ] if ;
: download-image ( arch -- )
diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor
index ab26a4ff13..30d0428744 100755
--- a/extra/bootstrap/image/upload/upload.factor
+++ b/extra/bootstrap/image/upload/upload.factor
@@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: http.client checksums checksums.md5 splitting assocs
+kernel io.files bootstrap.image sequences io namespaces
+io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload
-USING: http.client crypto.md5 splitting assocs kernel io.files
-bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ;
SYMBOL: upload-images-destination
@@ -17,7 +18,9 @@ SYMBOL: upload-images-destination
: compute-checksums ( -- )
checksums ascii [
- boot-image-names [ dup write bl file>md5str print ] each
+ boot-image-names [
+ [ write bl ] [ md5 checksum-file hex-string print ] bi
+ ] each
] with-file-writer ;
: upload-images ( -- )
diff --git a/extra/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor
index ab72f65b4b..e68fff5efd 100644
--- a/extra/bubble-chamber/particle/muon/colors/colors.factor
+++ b/extra/bubble-chamber/particle/muon/colors/colors.factor
@@ -1,5 +1,5 @@
-USING: kernel sequences math math.constants accessors
+USING: kernel sequences math math.constants math.order accessors
processing
processing.color ;
diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor
index 9e5e932831..afe277d30b 100644
--- a/extra/builder/benchmark/benchmark.factor
+++ b/extra/builder/benchmark/benchmark.factor
@@ -5,9 +5,9 @@ USING: kernel continuations arrays assocs sequences sorting math
IN: builder.benchmark
! : passing-benchmarks ( table -- table )
-! [ second first2 number? swap number? and ] subset ;
+! [ second first2 number? swap number? and ] filter ;
-: passing-benchmarks ( table -- table ) [ second number? ] subset ;
+: passing-benchmarks ( table -- table ) [ second number? ] filter ;
! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
diff --git a/extra/builder/release/branch/branch.factor b/extra/builder/release/branch/branch.factor
index 6218a2ea90..6b1266bb45 100644
--- a/extra/builder/release/branch/branch.factor
+++ b/extra/builder/release/branch/branch.factor
@@ -21,7 +21,7 @@ IN: builder.release.branch
{
"scp"
my-boot-image-name
- "factorcode.org:/var/www/factorcode.org/newsite/images/clean"
+ { "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform }
}
to-strings
try-process ;
diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor
index 3b0834b190..c40efaaa04 100644
--- a/extra/builder/util/util.factor
+++ b/extra/builder/util/util.factor
@@ -16,7 +16,7 @@ IN: builder.util
: minutes>ms ( min -- ms ) 60 * 1000 * ;
-: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ;
+: file>string ( file -- string ) utf8 file-contents ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -107,5 +107,5 @@ USE: prettyprint
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
- { "git" "show" } utf8 [ readln ] with-stream
+ { "git" "show" } utf8 [ readln ] with-input-stream
" " split second ;
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index 43b9edcd00..d546f9ea41 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets
ui.gadgets.canvas ui.render ui splitting combinators tools.time
system combinators.lib float-arrays continuations
opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
-bunny.cel-shaded bunny.outlined bunny.model ;
+bunny.cel-shaded bunny.outlined bunny.model accessors ;
IN: bunny
TUPLE: bunny-gadget model geom draw-seq draw-n ;
@@ -13,38 +13,33 @@ TUPLE: bunny-gadget model geom draw-seq draw-n ;
0.0 0.0 0.375
maybe-download read-model {
set-delegate
- set-bunny-gadget-model
+ (>>model)
} bunny-gadget construct ;
: bunny-gadget-draw ( gadget -- draw )
- { bunny-gadget-draw-n bunny-gadget-draw-seq }
+ { draw-n>> draw-seq>> }
get-slots nth ;
: bunny-gadget-next-draw ( gadget -- )
- dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
+ dup { draw-seq>> draw-n>> }
get-slots
1+ swap length mod
- swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
+ >>draw-n relayout-1 ;
M: bunny-gadget graft* ( gadget -- )
GL_DEPTH_TEST glEnable
- dup bunny-gadget-model
- over {
- [ ]
- [ ]
- [ ]
- } map-call-with [ ] subset
- 0
- roll {
- set-bunny-gadget-geom
- set-bunny-gadget-draw-seq
- set-bunny-gadget-draw-n
- } set-slots ;
+ dup model>> >>geom
+ dup
+ [ ]
+ [ ]
+ [ ] tri 3array
+ [ ] filter >>draw-seq
+ 0 >>draw-n
+ drop ;
M: bunny-gadget ungraft* ( gadget -- )
- { bunny-gadget-geom bunny-gadget-draw-seq } get-slots
- [ [ dispose ] when* ] each
- [ dispose ] when* ;
+ [ geom>> [ dispose ] when* ]
+ [ draw-seq>> [ [ dispose ] when* ] each ] bi ;
M: bunny-gadget draw-gadget* ( gadget -- )
0.15 0.15 0.15 1.0 glClearColor
@@ -52,7 +47,7 @@ M: bunny-gadget draw-gadget* ( gadget -- )
dup demo-gadget-set-matrices
GL_MODELVIEW glMatrixMode
0.02 -0.105 0.0 glTranslatef
- { bunny-gadget-geom bunny-gadget-draw } get-slots
+ { geom>> bunny-gadget-draw } get-slots
draw-bunny ;
M: bunny-gadget pref-dim* ( gadget -- dim )
diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
index d4f0b7612d..08bea0515b 100644
--- a/extra/bunny/cel-shaded/cel-shaded.factor
+++ b/extra/bunny/cel-shaded/cel-shaded.factor
@@ -1,5 +1,5 @@
USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders
- opengl.capabilities opengl.gl sequences sequences.lib ;
+ opengl.capabilities opengl.gl sequences sequences.lib accessors ;
IN: bunny.cel-shaded
STRING: vertex-shader-source
@@ -68,11 +68,12 @@ TUPLE: bunny-cel-shaded program ;
: ( gadget -- draw )
drop
cel-shading-supported? [
+ bunny-cel-shaded new
vertex-shader-source check-gl-shader
cel-shaded-fragment-shader-lib-source check-gl-shader
cel-shaded-fragment-shader-main-source check-gl-shader
3array check-gl-program
- { set-bunny-cel-shaded-program } bunny-cel-shaded construct
+ >>program
] [ f ] if ;
: (draw-cel-shaded-bunny) ( geom program -- )
@@ -85,8 +86,8 @@ TUPLE: bunny-cel-shaded program ;
} [ bunny-geom ] with-gl-program ;
M: bunny-cel-shaded draw-bunny
- bunny-cel-shaded-program (draw-cel-shaded-bunny) ;
+ program>> (draw-cel-shaded-bunny) ;
M: bunny-cel-shaded dispose
- bunny-cel-shaded-program delete-gl-program ;
+ program>> delete-gl-program ;
diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor
index f3fb68e515..bf0fc45f0f 100644
--- a/extra/bunny/fixed-pipeline/fixed-pipeline.factor
+++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor
@@ -6,7 +6,7 @@ TUPLE: bunny-fixed-pipeline ;
: ( gadget -- draw )
drop
- { } bunny-fixed-pipeline construct ;
+ bunny-fixed-pipeline new ;
M: bunny-fixed-pipeline draw-bunny
drop
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index 897a30c417..239603755d 100755
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -2,17 +2,17 @@ USING: alien alien.c-types arrays sequences math math.vectors
math.matrices math.parser io io.files kernel opengl opengl.gl
opengl.glu io.encodings.ascii opengl.capabilities shuffle
http.client vectors splitting tools.time system combinators
-float-arrays continuations namespaces sequences.lib ;
+float-arrays continuations namespaces sequences.lib accessors ;
IN: bunny.model
: numbers ( str -- seq )
- " " split [ string>number ] map [ ] subset ;
+ " " split [ string>number ] map [ ] filter ;
: (parse-model) ( vs is -- vs is )
readln [
numbers {
{ [ dup length 5 = ] [ 3 head pick push ] }
- { [ dup first 3 = ] [ 1 tail over push ] }
+ { [ dup first 3 = ] [ rest over push ] }
[ drop ]
} cond (parse-model)
] when* ;
@@ -85,24 +85,24 @@ M: bunny-dlist bunny-geom
bunny-dlist-list glCallList ;
M: bunny-buffers bunny-geom
- dup {
- bunny-buffers-array
- bunny-buffers-element-array
- } get-slots [
+ dup { array>> element-array>> } get-slots [
{ GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [
GL_DOUBLE 0 0 buffer-offset glNormalPointer
- dup bunny-buffers-nv "double" heap-size * buffer-offset
- 3 GL_DOUBLE 0 roll glVertexPointer
- bunny-buffers-ni
- GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
+ [
+ nv>> "double" heap-size * buffer-offset
+ 3 GL_DOUBLE 0 roll glVertexPointer
+ ] [
+ ni>>
+ GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
+ ] bi
] all-enabled-client-state
] with-array-element-buffers ;
M: bunny-dlist dispose
- bunny-dlist-list delete-dlist ;
+ list>> delete-dlist ;
M: bunny-buffers dispose
- { bunny-buffers-array bunny-buffers-element-array } get-slots
+ { array>> element-array>> } get-slots
delete-gl-buffer delete-gl-buffer ;
: ( model -- geom )
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index 6a2f54cceb..fef57d95d2 100755
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -1,6 +1,7 @@
USING: arrays bunny.model bunny.cel-shaded continuations kernel
math multiline opengl opengl.shaders opengl.framebuffers
-opengl.gl opengl.capabilities sequences ui.gadgets combinators ;
+opengl.gl opengl.capabilities sequences ui.gadgets combinators
+accessors ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
@@ -139,9 +140,9 @@ TUPLE: bunny-outlined
: ( gadget -- draw )
outlining-supported? [
pass1-program pass2-program {
- set-bunny-outlined-gadget
- set-bunny-outlined-pass1-program
- set-bunny-outlined-pass2-program
+ (>>gadget)
+ (>>pass1-program)
+ (>>pass2-program)
} bunny-outlined construct
] [ drop f ] if ;
@@ -169,35 +170,33 @@ TUPLE: bunny-outlined
] with-framebuffer ;
: dispose-framebuffer ( draw -- )
- dup bunny-outlined-framebuffer-dim [
+ dup framebuffer-dim>> [
{
- [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ]
- [ bunny-outlined-color-texture [ delete-texture ] when* ]
- [ bunny-outlined-normal-texture [ delete-texture ] when* ]
- [ bunny-outlined-depth-texture [ delete-texture ] when* ]
- [ f swap set-bunny-outlined-framebuffer-dim ]
+ [ framebuffer>> [ delete-framebuffer ] when* ]
+ [ color-texture>> [ delete-texture ] when* ]
+ [ normal-texture>> [ delete-texture ] when* ]
+ [ depth-texture>> [ delete-texture ] when* ]
+ [ f >>framebuffer-dim drop ]
} cleave
] [ drop ] if ;
: remake-framebuffer-if-needed ( draw -- )
- dup bunny-outlined-gadget rect-dim
- over bunny-outlined-framebuffer-dim
+ dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi
over =
- [ 2drop ]
- [
- swap dup dispose-framebuffer >r
- dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
- swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
- swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
- swap >r
- [ (make-framebuffer) ] 3keep
- r> r> {
- set-bunny-outlined-framebuffer
- set-bunny-outlined-color-texture
- set-bunny-outlined-normal-texture
- set-bunny-outlined-depth-texture
- set-bunny-outlined-framebuffer-dim
- } set-slots
+ [ 2drop ] [
+ [ dup dispose-framebuffer dup ] dip {
+ [
+ GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
+ [ >>color-texture drop ] keep
+ ] [
+ GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
+ [ >>normal-texture drop ] keep
+ ] [
+ GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
+ [ >>depth-texture drop ] keep
+ ]
+ } 2cleave
+ (make-framebuffer) >>framebuffer drop
] if ;
: clear-framebuffer ( -- )
@@ -209,31 +208,34 @@ TUPLE: bunny-outlined
GL_COLOR_BUFFER_BIT glClear ;
: (pass1) ( geom draw -- )
- dup bunny-outlined-framebuffer [
+ dup framebuffer>> [
clear-framebuffer
{ GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
- bunny-outlined-pass1-program (draw-cel-shaded-bunny)
+ pass1-program>> (draw-cel-shaded-bunny)
] with-framebuffer ;
: (pass2) ( draw -- )
- init-matrices
- dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
- dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
- dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
- bunny-outlined-pass2-program {
- { "colormap" [ 0 glUniform1i ] }
- { "normalmap" [ 1 glUniform1i ] }
- { "depthmap" [ 2 glUniform1i ] }
- { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
- } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ;
+ init-matrices {
+ [ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
+ [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
+ [ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
+ [
+ pass2-program>> {
+ { "colormap" [ 0 glUniform1i ] }
+ { "normalmap" [ 1 glUniform1i ] }
+ { "depthmap" [ 2 glUniform1i ] }
+ { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
+ } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ]
+ with-gl-program
+ ]
+ } cleave ;
M: bunny-outlined draw-bunny
- dup remake-framebuffer-if-needed
- [ (pass1) ] keep (pass2) ;
+ [ remake-framebuffer-if-needed ]
+ [ (pass1) ]
+ [ (pass2) ] tri ;
M: bunny-outlined dispose
- {
- [ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
- [ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
- [ dispose-framebuffer ]
- } cleave ;
+ [ pass1-program>> [ delete-gl-program ] when* ]
+ [ pass2-program>> [ delete-gl-program ] when* ]
+ [ dispose-framebuffer ] tri ;
diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor
index 1bbad29835..a3b13c9691 100755
--- a/extra/cairo/png/png.factor
+++ b/extra/cairo/png/png.factor
@@ -21,7 +21,7 @@ ERROR: cairo-error string ;
{ CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
{ CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
[ drop ]
- } cond ;
+ } case ;
: ( path -- png )
normalize-path
diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor
index e49d3ad894..7d9716ae1a 100755
--- a/extra/calendar/calendar-tests.factor
+++ b/extra/calendar/calendar-tests.factor
@@ -1,7 +1,11 @@
USING: arrays calendar kernel math sequences tools.test
-continuations system ;
+continuations system math.order threads ;
IN: calendar.tests
+\ time+ must-infer
+\ time* must-infer
+\ time- must-infer
+
[ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test
@@ -127,16 +131,16 @@ IN: calendar.tests
[ t ] [ 2004 1 1 23 0 0 9+1/2 hours >gmt
2004 1 1 13 30 0 instant = ] unit-test
-[ 0 ] [ 2004 1 1 13 30 0 instant
+[ +eq+ ] [ 2004 1 1 13 30 0 instant
2004 1 1 12 30 0 -1 hours <=> ] unit-test
-[ 1 ] [ 2004 1 1 13 30 0 instant
+[ +gt+ ] [ 2004 1 1 13 30 0 instant