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/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..de62ccd878 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -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." } ; @@ -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..19e323bdae 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -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..e68c311836 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 -- ? ) @@ -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..a19ffe742e 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 @@ -74,6 +74,6 @@ nl malloc calloc free memcpy } compile -vocabs [ words [ compiled? not ] subset compile "." write flush ] each +vocabs [ words [ compiled? not ] filter compile "." write flush ] each " done" print flush diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 05d48af2e8..5d8bbf3f77 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 ; IN: bootstrap.image : my-arch ( -- arch ) @@ -305,7 +305,7 @@ 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 ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index dd3a4adf8b..bcd75e9854 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -157,7 +157,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 diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index dfd2e4be6f..8e4108866f 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 diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index f2941e3cef..6a286e3204 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -183,7 +183,7 @@ C: anonymous-complement : largest-class ( seq -- n elt ) dup [ [ 2dup class< >r swap class< not r> and ] - with subset empty? + with filter empty? ] curry find [ "Topological sort failed" throw ] unless* ; : sort-classes ( seq -- newseq ) @@ -193,7 +193,7 @@ C: anonymous-complement [ ] 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 ] if ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index dd3782e877..5971ffd9fa 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -55,7 +55,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 +63,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.factor b/core/classes/classes.factor index 4f43b86f64..c998a1b155 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -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 ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 33b0fc32fa..ca2547bacf 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -31,7 +31,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/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..41776c4eec 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 ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index c14205e1d9..8bcf023131 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index da98a78736..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 ; 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/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/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 1799411021..70345b1e96 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -4,7 +4,7 @@ USING: alien.c-types cpu.ppc.assembler cpu.architecture generic kernel kernel.private math memory namespaces sequences words assocs generator generator.registers generator.fixup system layouts classes words.private alien combinators -compiler.constants ; +compiler.constants math.order ; IN: cpu.ppc.architecture ! PowerPC register assignments diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor index 628022698f..b1d7016eff 100755 --- a/core/cpu/ppc/assembler/assembler.factor +++ b/core/cpu/ppc/assembler/assembler.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: generator.fixup generic kernel memory namespaces +words math math.bitfields math.order io.binary ; IN: cpu.ppc.assembler -USING: generator.fixup generic kernel math memory namespaces -words math.bitfields io.binary ; ! See the Motorola or IBM documentation for details. The opcode ! names are standard, and the operand order is the same as in diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index d79ce58d88..5f396e7751 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -181,7 +181,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >> : split-struct ( pairs -- seq ) [ [ 8 mod zero? [ t , ] when , ] assoc-each - ] { } make { t } split [ empty? not ] subset ; + ] { } make { t } split [ empty? not ] filter ; : flatten-large-struct ( type -- ) heap-size cell align 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.factor b/core/debugger/debugger.factor index 827a5c4e8d..9492304628 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -6,7 +6,8 @@ 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 ; +init kernel.private libc io.encodings mirrors accessors +math.order ; IN: debugger GENERIC: error. ( error -- ) @@ -289,6 +290,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..e0fd7bd457 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+ @@ -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 -- ) 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..82bab475b3 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..d71749804b 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -3,7 +3,7 @@ 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 diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index 1f0b80e016..c09f1abfd4 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..e4643b2f3d 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -17,8 +17,8 @@ C: predicate-dispatch-engine { { [ 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/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..54eb93a201 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 diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index f60748a5ac..2e1a69e407 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 ) @@ -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..9d0c55afeb 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -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/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/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..576307b589 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 ) @@ -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/streams/string/string.factor b/core/io/streams/string/string.factor index b7ff37a971..531d0401b2 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 ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 4578e2a93f..a3209ea42c 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 kernel.private vectors combinators quotations strings words -assocs arrays ; +assocs arrays math.order ; IN: kernel ARTICLE: "shuffle-words" "Shuffle words" @@ -393,29 +393,8 @@ 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/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..a35e4926bc 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -17,11 +17,6 @@ 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 @@ -61,23 +56,14 @@ M: object zero? drop f ; : 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 +82,9 @@ 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 +143,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/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..de7aec2bb1 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 ; 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/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/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..b69985fb1d 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -51,9 +51,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 @@ -294,6 +296,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 +329,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 +457,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 } } diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index ab193e1c02..20d51f3461 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,5 @@ must-fail-with [ "USE: this-better-not-exist" eval ] must-fail + +[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7639ebaa69..23c0c0a1a5 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 @@ -440,8 +453,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 +518,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 +536,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..e13a991e2b 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -3,7 +3,7 @@ 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 +io io.files math.parser effects classes.tuple math.order classes.tuple.private classes float-arrays ; IN: prettyprint.backend diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor index 7cc141be22..2933c8ee6f 100755 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -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.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.factor b/core/prettyprint/sections/sections.factor index 803f6e2459..5f32539115 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -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 @@ -310,7 +310,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..2a2fcf29cd 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" @@ -92,6 +92,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices" { $subsection subseq } { $subsection head } { $subsection tail } +{ $subsection rest } { $subsection head* } { $subsection tail* } "Taking a sequence apart into a head and a tail:" @@ -105,6 +106,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices" { $subsection } { $subsection head-slice } { $subsection tail-slice } +{ $subsection rest-slice } { $subsection head-slice* } { $subsection tail-slice* } "Taking a sequence apart into a head and a tail:" @@ -127,7 +129,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 +155,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 +502,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 +515,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 +532,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 +564,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 +574,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 +836,12 @@ 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: 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 if the index is out of bounds." } ; + 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 +862,11 @@ 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: 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..a63e6d2835 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,6 +210,8 @@ 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 ; @@ -248,12 +251,14 @@ 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 ; @@ -267,11 +272,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 +285,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 +329,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 +338,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 +379,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 +400,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 +420,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 +439,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 +478,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 +503,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 +525,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 +550,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 +615,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 +640,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 +668,10 @@ PRIVATE> tuck tail-slice >r tail-slice r> ; : unclip ( seq -- rest first ) - dup 1 tail swap first ; + [ rest ] [ first ] bi ; : unclip-slice ( seq -- rest first ) - dup 1 tail-slice swap first ; + [ rest-slice ] [ first ] bi ; : ( seq -- slice ) dup slice? [ { } like ] when 0 over length rot ; @@ -680,7 +686,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..55ef3ccddd 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -39,9 +39,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 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..78a92155fc 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -22,10 +22,10 @@ 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 ; 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..3da6ea6bd6 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:" diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index 732aeb045d..441867af66 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 diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 5f81b17187..6aafe2ded1 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math sequences vectors +USING: arrays kernel math sequences vectors math.order sequences sequences.private growable ; IN: sorting diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 5703b631f4..5ef2d46790 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -19,7 +19,7 @@ uses definitions ; : (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..eb10b9fe4a 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces strings arrays vectors sequences -sets ; +sets math.order ; IN: splitting TUPLE: groups seq n sliced? ; @@ -61,7 +61,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 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..b2f063ddf1 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -189,8 +189,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.factor b/core/threads/threads.factor index 2f9c3a73de..8b89cd5732 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -1,10 +1,11 @@ ! 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 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 ; 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/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/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/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/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/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/bunny/bunny.factor b/extra/bunny/bunny.factor index 43b9edcd00..ae34923c64 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- ) [ ] [ ] [ ] - } map-call-with [ ] subset + } map-call-with [ ] filter 0 roll { set-bunny-gadget-geom diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 897a30c417..8d05b14a20 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -6,13 +6,13 @@ float-arrays continuations namespaces sequences.lib ; 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* ; diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index c05d4f60eb..e2a2bc7e66 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,5 +1,5 @@ USING: arrays calendar kernel math sequences tools.test -continuations system ; +continuations system math.order threads ; IN: calendar.tests \ time+ must-infer @@ -163,3 +163,7 @@ IN: calendar.tests [ t ] [ 5 months checktime+ ] unit-test [ t ] [ 5 years checktime+ ] unit-test + +[ t ] [ now 50 milliseconds sleep now before? ] unit-test +[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test +[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 2f93bf8218..0e21876fe9 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -3,7 +3,7 @@ USING: arrays kernel math math.functions namespaces sequences strings system vocabs.loader calendar.backend threads -accessors combinators locals classes.tuple ; +accessors combinators locals classes.tuple math.order ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index 1ba892bef3..f4e1669178 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -1,5 +1,5 @@ USING: calendar.format calendar kernel math tools.test -io.streams.string accessors io ; +io.streams.string accessors io math.order ; IN: calendar.format.tests [ 0 ] [ @@ -43,3 +43,10 @@ IN: calendar.format.tests ] unit-test [ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test + +[ t ] [ now dup timestamp>cookie-string cookie-string>timestamp time- 1 seconds before? ] unit-test + +[ "Sun, 4 May 2008 07:00:00" ] [ + "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp + timestamp>string +] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 7bdaea70b5..26daaddc40 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,8 +1,50 @@ -USING: math math.parser kernel sequences io calendar +USING: math math.order math.parser kernel sequences io accessors arrays io.streams.string splitting -combinators accessors debugger ; +combinators accessors debugger +calendar calendar.format.macros ; IN: calendar.format +: pad-00 number>string 2 CHAR: 0 pad-left ; + +: pad-0000 number>string 4 CHAR: 0 pad-left ; + +: pad-00000 number>string 5 CHAR: 0 pad-left ; + +: write-00 pad-00 write ; + +: write-0000 pad-0000 write ; + +: write-00000 pad-00000 write ; + +: hh hour>> write-00 ; + +: mm minute>> write-00 ; + +: ss second>> >integer write-00 ; + +: D day>> number>string write ; + +: DD day>> write-00 ; + +: DAY day-of-week day-abbreviations3 nth write ; + +: MM month>> write-00 ; + +: MONTH month>> month-abbreviations nth write ; + +: YYYY year>> write-0000 ; + +: YYYYY year>> write-00000 ; + +: expect ( str -- ) + read1 swap member? [ "Parse error" throw ] unless ; + +: read-00 2 read string>number ; + +: read-000 3 read string>number ; + +: read-0000 4 read string>number ; + GENERIC: day. ( obj -- ) M: integer day. ( n -- ) @@ -25,7 +67,7 @@ M: array month. ( pair -- ) ] with each nl ; M: timestamp month. ( timestamp -- ) - { year>> month>> } get-slots 2array month. ; + [ year>> ] [ month>> ] bi 2array month. ; GENERIC: year. ( obj -- ) @@ -35,28 +77,14 @@ M: integer year. ( n -- ) M: timestamp year. ( timestamp -- ) year>> year. ; -: pad-00 number>string 2 CHAR: 0 pad-left ; - -: pad-0000 number>string 4 CHAR: 0 pad-left ; - -: write-00 pad-00 write ; - -: write-0000 pad-0000 write ; - : (timestamp>string) ( timestamp -- ) - dup day-of-week day-abbreviations3 nth write ", " write - dup day>> number>string write bl - dup month>> month-abbreviations nth write bl - dup year>> number>string write bl - dup hour>> write-00 ":" write - dup minute>> write-00 ":" write - second>> >integer write-00 ; + { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ; : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] with-string-writer ; : (write-gmt-offset) ( duration -- ) - [ hour>> write-00 ] [ minute>> write-00 ] bi ; + [ hh ] [ mm ] bi ; : write-gmt-offset ( gmt-offset -- ) dup instant <=> sgn { @@ -69,9 +97,9 @@ M: timestamp year. ( timestamp -- ) #! RFC822 timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 +0200 [ - dup (timestamp>string) - " " write - gmt-offset>> write-gmt-offset + [ (timestamp>string) " " write ] + [ gmt-offset>> write-gmt-offset ] + bi ] with-string-writer ; : timestamp>http-string ( timestamp -- str ) @@ -79,40 +107,32 @@ M: timestamp year. ( timestamp -- ) #! Example: Tue, 15 Nov 1994 08:12:31 GMT >gmt timestamp>rfc822 ; +: (timestamp>cookie-string) ( timestamp -- ) + >gmt + { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ; + +: timestamp>cookie-string ( timestamp -- str ) + [ (timestamp>cookie-string) ] with-string-writer ; + : (write-rfc3339-gmt-offset) ( duration -- ) - [ hour>> write-00 CHAR: : write1 ] - [ minute>> write-00 ] bi ; + [ hh ":" write ] [ mm ] bi ; : write-rfc3339-gmt-offset ( duration -- ) dup instant <=> sgn { { 0 [ drop "Z" write ] } - { -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] } - { 1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] } + { -1 [ "-" write before (write-rfc3339-gmt-offset) ] } + { 1 [ "+" write (write-rfc3339-gmt-offset) ] } } case ; : (timestamp>rfc3339) ( timestamp -- ) { - [ year>> number>string write CHAR: - write1 ] - [ month>> write-00 CHAR: - write1 ] - [ day>> write-00 CHAR: T write1 ] - [ hour>> write-00 CHAR: : write1 ] - [ minute>> write-00 CHAR: : write1 ] - [ second>> >fixnum write-00 ] + YYYY "-" MM "-" DD "T" hh ":" mm ":" ss [ gmt-offset>> write-rfc3339-gmt-offset ] - } cleave ; + } formatted ; : timestamp>rfc3339 ( timestamp -- str ) [ (timestamp>rfc3339) ] with-string-writer ; -: expect ( str -- ) - read1 swap member? [ "Parse error" throw ] unless ; - -: read-00 2 read string>number ; - -: read-000 3 read string>number ; - -: read-0000 4 read string>number ; - : signed-gmt-offset ( dt ch -- dt' ) { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ; @@ -142,17 +162,18 @@ M: timestamp year. ( timestamp -- ) : rfc3339>timestamp ( str -- timestamp ) [ (rfc3339>timestamp) ] with-string-reader ; -ERROR: invalid-rfc822-date ; +ERROR: invalid-timestamp-format ; -: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ; +: check-timestamp ( obj/f -- obj ) + [ invalid-timestamp-format ] unless* ; : read-token ( seps -- token ) - [ read-until ] keep member? check-rfc822-date drop ; + [ read-until ] keep member? check-timestamp drop ; : read-sp ( -- token ) " " read-token ; : checked-number ( str -- n ) - string>number check-rfc822-date ; + string>number check-timestamp ; : parse-rfc822-gmt-offset ( string -- dt ) dup "GMT" = [ drop instant ] [ @@ -163,10 +184,10 @@ ERROR: invalid-rfc822-date ; : (rfc822>timestamp) ( -- timestamp ) timestamp new - "," read-token day-abbreviations3 member? check-rfc822-date drop + "," read-token day-abbreviations3 member? check-timestamp drop read1 CHAR: \s assert= read-sp checked-number >>day - read-sp month-abbreviations index check-rfc822-date >>month + read-sp month-abbreviations index check-timestamp >>month read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute @@ -176,6 +197,42 @@ ERROR: invalid-rfc822-date ; : rfc822>timestamp ( str -- timestamp ) [ (rfc822>timestamp) ] with-string-reader ; +: (cookie-string>timestamp-1) ( -- timestamp ) + timestamp new + "," read-token day-abbreviations3 member? check-timestamp drop + read1 CHAR: \s assert= + "-" read-token checked-number >>day + "-" read-token month-abbreviations index check-timestamp >>month + read-sp checked-number >>year + ":" read-token checked-number >>hour + ":" read-token checked-number >>minute + " " read-token checked-number >>second + readln parse-rfc822-gmt-offset >>gmt-offset ; + +: cookie-string>timestamp-1 ( str -- timestamp ) + [ (cookie-string>timestamp-1) ] with-string-reader ; + +: (cookie-string>timestamp-2) ( -- timestamp ) + timestamp new + read-sp day-abbreviations3 member? check-timestamp drop + read-sp month-abbreviations index check-timestamp >>month + read-sp checked-number >>day + ":" read-token checked-number >>hour + ":" read-token checked-number >>minute + " " read-token checked-number >>second + read-sp checked-number >>year + readln parse-rfc822-gmt-offset >>gmt-offset ; + +: cookie-string>timestamp-2 ( str -- timestamp ) + [ (cookie-string>timestamp-2) ] with-string-reader ; + +: cookie-string>timestamp ( str -- timestamp ) + { + [ cookie-string>timestamp-1 ] + [ cookie-string>timestamp-2 ] + [ rfc822>timestamp ] + } attempt-all-quots ; + : (ymdhms>timestamp) ( -- timestamp ) read-ymd " " expect read-hms instant ; @@ -195,41 +252,30 @@ ERROR: invalid-rfc822-date ; [ (ymd>timestamp) ] with-string-reader ; : (timestamp>ymd) ( timestamp -- ) - dup timestamp-year write-0000 - "-" write - dup timestamp-month write-00 - "-" write - timestamp-day write-00 ; + { YYYY "-" MM "-" DD } formatted ; : timestamp>ymd ( timestamp -- str ) [ (timestamp>ymd) ] with-string-writer ; : (timestamp>hms) - dup timestamp-hour write-00 - ":" write - dup timestamp-minute write-00 - ":" write - timestamp-second >integer write-00 ; + { hh ":" mm ":" ss } formatted ; : timestamp>hms ( timestamp -- str ) [ (timestamp>hms) ] with-string-writer ; : timestamp>ymdhms ( timestamp -- str ) - >gmt [ - dup (timestamp>ymd) - " " write - (timestamp>hms) + >gmt + { (timestamp>ymd) " " (timestamp>hms) } formatted ] with-string-writer ; : file-time-string ( timestamp -- string ) [ - [ month>> month-abbreviations nth write ] keep bl - [ day>> number>string 2 32 pad-left write ] keep bl - dup now [ year>> ] bi@ = [ - [ hour>> write-00 ] keep ":" write - minute>> write-00 - ] [ - year>> number>string 5 32 pad-left write - ] if + { + MONTH " " DD " " + [ + dup now [ year>> ] bi@ = + [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if + ] + } formatted ] with-string-writer ; diff --git a/extra/calendar/format/macros/macros-tests.factor b/extra/calendar/format/macros/macros-tests.factor new file mode 100644 index 0000000000..91a8f80894 --- /dev/null +++ b/extra/calendar/format/macros/macros-tests.factor @@ -0,0 +1,14 @@ +USING: tools.test kernel ; +IN: calendar.format.macros + +[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test + +[ 2 ] [ { [ 1 throw ] [ 2 ] } attempt-all-quots ] unit-test + +[ { [ 1 throw ] } attempt-all-quots ] [ 1 = ] must-fail-with + +: compiled-test-1 { [ 1 throw ] [ 2 ] } attempt-all-quots ; + +\ compiled-test-1 must-infer + +[ 2 ] [ compiled-test-1 ] unit-test diff --git a/extra/calendar/format/macros/macros.factor b/extra/calendar/format/macros/macros.factor new file mode 100644 index 0000000000..6d6dd3ae23 --- /dev/null +++ b/extra/calendar/format/macros/macros.factor @@ -0,0 +1,19 @@ +USING: macros kernel words quotations io sequences combinators +continuations ; +IN: calendar.format.macros + +MACRO: formatted ( spec -- ) + [ + { + { [ dup word? ] [ 1quotation ] } + { [ dup quotation? ] [ ] } + [ [ nip write ] curry [ ] like ] + } cond + ] map [ cleave ] curry ; + +MACRO: attempt-all-quots ( quots -- ) + dup length 1 = [ first ] [ + unclip swap + [ nip attempt-all-quots ] curry + [ recover ] 2curry + ] if ; diff --git a/extra/classes/tuple/lib/lib-docs.factor b/extra/classes/tuple/lib/lib-docs.factor index 34dd181d3b..0c4c11e46f 100644 --- a/extra/classes/tuple/lib/lib-docs.factor +++ b/extra/classes/tuple/lib/lib-docs.factor @@ -6,6 +6,7 @@ HELP: >tuple< { $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." } { $example "USING: kernel prettyprint classes.tuple.lib ;" + "IN: scratchpad" "TUPLE: foo a b c ;" "1 2 3 \\ foo boa \\ foo >tuple< .s" "1\n2\n3" @@ -18,6 +19,7 @@ HELP: >tuple*< { $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." } { $example "USING: kernel prettyprint classes.tuple.lib ;" + "IN: scratchpad" "TUPLE: foo a bb* ccc dddd* ;" "1 2 3 4 \\ foo boa \\ foo >tuple*< .s" "2\n4" diff --git a/extra/classes/tuple/lib/lib.factor b/extra/classes/tuple/lib/lib.factor index 38104a45db..10261a1df7 100755 --- a/extra/classes/tuple/lib/lib.factor +++ b/extra/classes/tuple/lib/lib.factor @@ -7,11 +7,11 @@ IN: classes.tuple.lib [ slot-spec-reader ] map [ get-slots ] curry ; MACRO: >tuple< ( class -- ) - all-slots 1 tail-slice reader-slots ; + all-slots rest-slice reader-slots ; MACRO: >tuple*< ( class -- ) all-slots - [ slot-spec-name "*" tail? ] subset + [ slot-spec-name "*" tail? ] filter reader-slots ; diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index df3f84d451..f917e20bc4 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -142,7 +142,7 @@ H{ } assoc-union alien>objc-types set-global : objc-struct-type ( i string -- ctype ) - 2dup CHAR: = -rot index* swap subseq + 2dup CHAR: = -rot index-from swap subseq dup c-types get key? [ "Warning: no such C type: " write dup print drop "void*" diff --git a/extra/concurrency/combinators/combinators-docs.factor b/extra/concurrency/combinators/combinators-docs.factor index 0db235d9e6..bbf8fb0f5f 100755 --- a/extra/concurrency/combinators/combinators-docs.factor +++ b/extra/concurrency/combinators/combinators-docs.factor @@ -11,15 +11,15 @@ HELP: parallel-each { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." } { $errors "Throws an error if one of the iterations throws an error." } ; -HELP: parallel-subset +HELP: parallel-filter { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." } { $errors "Throws an error if one of the iterations throws an error." } ; ARTICLE: "concurrency.combinators" "Concurrent combinators" -"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link subset } ":" +"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":" { $subsection parallel-each } { $subsection parallel-map } -{ $subsection parallel-subset } ; +{ $subsection parallel-filter } ; ABOUT: "concurrency.combinators" diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index 731a740983..3381cba5e8 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -4,7 +4,7 @@ concurrency.mailboxes threads sequences accessors ; [ [ drop ] parallel-each ] must-infer [ [ ] parallel-map ] must-infer -[ [ ] parallel-subset ] must-infer +[ [ ] parallel-filter ] must-infer [ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test @@ -14,7 +14,7 @@ concurrency.mailboxes threads sequences accessors ; [ error>> "Even" = ] must-fail-with [ V{ 0 3 6 9 } ] -[ 10 [ 3 mod zero? ] parallel-subset ] unit-test +[ 10 [ 3 mod zero? ] parallel-filter ] unit-test [ 10 ] [ diff --git a/extra/concurrency/combinators/combinators.factor b/extra/concurrency/combinators/combinators.factor index 76c3cfa77d..3c4101e381 100755 --- a/extra/concurrency/combinators/combinators.factor +++ b/extra/concurrency/combinators/combinators.factor @@ -13,5 +13,5 @@ IN: concurrency.combinators [ [ >r curry r> spawn-stage ] 2curry each ] keep await ; inline -: parallel-subset ( seq quot -- newseq ) +: parallel-filter ( seq quot -- newseq ) over >r pusher >r each r> r> like ; inline diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 67a4e59d04..4698aa45ae 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -153,7 +153,7 @@ SYMBOL: event-stream-callbacks [ event-stream-callbacks global - [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at + [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at ] "core-foundation" add-init-hook : add-event-source-callback ( quot -- id ) diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index ecc998e99c..f1af0ef15e 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -573,7 +573,7 @@ SYMBOL: $4 #! $1, $2, etc with the relevant item from the #! given index. dup quotation? over [ ] = not and [ ! vector tree - dup first swap 1 tail ! vector car cdr + dup first swap rest ! vector car cdr >r dupd replace-patterns ! vector v R: cdr swap r> replace-patterns >r 1quotation r> append ] [ ! vector value diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 37e92db60f..3a74d1f5db 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -123,6 +123,6 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; : byte-array>sha1-interleave ( string -- seq ) [ zero? ] left-trim - dup length odd? [ 1 tail ] when + dup length odd? [ rest ] when seq>2seq [ byte-array>sha1 ] bi@ 2seq>seq ; diff --git a/extra/db/db-tests.factor b/extra/db/db-tests.factor index 9c32f9e326..0d95e3aea7 100755 --- a/extra/db/db-tests.factor +++ b/extra/db/db-tests.factor @@ -3,3 +3,4 @@ USING: tools.test db kernel ; { 1 0 } [ [ drop ] query-each ] must-infer-as { 1 1 } [ [ ] query-map ] must-infer-as +{ 2 0 } [ [ ] with-db ] must-infer-as diff --git a/extra/db/db.factor b/extra/db/db.factor index 82193ed467..42a2b4bcb0 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -130,7 +130,8 @@ M: nonthrowable execute-statement* ( statement type -- ) : with-db ( db seq quot -- ) >r make-db db-open db r> - [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ; + [ db get swap [ drop ] prepose with-disposal ] curry with-variable ; + inline : default-query ( query -- result-set ) query-results [ [ sql-row ] query-map ] with-disposal ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index d270e6f40d..436d701803 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -69,6 +69,11 @@ M: postgresql-result-null summary ( obj -- str ) : malloc-byte-array/length [ malloc-byte-array dup free-always ] [ length ] bi ; +: default-param-value + number>string* dup [ + utf8 malloc-string dup free-always + ] when 0 ; + : param-values ( statement -- seq seq2 ) [ bind-params>> ] [ in-params>> ] bi [ @@ -77,11 +82,11 @@ M: postgresql-result-null summary ( obj -- str ) dup [ object>bytes malloc-byte-array/length ] [ 0 ] if ] } { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] } - [ - drop number>string* dup [ - utf8 malloc-string dup free-always - ] when 0 - ] + { DATE [ dup [ timestamp>ymd ] when default-param-value ] } + { TIME [ dup [ timestamp>hms ] when default-param-value ] } + { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] } + { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] } + [ drop default-param-value ] } case 2array ] 2map flip dup empty? [ drop f f diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index c9fd9a38a4..41b2d01b28 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -95,6 +95,6 @@ M: db ( tuple class -- statement ) " from " 0% 0% dupd - [ slot-name>> swap get-slot-named ] with subset + [ slot-name>> swap get-slot-named ] with filter dup empty? [ 2drop ] [ where-clause ] if ";" 0% ] query-make ; diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 4561424a9d..184c45f8b1 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -1,4 +1,4 @@ -USING: kernel parser quotations classes.tuple words +USING: kernel parser quotations classes.tuple words math.order namespaces.lib namespaces sequences arrays combinators prettyprint strings math.parser sequences.lib math symbols ; USE: tools.walker diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e5562700c9..9f29b9e6fb 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -33,7 +33,7 @@ IN: db.sqlite.lib : sqlite-prepare ( db sql -- handle ) dup length "void*" "void*" - [ sqlite3_prepare sqlite-check-result ] 2keep + [ sqlite3_prepare_v2 sqlite-check-result ] 2keep drop *void* ; : sqlite-bind-parameter-index ( handle name -- index ) @@ -97,10 +97,10 @@ IN: db.sqlite.lib { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { DATE [ sqlite-bind-text-by-name ] } - { TIME [ sqlite-bind-text-by-name ] } - { DATETIME [ sqlite-bind-text-by-name ] } - { TIMESTAMP [ sqlite-bind-text-by-name ] } + { DATE [ timestamp>ymd sqlite-bind-text-by-name ] } + { TIME [ timestamp>hms sqlite-bind-text-by-name ] } + { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] } + { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ object>bytes diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 32562a4ae8..066bf1ce96 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -40,7 +40,7 @@ SYMBOL: person4 [ 1 ] [ person1 get person-the-id ] unit-test - 200 person1 get set-person-the-number + [ ] [ 200 person1 get set-person-the-number ] unit-test [ ] [ person1 get update-tuple ] unit-test @@ -121,8 +121,16 @@ SYMBOL: person4 } define-persistent "billy" 10 3.14 f f f f f person1 set "johnny" 10 3.14 f f f f f person2 set - "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set - "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; + "teddy" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set + "eddie" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } + f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; : assigned-person-schema ( -- ) person "PERSON" @@ -139,8 +147,17 @@ SYMBOL: person4 } define-persistent 1 "billy" 10 3.14 f f f f f person1 set 2 "johnny" 10 3.14 f f f f f person2 set - 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set - 4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; + 3 "teddy" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } + f person3 set + 4 "eddie" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } + T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } + f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -363,3 +380,6 @@ TUPLE: does-not-persist ; \ delete-tuple must-infer \ select-tuple must-infer \ define-persistent must-infer +\ ensure-table must-infer +\ create-table must-infer +\ drop-table must-infer diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index fd4cfb906f..ce2236d23b 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -105,7 +105,7 @@ M: retryable execute-statement* ( statement type -- ) [ with-disposal ] curry each ] [ with-disposal - ] if ; + ] if ; inline : create-table ( class -- ) create-sql-statement [ execute-statement ] with-disposals ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 110a8a388a..887293ef94 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -83,13 +83,13 @@ FACTOR-BLOB NULL ; dup number? [ number>string ] when ; : maybe-remove-id ( specs -- obj ) - [ +native-id+? not ] subset ; + [ +native-id+? not ] filter ; : remove-relations ( specs -- newcolumns ) - [ relation? not ] subset ; + [ relation? not ] filter ; : remove-id ( specs -- obj ) - [ primary-key>> not ] subset ; + [ primary-key>> not ] filter ; ! SQLite Types: http://www.sqlite.org/datatype3.html ! NULL INTEGER REAL TEXT BLOB @@ -152,7 +152,7 @@ HOOK: bind# db ( spec obj -- ) tuck offset-of-slot set-slot ; : tuple>filled-slots ( tuple -- alist ) - [ nip ] assoc-subset ; + [ nip ] assoc-filter ; : tuple>params ( specs tuple -- obj ) [ diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 506d7175b6..0ae8592e66 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -23,7 +23,7 @@ IN: delegate : forget-old-definitions ( protocol new-wordlist -- ) >r users-and-words r> - diff forget-all-methods ; + swap diff forget-all-methods ; : define-protocol ( protocol wordlist -- ) ! 2dup forget-old-definitions diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 4fa4ed3c09..435a0aca55 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math models namespaces sequences strings -splitting combinators unicode.categories ; +splitting combinators unicode.categories math.order ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; @@ -184,10 +184,10 @@ M: one-char-elt next-elt 2drop ; [ >r blank? r> xor ] curry ; inline : (prev-word) ( ? col str -- col ) - rot break-detector find-last* drop ?1+ ; + rot break-detector find-last-from drop ?1+ ; : (next-word) ( ? col str -- col ) - [ rot break-detector find* drop ] keep + [ rot break-detector find-from drop ] keep over not [ nip length ] [ drop ] if ; TUPLE: one-word-elt ; diff --git a/extra/factory/commands/commands.factor b/extra/factory/commands/commands.factor index 5b0c575771..6bf5ee8d4f 100644 --- a/extra/factory/commands/commands.factor +++ b/extra/factory/commands/commands.factor @@ -35,7 +35,7 @@ pointer-window up-till-frame dup is? [ ] [ drop f ] if ; wm-root> <- children - [ <- mapped? ] subset + [ <- mapped? ] filter [ check-window-table ] map reverse @@ -64,7 +64,7 @@ drop ! wm-root> ! <- children -! [ <- mapped? ] subset +! [ <- mapped? ] filter ! [ check-window-table ] map ! reverse diff --git a/extra/factory/factory.factor b/extra/factory/factory.factor index ca534f12c1..6faf334fc3 100644 --- a/extra/factory/factory.factor +++ b/extra/factory/factory.factor @@ -13,7 +13,7 @@ IN: factory ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : manage-windows ( -- ) -dpy get $default-root <- children [ <- mapped? ] subset +dpy get $default-root <- children [ <- mapped? ] filter [ $id new* drop ] each ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 1022a02d7e..3cb17cf08b 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -16,7 +16,7 @@ TUPLE: q/a question answer ; C: q/a : li>q/a ( li -- q/a ) - [ "br" tag-named*? not ] subset + [ "br" tag-named*? not ] filter [ "strong" tag-named*? ] find-after >r tag-children r> ; @@ -39,7 +39,7 @@ C: question-list : xml>question-list ( list -- question-list ) [ "title" swap at ] keep - tag-children [ tag? ] subset [ xml>q/a ] map + tag-children [ tag? ] filter [ xml>q/a ] map ; : question-list>xml ( question-list -- list ) @@ -85,7 +85,7 @@ C: faq : toc, ( faq -- ) "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [ "strong" [ "The big questions" , ] tag, br, - faq-lists 1 tail dup length [ toc-link, ] 2each + faq-lists rest dup length [ toc-link, ] 2each ] tag*, ; : faq-sections, ( question-lists -- ) diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index 7621af6899..1b9e2dc82b 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -14,7 +14,7 @@ DEFER: (shallow-fry) : ((shallow-fry)) ( accum quot adder -- result ) >r [ ] swap (shallow-fry) r> append swap dup empty? [ drop ] [ - [ swap compose ] curry append + [ prepose ] curry append ] if ; inline : (shallow-fry) ( accum quot -- result ) @@ -51,7 +51,7 @@ DEFER: (shallow-fry) [ dup callable? [ [ - [ { , namespaces:, @ } member? ] subset length + [ { , namespaces:, @ } member? ] filter length \ , % ] [ deep-fry % ] bi diff --git a/extra/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor index d3b946afe9..55a1276dd4 100644 --- a/extra/gap-buffer/gap-buffer.factor +++ b/extra/gap-buffer/gap-buffer.factor @@ -4,7 +4,8 @@ ! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain ! for a good introduction see: ! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf -USING: kernel arrays sequences sequences.private circular math math.functions generic ; +USING: kernel arrays sequences sequences.private circular math +math.order math.functions generic ; IN: gap-buffer ! gap-start -- the first element of the gap diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 861894c8f4..611319e28b 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays byte-arrays combinators -graphics.viewer io io.binary io.files kernel libc math -math.functions namespaces opengl opengl.gl prettyprint +USING: alien arrays byte-arrays combinators inspector +io.backend graphics.viewer io io.binary io.files kernel libc +math math.functions namespaces opengl opengl.gl prettyprint sequences strings ui ui.gadgets.panes io.encodings.binary ; IN: graphics.bitmap @@ -25,10 +25,14 @@ TUPLE: bitmap magic size reserved offset header-length width { 1 [ "1bit" throw ] } } case ; +ERROR: bitmap-magic ; + +M: bitmap-magic summary + drop "First two bytes of bitmap stream must be 'BM'" ; + : parse-file-header ( bitmap -- ) - 2 read [ over set-bitmap-magic ] keep "BM" = [ - "BITMAPFILEHEADER: First two bytes must be BM" throw - ] unless + 2 read >string dup "BM" = [ bitmap-magic ] unless + over set-bitmap-magic 4 read le> over set-bitmap-size 4 read le> over set-bitmap-reserved 4 read le> swap set-bitmap-offset ; @@ -59,7 +63,7 @@ TUPLE: bitmap magic size reserved offset header-length width dup color-index-length read swap set-bitmap-color-index ; : load-bitmap ( path -- bitmap ) - binary [ + normalize-path binary [ T{ bitmap } clone dup parse-file-header dup parse-bitmap-header @@ -113,20 +117,18 @@ M: bitmap height ( bitmap -- ) bitmap-height ; : bitmap. ( path -- ) load-bitmap gadget. ; -: bitmap-window ( path -- ) - load-bitmap [ "bitmap" open-window ] keep ; +: bitmap-window ( path -- gadget ) + load-bitmap [ "bitmap" open-window ] keep ; : test-bitmap24 ( -- ) - "extra/graphics/bitmap/test-data/thiswayup24.bmp" resource-path bitmap. ; + "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; : test-bitmap8 ( -- ) - "extra/graphics/bitmap/test-data/rgb8bit.bmp" resource-path bitmap. ; + "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; : test-bitmap4 ( -- ) - "extra/graphics/bitmap/test-data/rgb4bit.bmp" resource-path - load-bitmap ; - ! bitmap. ; + "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; : test-bitmap1 ( -- ) - "extra/graphics/bitmap/test-data/1bit.bmp" resource-path bitmap. ; + "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; diff --git a/extra/hardware-info/linux/linux.factor b/extra/hardware-info/linux/linux.factor index de7b3f40a5..5d9ca6eaa7 100644 --- a/extra/hardware-info/linux/linux.factor +++ b/extra/hardware-info/linux/linux.factor @@ -7,7 +7,7 @@ IN: hardware-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep - "\0" split [ empty? not ] subset [ >string ] map + "\0" split [ empty? not ] filter [ >string ] map 6 "" pad-right ; : sysname ( -- string ) uname first ; @@ -18,4 +18,4 @@ IN: hardware-info.linux : domainname ( -- string ) uname 5 swap nth ; : kernel-version ( -- seq ) - release ".-" split [ ] subset 5 "" pad-right ; + release ".-" split [ ] filter 5 "" pad-right ; diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 10474c09f7..3162496974 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 words combinators vocabs.loader hardware-info.backend -system ; +system alien.strings ; IN: hardware-info.windows : system-info ( -- SYSTEM_INFO ) diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 9b21bf7fff..995b8540f5 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -111,7 +111,7 @@ $nl "You can create a new array, only containing elements which satisfy some condition:" { $example ": negative? ( n -- ? ) 0 < ;" - "{ -12 10 16 0 -1 -3 -9 } [ negative? ] subset ." + "{ -12 10 16 0 -1 -3 -9 } [ negative? ] filter ." "{ -12 -1 -3 -9 }" } { $references diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor index 0b17461a99..54ede93aa1 100644 --- a/extra/help/crossref/crossref.factor +++ b/extra/help/crossref/crossref.factor @@ -14,7 +14,7 @@ M: link uses collect-elements [ \ f or ] map ; : help-path ( topic -- seq ) - [ article-parent ] follow 1 tail ; + [ article-parent ] follow rest ; : set-article-parents ( parent article -- ) article-children [ set-article-parent ] with each ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 15e3b8be1d..7babaec7f6 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -228,13 +228,13 @@ ARTICLE: "article-index" "Article index" { $index [ articles get keys ] } ; ARTICLE: "primitive-index" "Primitive index" -{ $index [ all-words [ primitive? ] subset ] } ; +{ $index [ all-words [ primitive? ] filter ] } ; ARTICLE: "error-index" "Error index" { $index [ all-errors ] } ; ARTICLE: "type-index" "Type index" -{ $index [ builtins get [ ] subset ] } ; +{ $index [ builtins get [ ] filter ] } ; ARTICLE: "class-index" "Class index" { $index [ classes ] } ; diff --git a/extra/help/help.factor b/extra/help/help.factor index e0b2709932..2d56251392 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -29,7 +29,7 @@ M: predicate word-help* drop \ $predicate ; : all-articles ( -- seq ) articles get keys - all-words [ word-help ] subset append ; + all-words [ word-help ] filter append ; : xref-help ( -- ) all-articles [ xref-article ] each ; @@ -41,7 +41,7 @@ M: predicate word-help* drop \ $predicate ; [ dup article-title ] { } map>assoc sort-values keys ; : all-errors ( -- seq ) - all-words [ error? ] subset sort-articles ; + all-words [ error? ] filter sort-articles ; M: word article-name word-name ; @@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":vars - list all variables at error time" print ; : :help ( -- ) - error get delegates [ error-help ] map [ ] subset + error get delegates [ error-help ] map [ ] filter { { [ dup empty? ] [ (:help-none) ] } { [ dup length 1 = ] [ first help ] } diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 28af93f295..fc4b7f6f25 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -9,7 +9,7 @@ macros combinators.lib sequences.lib math sets ; IN: help.lint : check-example ( element -- ) - 1 tail [ + rest [ 1 head* "\n" join 1vector [ use [ clone ] change @@ -23,7 +23,7 @@ IN: help.lint : extract-values ( element -- seq ) \ $values swap elements dup empty? [ - first 1 tail [ first ] map prune natural-sort + first rest [ first ] map prune natural-sort ] unless ; : effect-values ( word -- seq ) @@ -59,7 +59,7 @@ IN: help.lint : check-see-also ( word element -- ) nip \ $see-also swap elements [ - 1 tail dup prune [ length ] bi@ assert= + rest dup prune [ length ] bi@ assert= ] each ; : vocab-exists? ( name -- ? ) @@ -75,7 +75,7 @@ IN: help.lint [ help ] with-string-writer drop ; : all-word-help ( words -- seq ) - [ word-help ] subset ; + [ word-help ] filter ; TUPLE: help-error topic ; @@ -131,7 +131,7 @@ M: help-error error. articles get keys "group-articles" set child-vocabs [ dup check-vocab ] { } map>assoc - [ nip empty? not ] assoc-subset + [ nip empty? not ] assoc-filter ] with-scope ; : typos. ( assoc -- ) @@ -150,12 +150,12 @@ M: help-error error. : help-lint-all ( -- ) "" help-lint ; : unlinked-words ( words -- seq ) - all-word-help [ article-parent not ] subset ; + all-word-help [ article-parent not ] filter ; : linked-undocumented-words ( -- seq ) all-words - [ word-help not ] subset - [ article-parent ] subset - [ "predicating" word-prop not ] subset ; + [ word-help not ] filter + [ article-parent ] filter + [ "predicating" word-prop not ] filter ; MAIN: help-lint diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 2e2b34ebfd..378dd1e2fe 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -311,7 +311,7 @@ M: array elements* [ swap [ elements [ - 1 tail [ dup set ] each + rest [ dup set ] each ] each ] curry each ] H{ } make-assoc keys ; diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor index f01840d927..fffcda69b6 100755 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -123,8 +123,8 @@ $nl { $code "\"A man, a plan, a canal: Panama.\"" } "Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:" { $code "[ Letter? ]" } -"Finally, pass the string and the quotation to the " { $link subset } " word:" -{ $code "subset" } +"Finally, pass the string and the quotation to the " { $link filter } " word:" +{ $code "filter" } "Now the stack should contain the following string:" { "\"AmanaplanacanalPanama\"" } "This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as ``to'':" @@ -132,9 +132,9 @@ $nl "Finally, let's print the top of the stack and discard it:" { $code "." } "This will output " { $snippet "amanaplanacanalpanama" } ". This string is in the form that we want, and we evaluated the following code to get it into this form:" -{ $code "[ Letter? ] subset >lower" } +{ $code "[ Letter? ] filter >lower" } "This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":" -{ $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" } +{ $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" } "You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." $nl "We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:" diff --git a/extra/html/html.factor b/extra/html/html.factor index 5c82b7f038..f0ae424760 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: generic assocs help http io io.styles io.files continuations -io.streams.string kernel math math.parser namespaces +io.streams.string kernel math math.order math.parser namespaces quotations assocs sequences strings words html.elements xml.entities sbufs continuations ; IN: html diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 1a60390f64..160b95ab1d 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -11,7 +11,7 @@ IN: html.parser.analyzer (find-relative) ; : (find-all) ( n seq quot -- ) - 2dup >r >r find* [ + 2dup >r >r find-from [ dupd 2array , 1+ r> r> (find-all) ] [ r> r> 3drop @@ -21,7 +21,7 @@ IN: html.parser.analyzer [ 0 -rot (find-all) ] { } make ; : (find-nth) ( offset seq quot n count -- obj ) - >r >r [ find* ] 2keep 4 npick [ + >r >r [ find-from ] 2keep 4 npick [ r> r> 1+ 2dup <= [ 4drop ] [ @@ -46,7 +46,7 @@ IN: html.parser.analyzer ] [ drop t ] if - ] subset ; + ] filter ; : trim-text ( vector -- vector' ) [ @@ -57,14 +57,14 @@ IN: html.parser.analyzer ] map ; : find-by-id ( id vector -- vector ) - [ tag-attributes "id" swap at = ] with subset ; + [ tag-attributes "id" swap at = ] with filter ; : find-by-class ( id vector -- vector ) - [ tag-attributes "class" swap at = ] with subset ; + [ tag-attributes "class" swap at = ] with filter ; : find-by-name ( str vector -- vector ) >r >lower r> - [ tag-name = ] with subset ; + [ tag-name = ] with filter ; : find-first-name ( str vector -- i/f tag/f ) >r >lower r> @@ -76,13 +76,13 @@ IN: html.parser.analyzer : find-by-attribute-key ( key vector -- vector ) >r >lower r> - [ tag-attributes at ] with subset - [ ] subset ; + [ tag-attributes at ] with filter + [ ] filter ; : find-by-attribute-key-value ( value key vector -- vector ) >r >lower r> - [ tag-attributes at over = ] with subset nip - [ ] subset ; + [ tag-attributes at over = ] with filter nip + [ ] filter ; : find-first-attribute-key-value ( value key vector -- i/f tag/f ) >r >lower r> @@ -99,7 +99,7 @@ IN: html.parser.analyzer : find-between ( i/f tag/f vector -- vector ) find-between* dup length 3 >= [ - [ 1 tail-slice 1 head-slice* ] keep like + [ rest-slice 1 head-slice* ] keep like ] when ; : find-between-first ( string vector -- vector' ) @@ -109,12 +109,12 @@ IN: html.parser.analyzer tag-attributes [ "href" swap at ] [ f ] if* ; : find-links ( vector -- vector ) - [ tag-name "a" = ] subset - [ tag-link ] subset ; + [ tag-name "a" = ] filter + [ tag-link ] filter ; : find-by-text ( seq quot -- tag ) - [ dup tag-name text = ] swap compose find drop ; + [ dup tag-name text = ] prepose find drop ; : find-opening-tags-by-name ( name seq -- seq ) [ [ tag-name = ] keep tag-closing? not and ] with find-all ; @@ -125,11 +125,11 @@ IN: html.parser.analyzer : query>assoc* ( str -- hash ) "?" split1 nip query>assoc ; -! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map +! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] filter [ "=" split peek ] map ! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text ! "a" over find-opening-tags-by-name -! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset +! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-filter ! first first 8 + over nth ! tag-attributes "href" swap at query>assoc* ! "lat" over at "lon" rot at diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index b574799b38..0ae75e41fd 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -36,7 +36,7 @@ IN: html.parser.utils dup quoted? [ quote ] unless ; : unquote ( str -- newstr ) - dup quoted? [ 1 head-slice* 1 tail-slice >string ] when ; + dup quoted? [ 1 head-slice* rest-slice >string ] when ; : quote? ( ch -- ? ) "'\"" member? ; diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index cc356ca8e3..7762b01843 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting calendar continuations accessors vectors +splitting calendar continuations accessors vectors math.order io.encodings.8-bit io.encodings.binary fry debugger inspector ; IN: http.client diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 3a50630335..e624f56573 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,6 +1,6 @@ USING: http tools.test multiline tuple-syntax io.streams.string kernel arrays splitting sequences -assocs io.sockets ; +assocs io.sockets db db.sqlite ; IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test @@ -133,21 +133,32 @@ read-response-test-1' 1array [ ] unit-test ! Live-fire exercise -USING: http.server http.server.static http.server.actions -http.client io.server io.files io accessors namespaces threads -io.encodings.ascii ; +USING: http.server http.server.static http.server.sessions +http.server.sessions.storage.db http.server.actions +http.server.auth.login http.server.db http.client +io.server io.files io io.encodings.ascii +accessors namespaces threads ; + +: add-quit-action + + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display + "quit" add-responder ; + +: test-db "test.db" temp-file sqlite-db ; + +test-db [ + init-sessions-table +] with-db [ ] [ [ - - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display - "quit" add-responder + add-quit-action "extra/http/test" resource-path >>default "nested" add-responder - [ "redirect-loop" f ] >>display + [ "redirect-loop" f ] >>display "redirect-loop" add-responder main-responder set @@ -176,3 +187,57 @@ io.encodings.ascii ; [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +! Dispatcher bugs +[ ] [ + [ + + + + + sessions-in-db >>sessions + "" add-responder + add-quit-action + + "a" add-main-responder + "d" add-responder + test-db + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 1000 sleep ] unit-test + +: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; + +! This should give a 404 not an infinite redirect loop +[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with + +! This should give a 404 not an infinite redirect loop +[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +[ ] [ + [ + + [ "text/plain" [ "Hi" write ] >>body ] >>display + + + sessions-in-db >>sessions + "" add-responder + add-quit-action + test-db + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 1000 sleep ] unit-test + +[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 3e81fccd24..3402b42ca7 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -135,11 +135,12 @@ IN: http ] { } assoc>map "&" join ; -TUPLE: cookie name value path domain expires http-only ; +TUPLE: cookie name value path domain expires max-age http-only ; : ( value name -- cookie ) cookie new - swap >>name swap >>value ; + swap >>name + swap >>value ; : parse-cookies ( string -- seq ) [ @@ -147,7 +148,8 @@ TUPLE: cookie name value path domain expires http-only ; ";" split [ [ blank? ] trim "=" split1 swap >lower { - { "expires" [ >>expires ] } + { "expires" [ cookie-string>timestamp >>expires ] } + { "max-age" [ string>number seconds >>max-age ] } { "domain" [ >>domain ] } { "path" [ >>path ] } { "httponly" [ drop t >>http-only ] } @@ -163,7 +165,14 @@ TUPLE: cookie name value path domain expires http-only ; { { f [ drop ] } { t [ , ] } - [ "=" swap 3append , ] + [ + { + { [ dup timestamp? ] [ timestamp>cookie-string ] } + { [ dup duration? ] [ dt>seconds number>string ] } + [ ] + } cond + "=" swap 3append , + ] } case ; : unparse-cookie ( cookie -- strings ) @@ -172,6 +181,7 @@ TUPLE: cookie name value path domain expires http-only ; "path" over path>> (unparse-cookie) "domain" over domain>> (unparse-cookie) "expires" over expires>> (unparse-cookie) + "max-age" over max-age>> (unparse-cookie) "httponly" over http-only>> (unparse-cookie) drop ] { } make ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 90e632d7f5..5aa761603f 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,7 +1,7 @@ -IN: http.server.actions.tests USING: http.server.actions http.server.validators tools.test math math.parser multiline namespaces http io.streams.string http.server sequences splitting accessors ; +IN: http.server.actions.tests [ "a" [ v-number ] { { "a" "123" } } validate-param @@ -22,30 +22,9 @@ blah ; [ 25 ] [ + init-request action-request-test-1 lf>crlf [ read-request ] with-string-reader request set - "/blah" - "action-1" get call-responder -] unit-test - - - [ +append-path get "xxx" get "X" concat append ] >>submit - { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params -"action-2" set - -STRING: action-request-test-2 -POST http://foo/bar/baz HTTP/1.1 -content-length: 5 -content-type: application/x-www-form-urlencoded - -xxx=4 -; - -[ "/blahXXXX" ] [ - action-request-test-2 lf>crlf - [ read-request ] with-string-reader - request set - "/blah" - "action-2" get call-responder + { } "action-1" get call-responder ] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 2b2aaea6a8..6e1aac9627 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces fry continuations locals ; IN: http.server.actions -SYMBOL: +append-path +SYMBOL: +path+ SYMBOL: params @@ -37,14 +37,20 @@ TUPLE: action init display submit get-params post-params ; : validation-failed ( -- * ) action get display>> call exit-with ; -M: action call-responder ( path action -- response ) +M: action call-responder* ( path action -- response ) '[ - , , - [ +append-path associate request-params assoc-union params set ] - [ action set ] bi* - request get method>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case + , [ CHAR: / = ] right-trim empty? [ + , action set + request get + [ request-params params set ] + [ + method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] bi + ] [ + <404> + ] if ] with-exit-continuation ; diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor index 69a3c76c2b..6b5a426102 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/http/server/auth/auth.factor @@ -1,7 +1,9 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: http.server.sessions accessors -http.server.auth.providers assocs namespaces kernel ; +USING: accessors assocs namespaces kernel +http.server +http.server.sessions +http.server.auth.providers ; IN: http.server.auth SYMBOL: logged-in-user @@ -11,6 +13,12 @@ GENERIC: init-user-profile ( responder -- ) M: object init-user-profile drop ; +M: dispatcher init-user-profile + default>> init-user-profile ; + +M: filter-responder init-user-profile + responder>> init-user-profile ; + : uid ( -- string ) logged-in-user sget username>> ; : profile ( -- assoc ) logged-in-user sget profile>> ; diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor index 04c0e62d07..daf6e30eae 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/http/server/auth/basic/basic.factor @@ -6,7 +6,7 @@ http.server.auth.providers http.server.auth.providers.null http sequences ; IN: http.server.auth.basic -TUPLE: basic-auth responder realm provider ; +TUPLE: basic-auth < filter-responder realm provider ; C: basic-auth @@ -36,6 +36,6 @@ C: basic-auth : logged-in? ( request responder -- ? ) provider>> swap "authorization" header authorization-ok? ; -M: basic-auth call-responder ( request path responder -- response ) +M: basic-auth call-responder* ( request path responder -- response ) pick over logged-in? - [ responder>> call-responder ] [ 2nip realm>> <401> ] if ; + [ call-next-method ] [ 2nip realm>> <401> ] if ; diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml index 86a4e86551..c19b18c947 100644 --- a/extra/http/server/auth/login/edit-profile.xml +++ b/extra/http/server/auth/login/edit-profile.xml @@ -4,18 +4,18 @@ Edit Profile - + - + - + @@ -25,7 +25,7 @@ - + @@ -35,12 +35,12 @@ - + - + @@ -50,7 +50,7 @@ - + @@ -63,11 +63,11 @@

- + invalid password - + passwords do not match

diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 7593f217f7..716996dc5a 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -13,6 +13,7 @@ http.server.auth.providers http.server.auth.providers.null http.server.actions http.server.components +http.server.flows http.server.forms http.server.sessions http.server.boilerplate @@ -22,7 +23,6 @@ http.server.validators ; IN: http.server.auth.login QUALIFIED: smtp -SYMBOL: post-login-url SYMBOL: login-failed? TUPLE: login < dispatcher users ; @@ -60,8 +60,7 @@ M: user-saver dispose : successful-login ( user -- response ) logged-in-user sset - post-login-url sget "" or f - f post-login-url sset ; + "$login" end-flow ; :: ( -- action ) [let | form [ ] | @@ -139,7 +138,7 @@ SYMBOL: user-exists? successful-login - login get default>> responder>> init-user-profile + login get init-user-profile ] >>submit ] ; @@ -155,17 +154,17 @@ SYMBOL: user-exists? "verify-password" add-field "email" add-field ; -SYMBOL: previous-page - :: ( -- action ) [let | form [ ] | [ blank-values + logged-in-user sget - dup username>> "username" set-value - dup realname>> "realname" set-value - dup email>> "email" set-value + [ username>> "username" set-value ] + [ realname>> "realname" set-value ] + [ email>> "email" set-value ] + tri ] >>init [ form edit-form ] >>display @@ -178,7 +177,8 @@ SYMBOL: previous-page logged-in-user sget - "password" value empty? [ + { "password" "new-password" "verify-password" } + [ value empty? ] all? [ same-password-twice "password" value uid users check-login @@ -190,9 +190,11 @@ SYMBOL: previous-page "realname" value >>realname "email" value >>email + drop + user-profile-changed? on - previous-page sget f + "$login" end-flow ] >>submit ] ; @@ -329,31 +331,28 @@ SYMBOL: lost-password-from [ f logged-in-user sset - "login" f + "$login/login" end-flow ] >>submit ; ! ! ! Authentication logic -TUPLE: protected responder ; +TUPLE: protected < filter-responder ; C: protected : show-login-page ( -- response ) - request get request-url post-login-url sset - "login" f ; + begin-flow + "$login/login" f ; -M: protected call-responder ( path responder -- response ) +M: protected call-responder* ( path responder -- response ) logged-in-user sget dup [ save-user-after - request get request-url previous-page sset - responder>> call-responder + call-next-method ] [ - 3drop - request get method>> { "GET" "HEAD" } member? - [ show-login-page ] [ <400> ] if + 3drop show-login-page ] if ; -M: login call-responder ( path responder -- response ) +M: login call-responder* ( path responder -- response ) dup login set call-next-method ; diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml index 2f16c09d8d..0524d0889f 100644 --- a/extra/http/server/auth/login/login.xml +++ b/extra/http/server/auth/login/login.xml @@ -4,18 +4,18 @@ Login - +
User name:
Real name:
Current password:
New password:
Verify:
E-mail:
- + - +
User name:
Password:
@@ -24,7 +24,7 @@ - + invalid username or password

@@ -33,11 +33,11 @@

- Register + Register | - Recover Password + Recover Password

diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/http/server/auth/login/recover-1.xml index dd3a60f1d1..7c72181c10 100644 --- a/extra/http/server/auth/login/recover-1.xml +++ b/extra/http/server/auth/login/recover-1.xml @@ -6,23 +6,23 @@

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

- + - + - + - + diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml index 115c2cea21..61ef0aef86 100644 --- a/extra/http/server/auth/login/recover-3.xml +++ b/extra/http/server/auth/login/recover-3.xml @@ -6,21 +6,21 @@

Choose a new password for your account.

- +
User name:
E-mail:
Captcha:
- - + + - + - + @@ -33,7 +33,7 @@

- + passwords do not match

diff --git a/extra/http/server/auth/login/recover-4.xml b/extra/http/server/auth/login/recover-4.xml index 3c10869fbd..f5d02fa858 100755 --- a/extra/http/server/auth/login/recover-4.xml +++ b/extra/http/server/auth/login/recover-4.xml @@ -4,6 +4,6 @@ Recover lost password: step 4 of 4 -

Your password has been reset. You may now log in.

+

Your password has been reset. You may now log in.

diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml index 1bacf71801..19917002b5 100644 --- a/extra/http/server/auth/login/register.xml +++ b/extra/http/server/auth/login/register.xml @@ -4,18 +4,18 @@ New User Registration - +
Password:
Verify password:
- + - + @@ -25,12 +25,12 @@ - + - + @@ -40,7 +40,7 @@ - + @@ -50,7 +50,7 @@ - + @@ -64,11 +64,11 @@ - + username taken - + passwords do not match diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index eabcefeb7f..1dc5effbe2 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -5,10 +5,11 @@ io io.streams.string arrays html.elements http http.server +http.server.sessions http.server.templating ; IN: http.server.boilerplate -TUPLE: boilerplate responder template ; +TUPLE: boilerplate < filter-responder template ; : f boilerplate boa ; @@ -67,8 +68,8 @@ M: f call-template* drop call-next-template ; bi* ] with-scope ; inline -M: boilerplate call-responder - tuck responder>> call-responder +M: boilerplate call-responder* + tuck call-next-method dup "content-type" header "text/html" = [ clone swap template>> [ [ with-boilerplate ] 2curry ] curry change-body diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor index 4cad097cf5..cca5942328 100755 --- a/extra/http/server/callbacks/callbacks-tests.factor +++ b/extra/http/server/callbacks/callbacks-tests.factor @@ -5,10 +5,12 @@ splitting kernel hashtables continuations ; [ 123 ] [ [ + init-request + "GET" >>method request set [ exit-continuation set - "xxx" + { } [ [ "hello" print 123 ] show-final ] >>display call-responder @@ -17,6 +19,8 @@ splitting kernel hashtables continuations ; ] unit-test [ + init-request + [ [ "hello" print @@ -31,7 +35,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set "GET" >>method request set - "" "r" get call-responder + { } "r" get call-responder ] callcc1 body>> first @@ -44,7 +48,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set - "/" + { } "r" get call-responder ] callcc1 @@ -57,7 +61,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set - "/" + { } "r" get call-responder ] callcc1 ] unit-test diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index 42213d015f..5325ee3b55 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -96,7 +96,7 @@ SYMBOL: current-show : resuming-callback ( responder request -- id ) cont-id query-param swap callbacks>> at ; -M: callback-responder call-responder ( path responder -- response ) +M: callback-responder call-responder* ( path responder -- response ) '[ , , diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor new file mode 100644 index 0000000000..90b70c7bcc --- /dev/null +++ b/extra/http/server/components/code/code.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: splitting kernel io sequences xmode.code2html accessors +http.server.components ; +IN: http.server.components.code + +TUPLE: code-renderer < text-renderer mode ; + +: ( mode -- renderer ) + code-renderer new-text-renderer + swap >>mode ; + +M: code-renderer render-view* + [ string-lines ] [ mode>> value ] bi* htmlize-lines ; + +: ( id mode -- component ) + swap + swap >>renderer ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 331231dfb3..f0e7955947 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -336,3 +336,26 @@ TUPLE: list < component ; list swap new-component ; M: list component-string drop ; + +! Choice +TUPLE: choice-renderer choices ; + +C: choice-renderer + +M: choice-renderer render-view* + drop write ; + +M: choice-renderer render-edit* + ; + +TUPLE: choice < string ; + +: ( id choices -- component ) + swap choice new-string + swap >>renderer ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor index 65de881adb..90af25df5b 100755 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -18,7 +18,7 @@ IN: http.server.crud [ form view-form ] >>display ; : ( id next -- response ) - swap number>string "id" associate ; + swap number>string "id" associate ; :: ( form ctor next -- action ) @@ -53,7 +53,7 @@ IN: http.server.crud [ "id" get ctor call delete-tuple - next f + next f ] >>submit ; :: ( form ctor -- action ) diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index a8b929bc98..047af3f4ac 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db http.server kernel accessors +USING: db http.server http.server.sessions kernel accessors continuations namespaces destructors ; IN: http.server.db -TUPLE: db-persistence responder db params ; +TUPLE: db-persistence < filter-responder db params ; C: db-persistence @@ -12,5 +12,5 @@ C: db-persistence [ db>> ] [ params>> ] bi make-db db-open [ db set ] [ add-always-destructor ] bi ; -M: db-persistence call-responder - [ connect-db ] [ responder>> call-responder ] bi ; +M: db-persistence call-responder* + [ connect-db ] [ call-next-method ] bi ; diff --git a/extra/http/server/flows/flows.factor b/extra/http/server/flows/flows.factor new file mode 100644 index 0000000000..7a9b362111 --- /dev/null +++ b/extra/http/server/flows/flows.factor @@ -0,0 +1,64 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors namespaces sequences arrays kernel +assocs assocs.lib hashtables math.parser +html.elements http http.server http.server.sessions ; +IN: http.server.flows + +TUPLE: flows < filter-responder ; + +C: flows + +: begin-flow* ( -- id ) + request get + [ path>> ] [ request-params ] [ method>> ] tri 3array + flows sget set-at-unique + session-changed ; + +: end-flow-post ( path params -- response ) + request [ + clone + "POST" >>method + swap >>post-data + swap >>path + ] change + request get path>> split-path + flows get responder>> call-responder ; + +: end-flow* ( default id -- response ) + flows sget at + [ first3 "POST" = [ end-flow-post ] [ ] if ] + [ f ] ?if ; + +SYMBOL: flow-id + +: flow-id-key "factorflowid" ; + +: begin-flow ( -- ) + begin-flow* flow-id set ; + +: end-flow ( default -- response ) + flow-id get end-flow* ; + +: add-flow-id ( query -- query' ) + flow-id get [ flow-id-key associate assoc-union ] when* ; + +: flow-form-field ( -- ) + flow-id get [ + + ] when* ; + +M: flows call-responder* + dup flows set + [ add-flow-id ] add-link-hook + [ flow-form-field ] add-form-hook + flow-id-key request get request-params at flow-id set + call-next-method ; + +M: flows init-session* + H{ } clone flows sset + call-next-method ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 346a31f30f..a5dffbc58b 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,7 +1,9 @@ USING: http.server tools.test kernel namespaces accessors -io http math sequences assocs ; +io http math sequences assocs arrays classes words ; IN: http.server.tests +\ find-responder must-infer + [ "www.apple.com" >>host @@ -9,6 +11,8 @@ IN: http.server.tests { { "a" "b" } } >>query request set + [ ] link-hook set + [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test @@ -23,13 +27,15 @@ TUPLE: mock-responder path ; C: mock-responder -M: mock-responder call-responder +M: mock-responder call-responder* nip path>> on "text/plain" ; : check-dispatch ( tag path -- ? ) + H{ } clone base-paths set over off + split-path main-responder get call-responder write-response get ; @@ -44,11 +50,11 @@ M: mock-responder call-responder main-responder set [ "foo" ] [ - "foo" main-responder get find-responder path>> nip + { "foo" } main-responder get find-responder path>> nip ] unit-test [ "bar" ] [ - "bar" main-responder get find-responder path>> nip + { "bar" } main-responder get find-responder path>> nip ] unit-test [ t ] [ "foo" "foo" check-dispatch ] unit-test @@ -60,14 +66,6 @@ M: mock-responder call-responder [ t ] [ "123" "baz/123" check-dispatch ] unit-test [ t ] [ "123" "baz///123" check-dispatch ] unit-test - [ t ] [ - - "baz" >>path - request set - "baz" main-responder get call-responder - dup code>> 300 399 between? >r - header>> "location" swap at "baz/" tail? r> and - ] unit-test ] with-scope [ @@ -77,3 +75,67 @@ M: mock-responder call-responder [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test ] with-scope + +! Make sure path for default responder isn't chopped +TUPLE: path-check-responder ; + +C: path-check-responder + +M: path-check-responder call-responder* + drop + "text/plain" swap >array >>body ; + +[ { "c" } ] [ + H{ } clone base-paths set + + { "b" "c" } + + + >>default + "b" add-responder + call-responder + body>> +] unit-test + +! Test that "" dispatcher works with default>> +[ ] [ + + "" "" add-responder + "bar" "bar" add-responder + "baz" >>default + main-responder set + + [ t ] [ "" "" check-dispatch ] unit-test + [ f ] [ "" "quux" check-dispatch ] unit-test + [ t ] [ "baz" "quux" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "baz" "xxx" check-dispatch ] unit-test +] unit-test + +TUPLE: funny-dispatcher < dispatcher ; + +: funny-dispatcher new-dispatcher ; + +TUPLE: base-path-check-responder ; + +C: base-path-check-responder + +M: base-path-check-responder call-responder* + 2drop + "$funny-dispatcher" resolve-base-path + "text/plain" swap >>body ; + +[ ] [ + + + + "c" add-responder + "b" add-responder + "a" add-responder + main-responder set +] unit-test + +[ "/a/b/" ] [ + "a/b/c" split-path main-responder get call-responder body>> +] unit-test diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index d3bd6c6bbe..ad04812c63 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,13 +4,15 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar html.elements accessors math.parser combinators.lib tools.vocabs debugger html continuations random combinators -destructors io.encodings.8-bit fry ; +destructors io.encodings.8-bit fry classes words ; IN: http.server -GENERIC: call-responder ( path responder -- response ) +! path is a sequence of path component strings -: request-params ( -- assoc ) - request get dup method>> { +GENERIC: call-responder* ( path responder -- response ) + +: request-params ( request -- assoc ) + dup method>> { { "GET" [ query>> ] } { "HEAD" [ query>> ] } { "POST" [ post-data>> ] } @@ -26,7 +28,7 @@ TUPLE: trivial-responder response ; C: trivial-responder -M: trivial-responder call-responder nip response>> call ; +M: trivial-responder call-responder* nip response>> call ; : trivial-response-body ( code message -- ) @@ -52,27 +54,63 @@ SYMBOL: 404-responder [ <404> ] 404-responder set-global +SYMBOL: base-paths + +: invert-slice ( slice -- slice' ) + dup slice? [ + [ seq>> ] [ from>> ] bi head-slice + ] [ + drop { } + ] if ; + +: add-base-path ( path dispatcher -- ) + [ invert-slice ] [ class word-name ] bi* + base-paths get set-at ; + +: call-responder ( path responder -- response ) + [ add-base-path ] [ call-responder* ] 2bi ; + SYMBOL: link-hook +: add-link-hook ( quot -- ) + link-hook [ compose ] change ; inline + : modify-query ( query -- query ) - link-hook get [ ] or call ; + link-hook get call ; + +: base-path ( string -- path ) + dup base-paths get at + [ ] [ "No such responder: " swap append throw ] ?if ; + +: resolve-base-path ( string -- string' ) + "$" ?head [ + [ + "/" split1 >r + base-path [ "/" % % ] each "/" % + r> % + ] "" make + ] when ; : link>string ( url query -- url' ) - modify-query (link>string) ; + [ resolve-base-path ] [ modify-query ] bi* (link>string) ; : write-link ( url query -- ) link>string write ; SYMBOL: form-hook +: add-form-hook ( quot -- ) + form-hook [ compose ] change ; + : hidden-form-field ( -- ) - form-hook get [ ] or call ; + form-hook get call ; : absolute-redirect ( to query -- url ) #! Same host. request get clone - swap [ >>query ] when* - swap url-encode >>path + swap [ >>query ] when* + swap url-encode >>path + [ modify-query ] change-query request-url ; : replace-last-component ( path with -- path' ) @@ -82,13 +120,14 @@ SYMBOL: form-hook request get clone swap [ >>query ] when* swap [ '[ , replace-last-component ] change-path ] when* - dup query>> modify-query >>query + [ modify-query ] change-query request-url ; : derive-url ( to query -- url ) { { [ over "http://" head? ] [ link>string ] } { [ over "/" head? ] [ absolute-redirect ] } + { [ over "$" head? ] [ >r resolve-base-path r> derive-url ] } [ relative-redirect ] } cond ; @@ -103,6 +142,10 @@ SYMBOL: form-hook : ( to query -- response ) 307 "Temporary Redirect" ; +: ( to query -- response ) + request get method>> "POST" = + [ ] [ ] if ; + TUPLE: dispatcher default responders ; : new-dispatcher ( class -- dispatcher ) @@ -113,23 +156,18 @@ TUPLE: dispatcher default responders ; : ( -- dispatcher ) dispatcher new-dispatcher ; -: split-path ( path -- rest first ) - [ CHAR: / = ] left-trim "/" split1 swap ; - : find-responder ( path dispatcher -- path responder ) - over split-path pick responders>> at* - [ >r >r 2drop r> r> ] [ 2drop default>> ] if ; - -: redirect-with-/ ( -- response ) - request get path>> "/" append f ; - -M: dispatcher call-responder ( path dispatcher -- response ) - over [ - find-responder call-responder + over empty? [ + "" over responders>> at* + [ nip ] [ drop default>> ] if ] [ - 2drop redirect-with-/ + over first over responders>> at* + [ >r drop rest-slice r> ] [ drop default>> ] if ] if ; +M: dispatcher call-responder* ( path dispatcher -- response ) + find-responder call-responder ; + TUPLE: vhost-dispatcher default responders ; : ( -- dispatcher ) @@ -139,18 +177,21 @@ TUPLE: vhost-dispatcher default responders ; request get host>> over responders>> at* [ nip ] [ drop default>> ] if ; -M: vhost-dispatcher call-responder ( path dispatcher -- response ) +M: vhost-dispatcher call-responder* ( path dispatcher -- response ) find-vhost call-responder ; -: set-main ( dispatcher name -- dispatcher ) - '[ , f ] - >>default ; - : add-responder ( dispatcher responder path -- dispatcher ) pick responders>> set-at ; : add-main-responder ( dispatcher responder path -- dispatcher ) - [ add-responder ] keep set-main ; + [ add-responder drop ] + [ drop "" add-responder drop ] + [ 2drop ] 3tri ; + +TUPLE: filter-responder responder ; + +M: filter-responder call-responder* + responder>> call-responder ; SYMBOL: main-responder @@ -197,11 +238,20 @@ SYMBOL: exit-continuation : with-exit-continuation ( quot -- ) '[ exit-continuation set @ ] callcc1 exit-continuation off ; +: split-path ( string -- path ) + "/" split [ empty? not ] filter ; + +: init-request ( -- ) + H{ } clone base-paths set + [ ] link-hook set + [ ] form-hook set ; + : do-request ( request -- response ) [ - [ log-request ] + init-request [ request set ] - [ path>> main-responder get call-responder ] tri + [ log-request ] + [ path>> split-path main-responder get call-responder ] tri [ <404> ] unless* ] [ [ \ do-request log-error ] diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 26e6927d7c..c95ff30069 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -1,12 +1,17 @@ IN: http.server.sessions.tests USING: tools.test http http.server.sessions -http.server.sessions.storage http.server.sessions.storage.assoc +http.server.sessions.storage http.server.sessions.storage.db http.server.actions http.server math namespaces kernel accessors -prettyprint io.streams.string splitting destructors sequences ; +prettyprint io.streams.string io.files splitting destructors +sequences db db.sqlite continuations ; -[ H{ } ] [ H{ } add-session-id ] unit-test - -: with-session \ session swap with-variable ; inline +: with-session + [ + >r + [ session-manager get swap save-session-after ] + [ \ session set ] bi + r> call + ] with-destructors ; inline TUPLE: foo ; @@ -14,61 +19,11 @@ C: foo M: foo init-session* drop 0 "x" sset ; -M: foo call-responder +M: foo call-responder* 2drop "x" [ 1+ ] schange "text/html" [ "x" sget pprint ] >>body ; -[ - "123" session-id set - H{ } clone session set - session-changed? off - - [ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test - - [ ] [ 3 "x" sset ] unit-test - - [ 9 ] [ "x" sget sq ] unit-test - - [ ] [ "x" [ 1- ] schange ] unit-test - - [ 4 ] [ "x" sget sq ] unit-test - - [ t ] [ session-changed? get ] unit-test -] with-scope - -[ t ] [ f url-sessions? ] unit-test -[ t ] [ f cookie-sessions? ] unit-test - -[ ] [ - - >>sessions - "manager" set -] unit-test - -[ { 5 0 } ] [ - [ - "manager" get begin-session drop - dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session - dup "manager" get sessions>> get-session [ "a" sget , ] with-session - dup "manager" get sessions>> get-session [ "x" sget , ] with-session - "manager" get sessions>> get-session - "manager" get sessions>> delete-session - ] { } make -] unit-test - -[ ] [ - - "GET" >>method - request set - "/etc" "manager" get call-responder - response set -] unit-test - -[ 307 ] [ response get code>> ] unit-test - -[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test - : url-responder-mock-test [ @@ -76,70 +31,125 @@ M: foo call-responder "id" get session-id-key set-query-param "/" >>path request set - "/" "manager" get call-responder + { } session-manager get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; -[ "1" ] [ url-responder-mock-test ] unit-test -[ "2" ] [ url-responder-mock-test ] unit-test -[ "3" ] [ url-responder-mock-test ] unit-test -[ "4" ] [ url-responder-mock-test ] unit-test - -[ ] [ - - >>sessions - "manager" set -] unit-test - -[ - - "GET" >>method - "/" >>path - request set - "/etc" "manager" get call-responder response set - [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test - response get -] with-destructors -response set - -[ ] [ response get cookies>> "cookies" set ] unit-test - -: cookie-responder-mock-test +: session-manager-mock-test [ "GET" >>method "cookies" get >>cookies "/" >>path request set - "/" "manager" get call-responder + { } session-manager get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; -[ "2" ] [ cookie-responder-mock-test ] unit-test -[ "3" ] [ cookie-responder-mock-test ] unit-test -[ "4" ] [ cookie-responder-mock-test ] unit-test - : [ "text/plain" exit-with ] >>display ; -[ - [ ] [ - - "GET" >>method - "id" get session-id-key set-query-param - "/" >>path - request set +[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors - [ - "/" - call-responder - ] with-destructors response set +"auth-test.db" temp-file sqlite-db [ + + init-request + init-sessions-table + + [ ] [ + + sessions-in-db >>sessions + session-manager set ] unit-test - [ "text/plain" ] [ response get "content-type" header ] unit-test + [ + empty-session + 123 >>id session set - [ f ] [ response get cookies>> empty? ] unit-test -] with-scope + [ ] [ 3 "x" sset ] unit-test + + [ 9 ] [ "x" sget sq ] unit-test + + [ ] [ "x" [ 1- ] schange ] unit-test + + [ 4 ] [ "x" sget sq ] unit-test + + [ t ] [ session get changed?>> ] unit-test + ] with-scope + + [ t ] [ + session-manager get begin-session id>> + session-manager get sessions>> get-session session? + ] unit-test + + [ { 5 0 } ] [ + [ + session-manager get begin-session + dup [ 5 "a" sset ] with-session + dup [ "a" sget , ] with-session + dup [ "x" sget , ] with-session + id>> session-manager get sessions>> delete-session + ] { } make + ] unit-test + + [ 0 ] [ + session-manager get begin-session id>> + session-manager get sessions>> get-session [ "x" sget ] with-session + ] unit-test + + [ { 5 0 } ] [ + [ + session-manager get begin-session id>> + dup session-manager get sessions>> get-session [ 5 "a" sset ] with-session + dup session-manager get sessions>> get-session [ "a" sget , ] with-session + dup session-manager get sessions>> get-session [ "x" sget , ] with-session + session-manager get sessions>> delete-session + ] { } make + ] unit-test + + [ ] [ + + sessions-in-db >>sessions + session-manager set + ] unit-test + + [ + + "GET" >>method + "/" >>path + request set + { "etc" } session-manager get call-responder response set + [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test + response get + ] with-destructors + response set + + [ ] [ response get cookies>> "cookies" set ] unit-test + + [ "2" ] [ session-manager-mock-test ] unit-test + [ "3" ] [ session-manager-mock-test ] unit-test + [ "4" ] [ session-manager-mock-test ] unit-test + + [ + [ ] [ + + "GET" >>method + "id" get session-id-key set-query-param + "/" >>path + request set + + [ + { } + sessions-in-db >>sessions + call-responder + ] with-destructors response set + ] unit-test + + [ "text/plain" ] [ response get "content-type" header ] unit-test + + [ f ] [ response get cookies>> empty? ] unit-test + ] with-scope +] with-db diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 9e4f538583..df2a5bbd28 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -1,134 +1,133 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs calendar kernel math.parser namespaces random -accessors http http.server -http.server.sessions.storage http.server.sessions.storage.assoc -quotations hashtables sequences fry html.elements symbols -continuations destructors ; +USING: assocs kernel math.parser namespaces random +accessors quotations hashtables sequences continuations +fry calendar combinators destructors +http +http.server +http.server.sessions.storage +http.server.sessions.storage.null +html.elements ; IN: http.server.sessions -! ! ! ! ! ! -! WARNING: this session manager is vulnerable to XSRF attacks -! ! ! ! ! ! +TUPLE: session id expires namespace changed? ; + +: ( id -- session ) + session new + swap >>id ; GENERIC: init-session* ( responder -- ) M: object init-session* drop ; -TUPLE: session-manager responder sessions ; +M: dispatcher init-session* default>> init-session* ; -: new-session-manager ( responder class -- responder' ) - new - >>sessions - swap >>responder ; inline +M: filter-responder init-session* responder>> init-session* ; -SYMBOLS: session session-id session-changed? ; +TUPLE: session-manager < filter-responder sessions timeout domain ; + +: ( responder -- responder' ) + session-manager new + swap >>responder + null-sessions >>sessions + 20 minutes >>timeout ; + +: (session-changed) ( session -- ) + t >>changed? drop ; + +: session-changed ( -- ) + session get (session-changed) ; : sget ( key -- value ) - session get at ; + session get namespace>> at ; : sset ( value key -- ) - session get set-at - session-changed? on ; + session get + [ namespace>> set-at ] [ (session-changed) ] bi ; : schange ( key quot -- ) - session get swap change-at - session-changed? on ; inline + session get + [ namespace>> swap change-at ] keep + (session-changed) ; inline -: sessions session-manager get sessions>> ; +: init-session ( session managed -- ) + >r session r> '[ , init-session* ] with-variable ; -: managed-responder session-manager get responder>> ; +: cutoff-time ( -- time ) + session-manager get timeout>> from-now timestamp>millis ; -: init-session ( managed -- session ) - H{ } clone [ session [ init-session* ] with-variable ] keep ; +: touch-session ( session -- ) + cutoff-time >>expires drop ; -: begin-session ( responder -- id session ) - [ responder>> init-session ] [ sessions>> ] bi - [ new-session ] [ drop ] 2bi ; +: empty-session ( -- session ) + f + H{ } clone >>namespace + dup touch-session ; + +: begin-session ( responder -- session ) + >r empty-session r> + [ init-session ] + [ sessions>> new-session ] + [ drop ] + 2tri ; ! Destructor -TUPLE: session-saver id session ; +TUPLE: session-saver manager session ; C: session-saver M: session-saver dispose - session-changed? get [ - [ session>> ] [ id>> ] bi - sessions update-session - ] [ drop ] if ; + [ session>> ] [ manager>> sessions>> ] bi + over changed?>> [ + [ drop touch-session ] [ update-session ] 2bi + ] [ 2drop ] if ; -: save-session-after ( id session -- ) +: save-session-after ( manager session -- ) add-always-destructor ; -: call-responder/session ( path responder id session -- response ) +: existing-session ( path manager session -- response ) + [ nip session set ] [ save-session-after ] - [ [ session-id set ] [ session set ] bi* ] 2bi - [ session-manager set ] [ responder>> call-responder ] bi ; - -TUPLE: null-sessions < session-manager ; - -: - null-sessions new-session-manager ; - -M: null-sessions call-responder ( path responder -- response ) - H{ } clone f call-responder/session ; - -TUPLE: url-sessions < session-manager ; - -: ( responder -- responder' ) - url-sessions new-session-manager ; + [ drop responder>> ] 2tri + call-responder ; : session-id-key "factorsessid" ; -: current-url-session ( responder -- id/f session/f ) - [ request-params session-id-key swap at ] [ sessions>> ] bi* - [ drop ] [ get-session ] 2bi ; +: cookie-session-id ( -- id/f ) + request get session-id-key get-cookie + dup [ value>> string>number ] when ; -: add-session-id ( query -- query' ) - session-id get [ session-id-key associate assoc-union ] when* ; +: post-session-id ( -- id/f ) + session-id-key request get post-data>> at string>number ; + +: request-session-id ( -- id/f ) + request get method>> { + { "GET" [ cookie-session-id ] } + { "HEAD" [ cookie-session-id ] } + { "POST" [ post-session-id ] } + } case ; + +: request-session ( responder -- session/f ) + >r request-session-id r> sessions>> get-session ; + +: ( id -- cookie ) + session-id-key + "$session-manager" resolve-base-path >>path + session-manager get timeout>> from-now >>expires + session-manager get domain>> >>domain ; + +: put-session-cookie ( response -- response' ) + session get id>> number>string put-cookie ; : session-form-field ( -- ) > number>string =value input/> ; -: new-url-session ( responder -- response ) - [ f ] [ begin-session drop session-id-key associate ] bi* - ; - -M: url-sessions call-responder ( path responder -- response ) - [ add-session-id ] link-hook set - [ session-form-field ] form-hook set - dup current-url-session dup [ - call-responder/session - ] [ - 2drop nip new-url-session - ] if ; - -TUPLE: cookie-sessions < session-manager ; - -: ( responder -- responder' ) - cookie-sessions new-session-manager ; - -: current-cookie-session ( responder -- id namespace/f ) - request get session-id-key get-cookie dup - [ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ; - -: ( id -- cookie ) - session-id-key ; - -: call-responder/new-session ( path responder -- response ) - dup begin-session - [ call-responder/session ] - [ drop ] 2bi - put-cookie ; - -M: cookie-sessions call-responder ( path responder -- response ) - dup current-cookie-session dup [ - call-responder/session - ] [ - 2drop call-responder/new-session - ] if ; +M: session-manager call-responder* ( path responder -- response ) + [ session-form-field ] add-form-hook + dup session-manager set + dup request-session [ dup begin-session ] unless* + existing-session put-session-cookie ; diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor deleted file mode 100755 index 6e4a84d646..0000000000 --- a/extra/http/server/sessions/storage/assoc/assoc.factor +++ /dev/null @@ -1,37 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs assocs.lib accessors http.server.sessions.storage -alarms kernel fry http.server ; -IN: http.server.sessions.storage.assoc - -TUPLE: sessions-in-memory sessions alarms ; - -: ( -- storage ) - H{ } clone H{ } clone sessions-in-memory boa ; - -: cancel-session-timeout ( id storage -- ) - alarms>> at [ cancel-alarm ] when* ; - -: touch-session ( id storage -- ) - [ cancel-session-timeout ] - [ '[ , , delete-session ] timeout later ] - [ alarms>> set-at ] - 2tri ; - -M: sessions-in-memory get-session ( id storage -- namespace ) - [ sessions>> at ] [ touch-session ] 2bi ; - -M: sessions-in-memory update-session ( namespace id storage -- ) - [ sessions>> set-at ] - [ touch-session ] - 2bi ; - -M: sessions-in-memory delete-session ( id storage -- ) - [ sessions>> delete-at ] - [ cancel-session-timeout ] - 2bi ; - -M: sessions-in-memory new-session ( namespace storage -- id ) - [ sessions>> set-at-unique ] - [ [ touch-session ] [ drop ] 2bi ] - bi ; diff --git a/extra/http/server/sessions/storage/db/db-tests.factor b/extra/http/server/sessions/storage/db/db-tests.factor deleted file mode 100755 index 4e6ae8a9b4..0000000000 --- a/extra/http/server/sessions/storage/db/db-tests.factor +++ /dev/null @@ -1,24 +0,0 @@ -IN: http.server.sessions.storage.db -USING: http.server.sessions.storage -http.server.sessions.storage.db namespaces io.files -db.sqlite db accessors math tools.test kernel assocs -sequences ; - -sessions-in-db "storage" set - -"auth-test.db" temp-file sqlite-db [ - [ ] [ init-sessions-table ] unit-test - - [ f ] [ H{ } "storage" get new-session empty? ] unit-test - - H{ } "storage" get new-session "id" set - - "id" get "storage" get get-session "session" set - "a" "b" "session" get set-at - - "session" get "id" get "storage" get update-session - - [ H{ { "b" "a" } } ] [ - "id" get "storage" get get-session - ] unit-test -] with-db diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 0245db15b0..58a0130b36 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -1,46 +1,40 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs accessors http.server.sessions.storage -alarms kernel http.server db.tuples db.types math.parser -classes.singleton ; +USING: assocs accessors kernel http.server.sessions.storage +http.server.sessions http.server db db.tuples db.types math.parser +math.intervals fry random calendar sequences alarms ; IN: http.server.sessions.storage.db SINGLETON: sessions-in-db -TUPLE: session id namespace ; - session "SESSIONS" { + ! { "id" "ID" +random-id+ system-random-generator } { "id" "ID" INTEGER +native-id+ } + { "expires" "EXPIRES" BIG-INTEGER +not-null+ } { "namespace" "NAMESPACE" FACTOR-BLOB } } define-persistent : init-sessions-table session ensure-table ; -: ( id -- session ) - session new - swap dup [ string>number ] when >>id ; +M: sessions-in-db get-session ( id storage -- session/f ) + drop dup [ select-tuple ] when ; -M: sessions-in-db get-session ( id storage -- namespace/f ) - drop - dup [ - - select-tuple dup [ namespace>> ] when - ] when ; - -M: sessions-in-db update-session ( namespace id storage -- ) - drop - - swap >>namespace - update-tuple ; +M: sessions-in-db update-session ( session storage -- ) + drop update-tuple ; M: sessions-in-db delete-session ( id storage -- ) - drop - - delete-tuple ; + drop delete-tuple ; -M: sessions-in-db new-session ( namespace storage -- id ) - drop +M: sessions-in-db new-session ( session storage -- ) + drop insert-tuple ; + +: expired-sessions ( -- session ) f - swap >>namespace - [ insert-tuple ] [ id>> number>string ] bi ; + USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expires + select-tuples ; + +: start-expiring-sessions ( db seq -- ) + '[ + , , [ expired-sessions [ delete-tuple ] each ] with-db + ] 5 minutes every drop ; diff --git a/extra/http/server/sessions/storage/null/null.factor b/extra/http/server/sessions/storage/null/null.factor new file mode 100644 index 0000000000..e915d57f83 --- /dev/null +++ b/extra/http/server/sessions/storage/null/null.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel http.server.sessions.storage ; +IN: http.server.sessions.storage.null + +SINGLETON: null-sessions + +: null-sessions-error "No session storage installed" throw ; + +M: null-sessions get-session null-sessions-error ; + +M: null-sessions update-session null-sessions-error ; + +M: null-sessions delete-session null-sessions-error ; + +M: null-sessions new-session null-sessions-error ; diff --git a/extra/http/server/sessions/storage/storage.factor b/extra/http/server/sessions/storage/storage.factor index df96c815c7..c605600f7b 100755 --- a/extra/http/server/sessions/storage/storage.factor +++ b/extra/http/server/sessions/storage/storage.factor @@ -3,12 +3,10 @@ USING: calendar ; IN: http.server.sessions.storage -: timeout 20 minutes ; +GENERIC: get-session ( id storage -- session ) -GENERIC: get-session ( id storage -- namespace ) - -GENERIC: update-session ( namespace id storage -- ) +GENERIC: update-session ( session storage -- ) GENERIC: delete-session ( id storage -- ) -GENERIC: new-session ( namespace storage -- id ) +GENERIC: new-session ( session storage -- ) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 2d4a97c3c0..af6018fbdc 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -69,32 +69,24 @@ TUPLE: file-responder root hook special ; swap '[ , directory. ] >>body ; : find-index ( filename -- path ) - { "index.html" "index.fhtml" } [ append-path ] with map - [ exists? ] find nip ; + "index.html" append-path dup exists? [ drop f ] unless ; : serve-directory ( filename -- response ) - dup "/" tail? [ - dup find-index - [ serve-file ] [ list-directory ] ?if + request get path>> "/" tail? [ + dup + find-index [ serve-file ] [ list-directory ] ?if ] [ - drop request get redirect-with-/ + drop + request get path>> "/" append f ] if ; : serve-object ( filename -- response ) - serving-path dup exists? [ - dup directory? [ serve-directory ] [ serve-file ] if - ] [ - drop <404> - ] if ; + serving-path dup exists? + [ dup directory? [ serve-directory ] [ serve-file ] if ] + [ drop <404> ] + if ; -M: file-responder call-responder ( path responder -- response ) +M: file-responder call-responder* ( path responder -- response ) file-responder set - dup [ - ".." over subseq? [ - drop <400> - ] [ - serve-object - ] if - ] [ - drop redirect-with-/ - ] if ; + ".." over member? + [ drop <400> ] [ "/" join serve-object ] if ; diff --git a/extra/http/server/templating/chloe/chloe-tests.factor b/extra/http/server/templating/chloe/chloe-tests.factor index f517af4a12..61f72a2f14 100644 --- a/extra/http/server/templating/chloe/chloe-tests.factor +++ b/extra/http/server/templating/chloe/chloe-tests.factor @@ -4,14 +4,6 @@ io.streams.string kernel sequences ascii boxes namespaces xml splitting ; IN: http.server.templating.chloe.tests -[ "foo" ] -[ "blah" string>xml "href" required-attr ] -unit-test - -[ "blah" string>xml "href" required-attr ] -[ "href attribute is required" = ] -must-fail-with - [ f ] [ f parse-query-attr ] unit-test [ f ] [ "" parse-query-attr ] unit-test @@ -30,7 +22,7 @@ must-fail-with ] unit-test : run-template - with-string-writer [ "\r\n\t" member? not ] subset + with-string-writer [ "\r\n\t" member? not ] filter "?>" split1 nip ; inline : test-template ( name -- template ) diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor index 685988dfaf..a8a456cdb2 100644 --- a/extra/http/server/templating/chloe/chloe.factor +++ b/extra/http/server/templating/chloe/chloe.factor @@ -1,9 +1,10 @@ USING: accessors kernel sequences combinators kernel namespaces -classes.tuple assocs splitting words arrays +classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 html.elements unicode.case tuple-syntax xml xml.data xml.writer xml.utilities http.server http.server.auth +http.server.flows http.server.components http.server.sessions http.server.templating @@ -18,23 +19,31 @@ C: chloe DEFER: process-template -: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ; +: chloe-ns "http://factorcode.org/chloe/1.0" ; inline + +: filter-chloe-attrs ( assoc -- assoc' ) + [ drop name-url chloe-ns = not ] assoc-filter ; : chloe-tag? ( tag -- ? ) { { [ dup tag? not ] [ f ] } - { [ dup chloe-ns names-match? not ] [ f ] } + { [ dup url>> chloe-ns = not ] [ f ] } [ t ] } cond nip ; SYMBOL: tags +MEMO: chloe-name ( string -- name ) + name new + swap >>tag + chloe-ns >>url ; + : required-attr ( tag name -- value ) - dup rot at* + dup chloe-name rot at* [ nip ] [ drop " attribute is required" append throw ] if ; : optional-attr ( tag name -- value ) - swap at ; + chloe-name swap at ; : write-title-tag ( tag -- ) drop @@ -83,14 +92,33 @@ SYMBOL: tags dup empty? [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; +: flow-attr ( tag -- ) + "flow" optional-attr { + { "none" [ flow-id off ] } + { "begin" [ begin-flow ] } + { "current" [ ] } + { f [ ] } + } case ; + +: session-attr ( tag -- ) + "session" optional-attr { + { "none" [ session off flow-id off ] } + { "current" [ ] } + { f [ ] } + } case ; + : a-start-tag ( tag -- ) - string =href - a> ; + [ + string =href + a> + ] with-scope ; : process-tag-children ( tag -- ) [ process-template ] each ; @@ -102,11 +130,18 @@ SYMBOL: tags tri ; : form-start-tag ( tag -- ) -
- hidden-form-field ; + [ + + hidden-form-field + ] with-scope ; : form-tag ( tag -- ) [ form-start-tag ] diff --git a/extra/http/server/templating/chloe/test/test4.xml b/extra/http/server/templating/chloe/test/test4.xml index 0381bcc27a..dd9b232d73 100644 --- a/extra/http/server/templating/chloe/test/test4.xml +++ b/extra/http/server/templating/chloe/test/test4.xml @@ -2,7 +2,7 @@ - + True diff --git a/extra/http/server/templating/chloe/test/test5.xml b/extra/http/server/templating/chloe/test/test5.xml index d74a5e5368..3bd39e45bd 100644 --- a/extra/http/server/templating/chloe/test/test5.xml +++ b/extra/http/server/templating/chloe/test/test5.xml @@ -2,7 +2,7 @@ - + True diff --git a/extra/http/server/templating/chloe/test/test6.xml b/extra/http/server/templating/chloe/test/test6.xml index 5b6a71cf6b..56234a5f0d 100644 --- a/extra/http/server/templating/chloe/test/test6.xml +++ b/extra/http/server/templating/chloe/test/test6.xml @@ -2,7 +2,7 @@ - + True diff --git a/extra/http/server/templating/chloe/test/test7.xml b/extra/http/server/templating/chloe/test/test7.xml index 4381b5cec4..a4f8e06e7d 100644 --- a/extra/http/server/templating/chloe/test/test7.xml +++ b/extra/http/server/templating/chloe/test/test7.xml @@ -2,7 +2,7 @@ - + True diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 7a2856e311..265675f8df 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -204,7 +204,7 @@ DEFER: _ "predicate" word-prop [ dupd call assure ] curry ; : slot-readers ( class -- quot ) - all-slots 1 tail ! tail gets rid of delegate + all-slots rest ! tail gets rid of delegate [ slot-spec-reader 1quotation [ keep ] curry ] map concat [ ] like [ drop ] compose ; @@ -218,7 +218,7 @@ DEFER: _ : empty-inverse ( class -- quot ) deconstruct-pred - [ tuple>array 1 tail [ ] contains? [ fail ] when ] + [ tuple>array rest [ ] contains? [ fail ] when ] compose ; \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index a901475544..d5b917246a 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2005 Mackenzie Straight. ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: io.buffers USING: alien alien.accessors alien.c-types alien.syntax kernel kernel.private libc math sequences byte-arrays strings hints -accessors ; +accessors math.order ; +IN: io.buffers TUPLE: buffer size ptr fill pos ; diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index dc6e52d67e..3fbb3908e2 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -39,7 +39,7 @@ IN: io.encodings.8-bit : process-contents ( lines -- assoc ) [ "#" split1 drop ] map - [ empty? not ] subset + [ empty? not ] filter [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ; : byte>ch ( assoc -- array ) diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index a00f7cd92b..da3ed38688 100755 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -2,9 +2,11 @@ USING: io io.mmap io.files kernel tools.test continuations sequences io.encodings.ascii accessors ; IN: io.mmap.tests -[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors -[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test -[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test -[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test -[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test -[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors +[ "resource:mmap-test-file.txt" delete-file ] ignore-errors +[ ] [ "12345" "resource:mmap-test-file.txt" ascii set-file-contents ] unit-test +[ ] [ "resource:mmap-test-file.txt" dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test +[ 5 ] [ "resource:mmap-test-file.txt" dup file-info size>> [ length ] with-mapped-file ] unit-test +[ "22345" ] [ "resource:mmap-test-file.txt" ascii file-contents ] unit-test +[ "resource:mmap-test-file.txt" delete-file ] ignore-errors + + diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index 59246115cf..a07443783c 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -21,7 +21,10 @@ M: mapped-file set-nth-unsafe INSTANCE: mapped-file sequence -HOOK: io-backend ( path length -- mmap ) +HOOK: (mapped-file) io-backend ( path length -- mmap ) + +: ( path length -- mmap ) + >r normalize-path r> (mapped-file) ; HOOK: close-mapped-file io-backend ( mmap -- ) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 0bf7a6ccec..fc8ade5758 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: math kernel io sequences io.buffers io.timeouts generic -byte-vectors system io.streams.duplex io.encodings +byte-vectors system io.streams.duplex io.encodings math.order io.backend continuations debugger classes byte-arrays namespaces splitting dlists assocs io.encodings.binary inspector accessors ; IN: io.nonblocking diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index 2a376e18c2..fa82080259 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -103,7 +103,7 @@ M: f parse-sockaddr nip ; : parse-addrinfo-list ( addrinfo -- seq ) [ addrinfo-next ] follow [ addrinfo>addrspec ] map - [ ] subset ; + [ ] filter ; : prepare-resolve-host ( host serv passive? -- host' serv' flags ) #! If the port is a number, we resolve for 'http' then diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 2815a49cd3..ada1f94d87 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -10,7 +10,7 @@ IN: io.unix.mmap >r f -roll r> open-r/w [ 0 mmap ] keep over MAP_FAILED = [ close (io-error) ] when ; -M: unix ( path length -- obj ) +M: unix (mapped-file) ( path length -- obj ) swap >r dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor r> mmap-open f mapped-file boa ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 9413556d4f..74b7136823 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel io.nonblocking io.unix.backend bit-arrays sequences assocs unix math namespaces structs -accessors ; +accessors math.order ; IN: io.unix.select TUPLE: select-mx < mx read-fdset write-fdset ; diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 0164ed1697..dc29405b12 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -70,7 +70,7 @@ M: wince with-privileges dup close-later ] with-privileges ; -M: windows ( path length -- mmap ) +M: windows (mapped-file) ( path length -- mmap ) [ swap GENERIC_WRITE GENERIC_READ bitor diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 4c2277acb9..2397d207b9 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -98,7 +98,7 @@ TUPLE: win32-monitor < monitor port ; M:: winnt (monitor) ( path recursive? mailbox -- monitor ) [ - path mailbox win32-monitor new-monitor + path normalize-path mailbox win32-monitor new-monitor path open-directory \ win32-monitor-port recursive? >>recursive >>port diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 4dda206c7b..1db17278ad 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -9,7 +9,7 @@ IN: irc ! utils : split-at-first ( seq separators -- before after ) dupd '[ , member? ] find - [ cut 1 tail ] + [ cut rest ] [ swap ] if ; @@ -101,7 +101,7 @@ SYMBOL: irc-client : irc-client> ( -- irc-client ) irc-client get ; : irc-stream> ( -- stream ) irc-client> stream>> ; -: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; +: remove-heading-: ( seq -- seq ) dup ":" head? [ rest ] when ; : parse-name ( string -- string ) remove-heading-: "!" split-at-first drop ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index d5ee7f3ebc..c3f6b37fb8 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -84,7 +84,7 @@ TUPLE: segment number color radius ; pick >r nearer-segment dup r> = ; : find-nearest-segment ( oint segments -- segment ) - dup first swap 1 tail-slice rot [ (find-nearest-segment) ] curry + dup first swap rest-slice rot [ (find-nearest-segment) ] curry find 2drop ; : nearest-segment-forward ( segments oint start -- segment ) diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index b136012433..17c1b272df 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser-combinators namespaces sequences promises strings - assocs math math.parser math.vectors math.functions + assocs math math.parser math.vectors math.functions math.order lazy-lists hashtables ascii ; IN: json.reader diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index b079cec42c..e9de82ebb6 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -3,7 +3,7 @@ USING: arrays assocs hashtables assocs io kernel math math.vectors math.matrices math.matrices.elimination namespaces parser prettyprint sequences words combinators math.parser -splitting sorting shuffle symbols sets ; +splitting sorting shuffle symbols sets math.order ; IN: koszul ! Utilities @@ -19,7 +19,7 @@ IN: koszul } cond ; : canonicalize - [ nip zero? not ] assoc-subset ; + [ nip zero? not ] assoc-filter ; SYMBOL: terms @@ -71,7 +71,7 @@ SYMBOL: terms [ natural-sort ] keep [ index ] curry map ; : (inversions) ( n seq -- n ) - [ > ] with subset length ; + [ > ] with filter length ; : inversions ( seq -- n ) 0 swap [ length ] keep [ @@ -148,7 +148,7 @@ DEFER: (d) : nth-basis-elt ( generators n -- elt ) over length [ 3dup bit? [ nth ] [ 2drop f ] if - ] map [ ] subset 2nip ; + ] map [ ] filter 2nip ; : basis ( generators -- seq ) natural-sort dup length 2^ [ nth-basis-elt ] with map ; @@ -203,7 +203,7 @@ DEFER: (d) [ basis graded ] bi@ tensor bigraded-ker/im-d [ [ [ first ] map ] map ] keep [ [ second ] map 2 head* { 0 0 } prepend ] map - 1 tail dup first length 0 suffix + rest dup first length 0 suffix [ v- ] 2map ; ! Laplacian @@ -279,7 +279,7 @@ DEFER: (d) : bigraded-laplacian ( u-generators z-generators quot -- seq ) >r [ basis graded ] bi@ tensor bigraded-triples r> - [ [ first3 ] swap compose map ] curry map ; inline + [ [ first3 ] prepose map ] curry map ; inline : bigraded-laplacian-betti ( u-generators z-generators -- seq ) [ laplacian-betti ] bigraded-laplacian ; diff --git a/extra/lazy-lists/examples/examples.factor b/extra/lazy-lists/examples/examples.factor index 2f7646aab1..844ae31085 100644 --- a/extra/lazy-lists/examples/examples.factor +++ b/extra/lazy-lists/examples/examples.factor @@ -8,7 +8,7 @@ IN: lazy-lists.examples : naturals 0 lfrom ; : positives 1 lfrom ; : evens 0 [ 2 + ] lfrom-by ; -: odds 1 lfrom [ 2 mod 1 = ] lsubset ; +: odds 1 lfrom [ 2 mod 1 = ] lfilter ; : powers-of-2 1 [ 2 * ] lfrom-by ; : ones 1 [ ] lfrom-by ; : squares naturals [ dup * ] lmap ; diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index ebacea03d8..b240b3fbc2 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -82,7 +82,7 @@ HELP: uncons { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; -{ leach lreduce lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words +{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words HELP: leach { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } @@ -104,9 +104,9 @@ HELP: ltake { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } { $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; -HELP: lsubset +HELP: lfilter { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } } -{ $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; +{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: lwhile { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } } diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index b87a1e5f2e..6db82ed2c1 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -201,37 +201,37 @@ M: lazy-while cdr ( lazy-while -- cdr ) M: lazy-while nil? ( lazy-while -- bool ) [ car ] keep lazy-while-quot call not ; -TUPLE: lazy-subset cons quot ; +TUPLE: lazy-filter cons quot ; -C: lazy-subset +C: lazy-filter -: lsubset ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; +: lfilter ( list quot -- result ) + over nil? [ 2drop nil ] [ ] if ; -: car-subset? ( lazy-subset -- ? ) - [ lazy-subset-cons car ] keep - lazy-subset-quot call ; +: car-filter? ( lazy-filter -- ? ) + [ lazy-filter-cons car ] keep + lazy-filter-quot call ; -: skip ( lazy-subset -- ) - [ lazy-subset-cons cdr ] keep - set-lazy-subset-cons ; +: skip ( lazy-filter -- ) + [ lazy-filter-cons cdr ] keep + set-lazy-filter-cons ; -M: lazy-subset car ( lazy-subset -- car ) - dup car-subset? [ lazy-subset-cons ] [ dup skip ] if car ; +M: lazy-filter car ( lazy-filter -- car ) + dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ; -M: lazy-subset cdr ( lazy-subset -- cdr ) - dup car-subset? [ - [ lazy-subset-cons cdr ] keep - lazy-subset-quot lsubset +M: lazy-filter cdr ( lazy-filter -- cdr ) + dup car-filter? [ + [ lazy-filter-cons cdr ] keep + lazy-filter-quot lfilter ] [ dup skip cdr ] if ; -M: lazy-subset nil? ( lazy-subset -- bool ) - dup lazy-subset-cons nil? [ +M: lazy-filter nil? ( lazy-filter -- bool ) + dup lazy-filter-cons nil? [ drop t ] [ - dup car-subset? [ + dup car-filter? [ drop f ] [ dup skip nil? @@ -373,7 +373,7 @@ M: lazy-concat nil? ( lazy-concat -- bool ) [ lcartesian-product* ] dip lmap ; : lcomp* ( list guards quot -- result ) - [ [ lcartesian-product* ] dip [ lsubset ] each ] dip lmap ; + [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ; DEFER: lmerge @@ -442,4 +442,4 @@ INSTANCE: lazy-from-by list INSTANCE: lazy-zip list INSTANCE: lazy-while list INSTANCE: lazy-until list -INSTANCE: lazy-subset list +INSTANCE: lazy-filter list diff --git a/extra/levenshtein/levenshtein.factor b/extra/levenshtein/levenshtein.factor index 98b376593c..07731bfb84 100644 --- a/extra/levenshtein/levenshtein.factor +++ b/extra/levenshtein/levenshtein.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays help io kernel math namespaces sequences ; +USING: arrays help io kernel math namespaces sequences +math.order ; IN: levenshtein : ( m n -- matrix ) diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 372a567550..18d9ec868e 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -1,4 +1,5 @@ -USING: help.syntax help.markup kernel macros prettyprint ; +USING: help.syntax help.markup kernel macros prettyprint +memoize ; IN: locals > ] [ body>> ] bi free-vars diff % ; + [ vars>> ] [ body>> ] bi free-vars swap diff % ; GENERIC: lambda-rewrite* ( obj -- ) @@ -298,6 +298,8 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ; : MACRO:: (::) define-macro ; parsing +: MEMO:: (::) define-memoized ; parsing + >r >r dup r> r> 2curry annotate ; : call-logging-quot ( quot word level -- quot' ) - "called" -rot [ log-message ] 3curry swap compose ; + "called" -rot [ log-message ] 3curry prepose ; : add-logging ( word level -- ) [ call-logging-quot ] (define-logging) ; @@ -88,7 +88,7 @@ PRIVATE> : input# stack-effect effect-in length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-stack ] 3curry swap compose ; + over input# -rot [ log-stack ] 3curry prepose ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index c6aee034cc..7601d1cc2e 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -37,12 +37,12 @@ SYMBOL: log-files write bl write ": " write print ; : write-message ( msg word-name level -- ) - rot [ empty? not ] subset { + rot [ empty? not ] filter { { [ dup empty? ] [ 3drop ] } { [ dup length 1 = ] [ first -rot f (write-message) ] } [ [ first -rot f (write-message) ] 3keep - 1 tail -rot [ t (write-message) ] 2curry each + rest -rot [ t (write-message) ] 2curry each ] } cond ; diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor index 87536476ee..d75915ae8e 100644 --- a/extra/lsys/tortoise/graphics/graphics.factor +++ b/extra/lsys/tortoise/graphics/graphics.factor @@ -1,5 +1,5 @@ -USING: kernel math vectors sequences opengl.gl math.vectors +USING: kernel math vectors sequences opengl.gl math.vectors math.order math.matrices vars opengl self pos ori turtle lsys.tortoise lsys.strings.interpret ; diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index c8d103a084..c3b9190c3c 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -1,5 +1,6 @@ -USING: kernel namespaces threads math math.vectors quotations sequences +USING: kernel namespaces threads math math.order math.vectors + quotations sequences opengl opengl.gl colors @@ -495,4 +496,4 @@ make-pile 1 over set-pack-fill "L-system scenes" open-window ; : lsys-window* ( -- ) [ lsys-controller lsys-viewer ] with-ui ; -MAIN: lsys-window* \ No newline at end of file +MAIN: lsys-window* diff --git a/extra/match/match-docs.factor b/extra/match/match-docs.factor index 4ac59bb0cc..2e23721e93 100644 --- a/extra/match/match-docs.factor +++ b/extra/match/match-docs.factor @@ -42,6 +42,7 @@ HELP: match-replace { $examples { $example "USING: match prettyprint ;" + "IN: scratchpad" "MATCH-VARS: ?a ?b ;" "{ 1 2 } { ?a ?b } { ?b ?a } match-replace ." "{ 2 1 }" diff --git a/extra/match/match.factor b/extra/match/match.factor index e559ebc60d..c5a063ab98 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -67,13 +67,13 @@ MACRO: match-cond ( assoc -- ) [ replace-patterns ] bind ; : ?1-tail ( seq -- tail/f ) - dup length zero? not [ 1 tail ] [ drop f ] if ; + dup length zero? not [ rest ] [ drop f ] if ; : (match-first) ( seq pattern-seq -- bindings leftover/f ) 2dup [ length ] bi@ < [ 2drop f f ] [ 2dup length head over match - [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if* + [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if* ] if ; : match-first ( seq pattern-seq -- bindings ) diff --git a/extra/math/combinatorics/combinatorics-docs.factor b/extra/math/combinatorics/combinatorics-docs.factor index 355898a8bd..514c808ee0 100644 --- a/extra/math/combinatorics/combinatorics-docs.factor +++ b/extra/math/combinatorics/combinatorics-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel math sequences ; +USING: help.markup help.syntax kernel math math.order sequences ; IN: math.combinatorics HELP: factorial diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index 487d9828ea..3376ea640b 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math math.ranges mirrors namespaces sequences sorting ; +USING: assocs kernel math math.order math.ranges mirrors +namespaces sequences sorting ; IN: math.combinatorics ] must-fail diff --git a/extra/math/functions/functions-docs.factor b/extra/math/functions/functions-docs.factor index 35471653dc..c023258105 100755 --- a/extra/math/functions/functions-docs.factor +++ b/extra/math/functions/functions-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel math +USING: help.markup help.syntax kernel math math.order sequences quotations math.functions.private ; IN: math.functions diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 8c71eb545b..c9215d8de7 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -1,5 +1,5 @@ -USING: kernel math math.constants math.functions math.private -math.libm tools.test ; +USING: kernel math math.constants math.functions math.order +math.private math.libm tools.test ; IN: math.functions.tests [ t ] [ 4 4 .00000001 ~ ] unit-test diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 632939ff71..481b58bb92 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel math.constants math.private -math.libm combinators ; +math.libm combinators math.order ; IN: math.functions r find* drop r> length or ; inline + over >r find-from drop r> length or ; inline : first-col ( row# -- n ) #! First non-zero column @@ -69,7 +69,7 @@ SYMBOL: matrix : echelon ( matrix -- matrix' ) [ 0 0 (echelon) ] with-matrix ; -: nonzero-rows [ [ zero? ] all? not ] subset ; +: nonzero-rows [ [ zero? ] all? not ] filter ; : null/rank ( matrix -- null rank ) echelon dup length swap nonzero-rows length [ - ] keep ; diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor index 327bf76552..294cd6278a 100755 --- a/extra/math/matrices/matrices.factor +++ b/extra/math/matrices/matrices.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel sequences math math.functions -math.vectors ; +math.vectors math.order ; IN: math.matrices ! Matrices diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index 7835277b9b..c668806fc2 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -76,7 +76,9 @@ TUPLE: miller-rabin-bounds ; : find-relative-prime ( n -- p ) dup random find-relative-prime* ; +ERROR: too-few-primes ; + : unique-primes ( numbits n -- seq ) #! generate two primes - over 5 < [ "not enough primes below 5 bits" throw ] when + over 5 < [ too-few-primes ] when [ [ drop random-prime ] with map ] [ all-unique? ] generate ; diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index 0b0d3520ef..842c4c7f50 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -1,5 +1,5 @@ USING: arrays kernel sequences vectors math math.vectors namespaces -shuffle splitting sequences.lib ; +shuffle splitting sequences.lib math.order ; IN: math.polynomials ! Polynomials are vectors with the highest powers on the right: @@ -58,7 +58,7 @@ PRIVATE> 2dup /-last 2dup , n*p swapd p- >vector - dup pop* swap 1 tail-slice ; + dup pop* swap rest-slice ; PRIVATE> diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index edad69fffc..2eeaca6c92 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel lazy-lists math math.functions math.miller-rabin - math.primes.list math.ranges sequences sorting ; + math.order math.primes.list math.ranges sequences sorting ; IN: math.primes fraction ] unit-test diff --git a/extra/math/vectors/vectors.factor b/extra/math/vectors/vectors.factor index 51efd33d45..9c9015d242 100755 --- a/extra/math/vectors/vectors.factor +++ b/extra/math/vectors/vectors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel sequences math math.functions hints -float-arrays ; +float-arrays math.order ; IN: math.vectors : vneg ( u -- v ) [ neg ] map ; diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index 5d7bb9a1a2..dbf983be62 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -1,6 +1,7 @@ ! From http://www.ffconsultancy.com/ocaml/maze/index.html USING: sequences namespaces math math.vectors opengl opengl.gl -arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render ; +arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render +math.order ; IN: maze : line-width 8 ; @@ -17,7 +18,7 @@ SYMBOL: visited : choices ( cell -- seq ) { { -1 0 } { 1 0 } { 0 -1 } { 0 1 } } [ v+ ] with map - [ unvisited? ] subset ; + [ unvisited? ] filter ; : random-neighbour ( cell -- newcell ) choices random ; diff --git a/extra/memoize/memoize-tests.factor b/extra/memoize/memoize-tests.factor index dbd2d3a16a..43428efbe0 100644 --- a/extra/memoize/memoize-tests.factor +++ b/extra/memoize/memoize-tests.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel memoize tools.test parser ; +IN: memoize.tests MEMO: fib ( m -- n ) dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail +[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 45ae2cc959..4136f9eaff 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -39,8 +39,7 @@ IN: memoize over H{ } clone "memoize" set-word-prop over make-memoizer define ; -: MEMO: - CREATE-WORD parse-definition define-memoized ; parsing +: MEMO: (:) define-memoized ; parsing PREDICATE: memoized < word "memoize" word-prop ; diff --git a/extra/models/models.factor b/extra/models/models.factor index 58335de3d1..7a0b4b532a 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: generic kernel math sequences arrays assocs alarms -calendar ; +calendar math.order ; IN: models TUPLE: model < identity-tuple diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index dd6fc7dfff..07d110b01a 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -4,7 +4,7 @@ USING: kernel math sequences vectors classes classes.algebra combinators arrays words assocs parser namespaces definitions prettyprint prettyprint.backend quotations arrays.lib debugger io compiler.units kernel.private effects accessors -hashtables sorting shuffle ; +hashtables sorting shuffle math.order ; IN: multi-methods ! PART I: Converting hook specializers @@ -19,12 +19,12 @@ SYMBOL: total : canonicalize-specializer-1 ( specializer -- specializer' ) [ - [ class? ] subset + [ class? ] filter [ length [ 1+ neg ] map ] keep zip [ length args [ max ] change ] keep ] [ - [ pair? ] subset + [ pair? ] filter [ keys [ hooks get push-new ] each ] keep ] bi append ; @@ -73,7 +73,7 @@ SYMBOL: total ! Part II: Topologically sorting specializers : maximal-element ( seq quot -- n elt ) dupd [ - swapd [ call 0 < ] 2curry subset empty? + swapd [ call 0 < ] 2curry filter empty? ] 2curry find [ "Topological sort failed" throw ] unless* ; inline @@ -111,7 +111,7 @@ SYMBOL: total : multi-predicate ( classes -- quot ) dup length [ picker 2array ] 2map - [ drop object eq? not ] assoc-subset + [ drop object eq? not ] assoc-filter dup empty? [ drop [ t ] ] [ [ (multi-predicate) ] { } assoc>map unclip [ swap [ f ] \ if 3array append [ ] like ] reduce diff --git a/extra/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor index ed8bece4ba..cea7022759 100644 --- a/extra/multi-methods/tests/topological-sort.factor +++ b/extra/multi-methods/tests/topological-sort.factor @@ -1,5 +1,6 @@ +USING: kernel multi-methods tools.test math arrays sequences +math.order ; IN: multi-methods.tests -USING: kernel multi-methods tools.test math arrays sequences ; [ { 1 2 3 4 5 6 } ] [ { 6 4 5 1 3 2 } [ <=> ] topological-sort diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index 079f484274..e140c5227c 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -34,7 +34,7 @@ IN: multiline [ lexer get lexer-column swap (parse-multiline-string) lexer get set-lexer-column - ] "" make 1 tail 1 head* ; + ] "" make rest 1 head* ; : <" "\">" parse-multiline-string parsed ; parsing diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index 3e5f66eb6f..2b2f916aea 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -143,7 +143,7 @@ METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: subset-of ( quot seq -- seq ) swap subset ; +: filter-of ( quot seq -- seq ) swap filter ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor index d4ad11311f..251206f1d1 100755 --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -15,7 +15,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays namespaces threads shuffle opengl arrays ui.gadgets.worlds combinators math.parser ui.gadgets ui.render opengl.gl ui continuations io.files hints combinators.lib sequences.lib - io.encodings.binary debugger ; + io.encodings.binary debugger math.order ; IN: ogg.player diff --git a/extra/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor index 6802d15378..d658235cf6 100755 --- a/extra/opengl/capabilities/capabilities.factor +++ b/extra/opengl/capabilities/capabilities.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences splitting opengl.gl -continuations math.parser math arrays sets ; +continuations math.parser math arrays sets math.order ; IN: opengl.capabilities : (require-gl) ( thing require-quot make-error-quot -- ) @@ -15,7 +15,7 @@ IN: opengl.capabilities : has-gl-extensions? ( extensions -- ? ) gl-extensions swap [ over member? ] all? nip ; : (make-gl-extensions-error) ( required-extensions -- ) - gl-extensions swap diff + gl-extensions diff "Required OpenGL extensions not supported:\n" % [ " " % % "\n" % ] each ; : require-gl-extensions ( extensions -- ) diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 84515305c8..460558db8b 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,5 +1,6 @@ -USING: arrays combinators.lib kernel math math.functions math.vectors namespaces - opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; +USING: arrays combinators.lib kernel math math.functions +math.order math.vectors namespaces opengl opengl.gl sequences ui +ui.gadgets ui.gestures ui.render ; IN: opengl.demo-support : NEAR-PLANE 1.0 64.0 / ; inline diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index 739ad203a1..8f2eee9459 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -43,6 +43,6 @@ reset-gl-function-number-counter scan drop "}" parse-tokens swap prefix gl-function-number [ gl-function-pointer ] 2curry swap - ";" parse-tokens [ "()" subseq? not ] subset + ";" parse-tokens [ "()" subseq? not ] filter define-indirect ; parsing diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index 5825ca7270..f42c611fc0 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -84,7 +84,7 @@ verify-load-locations ] unit-test ! SYMBOL: ssl ! ! : is-set ( seq -- newseq ) -! >alist [ nip ] assoc-subset >hashtable keys ; +! >alist [ nip ] assoc-filter >hashtable keys ; ! ! ! 1234 server-socket sock set ! "127.0.0.1" 1234 SOCK_STREAM server-fd sock set diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 3ae0c94b12..fa35534439 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -38,7 +38,7 @@ M: comment pprint* " --" % " " over node-out-d values% " r: " swap node-out-r values% - ] "" make 1 tail ; + ] "" make rest ; MACRO: match-choose ( alist -- ) [ [ ] curry ] assoc-map [ match-cond ] curry ; diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor index feaace9808..70756e81c2 100755 --- a/extra/optimizer/report/report.factor +++ b/extra/optimizer/report/report.factor @@ -1,14 +1,14 @@ -IN: optimizer.report USING: assocs words sequences arrays compiler tools.time io.styles io prettyprint vocabs kernel sorting generator -optimizer math ; +optimizer math math.order ; +IN: optimizer.report : count-optimization-passes ( nodes n -- n ) >r optimize-1 [ r> 1+ count-optimization-passes ] [ drop r> ] if ; : results - [ [ second ] swap compose compare ] curry sort 20 tail* + [ [ second ] prepose compare ] curry sort 20 tail* print standard-table-style [ @@ -16,7 +16,7 @@ optimizer math ; ] tabular-output ; : optimizer-report - all-words [ compiled? ] subset + all-words [ compiled? ] filter [ dup [ word-dataflow nip 1 count-optimization-passes diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 40620295c6..9537a0c88c 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -177,7 +177,7 @@ M: or-parser parse ( input parser1 -- list ) #! Return a new string without any leading whitespace #! from the original string. dup empty? [ - dup first blank? [ 1 tail-slice left-trim-slice ] when + dup first blank? [ rest-slice left-trim-slice ] when ] unless ; TUPLE: sp-parser p1 ; @@ -200,7 +200,7 @@ M: just-parser parse ( input parser -- result ) #! from the results anything where the remaining #! input to be parsed is not empty. So ensures a #! fully parsed input string. - just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ; + just-parser-p1 parse [ parse-result-unparsed empty? ] lfilter ; TUPLE: apply-parser p1 quot ; diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 8bf0475da5..57851812ef 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -285,7 +285,7 @@ M: ebnf-optional (transform) ( ast -- parser ) GENERIC: build-locals ( code ast -- code ) M: ebnf-sequence build-locals ( code ast -- code ) - elements>> dup [ ebnf-var? ] subset empty? [ + elements>> dup [ ebnf-var? ] filter empty? [ drop ] [ [ diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index da7f678f2d..784e6c064c 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -107,7 +107,7 @@ MEMO: pack ( begin body end -- parser ) #! range of characters from the first to the second, #! inclusive. dup first CHAR: ^ = [ - 1 tail (range-pattern) [ member? not ] curry satisfy + rest (range-pattern) [ member? not ] curry satisfy ] [ (range-pattern) [ member? ] curry satisfy ] if ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 858d062c68..b420574a3b 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces math assocs shuffle - vectors arrays math.parser + vectors arrays math.parser math.order unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting ; IN: peg @@ -448,7 +448,7 @@ M: action-parser (compile) ( parser -- quot ) #! Return a new string without any leading whitespace #! from the original string. dup empty? [ - dup first blank? [ 1 tail-slice left-trim-slice ] when + dup first blank? [ rest-slice left-trim-slice ] when ] unless ; TUPLE: sp-parser p1 ; diff --git a/extra/peg/search/search.factor b/extra/peg/search/search.factor index 21a111f6f7..3da676dcb2 100755 --- a/extra/peg/search/search.factor +++ b/extra/peg/search/search.factor @@ -17,14 +17,14 @@ MEMO: any-char-parser ( -- parser ) : search ( string parser -- seq ) any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ - parse-result-ast [ ] subset + parse-result-ast [ ] filter ] [ drop { } ] if ; : (replace) ( string parser -- seq ) - any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ; + any-char-parser 2array choice repeat0 parse parse-result-ast [ ] filter ; : replace ( string parser -- result ) [ (replace) [ tree-write ] each ] with-string-writer ; diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor index da0658f94d..32386fed2b 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -62,5 +62,5 @@ io.files io.encodings.utf8 ; "extra/porter-stemmer/test/voc.txt" resource-lines [ stem ] map "extra/porter-stemmer/test/output.txt" resource-lines - [ 2array ] 2map [ first2 = not ] subset + [ 2array ] 2map [ first2 = not ] filter ] unit-test diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor index dc191bc439..5abe23bb90 100644 --- a/extra/processing/gallery/trails/trails.factor +++ b/extra/processing/gallery/trails/trails.factor @@ -1,5 +1,5 @@ -USING: kernel arrays sequences math qualified +USING: kernel arrays sequences math math.order qualified sequences.lib circular processing ui newfx ; IN: processing.gallery.trails @@ -44,4 +44,4 @@ IN: processing.gallery.trails : go ( -- ) [ go* ] with-ui ; -MAIN: go \ No newline at end of file +MAIN: go diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 7d77e86fec..843f8b87ba 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -30,7 +30,7 @@ IN: project-euler.001 ! ------------------- : euler001a ( -- answer ) - 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] subset sum ; + 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ; ! [ euler001a ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index b660ed0958..c2def03ace 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -30,7 +30,7 @@ PRIVATE> V{ 0 } clone 1 rot (fib-upto) ; : euler002 ( -- answer ) - 1000000 fib-upto [ even? ] subset sum ; + 1000000 fib-upto [ even? ] filter sum ; ! [ euler002 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials @@ -44,7 +44,7 @@ PRIVATE> 1 head-slice* { 0 1 } prepend ; : euler002a ( -- answer ) - 1000000 fib-upto* [ even? ] subset sum ; + 1000000 fib-upto* [ even? ] filter sum ; ! [ euler002a ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor index b2146b4aea..1f268f1500 100644 --- a/extra/project-euler/004/004.factor +++ b/extra/project-euler/004/004.factor @@ -21,7 +21,7 @@ IN: project-euler.004 append ; : abundants-upto ( n -- seq ) - [1,b] [ abundant? ] subset ; + [1,b] [ abundant? ] filter ; : possible-sums ( seq -- seq ) dup { } -rot [ dupd [ + ] curry map - rot append prune swap 1 tail + rot append prune swap rest ] each drop natural-sort ; PRIVATE> : euler023 ( -- answer ) - 20161 abundants-upto possible-sums source-023 diff sum ; + source-023 + 20161 abundants-upto possible-sums diff sum ; ! TODO: solution is still too slow, although it takes under 1 minute diff --git a/extra/project-euler/026/026.factor b/extra/project-euler/026/026.factor index f1f546ec1c..8cbf20d0bf 100644 --- a/extra/project-euler/026/026.factor +++ b/extra/project-euler/026/026.factor @@ -34,7 +34,7 @@ IN: project-euler.026 : euler030 ( -- answer ) - 325537 [ dup sum-fifth-powers = ] subset sum 1- ; + 325537 [ dup sum-fifth-powers = ] filter sum 1- ; ! [ euler030 ] 100 ave-time ! 2537 ms run / 125 ms GC ave time - 100 trials diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 7b24004df6..68b42ca442 100755 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -46,7 +46,7 @@ IN: project-euler.032 PRIVATE> : euler032 ( -- answer ) - source-032 [ valid? ] subset products prune sum ; + source-032 [ valid? ] filter products prune sum ; ! [ euler032 ] 10 ave-time ! 23922 ms run / 1505 ms GC ave time - 10 trials @@ -70,7 +70,7 @@ PRIVATE> PRIVATE> : euler032a ( -- answer ) - source-032a [ mmp ] map [ pandigital? ] subset products prune sum ; + source-032a [ mmp ] map [ pandigital? ] filter products prune sum ; ! [ euler032a ] 100 ave-time ! 5978 ms run / 327 ms GC ave time - 100 trials diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor index 35b1c87e7a..8cb0dc45c3 100644 --- a/extra/project-euler/033/033.factor +++ b/extra/project-euler/033/033.factor @@ -30,7 +30,7 @@ IN: project-euler.033 diff --git a/extra/project-euler/034/034.factor b/extra/project-euler/034/034.factor index c15d722266..cf73ee828b 100644 --- a/extra/project-euler/034/034.factor +++ b/extra/project-euler/034/034.factor @@ -39,7 +39,7 @@ IN: project-euler.034 PRIVATE> : euler034 ( -- answer ) - 3 2000000 [a,b] [ factorion? ] subset sum ; + 3 2000000 [a,b] [ factorion? ] filter sum ; ! [ euler034 ] 10 ave-time ! 15089 ms run / 725 ms GC ave time - 10 trials diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor index c362e1e1a5..cec9bc6957 100755 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -28,7 +28,7 @@ IN: project-euler.035 : possible? ( seq -- ? ) dup length 1 > [ - dup { 0 2 4 5 6 8 } swap diff = + dup { 0 2 4 5 6 8 } diff = ] [ drop t ] if ; @@ -50,7 +50,7 @@ IN: project-euler.035 PRIVATE> : euler035 ( -- answer ) - source-035 [ possible? ] subset [ circular? ] count ; + source-035 [ possible? ] filter [ circular? ] count ; ! [ euler035 ] 100 ave-time ! 904 ms run / 86 ms GC ave time - 100 trials diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor index 3ca1c73f39..153901ce6d 100644 --- a/extra/project-euler/036/036.factor +++ b/extra/project-euler/036/036.factor @@ -32,7 +32,7 @@ IN: project-euler.036 PRIVATE> : euler036 ( -- answer ) - 1 1000000 2 [ both-bases? ] subset sum ; + 1 1000000 2 [ both-bases? ] filter sum ; ! [ euler036 ] 100 ave-time ! 3891 ms run / 173 ms GC ave time - 100 trials diff --git a/extra/project-euler/037/037.factor b/extra/project-euler/037/037.factor index 66b1665037..a5bc0581e6 100755 --- a/extra/project-euler/037/037.factor +++ b/extra/project-euler/037/037.factor @@ -44,7 +44,7 @@ IN: project-euler.037 PRIVATE> : euler037 ( -- answer ) - 23 1000000 primes-between [ r-trunc? ] subset [ l-trunc? ] subset sum ; + 23 1000000 primes-between [ r-trunc? ] filter [ l-trunc? ] filter sum ; ! [ euler037 ] 100 ave-time ! 768 ms run / 9 ms GC ave time - 100 trials diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor index 2369db25fb..78e3848a33 100755 --- a/extra/project-euler/038/038.factor +++ b/extra/project-euler/038/038.factor @@ -47,7 +47,7 @@ IN: project-euler.038 PRIVATE> : euler038 ( -- answer ) - 9123 9876 [a,b] [ concat-product ] map [ pandigital? ] subset supremum ; + 9123 9876 [a,b] [ concat-product ] map [ pandigital? ] filter supremum ; ! [ euler038 ] 100 ave-time ! 37 ms run / 1 ms GC ave time - 100 trials diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor index a87722debc..1fda8a402a 100644 --- a/extra/project-euler/042/042.factor +++ b/extra/project-euler/042/042.factor @@ -31,7 +31,7 @@ IN: project-euler.042 : source-042 ( -- seq ) "extra/project-euler/042/words.txt" resource-path - ascii file-contents [ quotable? ] subset "," split ; + ascii file-contents [ quotable? ] filter "," split ; : (triangle-upto) ( limit n -- ) 2dup nth-triangle > [ diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index 0d1eb00bfa..41e378e531 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -53,7 +53,7 @@ PRIVATE> : euler043 ( -- answer ) 1234567890 number>digits all-permutations - [ interesting? ] subset [ 10 digits>integer ] map sum ; + [ interesting? ] filter [ 10 digits>integer ] map sum ; ! [ euler043 ] time ! 125196 ms run / 19548 ms GC time @@ -70,20 +70,20 @@ PRIVATE> [ number>digits 3 0 pad-left ] map [ all-unique? ] subset ; + 1000 over [ number>digits 3 0 pad-left ] map [ all-unique? ] filter ; : overlap? ( seq -- ? ) dup first 2 tail* swap second 2 head = ; : clean ( seq -- seq ) - [ unclip 1 head prefix concat ] map [ all-unique? ] subset ; + [ unclip 1 head prefix concat ] map [ all-unique? ] filter ; : add-missing-digit ( seq -- seq ) - dup natural-sort 10 diff first prefix ; + dup natural-sort 10 swap diff first prefix ; : interesting-pandigitals ( -- seq ) 17 candidates { 13 11 7 5 3 2 } [ - candidates swap cartesian-product [ overlap? ] subset clean + candidates swap cartesian-product [ overlap? ] filter clean ] each [ add-missing-digit ] map ; PRIVATE> diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor index bc8aec8bde..eaa6bf96ef 100644 --- a/extra/project-euler/044/044.factor +++ b/extra/project-euler/044/044.factor @@ -37,7 +37,7 @@ PRIVATE> : euler044 ( -- answer ) 2500 [1,b] [ nth-pentagonal ] map dup cartesian-product - [ first2 sum-and-diff? ] subset [ first2 - abs ] map infimum ; + [ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ; ! [ euler044 ] 10 ave-time ! 8924 ms run / 2872 ms GC ave time - 10 trials diff --git a/extra/project-euler/076/076.factor b/extra/project-euler/076/076.factor index b09a2742c3..782d6d0429 100644 --- a/extra/project-euler/076/076.factor +++ b/extra/project-euler/076/076.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Eric Mertens ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs combinators kernel math sequences math.ranges locals ; +USING: arrays assocs combinators kernel math sequences +math.order math.ranges locals ; IN: project-euler.076 ! http://projecteuler.net/index.php?section=problems&id=76 diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index 452a64af44..3674804b0c 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -35,11 +35,11 @@ IN: project-euler.079 ] { } make ; : find-source ( seq -- elt ) - dup values swap keys [ prune ] bi@ diff + [ keys ] [ values ] bi diff prune dup empty? [ "Topological sort failed" throw ] [ first ] if ; : remove-source ( seq elt -- seq ) - [ swap member? not ] curry subset ; + [ swap member? not ] curry filter ; : (topological-sort) ( seq -- ) dup length 1 > [ @@ -52,7 +52,7 @@ PRIVATE> : topological-sort ( seq -- seq ) [ [ (topological-sort) ] { } make ] keep - concat prune dupd diff append ; + concat prune over diff append ; : euler079 ( -- answer ) source-079 >edges topological-sort 10 digits>integer ; diff --git a/extra/project-euler/100/100.factor b/extra/project-euler/100/100.factor new file mode 100644 index 0000000000..d2d396a0e1 --- /dev/null +++ b/extra/project-euler/100/100.factor @@ -0,0 +1,7 @@ +USING: kernel sequences math.functions math ; +IN: project-euler.100 + +: euler100 ( -- n ) + 1 1 + [ dup dup 1- * 2 * 10 24 ^ <= ] + [ tuck 6 * swap - 2 - ] [ ] while nip ; diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor index 5056560a85..3a05261710 100644 --- a/extra/project-euler/117/117.factor +++ b/extra/project-euler/117/117.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Eric Mertens ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math splitting sequences ; +USING: kernel math math.order splitting sequences ; IN: project-euler.117 diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index fb7fdebd51..11af1960ed 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel lazy-lists math.algebra math math.functions math.primes - math.ranges project-euler.common sequences ; +USING: arrays kernel lazy-lists math.algebra math math.functions + math.order math.primes math.ranges project-euler.common sequences ; IN: project-euler.134 ! http://projecteuler.net/index.php?section=problems&id=134 diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index c96c1ebc73..8c93d4f7e6 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Eric Mertens ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences sequences.private locals hints ; +USING: kernel math math.order sequences sequences.private +locals hints ; IN: project-euler.150 sgn + { + { -1 [ ] } + { 0 [ 1- ] } + { 1 [ 1+ ] } + } case + ] curry map-index ; + +DEFER: (euler151) + +: pick-sheet ( seq i -- res ) + 2dup swap nth dup zero? [ + 3drop 0 + ] [ + [ (pick-sheet) (euler151) ] dip * + ] if ; + +: (euler151) ( x -- y ) + table get [ { + { { 0 0 0 1 } [ 0 ] } + { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1+ ] } + { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1+ ] } + { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1+ ] } + [ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ] + } case ] cache ; + +: euler151 ( -- n ) + [ + H{ } clone table set + { 1 1 1 1 } (euler151) + ] with-scope ; diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 5829f66c01..fefb986fe0 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,6 +1,6 @@ USING: arrays kernel math math.functions math.miller-rabin math.matrices - math.parser math.primes.factors math.ranges namespaces sequences - sequences.lib sorting unicode.case ; + math.order math.parser math.primes.factors math.ranges namespaces + sequences sequences.lib sorting unicode.case ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -40,10 +40,10 @@ IN: project-euler.common ! Propagate one row into the upper one : propagate ( bottom top -- newtop ) - [ over 1 tail rot first2 max rot + ] map nip ; + [ over rest rot first2 max rot + ] map nip ; : shift-3rd ( seq obj obj -- seq obj obj ) - rot 1 tail -rot ; + rot rest -rot ; : (sum-divisors) ( n -- sum ) dup sqrt >fixnum [1,b] [ @@ -95,7 +95,7 @@ PRIVATE> ! Not strictly needed, but it is nice to be able to dump the triangle after the ! propagation : propagate-all ( triangle -- newtriangle ) - reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap suffix ; + reverse [ first dup ] keep rest [ propagate dup ] map nip reverse swap suffix ; : sum-divisors ( n -- sum ) dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ; diff --git a/extra/promises/promises-docs.factor b/extra/promises/promises-docs.factor index ade3357f34..c482df0d15 100755 --- a/extra/promises/promises-docs.factor +++ b/extra/promises/promises-docs.factor @@ -29,6 +29,6 @@ HELP: LAZY: { $values { "word" "a new word to define" } { "definition" "a word definition" } } { $description "Creates a lazy word in the current vocabulary. When executed the word will return a " { $link promise } " that when forced, executes the word definition. Any values on the stack that are required by the word definition are captured along with the promise." } { $examples - { $example "USING: math prettyprint promises ;" "LAZY: my-add ( a b -- c ) + ;" "1 2 my-add force ." "3" } + { $example "USING: arrays sequences prettyprint promises ;" "IN: scratchpad" "LAZY: zeroes ( -- pair ) 0 zeroes 2array ;" "zeroes force second force first ." "0" } } { $see-also force promise-with promise-with2 } ; diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index 730388ade0..e48714bc44 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -23,7 +23,7 @@ IN: qualified ] curry map zip ; : partial-vocab-ignoring ( words name -- assoc ) - [ vocab-words keys diff ] keep partial-vocab ; + [ vocab-words keys swap diff ] keep partial-vocab ; : EXCLUDE: #! Syntax: EXCLUDE: vocab => words ... ; diff --git a/extra/random-weighted/random-weighted.factor b/extra/random-weighted/random-weighted.factor index 476fc083a7..59cc15cba6 100644 --- a/extra/random-weighted/random-weighted.factor +++ b/extra/random-weighted/random-weighted.factor @@ -7,7 +7,7 @@ IN: random-weighted : probabilities ( weights -- probabilities ) dup sum v/n ; : layers ( probabilities -- layers ) -dup length 1+ [ head ] with map 1 tail [ sum ] map ; +dup length 1+ [ head ] with map rest [ sum ] map ; : random-weighted ( weights -- elt ) probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ; diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor index 703a0c16e4..d25ceacdb1 100755 --- a/extra/random/mersenne-twister/mersenne-twister-tests.factor +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -1,5 +1,5 @@ USING: kernel math random namespaces random.mersenne-twister -sequences tools.test ; +sequences tools.test math.order ; IN: random.mersenne-twister.tests : check-random ( max -- ? ) diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index d517db09fe..78ffaf5eeb 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -1,6 +1,6 @@ USING: arrays combinators kernel lazy-lists math math.parser namespaces parser parser-combinators parser-combinators.simple -promises quotations sequences combinators.lib strings +promises quotations sequences combinators.lib strings math.order assocs prettyprint.backend memoize unicode.case unicode.categories ; USE: io IN: regexp @@ -291,7 +291,7 @@ TUPLE: regexp source parser ignore-case? ; : parse-regexp ( accum end -- accum ) lexer get dup skip-blank - [ [ index* dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column + [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column lexer get dup still-parsing-line? [ (parse-token) parse-options ] [ drop f ] if parsed ; diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor index 8c26d880f1..f7023c74bf 100644 --- a/extra/regexp2/regexp2.factor +++ b/extra/regexp2/regexp2.factor @@ -1,6 +1,6 @@ USING: assocs combinators.lib kernel math math.parser namespaces peg unicode.case sequences unicode.categories -memoize peg.parsers ; +memoize peg.parsers math.order ; USE: io USE: tools.walker IN: regexp2 diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index c3b7311714..3b37171da3 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -1,7 +1,7 @@ USING: assocs math kernel shuffle combinators.lib words quotations arrays combinators sequences math.vectors io.styles prettyprint vocabs sorting io generic locals.private -math.statistics ; +math.statistics math.order ; IN: reports.noise : badness ( word -- n ) diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor index f38d1d808b..06e76d0a99 100755 --- a/extra/reports/optimizer/optimizer.factor +++ b/extra/reports/optimizer/optimizer.factor @@ -1,6 +1,6 @@ USING: assocs words sequences arrays compiler tools.time io.styles io prettyprint vocabs kernel sorting generator -optimizer math ; +optimizer math math.order ; IN: report.optimizer : count-optimization-passes ( nodes n -- n ) @@ -8,7 +8,7 @@ IN: report.optimizer [ r> 1+ count-optimization-passes ] [ drop r> ] if ; : results - [ [ second ] swap compose compare ] curry sort 20 tail* + [ [ second ] prepose compare ] curry sort 20 tail* print standard-table-style [ @@ -16,7 +16,7 @@ IN: report.optimizer ] tabular-output ; inline : optimizer-measurements ( -- alist ) - all-words [ compiled? ] subset + all-words [ compiled? ] filter [ dup [ word-dataflow nip 1 count-optimization-passes diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index 07e43cea8e..71b5d69693 100644 --- a/extra/roman/roman.factor +++ b/extra/roman/roman.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math math.vectors namespaces +USING: arrays assocs kernel math math.order math.vectors namespaces quotations sequences sequences.lib sequences.private strings unicode.case ; IN: roman diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 5fc688967a..6e616e51a9 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -IN: rss -USING: xml.utilities kernel assocs xml.generator +USING: xml.utilities kernel assocs xml.generator math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables calendar.format accessors continuations ; +IN: rss : any-tag-named ( tag names -- tag-inside ) f -rot [ tag-named nip dup ] with find 2drop ; diff --git a/extra/sequences/deep/deep-docs.factor b/extra/sequences/deep/deep-docs.factor index b98dbfc50f..3dc560f46d 100644 --- a/extra/sequences/deep/deep-docs.factor +++ b/extra/sequences/deep/deep-docs.factor @@ -9,7 +9,7 @@ HELP: deep-map { $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } { "newobj" "the mapped object" } } { $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } ; -HELP: deep-subset +HELP: deep-filter { $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "seq" "a sequence" } } { $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ; diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor index 9629d569cb..395086e202 100755 --- a/extra/sequences/deep/deep-tests.factor +++ b/extra/sequences/deep/deep-tests.factor @@ -4,11 +4,11 @@ IN: sequences.deep.tests [ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test -[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find* ] unit-test +[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find-from ] unit-test -[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find* ] unit-test +[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find-from ] unit-test -[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test +[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find-from ] unit-test : change-something ( seq -- newseq ) dup array? [ "hi" suffix ] [ "hello" append ] if ; diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor index 27b875bd8f..c0e516e471 100644 --- a/extra/sequences/deep/deep.factor +++ b/extra/sequences/deep/deep.factor @@ -18,21 +18,21 @@ IN: sequences.deep [ call ] keep over branch? [ [ deep-map ] curry map ] [ drop ] if ; inline -: deep-subset ( obj quot -- seq ) +: deep-filter ( obj quot -- seq ) over >r pusher >r deep-each r> r> dup branch? [ like ] [ drop ] if ; inline -: deep-find* ( obj quot -- elt ? ) +: deep-find-from ( obj quot -- elt ? ) [ call ] 2keep rot [ drop t ] [ over branch? [ - f -rot [ >r nip r> deep-find* ] curry find drop >boolean + f -rot [ >r nip r> deep-find-from ] curry find drop >boolean ] [ 2drop f f ] if ] if ; inline -: deep-find ( obj quot -- elt ) deep-find* drop ; inline +: deep-find ( obj quot -- elt ) deep-find-from drop ; inline -: deep-contains? ( obj quot -- ? ) deep-find* nip ; inline +: deep-contains? ( obj quot -- ? ) deep-find-from nip ; inline : deep-all? ( obj quot -- ? ) [ not ] compose deep-contains? not ; inline @@ -43,4 +43,4 @@ IN: sequences.deep ] curry change-each ] [ 2drop ] if ; inline : flatten ( obj -- seq ) - [ branch? not ] deep-subset ; + [ branch? not ] deep-filter ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index b186ee7777..ad5a40ed6d 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -4,7 +4,7 @@ USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors arrays math.parser math.private sorting strings ascii macros -assocs.lib quotations hashtables ; +assocs.lib quotations hashtables math.order ; IN: sequences.lib : each-withn ( seq quot n -- ) nwith each ; inline @@ -45,7 +45,7 @@ MACRO: firstn ( n -- ) >r dup length dup [ / ] curry - [ 1+ ] swap compose + [ 1+ ] prepose r> compose 2each ; inline @@ -117,7 +117,7 @@ MACRO: firstn ( n -- ) : split-around ( seq quot -- before elem after ) dupd find over [ "Element not found" throw ] unless - >r cut 1 tail r> swap ; inline + >r cut rest r> swap ; inline : (map-until) ( quot pred -- quot ) [ dup ] swap 3compose @@ -129,7 +129,11 @@ MACRO: firstn ( n -- ) : take-while ( seq quot -- newseq ) [ not ] compose [ find drop [ head-slice ] when* ] curry - [ dup ] swap compose keep like ; + [ dup ] prepose keep like ; + +: replicate ( seq quot -- newseq ) + #! quot: ( -- obj ) + [ drop ] prepose map ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -155,7 +159,7 @@ PRIVATE> : switches ( seq1 seq -- subseq ) ! seq1 is a sequence of ones and zeroes - >r [ length ] keep [ nth 1 = ] curry subset r> + >r [ length ] keep [ nth 1 = ] curry filter r> [ nth ] curry { } map-as ; : power-set ( seq -- subsets ) @@ -212,7 +216,7 @@ USE: continuations >r dup length swap r> [ = [ ] [ drop f ] if ] curry 2map - [ ] subset ; + [ ] filter ; zip >hashtable substitute ; : remove-nth ( seq n -- seq' ) - cut-slice 1 tail-slice append ; + cut-slice rest-slice append ; + +: short ( seq n -- seq n' ) + over length min ; inline diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index bb69a8a41c..fcf57714d6 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -111,7 +111,7 @@ M: tuple (serialize) ( obj -- ) CHAR: T write1 [ class (serialize) ] [ add-object ] - [ tuple>array 1 tail (serialize) ] + [ tuple>array rest (serialize) ] tri ] serialize-shared ; @@ -230,6 +230,7 @@ SYMBOL: deserialized : deserialize-word ( -- word ) (deserialize) (deserialize) 2dup lookup dup [ 2nip ] [ + drop "Unknown word: " -rot 2array unparse append throw ] if ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 1d22ed731a..162512f9f3 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -63,7 +63,7 @@ IN: smtp.tests prepare dup headers>> >alist sort-keys [ drop { "Date" "Message-Id" } member? not - ] assoc-subset + ] assoc-filter over to>> rot from>> ] unit-test diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index d565117e5f..4d548738d2 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -131,7 +131,7 @@ M: email clone "-" % millis # "@" % - smtp-domain get % + smtp-domain get [ host-name ] unless* % ">" % ] "" make ; diff --git a/extra/state-parser/state-parser-docs.factor b/extra/state-parser/state-parser-docs.factor index 7ef2869452..cac0e30175 100644 --- a/extra/state-parser/state-parser-docs.factor +++ b/extra/state-parser/state-parser-docs.factor @@ -13,7 +13,7 @@ ARTICLE: { "state-parser" "main" } "State-based parsing" { $subsection next } { $subsection state-parse } { $subsection get-char } - { $subsection rest } + { $subsection take-rest } { $subsection string-parse } { $subsection expect } { $subsection expect-string } @@ -23,7 +23,7 @@ HELP: get-char { $values { "char" "the current character" } } { $description "Accesses the current character of the stream that is being parsed" } ; -HELP: rest +HELP: take-rest { $values { "string" "the rest of the parser input" } } { $description "Exausts the stream of the parser input and returns a string representing the rest of the input" } ; diff --git a/extra/state-parser/state-parser-tests.factor b/extra/state-parser/state-parser-tests.factor index 4e1ecaddfc..e0b274b3e6 100755 --- a/extra/state-parser/state-parser-tests.factor +++ b/extra/state-parser/state-parser-tests.factor @@ -1,8 +1,8 @@ USING: tools.test state-parser kernel io strings ascii ; -[ "hello" ] [ "hello" [ rest ] string-parse ] unit-test -[ 2 4 ] [ "12\n123" [ rest drop get-line get-column ] string-parse ] unit-test -[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until rest ] string-parse ] unit-test -[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char rest ] string-parse ] unit-test -[ "foo " " bar" ] [ "foo and bar" [ "and" take-string rest ] string-parse ] unit-test -[ "baz" ] [ " \n\t baz" [ pass-blank rest ] string-parse ] unit-test +[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test +[ 2 4 ] [ "12\n123" [ take-rest drop get-line get-column ] string-parse ] unit-test +[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test +[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test +[ "foo " " bar" ] [ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test +[ "baz" ] [ " \n\t baz" [ pass-blank take-rest ] string-parse ] unit-test diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index 6a3bf1d552..96ad4ca0b4 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -99,7 +99,7 @@ SYMBOL: prolog-data dup slip swap dup [ get-char , ] unless ] skip-until ] "" make nip ; inline -: rest ( -- string ) +: take-rest ( -- string ) [ f ] take-until ; : take-char ( ch -- string ) diff --git a/extra/symbols/symbols-docs.factor b/extra/symbols/symbols-docs.factor index f542948970..9f79b71365 100644 --- a/extra/symbols/symbols-docs.factor +++ b/extra/symbols/symbols-docs.factor @@ -5,5 +5,5 @@ HELP: SYMBOLS: { $syntax "SYMBOLS: words... ;" } { $values { "words" "a sequence of new words to define" } } { $description "Creates a new word for every token until the ';'." } -{ $examples { $example "USING: prettyprint symbols ;" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } +{ $examples { $example "USING: prettyprint symbols ;" "IN: scratchpad" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } { $see-also POSTPONE: SYMBOL: } ; diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor index f1f3868ec8..8456d95673 100644 --- a/extra/taxes/taxes.factor +++ b/extra/taxes/taxes.factor @@ -1,5 +1,5 @@ USING: arrays assocs kernel math math.intervals namespaces -sequences combinators.lib money ; +sequences combinators.lib money math.order ; IN: taxes : monthly ( x -- y ) 12 / ; diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor index 532978e359..3e4548078c 100644 --- a/extra/tetris/board/board.factor +++ b/extra/tetris/board/board.factor @@ -47,7 +47,7 @@ TUPLE: board width height rows ; ] if ; : remove-full-rows ( board -- ) - dup board-rows [ row-not-full? ] subset swap set-board-rows ; + dup board-rows [ row-not-full? ] filter swap set-board-rows ; : check-rows ( board -- n ) #! remove full rows, then add blank ones at the top, returning the number diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index ef710ea57d..d6016f280c 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -61,7 +61,7 @@ M: word reset "--- Entering: " write swap . "--- Variable values:" print [ dup get ] H{ } map>assoc describe - ] 2curry swap compose ; + ] 2curry prepose ; : watch-vars ( word vars -- ) dupd [ (watch-vars) ] 2curry annotate ; diff --git a/extra/tools/completion/completion.factor b/extra/tools/completion/completion.factor index b9c37c0656..4bb6d6142f 100755 --- a/extra/tools/completion/completion.factor +++ b/extra/tools/completion/completion.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: tools.completion USING: kernel arrays sequences math namespaces strings io vectors words assocs combinators sorting unicode.case -unicode.categories ; +unicode.categories math.order ; +IN: tools.completion : (fuzzy) ( accum ch i full -- accum i ? ) - index* + index-from [ [ swap push ] 2keep 1+ t ] [ @@ -52,7 +52,7 @@ unicode.categories ; : rank-completions ( results -- newresults ) sort-keys [ 0 [ first max ] reduce 3 /f ] keep - [ first < ] with subset + [ first < ] with filter [ second ] map ; : complete ( full short -- score ) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 82e2652c01..f95b83467a 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -73,7 +73,7 @@ IN: tools.deploy.shaker [ [ word-props swap - '[ , nip member? ] assoc-subset + '[ , nip member? ] assoc-filter f assoc-like ] keep set-word-props ] with each ; @@ -104,7 +104,7 @@ IN: tools.deploy.shaker set-global ; : strip-vocab-globals ( except names -- words ) - [ child-vocabs [ words ] map concat ] map concat diff ; + [ child-vocabs [ words ] map concat ] map concat swap diff ; : stripped-globals ( -- seq ) [ @@ -201,8 +201,8 @@ IN: tools.deploy.shaker strip-globals? [ "Stripping globals" show global swap - '[ drop , member? not ] assoc-subset - [ drop string? not ] assoc-subset ! strip CLI args + '[ drop , member? not ] assoc-filter + [ drop string? not ] assoc-filter ! strip CLI args dup keys unparse show 21 setenv ] [ drop ] if ; diff --git a/extra/tools/memory/memory-docs.factor b/extra/tools/memory/memory-docs.factor index 28c219ee4d..821a6ca7f5 100755 --- a/extra/tools/memory/memory-docs.factor +++ b/extra/tools/memory/memory-docs.factor @@ -9,7 +9,7 @@ ARTICLE: "tools.memory" "Object memory tools" "You can query memory status:" { $subsection data-room } { $subsection code-room } -"There are a pair of combinators, analogous to " { $link each } " and " { $link subset } ", which operate on the entire collection of objects in the object heap:" +"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:" { $subsection each-object } { $subsection instances } "You can check an object's the heap memory usage:" diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 467fcc14f4..6a5fce6281 100755 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -39,7 +39,7 @@ M: method-body (profile.) ] with-row ; : counters. ( assoc -- ) - [ second 0 > ] subset sort-values + [ second 0 > ] filter sort-values standard-table-style [ [ counter. ] assoc-each ] tabular-output ; @@ -58,13 +58,13 @@ M: method-body (profile.) "Call counts for words which call " write dup pprint ":" print - usage [ word? ] subset counters counters. ; + usage [ word? ] filter counters counters. ; : vocabs-profile. ( -- ) "Call counts for all vocabularies:" print vocabs [ dup words - [ "predicating" word-prop not ] subset + [ "predicating" word-prop not ] filter [ profile-counter ] map sum ] { } map>assoc counters. ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 031b3c3af8..854ef7af0e 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -85,7 +85,7 @@ SYMBOL: this-test : run-tests ( prefix -- failures ) child-vocabs dup empty? [ drop f ] [ [ dup run-test ] { } map>assoc - [ second empty? not ] subset + [ second empty? not ] filter ] if ; : test ( prefix -- ) diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor index 060377d127..2bd38cf304 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: tools.threads USING: threads kernel prettyprint prettyprint.config io io.styles sequences assocs namespaces sorting boxes -heaps.private system math math.parser ; +heaps.private system math math.parser math.order ; +IN: tools.threads : thread. ( thread -- ) dup thread-id pprint-cell diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index db1edbeb61..2b28e158df 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -105,8 +105,8 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map - [ [ word? ] subset [ word-vocabulary ] map ] map>set - remove [ ] subset [ vocab ] map ; inline + [ [ word? ] filter [ word-vocabulary ] map ] map>set + remove [ ] filter [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; @@ -143,7 +143,7 @@ C: vocab-author : keyed-vocabs ( str quot -- seq ) all-vocabs [ swap >r - [ >r 2dup r> swap call member? ] subset + [ >r 2dup r> swap call member? ] filter r> swap ] assoc-map 2nip ; inline diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 40e79ee014..e265f233e3 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -15,7 +15,7 @@ IN: tools.vocabs dup vocab-dir "tests" append-path vocab-append-path dup [ dup exists? [ dup directory keys - [ ".factor" tail? ] subset + [ ".factor" tail? ] filter [ append-path ] with map ] [ drop f ] if ] [ drop f ] if ; @@ -90,7 +90,7 @@ SYMBOL: changed-vocabs changed-vocabs get dup [ key? ] [ 2drop t ] if ; : filter-changed ( vocabs -- vocabs' ) - [ changed-vocab? ] subset ; + [ changed-vocab? ] filter ; SYMBOL: modified-sources SYMBOL: modified-docs @@ -127,7 +127,7 @@ SYMBOL: modified-docs modified-sources get modified-docs get ] - [ modified-sources get modified-docs get append swap diff ] bi + [ modified-docs get modified-sources get append diff ] bi ] with-scope ; : do-refresh ( modified-sources modified-docs unchanged -- ) @@ -208,7 +208,7 @@ M: vocab-link summary vocab-summary ; dup vocab-authors-path set-vocab-file-contents ; : subdirs ( dir -- dirs ) - directory [ second ] subset keys natural-sort ; + directory [ second ] filter keys natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) [ vocab-dir append-path subdirs ] keep @@ -260,7 +260,7 @@ MEMO: all-vocabs-seq ( -- seq ) } cond nip ; : filter-dangerous ( seq -- seq' ) - [ vocab-name dangerous? not ] subset ; + [ vocab-name dangerous? not ] filter ; : try-everything ( -- failures ) all-vocabs-seq @@ -273,10 +273,10 @@ MEMO: all-vocabs-seq ( -- seq ) : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . suffix ] unless vocabs - [ find-vocab-root not ] subset + [ find-vocab-root not ] filter [ vocab-name swap ?head CHAR: . rot member? not and - ] with subset + ] with filter [ vocab ] map ; : all-child-vocabs ( prefix -- assoc ) @@ -288,7 +288,7 @@ MEMO: all-vocabs-seq ( -- seq ) : all-child-vocabs-seq ( prefix -- assoc ) vocab-roots get swap [ dupd (all-child-vocabs) - [ vocab-dir? ] with subset + [ vocab-dir? ] with filter ] curry map concat ; : map>set ( seq quot -- ) diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 5c88187c6c..3a37ec5fc7 100755 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel generic math math.functions math.parser -namespaces io prettyprint.backend sequences trees assocs parser ; +namespaces io prettyprint.backend sequences trees assocs parser +math.order ; IN: trees.avl TUPLE: avl ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 4b82f86a57..f2e3f9645f 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces sequences assocs parser -prettyprint.backend trees generic ; +prettyprint.backend trees generic math.order ; IN: trees.splay TUPLE: splay ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 07497b2098..89443dec8e 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic math sequences arrays io namespaces prettyprint.private kernel.private assocs random combinators -parser prettyprint.backend ; +parser prettyprint.backend math.order ; IN: trees MIXIN: tree-mixin diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor index ed524148e3..5ff0752c19 100644 --- a/extra/ui/commands/commands-docs.factor +++ b/extra/ui/commands/commands-docs.factor @@ -47,6 +47,7 @@ HELP: command-name { $examples { $example "USING: io ui.commands ;" + "IN: scratchpad" ": com-my-command ;" "\\ com-my-command command-name write" "My Command" @@ -105,6 +106,7 @@ HELP: command-string { $examples { $example "USING: io ui.commands ui.gestures ;" + "IN: scratchpad" ": com-my-command ;" "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write" "My Command (C+s)" diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor index c7db687dc3..f341595969 100755 --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -37,7 +37,7 @@ GENERIC: command-word ( command -- word ) : command-gestures ( class -- hash ) commands values [ [ - [ first ] subset + [ first ] filter [ [ invoke-command ] curry swap set ] assoc-each ] each ] H{ } make-assoc ; @@ -56,7 +56,7 @@ GENERIC: command-word ( command -- word ) M: word command-name ( word -- str ) word-name "com-" ?head drop - dup first Letter? [ 1 tail ] unless + dup first Letter? [ rest ] unless (command-name) ; M: word command-description ( word -- str ) diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index b3ecad6aed..c4a808bb2d 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -4,7 +4,8 @@ USING: arrays documents ui.clipboards ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io kernel math models namespaces opengl opengl.gl sequences strings -io.styles math.vectors sorting colors combinators assocs ; +io.styles math.vectors sorting colors combinators assocs +math.order ; IN: ui.gadgets.editors TUPLE: editor diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 9213c3886f..fd5234ab03 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels ui.gadgets.scrollers -kernel sequences models opengl math namespaces +kernel sequences models opengl math math.order namespaces ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs math.vectors classes.tuple ; IN: ui.gadgets.lists diff --git a/extra/ui/gadgets/packs/packs.factor b/extra/ui/gadgets/packs/packs.factor index 09ef3218b4..c6f437583e 100755 --- a/extra/ui/gadgets/packs/packs.factor +++ b/extra/ui/gadgets/packs/packs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences ui.gadgets kernel math math.functions -math.vectors namespaces ; +math.vectors namespaces math.order ; IN: ui.gadgets.packs TUPLE: pack align fill gap ; diff --git a/extra/ui/gadgets/paragraphs/paragraphs.factor b/extra/ui/gadgets/paragraphs/paragraphs.factor index 7576bce568..9f375d0126 100644 --- a/extra/ui/gadgets/paragraphs/paragraphs.factor +++ b/extra/ui/gadgets/paragraphs/paragraphs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math -namespaces sequences ; +namespaces sequences math.order ; IN: ui.gadgets.paragraphs ! A word break gadget diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor index a420f59047..4d2c423445 100755 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons -ui.gadgets.frames ui.gadgets.grids +ui.gadgets.frames ui.gadgets.grids math.order ui.gadgets.theme ui.render kernel math namespaces sequences vectors models math.vectors math.functions quotations colors ; IN: ui.gadgets.sliders diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index d8caf54ad2..56a0fbc3ee 100644 --- a/extra/ui/gadgets/tracks/tracks.factor +++ b/extra/ui/gadgets/tracks/tracks.factor @@ -8,7 +8,7 @@ TUPLE: track sizes ; : normalized-sizes ( track -- seq ) track-sizes - [ [ ] subset sum ] keep [ dup [ over / ] when ] map nip ; + [ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ; : ( orientation -- track ) V{ } clone diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index ed0f38b743..0970bd6027 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -172,7 +172,7 @@ SYMBOL: drag-timer ] if ; : modifier ( mod modifiers -- seq ) - [ second swap bitand 0 > ] with subset + [ second swap bitand 0 > ] with filter 0 prune dup empty? [ drop f ] [ >array ] if ; : drag-loc ( -- loc ) diff --git a/extra/ui/operations/operations.factor b/extra/ui/operations/operations.factor index 26200ea96f..ac414b2cb9 100755 --- a/extra/ui/operations/operations.factor +++ b/extra/ui/operations/operations.factor @@ -37,7 +37,7 @@ M: operation command-word operation-command command-word ; SYMBOL: operations : object-operations ( obj -- operations ) - operations get [ operation-predicate call ] with subset ; + operations get [ operation-predicate call ] with filter ; : find-operation ( obj quot -- command ) >r object-operations r> find-last nip ; inline diff --git a/extra/ui/render/render.factor b/extra/ui/render/render.factor index cacd0a8d3a..d33a789fe7 100644 --- a/extra/ui/render/render.factor +++ b/extra/ui/render/render.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays hashtables io kernel math namespaces opengl opengl.gl opengl.glu sequences strings io.styles vectors -combinators math.vectors ui.gadgets colors ; +combinators math.vectors ui.gadgets colors math.order ; IN: ui.render SYMBOL: clip diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 3837ce2de1..6c8b77d1f2 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -7,7 +7,7 @@ sequences strings threads listener classes.tuple ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures definitions boxes calendar concurrency.flags ui.tools.workspace -accessors ; +accessors math.order ; IN: ui.tools.interactor TUPLE: interactor history output flag thread help ; diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index 279737466f..6d22083096 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -17,7 +17,7 @@ IN: ui.tools.tests [ ] [ "w" get com-scroll-down ] unit-test [ t ] [ "w" get workspace-book gadget-children - [ tool-scroller ] map [ ] subset [ scroller? ] all? + [ tool-scroller ] map [ ] filter [ scroller? ] all? ] unit-test [ ] [ "w" get hide-popup ] unit-test [ ] [ "w" get show-popup ] unit-test diff --git a/extra/ui/traverse/traverse.factor b/extra/ui/traverse/traverse.factor index e3aff92109..85b2266159 100644 --- a/extra/ui/traverse/traverse.factor +++ b/extra/ui/traverse/traverse.factor @@ -60,7 +60,7 @@ DEFER: (gadget-subtree) : traverse-child ( frompath topath gadget -- ) dup -roll [ - >r >r 1 tail-slice r> r> traverse-step (gadget-subtree) + >r >r rest-slice r> r> traverse-step (gadget-subtree) ] make-node ; : (gadget-subtree) ( frompath topath gadget -- ) diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 946fe283aa..12565235ab 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -26,7 +26,7 @@ SYMBOL: windows [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ; : unregister-window ( handle -- ) - windows global [ [ first = not ] with subset ] change-at ; + windows global [ [ first = not ] with filter ] change-at ; : raised-window ( world -- ) windows get-global [ second eq? ] with find drop diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index ee3c8729c4..5ab997470a 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -25,7 +25,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; : process-other-extend ( lines -- set ) [ "#" split1 drop ";" split1 drop trim-blank ] map - [ empty? not ] subset + [ empty? not ] filter [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map concat [ dup ] H{ } map>assoc ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 58d836464c..5e1d30d529 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,6 +1,7 @@ USING: assocs math kernel sequences io.files hashtables -quotations splitting arrays math.parser hash2 -byte-arrays words namespaces words compiler.units parser io.encodings.ascii ; +quotations splitting arrays math.parser hash2 math.order +byte-arrays words namespaces words compiler.units parser +io.encodings.ascii ; IN: unicode.data << @@ -25,7 +26,7 @@ IN: unicode.data : (process-data) ( index data -- newdata ) [ [ nth ] keep first swap 2array ] with map - [ second empty? not ] subset + [ second empty? not ] filter [ >r hex> r> ] assoc-map ; : process-data ( index data -- hash ) @@ -48,9 +49,9 @@ IN: unicode.data [ " " split [ hex> ] map ] assoc-map ; : process-canonical ( data -- hash2 hash ) - (process-decomposed) [ first* ] subset + (process-decomposed) [ first* ] filter [ - [ second length 2 = ] subset + [ second length 2 = ] filter ! using 1009 as the size, the maximum load is 4 [ first2 first2 rot 3array ] map 1009 alist>hash2 ] keep @@ -58,13 +59,13 @@ IN: unicode.data : process-compat ( data -- hash ) (process-decomposed) - [ dup first* [ first2 1 tail 2array ] unless ] map + [ dup first* [ first2 rest 2array ] unless ] map >hashtable chain-decomposed ; : process-combining ( data -- hash ) 3 swap (process-data) [ string>number ] assoc-map - [ nip zero? not ] assoc-subset + [ nip zero? not ] assoc-filter >hashtable ; : categories ( -- names ) @@ -96,7 +97,7 @@ IN: unicode.data ] assoc-map >hashtable ; : multihex ( hexstring -- string ) - " " split [ hex> ] map [ ] subset ; + " " split [ hex> ] map [ ] filter ; TUPLE: code-point lower title upper ; @@ -128,7 +129,7 @@ VALUE: special-casing ! Special casing data : load-special-casing ( -- special-casing ) "extra/unicode/SpecialCasing.txt" resource-path data - [ length 5 = ] subset + [ length 5 = ] filter [ [ set-code-point ] each ] H{ } make-assoc ; load-data diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 34c329b55c..c463c0f727 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -51,11 +51,11 @@ IN: unicode.normalize [ >r >r 2dup r> r> insert ] 2each 2drop ; inline : reorder-slice ( string start -- slice done? ) - 2dup swap [ non-starter? not ] find* drop + 2dup swap [ non-starter? not ] find-from drop [ [ over length ] unless* rot ] keep not ; : reorder-next ( string i -- new-i done? ) - over [ non-starter? ] find* drop [ + over [ non-starter? ] find-from drop [ reorder-slice >r dup [ combining-class ] insertion-sort slice-to r> ] [ length t ] if* ; @@ -67,7 +67,7 @@ IN: unicode.normalize 0 reorder-loop ; : reorder-back ( string i -- ) - over [ non-starter? not ] find-last* drop ?1+ reorder-next 2drop ; + over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ; : decompose ( string quot -- decomposed ) ! When there are 8 and 32-bit strings, this'll be diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index 4dc91a73c2..b5ba25db4e 100755 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -1,5 +1,6 @@ -USING: unicode.data kernel math sequences parser bit-arrays namespaces -sequences.private arrays quotations classes.predicate assocs ; +USING: unicode.data kernel math sequences parser bit-arrays +namespaces sequences.private arrays quotations assocs +classes.predicate math.order ; IN: unicode.syntax ! Character classes (categories) @@ -27,8 +28,8 @@ IN: unicode.syntax : [category] ( categories -- quot ) [ - [ [ categories member? not ] subset as-string ] keep - [ categories member? ] subset >category-array + [ [ categories member? not ] filter as-string ] keep + [ categories member? ] filter >category-array [ dup category# ] % , [ nth-unsafe [ drop t ] ] % \ member? 2array >quotation , \ if , @@ -41,7 +42,7 @@ IN: unicode.syntax CREATE ";" parse-tokens define-category ; parsing : seq-minus ( seq1 seq2 -- diff ) - [ member? not ] curry subset ; + [ member? not ] curry filter ; : CATEGORY-NOT: CREATE ";" parse-tokens diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 3483d4321e..0c7b95525e 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -1,22 +1,44 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences io.files io.sockets -db.sqlite smtp namespaces db +USING: accessors kernel sequences assocs io.files io.sockets +namespaces db db.sqlite smtp +http.server http.server.db +http.server.flows http.server.sessions http.server.auth.login http.server.auth.providers.db http.server.sessions.storage.db http.server.boilerplate -http.server.templating.chloe ; +http.server.templating.chloe +webapps.pastebin +webapps.planet +webapps.todo ; IN: webapps.factor-website +: test-db "test.db" resource-path sqlite-db ; + : factor-template ( path -- template ) "resource:extra/webapps/factor-website/" swap ".xml" 3append ; -: test-db "todo.db" resource-path sqlite-db ; +: init-factor-db ( -- ) + test-db [ + init-users-table + init-sessions-table -: ( responder -- responder' ) + init-pastes-table + init-annotations-table + + init-blog-table + + init-todo-table + ] with-db ; + +: ( -- responder ) + + "todo" add-responder + "pastebin" add-responder + "planet" add-responder users-in-db >>users allow-registration @@ -24,7 +46,8 @@ IN: webapps.factor-website allow-edit-profile "page" factor-template >>template - + + sessions-in-db >>sessions test-db ; @@ -32,7 +55,11 @@ IN: webapps.factor-website "factorcode.org" 25 smtp-server set-global "todo@factorcode.org" lost-password-from set-global - test-db [ - init-sessions-table - init-users-table - ] with-db ; + init-factor-db + + main-responder set-global ; + +: start-factor-website + test-db start-expiring-sessions + "planet" main-responder get responders>> at test-db start-update-task + 8812 httpd ; diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml index d929042320..3e2f43845a 100644 --- a/extra/webapps/factor-website/page.xml +++ b/extra/webapps/factor-website/page.xml @@ -10,6 +10,8 @@ + + body, button { font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; @@ -47,6 +49,18 @@ padding: 5px; border: 1px solid #ccc; } + + .big-field-label { + vertical-align: top; + } + + .description { + border: 1px dashed #ccc; + background-color: #f5f5f5; + padding: 5px; + font-size: 150%; + color: #000000; + } diff --git a/extra/webapps/pastebin/annotation.xml b/extra/webapps/pastebin/annotation.xml new file mode 100644 index 0000000000..e5a95d8908 --- /dev/null +++ b/extra/webapps/pastebin/annotation.xml @@ -0,0 +1,23 @@ + + + + +

Annotation:

+ +
User name:
Real name:
Password:
Verify:
E-mail:
Captcha:
+ + + +
Author:
Mode:
Date:
+ +
+ +
+ + + + + + + + diff --git a/extra/webapps/pastebin/authors.txt b/extra/webapps/pastebin/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/pastebin/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/pastebin/new-annotation.xml b/extra/webapps/pastebin/new-annotation.xml new file mode 100644 index 0000000000..ad7152d209 --- /dev/null +++ b/extra/webapps/pastebin/new-annotation.xml @@ -0,0 +1,25 @@ + + + + + New Annotation + + + + + + + + + + + + + + +
Summary:
Author:
Mode:
Description:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ + + + + diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml new file mode 100644 index 0000000000..86daf09aeb --- /dev/null +++ b/extra/webapps/pastebin/new-paste.xml @@ -0,0 +1,23 @@ + + + + + New Paste + + + + + + + + + + + + + +
Summary:
Author:
Mode:
Description:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ + + + diff --git a/extra/webapps/pastebin/paste-list.xml b/extra/webapps/pastebin/paste-list.xml new file mode 100644 index 0000000000..c91aa6fc42 --- /dev/null +++ b/extra/webapps/pastebin/paste-list.xml @@ -0,0 +1,15 @@ + + + + + Pastebin + + + + + + + +
Summary:Paste by:Date:
+ + diff --git a/extra/webapps/pastebin/paste-summary.xml b/extra/webapps/pastebin/paste-summary.xml new file mode 100644 index 0000000000..eca46e254d --- /dev/null +++ b/extra/webapps/pastebin/paste-summary.xml @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml new file mode 100644 index 0000000000..9db60bfcc3 --- /dev/null +++ b/extra/webapps/pastebin/paste.xml @@ -0,0 +1,25 @@ + + + + + Pastebin + +

Paste:

+ + + + + +
Author:
Mode:
Date:
+ +
+ + + + + + | + Annotate + + + diff --git a/extra/webapps/pastebin/pastebin.css b/extra/webapps/pastebin/pastebin.css new file mode 100644 index 0000000000..16814770a2 --- /dev/null +++ b/extra/webapps/pastebin/pastebin.css @@ -0,0 +1,7 @@ +pre.code { + border:1px dashed #ccc; + background-color:#f5f5f5; + padding:5px; + font-size:150%; + color:#000000; +} diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor new file mode 100644 index 0000000000..9301b14353 --- /dev/null +++ b/extra/webapps/pastebin/pastebin.factor @@ -0,0 +1,254 @@ +USING: namespaces assocs sorting sequences kernel accessors +hashtables sequences.lib locals db.types db.tuples db +calendar calendar.format rss xml.writer +xmode.catalog +http.server +http.server.crud +http.server.actions +http.server.components +http.server.components.code +http.server.templating.chloe +http.server.auth.login +http.server.boilerplate +http.server.validators +http.server.forms ; +IN: webapps.pastebin + +: ( id -- component ) + modes keys natural-sort ; + +: pastebin-template ( name -- template ) + "resource:extra/webapps/pastebin/" swap ".xml" 3append ; + +TUPLE: paste id summary author mode date contents annotations captcha ; + +paste "PASTE" +{ + { "id" "ID" INTEGER +native-id+ } + { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } + { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } + { "mode" "MODE" { VARCHAR 256 } +not-null+ } + { "date" "DATE" DATETIME +not-null+ } + { "contents" "CONTENTS" TEXT +not-null+ } +} define-persistent + +: ( id -- paste ) + paste new + swap >>id ; + +: pastes ( -- pastes ) + f select-tuples ; + +TUPLE: annotation aid id summary author mode contents date captcha ; + +annotation "ANNOTATION" +{ + { "aid" "AID" INTEGER +native-id+ } + { "id" "ID" INTEGER +not-null+ } + { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } + { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } + { "mode" "MODE" { VARCHAR 256 } +not-null+ } + { "date" "DATE" DATETIME +not-null+ } + { "contents" "CONTENTS" TEXT +not-null+ } +} define-persistent + +: ( id aid -- annotation ) + annotation new + swap >>aid + swap >>id ; + +: fetch-annotations ( paste -- paste ) + dup annotations>> [ + dup id>> f select-tuples >>annotations + ] unless ; + +: ( -- form ) + "paste" + "id" + hidden >>renderer + add-field + "aid" + hidden >>renderer + add-field + "annotation" pastebin-template >>view-template + "summary" add-field + "author" add-field + "mode" add-field + "contents" "mode" add-field + "date" add-field ; + +: ( -- form ) + "paste" + "new-annotation" pastebin-template >>edit-template + "id" + hidden >>renderer + t >>required add-field + "summary" + t >>required add-field + "author" + t >>required + add-field + "mode" + "factor" >>default + t >>required + add-field + "contents" "mode" + t >>required add-field + "captcha" add-field ; + +: ( -- form ) + "paste" + "paste" pastebin-template >>view-template + "paste-summary" pastebin-template >>summary-template + "id" + hidden >>renderer add-field + "summary" add-field + "author" add-field + "mode" add-field + "date" add-field + "contents" "mode" add-field + "annotations" +plain+ add-field ; + +: ( -- form ) + "paste" + "new-paste" pastebin-template >>edit-template + "summary" + t >>required add-field + "author" + t >>required add-field + "mode" + "factor" >>default + t >>required + add-field + "contents" "mode" + t >>required add-field + "captcha" add-field ; + +: ( -- form ) + "pastebin" + "paste-list" pastebin-template >>view-template + "pastes" +plain+ add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ + blank-values + + pastes "pastes" set-value + + form view-form + ] >>display + ] ; + +:: ( form ctor next -- action ) + + { { "id" [ v-number ] } } >>get-params + + [ + "id" get f ctor call + + from-tuple form set-defaults + ] >>init + + [ form edit-form ] >>display + + [ + f f ctor call from-tuple + + form validate-form + + values-tuple insert-tuple + + "id" value next + ] >>submit ; + +: pastebin-feed-entries ( -- entries ) + pastes 20 short head [ + [ summary>> ] + [ "$pastebin/view-paste" swap id>> "id" associate link>string ] + [ date>> ] tri + f swap + ] map ; + +: pastebin-feed ( -- feed ) + feed new + "Factor Pastebin" >>title + "http://paste.factorcode.org" >>link + pastebin-feed-entries >>entries ; + +: ( -- action ) + + [ + "text/xml" + [ pastebin-feed feed>xml write-xml ] >>body + ] >>display ; + +:: ( form ctor -- action ) + + { { "id" [ v-number ] } } >>get-params + + [ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init + + [ form view-form ] >>display ; + +:: ( ctor next -- action ) + + { { "id" [ v-number ] } } >>post-params + + [ + "id" get ctor call delete-tuple + + "id" get f select-tuples [ delete-tuple ] each + + next f + ] >>submit ; + +:: ( ctor next -- action ) + + { { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params + + [ + "id" get "aid" get ctor call delete-tuple + + "id" get next + ] >>submit ; + +:: ( form ctor next -- action ) + + [ + f ctor call from-tuple + + form set-defaults + ] >>init + + [ form edit-form ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple insert-tuple + + "id" value next + ] >>submit ; + +TUPLE: pastebin < dispatcher ; + +: ( -- responder ) + pastebin new-dispatcher + "list" add-main-responder + "feed.xml" add-responder + [ ] "view-paste" add-responder + [ ] "$pastebin/list" "delete-paste" add-responder + [ ] "$pastebin/view-paste" "delete-annotation" add-responder + [ ] "$pastebin/view-paste" add-responder + [ now >>date ] "$pastebin/view-paste" "new-paste" add-responder + [ now >>date ] "$pastebin/view-paste" "annotate" add-responder + + "pastebin" pastebin-template >>template ; + +: init-pastes-table paste ensure-table ; + +: init-annotations-table annotation ensure-table ; diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml new file mode 100644 index 0000000000..99fede727e --- /dev/null +++ b/extra/webapps/pastebin/pastebin.xml @@ -0,0 +1,32 @@ + + + + + + + + +
+ Pastes + | New Paste + | Atom Feed + + + + + | Edit Profile + + + + | + + + + +
+ +

+ + + + diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 1a18cad94b..c79fe2efd1 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -4,10 +4,11 @@ Planet Factor Administration - +

- Add Blog | Update + Add Blog + | Update

diff --git a/extra/webapps/planet/blog-admin-link.xml b/extra/webapps/planet/blog-admin-link.xml index 712db4ba0d..8d6c890643 100644 --- a/extra/webapps/planet/blog-admin-link.xml +++ b/extra/webapps/planet/blog-admin-link.xml @@ -2,6 +2,6 @@ - + diff --git a/extra/webapps/planet/edit-blog.xml b/extra/webapps/planet/edit-blog.xml index 890b23dcce..b2eab2b0b4 100644 --- a/extra/webapps/planet/edit-blog.xml +++ b/extra/webapps/planet/edit-blog.xml @@ -4,25 +4,25 @@ Edit Blog - + - + - + - + - - + +
Blog name:
Home page:
Atom feed:Feed:
@@ -31,10 +31,8 @@ - View - | - - + + diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml index a87703252c..741b123456 100644 --- a/extra/webapps/planet/entry-summary.xml +++ b/extra/webapps/planet/entry-summary.xml @@ -3,8 +3,8 @@

-
- Read More... +
+ Read More...

diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml index bc89af3263..5e43717384 100644 --- a/extra/webapps/planet/entry.xml +++ b/extra/webapps/planet/entry.xml @@ -3,15 +3,15 @@

- +

- +

- +

diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 464e2bbfb3..0e9601461c 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences sorting locals math +USING: kernel accessors sequences sorting locals math math.order calendar alarms logging concurrency.combinators namespaces -db.types db.tuples db +sequences.lib db.types db.tuples db fry rss xml.writer http.server http.server.crud @@ -11,8 +11,7 @@ http.server.actions http.server.boilerplate http.server.templating.chloe http.server.components -http.server.auth.login -webapps.factor-website ; +http.server.auth.login ; IN: webapps.planet TUPLE: planet-factor < dispatcher postings ; @@ -20,7 +19,7 @@ TUPLE: planet-factor < dispatcher postings ; : planet-template ( name -- template ) "resource:extra/webapps/planet/" swap ".xml" 3append ; -TUPLE: blog id name www-url atom-url ; +TUPLE: blog id name www-url feed-url ; M: blog link-title name>> ; @@ -31,7 +30,7 @@ blog "BLOGS" { "id" "ID" INTEGER +native-id+ } { "name" "NAME" { VARCHAR 256 } +not-null+ } { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ } - { "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ } + { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ } } define-persistent : init-blog-table blog ensure-table ; @@ -54,7 +53,6 @@ blog "BLOGS" : ( -- form ) "blog" "edit-blog" planet-template >>edit-template - "view-blog" planet-template >>view-template "blog-admin-link" planet-template >>summary-template "id" hidden >>renderer @@ -65,7 +63,7 @@ blog "BLOGS" "www-url" t >>required add-field - "atom-url" + "feed-url" t >>required add-field ; @@ -106,14 +104,11 @@ blog "BLOGS" ] >>display ] ; -: safe-head ( seq n -- seq' ) - over length min head ; - :: planet-feed ( planet -- feed ) feed new - "[ planet-factor ]" >>title + "Planet Factor" >>title "http://planet.factorcode.org" >>link - planet postings>> 16 safe-head >>entries ; + planet postings>> 16 short head >>entries ; :: ( planet -- action ) @@ -132,7 +127,7 @@ blog "BLOGS" : fetch-blogroll ( blogroll -- entries ) dup - [ atom-url>> fetch-feed ] parallel-map + [ feed-url>> fetch-feed ] parallel-map [ >r name>> r> [ ] with map ] 2map concat ; : sort-entries ( entries -- entries' ) @@ -140,7 +135,7 @@ blog "BLOGS" : update-cached-postings ( planet -- ) "webapps.planet" [ - blogroll fetch-blogroll sort-entries 8 safe-head + blogroll fetch-blogroll sort-entries 8 short head >>postings drop ] with-logging ; @@ -157,32 +152,25 @@ blog "BLOGS" planet-factor >>default + planet-factor "update" add-responder + ! Administrative CRUD - blog-ctor "" "delete-blog" add-responder - blog-form blog-ctor "view-blog" add-responder - blog-form blog-ctor "view-blog" "edit-blog" add-responder + blog-ctor "$planet-factor/admin" "delete-blog" add-responder + blog-form blog-ctor "$planet-factor/admin" "edit-blog" add-responder ] ; : ( -- responder ) planet-factor new-dispatcher - dup >>default + dup "list" add-main-responder dup "feed.xml" add-responder - dup "update" add-responder dup "admin" add-responder "planet" planet-template >>template ; - -: ( -- responder ) - ; -: start-update-task ( planet -- ) - [ update-cached-postings ] curry 10 minutes every drop ; - -: init-planet ( -- ) - test-db [ - init-blog-table - ] with-db - - - "planet" add-responder - main-responder set-global ; +: start-update-task ( planet db seq -- ) + '[ + , , , [ + dup filter-responder? [ responder>> ] when + update-cached-postings + ] with-db + ] 10 minutes every drop ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 772f81906d..fdbfe6d841 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -3,25 +3,24 @@ - +
- Front Page - | Atom Feed + Front Page + | Atom Feed + | Admin - | Admin - - - - | Edit Profile + + + | Edit Profile + + + + | + - - - | - -

diff --git a/extra/webapps/planet/postings-summary.xml b/extra/webapps/planet/postings-summary.xml index 950191e4c3..765c3a8006 100644 --- a/extra/webapps/planet/postings-summary.xml +++ b/extra/webapps/planet/postings-summary.xml @@ -2,6 +2,6 @@ - + diff --git a/extra/webapps/planet/postings.xml b/extra/webapps/planet/postings.xml index f59a4f61b8..c2c73d7e89 100644 --- a/extra/webapps/planet/postings.xml +++ b/extra/webapps/planet/postings.xml @@ -6,12 +6,12 @@ - +

Blogroll

- +
diff --git a/extra/webapps/planet/view-blog.xml b/extra/webapps/planet/view-blog.xml deleted file mode 100644 index fbc03aff25..0000000000 --- a/extra/webapps/planet/view-blog.xml +++ /dev/null @@ -1,41 +0,0 @@ - - - - - View Blog - - - - - - - - - - - - - - - - - - -
Blog name:
Home page: - - - -
Atom feed: - - - -
- - Edit - | - - - - - - diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml index 71d6900f1a..ef1e1fd26a 100644 --- a/extra/webapps/todo/edit-todo.xml +++ b/extra/webapps/todo/edit-todo.xml @@ -4,21 +4,21 @@ Edit Item - + - - + +
Summary:
Priority:
Summary:
Priority:
Description:
 - View + View | - + diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml index 1887fccdc1..66abeafc86 100644 --- a/extra/webapps/todo/todo-list.xml +++ b/extra/webapps/todo/todo-list.xml @@ -6,7 +6,7 @@ - +
SummaryPriorityViewEdit
 diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml index 9e03b7f135..056c9cab0a 100644 --- a/extra/webapps/todo/todo-summary.xml +++ b/extra/webapps/todo/todo-summary.xml @@ -4,16 +4,16 @@ - + - + - View + View - Edit + Edit diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css index 2520a56128..26a0fe0960 100644 --- a/extra/webapps/todo/todo.css +++ b/extra/webapps/todo/todo.css @@ -1,15 +1,3 @@ -.big-field-label { - vertical-align: top; -} - -.description { - border: 1px dashed #ccc; - background-color: #f5f5f5; - padding: 5px; - font-size: 150%; - color: #000000; -} - pre { font-size: 75%; } diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 97af356dc5..5c60b37f82 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -7,8 +7,7 @@ http.server.forms http.server.templating.chloe http.server.boilerplate http.server.crud http.server.auth http.server.actions http.server.db http.server.auth.login -http.server -webapps.factor-website ; +http.server ; IN: webapps.todo TUPLE: todo uid id priority summary description ; @@ -58,29 +57,18 @@ todo "TODO" "list" +plain+ add-field ; -TUPLE: todo-responder < dispatcher ; +TUPLE: todo-list < dispatcher ; -:: ( -- responder ) +:: ( -- responder ) [let | todo-form [ ] list-form [ ] ctor [ [ ] ] | - todo-responder new-dispatcher + todo-list new-dispatcher list-form ctor "list" add-main-responder todo-form ctor "view" add-responder - todo-form ctor "view" "edit" add-responder - ctor "list" "delete" add-responder + todo-form ctor "$todo-list/view" "edit" add-responder + ctor "$todo-list/list" "delete" add-responder "todo" todo-template >>template + ] ; - -: ( -- responder ) - ; - -: init-todo ( -- ) - test-db [ - init-todo-table - ] with-db - - - "todo" add-responder - main-responder set-global ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 81a5d3a425..ff58b27df2 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -4,17 +4,15 @@ - -
- List Items - | Add Item + List Items + | Add Item - - | Edit Profile + + | Edit Profile - + |
diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml index fea77c1189..f77396c73c 100644 --- a/extra/webapps/todo/view-todo.xml +++ b/extra/webapps/todo/view-todo.xml @@ -10,13 +10,13 @@
- +
- Edit + Edit | - - + + diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index acd3848f10..14ce1acda6 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -46,7 +46,7 @@ unless : parse-com-functions ( -- functions ) ";" parse-tokens { ")" } split - [ empty? not ] subset + [ empty? not ] filter [ (parse-com-function) ] map ; : (iid-word) ( definition -- word ) diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor index 3b0db96d63..4c20d0fb42 100644 --- a/extra/windows/messages/messages.factor +++ b/extra/windows/messages/messages.factor @@ -7,7 +7,7 @@ IN: windows.messages SYMBOL: windows-messages "windows.messages" words -[ word-name "windows-message" head? not ] subset +[ word-name "windows-message" head? not ] filter [ dup execute swap ] { } map>assoc windows-messages set-global diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index a2ca25ce6e..9b1eeede96 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -1,4 +1,4 @@ -USING: sequences kernel namespaces splitting math ; +USING: sequences kernel namespaces splitting math math.order ; IN: wrap ! Very stupid word wrapping/line breaking @@ -8,7 +8,7 @@ IN: wrap SYMBOL: width : line-chunks ( string -- words-lines ) - "\n" split [ " \t" split [ empty? not ] subset ] map ; + "\n" split [ " \t" split [ empty? not ] filter ] map ; : (split-chunk) ( words -- ) -1 over [ length + 1+ dup width get > ] find drop nip diff --git a/extra/x/widgets/wm/root/root.factor b/extra/x/widgets/wm/root/root.factor index 2f6882304f..ff18862d05 100755 --- a/extra/x/widgets/wm/root/root.factor +++ b/extra/x/widgets/wm/root/root.factor @@ -37,7 +37,7 @@ dup >r $id dpy get $window-table at r> or ; : circulate-focus ( -- ) dpy get $default-root <- children -[ find-in-table ] map [ <- mapped? ] subset dup length 1 > +[ find-in-table ] map [ <- mapped? ] filter dup length 1 > [ reverse dup first <- lower drop second <- raise dup is? [ $child ] [ ] if @@ -48,7 +48,7 @@ if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : managed? ( id -- ? ) -dpy get $window-table values [ is? ] subset [ $id ] map member? ; +dpy get $window-table values [ is? ] filter [ $id ] map member? ; : event>keyname ( event -- keyname ) lookup-keysym keysym>name ; diff --git a/extra/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor b/extra/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor index e1b3c5dd82..214d45da6c 100644 --- a/extra/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor +++ b/extra/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor @@ -24,7 +24,7 @@ VAR: unmapped-frames-menu : unmapped-frames ( -- seq ) dpy get $window-table values -[ is? ] subset [ <- mapped? not ] subset ; +[ is? ] filter [ <- mapped? not ] filter ; { diff --git a/extra/x/widgets/wm/workspace/workspace.factor b/extra/x/widgets/wm/workspace/workspace.factor index f456c060f9..104021706f 100644 --- a/extra/x/widgets/wm/workspace/workspace.factor +++ b/extra/x/widgets/wm/workspace/workspace.factor @@ -18,7 +18,7 @@ VAR: current-workspace : add-workspace ( -- ) { } clone workspaces> push ; : mapped-windows ( -- seq ) -dpy get $default-root <- children [ <- mapped? ] subset ; +dpy get $default-root <- children [ <- mapped? ] filter ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/x11/events/events.factor b/extra/x11/events/events.factor index e7a5645f81..0a389c8034 100644 --- a/extra/x11/events/events.factor +++ b/extra/x11/events/events.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays hashtables io kernel math -namespaces prettyprint sequences strings combinators x11.xlib ; +math.order namespaces prettyprint sequences strings combinators +x11.xlib ; IN: x11.events GENERIC: expose-event ( event window -- ) diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor index d50cfa0d1e..d41f66739c 100755 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -IN: xml-rpc USING: kernel xml arrays math generic http.client combinators hashtables namespaces io base64 sequences strings calendar xml.data xml.writer xml.utilities assocs math.parser debugger - calendar.format ; + calendar.format math.order ; +IN: xml-rpc ! * Sending RPC requests ! TODO: time diff --git a/extra/xml/char-classes/char-classes.factor b/extra/xml/char-classes/char-classes.factor index ddf935a30b..4688e20767 100755 --- a/extra/xml/char-classes/char-classes.factor +++ b/extra/xml/char-classes/char-classes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences unicode.syntax math ; +USING: kernel sequences unicode.syntax math math.order ; IN: xml.char-classes CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_ ; diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor index 72ab7b1340..d85345b3c7 100644 --- a/extra/xml/tests/test.factor +++ b/extra/xml/tests/test.factor @@ -36,7 +36,7 @@ SYMBOL: xml-file ] unit-test [ "abcd" ] [ "
abcd
" string>xml - [ string? ] deep-subset concat + [ string? ] deep-filter concat ] unit-test [ "foo" ] [ "foo" string>xml diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index 5ba151c213..b4ff3a4ce9 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -162,7 +162,7 @@ SYMBOL: ns-stack T{ name f "" "version" f } T{ name f "" "encoding" f } T{ name f "" "standalone" f } - } swap diff + } diff dup empty? [ drop ] [ throw ] if ; : good-version ( version -- version ) diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index ed0773bd6f..87a0242412 100755 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -54,7 +54,7 @@ M: process-missing error. concat ; : children-tags ( tag -- sequence ) - tag-children [ tag? ] subset ; + tag-children [ tag? ] filter ; : first-child-tag ( tag -- tag ) tag-children [ tag? ] find nip ; @@ -73,7 +73,7 @@ M: process-missing error. assure-name [ swap tag-named? ] curry deep-find ; : deep-tags-named ( tag name/string -- tags-seq ) - tags@ [ swap tag-named? ] curry deep-subset ; + tags@ [ swap tag-named? ] curry deep-filter ; : tag-named ( tag name/string -- matching-tag ) ! like get-name-tag but only looks at direct children, @@ -81,7 +81,7 @@ M: process-missing error. assure-name swap [ tag-named? ] with find nip ; : tags-named ( tag name/string -- tags-seq ) - tags@ swap [ tag-named? ] with subset ; + tags@ swap [ tag-named? ] with filter ; : tag-with-attr? ( elem attr-value attr-name -- ? ) rot dup tag? [ at = ] [ 3drop f ] if ; @@ -90,13 +90,13 @@ M: process-missing error. assure-name [ tag-with-attr? ] 2curry find nip ; : tags-with-attr ( tag attr-value attr-name -- tags-seq ) - tags@ [ tag-with-attr? ] 2curry subset tag-children ; + tags@ [ tag-with-attr? ] 2curry filter tag-children ; : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag ) assure-name [ tag-with-attr? ] 2curry deep-find ; : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) - tags@ [ tag-with-attr? ] 2curry deep-subset ; + tags@ [ tag-with-attr? ] 2curry deep-filter ; : get-id ( tag id -- elem ) ! elem=tag.getElementById(id) "id" deep-tag-with-attr ; diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 44c92006a0..41e5422830 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -34,7 +34,7 @@ SYMBOL: indenter : ?filter-children ( children -- no-whitespace ) xml-pprint? get [ [ dup string? [ trim-whitespace ] when ] map - [ dup empty? swap string? and not ] subset + [ dup empty? swap string? and not ] filter ] when ; : print-name ( name -- ) diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index 61ef27b72e..2d7c8c8ff8 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -12,7 +12,7 @@ IN: xml SYMBOL: xml-stack : ( -- unclosed ) - xml-stack get 1 tail-slice [ first opener-name ] map + xml-stack get rest-slice [ first opener-name ] map { set-unclosed-tags } unclosed construct ; : add-child ( object -- ) @@ -72,7 +72,7 @@ M: closer process reset-prolog init-xml-stack init-ns-stack ; : assert-blanks ( seq pre? -- ) - swap [ string? ] subset + swap [ string? ] filter [ dup [ blank? ] all? [ drop ] [ swap 
 throw ] if
@@ -93,7 +93,7 @@ M: closer process
 
 : make-xml-doc ( prolog seq -- xml-doc )
     dup [ tag? ] find
-    >r assure-tags cut 1 tail
+    >r assure-tags cut rest
     no-pre/post no-post-tags
     r> swap  ;
 
diff --git a/extra/xmode/keyword-map/keyword-map.factor b/extra/xmode/keyword-map/keyword-map.factor
index a6ef34a1f9..f786209865 100644
--- a/extra/xmode/keyword-map/keyword-map.factor
+++ b/extra/xmode/keyword-map/keyword-map.factor
@@ -26,7 +26,7 @@ M: keyword-map clear-assoc
 M: keyword-map >alist delegate >alist ;
 
 : (keyword-map-no-word-sep)
-    keys concat [ alpha? not ] subset prune natural-sort ;
+    keys concat [ alpha? not ] filter prune natural-sort ;
 
 : keyword-map-no-word-sep* ( keyword-map -- str )
     dup keyword-map-no-word-sep [ ] [
diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor
index 57a8a5ac16..99689d8819 100755
--- a/extra/xmode/utilities/utilities-tests.factor
+++ b/extra/xmode/utilities/utilities-tests.factor
@@ -35,7 +35,7 @@ TAGS>
         { { "type" >upper set-company-type } }
         init-from-tag dup
     ] keep
-    tag-children [ tag? ] subset
+    tag-children [ tag? ] filter
     [ parse-employee-tag ] with each ;
 
 [
diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor
index f7c8606420..db59465b7b 100644
--- a/extra/xmode/utilities/utilities.factor
+++ b/extra/xmode/utilities/utilities.factor
@@ -4,7 +4,7 @@ IN: xmode.utilities
 
 : implies >r not r> or ; inline
 
-: child-tags ( tag -- seq ) tag-children [ tag? ] subset ;
+: child-tags ( tag -- seq ) tag-children [ tag? ] filter ;
 
 : map-find ( seq quot -- result elt )
     f -rot
@@ -13,7 +13,7 @@ IN: xmode.utilities
 
 : tag-init-form ( spec -- quot )
     {
-        { [ dup quotation? ] [ [ object get tag get ] swap compose ] }
+        { [ dup quotation? ] [ [ object get tag get ] prepose ] }
         { [ dup length 2 = ] [
             first2 [
                 >r >r tag get children>string
@@ -29,7 +29,7 @@ IN: xmode.utilities
     } cond ;
 
 : with-tag-initializer ( tag obj quot -- )
-    [ object set tag set ] swap compose with-scope ; inline
+    [ object set tag set ] prepose with-scope ; inline
 
 MACRO: (init-from-tag) ( specs -- )
     [ tag-init-form ] map concat [ ] like
diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor
index 1725c10a44..89f937d847 100644
--- a/extra/yahoo/yahoo.factor
+++ b/extra/yahoo/yahoo.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: http.client xml xml.utilities kernel sequences
-namespaces http math.parser help ;
+namespaces http math.parser help math.order ;
 IN: yahoo
 
 TUPLE: result title url summary ;
diff --git a/extra/shufflers/authors.txt b/unmaintained/shufflers/authors.txt
similarity index 100%
rename from extra/shufflers/authors.txt
rename to unmaintained/shufflers/authors.txt
diff --git a/extra/shufflers/shufflers-docs.factor b/unmaintained/shufflers/shufflers-docs.factor
similarity index 100%
rename from extra/shufflers/shufflers-docs.factor
rename to unmaintained/shufflers/shufflers-docs.factor
diff --git a/extra/shufflers/shufflers-tests.factor b/unmaintained/shufflers/shufflers-tests.factor
similarity index 90%
rename from extra/shufflers/shufflers-tests.factor
rename to unmaintained/shufflers/shufflers-tests.factor
index 5bcdab8068..753f35b2e6 100644
--- a/extra/shufflers/shufflers-tests.factor
+++ b/unmaintained/shufflers/shufflers-tests.factor
@@ -1,4 +1,5 @@
 USING: shufflers tools.test ;
+IN: shufflers.tests
 
 SHUFFLE: abcd 4
 [ ] [ 1 2 3 4 abcd- ] unit-test
diff --git a/extra/shufflers/shufflers.factor b/unmaintained/shufflers/shufflers.factor
similarity index 100%
rename from extra/shufflers/shufflers.factor
rename to unmaintained/shufflers/shufflers.factor
diff --git a/extra/shufflers/summary.txt b/unmaintained/shufflers/summary.txt
similarity index 100%
rename from extra/shufflers/summary.txt
rename to unmaintained/shufflers/summary.txt
diff --git a/extra/shufflers/tags.txt b/unmaintained/shufflers/tags.txt
similarity index 100%
rename from extra/shufflers/tags.txt
rename to unmaintained/shufflers/tags.txt
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index b2cbf9b6b5..5cdfbb2a9e 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -255,7 +255,7 @@ static int global_var;
 
 void ffi_test_36_point_5(void)
 {
-	printf("int_ffi_test_36_point_5\n");
+	printf("ffi_test_36_point_5\n");
 	global_var = 0;
 }
 
diff --git a/vm/ffi_test.h b/vm/ffi_test.h
index d455d999b1..0f51092d25 100755
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -62,7 +62,7 @@ struct test_struct_12 { int a; double x; };
 
 DLLEXPORT double ffi_test_36(struct test_struct_12 x);
 
-DLLEXPORT void int_ffi_test_36_point_5(void);
+DLLEXPORT void ffi_test_36_point_5(void);
 
 DLLEXPORT int ffi_test_37(int (*f)(int, int, int));