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

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

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

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

@ -3,14 +3,14 @@ debugger ;
IN: alien.strings IN: alien.strings
HELP: string>alien 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." } { $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." } ; { $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 { string>alien alien>string malloc-string } related-words
HELP: alien>string 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." } ; { $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
HELP: malloc-string 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 ; io.encodings.utf16 system alien strings cpu.architecture ;
IN: alien.strings 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 M: c-ptr alien>string
>r <memory-stream> r> <decoder> >r <memory-stream> r> <decoder>

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

@ -3,7 +3,7 @@ bit-vectors.private combinators ;
IN: bit-vectors IN: bit-vectors
ARTICLE: "bit-vectors" "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 $nl
"Bit vectors form a class:" "Bit vectors form a class:"
{ $subsection bit-vector } { $subsection bit-vector }
@ -19,7 +19,7 @@ $nl
ABOUT: "bit-vectors" ABOUT: "bit-vectors"
HELP: bit-vector 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> HELP: <bit-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" 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" ABOUT: "byte-vectors"
HELP: byte-vector 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> HELP: <byte-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" 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 ; continuations system ;
IN: calendar.tests 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 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 ] [ 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 [ 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 #! Uses average month/year length since dt loses calendar
#! data #! data
0 swap 0 swap
[ year>> + ] keep {
[ month>> months-per-year / + ] keep [ year>> + ]
[ day>> days-per-year / + ] keep [ month>> months-per-year / + ]
[ hour>> hours-per-year / + ] keep [ day>> days-per-year / + ]
[ minute>> minutes-per-year / + ] keep [ hour>> hours-per-year / + ]
second>> seconds-per-year / + ; [ minute>> minutes-per-year / + ]
[ second>> seconds-per-year / + ]
} cleave ;
M: duration <=> [ dt>years ] compare ; M: duration <=> [ dt>years ] compare ;
@ -252,14 +254,21 @@ M: timestamp time-
#! Exact calendar-time difference #! Exact calendar-time difference
(time-) seconds ; (time-) seconds ;
: time* ( obj1 obj2 -- obj3 )
dup real? [ swap ] when
dup real? [ * ] [
{
[ year>> * ]
[ month>> * ]
[ day>> * ]
[ hour>> * ]
[ minute>> * ]
[ second>> * ]
} 2cleave <duration>
] if ;
: before ( dt -- -dt ) : before ( dt -- -dt )
[ year>> neg ] keep -1 time* ;
[ month>> neg ] keep
[ day>> neg ] keep
[ hour>> neg ] keep
[ minute>> neg ] keep
second>> neg
<duration> ;
M: duration time- M: duration time-
before time+ ; before time+ ;

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

@ -1,26 +1,45 @@
USING: calendar.format calendar kernel tools.test USING: calendar.format calendar kernel math tools.test
io.streams.string ; io.streams.string accessors io ;
IN: calendar.format.tests IN: calendar.format.tests
[ 0 ] [ [ 0 ] [
"Z" [ read-rfc3339-gmt-offset ] with-string-reader "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test ] unit-test
[ 1 ] [ [ 1 ] [
"+01" [ read-rfc3339-gmt-offset ] with-string-reader "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test ] unit-test
[ -1 ] [ [ -1 ] [
"-01" [ read-rfc3339-gmt-offset ] with-string-reader "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test ] unit-test
[ -1-1/2 ] [ [ -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 ] unit-test
[ 1+1/2 ] [ [ 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 ] unit-test
[ ] [ now timestamp>rfc3339 drop ] unit-test [ ] [ now timestamp>rfc3339 drop ] unit-test
[ ] [ now timestamp>rfc822 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 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 IN: calendar.format
GENERIC: day. ( obj -- ) GENERIC: day. ( obj -- )
@ -58,11 +59,11 @@ M: timestamp year. ( timestamp -- )
[ hour>> write-00 ] [ minute>> write-00 ] bi ; [ hour>> write-00 ] [ minute>> write-00 ] bi ;
: write-gmt-offset ( gmt-offset -- ) : write-gmt-offset ( gmt-offset -- )
dup instant <=> { dup instant <=> sgn {
{ [ dup 0 = ] [ 2drop "GMT" write ] } { 0 [ drop "GMT" write ] }
{ [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] } { -1 [ "-" write before (write-gmt-offset) ] }
{ [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] } { 1 [ "+" write (write-gmt-offset) ] }
} cond ; } case ;
: timestamp>rfc822 ( timestamp -- str ) : timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format #! RFC822 timestamp format
@ -83,20 +84,22 @@ M: timestamp year. ( timestamp -- )
[ minute>> write-00 ] bi ; [ minute>> write-00 ] bi ;
: write-rfc3339-gmt-offset ( duration -- ) : write-rfc3339-gmt-offset ( duration -- )
dup instant <=> { dup instant <=> sgn {
{ [ dup 0 = ] [ 2drop "Z" write ] } { 0 [ drop "Z" write ] }
{ [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] } { -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
{ [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] } { 1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] }
} cond ; } case ;
: (timestamp>rfc3339) ( timestamp -- ) : (timestamp>rfc3339) ( timestamp -- )
dup year>> number>string write CHAR: - write1 {
dup month>> write-00 CHAR: - write1 [ year>> number>string write CHAR: - write1 ]
dup day>> write-00 CHAR: T write1 [ month>> write-00 CHAR: - write1 ]
dup hour>> write-00 CHAR: : write1 [ day>> write-00 CHAR: T write1 ]
dup minute>> write-00 CHAR: : write1 [ hour>> write-00 CHAR: : write1 ]
dup second>> >fixnum write-00 [ minute>> write-00 CHAR: : write1 ]
gmt-offset>> write-rfc3339-gmt-offset ; [ second>> >fixnum write-00 ]
[ gmt-offset>> write-rfc3339-gmt-offset ]
} cleave ;
: timestamp>rfc3339 ( timestamp -- str ) : timestamp>rfc3339 ( timestamp -- str )
[ (timestamp>rfc3339) ] with-string-writer ; [ (timestamp>rfc3339) ] with-string-writer ;
@ -106,14 +109,20 @@ M: timestamp year. ( timestamp -- )
: read-00 2 read string>number ; : read-00 2 read string>number ;
: read-000 3 read string>number ;
: read-0000 4 read string>number ; : read-0000 4 read string>number ;
: read-rfc3339-gmt-offset ( -- n ) : signed-gmt-offset ( dt ch -- dt' )
read1 dup CHAR: Z = [ drop 0 ] [ { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
read-00 : read-rfc3339-gmt-offset ( ch -- dt )
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case dup CHAR: Z = [ drop instant ] [
60 / + * >r
read-00 hours
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
time+
r> signed-gmt-offset
] if ; ] if ;
: read-ymd ( -- y m d ) : read-ymd ( -- y m d )
@ -126,26 +135,61 @@ M: timestamp year. ( timestamp -- )
read-ymd read-ymd
"Tt" expect "Tt" expect
read-hms read-hms
read-rfc3339-gmt-offset ! timezone read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
read-rfc3339-gmt-offset
<timestamp> ; <timestamp> ;
: rfc3339>timestamp ( str -- timestamp ) : rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] with-string-reader ; [ (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 ) : (ymdhms>timestamp) ( -- timestamp )
read-ymd " " expect read-hms 0 <timestamp> ; read-ymd " " expect read-hms instant <timestamp> ;
: ymdhms>timestamp ( str -- timestamp ) : ymdhms>timestamp ( str -- timestamp )
[ (ymdhms>timestamp) ] with-string-reader ; [ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp ) : (hms>timestamp) ( -- timestamp )
f f f read-hms f <timestamp> ; f f f read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp ) : hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ; [ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp ) : (ymd>timestamp) ( -- timestamp )
read-ymd f f f f <timestamp> ; read-ymd f f f instant <timestamp> ;
: ymd>timestamp ( str -- timestamp ) : ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ; [ (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." } { $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 { $examples
{ $example { $example
"USING: arrays prettyprint sequences ;" "USING: arrays prettyprint columns ;"
"{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ." "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
"{ 1 4 7 }" "{ 1 4 7 }"
} }

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

@ -80,9 +80,9 @@ SYMBOL: person4
"teddy" "teddy"
10 10
3.14 3.14
T{ timestamp f 2008 3 5 16 24 11 0 } 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 f } 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 f } 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 } B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
} }
] [ T{ person f 3 } select-tuple ] unit-test ] [ T{ person f 3 } select-tuple ] unit-test
@ -96,9 +96,9 @@ SYMBOL: person4
"eddie" "eddie"
10 10
3.14 3.14
T{ timestamp f 2008 3 5 16 24 11 0 } 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 f } 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 f } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f f
H{ { 1 2 } { 3 4 } { 5 "lol" } } H{ { 1 2 } { 3 4 } { 5 "lol" } }
} }

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

@ -3,7 +3,7 @@ float-vectors.private combinators ;
IN: float-vectors IN: float-vectors
ARTICLE: "float-vectors" "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 $nl
"Float vectors form a class:" "Float vectors form a class:"
{ $subsection float-vector } { $subsection float-vector }
@ -19,7 +19,7 @@ $nl
ABOUT: "float-vectors" ABOUT: "float-vectors"
HELP: float-vector 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> HELP: <float-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } } { $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }

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

@ -1,7 +1,7 @@
USING: alien alien.c-types kernel libc math namespaces USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32 windows windows.kernel32 windows.advapi32
words combinators vocabs.loader hardware-info.backend words combinators vocabs.loader hardware-info.backend
system ; system alien.strings ;
IN: hardware-info.windows IN: hardware-info.windows
: system-info ( -- SYSTEM_INFO ) : system-info ( -- SYSTEM_INFO )

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

@ -39,13 +39,16 @@ DEFER: http-request
SYMBOL: redirects SYMBOL: redirects
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: do-redirect ( response -- response stream ) : do-redirect ( response -- response stream )
dup response-code 300 399 between? [ dup response-code 300 399 between? [
stdio get dispose stdio get dispose
redirects inc redirects inc
redirects get max-redirects < [ redirects get max-redirects < [
header>> "location" swap at header>> "location" swap at
dup "http://" head? [ dup absolute-url? [
absolute-redirect absolute-redirect
] [ ] [
relative-redirect relative-redirect
@ -74,8 +77,8 @@ PRIVATE>
] with-variable ; ] with-variable ;
: read-chunks ( -- ) : read-chunks ( -- )
readln ";" split1 drop hex> read-crlf ";" split1 drop hex> dup { f 0 } member?
dup { f 0 } member? [ drop ] [ read % read-chunks ] if ; [ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
: do-chunked-encoding ( response stream -- response stream/string ) : do-chunked-encoding ( response stream -- response stream/string )
over "transfer-encoding" header "chunked" = [ over "transfer-encoding" header "chunked" = [
@ -116,8 +119,12 @@ M: download-failed error.
: download-to ( url file -- ) : download-to ( url file -- )
#! Downloads the contents of a URL to a file. #! Downloads the contents of a URL to a file.
swap http-get-stream swap check-response swap http-get-stream check-response
[ swap latin1 <file-writer> stream-copy ] with-disposal ; dup string? [
latin1 [ write ] with-file-writer
] [
[ swap latin1 <file-writer> stream-copy ] with-disposal
] if ;
: download ( url -- ) : download ( url -- )
dup download-name download-to ; dup download-name download-to ;

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

@ -24,6 +24,8 @@ IN: http.tests
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test [ "/bar" ] [ "/bar" url>path ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1 STRING: read-request-test-1
GET http://foo/bar HTTP/1.1 GET http://foo/bar HTTP/1.1
Some-Header: 1 Some-Header: 1
@ -45,7 +47,7 @@ blah
cookies: V{ } cookies: V{ }
} }
] [ ] [
read-request-test-1 [ read-request-test-1 lf>crlf [
read-request read-request
] with-string-reader ] with-string-reader
] unit-test ] unit-test
@ -59,7 +61,7 @@ blah
; ;
read-request-test-1' 1array [ read-request-test-1' 1array [
read-request-test-1 read-request-test-1 lf>crlf
[ read-request ] with-string-reader [ read-request ] with-string-reader
[ write-request ] with-string-writer [ write-request ] with-string-writer
! normalize crlf ! normalize crlf
@ -69,6 +71,7 @@ read-request-test-1' 1array [
STRING: read-request-test-2 STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1 HEAD http://foo/bar HTTP/1.1
Host: www.sex.com Host: www.sex.com
; ;
[ [
@ -83,7 +86,7 @@ Host: www.sex.com
cookies: V{ } cookies: V{ }
} }
] [ ] [
read-request-test-2 [ read-request-test-2 lf>crlf [
read-request read-request
] with-string-reader ] with-string-reader
] unit-test ] unit-test
@ -104,7 +107,7 @@ blah
cookies: V{ } cookies: V{ }
} }
] [ ] [
read-response-test-1 read-response-test-1 lf>crlf
[ read-response ] with-string-reader [ read-response ] with-string-reader
] unit-test ] unit-test
@ -117,7 +120,7 @@ content-type: text/html
; ;
read-response-test-1' 1array [ read-response-test-1' 1array [
read-response-test-1 read-response-test-1 lf>crlf
[ read-response ] with-string-reader [ read-response ] with-string-reader
[ write-response ] with-string-writer [ write-response ] with-string-writer
! normalize crlf ! normalize crlf
@ -162,7 +165,7 @@ io.encodings.ascii ;
"localhost" 1237 <inet> ascii <client> [ "localhost" 1237 <inet> ascii <client> [
"GET nested HTTP/1.0\r\n" write flush "GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush "\r\n" write flush
readln drop read-crlf drop
read-header read-header
] with-stream "location" swap at "/" head? ] with-stream "location" swap at "/" head?
] unit-test ] unit-test

42
extra/http/http.factor
View File

@ -1,10 +1,18 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry hashtables io io.streams.string kernel math sets USING: accessors kernel combinators math namespaces
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string io.sockets namespaces assocs sequences splitting sorting sets debugger
unicode.case combinators vectors sorting accessors calendar strings vectors hashtables quotations arrays byte-arrays
calendar.format quotations arrays combinators.lib 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 IN: http
: http-port 80 ; inline : http-port 80 ; inline
@ -13,11 +21,12 @@ IN: http
#! In a URL, can this character be used without #! In a URL, can this character be used without
#! URL-encoding? #! URL-encoding?
{ {
[ dup letter? ] { [ dup letter? ] [ t ] }
[ dup LETTER? ] { [ dup LETTER? ] [ t ] }
[ dup digit? ] { [ dup digit? ] [ t ] }
[ dup "/_-.:" member? ] { [ dup "/_-.:" member? ] [ t ] }
} || nip ; foldable [ f ]
} cond nip ; foldable
: push-utf8 ( ch -- ) : push-utf8 ( ch -- )
1string utf8 encode 1string utf8 encode
@ -75,8 +84,15 @@ IN: http
] if ] if
] 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 ( -- ) : read-header-line ( -- )
readln dup read-crlf dup
empty? [ drop ] [ header-line read-header-line ] if ; empty? [ drop ] [ header-line read-header-line ] if ;
: read-header ( -- assoc ) : read-header ( -- assoc )
@ -224,7 +240,7 @@ cookies ;
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
: read-request-version ( request -- request ) : read-request-version ( request -- request )
readln [ CHAR: \s = ] left-trim read-crlf [ CHAR: \s = ] left-trim
parse-version parse-version
>>version ; >>version ;
@ -372,7 +388,7 @@ body ;
>>code ; >>code ;
: read-response-message : read-response-message
readln >>message ; read-crlf >>message ;
: read-response-header : read-response-header
read-header >>header read-header >>header

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

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

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

@ -363,7 +363,7 @@ M: login call-responder ( path responder -- response )
: <login> ( responder -- auth ) : <login> ( responder -- auth )
login new-dispatcher login new-dispatcher
swap <protected> >>default swap >>default
<login-action> <login-boilerplate> "login" add-responder <login-action> <login-boilerplate> "login" add-responder
<logout-action> <login-boilerplate> "logout" add-responder <logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ; no-users >>users ;

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

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

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

@ -280,6 +280,22 @@ TUPLE: date < string ;
M: date component-string M: date component-string
drop timestamp>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 ! List components
SYMBOL: +plain+ SYMBOL: +plain+
SYMBOL: +ordered+ SYMBOL: +ordered+
@ -289,17 +305,20 @@ TUPLE: list-renderer component type ;
C: <list-renderer> list-renderer C: <list-renderer> list-renderer
: render-plain-list ( seq quot component -- ) : render-plain-list ( seq component quot -- )
swap '[ , @ ] each ; inline '[ , component>> renderer>> @ ] each ; inline
: render-li-list ( seq component quot -- )
'[ <li> @ </li> ] render-plain-list ; inline
: render-ordered-list ( seq quot component -- ) : 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 -- ) : render-unordered-list ( seq quot component -- )
swap <ul> '[ <li> , @ </li> ] each </ul> ; inline <ul> render-li-list </ul> ; inline
: render-list ( value renderer quot -- ) : render-list ( value renderer quot -- )
swap [ component>> ] [ type>> ] bi { over type>> {
{ +plain+ [ render-plain-list ] } { +plain+ [ render-plain-list ] }
{ +ordered+ [ render-ordered-list ] } { +ordered+ [ render-ordered-list ] }
{ +unordered+ [ render-unordered-list ] } { +unordered+ [ render-unordered-list ] }

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

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

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

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

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

@ -153,6 +153,7 @@ SYMBOL: tags
{ "form" [ form-tag ] } { "form" [ form-tag ] }
{ "error" [ error-tag ] } { "error" [ error-tag ] }
{ "if" [ if-tag ] } { "if" [ if-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] } { "call-next-template" [ drop call-next-template ] }
[ "Unknown chloe tag: " swap append throw ] [ "Unknown chloe tag: " swap append throw ]
} case ; } case ;
@ -189,7 +190,7 @@ SYMBOL: tags
] if ] if
] with-scope ; ] with-scope ;
M: chloe call-template M: chloe call-template*
path>> utf8 <file-reader> read-xml process-chloe ; path>> utf8 <file-reader> read-xml process-chloe ;
INSTANCE: chloe template INSTANCE: chloe template

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

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

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

@ -1,10 +1,21 @@
USING: accessors kernel fry io.encodings.utf8 io.files USING: accessors kernel fry io io.encodings.utf8 io.files
http http.server ; http http.server debugger prettyprint continuations ;
IN: http.server.templating IN: http.server.templating
MIXIN: template 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 ; M: template write-response-body* call-template ;

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

@ -5,7 +5,7 @@ IN: rss.tests
: load-news-file ( filename -- feed ) : load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning #! Load an news syndication file and process it, returning
#! it as an feed tuple. #! it as an feed tuple.
utf8 <file-reader> read-feed ; utf8 file-contents read-feed ;
[ T{ [ T{
feed feed
@ -36,7 +36,7 @@ IN: rss.tests
"http://example.org/2005/04/02/atom" "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 " "\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 } ] [ "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 [ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep [ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name> 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> ; <entry> ;
: rss1.0 ( xml -- feed ) : rss1.0 ( xml -- feed )
@ -39,7 +39,7 @@ C: <entry> entry
[ "link" tag-named ] keep [ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep [ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named 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 ) : rss2.0 ( xml -- feed )
"channel" tag-named "channel" tag-named
@ -71,16 +71,12 @@ C: <entry> entry
{ "feed" [ atom1.0 ] } { "feed" [ atom1.0 ] }
} case ; } case ;
: read-feed ( stream -- feed ) : read-feed ( string -- feed )
[ read-xml ] with-html-entities xml>feed ; [ string>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed ) : download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple. #! Retrieve an news syndication file, return as a feed tuple.
http-get-stream swap code>> success? [ http-get read-feed ;
read-feed
] [
dispose "Error retrieving newsfeed file" throw
] if ;
! Atom generation ! Atom generation
: simple-tag, ( content name -- ) : simple-tag, ( content name -- )

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

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

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

@ -0,0 +1,38 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences io.files io.sockets
db.sqlite smtp namespaces db
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 ;
IN: webapps.factor-website
: factor-template ( path -- template )
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
: test-db "todo.db" resource-path sqlite-db ;
: <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> ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
test-db [
init-sessions-table
init-users-table
] with-db ;

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

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

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

@ -0,0 +1,13 @@
<?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="edit-blog">Add Blog</t:a> | <t:a href="update">Update</t:a>
</p>
</t:chloe>

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

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

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

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math USING: kernel accessors sequences sorting locals math
calendar alarms logging concurrency.combinators calendar alarms logging concurrency.combinators namespaces
db.types db.tuples db db.types db.tuples db
rss xml.writer rss xml.writer
http.server http.server
@ -10,11 +10,22 @@ http.server.forms
http.server.actions http.server.actions
http.server.boilerplate http.server.boilerplate
http.server.templating.chloe http.server.templating.chloe
http.server.components ; http.server.components
http.server.auth.login
webapps.factor-website ;
IN: webapps.planet IN: webapps.planet
TUPLE: planet-factor < dispatcher postings ;
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
TUPLE: blog id name www-url atom-url ; TUPLE: blog id name www-url atom-url ;
M: blog link-title name>> ;
M: blog link-href www-url>> ;
blog "BLOGS" blog "BLOGS"
{ {
{ "id" "ID" INTEGER +native-id+ } { "id" "ID" INTEGER +native-id+ }
@ -29,8 +40,8 @@ blog "BLOGS"
blog new blog new
swap >>id ; swap >>id ;
: planet-template ( name -- template ) : blogroll ( -- seq )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ; f <blog> select-tuples [ [ name>> ] compare ] sort ;
: <entry-form> ( -- form ) : <entry-form> ( -- form )
"entry" <form> "entry" <form>
@ -44,7 +55,7 @@ blog "BLOGS"
"blog" <form> "blog" <form>
"edit-blog" planet-template >>edit-template "edit-blog" planet-template >>edit-template
"view-blog" planet-template >>view-template "view-blog" planet-template >>view-template
"blog-summary" planet-template >>summary-template "blog-admin-link" planet-template >>summary-template
"id" <integer> "id" <integer>
hidden >>renderer hidden >>renderer
add-field add-field
@ -60,15 +71,27 @@ blog "BLOGS"
: <planet-factor-form> ( -- form ) : <planet-factor-form> ( -- form )
"planet-factor" <form> "planet-factor" <form>
"planet" planet-template >>view-template "postings" planet-template >>view-template
"mini-planet" planet-template >>summary-template "postings-summary" planet-template >>summary-template
"postings" <entry-form> +plain+ <list> add-field "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" <blog-form> +unordered+ <list> add-field ;
: blogroll ( -- seq ) :: <edit-blogroll-action> ( planet -- action )
f <blog> select-tuples [ [ name>> ] compare ] sort ; [let | form [ <admin-form> ] |
<action>
[
blank-values
TUPLE: planet-factor < dispatcher postings ; blogroll "blogroll" set-value
form view-form
] >>display
] ;
:: <planet-action> ( planet -- action ) :: <planet-action> ( planet -- action )
[let | form [ <planet-factor-form> ] | [let | form [ <planet-factor-form> ] |
@ -90,7 +113,7 @@ TUPLE: planet-factor < dispatcher postings ;
feed new feed new
"[ planet-factor ]" >>title "[ planet-factor ]" >>title
"http://planet.factorcode.org" >>link "http://planet.factorcode.org" >>link
planet postings>> 30 safe-head >>entries ; planet postings>> 16 safe-head >>entries ;
:: <feed-action> ( planet -- action ) :: <feed-action> ( planet -- action )
<action> <action>
@ -117,7 +140,8 @@ TUPLE: planet-factor < dispatcher postings ;
: update-cached-postings ( planet -- ) : update-cached-postings ( planet -- )
"webapps.planet" [ "webapps.planet" [
blogroll fetch-blogroll sort-entries >>postings drop blogroll fetch-blogroll sort-entries 8 safe-head
>>postings drop
] with-logging ; ] with-logging ;
:: <update-action> ( planet -- action ) :: <update-action> ( planet -- action )
@ -127,16 +151,11 @@ TUPLE: planet-factor < dispatcher postings ;
"" f <temporary-redirect> "" f <temporary-redirect>
] >>display ; ] >>display ;
: start-update-task ( planet -- ) :: <planet-factor-admin> ( planet-factor -- responder )
[ update-cached-postings ] curry 10 minutes every drop ;
:: <planet-factor> ( -- responder )
[let | blog-form [ <blog-form> ] [let | blog-form [ <blog-form> ]
blog-ctor [ [ <blog> ] ] | blog-ctor [ [ <blog> ] ] |
planet-factor new-dispatcher <dispatcher>
dup <planet-action> >>default planet-factor <edit-blogroll-action> >>default
dup <feed-action> "feed.xml" add-responder
dup <update-action> "update" add-responder
! Administrative CRUD ! Administrative CRUD
blog-ctor "" <delete-action> "delete-blog" add-responder blog-ctor "" <delete-action> "delete-blog" add-responder
@ -144,30 +163,25 @@ TUPLE: planet-factor < dispatcher postings ;
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
] ; ] ;
USING: namespaces io.files io.sockets : <planet-factor> ( -- responder )
db.sqlite smtp planet-factor new-dispatcher
http.server.db dup <planet-action> >>default
http.server.sessions dup <feed-action> "feed.xml" add-responder
http.server.auth.login dup <update-action> "update" add-responder
http.server.auth.providers.db dup <planet-factor-admin> <protected> "admin" add-responder
http.server.sessions.storage.db ;
: test-db "planet.db" resource-path sqlite-db ;
: <planet-app> ( -- responder )
<planet-factor>
<boilerplate> <boilerplate>
"page" planet-template >>template "planet" planet-template >>template ;
! <url-sessions>
! sessions-in-db >>sessions : <planet-app> ( -- responder )
test-db <db-persistence> ; <planet-factor> <factor-boilerplate> ;
: start-update-task ( planet -- )
[ update-cached-postings ] curry 10 minutes every drop ;
: init-planet ( -- ) : init-planet ( -- )
! test-db [ test-db [
! init-blog-table init-blog-table
! init-users-table ] with-db
! init-sessions-table
! ] with-db
<dispatcher> <dispatcher>
<planet-app> "planet" add-responder <planet-app> "planet" add-responder

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

@ -2,36 +2,30 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor</t:title> <t:comment>
<t:atom title="Planet Factor - Atom" href="feed.xml" /> <t:atom title="Planet Factor - Atom" href="feed.xml" />
</t:comment>
<t:style include="resource:extra/webapps/planet/planet.css" /> <t:style include="resource:extra/webapps/planet/planet.css" />
<table width="100%" cellpadding="10"> <div class="navbar">
<tr> <t:a href="list">Front Page</t:a>
<td> <t:view component="postings" /> </td> | <t:a href="feed.xml">Atom Feed</t:a>
<td valign="top" width="25%" class="infobox"> | <t:a href="admin">Admin</t:a>
<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>
<h2>Blogroll</h2> <t:comment>
<t:if code="http.server.auth.login:allow-edit-profile?">
| <t:a href="edit-profile">Edit Profile</t:a>
</t:if>
<t:summary component="blogroll" /> <t:form action="logout" class="inline">
| <button type="submit" class="link-button link">Logout</button>
</t:form>
</t:comment>
</div>
Admin: <t:a href="edit-blog">Add Blog</t:a> <h1><t:write-title /></h1>
|
<t:a href="update">Update</t:a> <t:call-next-template />
</td>
</tr>
</table>
</t:chloe> </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>

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>

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

@ -10,22 +10,6 @@
color: #000000; color: #000000;
} }
.link-button {
padding: 0px;
background: none;
border: none;
}
.navbar {
background-color: #eeeeee;
padding: 5px;
border: 1px solid #ccc;
}
.inline {
display: inline;
}
pre { pre {
font-size: 75%; font-size: 75%;
} }

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

@ -1,12 +1,14 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! 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 db db.types db.tuples
http.server.components http.server.components.farkup http.server.components http.server.components.farkup
http.server.forms http.server.templating.chloe http.server.forms http.server.templating.chloe
http.server.boilerplate http.server.crud http.server.auth http.server.boilerplate http.server.crud http.server.auth
http.server.actions http.server.db http.server.actions http.server.db
http.server ; http.server.auth.login
http.server
webapps.factor-website ;
IN: webapps.todo IN: webapps.todo
TUPLE: todo uid id priority summary description ; TUPLE: todo uid id priority summary description ;
@ -71,41 +73,12 @@ TUPLE: todo-responder < dispatcher ;
"todo" todo-template >>template "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-app> ( -- responder )
<todo-responder> <todo-responder> <protected> <factor-boilerplate> ;
<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 ( -- ) : init-todo ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
test-db [ test-db [
init-todo-table init-todo-table
init-users-table
init-sessions-table
] with-db ] with-db
<dispatcher> <dispatcher>

8
extra/windows/windows.factor
View File

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

2
vm/ffi_test.c
View File

@ -253,7 +253,7 @@ double ffi_test_36(struct test_struct_12 x)
static int global_var; static int global_var;
void ffi_test_36_point_5(void) void int_ffi_test_36_point_5(void)
{ {
printf("int_ffi_test_36_point_5\n"); printf("int_ffi_test_36_point_5\n");
global_var = 0; global_var = 0;