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

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 int_ffi_test_36_point_5 ( ) ;
[ ] [ int_ffi_test_36_point_5 ] unit-test
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test

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>

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

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

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

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

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 )

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

@ -39,13 +39,16 @@ DEFER: http-request
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
redirects inc
redirects get max-redirects < [
header>> "location" swap at
dup "http://" head? [
dup absolute-url? [
absolute-redirect
] [
relative-redirect
@ -74,8 +77,8 @@ PRIVATE>
] with-variable ;
: read-chunks ( -- )
readln ";" split1 drop hex>
dup { f 0 } member? [ drop ] [ read % read-chunks ] if ;
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" = [
@ -116,8 +119,12 @@ M: download-failed error.
: 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 ;

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" ] [ "/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
@ -162,7 +165,7 @@ io.encodings.ascii ;
"localhost" 1237 <inet> ascii <client> [
"GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush
readln drop
read-crlf drop
read-header
] with-stream "location" swap at "/" head?
] unit-test

42
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 io.sockets 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 )
@ -224,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 ;
@ -372,7 +388,7 @@ body ;
>>code ;
: read-response-message
readln >>message ;
read-crlf >>message ;
: read-response-header
read-header >>header

10
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 ;
[
"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,7 +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
@ -40,7 +43,8 @@ xxx=4
;
[ "/blahXXXX" ] [
action-request-test-2 [ read-request ] with-string-reader
action-request-test-2 lf>crlf
[ read-request ] with-string-reader
request set
"/blah"
"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 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 -- )
[

29
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 ] }

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 ;

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

@ -160,23 +160,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

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

@ -153,6 +153,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 +190,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 ;

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

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 ]

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>
<t:write-title />
<t:write-atom />
<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;
}
</t:style>
<t:write-style />
</head>
<body>
<h1><t:a href="planet"><t:write-title /></t:a></h1>
<t:call-next-template />
</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">
<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>

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

@ -1,7 +1,7 @@
! 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
calendar alarms logging concurrency.combinators namespaces
db.types db.tuples db
rss xml.writer
http.server
@ -10,11 +10,22 @@ http.server.forms
http.server.actions
http.server.boilerplate
http.server.templating.chloe
http.server.components ;
http.server.components
http.server.auth.login
webapps.factor-website ;
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 ;
M: blog link-title name>> ;
M: blog link-href www-url>> ;
blog "BLOGS"
{
{ "id" "ID" INTEGER +native-id+ }
@ -29,8 +40,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>
@ -44,7 +55,7 @@ blog "BLOGS"
"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
@ -60,15 +71,27 @@ blog "BLOGS"
: <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> ] |
@ -90,7 +113,7 @@ TUPLE: planet-factor < dispatcher postings ;
feed new
"[ planet-factor ]" >>title
"http://planet.factorcode.org" >>link
planet postings>> 30 safe-head >>entries ;
planet postings>> 16 safe-head >>entries ;
:: <feed-action> ( planet -- action )
<action>
@ -117,7 +140,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 safe-head
>>postings drop
] with-logging ;
:: <update-action> ( planet -- action )
@ -127,16 +151,11 @@ 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
! Administrative CRUD
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
] ;
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> >>default
dup <feed-action> "feed.xml" add-responder
dup <update-action> "update" 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 ;
: <planet-app> ( -- responder )
<planet-factor> <factor-boilerplate> ;
: start-update-task ( planet -- )
[ update-cached-postings ] curry 10 minutes every drop ;
: init-planet ( -- )
! test-db [
! init-blog-table
! init-users-table
! init-sessions-table
! ] with-db
test-db [
init-blog-table
] with-db
<dispatcher>
<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:title>Planet Factor</t:title>
<t:comment>
<t:atom title="Planet Factor - Atom" href="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="list">Front Page</t:a>
| <t:a href="feed.xml">Atom Feed</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:a href="admin">Admin</t:a>
<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>
|
<t:a href="update">Update</t:a>
</td>
</tr>
</table>
<h1><t:write-title /></h1>
<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>

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

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

@ -1,12 +1,14 @@
! 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 ;
http.server.auth.login
http.server
webapps.factor-website ;
IN: webapps.todo
TUPLE: todo uid id priority summary description ;
@ -71,41 +73,12 @@ TUPLE: todo-responder < dispatcher ;
"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> ;
<todo-responder> <protected> <factor-boilerplate> ;
: 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>

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

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