From d2d2c5d84fbf6eaa2c5150067fd19dc8f6a314c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 20:00:04 -0500 Subject: [PATCH 01/55] fix using in hardware-info --- extra/hardware-info/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 ) From 8a0909d84923ce59a47e5322e449eb1c149d2768 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 20:09:36 -0500 Subject: [PATCH 02/55] fix ffi test int ffi test 36 point 5 --- core/alien/compiler/compiler-tests.factor | 750 +++++++++++----------- vm/ffi_test.c | 2 +- 2 files changed, 376 insertions(+), 376 deletions(-) diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 3d0f36e415..57bf163443 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 int_ffi_test_36_point_5 ( ) ; + +[ ] [ int_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/vm/ffi_test.c b/vm/ffi_test.c index b2cbf9b6b5..4293a6bbae 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -253,7 +253,7 @@ double ffi_test_36(struct test_struct_12 x) static int global_var; -void ffi_test_36_point_5(void) +void int_ffi_test_36_point_5(void) { printf("int_ffi_test_36_point_5\n"); global_var = 0; From f9659ecc7c412eaf986d14fd19b6d29c6de3d230 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 22 Apr 2008 23:45:30 -0700 Subject: [PATCH 03/55] Add sequences.lib.replicate --- extra/sequences/lib/lib.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index b186ee7777..c648660d66 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -131,6 +131,10 @@ MACRO: firstn ( n -- ) [ find drop [ head-slice ] when* ] curry [ dup ] swap compose keep like ; +: replicate ( seq quot -- newseq ) + #! quot: ( -- obj ) + [ drop ] swap compose map ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Date: Wed, 23 Apr 2008 02:46:21 -0500 Subject: [PATCH 04/55] use sqlite_prepare_v2 (freebsd64 now has this symbol too) --- extra/db/sqlite/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e5562700c9..b6078fc983 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 ) From ca1484b94c72b372081483c0e00485ddc1cde38a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 23 Apr 2008 17:07:37 -0500 Subject: [PATCH 05/55] fix ffi test --- core/alien/compiler/compiler-tests.factor | 4 ++-- vm/ffi_test.c | 4 ++-- vm/ffi_test.h | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 57bf163443..5d847e364f 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -364,9 +364,9 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; + + 1+ ] alien-callback ; -FUNCTION: void int_ffi_test_36_point_5 ( ) ; +FUNCTION: void ffi_test_36_point_5 ( ) ; -[ ] [ int_ffi_test_36_point_5 ] unit-test +[ ] [ ffi_test_36_point_5 ] unit-test FUNCTION: int ffi_test_37 ( void* func ) ; diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 4293a6bbae..5cdfbb2a9e 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -253,9 +253,9 @@ double ffi_test_36(struct test_struct_12 x) static int global_var; -void int_ffi_test_36_point_5(void) +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)); From d9efbb550dde98f29a2b1f7f042e2e606de2af96 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 19:40:17 -0500 Subject: [PATCH 06/55] Fix db inference --- extra/db/db-tests.factor | 1 + extra/db/db.factor | 1 + extra/db/tuples/tuples-tests.factor | 5 ++++- extra/db/tuples/tuples.factor | 2 +- 4 files changed, 7 insertions(+), 2 deletions(-) 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..91128a7ffb 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -131,6 +131,7 @@ 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 ; + inline : default-query ( query -- result-set ) query-results [ [ sql-row ] query-map ] with-disposal ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 32562a4ae8..557241f3c9 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 @@ -363,3 +363,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 ; From 358bbab86171e248dc202018333a9cbd6e8f5759 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 23 Apr 2008 22:23:22 -0500 Subject: [PATCH 07/55] fix timestamps in db --- extra/db/postgresql/lib/lib.factor | 15 ++++++++++----- extra/db/sqlite/lib/lib.factor | 8 ++++---- extra/db/tuples/tuples-tests.factor | 25 +++++++++++++++++++++---- 3 files changed, 35 insertions(+), 13 deletions(-) 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/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index b6078fc983..9f29b9e6fb 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -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..b166bdc28c 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -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 ; From 857ecda0eb1454d95b2997b4d9f82d921291b220 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Apr 2008 02:48:48 -0500 Subject: [PATCH 08/55] Improve error messages for mirrors --- core/debugger/debugger.factor | 6 +++++- core/mirrors/mirrors-docs.factor | 4 ---- core/mirrors/mirrors-tests.factor | 14 +++++++++++++- core/mirrors/mirrors.factor | 29 ++++++++++++++--------------- 4 files changed, 32 insertions(+), 21 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 827a5c4e8d..f2740a63a9 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -6,7 +6,7 @@ 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 ; IN: debugger GENERIC: error. ( error -- ) @@ -289,6 +289,10 @@ 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" ; + } } ; -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 ) From 916ed96ffb81b052ad9cdcbb41e982a64664c0ae Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 22 Apr 2008 01:44:50 -0700 Subject: [PATCH 09/55] Add project-euler.151 --- extra/project-euler/151/151.factor | 40 ++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 extra/project-euler/151/151.factor diff --git a/extra/project-euler/151/151.factor b/extra/project-euler/151/151.factor new file mode 100644 index 0000000000..85aad116b4 --- /dev/null +++ b/extra/project-euler/151/151.factor @@ -0,0 +1,40 @@ +! Copyright (c) 2008 Eric Mertens +! See http://factorcode.org/license.txt for BSD license. +USING: sequences combinators kernel sequences.lib math assocs namespaces ; +IN: project-euler.151 + +SYMBOL: table + +: (pick-sheet) ( seq i -- newseq ) + [ + <=> 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 ; From 57a15fb363f5f03c8f49e033879bb755763d9299 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 22 Apr 2008 01:45:29 -0700 Subject: [PATCH 10/55] Add project-euler.100 --- extra/project-euler/100/100.factor | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 extra/project-euler/100/100.factor 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 ; From 6fa498f5cb2d653583f32cb932120bfb0ee8b60c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Apr 2008 14:49:31 -0500 Subject: [PATCH 11/55] Add 'short' word --- extra/sequences/lib/lib.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index b186ee7777..40768e58e2 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -236,3 +236,6 @@ PRIVATE> : remove-nth ( seq n -- seq' ) cut-slice 1 tail-slice append ; + +: short ( seq n -- seq n' ) + over length min ; inline From b1016e6ea5355cb867c5f1a2af22c16916aca15f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 24 Apr 2008 19:46:52 -0500 Subject: [PATCH 12/55] and mmaped-file use normalize-path now --- extra/io/monitors/monitors.factor | 2 +- extra/io/unix/mmap/mmap.factor | 4 ++-- extra/io/windows/mmap/mmap.factor | 1 + 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 863c8fc95c..fb404f24f5 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -39,7 +39,7 @@ M: monitor set-timeout (>>timeout) ; HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) : ( path recursive? -- monitor ) - (monitor) ; + >r normalize-path r> (monitor) ; : next-change ( monitor -- path changed ) [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 2815a49cd3..332c1927c8 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien io io.files kernel math system unix io.unix.backend -io.mmap ; +io.mmap io.backend ; IN: io.unix.mmap : open-r/w ( path -- fd ) O_RDWR file-mode open dup io-error ; @@ -11,7 +11,7 @@ IN: io.unix.mmap over MAP_FAILED = [ close (io-error) ] when ; M: unix ( path length -- obj ) - swap >r + swap normalize-path >r dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor r> mmap-open f mapped-file boa ; diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 0164ed1697..96b68d5a6d 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -61,6 +61,7 @@ M: wince with-privileges nip call ; : mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) + >r >r >r >r normalize-path r> r> r> r> { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ >r >r 0 open-file dup f r> 0 0 f CreateFileMapping [ win32-error=0/f ] keep From e5575e0dc076979eba0aba6c0873b7d1a4b70751 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 24 Apr 2008 20:13:18 -0500 Subject: [PATCH 13/55] use host-name if smtp-host symbol not set --- extra/smtp/smtp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 ; From 9318726fc23c78a9248480285583f7dd2be5a4ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 24 Apr 2008 20:16:45 -0500 Subject: [PATCH 14/55] use normalize-path in mmap tests --- extra/io/mmap/mmap-tests.factor | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) 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 + + From ad0139ac0c847421474a3808ed309bef6561a059 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 25 Apr 2008 00:23:49 -0500 Subject: [PATCH 15/55] default vocab is now f when parsing files --- core/parser/parser-docs.factor | 16 +++++++++++----- core/parser/parser.factor | 17 ++++++++++++----- 2 files changed, 23 insertions(+), 10 deletions(-) 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.factor b/core/parser/parser.factor index 7639ebaa69..961fa89d8f 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 ; @@ -440,8 +448,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 From b440bda681762dfca5f0eeea84121d62decb5a36 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 25 Apr 2008 00:25:37 -0500 Subject: [PATCH 16/55] error message --- extra/math/miller-rabin/miller-rabin.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index 7835277b9b..a1f90d74c9 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -1,4 +1,4 @@ -USING: combinators combinators.lib io locals kernel math +eSING: combinators combinators.lib io locals kernel math math.functions math.ranges namespaces random sequences hashtables sets ; IN: math.miller-rabin @@ -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 ; From 13c2e444a8d53dcd42d8e49be369a240adb95337 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 25 Apr 2008 00:59:44 -0500 Subject: [PATCH 17/55] normalize-path on windows file monitor --- extra/io/monitors/monitors.factor | 2 +- extra/io/windows/nt/monitors/monitors.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index fb404f24f5..863c8fc95c 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -39,7 +39,7 @@ M: monitor set-timeout (>>timeout) ; HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) : ( path recursive? -- monitor ) - >r normalize-path r> (monitor) ; + (monitor) ; : next-change ( monitor -- path changed ) [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ; 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 From 9e3cab4327d61741a3e4b9a50393da1690644a8d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 25 Apr 2008 01:10:40 -0500 Subject: [PATCH 18/55] move normalize-path to (mapped-file) is now the hook --- extra/io/mmap/mmap.factor | 5 ++++- extra/io/unix/mmap/mmap.factor | 4 ++-- extra/io/windows/mmap/mmap.factor | 3 +-- 3 files changed, 7 insertions(+), 5 deletions(-) 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/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 332c1927c8..72ff107f8f 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -10,8 +10,8 @@ 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 ) - swap normalize-path >r +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/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 96b68d5a6d..dc29405b12 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -61,7 +61,6 @@ M: wince with-privileges nip call ; : mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) - >r >r >r >r normalize-path r> r> r> r> { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ >r >r 0 open-file dup f r> 0 0 f CreateFileMapping [ win32-error=0/f ] keep @@ -71,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 From c56cf86793f080aa0728e15b4f67c12fecebfc88 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Thu, 24 Apr 2008 23:11:21 -0700 Subject: [PATCH 19/55] make sequences.lib.replicate inline --- extra/sequences/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index fe2c660d54..e534a204b1 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -133,7 +133,7 @@ MACRO: firstn ( n -- ) : replicate ( seq quot -- newseq ) #! quot: ( -- obj ) - [ drop ] swap compose map ; + [ drop ] swap compose map ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 9f97ae2b0c348304be99b08191b8bd2d3ddf047a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 25 Apr 2008 01:54:42 -0500 Subject: [PATCH 20/55] add unit test for parser --- core/parser/parser-tests.factor | 3 +++ 1 file changed, 3 insertions(+) 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 From a9c9f268220e2c86cce26511baa142acea338a95 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 25 Apr 2008 01:55:24 -0500 Subject: [PATCH 21/55] remove extra using --- extra/io/unix/mmap/mmap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 72ff107f8f..ada1f94d87 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien io io.files kernel math system unix io.unix.backend -io.mmap io.backend ; +io.mmap ; IN: io.unix.mmap : open-r/w ( path -- fd ) O_RDWR file-mode open dup io-error ; From a8e8b0533901a75f33d87f5495d9383b74d41ebf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 25 Apr 2008 03:23:47 -0500 Subject: [PATCH 22/55] Improved HTTP server dispatcher --- extra/http/http-tests.factor | 62 ++++- .../http/server/actions/actions-tests.factor | 26 +- extra/http/server/actions/actions.factor | 21 +- extra/http/server/auth/login/login.factor | 16 +- .../server/callbacks/callbacks-tests.factor | 8 +- extra/http/server/components/code/code.factor | 18 ++ .../http/server/components/components.factor | 23 ++ extra/http/server/server-tests.factor | 82 +++++- extra/http/server/server.factor | 75 ++++-- .../server/sessions/sessions-tests.factor | 10 +- extra/http/server/static/static.factor | 32 +-- .../http/server/templating/chloe/chloe.factor | 3 +- .../factor-website/factor-website.factor | 51 +++- extra/webapps/factor-website/page.xml | 14 + extra/webapps/pastebin/annotation.xml | 23 ++ extra/webapps/pastebin/authors.txt | 1 + extra/webapps/pastebin/new-annotation.xml | 25 ++ extra/webapps/pastebin/new-paste.xml | 23 ++ extra/webapps/pastebin/paste-list.xml | 15 ++ extra/webapps/pastebin/paste-summary.xml | 11 + extra/webapps/pastebin/paste.xml | 27 ++ extra/webapps/pastebin/pastebin.css | 7 + extra/webapps/pastebin/pastebin.factor | 253 ++++++++++++++++++ extra/webapps/pastebin/pastebin.xml | 29 ++ extra/webapps/planet/admin.xml | 3 +- extra/webapps/planet/blog-admin-link.xml | 2 +- extra/webapps/planet/edit-blog.xml | 10 +- extra/webapps/planet/planet.factor | 45 +--- extra/webapps/planet/planet.xml | 13 +- extra/webapps/planet/view-blog.xml | 41 --- extra/webapps/todo/edit-todo.xml | 10 +- extra/webapps/todo/todo-summary.xml | 4 +- extra/webapps/todo/todo.css | 12 - extra/webapps/todo/todo.factor | 25 +- extra/webapps/todo/todo.xml | 10 +- extra/webapps/todo/view-todo.xml | 4 +- 36 files changed, 783 insertions(+), 251 deletions(-) create mode 100644 extra/http/server/components/code/code.factor create mode 100644 extra/webapps/pastebin/annotation.xml create mode 100755 extra/webapps/pastebin/authors.txt create mode 100644 extra/webapps/pastebin/new-annotation.xml create mode 100644 extra/webapps/pastebin/new-paste.xml create mode 100644 extra/webapps/pastebin/paste-list.xml create mode 100644 extra/webapps/pastebin/paste-summary.xml create mode 100644 extra/webapps/pastebin/paste.xml create mode 100644 extra/webapps/pastebin/pastebin.css create mode 100644 extra/webapps/pastebin/pastebin.factor create mode 100644 extra/webapps/pastebin/pastebin.xml delete mode 100644 extra/webapps/planet/view-blog.xml diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 3a50630335..473bc964d3 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -133,16 +133,20 @@ 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 +USING: http.server http.server.static http.server.sessions +http.server.actions http.server.auth.login http.client +io.server io.files io accessors namespaces threads io.encodings.ascii ; +: add-quit-action + + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display + "quit" add-responder ; + [ ] [ [ - - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display - "quit" add-responder + add-quit-action "extra/http/test" resource-path >>default "nested" add-responder @@ -176,3 +180,51 @@ io.encodings.ascii ; [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +! Dispatcher bugs +[ ] [ + [ + + + + "" add-responder + add-quit-action + + "a" add-main-responder + "d" add-responder + 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 + + "" add-responder + add-quit-action + 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/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 90e632d7f5..615077821a 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 @@ -25,27 +25,5 @@ blah 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..bfcbd20cca 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 @@ -39,12 +39,15 @@ TUPLE: action init display submit get-params post-params ; 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-params params set + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] [ + <404> + ] if ] with-exit-continuation ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 7593f217f7..1b6ceeb51b 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -60,7 +60,7 @@ M: user-saver dispose : successful-login ( user -- response ) logged-in-user sset - post-login-url sget "" or f + post-login-url sget "$login" or f f post-login-url sset ; :: ( -- action ) @@ -162,10 +162,12 @@ SYMBOL: previous-page [ 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 @@ -190,6 +192,8 @@ SYMBOL: previous-page "realname" value >>realname "email" value >>email + drop + user-profile-changed? on previous-page sget f @@ -329,7 +333,7 @@ SYMBOL: lost-password-from [ f logged-in-user sset - "login" f + "$login/login" f ] >>submit ; ! ! ! Authentication logic @@ -340,7 +344,7 @@ C: protected : show-login-page ( -- response ) request get request-url post-login-url sset - "login" f ; + "$login/login" f ; M: protected call-responder ( path responder -- response ) logged-in-user sget dup [ diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor index 4cad097cf5..498f120cd8 100755 --- a/extra/http/server/callbacks/callbacks-tests.factor +++ b/extra/http/server/callbacks/callbacks-tests.factor @@ -8,7 +8,7 @@ splitting kernel hashtables continuations ; "GET" >>method request set [ exit-continuation set - "xxx" + { } [ [ "hello" print 123 ] show-final ] >>display call-responder @@ -31,7 +31,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 +44,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set - "/" + { } "r" get call-responder ] callcc1 @@ -57,7 +57,7 @@ splitting kernel hashtables continuations ; [ exit-continuation set - "/" + { } "r" get call-responder ] callcc1 ] unit-test 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/server-tests.factor b/extra/http/server/server-tests.factor index 346a31f30f..84e873d001 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 @@ -29,7 +31,9 @@ M: mock-responder call-responder "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 +48,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 +64,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 +73,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..88a748d949 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,9 +4,11 @@ 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 +! path is a sequence of path component strings + GENERIC: call-responder ( path responder -- response ) : request-params ( -- assoc ) @@ -52,13 +54,39 @@ 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 ; + SYMBOL: link-hook : modify-query ( query -- query ) link-hook get [ ] or 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 ; @@ -71,8 +99,9 @@ SYMBOL: form-hook : 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 +111,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 ; @@ -113,22 +143,17 @@ 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 ; + over empty? [ + "" over responders>> at* + [ nip ] [ drop default>> ] if + ] [ + over first over responders>> at* + [ >r drop 1 tail-slice r> ] [ drop default>> ] if + ] if ; M: dispatcher call-responder ( path dispatcher -- response ) - over [ - find-responder call-responder - ] [ - 2drop redirect-with-/ - ] if ; + [ add-base-path ] [ find-responder call-responder ] 2bi ; TUPLE: vhost-dispatcher default responders ; @@ -142,15 +167,13 @@ TUPLE: vhost-dispatcher default responders ; 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 ; SYMBOL: main-responder @@ -197,11 +220,15 @@ SYMBOL: exit-continuation : with-exit-continuation ( quot -- ) '[ exit-continuation set @ ] callcc1 exit-continuation off ; +: split-path ( string -- path ) + "/" split [ empty? not ] subset ; + : do-request ( request -- response ) [ + H{ } clone base-paths set [ log-request ] [ request set ] - [ path>> main-responder get call-responder ] tri + [ 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..02dee1f7e0 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -61,7 +61,7 @@ M: foo call-responder "GET" >>method request set - "/etc" "manager" get call-responder + { "etc" } "manager" get call-responder response set ] unit-test @@ -76,7 +76,7 @@ M: foo call-responder "id" get session-id-key set-query-param "/" >>path request set - "/" "manager" get call-responder + { } "manager" get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; @@ -96,7 +96,7 @@ M: foo call-responder "GET" >>method "/" >>path request set - "/etc" "manager" get call-responder response set + { "etc" } "manager" get call-responder response set [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test response get ] with-destructors @@ -111,7 +111,7 @@ response set "cookies" get >>cookies "/" >>path request set - "/" "manager" get call-responder + { } "manager" get call-responder [ write-response-body drop ] with-string-writer ] with-destructors ; @@ -134,7 +134,7 @@ response set request set [ - "/" + { } call-responder ] with-destructors response set ] unit-test diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 2d4a97c3c0..1605144b61 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 ) 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.factor b/extra/http/server/templating/chloe/chloe.factor index 685988dfaf..3793604929 100644 --- a/extra/http/server/templating/chloe/chloe.factor +++ b/extra/http/server/templating/chloe/chloe.factor @@ -104,7 +104,8 @@ SYMBOL: tags : form-start-tag ( tag -- )
hidden-form-field ; diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 3483d4321e..d78fd4b6c2 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -1,21 +1,25 @@ ! 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.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 ; - : ( responder -- responder' ) users-in-db >>users @@ -28,11 +32,40 @@ IN: webapps.factor-website sessions-in-db >>sessions test-db ; +: ( -- responder ) + ; + +: ( -- responder ) + ; + +: ( -- responder ) + ; + +: init-factor-db ( -- ) + test-db [ + init-users-table + init-sessions-table + + init-pastes-table + init-annotations-table + + init-blog-table + + init-todo-table + ] with-db ; + +: ( -- responder ) + + "todo" add-responder + "pastebin" add-responder + "planet" add-responder ; + : init-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 + + "planet" main-responder get responders>> at start-update-task ; diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml index d929042320..2f67b5e857 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..af6a835a64 --- /dev/null +++ b/extra/webapps/pastebin/annotation.xml @@ -0,0 +1,23 @@ + + + + +

Annotation:

+ + + + + +
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..4afc5cfec5 --- /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..4b2b4a46ce --- /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..12b926c7d1 --- /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..952d0de73d --- /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..89d1891221 --- /dev/null +++ b/extra/webapps/pastebin/paste.xml @@ -0,0 +1,27 @@ + + + + + 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..4fa8f55ca8 --- /dev/null +++ b/extra/webapps/pastebin/pastebin.factor @@ -0,0 +1,253 @@ +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.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..2d335fe9ce --- /dev/null +++ b/extra/webapps/pastebin/pastebin.xml @@ -0,0 +1,29 @@ + + + + + + + + +
+ Pastes + | New Paste + | Atom Feed + + + + | Edit Profile + + + + | + + +
+ +

+ + + + diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 1a18cad94b..3bd406ee38 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -7,7 +7,8 @@

- 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..a92af8dd1d 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..83273540a5 100644 --- a/extra/webapps/planet/edit-blog.xml +++ b/extra/webapps/planet/edit-blog.xml @@ -4,7 +4,7 @@ Edit Blog - + @@ -21,8 +21,8 @@ - Atom feed: - + Feed: + @@ -31,9 +31,7 @@ - View - | - + diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 464e2bbfb3..3cd35be5fb 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sorting locals math calendar alarms logging concurrency.combinators namespaces -db.types db.tuples db +sequences.lib db.types db.tuples db 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,20 @@ 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 ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 772f81906d..c96a143246 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -3,22 +3,21 @@ - +
- Front Page - | Atom Feed - - | Admin + Front Page + | Atom Feed + | Admin - | Edit Profile + | Edit Profile - + | 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-summary.xml b/extra/webapps/todo/todo-summary.xml index 9e03b7f135..008b0acaf5 100644 --- a/extra/webapps/todo/todo-summary.xml +++ b/extra/webapps/todo/todo-summary.xml @@ -10,10 +10,10 @@ - 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..bb4a4b9cd2 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,17 @@ 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..70bbb1250b 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..e8c2fd3983 100644 --- a/extra/webapps/todo/view-todo.xml +++ b/extra/webapps/todo/view-todo.xml @@ -13,9 +13,9 @@
- Edit + Edit | - + From 3ea844b9f2b257842c0839c77c1417000e3e48f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 25 Apr 2008 03:23:56 -0500 Subject: [PATCH 23/55] Better error message --- core/debugger/debugger.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index f2740a63a9..8360019646 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -293,6 +293,8 @@ 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" ; + Date: Fri, 25 Apr 2008 15:56:15 -0500 Subject: [PATCH 24/55] fix typo --- extra/math/miller-rabin/miller-rabin.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index a1f90d74c9..c668806fc2 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -1,4 +1,4 @@ -eSING: combinators combinators.lib io locals kernel math +USING: combinators combinators.lib io locals kernel math math.functions math.ranges namespaces random sequences hashtables sets ; IN: math.miller-rabin From 15402ed1b4c876dbe5d3fc465e87292a79f670f4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 25 Apr 2008 23:12:44 -0500 Subject: [PATCH 25/55] core changes: index* -> index-from last-index* -> last-index-from 1 tail -> rest 1 tail-slice -> rest-slice subset -> filter prepose find* -> find-from find-last* -> find-last-from before, after generic, < for integers make between? work for timestamps --- core/alien/syntax/syntax.factor | 2 +- core/assocs/assocs-docs.factor | 4 +- core/assocs/assocs-tests.factor | 4 +- core/assocs/assocs.factor | 8 +- core/bootstrap/compiler/compiler.factor | 4 +- core/bootstrap/image/image.factor | 2 +- core/bootstrap/primitives.factor | 2 +- core/bootstrap/stage2.factor | 4 +- core/classes/algebra/algebra.factor | 4 +- core/classes/classes.factor | 2 +- core/classes/mixin/mixin.factor | 2 +- core/classes/tuple/tuple.factor | 2 +- core/combinators/combinators.factor | 4 +- core/command-line/command-line.factor | 2 +- core/compiler/errors/errors.factor | 2 +- core/compiler/tests/intrinsics.factor | 4 +- core/compiler/tests/stack-trace.factor | 4 +- core/compiler/units/units.factor | 4 +- core/cpu/x86/64/64.factor | 2 +- core/cpu/x86/architecture/architecture.factor | 3 +- core/cpu/x86/assembler/assembler.factor | 2 +- core/debugger/debugger.factor | 3 +- core/definitions/definitions-tests.factor | 2 +- core/dlists/dlists.factor | 2 +- core/generator/fixup/fixup.factor | 2 +- core/generator/registers/registers.factor | 6 +- core/generic/generic-tests.factor | 8 +- core/generic/generic.factor | 4 +- core/generic/math/math.factor | 2 +- core/generic/standard/engines/engines.factor | 4 +- core/hashtables/hashtables-tests.factor | 2 +- core/heaps/heaps-docs.factor | 3 +- core/heaps/heaps.factor | 2 +- core/inference/backend/backend.factor | 6 +- core/inference/class/class.factor | 2 +- core/inference/dataflow/dataflow.factor | 2 +- core/inspector/inspector.factor | 2 +- core/io/files/files-tests.factor | 4 +- core/io/files/files.factor | 6 +- core/io/streams/string/string.factor | 2 +- core/kernel/kernel-docs.factor | 23 +----- core/kernel/kernel.factor | 7 +- core/layouts/layouts.factor | 2 +- core/math/intervals/intervals-docs.factor | 2 +- core/math/intervals/intervals-tests.factor | 4 +- core/math/intervals/intervals.factor | 2 +- core/math/math-docs.factor | 39 --------- core/math/math.factor | 22 +---- core/optimizer/backend/backend.factor | 2 +- core/optimizer/control/control.factor | 4 +- core/optimizer/def-use/def-use.factor | 4 +- core/optimizer/math/partial/partial.factor | 4 +- .../specializers/specializers.factor | 2 +- core/parser/parser.factor | 12 +-- core/prettyprint/backend/backend.factor | 2 +- core/prettyprint/prettyprint.factor | 2 +- core/prettyprint/sections/sections.factor | 4 +- core/quotations/quotations.factor | 6 +- core/sequences/sequences-docs.factor | 45 +++++++---- core/sequences/sequences-tests.factor | 21 +++-- core/sequences/sequences.factor | 80 ++++++++++--------- core/sets/sets.factor | 4 +- core/slots/deprecated/deprecated.factor | 2 +- core/sorting/sorting-docs.factor | 5 +- core/sorting/sorting.factor | 2 +- core/source-files/source-files.factor | 2 +- core/splitting/splitting.factor | 4 +- core/strings/strings-tests.factor | 2 + core/threads/threads.factor | 5 +- core/vocabs/vocabs.factor | 4 +- core/words/words-tests.factor | 4 +- core/words/words.factor | 11 +-- 72 files changed, 205 insertions(+), 260 deletions(-) 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..f06cc70613 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." } ; 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..a58dfea900 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 ; + swap [ 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..46ed34c35c 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 ) 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..8e16417ca6 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -23,12 +23,12 @@ SYMBOL: bootstrap-time : load-components ( -- ) "exclude" "include" - [ get-global " " split [ empty? not ] subset ] bi@ + [ get-global " " split [ empty? not ] filter ] bi@ diff [ "bootstrap." prepend require ] each ; : count-words ( pred -- ) - all-words swap subset length number>string write ; + all-words swap filter length number>string write ; : print-report ( time -- ) 1000 /i 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.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/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..f4aef6292d 100644 --- a/core/command-line/command-line.factor +++ b/core/command-line/command-line.factor @@ -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/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 8360019646..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 mirrors accessors ; +init kernel.private libc io.encodings mirrors accessors +math.order ; IN: debugger GENERIC: error. ( error -- ) diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index b20d81ec7c..b2d265a2e3 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -1,6 +1,6 @@ -IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units words ; +IN: definitions.tests GENERIC: some-generic ( a -- b ) 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..4753f18c9a 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 ) @@ -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/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.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.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..7fa2080661 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 -- ? ) @@ -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/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.factor b/core/parser/parser.factor index 961fa89d8f..1cfe6d63d9 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 -- ) @@ -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? @@ -270,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+) ; @@ -278,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 @@ -516,7 +516,7 @@ SYMBOL: interactive-vocabs 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 @@ -531,7 +531,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.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..798a3ed1ed 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 -- seq' ) 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.factor b/core/sets/sets.factor index 31c39c6105..71a7d77903 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 ; + swap 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.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..028759c9f9 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -31,6 +31,8 @@ IN: strings.tests [ t ] [ "abc" "abd" before? ] unit-test [ t ] [ "z" "abd" after? ] unit-test +[ t ] [ "abc" "abd" min ] unit-test +[ t ] [ "z" "abd" max ] unit-test [ 0 10 "hello" subseq ] must-fail 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-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 ; Date: Fri, 25 Apr 2008 23:17:08 -0500 Subject: [PATCH 26/55] extra changes: index* -> index-from last-index* -> last-index-from 1 tail -> rest 1 tail-slice -> rest-slice subset -> filter prepose find* -> find-from find-last* -> find-last-from before, after generic, < for integers make between? work for timestamps --- extra/alarms/alarms.factor | 2 +- extra/ascii/ascii-tests.factor | 3 +- extra/ascii/ascii.factor | 2 +- extra/benchmark/dispatch1/dispatch1.factor | 2 +- extra/benchmark/dispatch5/dispatch5.factor | 2 +- extra/bitfields/bitfields.factor | 2 +- extra/boids/boids.factor | 6 +-- extra/bootstrap/help/help.factor | 2 +- extra/builder/benchmark/benchmark.factor | 4 +- extra/bunny/bunny.factor | 2 +- extra/bunny/model/model.factor | 2 +- extra/calendar/calendar.factor | 2 +- extra/calendar/format/format.factor | 2 +- extra/classes/tuple/lib/lib.factor | 2 +- extra/cocoa/messages/messages.factor | 2 +- .../combinators/combinators-docs.factor | 6 +-- .../combinators/combinators-tests.factor | 4 +- .../combinators/combinators.factor | 2 +- .../core-foundation/fsevents/fsevents.factor | 2 +- extra/db/db.factor | 2 +- extra/db/queries/queries.factor | 2 +- extra/db/types/types.factor | 8 ++-- extra/documents/documents.factor | 6 +-- extra/factory/commands/commands.factor | 4 +- extra/factory/factory.factor | 2 +- extra/faq/faq.factor | 4 +- extra/fry/fry.factor | 4 +- extra/hardware-info/linux/linux.factor | 4 +- extra/help/cookbook/cookbook.factor | 2 +- extra/help/handbook/handbook.factor | 4 +- extra/help/help.factor | 6 +-- extra/help/lint/lint.factor | 12 +++--- extra/help/tutorial/tutorial.factor | 8 ++-- extra/html/parser/analyzer/analyzer.factor | 30 ++++++------- extra/http/server/server.factor | 2 +- .../templating/chloe/chloe-tests.factor | 2 +- .../http/server/templating/chloe/chloe.factor | 2 +- extra/io/buffers/buffers.factor | 4 +- extra/io/encodings/8-bit/8-bit.factor | 2 +- extra/io/nonblocking/nonblocking.factor | 2 +- extra/io/sockets/impl/impl.factor | 2 +- extra/io/unix/select/select.factor | 2 +- extra/koszul/koszul.factor | 8 ++-- extra/lazy-lists/examples/examples.factor | 2 +- extra/lazy-lists/lazy-lists-docs.factor | 6 +-- extra/lazy-lists/lazy-lists.factor | 42 +++++++++---------- extra/logging/logging.factor | 4 +- extra/logging/server/server.factor | 2 +- extra/math/complex/complex-tests.factor | 4 +- extra/math/functions/functions-docs.factor | 2 +- extra/math/functions/functions-tests.factor | 4 +- extra/math/functions/functions.factor | 2 +- .../matrices/elimination/elimination.factor | 4 +- extra/math/ranges/ranges.factor | 2 +- extra/math/ratios/ratios-tests.factor | 4 +- extra/math/vectors/vectors.factor | 2 +- extra/maze/maze.factor | 2 +- extra/memoize/memoize-tests.factor | 1 + extra/models/models.factor | 2 +- extra/multi-methods/multi-methods.factor | 8 ++-- extra/newfx/newfx.factor | 2 +- extra/opengl/gl/extensions/extensions.factor | 2 +- extra/openssl/openssl-tests.factor | 2 +- extra/optimizer/report/report.factor | 4 +- .../parser-combinators.factor | 2 +- extra/peg/ebnf/ebnf.factor | 2 +- extra/peg/peg.factor | 2 +- extra/peg/search/search.factor | 4 +- .../porter-stemmer-tests.factor | 2 +- extra/project-euler/001/001.factor | 2 +- extra/project-euler/002/002.factor | 4 +- extra/project-euler/004/004.factor | 2 +- extra/project-euler/022/022.factor | 2 +- extra/project-euler/023/023.factor | 2 +- extra/project-euler/026/026.factor | 2 +- extra/project-euler/027/027.factor | 4 +- extra/project-euler/030/030.factor | 2 +- extra/project-euler/032/032.factor | 4 +- extra/project-euler/033/033.factor | 4 +- extra/project-euler/034/034.factor | 2 +- extra/project-euler/035/035.factor | 2 +- extra/project-euler/036/036.factor | 2 +- extra/project-euler/037/037.factor | 2 +- extra/project-euler/038/038.factor | 2 +- extra/project-euler/042/042.factor | 2 +- extra/project-euler/043/043.factor | 8 ++-- extra/project-euler/044/044.factor | 2 +- extra/project-euler/079/079.factor | 2 +- extra/project-euler/150/150.factor | 2 +- extra/regexp/regexp.factor | 2 +- extra/reports/optimizer/optimizer.factor | 4 +- extra/sequences/deep/deep-docs.factor | 2 +- extra/sequences/deep/deep-tests.factor | 6 +-- extra/sequences/deep/deep.factor | 12 +++--- extra/sequences/lib/lib.factor | 12 +++--- extra/shufflers/shufflers-tests.factor | 1 + extra/smtp/smtp-tests.factor | 2 +- extra/tetris/board/board.factor | 2 +- extra/tools/annotations/annotations.factor | 2 +- extra/tools/completion/completion.factor | 8 ++-- extra/tools/deploy/shaker/shaker.factor | 6 +-- extra/tools/memory/memory-docs.factor | 2 +- extra/tools/profiler/profiler.factor | 6 +-- extra/tools/test/test.factor | 2 +- extra/tools/threads/threads.factor | 4 +- extra/tools/vocabs/browser/browser.factor | 6 +-- extra/tools/vocabs/vocabs.factor | 14 +++---- extra/ui/commands/commands.factor | 2 +- extra/ui/gadgets/editors/editors.factor | 3 +- extra/ui/gadgets/lists/lists.factor | 2 +- extra/ui/gadgets/packs/packs.factor | 2 +- extra/ui/gadgets/paragraphs/paragraphs.factor | 2 +- extra/ui/gadgets/sliders/sliders.factor | 2 +- extra/ui/gadgets/tracks/tracks.factor | 2 +- extra/ui/gestures/gestures.factor | 2 +- extra/ui/operations/operations.factor | 2 +- extra/ui/render/render.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 2 +- extra/ui/tools/tools-tests.factor | 2 +- extra/ui/ui.factor | 2 +- extra/unicode/breaks/breaks.factor | 2 +- extra/unicode/data/data.factor | 17 ++++---- extra/unicode/normalize/normalize.factor | 6 +-- extra/unicode/syntax/syntax.factor | 11 ++--- extra/windows/com/syntax/syntax.factor | 2 +- extra/windows/messages/messages.factor | 2 +- extra/wrap/wrap.factor | 2 +- extra/x/widgets/wm/root/root.factor | 4 +- .../unmapped-frames-menu.factor | 2 +- extra/x/widgets/wm/workspace/workspace.factor | 2 +- extra/xml/tests/test.factor | 2 +- extra/xml/utilities/utilities.factor | 10 ++--- extra/xml/writer/writer.factor | 2 +- extra/xml/xml.factor | 2 +- extra/xmode/keyword-map/keyword-map.factor | 2 +- extra/xmode/utilities/utilities-tests.factor | 2 +- extra/xmode/utilities/utilities.factor | 6 +-- 137 files changed, 272 insertions(+), 268 deletions(-) diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index bd1f02c44c..ddc1d34121 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar combinators generic init kernel math namespaces sequences heaps boxes threads debugger quotations -assocs ; +assocs math.order ; IN: alarms TUPLE: alarm quot time interval entry ; diff --git a/extra/ascii/ascii-tests.factor b/extra/ascii/ascii-tests.factor index b2b13b1d78..7dacce734b 100644 --- a/extra/ascii/ascii-tests.factor +++ b/extra/ascii/ascii-tests.factor @@ -1,5 +1,5 @@ -IN: ascii.tests USING: ascii tools.test sequences kernel math ; +IN: ascii.tests [ t ] [ CHAR: a letter? ] unit-test [ f ] [ CHAR: A letter? ] unit-test @@ -8,7 +8,6 @@ USING: ascii tools.test sequences kernel math ; [ t ] [ CHAR: 0 digit? ] unit-test [ f ] [ CHAR: x digit? ] unit-test - [ 4 ] [ 0 "There are Four Upper Case characters" [ LETTER? [ 1+ ] when ] each diff --git a/extra/ascii/ascii.factor b/extra/ascii/ascii.factor index e4a365cd1b..30b801a950 100755 --- a/extra/ascii/ascii.factor +++ b/extra/ascii/ascii.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences math kernel ; +USING: kernel math math.order sequences ; IN: ascii : blank? ( ch -- ? ) " \t\n\r" member? ; inline 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/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..91e5e5fe22 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -116,7 +116,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 +136,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 +156,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/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..2af7a17560 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -6,7 +6,7 @@ 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 [ 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.factor b/extra/calendar/format/format.factor index 7bdaea70b5..33cc8c63fe 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,5 +1,5 @@ USING: math math.parser kernel sequences io calendar -accessors arrays io.streams.string splitting +accessors arrays io.streams.string splitting math.order combinators accessors debugger ; IN: calendar.format diff --git a/extra/classes/tuple/lib/lib.factor b/extra/classes/tuple/lib/lib.factor index 38104a45db..d48addecc3 100755 --- a/extra/classes/tuple/lib/lib.factor +++ b/extra/classes/tuple/lib/lib.factor @@ -11,7 +11,7 @@ MACRO: >tuple< ( class -- ) 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/db/db.factor b/extra/db/db.factor index 91128a7ffb..42a2b4bcb0 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -130,7 +130,7 @@ 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 ) 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/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/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..8c1a0e034c 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 ) 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/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/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/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..99c1798314 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -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/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/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 1a60390f64..afe83d180a 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> @@ -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/http/server/server.factor b/extra/http/server/server.factor index 88a748d949..848d878c5b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -221,7 +221,7 @@ SYMBOL: exit-continuation '[ exit-continuation set @ ] callcc1 exit-continuation off ; : split-path ( string -- path ) - "/" split [ empty? not ] subset ; + "/" split [ empty? not ] filter ; : do-request ( request -- response ) [ diff --git a/extra/http/server/templating/chloe/chloe-tests.factor b/extra/http/server/templating/chloe/chloe-tests.factor index f517af4a12..cb8b56e002 100644 --- a/extra/http/server/templating/chloe/chloe-tests.factor +++ b/extra/http/server/templating/chloe/chloe-tests.factor @@ -30,7 +30,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 3793604929..5714ccbfe3 100644 --- a/extra/http/server/templating/chloe/chloe.factor +++ b/extra/http/server/templating/chloe/chloe.factor @@ -105,7 +105,7 @@ SYMBOL: tags hidden-form-field ; 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/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/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/koszul/koszul.factor b/extra/koszul/koszul.factor index b079cec42c..7e24d873a2 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -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 ; @@ -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/logging/logging.factor b/extra/logging/logging.factor index 664337c3d3..f54ab05bbd 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -72,7 +72,7 @@ PRIVATE> >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..9da2bec927 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -37,7 +37,7 @@ 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) ] } [ diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index 9174ac9988..063871ce5b 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -1,5 +1,5 @@ -USING: kernel math math.constants math.functions tools.test -prettyprint ; +USING: kernel math math.constants math.functions math.order +tools.test prettyprint ; IN: math.complex.tests [ 1 C{ 0 1 } rect> ] 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/ranges/ranges.factor b/extra/math/ranges/ranges.factor index cc7d0758e5..eb26232969 100755 --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -1,4 +1,4 @@ -USING: kernel layouts math namespaces sequences +USING: kernel layouts math math.order namespaces sequences sequences.private accessors ; IN: math.ranges diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 75572d8415..28801fa2e9 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -1,5 +1,5 @@ -USING: kernel math math.parser math.ratios math.functions -tools.test ; +USING: kernel math math.order math.parser math.ratios +math.functions tools.test ; IN: math.ratios.tests [ 1 2 ] [ 1/2 >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..fa25dbd17c 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -17,7 +17,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..3ce0abd7d9 100644 --- a/extra/memoize/memoize-tests.factor +++ b/extra/memoize/memoize-tests.factor @@ -1,6 +1,7 @@ ! 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 ; 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..1c6473216e 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -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/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/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/report/report.factor b/extra/optimizer/report/report.factor index feaace9808..5cf2d5129e 100755 --- a/extra/optimizer/report/report.factor +++ b/extra/optimizer/report/report.factor @@ -8,7 +8,7 @@ optimizer math ; [ 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..b710d9d481 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -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/peg.factor b/extra/peg/peg.factor index 858d062c68..3922fc9f86 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 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/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 [ 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..53cee7c0ff 100755 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -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..a607931083 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 ; : 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/079/079.factor b/extra/project-euler/079/079.factor index 452a64af44..65162cc519 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -39,7 +39,7 @@ IN: project-euler.079 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 > [ diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index c96c1ebc73..c8bd28a3a9 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -17,7 +17,7 @@ IN: project-euler.150 0 0 rot [ (partial-sum-infimum) ] each drop ; inline : generate ( n quot -- seq ) - [ drop ] swap compose map ; inline + [ drop ] prepose map ; inline : map-infimum ( seq quot -- min ) [ min ] compose 0 swap reduce ; inline diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index d517db09fe..e3709e360f 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -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/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor index f38d1d808b..a4018254d3 100755 --- a/extra/reports/optimizer/optimizer.factor +++ b/extra/reports/optimizer/optimizer.factor @@ -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/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 e534a204b1..b8e2717a71 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 @@ -129,11 +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 ] swap compose map ; inline + [ drop ] prepose map ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -159,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 ) @@ -216,7 +216,7 @@ USE: continuations >r dup length swap r> [ = [ ] [ drop f ] if ] curry 2map - [ ] subset ; + [ ] filter ; > >alist sort-keys [ drop { "Date" "Message-Id" } member? not - ] assoc-subset + ] assoc-filter over to>> rot from>> ] unit-test 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..b8ecf87989 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 ; @@ -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..2a5213c70d 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 @@ -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/ui/commands/commands.factor b/extra/ui/commands/commands.factor index c7db687dc3..9d6775159a 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 ; 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/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..0c7100d35c 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 @@ -64,7 +65,7 @@ IN: unicode.data : 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/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..4e2e092642 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -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/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/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..a75c5396f0 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -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
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

From 714b0ebc94529f2c6048a157b17ccca60907b843 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 00:59:03 -0500
Subject: [PATCH 27/55] move shufflers to unmaintained  - unit test fails
 because of "in" vocab weirdness

---
 unmaintained/shufflers/authors.txt            |  1 +
 unmaintained/shufflers/shufflers-docs.factor  | 13 +++++++
 unmaintained/shufflers/shufflers-tests.factor |  8 +++++
 unmaintained/shufflers/shufflers.factor       | 36 +++++++++++++++++++
 unmaintained/shufflers/summary.txt            |  1 +
 unmaintained/shufflers/tags.txt               |  1 +
 6 files changed, 60 insertions(+)
 create mode 100644 unmaintained/shufflers/authors.txt
 create mode 100644 unmaintained/shufflers/shufflers-docs.factor
 create mode 100644 unmaintained/shufflers/shufflers-tests.factor
 create mode 100644 unmaintained/shufflers/shufflers.factor
 create mode 100644 unmaintained/shufflers/summary.txt
 create mode 100644 unmaintained/shufflers/tags.txt

diff --git a/unmaintained/shufflers/authors.txt b/unmaintained/shufflers/authors.txt
new file mode 100644
index 0000000000..f990dd0ed2
--- /dev/null
+++ b/unmaintained/shufflers/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/unmaintained/shufflers/shufflers-docs.factor b/unmaintained/shufflers/shufflers-docs.factor
new file mode 100644
index 0000000000..ac372534ae
--- /dev/null
+++ b/unmaintained/shufflers/shufflers-docs.factor
@@ -0,0 +1,13 @@
+USING: help.syntax help.markup ;
+IN: shufflers
+
+HELP: SHUFFLE:
+{ $syntax "SHUFFLE: alphabet #" }
+{ $values { "alphabet" "an alphabet of unique letters" } { "#" "the maximum length" } }
+{ $description "Defines stack shufflers of the form abc-bcba where 'abc' describes the inputs and 'bcba' describes the outputs. Given a stack of 1 2 3, this returns 2 3 2 1. The stack shufflers defined are put in the current vocab with the suffix '.shuffle' appended." }
+{ $examples
+"SHUFFLE: abcd 6\n"
+": 4drop abcd- ;\n"
+": 2over abcd-abcdab ;\n"
+": 2swap abcd-cdab ;\n"
+": 3dup abc-abcabc ;\n" } ;
diff --git a/unmaintained/shufflers/shufflers-tests.factor b/unmaintained/shufflers/shufflers-tests.factor
new file mode 100644
index 0000000000..753f35b2e6
--- /dev/null
+++ b/unmaintained/shufflers/shufflers-tests.factor
@@ -0,0 +1,8 @@
+USING: shufflers tools.test ;
+IN: shufflers.tests
+
+SHUFFLE: abcd 4
+[ ] [ 1 2 3 4 abcd- ] unit-test
+[ 1 2 1 2 ] [ 1 2 3 abc-abab ] unit-test
+[ 4 3 2 1 ] [ 1 2 3 4 abcd-dcba ] unit-test
+[ 1 1 1 1 ] [ 1 a-aaaa ] unit-test
diff --git a/unmaintained/shufflers/shufflers.factor b/unmaintained/shufflers/shufflers.factor
new file mode 100644
index 0000000000..b11668a53e
--- /dev/null
+++ b/unmaintained/shufflers/shufflers.factor
@@ -0,0 +1,36 @@
+USING: kernel sequences words math math.functions arrays 
+shuffle quotations parser math.parser strings namespaces 
+splitting effects sequences.lib ;
+IN: shufflers
+
+: shuffle>string ( names shuffle -- string )
+    swap [ [ nth ] curry map ] curry map
+    first2 "-" swap 3append >string ;
+
+: make-shuffles ( max-out max-in -- shuffles )
+    [ 1+ dup rot strings [ 2array ] with map ]
+    with map concat ;
+
+: shuffle>quot ( shuffle -- quot )
+    [
+        first2 2dup [ - ] with map
+        reverse [ , \ npick , \ >r , ] each
+        swap , \ ndrop , length [ \ r> , ] times
+    ] [ ] make ;
+
+: put-effect ( word -- )
+    dup word-name "-" split1
+    [ >array [ 1string ] map ] bi@
+     "declared-effect" set-word-prop ;
+
+: in-shuffle ( -- ) in get ".shuffle" append set-in ;
+: out-shuffle ( -- ) in get ".shuffle" ?tail drop set-in ;
+
+: define-shuffles ( names max-out -- )
+    in-shuffle over length make-shuffles [
+        [ shuffle>string create-in ] keep
+        shuffle>quot dupd define put-effect
+    ] with each out-shuffle ;
+
+: SHUFFLE:
+    scan scan string>number define-shuffles ; parsing
diff --git a/unmaintained/shufflers/summary.txt b/unmaintained/shufflers/summary.txt
new file mode 100644
index 0000000000..37b87be410
--- /dev/null
+++ b/unmaintained/shufflers/summary.txt
@@ -0,0 +1 @@
+Arbitrary stack shuffling operators of the form abc-cbab
diff --git a/unmaintained/shufflers/tags.txt b/unmaintained/shufflers/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/unmaintained/shufflers/tags.txt
@@ -0,0 +1 @@
+extensions

From ca77a729d8f3e57231407e473b3a0ca8cf8ed657 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sat, 26 Apr 2008 01:44:45 -0500
Subject: [PATCH 28/55] Clean up session persistence

---
 extra/http/http-tests.factor                  |  25 +-
 .../server/sessions/sessions-tests.factor     | 225 ++++++++++--------
 extra/http/server/sessions/sessions.factor    | 100 ++++----
 .../sessions/storage/assoc/assoc.factor       |  37 ---
 .../sessions/storage/db/db-tests.factor       |  24 --
 .../http/server/sessions/storage/db/db.factor |  41 +---
 .../server/sessions/storage/null/null.factor  |  16 ++
 .../server/sessions/storage/storage.factor    |   6 +-
 8 files changed, 235 insertions(+), 239 deletions(-)
 delete mode 100755 extra/http/server/sessions/storage/assoc/assoc.factor
 delete mode 100755 extra/http/server/sessions/storage/db/db-tests.factor
 create mode 100644 extra/http/server/sessions/storage/null/null.factor

diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 473bc964d3..553b4f2cda 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
@@ -134,15 +134,22 @@ read-response-test-1' 1array [
 
 ! Live-fire exercise
 USING: http.server http.server.static http.server.sessions
-http.server.actions http.server.auth.login http.client
-io.server io.files io accessors namespaces threads
-io.encodings.ascii ;
+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
+
 [ ] [
     [
         
@@ -187,11 +194,14 @@ io.encodings.ascii ;
         
              
             
-             "" add-responder
+            
+                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
@@ -214,9 +224,12 @@ io.encodings.ascii ;
     [
         
              [ "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
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index 02dee1f7e0..4d8c93ef67 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -1,12 +1,14 @@
 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 ;
 
-[ H{ } ] [ H{ } add-session-id ] unit-test
-
-: with-session \ session swap with-variable ; inline
+: with-session
+    [
+        >r [ save-session-after ] [ \ session set ] bi r> call
+    ] with-destructors ; inline
 
 TUPLE: foo ;
 
@@ -19,56 +21,6 @@ M: foo call-responder
     "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,34 +28,10 @@ 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
     [
         
@@ -111,35 +39,134 @@ response set
             "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 [
 
-        [
-            { }  
-            call-responder
-        ] with-destructors response set
+    [
+        empty-session
+            123 >>id 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-in-db >>sessions
+        session-manager set
     ] unit-test
 
-    [ "text/plain" ] [ response get "content-type" header ] unit-test
+    [ t ] [
+        session-manager get begin-session id>>
+        session-manager get sessions>> get-session session?
+    ] unit-test
 
-    [ f ] [ response get cookies>> empty? ] unit-test
-] with-scope
+    [ { 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
+
+    [ ] [
+        [
+            
+            "GET" >>method
+            request set
+            { "etc" } session-manager get call-responder
+        ] with-destructors
+        response set
+    ] unit-test
+
+    [ 307 ] [ response get code>> ] unit-test
+
+    [ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
+
+    [ "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-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" ] [ cookie-responder-mock-test ] unit-test
+    [ "3" ] [ cookie-responder-mock-test ] unit-test
+    [ "4" ] [ cookie-responder-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..5d0113b225 100755
--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@@ -1,16 +1,25 @@
 ! 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 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 user-agent client-addr namespace ;
+
+:  ( id -- session )
+    session new
+        swap >>id ;
+
 GENERIC: init-session* ( responder -- )
 
 M: object init-session* drop ;
@@ -19,59 +28,65 @@ TUPLE: session-manager responder sessions ;
 
 : new-session-manager ( responder class -- responder' )
     new
-         >>sessions
+        null-sessions >>sessions
         swap >>responder ; inline
 
-SYMBOLS: session session-id session-changed? ;
+SYMBOL: session-changed?
 
 : sget ( key -- value )
-    session get at ;
+    session get namespace>> at ;
 
 : sset ( value key -- )
-    session get set-at
+    session get namespace>> set-at
     session-changed? on ;
 
 : schange ( key quot -- )
-    session get swap change-at
+    session get namespace>> swap change-at
     session-changed? on ; inline
 
 : sessions session-manager get sessions>> ;
 
 : managed-responder session-manager get responder>> ;
 
-: init-session ( managed -- session )
-    H{ } clone [ session [ init-session* ] with-variable ] keep ;
+: init-session ( session managed -- )
+    >r session r> '[ , init-session* ] with-variable ;
 
-: begin-session ( responder -- id session )
-    [ responder>> init-session ] [ sessions>> ] bi
-    [ new-session ] [ drop ] 2bi ;
+: empty-session ( -- session )
+    f 
+        "" >>user-agent
+        "" >>client-addr
+        H{ } clone >>namespace ;
+
+: begin-session ( responder -- session )
+    >r empty-session r>
+    [ responder>> init-session ]
+    [ sessions>> new-session ]
+    [ drop ]
+    2tri ;
 
 ! Destructor
-TUPLE: session-saver id session ;
+TUPLE: session-saver session ;
 
 C:  session-saver
 
 M: session-saver dispose
-    session-changed? get [
-        [ session>> ] [ id>> ] bi
-        sessions update-session
-    ] [ drop ] if ;
+    session-changed? get
+    [ session>> sessions update-session ] [ drop ] if ;
 
-: save-session-after ( id session -- )
+: save-session-after ( session -- )
      add-always-destructor ;
 
-: call-responder/session ( path responder id session -- response )
-    [ save-session-after ]
-    [ [ session-id set ] [ session set ] bi* ] 2bi
+: call-responder/session ( path responder session -- response )
+    [ save-session-after ] [ session set ] bi
     [ session-manager set ] [ responder>> call-responder ] bi ;
 
 TUPLE: null-sessions < session-manager ;
 
-: 
+:  ( responder -- manager )
     null-sessions new-session-manager ;
 
 M: null-sessions call-responder ( path responder -- response )
-    H{ } clone f call-responder/session ;
+     call-responder/session ;
 
 TUPLE: url-sessions < session-manager ;
 
@@ -80,42 +95,43 @@ TUPLE: url-sessions < session-manager ;
 
 : 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 ;
+: current-url-session ( responder -- session/f )
+    >r request-params session-id-key swap at string>number
+    r> sessions>> get-session ;
 
 : add-session-id ( query -- query' )
-    session-id get [ session-id-key associate assoc-union ] when* ;
+    session get [ id>> session-id-key associate assoc-union ] when* ;
 
 : session-form-field ( -- )
     > =value
     input/> ;
 
-: new-url-session ( responder -- response )
-    [ f ] [ begin-session drop session-id-key associate ] bi*
+: new-url-session ( path responder -- response )
+    [ drop f ] [ begin-session id>> 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 [
+    dup current-url-session [
         call-responder/session
     ] [
-        2drop nip new-url-session
-    ] if ;
+        new-url-session
+    ] if* ;
 
 TUPLE: cookie-sessions < session-manager ;
 
 :  ( responder -- responder' )
     cookie-sessions new-session-manager ;
 
-: current-cookie-session ( responder -- id namespace/f )
+: current-cookie-session ( responder -- session/f )
     request get session-id-key get-cookie dup
-    [ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
+    [ value>> string>number swap sessions>> get-session ]
+    [ 2drop f ] if ;
 
 :  ( id -- cookie )
     session-id-key  ;
@@ -123,12 +139,12 @@ TUPLE: cookie-sessions < session-manager ;
 : call-responder/new-session ( path responder -- response )
     dup begin-session
     [ call-responder/session ]
-    [ drop  ] 2bi
+    [ id>> number>string  ] bi
     put-cookie ;
 
 M: cookie-sessions call-responder ( path responder -- response )
-    dup current-cookie-session dup [
+    dup current-cookie-session [
         call-responder/session
     ] [
-        2drop call-responder/new-session
-    ] if ;
+        call-responder/new-session
+    ] if* ;
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..bddb783c97 100755
--- a/extra/http/server/sessions/storage/db/db.factor
+++ b/extra/http/server/sessions/storage/db/db.factor
@@ -1,46 +1,31 @@
 ! 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.tuples db.types math.parser
+classes.singleton random ;
 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+ }
+    { "user-agent" "USERAGENT" { VARCHAR 256 } +not-null+ }
+    { "client-addr" "CLIENTADDR" { VARCHAR 256 } +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
-    f 
-        swap >>namespace
-    [ insert-tuple ] [ id>> number>string ] bi ;
+M: sessions-in-db new-session ( session storage -- )
+    drop insert-tuple ;
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..97d869e60a 100755
--- a/extra/http/server/sessions/storage/storage.factor
+++ b/extra/http/server/sessions/storage/storage.factor
@@ -5,10 +5,10 @@ IN: http.server.sessions.storage
 
 : timeout 20 minutes ;
 
-GENERIC: get-session ( id storage -- namespace )
+GENERIC: get-session ( id storage -- session )
 
-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 -- )

From e264537a1a558d08e377ea470997ff03ba4d085b Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 02:01:06 -0500
Subject: [PATCH 29/55] reverse the arguments of diff, assoc-diff fix lots of
 usings fix help-lint

---
 core/assocs/assocs-docs.factor                       |  2 +-
 core/assocs/assocs.factor                            |  2 +-
 core/bootstrap/image/image.factor                    |  2 +-
 core/bootstrap/stage2.factor                         |  2 +-
 core/classes/classes-docs.factor                     |  4 ++--
 core/classes/singleton/singleton-docs.factor         |  2 +-
 core/classes/tuple/tuple-docs.factor                 |  1 +
 core/classes/tuple/tuple-tests.factor                |  4 ++--
 core/dlists/dlists-tests.factor                      |  2 +-
 core/generator/registers/registers.factor            |  2 +-
 .../standard/engines/predicate/predicate.factor      |  4 ++--
 core/heaps/heaps-tests.factor                        |  2 +-
 core/inference/class/class-tests.factor              |  2 +-
 core/io/files/files.factor                           |  4 ++--
 core/mirrors/mirrors-docs.factor                     |  1 +
 core/namespaces/namespaces-docs.factor               |  2 +-
 core/namespaces/namespaces-tests.factor              |  2 +-
 core/parser/parser.factor                            |  6 +++---
 core/prettyprint/prettyprint-docs.factor             | 12 ++++++++++--
 core/sequences/sequences.factor                      |  2 +-
 core/sets/sets-docs.factor                           |  4 ++--
 core/sets/sets-tests.factor                          |  2 +-
 core/sets/sets.factor                                |  2 +-
 core/sorting/sorting-tests.factor                    |  4 ++--
 core/strings/strings-tests.factor                    |  2 +-
 core/syntax/syntax-docs.factor                       |  5 +++--
 core/words/words-docs.factor                         |  2 +-
 27 files changed, 46 insertions(+), 35 deletions(-)

diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index f06cc70613..de62ccd878 100755
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -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.factor b/core/assocs/assocs.factor
index a58dfea900..e68c311836 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -120,7 +120,7 @@ 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-filter ;
+    [ nip key? not ] curry assoc-filter ;
 
 : remove-all ( assoc seq -- subseq )
     swap [ key? not ] curry filter ;
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 46ed34c35c..5d8bbf3f77 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -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/stage2.factor b/core/bootstrap/stage2.factor
index 8e16417ca6..8e4108866f 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -22,7 +22,7 @@ SYMBOL: bootstrap-time
     xref-sources ;
 
 : load-components ( -- )
-    "exclude" "include"
+    "include" "exclude"
     [ get-global " " split [ empty? not ] filter ] bi@
     diff
     [ "bootstrap." prepend require ] each ;
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/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/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor
index b0fe2a1157..3bf324664f 100755
--- a/core/dlists/dlists-tests.factor
+++ b/core/dlists/dlists-tests.factor
@@ -79,7 +79,7 @@ IN: dlists.tests
         [ dlist-push-all ] keep
         [ dlist-delete-all ] keep
         dlist>array
-    ] 2keep diff assert-same-elements
+    ] 2keep swap diff assert-same-elements
 ] unit-test
 
 [ ] [
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index 4753f18c9a..e0fd7bd457 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -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 ( -- )
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/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/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/io/files/files.factor b/core/io/files/files.factor
index 7fa2080661..576307b589 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -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
diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor
index e3ebfefa5f..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 ."
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/parser/parser.factor b/core/parser/parser.factor
index 1cfe6d63d9..3f42980cf2 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -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
         ] [
@@ -513,7 +513,7 @@ 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-filter keys ;
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/sequences/sequences.factor b/core/sequences/sequences.factor
index 798a3ed1ed..a63e6d2835 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -257,7 +257,7 @@ PRIVATE>
 
 : tail ( seq n -- tailseq ) (tail) subseq ;
 
-: rest ( seq -- seq' ) 1 tail ;
+: rest ( seq -- tailseq ) 1 tail ;
 
 : head* ( seq n -- headseq ) from-end head ;
 
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 71a7d77903..78a92155fc 100644
--- a/core/sets/sets.factor
+++ b/core/sets/sets.factor
@@ -25,7 +25,7 @@ IN: sets
     unique [ key? ] curry filter ;
 
 : diff ( seq1 seq2 -- newseq )
-    swap unique [ key? not ] curry filter ;
+    unique [ key? not ] curry filter ;
 
 : union ( seq1 seq2 -- newseq )
     append prune ;
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/strings/strings-tests.factor b/core/strings/strings-tests.factor
index 028759c9f9..6d01e19585 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
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/words/words-docs.factor b/core/words/words-docs.factor
index f259378f7e..07df0ba4e3 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 )

From 4d0ba8c3c1c0739303ecb87de52a9cd348253f1d Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 02:01:43 -0500
Subject: [PATCH 30/55] reverse args for assoc-diff, diff fix lots of usings
 fix help lint

---
 extra/bunny/model/model.factor                |  2 +-
 extra/calendar/calendar-tests.factor          |  2 +-
 extra/classes/tuple/lib/lib-docs.factor       |  2 ++
 extra/classes/tuple/lib/lib.factor            |  2 +-
 extra/cpu/8080/emulator/emulator.factor       |  2 +-
 extra/crypto/sha1/sha1.factor                 |  2 +-
 extra/delegate/delegate.factor                |  2 +-
 extra/faq/faq.factor                          |  2 +-
 extra/help/crossref/crossref.factor           |  2 +-
 extra/help/lint/lint.factor                   |  6 ++--
 extra/help/markup/markup.factor               |  2 +-
 extra/html/parser/analyzer/analyzer.factor    |  2 +-
 extra/html/parser/utils/utils.factor          |  2 +-
 extra/http/client/client.factor               |  2 +-
 extra/http/server/server.factor               |  2 +-
 extra/inverse/inverse.factor                  |  4 +--
 extra/irc/irc.factor                          |  4 +--
 extra/jamshred/tunnel/tunnel.factor           |  2 +-
 extra/koszul/koszul.factor                    |  2 +-
 extra/locals/locals-docs.factor               |  4 +++
 extra/locals/locals.factor                    |  2 +-
 extra/logging/analysis/analysis.factor        |  2 +-
 extra/logging/server/server.factor            |  2 +-
 extra/match/match-docs.factor                 |  1 +
 extra/match/match.factor                      |  4 +--
 extra/math/matrices/matrices.factor           |  2 +-
 extra/math/polynomials/polynomials.factor     |  2 +-
 extra/memoize/memoize-tests.factor            |  2 +-
 extra/multiline/multiline.factor              |  2 +-
 extra/opengl/capabilities/capabilities.factor |  4 +--
 extra/opengl/demo-support/demo-support.factor |  5 +--
 extra/optimizer/debugger/debugger.factor      |  2 +-
 .../parser-combinators.factor                 |  2 +-
 extra/peg/parsers/parsers.factor              |  2 +-
 extra/peg/peg.factor                          |  2 +-
 extra/project-euler/023/023.factor            |  5 +--
 extra/project-euler/035/035.factor            |  2 +-
 extra/project-euler/043/043.factor            |  2 +-
 extra/project-euler/079/079.factor            |  4 +--
 extra/project-euler/common/common.factor      |  6 ++--
 extra/qualified/qualified.factor              |  2 +-
 extra/random-weighted/random-weighted.factor  |  2 +-
 .../mersenne-twister-tests.factor             |  2 +-
 extra/sequences/lib/lib.factor                |  4 +--
 extra/serialize/serialize.factor              |  2 +-
 extra/shufflers/authors.txt                   |  1 -
 extra/shufflers/shufflers-docs.factor         | 13 -------
 extra/shufflers/shufflers-tests.factor        |  8 -----
 extra/shufflers/shufflers.factor              | 36 -------------------
 extra/shufflers/summary.txt                   |  1 -
 extra/shufflers/tags.txt                      |  1 -
 extra/symbols/symbols-docs.factor             |  2 +-
 extra/tools/deploy/shaker/shaker.factor       |  2 +-
 extra/tools/vocabs/vocabs.factor              |  2 +-
 extra/ui/commands/commands-docs.factor        |  2 ++
 extra/ui/commands/commands.factor             |  2 +-
 extra/ui/traverse/traverse.factor             |  2 +-
 extra/unicode/data/data.factor                |  2 +-
 extra/xml/tokenize/tokenize.factor            |  2 +-
 extra/xml/xml.factor                          |  4 +--
 60 files changed, 74 insertions(+), 123 deletions(-)
 delete mode 100644 extra/shufflers/authors.txt
 delete mode 100644 extra/shufflers/shufflers-docs.factor
 delete mode 100644 extra/shufflers/shufflers-tests.factor
 delete mode 100644 extra/shufflers/shufflers.factor
 delete mode 100644 extra/shufflers/summary.txt
 delete mode 100644 extra/shufflers/tags.txt

diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index 2af7a17560..8d05b14a20 100755
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -12,7 +12,7 @@ IN: bunny.model
     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..d4cddb6081 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 ;
 IN: calendar.tests
 
 \ time+ must-infer
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 d48addecc3..10261a1df7 100755
--- a/extra/classes/tuple/lib/lib.factor
+++ b/extra/classes/tuple/lib/lib.factor
@@ -7,7 +7,7 @@ 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
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/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/faq/faq.factor b/extra/faq/faq.factor
index 8c1a0e034c..3cb17cf08b 100644
--- a/extra/faq/faq.factor
+++ b/extra/faq/faq.factor
@@ -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/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/lint/lint.factor b/extra/help/lint/lint.factor
index 99c1798314..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 -- ? )
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/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor
index afe83d180a..160b95ab1d 100755
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@@ -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' )
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/server/server.factor b/extra/http/server/server.factor
index 848d878c5b..7c88a608e5 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -149,7 +149,7 @@ TUPLE: dispatcher default responders ;
         [ nip ] [ drop default>> ] if
     ] [
         over first over responders>> at*
-        [ >r drop 1 tail-slice r> ] [ drop default>> ] if
+        [ >r drop rest-slice r> ] [ drop default>> ] if
     ] if ;
 
 M: dispatcher call-responder ( path dispatcher -- response )
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/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/koszul/koszul.factor b/extra/koszul/koszul.factor
index 7e24d873a2..b4a0934e41 100755
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -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
diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor
index 372a567550..cac27d5296 100644
--- a/extra/locals/locals-docs.factor
+++ b/extra/locals/locals-docs.factor
@@ -16,6 +16,7 @@ HELP: [|
 { $examples
     { $example
         "USING: kernel locals math prettyprint ;"
+        "IN: scratchpad"
         ":: adder ( n -- quot ) [| m | m n + ] ;"
         "3 5 adder call ."
         "8"
@@ -29,6 +30,7 @@ HELP: [let
 { $examples
     { $example
         "USING: kernel locals math math.functions prettyprint sequences ;"
+        "IN: scratchpad"
         ":: frobnicate ( n seq -- newseq )"
         "    [let | n' [ n 6 * ] |"
         "        seq [ n' gcd nip ] map ] ;"
@@ -44,6 +46,7 @@ HELP: [let*
 { $examples
     { $example
         "USING: kernel locals math math.functions prettyprint sequences ;"
+        "IN: scratchpad"
         ":: frobnicate ( n seq -- newseq )"
         "    [let* | a [ n 3 + ]"
         "            b [ a 4 * ] |"
@@ -62,6 +65,7 @@ HELP: [wlet
 { $examples
     { $example
         "USING: locals math prettyprint sequences ;"
+        "IN: scratchpad"
         ":: quuxify ( n seq -- newseq )"
         "    [wlet | add-n [| m | m n + ] |"
         "        seq [ add-n ] map ] ;"
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index be73f1db88..9b5640f3d8 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -130,7 +130,7 @@ M: object free-vars* drop ;
 M: quotation free-vars* [ add-if-free ] each ;
 
 M: lambda free-vars*
-    [ vars>> ] [ body>> ] bi free-vars diff % ;
+    [ vars>> ] [ body>> ] bi free-vars swap diff % ;
 
 GENERIC: lambda-rewrite* ( obj -- )
 
diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor
index e2c77377ac..cd1429ac53 100755
--- a/extra/logging/analysis/analysis.factor
+++ b/extra/logging/analysis/analysis.factor
@@ -14,7 +14,7 @@ SYMBOL: message-histogram
     dup second CRITICAL eq? [ dup errors get push ] when
     1 over third word-histogram get at+
     dup third word-names get member? [
-        1 over 1 tail message-histogram get at+
+        1 over rest message-histogram get at+
     ] when
     drop ;
 
diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor
index 9da2bec927..7601d1cc2e 100755
--- a/extra/logging/server/server.factor
+++ b/extra/logging/server/server.factor
@@ -42,7 +42,7 @@ SYMBOL: log-files
         { [ 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/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/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/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor
index 0b0d3520ef..c66f0c3fe3 100644
--- a/extra/math/polynomials/polynomials.factor
+++ b/extra/math/polynomials/polynomials.factor
@@ -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/memoize/memoize-tests.factor b/extra/memoize/memoize-tests.factor
index 3ce0abd7d9..43428efbe0 100644
--- a/extra/memoize/memoize-tests.factor
+++ b/extra/memoize/memoize-tests.factor
@@ -8,4 +8,4 @@ MEMO: fib ( m -- n )
 
 [ 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/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/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/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/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor
index b710d9d481..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 ;
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 3922fc9f86..b420574a3b 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -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/project-euler/023/023.factor b/extra/project-euler/023/023.factor
index 5d468a71c8..6b38a2b6ac 100644
--- a/extra/project-euler/023/023.factor
+++ b/extra/project-euler/023/023.factor
@@ -45,13 +45,14 @@ IN: project-euler.023
 : 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/035/035.factor b/extra/project-euler/035/035.factor
index 53cee7c0ff..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 ;
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index a607931083..41e378e531 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -79,7 +79,7 @@ PRIVATE>
     [ 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 } [
diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor
index 65162cc519..3674804b0c 100644
--- a/extra/project-euler/079/079.factor
+++ b/extra/project-euler/079/079.factor
@@ -35,7 +35,7 @@ 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 )
@@ -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/common/common.factor b/extra/project-euler/common/common.factor
index 5829f66c01..19cf4010c3 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -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/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/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index b8e2717a71..ad5a40ed6d 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -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
@@ -239,7 +239,7 @@ PRIVATE>
     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..3bfd4c349b 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 ;
 
diff --git a/extra/shufflers/authors.txt b/extra/shufflers/authors.txt
deleted file mode 100644
index f990dd0ed2..0000000000
--- a/extra/shufflers/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Daniel Ehrenberg
diff --git a/extra/shufflers/shufflers-docs.factor b/extra/shufflers/shufflers-docs.factor
deleted file mode 100644
index ac372534ae..0000000000
--- a/extra/shufflers/shufflers-docs.factor
+++ /dev/null
@@ -1,13 +0,0 @@
-USING: help.syntax help.markup ;
-IN: shufflers
-
-HELP: SHUFFLE:
-{ $syntax "SHUFFLE: alphabet #" }
-{ $values { "alphabet" "an alphabet of unique letters" } { "#" "the maximum length" } }
-{ $description "Defines stack shufflers of the form abc-bcba where 'abc' describes the inputs and 'bcba' describes the outputs. Given a stack of 1 2 3, this returns 2 3 2 1. The stack shufflers defined are put in the current vocab with the suffix '.shuffle' appended." }
-{ $examples
-"SHUFFLE: abcd 6\n"
-": 4drop abcd- ;\n"
-": 2over abcd-abcdab ;\n"
-": 2swap abcd-cdab ;\n"
-": 3dup abc-abcabc ;\n" } ;
diff --git a/extra/shufflers/shufflers-tests.factor b/extra/shufflers/shufflers-tests.factor
deleted file mode 100644
index 753f35b2e6..0000000000
--- a/extra/shufflers/shufflers-tests.factor
+++ /dev/null
@@ -1,8 +0,0 @@
-USING: shufflers tools.test ;
-IN: shufflers.tests
-
-SHUFFLE: abcd 4
-[ ] [ 1 2 3 4 abcd- ] unit-test
-[ 1 2 1 2 ] [ 1 2 3 abc-abab ] unit-test
-[ 4 3 2 1 ] [ 1 2 3 4 abcd-dcba ] unit-test
-[ 1 1 1 1 ] [ 1 a-aaaa ] unit-test
diff --git a/extra/shufflers/shufflers.factor b/extra/shufflers/shufflers.factor
deleted file mode 100644
index b11668a53e..0000000000
--- a/extra/shufflers/shufflers.factor
+++ /dev/null
@@ -1,36 +0,0 @@
-USING: kernel sequences words math math.functions arrays 
-shuffle quotations parser math.parser strings namespaces 
-splitting effects sequences.lib ;
-IN: shufflers
-
-: shuffle>string ( names shuffle -- string )
-    swap [ [ nth ] curry map ] curry map
-    first2 "-" swap 3append >string ;
-
-: make-shuffles ( max-out max-in -- shuffles )
-    [ 1+ dup rot strings [ 2array ] with map ]
-    with map concat ;
-
-: shuffle>quot ( shuffle -- quot )
-    [
-        first2 2dup [ - ] with map
-        reverse [ , \ npick , \ >r , ] each
-        swap , \ ndrop , length [ \ r> , ] times
-    ] [ ] make ;
-
-: put-effect ( word -- )
-    dup word-name "-" split1
-    [ >array [ 1string ] map ] bi@
-     "declared-effect" set-word-prop ;
-
-: in-shuffle ( -- ) in get ".shuffle" append set-in ;
-: out-shuffle ( -- ) in get ".shuffle" ?tail drop set-in ;
-
-: define-shuffles ( names max-out -- )
-    in-shuffle over length make-shuffles [
-        [ shuffle>string create-in ] keep
-        shuffle>quot dupd define put-effect
-    ] with each out-shuffle ;
-
-: SHUFFLE:
-    scan scan string>number define-shuffles ; parsing
diff --git a/extra/shufflers/summary.txt b/extra/shufflers/summary.txt
deleted file mode 100644
index 37b87be410..0000000000
--- a/extra/shufflers/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Arbitrary stack shuffling operators of the form abc-cbab
diff --git a/extra/shufflers/tags.txt b/extra/shufflers/tags.txt
deleted file mode 100644
index f4274299b1..0000000000
--- a/extra/shufflers/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-extensions
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/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index b8ecf87989..f95b83467a 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -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 )
     [
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index 2a5213c70d..e265f233e3 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -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 -- )
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 9d6775159a..f341595969 100755
--- a/extra/ui/commands/commands.factor
+++ b/extra/ui/commands/commands.factor
@@ -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/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/unicode/data/data.factor b/extra/unicode/data/data.factor
index 0c7100d35c..5e1d30d529 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -59,7 +59,7 @@ 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 )
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/xml.factor b/extra/xml/xml.factor
index a75c5396f0..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 -- )
@@ -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  ;
 

From 42bc93f66ecd585ecdda5de089304b0f61f95336 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sat, 26 Apr 2008 05:49:41 -0500
Subject: [PATCH 31/55] Start page flow code

---
 extra/http/server/auth/login/login.factor     | 14 ++---
 .../server/boilerplate/boilerplate.factor     |  3 +
 extra/http/server/db/db.factor                |  4 +-
 extra/http/server/flows/flows.factor          | 50 +++++++++++++++++
 extra/http/server/server.factor               | 13 ++++-
 .../server/sessions/sessions-tests.factor     |  6 +-
 extra/http/server/sessions/sessions.factor    | 56 ++++++++++---------
 .../http/server/sessions/storage/db/db.factor | 17 ++++--
 .../server/sessions/storage/storage.factor    |  2 -
 .../http/server/templating/chloe/chloe.factor | 34 ++++++++---
 .../factor-website/factor-website.factor      | 46 +++++++--------
 extra/webapps/pastebin/pastebin.xml           |  2 +-
 extra/webapps/planet/entry-summary.xml        |  2 +-
 extra/webapps/planet/entry.xml                |  4 +-
 extra/webapps/planet/planet.factor            |  8 ++-
 extra/webapps/planet/planet.xml               |  2 +-
 extra/webapps/todo/todo.xml                   |  2 +-
 17 files changed, 178 insertions(+), 87 deletions(-)
 create mode 100644 extra/http/server/flows/flows.factor

diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 1b6ceeb51b..413e0a3cf4 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 "$login" or f 
-    f post-login-url sset ;
+    "$login" end-flow ;
 
 ::  ( -- action )
     [let | form [  ] |
@@ -155,8 +154,6 @@ SYMBOL: user-exists?
         "verify-password"  add-field
         "email"  add-field ;
 
-SYMBOL: previous-page
-
 ::  ( -- action )
     [let | form [  ] |
         
@@ -196,7 +193,7 @@ SYMBOL: previous-page
 
                 user-profile-changed? on
 
-                previous-page sget f 
+                "$login" end-flow
             ] >>submit
     ] ;
 
@@ -342,14 +339,15 @@ TUPLE: protected responder ;
 
 C:  protected
 
+M: protected init-session* responder>> init-session* ;
+
 : show-login-page ( -- response )
-    request get request-url post-login-url sset
+    begin-flow
     "$login/login" f  ;
 
 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
     ] [
         3drop
diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor
index eabcefeb7f..bfa79e1a4e 100644
--- a/extra/http/server/boilerplate/boilerplate.factor
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -5,6 +5,7 @@ io io.streams.string arrays
 html.elements
 http
 http.server
+http.server.sessions
 http.server.templating ;
 IN: http.server.boilerplate
 
@@ -12,6 +13,8 @@ TUPLE: boilerplate responder template ;
 
 :  f boilerplate boa ;
 
+M: boilerplate init-session* responder>> init-session* ;
+
 SYMBOL: title
 
 : set-title ( string -- )
diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor
index a8b929bc98..0e08705fa8 100755
--- a/extra/http/server/db/db.factor
+++ b/extra/http/server/db/db.factor
@@ -1,11 +1,13 @@
 ! 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 ;
 
+M: db-persistence init-session* responder>> init-session* ;
+
 C:  db-persistence
 
 : connect-db ( db-persistence -- )
diff --git a/extra/http/server/flows/flows.factor b/extra/http/server/flows/flows.factor
new file mode 100644
index 0000000000..f6e8d051ce
--- /dev/null
+++ b/extra/http/server/flows/flows.factor
@@ -0,0 +1,50 @@
+! 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 responder ;
+
+C:  flows
+
+: begin-flow* ( -- id )
+    request get [ path>> ] [ query>> ] bi 2array
+    flows sget set-at-unique
+    session-changed ;
+
+: end-flow* ( default id -- response )
+    flows sget at [ first2 ] [ 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
+    [ add-flow-id ] add-link-hook
+    [ flow-form-field ] add-form-hook
+    flow-id-key request-params at flow-id set
+    responder>> call-responder ;
+
+M: flows init-session*
+    H{ } clone flows sset
+    responder>> init-session* ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 88a748d949..e51cb70de5 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -69,8 +69,11 @@ SYMBOL: base-paths
 
 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
@@ -93,8 +96,11 @@ SYMBOL: link-hook
 
 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.
@@ -226,6 +232,9 @@ SYMBOL: exit-continuation
 : do-request ( request -- response )
     [
         H{ } clone base-paths set
+        [ ] link-hook set
+        [ ] form-hook set
+
         [ log-request ]
         [ request set ]
         [ path>> split-path main-responder get call-responder ] tri
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index 4d8c93ef67..85adf7e69f 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -3,7 +3,7 @@ USING: tools.test http http.server.sessions
 http.server.sessions.storage http.server.sessions.storage.db
 http.server.actions http.server math namespaces kernel accessors
 prettyprint io.streams.string io.files splitting destructors
-sequences db db.sqlite ;
+sequences db db.sqlite continuations ;
 
 : with-session
     [
@@ -49,8 +49,12 @@ M: foo call-responder
             "text/plain"  exit-with
         ] >>display ;
 
+[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
+
 "auth-test.db" temp-file sqlite-db [
 
+    init-sessions-table
+
     [
         empty-session
             123 >>id session set
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
index 5d0113b225..96d1c3beca 100755
--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@@ -10,11 +10,7 @@ http.server.sessions.storage.null
 html.elements ;
 IN: http.server.sessions
 
-! ! ! ! ! !
-! WARNING: this session manager is vulnerable to XSRF attacks
-! ! ! ! ! !
-
-TUPLE: session id user-agent client-addr namespace ;
+TUPLE: session id expiry namespace changed? ;
 
 :  ( id -- session )
     session new
@@ -24,6 +20,8 @@ GENERIC: init-session* ( responder -- )
 
 M: object init-session* drop ;
 
+M: dispatcher init-session* default>> init-session* ;
+
 TUPLE: session-manager responder sessions ;
 
 : new-session-manager ( responder class -- responder' )
@@ -31,18 +29,23 @@ TUPLE: session-manager responder sessions ;
         null-sessions >>sessions
         swap >>responder ; inline
 
-SYMBOL: session-changed?
+: (session-changed) ( session -- )
+    t >>changed? drop ;
+
+: session-changed ( -- )
+    session get (session-changed) ;
 
 : sget ( key -- value )
     session get namespace>> at ;
 
 : sset ( value key -- )
-    session get namespace>> set-at
-    session-changed? on ;
+    session get
+    [ namespace>> set-at ] [ (session-changed) ] bi ;
 
 : schange ( key quot -- )
-    session get namespace>> swap change-at
-    session-changed? on ; inline
+    session get
+    [ namespace>> swap change-at ] keep
+    (session-changed) ; inline
 
 : sessions session-manager get sessions>> ;
 
@@ -51,11 +54,18 @@ SYMBOL: session-changed?
 : init-session ( session managed -- )
     >r session r> '[ , init-session* ] with-variable ;
 
+: timeout 20 minutes ;
+
+: cutoff-time ( -- time )
+    now timeout time+ timestamp>millis ;
+
+: touch-session ( session -- )
+    cutoff-time >>expiry drop ;
+
 : empty-session ( -- session )
     f 
-        "" >>user-agent
-        "" >>client-addr
-        H{ } clone >>namespace ;
+        H{ } clone >>namespace
+        dup touch-session ;
 
 : begin-session ( responder -- session )
     >r empty-session r>
@@ -70,8 +80,9 @@ TUPLE: session-saver session ;
 C:  session-saver
 
 M: session-saver dispose
-    session-changed? get
-    [ session>> sessions update-session ] [ drop ] if ;
+    session>> dup changed?>> [
+        [ touch-session ] [ sessions update-session ] bi
+    ] [ drop ] if ;
 
 : save-session-after ( session -- )
      add-always-destructor ;
@@ -80,14 +91,6 @@ M: session-saver dispose
     [ save-session-after ] [ session set ] bi
     [ session-manager set ] [ responder>> call-responder ] bi ;
 
-TUPLE: null-sessions < session-manager ;
-
-:  ( responder -- manager )
-    null-sessions new-session-manager ;
-
-M: null-sessions call-responder ( path responder -- response )
-     call-responder/session ;
-
 TUPLE: url-sessions < session-manager ;
 
 :  ( responder -- responder' )
@@ -105,9 +108,8 @@ TUPLE: url-sessions < session-manager ;
 : session-form-field ( -- )
     > =value
+        session get id>> number>string =value
     input/> ;
 
 : new-url-session ( path responder -- response )
@@ -115,8 +117,8 @@ TUPLE: url-sessions < session-manager ;
      ;
 
 M: url-sessions call-responder ( path responder -- response )
-    [ add-session-id ] link-hook set
-    [ session-form-field ] form-hook set
+    [ add-session-id ] add-link-hook
+    [ session-form-field ] add-form-hook
     dup current-url-session [
         call-responder/session
     ] [
diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor
index bddb783c97..637d86670f 100755
--- a/extra/http/server/sessions/storage/db/db.factor
+++ b/extra/http/server/sessions/storage/db/db.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors kernel http.server.sessions.storage
-http.server.sessions http.server db.tuples db.types math.parser
-classes.singleton random ;
+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
@@ -11,8 +11,7 @@ session "SESSIONS"
 {
     ! { "id" "ID" +random-id+ system-random-generator }
     { "id" "ID" INTEGER +native-id+ }
-    { "user-agent" "USERAGENT" { VARCHAR 256 } +not-null+ }
-    { "client-addr" "CLIENTADDR" { VARCHAR 256 } +not-null+ }
+    { "expiry" "EXPIRY" BIG-INTEGER +not-null+ }
     { "namespace" "NAMESPACE" FACTOR-BLOB }
 } define-persistent
 
@@ -29,3 +28,13 @@ M: sessions-in-db delete-session ( id storage -- )
 
 M: sessions-in-db new-session ( session storage -- )
     drop insert-tuple ;
+
+: expired-sessions ( -- session )
+    f 
+    USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expiry
+    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/storage.factor b/extra/http/server/sessions/storage/storage.factor
index 97d869e60a..c605600f7b 100755
--- a/extra/http/server/sessions/storage/storage.factor
+++ b/extra/http/server/sessions/storage/storage.factor
@@ -3,8 +3,6 @@
 USING: calendar ;
 IN: http.server.sessions.storage
 
-: timeout 20 minutes ;
-
 GENERIC: get-session ( id storage -- session )
 
 GENERIC: update-session ( session storage -- )
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
index 3793604929..99d6376fe8 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -4,6 +4,7 @@ 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
@@ -83,14 +84,33 @@ SYMBOL: tags
     dup empty?
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 
+: a-flow-attr ( tag -- )
+    "flow" optional-attr {
+        { "none" [ flow-id off ] }
+        { "begin" [ begin-flow ] }
+        { "current" [ ] }
+        { f [ ] }
+    } case ;
+
+: a-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 ;
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index d78fd4b6c2..d6ddeb32bb 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -4,6 +4,7 @@ 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
@@ -20,27 +21,6 @@ IN: webapps.factor-website
 : factor-template ( path -- template )
     "resource:extra/webapps/factor-website/" swap ".xml" 3append  ;
 
-:  ( responder -- responder' )
-    
-        users-in-db >>users
-        allow-registration
-        allow-password-recovery
-        allow-edit-profile
-    
-        "page" factor-template >>template
-    
-        sessions-in-db >>sessions
-    test-db  ;
-
-:  ( -- responder )
-      ;
-
-:  ( -- responder )
-      ;
-
-:  ( -- responder )
-       ;
-
 : init-factor-db ( -- )
     test-db [
         init-users-table
@@ -56,9 +36,20 @@ IN: webapps.factor-website
 
 :  ( -- responder )
     
-         "todo" add-responder
-         "pastebin" add-responder
-         "planet" add-responder ;
+         "todo" add-responder
+         "pastebin" add-responder
+         "planet" add-responder
+    
+        users-in-db >>users
+        allow-registration
+        allow-password-recovery
+        allow-edit-profile
+    
+        "page" factor-template >>template
+    
+    
+        sessions-in-db >>sessions
+    test-db  ;
 
 : init-factor-website ( -- )
     "factorcode.org" 25  smtp-server set-global
@@ -66,6 +57,9 @@ IN: webapps.factor-website
 
     init-factor-db
 
-     main-responder set-global
+     main-responder set-global ;
 
-    "planet" main-responder get responders>> at start-update-task ;
+: 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/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml
index 2d335fe9ce..6b49162637 100644
--- a/extra/webapps/pastebin/pastebin.xml
+++ b/extra/webapps/pastebin/pastebin.xml
@@ -13,7 +13,7 @@
 
 		
 		
-			| Edit Profile
+			| Edit Profile
 		
 
 		
diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml
index a87703252c..905795373b 100644
--- a/extra/webapps/planet/entry-summary.xml
+++ b/extra/webapps/planet/entry-summary.xml
@@ -4,7 +4,7 @@
 
 	

 		 

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

 
 
diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml
index bc89af3263..0e52c191a5 100644
--- a/extra/webapps/planet/entry.xml
+++ b/extra/webapps/planet/entry.xml
@@ -3,7 +3,7 @@
 
 
 	

-		
+		
 	

 
 	

@@ -11,7 +11,7 @@
 	

 
 	

-		
+		
 	

 
 
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 3cd35be5fb..752db18ee7 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sorting locals math
 calendar alarms logging concurrency.combinators namespaces
-sequences.lib db.types db.tuples db
+sequences.lib db.types db.tuples db fry
 rss xml.writer
 http.server
 http.server.crud
@@ -167,5 +167,7 @@ blog "BLOGS"
     
         "planet" planet-template >>template ;
 
-: start-update-task ( planet -- )
-    [ update-cached-postings ] curry 10 minutes every drop ;
+: start-update-task ( planet db seq -- )
+    '[
+        , , , [ update-cached-postings ] with-db
+    ] 10 minutes every drop ;
diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml
index c96a143246..328be84544 100644
--- a/extra/webapps/planet/planet.xml
+++ b/extra/webapps/planet/planet.xml
@@ -14,7 +14,7 @@
 
 		
 		
-			| Edit Profile
+			| Edit Profile
 		
 
 		
diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml
index 70bbb1250b..4e307b7cae 100644
--- a/extra/webapps/todo/todo.xml
+++ b/extra/webapps/todo/todo.xml
@@ -9,7 +9,7 @@
 		| Add Item
 
 		
-			| Edit Profile
+			| Edit Profile
 		
 
 		

From d44d5aba34de733b7e92255f62fddad535570a83 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sat, 26 Apr 2008 05:49:53 -0500
Subject: [PATCH 32/55] Smaller random ids

---
 extra/assocs/lib/lib.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 92fb9aac81..247be44bad 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -38,7 +38,7 @@ IN: assocs.lib
 : insert ( value variable -- ) namespace insert-at ;
 
 : generate-key ( assoc -- str )
-    >r 256 random-bits >hex r>
+    >r 32 random-bits >hex r>
     2dup key? [ nip generate-key ] [ drop ] if ;
 
 : set-at-unique ( value assoc -- key )

From 14b78f348e3b59062f65b56c14507533900d4375 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sat, 26 Apr 2008 05:49:59 -0500
Subject: [PATCH 33/55] Better error message

---
 extra/serialize/serialize.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor
index bb69a8a41c..27126f49eb 100755
--- a/extra/serialize/serialize.factor
+++ b/extra/serialize/serialize.factor
@@ -230,6 +230,7 @@ SYMBOL: deserialized
 : deserialize-word ( -- word )
     (deserialize) (deserialize) 2dup lookup
     dup [ 2nip ] [
+        drop
         "Unknown word: " -rot
         2array unparse append throw
     ] if ;

From 439c138aa5aef1c76f8fc17eccfe598523187e85 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 11:03:41 -0500
Subject: [PATCH 34/55] fix load errors

---
 extra/benchmark/binary-trees/binary-trees.factor        | 2 +-
 extra/benchmark/mandel/mandel.factor                    | 2 +-
 extra/boids/boids.factor                                | 1 +
 extra/bubble-chamber/particle/muon/colors/colors.factor | 2 +-
 extra/gap-buffer/gap-buffer.factor                      | 3 ++-
 extra/html/html.factor                                  | 2 +-
 extra/json/reader/reader.factor                         | 2 +-
 extra/koszul/koszul.factor                              | 2 +-
 extra/levenshtein/levenshtein.factor                    | 3 ++-
 extra/lsys/tortoise/graphics/graphics.factor            | 2 +-
 extra/lsys/ui/ui.factor                                 | 5 +++--
 extra/math/combinatorics/combinatorics-docs.factor      | 2 +-
 extra/math/combinatorics/combinatorics.factor           | 3 ++-
 extra/math/polynomials/polynomials.factor               | 2 +-
 extra/math/primes/primes.factor                         | 2 +-
 extra/maze/maze.factor                                  | 3 ++-
 extra/multi-methods/multi-methods.factor                | 2 +-
 extra/ogg/player/player.factor                          | 2 +-
 extra/optimizer/report/report.factor                    | 4 ++--
 extra/processing/gallery/trails/trails.factor           | 4 ++--
 extra/project-euler/019/019.factor                      | 2 +-
 extra/project-euler/076/076.factor                      | 3 ++-
 extra/project-euler/117/117.factor                      | 2 +-
 extra/project-euler/134/134.factor                      | 4 ++--
 extra/project-euler/150/150.factor                      | 3 ++-
 extra/project-euler/151/151.factor                      | 3 ++-
 extra/project-euler/common/common.factor                | 4 ++--
 extra/regexp/regexp.factor                              | 2 +-
 extra/regexp2/regexp2.factor                            | 2 +-
 extra/reports/noise/noise.factor                        | 2 +-
 extra/reports/optimizer/optimizer.factor                | 2 +-
 extra/roman/roman.factor                                | 2 +-
 extra/rss/rss.factor                                    | 4 ++--
 extra/taxes/taxes.factor                                | 2 +-
 extra/trees/avl/avl.factor                              | 3 ++-
 extra/trees/splay/splay.factor                          | 2 +-
 extra/trees/trees.factor                                | 2 +-
 extra/webapps/planet/planet.factor                      | 2 +-
 extra/wrap/wrap.factor                                  | 2 +-
 extra/x11/events/events.factor                          | 3 ++-
 extra/xml-rpc/xml-rpc.factor                            | 4 ++--
 extra/xml/char-classes/char-classes.factor              | 2 +-
 extra/yahoo/yahoo.factor                                | 2 +-
 43 files changed, 60 insertions(+), 49 deletions(-)

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/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/boids/boids.factor b/extra/boids/boids.factor
index 91e5e5fe22..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
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/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/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/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 b4a0934e41..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
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/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/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
 
 r optimize-1
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/019/019.factor b/extra/project-euler/019/019.factor
index a2c3ebcd1f..5006301c2b 100644
--- a/extra/project-euler/019/019.factor
+++ b/extra/project-euler/019/019.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: calendar combinators kernel math math.ranges namespaces sequences
-    sequences.lib ;
+    sequences.lib math.order ;
 IN: project-euler.019
 
 ! http://projecteuler.net/index.php?section=problems&id=19
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/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 c8bd28a3a9..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
 
 
Date: Sat, 26 Apr 2008 11:06:46 -0500
Subject: [PATCH 35/55] fix using

---
 core/cpu/ppc/assembler/assembler.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor
index 628022698f..e85e03bf9c 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.
-IN: cpu.ppc.assembler
 USING: generator.fixup generic kernel math memory namespaces
-words math.bitfields io.binary ;
+words math.bitfields math.order io.binary ;
+IN: cpu.ppc.assembler
 
 ! See the Motorola or IBM documentation for details. The opcode
 ! names are standard, and the operand order is the same as in

From 658ec32b6749a7eebfac6434793f94eab895f3a1 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 11:28:08 -0500
Subject: [PATCH 36/55] rearrange IN: add using

---
 core/command-line/command-line.factor         | 2 +-
 core/cpu/ppc/architecture/architecture.factor | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor
index f4aef6292d..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 [
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

From 0b72829d079e079924bf43bec31fb0e785c0ce70 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 12:55:10 -0500
Subject: [PATCH 37/55] add >string on byte-array for string comparison use
 ERROR:

---
 extra/graphics/bitmap/bitmap.factor | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index 861894c8f4..893fd0d6cf 100755
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -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 ] keep
     4 read le> over set-bitmap-size
     4 read le> over set-bitmap-reserved
     4 read le> swap set-bitmap-offset ;

From 2b1d5789a6e4065e9ff1a0a430df3e7857bad15d Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 13:01:11 -0500
Subject: [PATCH 38/55] fix bitmap parsing, fix tests

---
 extra/graphics/bitmap/bitmap.factor | 20 +++++++++-----------
 1 file changed, 9 insertions(+), 11 deletions(-)

diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index 893fd0d6cf..d9cc310454 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
 
@@ -32,7 +32,7 @@ M: bitmap-magic summary
 
 : parse-file-header ( bitmap -- )
     2 read >string dup "BM" = [ bitmap-magic ] unless
-        [ over set-bitmap-magic ] keep
+        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 ;
@@ -63,7 +63,7 @@ M: bitmap-magic summary
     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
@@ -121,16 +121,14 @@ M: bitmap height ( bitmap -- ) bitmap-height ;
     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. ;
 

From 7b9a757076d610b52688d44cb3100e1e6baadb44 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 13:04:10 -0500
Subject: [PATCH 39/55] keep gadget on stack, fix stack effect

---
 extra/graphics/bitmap/bitmap.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index d9cc310454..611319e28b 100755
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -117,8 +117,8 @@ 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 ( -- )
     "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;

From 60fb68d1de99f7e9728b305a2c24ba2749c00ad8 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 18:44:28 -0500
Subject: [PATCH 40/55] rename state-parser:rest to take-rest

---
 extra/calendar/calendar-tests.factor              |  6 +++++-
 extra/calendar/format/format-tests.factor         |  2 +-
 extra/multi-methods/tests/topological-sort.factor |  3 ++-
 extra/state-parser/state-parser-tests.factor      | 12 ++++++------
 extra/state-parser/state-parser.factor            |  2 +-
 5 files changed, 15 insertions(+), 10 deletions(-)

diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor
index d4cddb6081..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 math.order ;
+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/format/format-tests.factor b/extra/calendar/format/format-tests.factor
index 1ba892bef3..2eef21a013 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 ] [
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/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 )

From 93aa8669c40abf2c6265dcc372885ea48ba962b7 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 18:44:51 -0500
Subject: [PATCH 41/55] fix load error

---
 extra/db/sql/sql.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

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

From 550b83278a10b9123a6577d96a759b74e0b724ad Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 18:45:03 -0500
Subject: [PATCH 42/55] fix unit test

---
 core/strings/strings-tests.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor
index 6d01e19585..44e1d8859f 100755
--- a/core/strings/strings-tests.factor
+++ b/core/strings/strings-tests.factor
@@ -31,8 +31,8 @@ IN: strings.tests
 
 [ t ] [ "abc" "abd" before? ] unit-test
 [ t ] [ "z" "abd" after? ] unit-test
-[ t ] [ "abc" "abd" min ] unit-test
-[ t ] [ "z" "abd" max ] unit-test
+[ "abc" ] [ "abc" "abd" min ] unit-test
+[ "z" ] [ "z" "abd" max ] unit-test
 
 [ 0 10 "hello" subseq ] must-fail
 

From 6ee115901a99d6c5a4325dcdd7bde48e5ef501f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sat, 26 Apr 2008 18:55:26 -0500
Subject: [PATCH 43/55] Better error message

---
 core/parser/parser.factor |  5 +++++
 core/syntax/syntax.factor | 10 +++++++---
 2 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 961fa89d8f..55dd8220db 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -345,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
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

From 7d16edcc79642d90bad7ed49362d114d854b69c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sat, 26 Apr 2008 18:56:51 -0500
Subject: [PATCH 44/55] Merge URL and cookie session managers, clean up some
 code

---
 extra/http/http-tests.factor                  |  4 +-
 extra/http/server/auth/auth.factor            | 12 ++-
 extra/http/server/auth/basic/basic.factor     |  4 +-
 extra/http/server/auth/login/login.factor     | 11 +--
 .../server/boilerplate/boilerplate.factor     |  6 +-
 extra/http/server/db/db.factor                |  6 +-
 extra/http/server/flows/flows.factor          |  6 +-
 extra/http/server/server-tests.factor         |  2 +
 extra/http/server/server.factor               |  5 +
 .../server/sessions/sessions-tests.factor     | 41 ++------
 extra/http/server/sessions/sessions.factor    | 93 +++++++------------
 extra/webapps/pastebin/pastebin.factor        |  5 +-
 extra/webapps/todo/todo.factor                |  1 +
 13 files changed, 80 insertions(+), 116 deletions(-)

diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 553b4f2cda..a9e539c2a5 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -194,7 +194,7 @@ test-db [
         
              
             
-            
+            
                 sessions-in-db >>sessions
             "" add-responder
             add-quit-action
@@ -225,7 +225,7 @@ test-db [
         
              [ "text/plain"  [ "Hi" write ] >>body ] >>display
             
-            
+            
                 sessions-in-db >>sessions
             "" add-responder
             add-quit-action
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..62625e116b 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
 
@@ -38,4 +38,4 @@ C:  basic-auth
 
 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/login.factor b/extra/http/server/auth/login/login.factor
index 413e0a3cf4..5f58f51adb 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -138,7 +138,7 @@ SYMBOL: user-exists?
 
                 successful-login
 
-                login get default>> responder>> init-user-profile
+                login get init-user-profile
             ] >>submit
     ] ;
 
@@ -177,7 +177,8 @@ SYMBOL: user-exists?
 
                 logged-in-user sget
 
-                "password" value empty? [
+                { "password" "new-password" "verify-password" }
+                [ value empty? ] all? [
                     same-password-twice
 
                     "password" value uid users check-login
@@ -335,12 +336,10 @@ SYMBOL: lost-password-from
 
 ! ! ! Authentication logic
 
-TUPLE: protected responder ;
+TUPLE: protected < filter-responder ;
 
 C:  protected
 
-M: protected init-session* responder>> init-session* ;
-
 : show-login-page ( -- response )
     begin-flow
     "$login/login" f  ;
@@ -348,7 +347,7 @@ M: protected init-session* responder>> init-session* ;
 M: protected call-responder ( path responder -- response )
     logged-in-user sget dup [
         save-user-after
-        responder>> call-responder
+        call-next-method
     ] [
         3drop
         request get method>> { "GET" "HEAD" } member?
diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor
index bfa79e1a4e..fbe027cc05 100644
--- a/extra/http/server/boilerplate/boilerplate.factor
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -9,12 +9,10 @@ http.server.sessions
 http.server.templating ;
 IN: http.server.boilerplate
 
-TUPLE: boilerplate responder template ;
+TUPLE: boilerplate < filter-responder template ;
 
 :  f boilerplate boa ;
 
-M: boilerplate init-session* responder>> init-session* ;
-
 SYMBOL: title
 
 : set-title ( string -- )
@@ -71,7 +69,7 @@ M: f call-template* drop call-next-template ;
     ] with-scope ; inline
 
 M: boilerplate call-responder
-    tuck responder>> 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/db/db.factor b/extra/http/server/db/db.factor
index 0e08705fa8..221608fc91 100755
--- a/extra/http/server/db/db.factor
+++ b/extra/http/server/db/db.factor
@@ -4,9 +4,7 @@ USING: db http.server http.server.sessions kernel accessors
 continuations namespaces destructors ;
 IN: http.server.db
 
-TUPLE: db-persistence responder db params ;
-
-M: db-persistence init-session* responder>> init-session* ;
+TUPLE: db-persistence < filter-responder db params ;
 
 C:  db-persistence
 
@@ -15,4 +13,4 @@ C:  db-persistence
     [ db set ] [ add-always-destructor ] bi ;
 
 M: db-persistence call-responder
-    [ connect-db ] [ responder>> call-responder ] bi ;
+    [ connect-db ] [ call-next-method ] bi ;
diff --git a/extra/http/server/flows/flows.factor b/extra/http/server/flows/flows.factor
index f6e8d051ce..14ac1d8d79 100644
--- a/extra/http/server/flows/flows.factor
+++ b/extra/http/server/flows/flows.factor
@@ -5,7 +5,7 @@ assocs assocs.lib hashtables math.parser
 html.elements http http.server http.server.sessions ;
 IN: http.server.flows
 
-TUPLE: flows responder ;
+TUPLE: flows < filter-responder ;
 
 C:  flows
 
@@ -43,8 +43,8 @@ M: flows call-responder
     [ add-flow-id ] add-link-hook
     [ flow-form-field ] add-form-hook
     flow-id-key request-params at flow-id set
-    responder>> call-responder ;
+    call-next-method ;
 
 M: flows init-session*
     H{ } clone flows sset
-    responder>> init-session* ;
+    call-next-method ;
diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor
index 84e873d001..2048164884 100755
--- a/extra/http/server/server-tests.factor
+++ b/extra/http/server/server-tests.factor
@@ -11,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
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index e51cb70de5..13ed36ec65 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -181,6 +181,11 @@ M: vhost-dispatcher call-responder ( path dispatcher -- response )
     [ drop "" add-responder drop ]
     [ 2drop ] 3tri ;
 
+TUPLE: filter-responder responder ;
+
+M: filter-responder call-responder
+    responder>> call-responder ;
+
 SYMBOL: main-responder
 
 main-responder global
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index 85adf7e69f..4ff26c3a8f 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -32,7 +32,7 @@ M: foo call-responder
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
 
-: cookie-responder-mock-test
+: session-manager-mock-test
     [
         
             "GET" >>method
@@ -58,9 +58,6 @@ M: foo call-responder
     [
         empty-session
             123 >>id session set
-        session-changed? off
-
-        [ H{ { "factorsessid" 123 } } ] [ H{ } add-session-id ] unit-test
 
         [ ] [ 3 "x" sset ] unit-test
 
@@ -70,14 +67,11 @@ M: foo call-responder
 
         [ 4 ] [ "x" sget sq ] unit-test
 
-        [ t ] [ session-changed? get ] unit-test
+        [ t ] [ session get changed?>> ] unit-test
     ] with-scope
 
-    [ t ] [ f  url-sessions? ] unit-test
-    [ t ] [ f  cookie-sessions? ] unit-test
-
     [ ] [
-         
+         
             sessions-in-db >>sessions
         session-manager set
     ] unit-test
@@ -113,26 +107,7 @@ M: foo call-responder
     ] unit-test
 
     [ ] [
-        [
-            
-            "GET" >>method
-            request set
-            { "etc" } session-manager get call-responder
-        ] with-destructors
-        response set
-    ] unit-test
-
-    [ 307 ] [ response get code>> ] unit-test
-
-    [ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
-
-    [ "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-in-db >>sessions
         session-manager set
     ] unit-test
@@ -150,9 +125,9 @@ M: foo call-responder
 
     [ ] [ response get cookies>> "cookies" set ] unit-test
 
-    [ "2" ] [ cookie-responder-mock-test ] unit-test
-    [ "3" ] [ cookie-responder-mock-test ] unit-test
-    [ "4" ] [ cookie-responder-mock-test ] unit-test
+    [ "2" ] [ session-manager-mock-test ] unit-test
+    [ "3" ] [ session-manager-mock-test ] unit-test
+    [ "4" ] [ session-manager-mock-test ] unit-test
 
     [
         [ ] [
@@ -163,7 +138,7 @@ M: foo call-responder
             request set
 
             [
-                { }  
+                { }  
                     sessions-in-db >>sessions
                 call-responder
             ] with-destructors response set
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
index 96d1c3beca..d2c1d90e0a 100755
--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel math.parser namespaces random
 accessors quotations hashtables sequences continuations
-fry calendar destructors
+fry calendar combinators destructors
 http
 http.server
 http.server.sessions.storage
@@ -22,12 +22,12 @@ M: object init-session* drop ;
 
 M: dispatcher init-session* default>> init-session* ;
 
-TUPLE: session-manager responder sessions ;
+M: filter-responder init-session* responder>> init-session* ;
 
-: new-session-manager ( responder class -- responder' )
-    new
-        null-sessions >>sessions
-        swap >>responder ; inline
+TUPLE: session-manager < filter-responder sessions ;
+
+:  ( responder -- responder' )
+    null-sessions session-manager boa ;
 
 : (session-changed) ( session -- )
     t >>changed? drop ;
@@ -49,8 +49,6 @@ TUPLE: session-manager responder sessions ;
 
 : sessions session-manager get sessions>> ;
 
-: managed-responder session-manager get responder>> ;
-
 : init-session ( session managed -- )
     >r session r> '[ , init-session* ] with-variable ;
 
@@ -69,7 +67,7 @@ TUPLE: session-manager responder sessions ;
 
 : begin-session ( responder -- session )
     >r empty-session r>
-    [ responder>> init-session ]
+    [ init-session ]
     [ sessions>> new-session ]
     [ drop ]
     2tri ;
@@ -87,23 +85,37 @@ M: session-saver dispose
 : save-session-after ( session -- )
      add-always-destructor ;
 
-: call-responder/session ( path responder session -- response )
-    [ save-session-after ] [ session set ] bi
+: existing-session ( path responder session -- response )
+    [ session set ] [ save-session-after ] bi
     [ session-manager set ] [ responder>> call-responder ] bi ;
 
-TUPLE: url-sessions < session-manager ;
-
-:  ( responder -- responder' )
-    url-sessions new-session-manager ;
-
 : session-id-key "factorsessid" ;
 
-: current-url-session ( responder -- session/f )
-    >r request-params session-id-key swap at string>number
-    r> sessions>> get-session ;
+: cookie-session-id ( -- id/f )
+    request get session-id-key get-cookie
+    dup [ value>> string>number ] when ;
 
-: add-session-id ( query -- query' )
-    session get [ id>> 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  ;
+
+: new-session ( path responder -- response )
+    dup begin-session
+    [ existing-session ]
+    [ id>> number>string  ] bi
+    put-cookie ;
 
 : session-form-field ( -- )
     > number>string =value
     input/> ;
 
-: new-url-session ( path responder -- response )
-    [ drop f ] [ begin-session id>> session-id-key associate ] bi*
-     ;
-
-M: url-sessions call-responder ( path responder -- response )
-    [ add-session-id ] add-link-hook
+M: session-manager call-responder ( path responder -- response )
     [ session-form-field ] add-form-hook
-    dup current-url-session [
-        call-responder/session
-    ] [
-        new-url-session
-    ] if* ;
-
-TUPLE: cookie-sessions < session-manager ;
-
-:  ( responder -- responder' )
-    cookie-sessions new-session-manager ;
-
-: current-cookie-session ( responder -- session/f )
-    request get session-id-key get-cookie dup
-    [ value>> string>number swap sessions>> get-session ]
-    [ 2drop f ] if ;
-
-:  ( id -- cookie )
-    session-id-key  ;
-
-: call-responder/new-session ( path responder -- response )
-    dup begin-session
-    [ call-responder/session ]
-    [ id>> number>string  ] bi
-    put-cookie ;
-
-M: cookie-sessions call-responder ( path responder -- response )
-    dup current-cookie-session [
-        call-responder/session
-    ] [
-        call-responder/new-session
-    ] if* ;
+    dup request-session [ existing-session ] [ new-session ] if* ;
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 4fa8f55ca8..07b3e9c02d 100644
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -8,6 +8,7 @@ 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 ;
@@ -240,8 +241,8 @@ TUPLE: pastebin < 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/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
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index bb4a4b9cd2..5c60b37f82 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -70,4 +70,5 @@ TUPLE: todo-list < dispatcher ;
                       ctor "$todo-list/list"  "delete" add-responder
         
             "todo" todo-template >>template
+        
     ] ;

From 081d71727a7592c52b8adfbcaef90c6d74555c5e Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Sat, 26 Apr 2008 23:41:18 -0500
Subject: [PATCH 45/55] fix load error

---
 extra/state-parser/state-parser-docs.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

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" } ;
 

From 6980050a83685bc3b50cad71da21c63105f0a1b3 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sun, 27 Apr 2008 01:46:38 -0500
Subject: [PATCH 46/55] Add MEMO::

---
 extra/locals/locals.factor   | 4 +++-
 extra/memoize/memoize.factor | 3 +--
 2 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index be73f1db88..068f5d9a36 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
 arrays macros splitting combinators prettyprint.backend
 definitions prettyprint hashtables prettyprint.sections sets
 sequences.private effects generic compiler.units accessors
-locals.backend ;
+locals.backend memoize ;
 IN: locals
 
 ! Inspired by
@@ -298,6 +298,8 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 
 : MACRO:: (::) define-macro ; parsing
 
+: MEMO:: (::) define-memoized ; parsing
+
 
Date: Sun, 27 Apr 2008 01:49:05 -0500
Subject: [PATCH 47/55] Documentation for MEMO::

---
 extra/locals/locals-docs.factor | 14 ++++++++++++--
 1 file changed, 12 insertions(+), 2 deletions(-)

diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor
index 372a567550..a022b92a88 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
 
 
Date: Sun, 27 Apr 2008 03:09:00 -0500
Subject: [PATCH 48/55] Improved cookie support, and better session manager
 taking advantage of it

---
 extra/calendar/format/format-tests.factor     |   7 +
 extra/calendar/format/format.factor           | 186 +++++++++++-------
 .../format/macros/macros-tests.factor         |  14 ++
 extra/calendar/format/macros/macros.factor    |  19 ++
 extra/http/http-tests.factor                  |   2 +-
 extra/http/http.factor                        |  18 +-
 .../http/server/actions/actions-tests.factor  |   1 +
 extra/http/server/actions/actions.factor      |  17 +-
 extra/http/server/auth/basic/basic.factor     |   2 +-
 extra/http/server/auth/login/edit-profile.xml |  18 +-
 extra/http/server/auth/login/login.factor     |  12 +-
 extra/http/server/auth/login/login.xml        |  12 +-
 extra/http/server/auth/login/recover-1.xml    |   8 +-
 extra/http/server/auth/login/recover-3.xml    |  12 +-
 extra/http/server/auth/login/recover-4.xml    |   2 +-
 extra/http/server/auth/login/register.xml     |  18 +-
 .../server/boilerplate/boilerplate.factor     |   2 +-
 extra/http/server/callbacks/callbacks.factor  |   2 +-
 extra/http/server/crud/crud.factor            |   4 +-
 extra/http/server/db/db.factor                |   2 +-
 extra/http/server/flows/flows.factor          |  22 ++-
 extra/http/server/server-tests.factor         |   6 +-
 extra/http/server/server.factor               |  35 ++--
 .../server/sessions/sessions-tests.factor     |  15 +-
 extra/http/server/sessions/sessions.factor    |  54 ++---
 .../http/server/sessions/storage/db/db.factor |   4 +-
 extra/http/server/static/static.factor        |   4 +-
 .../http/server/templating/chloe/chloe.factor |  44 +++--
 .../factor-website/factor-website.factor      |   2 +-
 extra/webapps/factor-website/page.xml         |   2 +-
 extra/webapps/pastebin/annotation.xml         |  16 +-
 extra/webapps/pastebin/new-annotation.xml     |  14 +-
 extra/webapps/pastebin/new-paste.xml          |  12 +-
 extra/webapps/pastebin/paste-list.xml         |   2 +-
 extra/webapps/pastebin/paste-summary.xml      |   6 +-
 extra/webapps/pastebin/paste.xml              |  20 +-
 extra/webapps/pastebin/pastebin.factor        |   2 +-
 extra/webapps/pastebin/pastebin.xml           |  27 +--
 extra/webapps/planet/admin.xml                |   6 +-
 extra/webapps/planet/blog-admin-link.xml      |   2 +-
 extra/webapps/planet/edit-blog.xml            |  14 +-
 extra/webapps/planet/entry-summary.xml        |   4 +-
 extra/webapps/planet/entry.xml                |   6 +-
 extra/webapps/planet/planet.factor            |   5 +-
 extra/webapps/planet/planet.xml               |  22 +--
 extra/webapps/planet/postings-summary.xml     |   2 +-
 extra/webapps/planet/postings.xml             |   4 +-
 extra/webapps/todo/todo-list.xml              |   2 +-
 extra/webapps/todo/todo-summary.xml           |   8 +-
 extra/webapps/todo/todo.xml                   |  10 +-
 extra/webapps/todo/view-todo.xml              |   8 +-
 51 files changed, 441 insertions(+), 297 deletions(-)
 create mode 100644 extra/calendar/format/macros/macros-tests.factor
 create mode 100644 extra/calendar/format/macros/macros.factor

diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor
index 1ba892bef3..0d072f27f6 100755
--- a/extra/calendar/format/format-tests.factor
+++ b/extra/calendar/format/format-tests.factor
@@ -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..af536c2585 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.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/http/http-tests.factor b/extra/http/http-tests.factor
index a9e539c2a5..e624f56573 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -158,7 +158,7 @@ test-db [
                 "extra/http/test" resource-path  >>default
             "nested" add-responder
             
-                [ "redirect-loop" f  ] >>display
+                [ "redirect-loop" f  ] >>display
             "redirect-loop" add-responder
         main-responder set
 
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 3e81fccd24..99a48e58d8 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 ] }
                 { "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 615077821a..5aa761603f 100755
--- a/extra/http/server/actions/actions-tests.factor
+++ b/extra/http/server/actions/actions-tests.factor
@@ -22,6 +22,7 @@ blah
 ;
 
 [ 25 ] [
+    init-request
     action-request-test-1 lf>crlf
     [ read-request ] with-string-reader
     request set
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index bfcbd20cca..6e1aac9627 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -37,16 +37,19 @@ 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 )
     '[
         , [ CHAR: / = ] right-trim empty? [
             , action set
-            request-params params set
-            request get method>> {
-                { "GET" [ handle-get ] }
-                { "HEAD" [ handle-get ] }
-                { "POST" [ handle-post ] }
-            } case
+            request get
+            [ request-params params set ]
+            [
+                method>> {
+                    { "GET" [ handle-get ] }
+                    { "HEAD" [ handle-get ] }
+                    { "POST" [ handle-post ] }
+                } case
+            ] bi
         ] [
             <404>
         ] if
diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor
index 62625e116b..daf6e30eae 100755
--- a/extra/http/server/auth/basic/basic.factor
+++ b/extra/http/server/auth/basic/basic.factor
@@ -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?
     [ 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 5f58f51adb..716996dc5a 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -331,7 +331,7 @@ SYMBOL: lost-password-from
     
         [
             f logged-in-user sset
-            "$login/login" f 
+            "$login/login" end-flow
         ] >>submit ;
 
 ! ! ! Authentication logic
@@ -342,19 +342,17 @@ C:  protected
 
 : show-login-page ( -- response )
     begin-flow
-    "$login/login" f  ;
+    "$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
         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 fbe027cc05..1dc5effbe2 100644
--- a/extra/http/server/boilerplate/boilerplate.factor
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -68,7 +68,7 @@ M: f call-template* drop call-next-template ;
         bi*
     ] with-scope ; inline
 
-M: boilerplate call-responder
+M: boilerplate call-responder*
     tuck call-next-method
     dup "content-type" header "text/html" = [
         clone swap template>>
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/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 221608fc91..047af3f4ac 100755
--- a/extra/http/server/db/db.factor
+++ b/extra/http/server/db/db.factor
@@ -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
+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
index 14ac1d8d79..7a9b362111 100644
--- a/extra/http/server/flows/flows.factor
+++ b/extra/http/server/flows/flows.factor
@@ -10,12 +10,25 @@ TUPLE: flows < filter-responder ;
 C:  flows
 
 : begin-flow* ( -- id )
-    request get [ path>> ] [ query>> ] bi 2array
+    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 [ first2 ] [ f ] ?if  ;
+    flows sget at
+    [ first3 "POST" = [ end-flow-post ] [  ] if ]
+    [ f  ] ?if ;
 
 SYMBOL: flow-id
 
@@ -39,10 +52,11 @@ SYMBOL: flow-id
         input/>
     ] when* ;
 
-M: flows call-responder
+M: flows call-responder*
+    dup flows set
     [ add-flow-id ] add-link-hook
     [ flow-form-field ] add-form-hook
-    flow-id-key request-params at flow-id set
+    flow-id-key request get request-params at flow-id set
     call-next-method ;
 
 M: flows init-session*
diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor
index 2048164884..a5dffbc58b 100755
--- a/extra/http/server/server-tests.factor
+++ b/extra/http/server/server-tests.factor
@@ -27,7 +27,7 @@ TUPLE: mock-responder path ;
 
 C:  mock-responder
 
-M: mock-responder call-responder
+M: mock-responder call-responder*
     nip
     path>> on
     "text/plain"  ;
@@ -81,7 +81,7 @@ TUPLE: path-check-responder ;
 
 C:  path-check-responder
 
-M: path-check-responder call-responder
+M: path-check-responder call-responder*
     drop
     "text/plain"  swap >array >>body ;
 
@@ -121,7 +121,7 @@ TUPLE: base-path-check-responder ;
 
 C:  base-path-check-responder
 
-M: base-path-check-responder call-responder
+M: base-path-check-responder call-responder*
     2drop
     "$funny-dispatcher" resolve-base-path
     "text/plain"  swap >>body ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 13ed36ec65..6c128b3d83 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -9,10 +9,10 @@ IN: http.server
 
 ! path is a sequence of path component strings
 
-GENERIC: call-responder ( path responder -- response )
+GENERIC: call-responder* ( path responder -- response )
 
-: request-params ( -- assoc )
-    request get dup method>> {
+: request-params ( request -- assoc )
+    dup method>> {
         { "GET" [ query>> ] }
         { "HEAD" [ query>> ] }
         { "POST" [ post-data>> ] }
@@ -28,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 -- )
     
@@ -67,6 +67,9 @@ SYMBOL: base-paths
     [ 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 -- )
@@ -139,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 )
@@ -158,8 +165,8 @@ TUPLE: dispatcher default responders ;
         [ >r drop 1 tail-slice r> ] [ drop default>> ] if
     ] if ;
 
-M: dispatcher call-responder ( path dispatcher -- response )
-    [ add-base-path ] [ find-responder call-responder ] 2bi ;
+M: dispatcher call-responder* ( path dispatcher -- response )
+    find-responder call-responder ;
 
 TUPLE: vhost-dispatcher default responders ;
 
@@ -170,7 +177,7 @@ 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 ;
 
 : add-responder ( dispatcher responder path -- dispatcher )
@@ -183,7 +190,7 @@ M: vhost-dispatcher call-responder ( path dispatcher -- response )
 
 TUPLE: filter-responder responder ;
 
-M: filter-responder call-responder
+M: filter-responder call-responder*
     responder>> call-responder ;
 
 SYMBOL: main-responder
@@ -234,14 +241,16 @@ SYMBOL: exit-continuation
 : split-path ( string -- path )
     "/" split [ empty? not ] subset ;
 
+: init-request ( -- )
+    H{ } clone base-paths set
+    [ ] link-hook set
+    [ ] form-hook set ;
+
 : do-request ( request -- response )
     [
-        H{ } clone base-paths set
-        [ ] link-hook set
-        [ ] form-hook set
-
-        [ log-request ]
+        init-request
         [ request set ]
+        [ log-request ]
         [ path>> split-path main-responder get call-responder ] tri
         [ <404> ] unless*
     ] [
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index 4ff26c3a8f..548f3dc00b 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -16,7 +16,7 @@ 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 ;
@@ -53,8 +53,15 @@ M: foo call-responder
 
 "auth-test.db" temp-file sqlite-db [
 
+    init-request
     init-sessions-table
 
+    [ ] [
+         
+            sessions-in-db >>sessions
+        session-manager set
+    ] unit-test
+
     [
         empty-session
             123 >>id session set
@@ -70,12 +77,6 @@ M: foo call-responder
         [ t ] [ session get changed?>> ] unit-test
     ] with-scope
 
-    [ ] [
-         
-            sessions-in-db >>sessions
-        session-manager set
-    ] unit-test
-
     [ t ] [
         session-manager get begin-session id>>
         session-manager get sessions>> get-session session?
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
index d2c1d90e0a..df2a5bbd28 100755
--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@@ -10,7 +10,7 @@ http.server.sessions.storage.null
 html.elements ;
 IN: http.server.sessions
 
-TUPLE: session id expiry namespace changed? ;
+TUPLE: session id expires namespace changed? ;
 
 :  ( id -- session )
     session new
@@ -24,10 +24,13 @@ M: dispatcher init-session* default>> init-session* ;
 
 M: filter-responder init-session* responder>> init-session* ;
 
-TUPLE: session-manager < filter-responder sessions ;
+TUPLE: session-manager < filter-responder sessions timeout domain ;
 
 :  ( responder -- responder' )
-    null-sessions session-manager boa ;
+    session-manager new
+        swap >>responder
+        null-sessions >>sessions
+        20 minutes >>timeout ;
 
 : (session-changed) ( session -- )
     t >>changed? drop ;
@@ -47,18 +50,14 @@ TUPLE: session-manager < filter-responder sessions ;
     [ namespace>> swap change-at ] keep
     (session-changed) ; inline
 
-: sessions session-manager get sessions>> ;
-
 : init-session ( session managed -- )
     >r session r> '[ , init-session* ] with-variable ;
 
-: timeout 20 minutes ;
-
 : cutoff-time ( -- time )
-    now timeout time+ timestamp>millis ;
+    session-manager get timeout>> from-now timestamp>millis ;
 
 : touch-session ( session -- )
-    cutoff-time >>expiry drop ;
+    cutoff-time >>expires drop ;
 
 : empty-session ( -- session )
     f 
@@ -73,21 +72,24 @@ TUPLE: session-manager < filter-responder sessions ;
     2tri ;
 
 ! Destructor
-TUPLE: session-saver session ;
+TUPLE: session-saver manager session ;
 
 C:  session-saver
 
 M: session-saver dispose
-    session>> dup changed?>> [
-        [ touch-session ] [ sessions update-session ] bi
-    ] [ drop ] if ;
+    [ session>> ] [ manager>> sessions>> ] bi
+    over changed?>> [
+        [ drop touch-session ] [ update-session ] 2bi
+    ] [ 2drop ] if ;
 
-: save-session-after ( session -- )
+: save-session-after ( manager session -- )
      add-always-destructor ;
 
-: existing-session ( path responder session -- response )
-    [ session set ] [ save-session-after ] bi
-    [ session-manager set ] [ responder>> call-responder ] bi ;
+: existing-session ( path manager session -- response )
+    [ nip session set ]
+    [ save-session-after ]
+    [ drop responder>> ] 2tri
+    call-responder ;
 
 : session-id-key "factorsessid" ;
 
@@ -109,13 +111,13 @@ M: session-saver dispose
     >r request-session-id r> sessions>> get-session ;
 
 :  ( id -- cookie )
-    session-id-key  ;
+    session-id-key 
+        "$session-manager" resolve-base-path >>path
+        session-manager get timeout>> from-now >>expires
+        session-manager get domain>> >>domain ;
 
-: new-session ( path responder -- response )
-    dup begin-session
-    [ existing-session ]
-    [ id>> number>string  ] bi
-    put-cookie ;
+: put-session-cookie ( response -- response' )
+    session get id>> number>string  put-cookie ;
 
 : session-form-field ( -- )
     > number>string =value
     input/> ;
 
-M: session-manager call-responder ( path responder -- response )
+M: session-manager call-responder* ( path responder -- response )
     [ session-form-field ] add-form-hook
-    dup request-session [ existing-session ] [ new-session ] if* ;
+    dup session-manager set
+    dup request-session [ dup begin-session ] unless*
+    existing-session put-session-cookie ;
diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor
index 637d86670f..58a0130b36 100755
--- a/extra/http/server/sessions/storage/db/db.factor
+++ b/extra/http/server/sessions/storage/db/db.factor
@@ -11,7 +11,7 @@ session "SESSIONS"
 {
     ! { "id" "ID" +random-id+ system-random-generator }
     { "id" "ID" INTEGER +native-id+ }
-    { "expiry" "EXPIRY" BIG-INTEGER +not-null+ }
+    { "expires" "EXPIRES" BIG-INTEGER +not-null+ }
     { "namespace" "NAMESPACE" FACTOR-BLOB }
 } define-persistent
 
@@ -31,7 +31,7 @@ M: sessions-in-db new-session ( session storage -- )
 
 : expired-sessions ( -- session )
     f 
-    USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expiry
+    USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expires
     select-tuples ;
 
 : start-expiring-sessions ( db seq -- )
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 1605144b61..af6018fbdc 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -77,7 +77,7 @@ TUPLE: file-responder root hook special ;
         find-index [ serve-file ] [ list-directory ] ?if
     ] [
         drop
-        request get path>> "/" append f 
+        request get path>> "/" append f 
     ] if ;
 
 : serve-object ( filename -- response )
@@ -86,7 +86,7 @@ TUPLE: file-responder root hook special ;
     [ drop <404> ]
     if ;
 
-M: file-responder call-responder ( path responder -- response )
+M: file-responder call-responder* ( path responder -- response )
     file-responder set
     ".." over member?
     [ drop <400> ] [ "/" join serve-object ] if ;
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
index 99d6376fe8..622cfe900f 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -1,5 +1,5 @@
 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
@@ -19,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-subset ;
 
 : 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
@@ -84,7 +92,7 @@ SYMBOL: tags
     dup empty?
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 
-: a-flow-attr ( tag -- )
+: flow-attr ( tag -- )
     "flow" optional-attr {
         { "none" [ flow-id off ] }
         { "begin" [ begin-flow ] }
@@ -92,7 +100,7 @@ SYMBOL: tags
         { f [ ] }
     } case ;
 
-: a-session-attr ( tag -- )
+: session-attr ( tag -- )
     "session" optional-attr {
         { "none" [ session off flow-id off ] }
         { "current" [ ] }
@@ -102,8 +110,8 @@ SYMBOL: tags
 : a-start-tag ( tag -- )
     [
         
-    hidden-form-field ;
+    [
+        
+        hidden-form-field
+    ] with-scope ;
 
 : form-tag ( tag -- )
     [ form-start-tag ]
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index d6ddeb32bb..0c7b95525e 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -47,7 +47,7 @@ IN: webapps.factor-website
     
         "page" factor-template >>template
     
-    
+    
         sessions-in-db >>sessions
     test-db  ;
 
diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml
index 2f67b5e857..3e2f43845a 100644
--- a/extra/webapps/factor-website/page.xml
+++ b/extra/webapps/factor-website/page.xml
@@ -10,7 +10,7 @@
 		
 			
 
-			
+			
 
 			
 				body, button {
diff --git a/extra/webapps/pastebin/annotation.xml b/extra/webapps/pastebin/annotation.xml
index af6a835a64..e5a95d8908 100644
--- a/extra/webapps/pastebin/annotation.xml
+++ b/extra/webapps/pastebin/annotation.xml
@@ -2,21 +2,21 @@
 
 
 
-	
Annotation: 

+	
Annotation: 

 
 	

 
 		

 		User name:
 		

 
 		

 		Real name:
 		

 
 		

 		Password:
 		

 
 		

 		Verify:
 		

 
 		

 		E-mail:
 		

 
 		

 		Captcha:
 		

 
 		

-		
-		
-		
+		
+		
+		
Author:  
Mode:    
Date:    
Author:  
Mode:    
Date:    

 	

 
 	

-		
+		
 	

 
-	
-		
-		
+	
+		
+		
 		
 	
 
diff --git a/extra/webapps/pastebin/new-annotation.xml b/extra/webapps/pastebin/new-annotation.xml
index 4afc5cfec5..ad7152d209 100644
--- a/extra/webapps/pastebin/new-annotation.xml
+++ b/extra/webapps/pastebin/new-annotation.xml
@@ -4,15 +4,15 @@
 
 	New Annotation
 
-	
-		
+	
+		
 
 		
-			
-			
-			
-			
-			
+			
+			
+			
+			
+			
diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml
index 4b2b4a46ce..86daf09aeb 100644
--- a/extra/webapps/pastebin/new-paste.xml
+++ b/extra/webapps/pastebin/new-paste.xml
@@ -4,14 +4,14 @@
 
 	New Paste
 
-	
+	
 
 		
Summary: 
Author: 
Mode: 
Description:
Captcha: 
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
index 12b926c7d1..c91aa6fc42 100644
--- a/extra/webapps/pastebin/paste-list.xml
+++ b/extra/webapps/pastebin/paste-list.xml
@@ -9,7 +9,7 @@
 		
 
-		
+		
 	
Summary: 
Author: 
Mode: 
Description: 
Captcha: 
Summary: 
Author: 
Mode: 
Description: 
Captcha: 

 			

 			
 			Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.Paste by:
 		Date:

 
 
diff --git a/extra/webapps/pastebin/paste-summary.xml b/extra/webapps/pastebin/paste-summary.xml
index 952d0de73d..eca46e254d 100644
--- a/extra/webapps/pastebin/paste-summary.xml
+++ b/extra/webapps/pastebin/paste-summary.xml
@@ -3,9 +3,9 @@
 
 
 	
-		
-		
-		
+		
+		
+		
 	
 
 
diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml
index 89d1891221..9db60bfcc3 100644
--- a/extra/webapps/pastebin/paste.xml
+++ b/extra/webapps/pastebin/paste.xml
@@ -4,24 +4,22 @@
 
 	Pastebin
 
-	
Paste: 

+	
Paste: 

 
 	
-		
-		
-		
+		
+		
+		
Author:  
Mode:    
Date:    
Author:  
Mode:    
Date:    

 	

 
-	

-		
-	

+	

 
-	
-		
+	
+		
 		
 	
 	|
-	Annotate
+	Annotate
 
-	
+	
 
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 07b3e9c02d..9301b14353 100644
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -242,7 +242,7 @@ TUPLE: pastebin < dispatcher ;
          "feed.xml" add-responder
          [  ]  "view-paste" add-responder
                    [  ] "$pastebin/list"   "delete-paste" add-responder
-                   [  ] "$pastebin/view-paste"   "delete-annotation" 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
diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml
index 6b49162637..99fede727e 100644
--- a/extra/webapps/pastebin/pastebin.xml
+++ b/extra/webapps/pastebin/pastebin.xml
@@ -2,24 +2,27 @@
 
 
 
-	
+	
 
-	
+	
 
 	

-		  Pastes
-		| New Paste
-		| Atom Feed
+		  Pastes
+		| New Paste
+		| Atom Feed
+
+		
+
+			
+				| Edit Profile
+			
+
+			
+				| 
+			
 
-		
-		
-			| Edit Profile
 		
 
-		
-			| 
-		
-		
 	

 
 	

diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml
index 3bd406ee38..c79fe2efd1 100644
--- a/extra/webapps/planet/admin.xml
+++ b/extra/webapps/planet/admin.xml
@@ -4,11 +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 a92af8dd1d..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 83273540a5..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:
 			

 
 			

 				Feed:
 			

 
 		

@@ -31,8 +31,8 @@
 
 	
 
-	
-		
+	
+		
 		
 	
 
diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml
index 905795373b..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 0e52c191a5..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 752db18ee7..2acff094c3 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -169,5 +169,8 @@ blog "BLOGS"
 
 : start-update-task ( planet db seq -- )
     '[
-        , , , [ update-cached-postings ] with-db
+        , , , [
+            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 328be84544..fdbfe6d841 100644
--- a/extra/webapps/planet/planet.xml
+++ b/extra/webapps/planet/planet.xml
@@ -8,19 +8,19 @@
 	
 
 	

-		  Front Page
-		| Atom Feed
-		| Admin
+		  Front Page
+		| Atom Feed
+		| 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/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 008b0acaf5..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.xml b/extra/webapps/todo/todo.xml
index 4e307b7cae..ff58b27df2 100644
--- a/extra/webapps/todo/todo.xml
+++ b/extra/webapps/todo/todo.xml
@@ -5,14 +5,14 @@
 	
 
 	

-		  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 e8c2fd3983..f77396c73c 100644
--- a/extra/webapps/todo/view-todo.xml
+++ b/extra/webapps/todo/view-todo.xml
@@ -10,13 +10,13 @@
 	
 
 	

-		
+		
 	

 
-	Edit
+	Edit
 	|
-	
-		
+	
+		
 		
 	
 

From 7a7d7be3240d51a7c7a11bc7994c5097427a7bd6 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sun, 27 Apr 2008 03:15:31 -0500
Subject: [PATCH 49/55] Fix typo in documentation

---
 core/words/words-docs.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index f259378f7e..069a8615ac 100755
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -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 } } }

From e48755e5aa27cb22c12ee5145f9e1902c8e15ddf Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sun, 27 Apr 2008 04:27:04 -0500
Subject: [PATCH 50/55] Fixes

---
 extra/http/http.factor                          | 2 +-
 extra/http/server/templating/chloe/chloe.factor | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/http/http.factor b/extra/http/http.factor
index 99a48e58d8..3402b42ca7 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -149,7 +149,7 @@ TUPLE: cookie name value path domain expires max-age http-only ;
         ";" split [
             [ blank? ] trim "=" split1 swap >lower {
                 { "expires" [ cookie-string>timestamp >>expires ] }
-                { "max-age" [ string>number seconds ] }
+                { "max-age" [ string>number seconds >>max-age ] }
                 { "domain" [ >>domain ] }
                 { "path" [ >>path ] }
                 { "httponly" [ drop t >>http-only ] }
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
index 622cfe900f..a8a456cdb2 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -22,7 +22,7 @@ DEFER: process-template
 : chloe-ns "http://factorcode.org/chloe/1.0" ; inline
 
 : filter-chloe-attrs ( assoc -- assoc' )
-    [ drop name-url chloe-ns = not ] assoc-subset ;
+    [ drop name-url chloe-ns = not ] assoc-filter ;
 
 : chloe-tag? ( tag -- ? )
     {

From 173d064567f112ee8f7f2a821799a059b088649e Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sun, 27 Apr 2008 04:51:33 -0500
Subject: [PATCH 51/55] Unit tests pass

---
 extra/http/server/sessions/sessions-tests.factor      | 5 ++++-
 extra/http/server/templating/chloe/chloe-tests.factor | 8 --------
 extra/http/server/templating/chloe/test/test4.xml     | 2 +-
 extra/http/server/templating/chloe/test/test5.xml     | 2 +-
 extra/http/server/templating/chloe/test/test6.xml     | 2 +-
 extra/http/server/templating/chloe/test/test7.xml     | 2 +-
 6 files changed, 8 insertions(+), 13 deletions(-)

diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index 548f3dc00b..c95ff30069 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -7,7 +7,10 @@ sequences db db.sqlite continuations ;
 
 : with-session
     [
-        >r [ save-session-after ] [ \ session set ] bi r> call
+        >r
+        [ session-manager get swap save-session-after ]
+        [ \ session set ] bi
+        r> call
     ] with-destructors ; inline
 
 TUPLE: foo ;
diff --git a/extra/http/server/templating/chloe/chloe-tests.factor b/extra/http/server/templating/chloe/chloe-tests.factor
index cb8b56e002..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
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
 	
 

From 5ad8aab2b993438fddb6672e1de5363c2b8492f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sun, 27 Apr 2008 06:37:02 -0500
Subject: [PATCH 52/55] Fix unit tests

---
 extra/http/server/callbacks/callbacks-tests.factor | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor
index 498f120cd8..cca5942328 100755
--- a/extra/http/server/callbacks/callbacks-tests.factor
+++ b/extra/http/server/callbacks/callbacks-tests.factor
@@ -5,6 +5,8 @@ splitting kernel hashtables continuations ;
 
 [ 123 ] [
     [
+        init-request
+
          "GET" >>method request set
         [
             exit-continuation set
@@ -17,6 +19,8 @@ splitting kernel hashtables continuations ;
 ] unit-test
 
 [
+    init-request
+
      [
         [
             "hello" print

From 524e3ea762a83ddee9f53ccc82ab850e54e2de66 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sun, 27 Apr 2008 06:42:12 -0500
Subject: [PATCH 53/55] Fix PPC backend load error

---
 core/cpu/ppc/assembler/assembler.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor
index e85e03bf9c..6dce09a1ef 100755
--- a/core/cpu/ppc/assembler/assembler.factor
+++ b/core/cpu/ppc/assembler/assembler.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: generator.fixup generic kernel math memory namespaces
-words math.bitfields math.order io.binary ;
+USING: generator.fixup generic kernel math math.order memory
+namespaces words math.bitfields math.order io.binary ;
 IN: cpu.ppc.assembler
 
 ! See the Motorola or IBM documentation for details. The opcode

From 31308a7fb2252b33cbb180224b39010ce3692bd6 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sun, 27 Apr 2008 06:42:53 -0500
Subject: [PATCH 54/55] Oops

---
 core/cpu/ppc/assembler/assembler.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor
index 6dce09a1ef..b1d7016eff 100755
--- a/core/cpu/ppc/assembler/assembler.factor
+++ b/core/cpu/ppc/assembler/assembler.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: generator.fixup generic kernel math math.order memory
-namespaces words math.bitfields math.order io.binary ;
+USING: generator.fixup generic kernel memory namespaces
+words math math.bitfields math.order io.binary ;
 IN: cpu.ppc.assembler
 
 ! See the Motorola or IBM documentation for details. The opcode

From c88cf361e7c94ff163439cbe9014eecaed67ba4a Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Sun, 27 Apr 2008 06:46:01 -0500
Subject: [PATCH 55/55] Fix promises help lint

---
 extra/promises/promises-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

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