steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2008-04-25 21:04:24 -07:00
parent 03c4b6ee85 30ef9dbc77
commit 2db4547305
96 changed files with 1925 additions and 1012 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

750
core/alien/compiler/compiler-tests.factor
View File

@ -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" <c-object> [ 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>
"rect" <c-object>
[ 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 <rect> 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" <c-object>
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" <c-object>
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" <c-object>
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" <c-object>
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" <c-object>
[ 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 <array> 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" <c-object> [ 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>
"rect" <c-object>
[ 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 <rect> 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" <c-object>
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" <c-object>
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" <c-object>
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" <c-object>
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" <c-object>
[ 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 <array> 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

4
core/alien/strings/strings-docs.factor
View File

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

2
core/alien/strings/strings.factor
View File

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

2
core/combinators/combinators.factor
View File

@ -150,7 +150,7 @@ M: hashtable hashcode*
drop
] [
dup length 4 <=
over keys [ word? ] contains? or
over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
[
linear-case-quot
] [

8
core/debugger/debugger.factor
View File

@ -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,12 @@ M: encode-error summary drop "Character encoding error" ;
M: decode-error summary drop "Character decoding error" ;
M: no-such-slot summary drop "No such slot" ;
M: immutable-slot summary drop "Slot is immutable" ;
M: bad-create summary drop "Bad parameters to create" ;
<PRIVATE
: init-debugger ( -- )

4
core/mirrors/mirrors-docs.factor
View File

@ -37,10 +37,6 @@ HELP: <mirror>
}
} ;
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." } ;

14
core/mirrors/mirrors-tests.factor
View File

@ -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> foo
[ 3 ] [
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
] unit-test
[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
[ no-such-slot? ]
[ name>> "hi" = ]
[ object>> foo? ] tri and and
] must-fail-with
[ 3 "numerator" 1/2 <mirror> set-at ] [
[ immutable-slot? ]
[ name>> "numerator" = ]
[ object>> 1/2 = ] tri and and
] must-fail-with

29
core/mirrors/mirrors.factor
View File

@ -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 ;
: <mirror> ( 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 )

3
core/optimizer/known-words/known-words.factor
View File

@ -60,7 +60,8 @@ sequences.private combinators ;
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
[ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
[ literalize [ t ] ] { } map>assoc
[ drop f ] suffix [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot f splice-quot ;

17
core/optimizer/optimizer-tests.factor
View File

@ -1,9 +1,9 @@
USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes classes.algebra inference.dataflow
classes.tuple.private continuations growable optimizer.inlining
namespaces hints ;
kernel.private math optimizer generator prettyprint sequences
sbufs strings tools.test vectors words sequences.private
quotations optimizer.backend classes classes.algebra
inference.dataflow classes.tuple.private continuations growable
optimizer.inlining namespaces hints ;
IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@ -349,3 +349,10 @@ USE: sequences.private
1 2 3.0 3 counter-example ;
[ 2 4 6.0 0 ] [ counter-example' ] unit-test
: member-test { + - * / /i } member? ;
\ member-test must-infer
[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
[ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test

16
core/parser/parser-docs.factor
View File

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

3
core/parser/parser-tests.factor
View File

@ -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

17
core/parser/parser.factor
View File

@ -233,8 +233,16 @@ PREDICATE: unexpected-eof < unexpected
: parse-tokens ( end -- seq )
100 <vector> 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

4
extra/bit-vectors/bit-vectors-docs.factor
View File

@ -3,7 +3,7 @@ bit-vectors.private combinators ;
IN: bit-vectors
ARTICLE: "bit-vectors" "Bit vectors"
"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
$nl
"Bit vectors form a class:"
{ $subsection bit-vector }
@ -19,7 +19,7 @@ $nl
ABOUT: "bit-vectors"
HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }

2
extra/byte-vectors/byte-vectors-docs.factor
View File

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

4
extra/calendar/calendar-tests.factor
View File

@ -2,6 +2,10 @@ USING: arrays calendar kernel math sequences tools.test
continuations system ;
IN: calendar.tests
\ time+ must-infer
\ time* must-infer
\ time- must-infer
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test

35
extra/calendar/calendar.factor
View File

@ -211,12 +211,14 @@ M: duration time+
#! Uses average month/year length since dt loses calendar
#! data
0 swap
[ year>> + ] keep
[ month>> months-per-year / + ] keep
[ day>> days-per-year / + ] keep
[ hour>> hours-per-year / + ] keep
[ minute>> minutes-per-year / + ] keep
second>> seconds-per-year / + ;
{
[ year>> + ]
[ month>> months-per-year / + ]
[ day>> days-per-year / + ]
[ hour>> hours-per-year / + ]
[ minute>> minutes-per-year / + ]
[ second>> seconds-per-year / + ]
} cleave ;
M: duration <=> [ dt>years ] compare ;
@ -252,14 +254,21 @@ M: timestamp time-
#! Exact calendar-time difference
(time-) seconds ;
: time* ( obj1 obj2 -- obj3 )
dup real? [ swap ] when
dup real? [ * ] [
{
[ year>> * ]
[ month>> * ]
[ day>> * ]
[ hour>> * ]
[ minute>> * ]
[ second>> * ]
} 2cleave <duration>
] if ;
: before ( dt -- -dt )
[ year>> neg ] keep
[ month>> neg ] keep
[ day>> neg ] keep
[ hour>> neg ] keep
[ minute>> neg ] keep
second>> neg
<duration> ;
-1 time* ;
M: duration time-
before time+ ;

33
extra/calendar/format/format-tests.factor
View File

@ -1,26 +1,45 @@
USING: calendar.format calendar kernel tools.test
io.streams.string ;
USING: calendar.format calendar kernel math tools.test
io.streams.string accessors io ;
IN: calendar.format.tests
[ 0 ] [
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
"Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ 1 ] [
"+01" [ read-rfc3339-gmt-offset ] with-string-reader
"+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ -1 ] [
"-01" [ read-rfc3339-gmt-offset ] with-string-reader
"-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ -1-1/2 ] [
"-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
"-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ 1+1/2 ] [
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
"+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ ] [ now timestamp>rfc3339 drop ] unit-test
[ ] [ now timestamp>rfc822 drop ] unit-test
[ 8/1000 -4 ] [
"2008-04-19T04:56:00.008-04:00" rfc3339>timestamp
[ second>> ] [ gmt-offset>> hour>> ] bi
] unit-test
[ T{ duration f 0 0 0 0 0 0 } ] [
"GMT" parse-rfc822-gmt-offset
] unit-test
[ T{ duration f 0 0 0 -5 0 0 } ] [
"-0500" parse-rfc822-gmt-offset
] unit-test
[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [
"Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp
] unit-test
[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test

100
extra/calendar/format/format.factor
View File

@ -1,5 +1,6 @@
USING: math math.parser kernel sequences io calendar
accessors arrays io.streams.string combinators accessors ;
accessors arrays io.streams.string splitting
combinators accessors debugger ;
IN: calendar.format
GENERIC: day. ( obj -- )
@ -58,11 +59,11 @@ M: timestamp year. ( timestamp -- )
[ hour>> write-00 ] [ minute>> write-00 ] bi ;
: write-gmt-offset ( gmt-offset -- )
dup instant <=> {
{ [ dup 0 = ] [ 2drop "GMT" write ] }
{ [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }
{ [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }
} cond ;
dup instant <=> sgn {
{ 0 [ drop "GMT" write ] }
{ -1 [ "-" write before (write-gmt-offset) ] }
{ 1 [ "+" write (write-gmt-offset) ] }
} case ;
: timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format
@ -83,20 +84,22 @@ M: timestamp year. ( timestamp -- )
[ minute>> write-00 ] bi ;
: write-rfc3339-gmt-offset ( duration -- )
dup instant <=> {
{ [ dup 0 = ] [ 2drop "Z" write ] }
{ [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
{ [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }
} cond ;
dup instant <=> sgn {
{ 0 [ drop "Z" write ] }
{ -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
{ 1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] }
} case ;
: (timestamp>rfc3339) ( timestamp -- )
dup year>> number>string write CHAR: - write1
dup month>> write-00 CHAR: - write1
dup day>> write-00 CHAR: T write1
dup hour>> write-00 CHAR: : write1
dup minute>> write-00 CHAR: : write1
dup second>> >fixnum write-00
gmt-offset>> write-rfc3339-gmt-offset ;
{
[ 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 ]
[ gmt-offset>> write-rfc3339-gmt-offset ]
} cleave ;
: timestamp>rfc3339 ( timestamp -- str )
[ (timestamp>rfc3339) ] with-string-writer ;
@ -106,14 +109,20 @@ M: timestamp year. ( timestamp -- )
: read-00 2 read string>number ;
: read-000 3 read string>number ;
: read-0000 4 read string>number ;
: read-rfc3339-gmt-offset ( -- n )
read1 dup CHAR: Z = [ drop 0 ] [
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
read-00
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
60 / + *
: signed-gmt-offset ( dt ch -- dt' )
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
: read-rfc3339-gmt-offset ( ch -- dt )
dup CHAR: Z = [ drop instant ] [
>r
read-00 hours
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
time+
r> signed-gmt-offset
] if ;
: read-ymd ( -- y m d )
@ -126,26 +135,61 @@ M: timestamp year. ( timestamp -- )
read-ymd
"Tt" expect
read-hms
read-rfc3339-gmt-offset ! timezone
read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
read-rfc3339-gmt-offset
<timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] with-string-reader ;
ERROR: invalid-rfc822-date ;
: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ;
: read-token ( seps -- token )
[ read-until ] keep member? check-rfc822-date drop ;
: read-sp ( -- token ) " " read-token ;
: checked-number ( str -- n )
string>number check-rfc822-date ;
: parse-rfc822-gmt-offset ( string -- dt )
dup "GMT" = [ drop instant ] [
unclip >r
2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
r> signed-gmt-offset
] if ;
: (rfc822>timestamp) ( -- timestamp )
timestamp new
"," read-token day-abbreviations3 member? check-rfc822-date drop
read1 CHAR: \s assert=
read-sp checked-number >>day
read-sp month-abbreviations index check-rfc822-date >>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 ;
: rfc822>timestamp ( str -- timestamp )
[ (rfc822>timestamp) ] with-string-reader ;
: (ymdhms>timestamp) ( -- timestamp )
read-ymd " " expect read-hms 0 <timestamp> ;
read-ymd " " expect read-hms instant <timestamp> ;
: ymdhms>timestamp ( str -- timestamp )
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
f f f read-hms f <timestamp> ;
f f f read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
read-ymd f f f f <timestamp> ;
read-ymd f f f instant <timestamp> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;

2
extra/columns/columns-docs.factor
View File

@ -14,7 +14,7 @@ HELP: <column> ( seq n -- column )
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $examples
{ $example
"USING: arrays prettyprint sequences ;"
"USING: arrays prettyprint columns ;"
"{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
"{ 1 4 7 }"
}

1
extra/db/db-tests.factor
View File

@ -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

1
extra/db/db.factor
View File

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

15
extra/db/postgresql/lib/lib.factor
View File

@ -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

1
extra/db/sqlite/ffi/ffi.factor
View File

@ -108,6 +108,7 @@ LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;

8
extra/db/sqlite/lib/lib.factor
View File

@ -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

2
extra/db/sqlite/sqlite.factor
View File

@ -124,7 +124,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] query-make dup sql>> . ;
] query-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
[ "drop table " 0% 0% ";" 0% drop ] query-make ;

42
extra/db/tuples/tuples-tests.factor
View File

@ -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
@ -80,9 +80,9 @@ SYMBOL: person4
"teddy"
10
3.14
T{ timestamp f 2008 3 5 16 24 11 0 }
T{ timestamp f 2008 11 22 f f f f }
T{ timestamp f f f f 12 34 56 f }
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 f f f 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 }
}
] [ T{ person f 3 } select-tuple ] unit-test
@ -96,9 +96,9 @@ SYMBOL: person4
"eddie"
10
3.14
T{ timestamp f 2008 3 5 16 24 11 0 }
T{ timestamp f 2008 11 22 f f f f }
T{ timestamp f f f f 12 34 56 f }
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 f f f 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" } }
}
@ -121,8 +121,16 @@ SYMBOL: person4
} define-persistent
"billy" 10 3.14 f f f f f <person> person1 set
"johnny" 10 3.14 f f f f f <person> 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 <person> 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" } } <person> 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 <person> 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" } } <person> 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 <assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f <assigned-person> 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 <assigned-person> 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" } } <assigned-person> 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 <assigned-person> 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" } } <assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
@ -363,3 +380,6 @@ TUPLE: does-not-persist ;
\ delete-tuple must-infer
\ select-tuple must-infer
\ define-persistent must-infer
\ ensure-table must-infer
\ create-table must-infer
\ drop-table must-infer

2
extra/db/tuples/tuples.factor
View File

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

4
extra/float-vectors/float-vectors-docs.factor
View File

@ -3,7 +3,7 @@ float-vectors.private combinators ;
IN: float-vectors
ARTICLE: "float-vectors" "Float vectors"
"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
$nl
"Float vectors form a class:"
{ $subsection float-vector }
@ -19,7 +19,7 @@ $nl
ABOUT: "float-vectors"
HELP: float-vector
{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;
{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ;
HELP: <float-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }

4
extra/fry/fry-tests.factor
View File

@ -44,3 +44,7 @@ sequences ;
: funny-dip '[ @ _ ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
[ { 1 2 3 } ] [
3 1 '[ , [ , + ] map ] call
] unit-test

39
extra/fry/fry.factor
View File

@ -9,41 +9,54 @@ IN: fry
: @ "Only valid inside a fry" throw ;
: _ "Only valid inside a fry" throw ;
DEFER: (fry)
DEFER: (shallow-fry)
: ((fry)) ( accum quot adder -- result )
>r [ ] swap (fry) r>
: ((shallow-fry)) ( accum quot adder -- result )
>r [ ] swap (shallow-fry) r>
append swap dup empty? [ drop ] [
[ swap compose ] curry append
] if ; inline
: (fry) ( accum quot -- result )
: (shallow-fry) ( accum quot -- result )
dup empty? [
drop 1quotation
] [
unclip {
{ \ , [ [ curry ] ((fry)) ] }
{ \ @ [ [ compose ] ((fry)) ] }
{ \ , [ [ curry ] ((shallow-fry)) ] }
{ \ @ [ [ compose ] ((shallow-fry)) ] }
! to avoid confusion, remove if fry goes core
{ \ namespaces:, [ [ curry ] ((fry)) ] }
{ \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
[ swap >r suffix r> (fry) ]
[ swap >r suffix r> (shallow-fry) ]
} case
] if ;
: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
: fry ( quot -- quot' )
: deep-fry ( quot -- quot' )
{ _ } last-split1 [
[
trivial-fry %
shallow-fry %
[ >r ] %
fry %
deep-fry %
[ [ dip ] curry r> compose ] %
] [ ] make
] [
trivial-fry
shallow-fry
] if* ;
: fry ( quot -- quot' )
[
[
dup callable? [
[
[ { , namespaces:, @ } member? ] subset length
\ , <repetition> %
]
[ deep-fry % ] bi
] [ namespaces:, ] if
] each
] [ ] make deep-fry ;
: '[ \ ] parse-until fry over push-all ; parsing

2
extra/hardware-info/windows/windows.factor
View File

@ -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 )

8
extra/http/client/client-tests.factor
View File

@ -6,9 +6,9 @@ tuple-syntax namespaces ;
[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arc.com/foo.txt/" download-name ] unit-test
[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
[
TUPLE{ request
@ -18,7 +18,7 @@ tuple-syntax namespaces ;
port: 80
version: "1.1"
cookies: V{ }
header: H{ }
header: H{ { "connection" "close" } }
}
] [
[

78
extra/http/client/client.factor
View File

@ -3,9 +3,17 @@
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
io.encodings.8-bit io.encodings.binary fry ;
io.encodings.8-bit io.encodings.binary fry debugger inspector ;
IN: http.client
: max-redirects 10 ;
ERROR: too-many-redirects ;
M: too-many-redirects summary
drop
[ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
DEFER: http-request
<PRIVATE
@ -29,22 +37,29 @@ DEFER: http-request
: relative-redirect ( path -- request )
request get swap store-path ;
SYMBOL: redirects
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: do-redirect ( response -- response stream )
dup response-code 300 399 between? [
stdio get dispose
header>> "location" swap at
dup "http://" head? [
absolute-redirect
redirects inc
redirects get max-redirects < [
header>> "location" swap at
dup absolute-url? [
absolute-redirect
] [
relative-redirect
] if "GET" >>method http-request
] [
relative-redirect
] if "GET" >>method http-request
too-many-redirects
] if
] [
stdio get
] if ;
: request-addr ( request -- addr )
dup host>> swap port>> <inet> ;
: close-on-error ( stream quot -- )
'[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
@ -61,28 +76,55 @@ PRIVATE>
] close-on-error
] with-variable ;
: read-chunks ( -- )
read-crlf ";" split1 drop hex> dup { f 0 } member?
[ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
: do-chunked-encoding ( response stream -- response stream/string )
over "transfer-encoding" header "chunked" = [
[ [ read-chunks ] "" make ] with-stream
] when ;
: <get-request> ( url -- request )
<request> request-with-url "GET" >>method ;
: http-get-stream ( url -- response stream )
<get-request> http-request ;
: string-or-contents ( stream/string -- string )
dup string? [ contents ] unless ;
: http-get-stream ( url -- response stream/string )
<get-request> http-request do-chunked-encoding ;
: success? ( code -- ? ) 200 = ;
: check-response ( response -- )
code>> success?
[ "HTTP download failed" throw ] unless ;
ERROR: download-failed response body ;
M: download-failed error.
"HTTP download failed:" print nl
[
response>>
write-response-code
write-response-message nl
drop
]
[ body>> write ] bi ;
: check-response ( response string -- string )
over code>> success? [ nip ] [ download-failed ] if ;
: http-get ( url -- string )
http-get-stream contents swap check-response ;
http-get-stream string-or-contents check-response ;
: download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
swap http-get-stream swap check-response
[ swap latin1 <file-writer> stream-copy ] with-disposal ;
swap http-get-stream check-response
dup string? [
latin1 [ write ] with-file-writer
] [
[ swap latin1 <file-writer> stream-copy ] with-disposal
] if ;
: download ( url -- )
dup download-name download-to ;
@ -95,4 +137,4 @@ PRIVATE>
swap >>post-data-type ;
: http-post ( content-type content url -- response string )
<post-request> http-request contents ;
<post-request> http-request do-chunked-encoding string-or-contents ;

87
extra/http/http-tests.factor
View File

@ -24,6 +24,8 @@ IN: http.tests
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
GET http://foo/bar HTTP/1.1
Some-Header: 1
@ -45,7 +47,7 @@ blah
cookies: V{ }
}
] [
read-request-test-1 [
read-request-test-1 lf>crlf [
read-request
] with-string-reader
] unit-test
@ -59,7 +61,7 @@ blah
;
read-request-test-1' 1array [
read-request-test-1
read-request-test-1 lf>crlf
[ read-request ] with-string-reader
[ write-request ] with-string-writer
! normalize crlf
@ -69,6 +71,7 @@ read-request-test-1' 1array [
STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1
Host: www.sex.com
;
[
@ -83,7 +86,7 @@ Host: www.sex.com
cookies: V{ }
}
] [
read-request-test-2 [
read-request-test-2 lf>crlf [
read-request
] with-string-reader
] unit-test
@ -104,7 +107,7 @@ blah
cookies: V{ }
}
] [
read-response-test-1
read-response-test-1 lf>crlf
[ read-response ] with-string-reader
] unit-test
@ -117,7 +120,7 @@ content-type: text/html
;
read-response-test-1' 1array [
read-response-test-1
read-response-test-1 lf>crlf
[ read-response ] with-string-reader
[ write-response ] with-string-writer
! normalize crlf
@ -130,19 +133,26 @@ 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
<action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
"quit" add-responder ;
[ ] [
[
<dispatcher>
<action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
"quit" add-responder
add-quit-action
<dispatcher>
"extra/http/test" resource-path <static> >>default
"nested" add-responder
<action>
[ "redirect-loop" f <permanent-redirect> ] >>display
"redirect-loop" add-responder
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
@ -159,11 +169,62 @@ io.encodings.ascii ;
"localhost" 1237 <inet> ascii <client> [
"GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush
readln drop
read-header USE: prettyprint
] with-stream dup . "location" swap at "/" head?
read-crlf drop
read-header
] with-stream "location" swap at "/" head?
] unit-test
[ "http://localhost:1237/redirect-loop" http-get ]
[ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [
"http://localhost:1237/quit" http-get
] unit-test
! Dispatcher bugs
[ ] [
[
<dispatcher>
<action> <protected>
<login>
<url-sessions> "" add-responder
add-quit-action
<dispatcher>
<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
[ ] [
[
<dispatcher>
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
<login> <url-sessions>
"" 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

69
extra/http/http.factor
View File

@ -1,10 +1,18 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry hashtables io io.streams.string kernel math sets
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting accessors calendar
calendar.format quotations arrays combinators.lib byte-arrays ;
USING: accessors kernel combinators math namespaces
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets
unicode.case unicode.categories qualified ;
EXCLUDE: fry => , ;
IN: http
: http-port 80 ; inline
@ -13,11 +21,12 @@ IN: http
#! In a URL, can this character be used without
#! URL-encoding?
{
[ dup letter? ]
[ dup LETTER? ]
[ dup digit? ]
[ dup "/_-.:" member? ]
} || nip ; foldable
{ [ dup letter? ] [ t ] }
{ [ dup LETTER? ] [ t ] }
{ [ dup digit? ] [ t ] }
{ [ dup "/_-.:" member? ] [ t ] }
[ f ]
} cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
@ -75,8 +84,15 @@ IN: http
] if
] if ;
: read-lf ( -- string )
"\n" read-until CHAR: \n assert= ;
: read-crlf ( -- string )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: read-header-line ( -- )
readln dup
read-crlf dup
empty? [ drop ] [ header-line read-header-line ] if ;
: read-header ( -- assoc )
@ -175,13 +191,17 @@ post-data
post-data-type
cookies ;
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
: <request>
request new
"1.1" >>version
http-port >>port
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies ;
V{ } clone >>cookies
"close" "connection" set-header ;
: query-param ( request key -- value )
swap query>> at ;
@ -220,7 +240,7 @@ cookies ;
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
: read-request-version ( request -- request )
readln [ CHAR: \s = ] left-trim
read-crlf [ CHAR: \s = ] left-trim
parse-version
>>version ;
@ -295,9 +315,15 @@ SYMBOL: max-post-request
"application/x-www-form-urlencoded" >>post-data-type
] if ;
: request-addr ( request -- addr )
[ host>> ] [ port>> ] bi <inet> ;
: request-host ( request -- string )
[ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
: write-request-header ( request -- request )
dup header>> >hashtable
over host>> [ "host" pick set-at ] when*
over host>> [ over request-host "host" pick set-at ] when
over post-data>> [ length "content-length" pick set-at ] when*
over post-data-type>> [ "content-type" pick set-at ] when*
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
@ -330,9 +356,6 @@ SYMBOL: max-post-request
tri
] with-string-writer ;
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
GENERIC: write-response ( response -- )
GENERIC: write-full-response ( request response -- )
@ -347,11 +370,11 @@ body ;
: <response>
response new
"1.1" >>version
H{ } clone >>header
"close" "connection" set-header
now timestamp>http-string "date" set-header
V{ } clone >>cookies ;
"1.1" >>version
H{ } clone >>header
"close" "connection" set-header
now timestamp>http-string "date" set-header
V{ } clone >>cookies ;
: read-response-version
" \t" read-until
@ -365,7 +388,7 @@ body ;
>>code ;
: read-response-message
readln >>message ;
read-crlf >>message ;
: read-response-header
read-header >>header

32
extra/http/server/actions/actions-tests.factor
View File

@ -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 accessors ;
io.streams.string http.server sequences splitting accessors ;
IN: http.server.actions.tests
[
"a" [ v-number ] { { "a" "123" } } validate-param
@ -13,6 +13,8 @@ io.streams.string http.server sequences accessors ;
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
"action-1" set
: lf>crlf "\n" split "\r\n" join ;
STRING: action-request-test-1
GET http://foo/bar?a=12&b=13 HTTP/1.1
@ -20,28 +22,8 @@ blah
;
[ 25 ] [
action-request-test-1 [ read-request ] with-string-reader
action-request-test-1 lf>crlf
[ read-request ] with-string-reader
request set
"/blah"
"action-1" get call-responder
] unit-test
<action>
[ +append-path get "xxx" get "X" <repetition> 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 [ read-request ] with-string-reader
request set
"/blah"
"action-2" get call-responder
{ } "action-1" get call-responder
] unit-test

21
extra/http/server/actions/actions.factor
View File

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

18
extra/http/server/auth/login/login.factor
View File

@ -60,7 +60,7 @@ M: user-saver dispose
: successful-login ( user -- response )
logged-in-user sset
post-login-url sget "" or f <permanent-redirect>
post-login-url sget "$login" or f <permanent-redirect>
f post-login-url sset ;
:: <login-action> ( -- action )
@ -162,10 +162,12 @@ SYMBOL: previous-page
<action>
[
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 <permanent-redirect>
@ -329,7 +333,7 @@ SYMBOL: lost-password-from
<action>
[
f logged-in-user sset
"login" f <permanent-redirect>
"$login/login" f <permanent-redirect>
] >>submit ;
! ! ! Authentication logic
@ -340,7 +344,7 @@ C: <protected> protected
: show-login-page ( -- response )
request get request-url post-login-url sset
"login" f <permanent-redirect> ;
"$login/login" f <temporary-redirect> ;
M: protected call-responder ( path responder -- response )
logged-in-user sget dup [
@ -363,7 +367,7 @@ M: login call-responder ( path responder -- response )
: <login> ( responder -- auth )
login new-dispatcher
swap <protected> >>default
swap >>default
<login-action> <login-boilerplate> "login" add-responder
<logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ;

2
extra/http/server/boilerplate/boilerplate.factor
View File

@ -48,7 +48,7 @@ SYMBOL: next-template
: call-next-template ( -- )
next-template get write ;
M: f call-template drop call-next-template ;
M: f call-template* drop call-next-template ;
: with-boilerplate ( body template -- )
[

8
extra/http/server/callbacks/callbacks-tests.factor
View File

@ -8,7 +8,7 @@ splitting kernel hashtables continuations ;
<request> "GET" >>method request set
[
exit-continuation set
"xxx"
{ }
<action> [ [ "hello" print 123 ] show-final ] >>display
<callback-responder>
call-responder
@ -31,7 +31,7 @@ splitting kernel hashtables continuations ;
[
exit-continuation set
<request> "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

18
extra/http/server/components/code/code.factor Normal file
View File

@ -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 ;
: <code-renderer> ( mode -- renderer )
code-renderer new-text-renderer
swap >>mode ;
M: code-renderer render-view*
[ string-lines ] [ mode>> value ] bi* htmlize-lines ;
: <code> ( id mode -- component )
swap <text>
swap <code-renderer> >>renderer ;

52
extra/http/server/components/components.factor
View File

@ -280,6 +280,22 @@ TUPLE: date < string ;
M: date component-string
drop timestamp>string ;
! Link components
GENERIC: link-title ( obj -- string )
GENERIC: link-href ( obj -- url )
SINGLETON: link-renderer
M: link-renderer render-view*
drop <a dup link-href =href a> link-title write </a> ;
TUPLE: link < string ;
: <link> ( id -- component )
link new-string
link-renderer >>renderer ;
! List components
SYMBOL: +plain+
SYMBOL: +ordered+
@ -289,17 +305,20 @@ TUPLE: list-renderer component type ;
C: <list-renderer> list-renderer
: render-plain-list ( seq quot component -- )
swap '[ , @ ] each ; inline
: render-plain-list ( seq component quot -- )
'[ , component>> renderer>> @ ] each ; inline
: render-li-list ( seq component quot -- )
'[ <li> @ </li> ] render-plain-list ; inline
: render-ordered-list ( seq quot component -- )
swap <ol> '[ <li> , @ </li> ] each </ol> ; inline
<ol> render-li-list </ol> ; inline
: render-unordered-list ( seq quot component -- )
swap <ul> '[ <li> , @ </li> ] each </ul> ; inline
<ul> render-li-list </ul> ; inline
: render-list ( value renderer quot -- )
swap [ component>> ] [ type>> ] bi {
over type>> {
{ +plain+ [ render-plain-list ] }
{ +ordered+ [ render-ordered-list ] }
{ +unordered+ [ render-unordered-list ] }
@ -317,3 +336,26 @@ TUPLE: list < component ;
<list-renderer> list swap new-component ;
M: list component-string drop ;
! Choice
TUPLE: choice-renderer choices ;
C: <choice-renderer> choice-renderer
M: choice-renderer render-view*
drop write ;
M: choice-renderer render-edit*
<select swap =name select>
choices>> [
<option [ = [ "true" =selected ] when ] keep option>
write
</option>
] with each
</select> ;
TUPLE: choice < string ;
: <choice> ( id choices -- component )
swap choice new-string
swap <choice-renderer> >>renderer ;

2
extra/http/server/forms/forms.factor
View File

@ -78,4 +78,4 @@ M: form render-view*
dup view-template>> render-form ;
M: form render-edit*
dup edit-template>> render-form ;
nip dup edit-template>> render-form ;

82
extra/http/server/server-tests.factor
View File

@ -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
[
<request>
"www.apple.com" >>host
@ -29,7 +31,9 @@ M: mock-responder call-responder
"text/plain" <content> ;
: 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 ] [
<request>
"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> path-check-responder
M: path-check-responder call-responder
drop
"text/plain" <content> swap >array >>body ;
[ { "c" } ] [
H{ } clone base-paths set
{ "b" "c" }
<dispatcher>
<dispatcher>
<path-check-responder> >>default
"b" add-responder
call-responder
body>>
] unit-test
! Test that "" dispatcher works with default>>
[ ] [
<dispatcher>
"" <mock-responder> "" add-responder
"bar" <mock-responder> "bar" add-responder
"baz" <mock-responder> >>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> funny-dispatcher new-dispatcher ;
TUPLE: base-path-check-responder ;
C: <base-path-check-responder> base-path-check-responder
M: base-path-check-responder call-responder
2drop
"$funny-dispatcher" resolve-base-path
"text/plain" <content> swap >>body ;
[ ] [
<dispatcher>
<dispatcher>
<funny-dispatcher>
<base-path-check-responder> "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

104
extra/http/server/server.factor
View File

@ -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> ] <trivial-responder> 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 )
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 <permanent-redirect> ;
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 <permanent-redirect> ] <trivial-responder>
>>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
@ -160,23 +183,30 @@ drop
SYMBOL: development-mode
: http-error. ( error -- )
"Internal server error" [
development-mode get [
[ print-error nl :c ] with-html-stream
] [
500 "Internal server error"
trivial-response-body
] if
] simple-page ;
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
swap '[
, "Internal server error" [
development-mode get [
[ print-error nl :c ] with-html-stream
] [
500 "Internal server error"
trivial-response-body
] if
] simple-page
] >>body ;
swap '[ , http-error. ] >>body ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" =
[ drop ] [ write-response-body ] if ;
[ drop ] [
'[
, write-response-body
] [
http-error.
] recover
] if ;
LOG: httpd-hit NOTICE
@ -190,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 ]

10
extra/http/server/sessions/sessions-tests.factor
View File

@ -61,7 +61,7 @@ M: foo call-responder
<request>
"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
[
"/" <exiting-action> <cookie-sessions>
{ } <exiting-action> <cookie-sessions>
call-responder
] with-destructors response set
] unit-test

32
extra/http/server/static/static.factor
View File

@ -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 <permanent-redirect>
] 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 ;

6
extra/http/server/templating/chloe/chloe.factor
View File

@ -104,7 +104,8 @@ SYMBOL: tags
: form-start-tag ( tag -- )
<form
"POST" =method
tag-attrs print-attrs
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs [ drop name-tag "action" = not ] assoc-subset print-attrs ] bi
form>
hidden-form-field ;
@ -153,6 +154,7 @@ SYMBOL: tags
{ "form" [ form-tag ] }
{ "error" [ error-tag ] }
{ "if" [ if-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
[ "Unknown chloe tag: " swap append throw ]
} case ;
@ -189,7 +191,7 @@ SYMBOL: tags
] if
] with-scope ;
M: chloe call-template
M: chloe call-template*
path>> utf8 <file-reader> read-xml process-chloe ;
INSTANCE: chloe template

2
extra/http/server/templating/fhtml/fhtml.factor
View File

@ -76,7 +76,7 @@ TUPLE: fhtml path ;
C: <fhtml> fhtml
M: fhtml call-template ( filename -- )
M: fhtml call-template* ( filename -- )
'[
, path>> [
"quiet" on

17
extra/http/server/templating/templating.factor
View File

@ -1,10 +1,21 @@
USING: accessors kernel fry io.encodings.utf8 io.files
http http.server ;
USING: accessors kernel fry io io.encodings.utf8 io.files
http http.server debugger prettyprint continuations ;
IN: http.server.templating
MIXIN: template
GENERIC: call-template ( template -- )
GENERIC: call-template* ( template -- )
ERROR: template-error template error ;
M: template-error error.
"Error while processing template " write
[ template>> pprint ":" print nl ]
[ error>> error. ]
bi ;
: call-template ( template -- )
[ call-template* ] [ template-error ] recover ;
M: template write-response-body* call-template ;

14
extra/io/mmap/mmap-tests.factor
View File

@ -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

5
extra/io/mmap/mmap.factor
View File

@ -21,7 +21,10 @@ M: mapped-file set-nth-unsafe
INSTANCE: mapped-file sequence
HOOK: <mapped-file> io-backend ( path length -- mmap )
HOOK: (mapped-file) io-backend ( path length -- mmap )
: <mapped-file> ( path length -- mmap )
>r normalize-path r> (mapped-file) ;
HOOK: close-mapped-file io-backend ( mmap -- )

2
extra/io/unix/mmap/mmap.factor
View File

@ -10,7 +10,7 @@ IN: io.unix.mmap
>r f -roll r> open-r/w [ 0 mmap ] keep
over MAP_FAILED = [ close (io-error) ] when ;
M: unix <mapped-file> ( path length -- obj )
M: unix (mapped-file) ( path length -- obj )
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open f mapped-file boa ;

2
extra/io/windows/mmap/mmap.factor
View File

@ -70,7 +70,7 @@ M: wince with-privileges
dup close-later
] with-privileges ;
M: windows <mapped-file> ( path length -- mmap )
M: windows (mapped-file) ( path length -- mmap )
[
swap
GENERIC_WRITE GENERIC_READ bitor

2
extra/io/windows/nt/monitors/monitors.factor
View File

@ -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 <buffered-port>
recursive? >>recursive
>>port

6
extra/math/miller-rabin/miller-rabin.factor
View File

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

7
extra/project-euler/100/100.factor Normal file
View File

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

40
extra/project-euler/151/151.factor Normal file
View File

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

48
extra/project-euler/190/190.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (c) 2008 Eric Mertens
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.lib math math.functions math.ranges locals ;
IN: project-euler.190
! PROBLEM
! -------
! http://projecteuler.net/index.php?section=problems&id=190
! Let Sm = (x1, x2, ... , xm) be the m-tuple of positive real numbers
! with x1 + x2 + ... + xm = m for which Pm = x1 * x22 * ... * xmm is
! maximised.
! For example, it can be verified that [P10] = 4112 ([ ] is the integer
! part function).
! Find Σ[Pm] for 2 ≤ m ≤ 15.
! SOLUTION
! --------
! Pm = x1 * x2^2 * x3^3 * ... * xm^m
! fm = x1 + x2 + x3 + ... + xm - m = 0
! Gm === Pm - L * fm
! dG/dx_i = 0 = i * Pm / xi - L
! xi = i * Pm / L
! Sum(i=1 to m) xi = m
! Sum(i=1 to m) i * Pm / L = m
! Pm / L * Sum(i=1 to m) i = m
! Pm / L * m*(m+1)/2 = m
! Pm / L = 2 / (m+1)
! xi = i * (2 / (m+1)) = 2*i/(m+1)
<PRIVATE
: PI ( seq quot -- n )
[ * ] compose 1 swap reduce ; inline
PRIVATE>
:: P_m ( m -- P_m )
m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
: euler190 ( -- n )
2 15 [a,b] [ P_m truncate ] sigma ;

4
extra/rss/rss-tests.factor
View File

@ -5,7 +5,7 @@ IN: rss.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
utf8 <file-reader> read-feed ;
utf8 file-contents read-feed ;
[ T{
feed
@ -36,7 +36,7 @@ IN: rss.tests
"http://example.org/2005/04/02/atom"
"\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
T{ timestamp f 2003 12 13 8 29 29 -4 }
T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
}
}
} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test

14
extra/rss/rss.factor
View File

@ -23,7 +23,7 @@ C: <entry> entry
[ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name>
tag-named dup [ children>string rfc3339>timestamp ] when
tag-named dup [ children>string rfc822>timestamp ] when
<entry> ;
: rss1.0 ( xml -- feed )
@ -39,7 +39,7 @@ C: <entry> entry
[ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named children>string ] keep
"pubDate" tag-named children>string rfc3339>timestamp <entry> ;
"pubDate" tag-named children>string rfc822>timestamp <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
@ -71,16 +71,12 @@ C: <entry> entry
{ "feed" [ atom1.0 ] }
} case ;
: read-feed ( stream -- feed )
[ read-xml ] with-html-entities xml>feed ;
: read-feed ( string -- feed )
[ string>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
http-get-stream swap code>> success? [
read-feed
] [
dispose "Error retrieving newsfeed file" throw
] if ;
http-get read-feed ;
! Atom generation
: simple-tag, ( content name -- )

9
extra/sequences/lib/lib.factor
View File

@ -52,7 +52,7 @@ MACRO: firstn ( n -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n )
[ rot slip + ] curry 0 swap reduce ; inline
[ + ] compose 0 swap reduce ; inline
: count ( seq quot -- n )
[ 1 0 ? ] compose sigma ; inline
@ -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 ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
@ -236,3 +240,6 @@ PRIVATE>
: remove-nth ( seq n -- seq' )
cut-slice 1 tail-slice append ;
: short ( seq n -- seq n' )
over length min ; inline

2
extra/smtp/smtp.factor
View File

@ -131,7 +131,7 @@ M: email clone
"-" %
millis #
"@" %
smtp-domain get %
smtp-domain get [ host-name ] unless* %
">" %
] "" make ;

7
extra/ui/cocoa/views/views.factor
View File

@ -126,6 +126,13 @@ CLASS: {
{ +name+ "FactorView" }
{ +protocols+ { "NSTextInput" } }
}
! Rendering
! Rendering
{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
[ 3drop window relayout-1 ]
}
! Events
{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
[ 3drop 1 ]

71
extra/webapps/factor-website/factor-website.factor Normal file
View File

@ -0,0 +1,71 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
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
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 <chloe> ;
: <factor-boilerplate> ( responder -- responder' )
<login>
users-in-db >>users
allow-registration
allow-password-recovery
allow-edit-profile
<boilerplate>
"page" factor-template >>template
<url-sessions>
sessions-in-db >>sessions
test-db <db-persistence> ;
: <pastebin-app> ( -- responder )
<pastebin> <factor-boilerplate> ;
: <planet-app> ( -- responder )
<planet-factor> <factor-boilerplate> ;
: <todo-app> ( -- responder )
<todo-list> <protected> <factor-boilerplate> ;
: 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 ;
: <factor-website> ( -- responder )
<dispatcher>
<todo-app> "todo" add-responder
<pastebin-app> "pastebin" add-responder
<planet-app> "planet" add-responder ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
init-factor-db
<factor-website> main-responder set-global
"planet" main-responder get responders>> at start-update-task ;

47
extra/webapps/planet/page.xml → extra/webapps/factor-website/page.xml
View File

@ -10,52 +10,63 @@
<head>
<t:write-title />
<t:write-atom />
<t:style include="resource:extra/xmode/code2html/stylesheet.css" />
<t:style>
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
.link-button {
padding: 0px;
background: none;
border: none;
}
.inline {
display: inline;
}
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
a, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
}
h1 a {
border: none;
}
a:hover, .link:hover {
border-bottom:1px solid #66a;
}
.error { color: #a00; }
.field-label {
text-align: right;
}
.inline {
display: inline;
}
.navbar {
background-color: #eee;
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;
}
</t:style>
<t:write-style />
</head>
<body>
<h1><t:a href="planet"><t:write-title /></t:a></h1>
<t:call-next-template />
</body>

23
extra/webapps/pastebin/annotation.xml Normal file
View File

@ -0,0 +1,23 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2>Annotation: <t:view component="summary" /></h2>
<table>
<tr><th class="field-label">Author: </th><td><t:view component="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:view component="mode" /></td></tr>
<tr><th class="field-label">Date: </th><td><t:view component="date" /></td></tr>
</table>
<div class="description">
<t:view component="contents" />
</div>
<t:form action="$pastebin/delete-annotation" class="inline">
<t:edit component="id" />
<t:edit component="aid" />
<button class="link-button link">Delete Annotation</button>
</t:form>
</t:chloe>

1
extra/webapps/pastebin/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

25
extra/webapps/pastebin/new-annotation.xml Normal file
View File

@ -0,0 +1,25 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>New Annotation</t:title>
<t:form action="$pastebin/annotate">
<t:edit component="id" />
<table>
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:edit component="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:edit component="mode" /></td></tr>
<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="contents" /></td></tr>
<tr><th class="field-label">Captcha: </th><td><t:edit component="captcha" /></td></tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
</tr>
</table>
<input type="SUBMIT" value="Done" />
</t:form>
</t:chloe>

23
extra/webapps/pastebin/new-paste.xml Normal file
View File

@ -0,0 +1,23 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>New Paste</t:title>
<t:form action="$pastebin/new-paste">
<table>
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:edit component="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:edit component="mode" /></td></tr>
<tr><th class="field-label big-field-label">Description: </th><td><t:edit component="contents" /></td></tr>
<tr><th class="field-label">Captcha: </th><td><t:edit component="captcha" /></td></tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
</tr>
</table>
<input type="SUBMIT" value="Submit" />
</t:form>
</t:chloe>

15
extra/webapps/pastebin/paste-list.xml Normal file
View File

@ -0,0 +1,15 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Pastebin</t:title>
<table width="100%">
<th align="left" width="50%">Summary:</th>
<th align="left" width="100">Paste by:</th>
<th align="left" width="200">Date:</th>
<t:summary component="pastes" />
</table>
</t:chloe>

11
extra/webapps/pastebin/paste-summary.xml Normal file
View File

@ -0,0 +1,11 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<tr>
<td><t:a href="view-paste" query="id"><t:view component="summary" /></t:a></td>
<td><t:view component="author" /></td>
<td><t:view component="date" /></td>
</tr>
</t:chloe>

27
extra/webapps/pastebin/paste.xml Normal file
View File

@ -0,0 +1,27 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Pastebin</t:title>
<h2>Paste: <t:view component="summary" /></h2>
<table>
<tr><th class="field-label">Author: </th><td><t:view component="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:view component="mode" /></td></tr>
<tr><th class="field-label">Date: </th><td><t:view component="date" /></td></tr>
</table>
<div class="description">
<t:view component="contents" />
</div>
<t:form action="$pastebin/delete-paste" class="inline">
<t:edit component="id" />
<button class="link-button link">Delete Paste</button>
</t:form>
|
<t:a href="$pastebin/annotate" query="id">Annotate</t:a>
<t:view component="annotations" />
</t:chloe>

7
extra/webapps/pastebin/pastebin.css Normal file
View File

@ -0,0 +1,7 @@
pre.code {
border:1px dashed #ccc;
background-color:#f5f5f5;
padding:5px;
font-size:150%;
color:#000000;
}

253
extra/webapps/pastebin/pastebin.factor Normal file
View File

@ -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
: <mode> ( id -- component )
modes keys natural-sort <choice> ;
: pastebin-template ( name -- template )
"resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
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
: <paste> ( id -- paste )
paste new
swap >>id ;
: pastes ( -- pastes )
f <paste> 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
: <annotation> ( id aid -- annotation )
annotation new
swap >>aid
swap >>id ;
: fetch-annotations ( paste -- paste )
dup annotations>> [
dup id>> f <annotation> select-tuples >>annotations
] unless ;
: <annotation-form> ( -- form )
"paste" <form>
"id" <integer>
hidden >>renderer
add-field
"aid" <integer>
hidden >>renderer
add-field
"annotation" pastebin-template >>view-template
"summary" <string> add-field
"author" <string> add-field
"mode" <mode> add-field
"contents" "mode" <code> add-field
"date" <date> add-field ;
: <new-annotation-form> ( -- form )
"paste" <form>
"new-annotation" pastebin-template >>edit-template
"id" <integer>
hidden >>renderer
t >>required add-field
"summary" <string>
t >>required add-field
"author" <string>
t >>required
add-field
"mode" <mode>
"factor" >>default
t >>required
add-field
"contents" "mode" <code>
t >>required add-field
"captcha" <captcha> add-field ;
: <paste-form> ( -- form )
"paste" <form>
"paste" pastebin-template >>view-template
"paste-summary" pastebin-template >>summary-template
"id" <integer>
hidden >>renderer add-field
"summary" <string> add-field
"author" <string> add-field
"mode" <mode> add-field
"date" <date> add-field
"contents" "mode" <code> add-field
"annotations" <annotation-form> +plain+ <list> add-field ;
: <new-paste-form> ( -- form )
"paste" <form>
"new-paste" pastebin-template >>edit-template
"summary" <string>
t >>required add-field
"author" <string>
t >>required add-field
"mode" <mode>
"factor" >>default
t >>required
add-field
"contents" "mode" <code>
t >>required add-field
"captcha" <captcha> add-field ;
: <paste-list-form> ( -- form )
"pastebin" <form>
"paste-list" pastebin-template >>view-template
"pastes" <paste-form> +plain+ <list> add-field ;
:: <paste-list-action> ( -- action )
[let | form [ <paste-list-form> ] |
<action>
[
blank-values
pastes "pastes" set-value
form view-form
] >>display
] ;
:: <annotate-action> ( form ctor next -- action )
<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 <id-redirect>
] >>submit ;
: pastebin-feed-entries ( -- entries )
pastes <reversed> 20 short head [
[ summary>> ]
[ "$pastebin/view-paste" swap id>> "id" associate link>string ]
[ date>> ] tri
f swap <entry>
] map ;
: pastebin-feed ( -- feed )
feed new
"Factor Pastebin" >>title
"http://paste.factorcode.org" >>link
pastebin-feed-entries >>entries ;
: <feed-action> ( -- action )
<action>
[
"text/xml" <content>
[ pastebin-feed feed>xml write-xml ] >>body
] >>display ;
:: <view-paste-action> ( form ctor -- action )
<action>
{ { "id" [ v-number ] } } >>get-params
[ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init
[ form view-form ] >>display ;
:: <delete-paste-action> ( ctor next -- action )
<action>
{ { "id" [ v-number ] } } >>post-params
[
"id" get ctor call delete-tuple
"id" get f <annotation> select-tuples [ delete-tuple ] each
next f <permanent-redirect>
] >>submit ;
:: <delete-annotation-action> ( ctor next -- action )
<action>
{ { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
[
"id" get "aid" get ctor call delete-tuple
"id" get next <id-redirect>
] >>submit ;
:: <new-paste-action> ( form ctor next -- action )
<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 <id-redirect>
] >>submit ;
TUPLE: pastebin < dispatcher ;
: <pastebin> ( -- responder )
pastebin new-dispatcher
<paste-list-action> "list" add-main-responder
<feed-action> "feed.xml" add-responder
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
[ <paste> ] "$pastebin/list" <delete-paste-action> "delete-paste" add-responder
[ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> "delete-annotation" add-responder
<paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
<new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
<new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
<boilerplate>
"pastebin" pastebin-template >>template ;
: init-pastes-table paste ensure-table ;
: init-annotations-table annotation ensure-table ;

29
extra/webapps/pastebin/pastebin.xml Normal file
View File

@ -0,0 +1,29 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom title="Pastebin - Atom" href="$pastebin/feed.xml" />
<t:style include="resource:extra/webapps/pastebin/pastebin.css" />
<div class="navbar">
<t:a href="$pastebin/list">Pastes</t:a>
| <t:a href="$pastebin/new-paste">New Paste</t:a>
| <t:a href="$pastebin/feed.xml">Atom Feed</t:a>
<t:comment>
<t:if code="http.server.auth.login:allow-edit-profile?">
| <t:a href="$login/edit-profile">Edit Profile</t:a>
</t:if>
<t:form action="$login/logout" class="inline">
| <button type="submit" class="link-button link">Logout</button>
</t:form>
</t:comment>
</div>
<h1><t:write-title /></h1>
<t:call-next-template />
</t:chloe>

14
extra/webapps/planet/admin.xml Normal file
View File

@ -0,0 +1,14 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor Administration</t:title>
<t:summary component="blogroll" />
<p>
<t:a href="$planet-factor/admin/edit-blog">Add Blog</t:a>
| <t:a href="$planet-factor/admin/update">Update</t:a>
</p>
</t:chloe>

2
extra/webapps/planet/blog-summary.xml → extra/webapps/planet/blog-admin-link.xml
View File

@ -2,6 +2,6 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:a href="view-blog" query="id"><t:view component="name" /></t:a>
<t:a href="$planet-factor/admin/edit-blog" query="id"><t:view component="name" /></t:a>
</t:chloe>

10
extra/webapps/planet/edit-blog.xml
View File

@ -4,7 +4,7 @@
<t:title>Edit Blog</t:title>
<t:form action="edit-blog">
<t:form action="$planet-factor/admin/edit-blog">
<t:edit component="id" />
@ -21,8 +21,8 @@
</tr>
<tr>
<th class="field-label">Atom feed:</th>
<td><t:edit component="atom-url" /></td>
<th class="field-label">Feed:</th>
<td><t:edit component="feed-url" /></td>
</tr>
</table>
@ -31,9 +31,7 @@
</t:form>
<t:a href="view" query="id">View</t:a>
|
<t:form action="delete-blog" class="inline">
<t:form action="$planet-factor/admin/delete-blog" class="inline">
<t:edit component="id" />
<button type="submit" class="link-button link">Delete</button>
</t:form>

14
extra/webapps/planet/entry.xml
View File

@ -2,8 +2,16 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2 class="posting-title"><t:view component="title" /></h2>
<p class="posting-body"> <t:view component="description" /> </p>
<p class="posting-date"> <t:view component="pub-date" /> </p>
<h2 class="posting-title">
<t:a value="link"><t:view component="title" /></t:a>
</h2>
<p class="posting-body">
<t:view component="description" />
</p>
<p class="posting-date">
<t:a value="link"><t:view component="pub-date" /></t:a>
</p>
</t:chloe>

115
extra/webapps/planet/planet.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math
calendar alarms logging concurrency.combinators
db.types db.tuples db
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db
rss xml.writer
http.server
http.server.crud
@ -10,17 +10,27 @@ http.server.forms
http.server.actions
http.server.boilerplate
http.server.templating.chloe
http.server.components ;
http.server.components
http.server.auth.login ;
IN: webapps.planet
TUPLE: blog id name www-url atom-url ;
TUPLE: planet-factor < dispatcher postings ;
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
TUPLE: blog id name www-url feed-url ;
M: blog link-title name>> ;
M: blog link-href www-url>> ;
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 ;
@ -29,8 +39,8 @@ blog "BLOGS"
blog new
swap >>id ;
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
: blogroll ( -- seq )
f <blog> select-tuples [ [ name>> ] compare ] sort ;
: <entry-form> ( -- form )
"entry" <form>
@ -43,8 +53,7 @@ blog "BLOGS"
: <blog-form> ( -- form )
"blog" <form>
"edit-blog" planet-template >>edit-template
"view-blog" planet-template >>view-template
"blog-summary" planet-template >>summary-template
"blog-admin-link" planet-template >>summary-template
"id" <integer>
hidden >>renderer
add-field
@ -54,21 +63,33 @@ blog "BLOGS"
"www-url" <url>
t >>required
add-field
"atom-url" <url>
"feed-url" <url>
t >>required
add-field ;
: <planet-factor-form> ( -- form )
"planet-factor" <form>
"planet" planet-template >>view-template
"mini-planet" planet-template >>summary-template
"postings" planet-template >>view-template
"postings-summary" planet-template >>summary-template
"postings" <entry-form> +plain+ <list> add-field
"blogroll" "blog" <link> +unordered+ <list> add-field ;
: <admin-form> ( -- form )
"admin" <form>
"admin" planet-template >>view-template
"blogroll" <blog-form> +unordered+ <list> add-field ;
: blogroll ( -- seq )
f <blog> select-tuples [ [ name>> ] compare ] sort ;
:: <edit-blogroll-action> ( planet -- action )
[let | form [ <admin-form> ] |
<action>
[
blank-values
TUPLE: planet-factor < dispatcher postings ;
blogroll "blogroll" set-value
form view-form
] >>display
] ;
:: <planet-action> ( planet -- action )
[let | form [ <planet-factor-form> ] |
@ -83,14 +104,11 @@ TUPLE: planet-factor < dispatcher postings ;
] >>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>> 30 safe-head >>entries ;
planet postings>> 16 short head >>entries ;
:: <feed-action> ( planet -- action )
<action>
@ -109,7 +127,7 @@ TUPLE: planet-factor < dispatcher postings ;
: fetch-blogroll ( blogroll -- entries )
dup
[ atom-url>> fetch-feed ] parallel-map
[ feed-url>> fetch-feed ] parallel-map
[ >r name>> r> [ <posting> ] with map ] 2map concat ;
: sort-entries ( entries -- entries' )
@ -117,7 +135,8 @@ TUPLE: planet-factor < dispatcher postings ;
: update-cached-postings ( planet -- )
"webapps.planet" [
blogroll fetch-blogroll sort-entries >>postings drop
blogroll fetch-blogroll sort-entries 8 short head
>>postings drop
] with-logging ;
:: <update-action> ( planet -- action )
@ -127,48 +146,26 @@ TUPLE: planet-factor < dispatcher postings ;
"" f <temporary-redirect>
] >>display ;
: start-update-task ( planet -- )
[ update-cached-postings ] curry 10 minutes every drop ;
:: <planet-factor> ( -- responder )
:: <planet-factor-admin> ( planet-factor -- responder )
[let | blog-form [ <blog-form> ]
blog-ctor [ [ <blog> ] ] |
planet-factor new-dispatcher
dup <planet-action> >>default
dup <feed-action> "feed.xml" add-responder
dup <update-action> "update" add-responder
<dispatcher>
planet-factor <edit-blogroll-action> >>default
planet-factor <update-action> "update" add-responder
! Administrative CRUD
blog-ctor "" <delete-action> "delete-blog" add-responder
blog-form blog-ctor <view-action> "view-blog" add-responder
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
blog-ctor "$planet-factor/admin" <delete-action> "delete-blog" add-responder
blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder
] ;
USING: namespaces io.files io.sockets
db.sqlite smtp
http.server.db
http.server.sessions
http.server.auth.login
http.server.auth.providers.db
http.server.sessions.storage.db ;
: test-db "planet.db" resource-path sqlite-db ;
: <planet-app> ( -- responder )
<planet-factor>
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
dup <planet-action> "list" add-main-responder
dup <feed-action> "feed.xml" add-responder
dup <planet-factor-admin> <protected> "admin" add-responder
<boilerplate>
"page" planet-template >>template
! <url-sessions>
! sessions-in-db >>sessions
test-db <db-persistence> ;
"planet" planet-template >>template ;
: init-planet ( -- )
! test-db [
! init-blog-table
! init-users-table
! init-sessions-table
! ] with-db
<dispatcher>
<planet-app> "planet" add-responder
main-responder set-global ;
: start-update-task ( planet -- )
[ update-cached-postings ] curry 10 minutes every drop ;

43
extra/webapps/planet/planet.xml
View File

@ -2,36 +2,29 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor</t:title>
<t:atom title="Planet Factor - Atom" href="feed.xml" />
<t:comment>
<t:atom title="Planet Factor - Atom" href="$planet/feed.xml" />
</t:comment>
<t:style include="resource:extra/webapps/planet/planet.css" />
<table width="100%" cellpadding="10">
<tr>
<td> <t:view component="postings" /> </td>
<div class="navbar">
<t:a href="$planet-factor/list">Front Page</t:a>
| <t:a href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a href="$planet-factor/admin">Admin</t:a>
<td valign="top" width="25%" class="infobox">
<p>
<strong>planet-factor</strong> is an Atom feed aggregator that collects the
contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It was inspired by
<a href="http://planet.lisp.org">Planet Lisp</a>.
</p>
<p>
<img src="http://planet.lisp.org/feed-icon-14x14.png" />
<a href="feed.xml"> Syndicate </a>
</p>
<t:comment>
<t:if code="http.server.auth.login:allow-edit-profile?">
| <t:a href="$login/edit-profile">Edit Profile</t:a>
</t:if>
<h2>Blogroll</h2>
<t:form action="$login/logout" class="inline">
| <button type="submit" class="link-button link">Logout</button>
</t:form>
</t:comment>
</div>
<t:summary component="blogroll" />
<h1><t:write-title /></h1>
Admin: <t:a href="edit-blog">Add Blog</t:a>
|
<t:a href="update">Update</t:a>
</td>
</tr>
</table>
<t:call-next-template />
</t:chloe>

0
extra/webapps/planet/mini-planet.xml → extra/webapps/planet/postings-summary.xml
View File

19
extra/webapps/planet/postings.xml Normal file
View File

@ -0,0 +1,19 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor</t:title>
<table width="100%" cellpadding="10">
<tr>
<td> <t:view component="postings" /> </td>
<td valign="top" width="25%" class="infobox">
<h2>Blogroll</h2>
<t:summary component="blogroll" />
</td>
</tr>
</table>
</t:chloe>

41
extra/webapps/planet/view-blog.xml
View File

@ -1,41 +0,0 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>View Blog</t:title>
<table>
<tr>
<th class="field-label">Blog name:</th>
<td><t:view component="name" /></td>
</tr>
<tr>
<th class="field-label">Home page:</th>
<td>
<t:a value="www-url">
<t:view component="www-url" />
</t:a>
</td>
</tr>
<tr>
<th class="field-label">Atom feed:</th>
<td>
<t:a value="atom-url">
<t:view component="atom-url" />
</t:a>
</td>
</tr>
</table>
<t:a href="edit-blog" query="id">Edit</t:a>
|
<t:form action="delete-blog" class="inline">
<t:edit component="id" />
<button type="submit" class="link-button link">Delete</button>
</t:form>
</t:chloe>

10
extra/webapps/todo/edit-todo.xml
View File

@ -4,21 +4,21 @@
<t:title>Edit Item</t:title>
<t:form action="edit">
<t:form action="$todo-list/edit">
<t:edit component="id" />
<table>
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
<tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
<tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
</table>
<input type="SUBMIT" value="Done" />
</t:form>
<t:a href="view" query="id">View</t:a>
<t:a href="$todo-list/view" query="id">View</t:a>
|
<t:form action="delete" class="inline">
<t:form action="$todo-list/delete" class="inline">
<t:edit component="id" />
<button type="submit" class="link-button link">Delete</button>
</t:form>

45
extra/webapps/todo/page.xml
View File

@ -1,45 +0,0 @@
<?xml version='1.0' ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<head>
<t:write-title />
<t:style>
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
a, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
}
a:hover, .link:hover {
border-bottom:1px solid #66a;
}
.error { color: #a00; }
.field-label {
text-align: right;
}
</t:style>
<t:write-style />
</head>
<body>
<t:call-next-template />
</body>
</t:chloe>
</html>

4
extra/webapps/todo/todo-summary.xml
View File

@ -10,10 +10,10 @@
<t:view component="priority" />
</td>
<td>
<t:a href="view" query="id">View</t:a>
<t:a href="$todo-list/view" query="id">View</t:a>
</td>
<td>
<t:a href="edit" query="id">Edit</t:a>
<t:a href="$todo-list/edit" query="id">Edit</t:a>
</td>
</tr>

28
extra/webapps/todo/todo.css
View File

@ -1,31 +1,3 @@
.big-field-label {
vertical-align: top;
}
.description {
border: 1px dashed #ccc;
background-color: #f5f5f5;
padding: 5px;
font-size: 150%;
color: #000000;
}
.link-button {
padding: 0px;
background: none;
border: none;
}
.navbar {
background-color: #eeeeee;
padding: 5px;
border: 1px solid #ccc;
}
.inline {
display: inline;
}
pre {
font-size: 75%;
}

54
extra/webapps/todo/todo.factor
View File

@ -1,11 +1,12 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel locals sequences
USING: accessors kernel locals sequences namespaces
db db.types db.tuples
http.server.components http.server.components.farkup
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 ;
IN: webapps.todo
@ -56,58 +57,17 @@ todo "TODO"
"list" <todo-form> +plain+ <list>
add-field ;
TUPLE: todo-responder < dispatcher ;
TUPLE: todo-list < dispatcher ;
:: <todo-responder> ( -- responder )
:: <todo-list> ( -- responder )
[let | todo-form [ <todo-form> ]
list-form [ <todo-list-form> ]
ctor [ [ <todo> ] ] |
todo-responder new-dispatcher
todo-list new-dispatcher
list-form ctor <list-action> "list" add-main-responder
todo-form ctor <view-action> "view" add-responder
todo-form ctor "view" <edit-action> "edit" add-responder
ctor "list" <delete-action> "delete" add-responder
todo-form ctor "$todo-list/view" <edit-action> "edit" add-responder
ctor "$todo-list/list" <delete-action> "delete" add-responder
<boilerplate>
"todo" todo-template >>template
] ;
! What follows below is somewhat akin to a 'deployment descriptor'
! for the todo application. The <todo-responder> can be integrated
! into an existing web app that provides session management and
! login facilities, or <todo-app> can be used to run a
! self-contained todo instance.
USING: namespaces io.files io.sockets
db.sqlite smtp
http.server.sessions
http.server.auth.login
http.server.auth.providers.db
http.server.sessions.storage.db ;
: test-db "todo.db" resource-path sqlite-db ;
: <todo-app> ( -- responder )
<todo-responder>
<login>
users-in-db >>users
allow-registration
allow-password-recovery
allow-edit-profile
<boilerplate>
"page" todo-template >>template
<url-sessions>
sessions-in-db >>sessions
test-db <db-persistence> ;
: init-todo ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
test-db [
init-todo-table
init-users-table
init-sessions-table
] with-db
<dispatcher>
<todo-app> "todo" add-responder
main-responder set-global ;

10
extra/webapps/todo/todo.xml
View File

@ -4,17 +4,15 @@
<t:style include="resource:extra/webapps/todo/todo.css" />
<t:style include="resource:extra/xmode/code2html/stylesheet.css" />
<div class="navbar">
<t:a href="list">List Items</t:a>
| <t:a href="edit">Add Item</t:a>
<t:a href="$todo-list/list">List Items</t:a>
| <t:a href="$todo-list/edit">Add Item</t:a>
<t:if code="http.server.auth.login:allow-edit-profile?">
| <t:a href="edit-profile">Edit Profile</t:a>
| <t:a href="$login/edit-profile">Edit Profile</t:a>
</t:if>
<t:form action="logout" class="inline">
<t:form action="$login/logout" class="inline">
| <button type="submit" class="link-button link">Logout</button>
</t:form>
</div>

4
extra/webapps/todo/view-todo.xml
View File

@ -13,9 +13,9 @@
<t:view component="description" />
</div>
<t:a href="edit" query="id">Edit</t:a>
<t:a href="$todo-list/edit" query="id">Edit</t:a>
|
<t:form action="delete" class="inline">
<t:form action="$todo-list/delete" class="inline">
<t:edit component="id" />
<button class="link-button link">Delete</button>
</t:form>

8
extra/windows/windows.factor
View File

@ -30,10 +30,10 @@ FUNCTION: void* error_message ( DWORD id ) ;
: win32-error ( -- )
GetLastError (win32-error) ;
: win32-error=0/f { 0 f } member? [ win32-error ] when ;
: win32-error>0 0 > [ win32-error ] when ;
: win32-error<0 0 < [ win32-error ] when ;
: win32-error<>0 zero? [ win32-error ] unless ;
: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
: invalid-handle? ( handle -- )
INVALID_HANDLE_VALUE = [

2
vm/ffi_test.c
View File

@ -255,7 +255,7 @@ static int global_var;
void ffi_test_36_point_5(void)
{
printf("int_ffi_test_36_point_5\n");
printf("ffi_test_36_point_5\n");
global_var = 0;
}

2
vm/ffi_test.h
View File

@ -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));