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

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

db4
Aaron Schaefer 2008-02-09 22:40:50 -05:00
parent 9c2218a1c4 bf2efa3ecc
commit 8275ae01a7
94 changed files with 1576 additions and 1302 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Makefile
View File

@ -123,7 +123,15 @@ solaris-x86-32:
solaris-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
winnt-x86-32:
freetype6.dll:
wget http://factorcode.org/dlls/freetype6.dll
chmod 755 freetype6.dll
zlib1.dll:
wget http://factorcode.org/dlls/zlib1.dll
chmod 755 zlib1.dll
winnt-x86-32: freetype6.dll zlib1.dll
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:

5
core/alien/c-types/c-types.factor
View File

@ -7,6 +7,11 @@ math.parser cpu.architecture alien alien.accessors quotations
system compiler.units ;
IN: alien.c-types
DEFER: <int>
DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
boxer prep unboxer
getter setter

712
core/compiler/test/alien.factor → core/alien/compiler/compiler-tests.factor
View File

@ -1,356 +1,356 @@
IN: temporary
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 ;
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 data-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
data-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 data-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 data-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 code-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
! 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
data-gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] string-out
] unit-test
: callback-5
"void" { } "cdecl" [ data-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
IN: temporary
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 ;
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 data-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
data-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 data-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 data-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 code-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
! 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
data-gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] string-out
] unit-test
: callback-5
"void" { } "cdecl" [ data-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

28
core/compiler/compiler-tests.factor Normal file → Executable file
View File

@ -1,21 +1,7 @@
USING: io.files tools.test sequences namespaces kernel
compiler.units ;
{
"templates-early"
"simple"
"intrinsics"
"float"
"generic"
"ifte"
"templates"
"optimizer"
"redefine"
"stack-trace"
"alien"
"curry"
"tuples"
}
[ "resource:core/compiler/test/" swap ".factor" 3append ] map
[ run-test ] map
[ failures get push-all ] each
IN: temporary
USING: tools.browser tools.test kernel sequences vocabs ;
"compiler.test" child-vocabs empty? [
"compiler.test" load-children
"compiler.test" test
] when

0
core/compiler/test/curry.factor → core/compiler/test/curry/curry-tests.factor
View File

0
core/compiler/test/curry/curry.factor Normal file
View File

0
core/compiler/test/float.factor → core/compiler/test/float/float-tests.factor
View File

0
core/compiler/test/float/float.factor Normal file
View File

30
core/compiler/test/generic.factor
View File

@ -1,30 +0,0 @@
IN: temporary
USING: compiler generic tools.test math kernel words arrays
sequences quotations ;
GENERIC: single-combination-test
M: object single-combination-test drop ;
M: f single-combination-test nip ;
M: array single-combination-test drop ;
M: integer single-combination-test drop ;
[ 2 3 ] [ 2 3 t single-combination-test ] unit-test
[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
[ 2 f ] [ 2 3 f single-combination-test ] unit-test
DEFER: single-combination-test-2
: single-combination-test-4
dup [ single-combination-test-2 ] when ;
: single-combination-test-3
drop 3 ;
GENERIC: single-combination-test-2
M: object single-combination-test-2 single-combination-test-3 ;
M: f single-combination-test-2 single-combination-test-4 ;
[ 3 ] [ t single-combination-test-2 ] unit-test
[ 3 ] [ 3 single-combination-test-2 ] unit-test
[ f ] [ f single-combination-test-2 ] unit-test

131
core/compiler/test/ifte.factor
View File

@ -1,131 +0,0 @@
IN: temporary
USING: alien strings compiler tools.test math kernel words
math.private combinators ;
: dummy-if-1 t [ ] [ ] if ;
[ ] [ dummy-if-1 ] unit-test
: dummy-if-2 f [ ] [ ] if ;
[ ] [ dummy-if-2 ] unit-test
: dummy-if-3 t [ 1 ] [ 2 ] if ;
[ 1 ] [ dummy-if-3 ] unit-test
: dummy-if-4 f [ 1 ] [ 2 ] if ;
[ 2 ] [ dummy-if-4 ] unit-test
: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
[ 1 ] [ dummy-if-5 ] unit-test
: dummy-if-6
dup 1 fixnum<= [
drop 1
] [
1 fixnum- dup 1 fixnum- fixnum+
] if ;
[ 17 ] [ 10 dummy-if-6 ] unit-test
: dead-code-rec
t [
3.2
] [
dead-code-rec
] if ;
[ 3.2 ] [ dead-code-rec ] unit-test
: one-rec [ f one-rec ] [ "hi" ] if ;
[ "hi" ] [ t one-rec ] unit-test
: after-if-test
t [ ] [ ] if 5 ;
[ 5 ] [ after-if-test ] unit-test
DEFER: countdown-b
: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ;
: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ;
[ ] [ 10 countdown-b ] unit-test
: dummy-when-1 t [ ] when ;
[ ] [ dummy-when-1 ] unit-test
: dummy-when-2 f [ ] when ;
[ ] [ dummy-when-2 ] unit-test
: dummy-when-3 dup [ dup fixnum* ] when ;
[ 16 ] [ 4 dummy-when-3 ] unit-test
[ f ] [ f dummy-when-3 ] unit-test
: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
[ f t ] [ t f dummy-when-4 ] unit-test
: dummy-when-5 f [ dup fixnum* ] when ;
[ f ] [ f dummy-when-5 ] unit-test
: dummy-unless-1 t [ ] unless ;
[ ] [ dummy-unless-1 ] unit-test
: dummy-unless-2 f [ ] unless ;
[ ] [ dummy-unless-2 ] unit-test
: dummy-unless-3 dup [ drop 3 ] unless ;
[ 3 ] [ f dummy-unless-3 ] unit-test
[ 4 ] [ 4 dummy-unless-3 ] unit-test
! Test cond expansion
[ "even" ] [
[
2 {
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond
] compile-call
] unit-test
[ "odd" ] [
[
3 {
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond
] compile-call
] unit-test
[ "neither" ] [
[
3 {
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
{ [ t ] [ drop "neither" ] }
} cond
] compile-call
] unit-test
[ 3 ] [
[
3 {
{ [ dup fixnum? ] [ ] }
{ [ t ] [ drop t ] }
} cond
] compile-call
] unit-test

0
core/compiler/test/intrinsics.factor → core/compiler/test/intrinsics/intrinsics-tests.factor
View File

0
core/compiler/test/intrinsics/intrinsics.factor Normal file
View File

0
core/compiler/test/redefine.factor → core/compiler/test/redefine/redefine-tests.factor
View File

0
core/compiler/test/redefine/redefine.factor Normal file
View File

71
core/compiler/test/simple.factor
View File

@ -1,71 +0,0 @@
USING: compiler tools.test kernel kernel.private
combinators.private ;
IN: temporary
! Test empty word
[ ] [ [ ] compile-call ] unit-test
! Test literals
[ 1 ] [ [ 1 ] compile-call ] unit-test
[ 31 ] [ [ 31 ] compile-call ] unit-test
[ 255 ] [ [ 255 ] compile-call ] unit-test
[ -1 ] [ [ -1 ] compile-call ] unit-test
[ 65536 ] [ [ 65536 ] compile-call ] unit-test
[ -65536 ] [ [ -65536 ] compile-call ] unit-test
[ "hey" ] [ [ "hey" ] compile-call ] unit-test
! Calls
: no-op ;
[ ] [ [ no-op ] compile-call ] unit-test
[ 3 ] [ [ no-op 3 ] compile-call ] unit-test
[ 3 ] [ [ 3 no-op ] compile-call ] unit-test
: bar 4 ;
[ 4 ] [ [ bar no-op ] compile-call ] unit-test
[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
[ ] [ no-op ] unit-test
! Conditionals
[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline
[ ] [ t [ recursive ] compile-call ] unit-test
[ ] [ t recursive ] unit-test
! Make sure error reporting works
[ [ dup ] compile-call ] must-fail
[ [ drop ] compile-call ] must-fail
! Regression
[ ] [ [ callstack ] compile-call drop ] unit-test
! Regression
: empty ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test

227
core/compiler/test/simple/simple-tests.factor Executable file
View File

@ -0,0 +1,227 @@
USING: compiler tools.test kernel kernel.private
combinators.private math.private math combinators strings
alien arrays ;
IN: temporary
! Test empty word
[ ] [ [ ] compile-call ] unit-test
! Test literals
[ 1 ] [ [ 1 ] compile-call ] unit-test
[ 31 ] [ [ 31 ] compile-call ] unit-test
[ 255 ] [ [ 255 ] compile-call ] unit-test
[ -1 ] [ [ -1 ] compile-call ] unit-test
[ 65536 ] [ [ 65536 ] compile-call ] unit-test
[ -65536 ] [ [ -65536 ] compile-call ] unit-test
[ "hey" ] [ [ "hey" ] compile-call ] unit-test
! Calls
: no-op ;
[ ] [ [ no-op ] compile-call ] unit-test
[ 3 ] [ [ no-op 3 ] compile-call ] unit-test
[ 3 ] [ [ 3 no-op ] compile-call ] unit-test
: bar 4 ;
[ 4 ] [ [ bar no-op ] compile-call ] unit-test
[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
[ ] [ no-op ] unit-test
! Conditionals
[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline
[ ] [ t [ recursive ] compile-call ] unit-test
[ ] [ t recursive ] unit-test
! Make sure error reporting works
[ [ dup ] compile-call ] must-fail
[ [ drop ] compile-call ] must-fail
! Regression
[ ] [ [ callstack ] compile-call drop ] unit-test
! Regression
: empty ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
: dummy-if-1 t [ ] [ ] if ;
[ ] [ dummy-if-1 ] unit-test
: dummy-if-2 f [ ] [ ] if ;
[ ] [ dummy-if-2 ] unit-test
: dummy-if-3 t [ 1 ] [ 2 ] if ;
[ 1 ] [ dummy-if-3 ] unit-test
: dummy-if-4 f [ 1 ] [ 2 ] if ;
[ 2 ] [ dummy-if-4 ] unit-test
: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
[ 1 ] [ dummy-if-5 ] unit-test
: dummy-if-6
dup 1 fixnum<= [
drop 1
] [
1 fixnum- dup 1 fixnum- fixnum+
] if ;
[ 17 ] [ 10 dummy-if-6 ] unit-test
: dead-code-rec
t [
3.2
] [
dead-code-rec
] if ;
[ 3.2 ] [ dead-code-rec ] unit-test
: one-rec [ f one-rec ] [ "hi" ] if ;
[ "hi" ] [ t one-rec ] unit-test
: after-if-test
t [ ] [ ] if 5 ;
[ 5 ] [ after-if-test ] unit-test
DEFER: countdown-b
: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ;
: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ;
[ ] [ 10 countdown-b ] unit-test
: dummy-when-1 t [ ] when ;
[ ] [ dummy-when-1 ] unit-test
: dummy-when-2 f [ ] when ;
[ ] [ dummy-when-2 ] unit-test
: dummy-when-3 dup [ dup fixnum* ] when ;
[ 16 ] [ 4 dummy-when-3 ] unit-test
[ f ] [ f dummy-when-3 ] unit-test
: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
[ f t ] [ t f dummy-when-4 ] unit-test
: dummy-when-5 f [ dup fixnum* ] when ;
[ f ] [ f dummy-when-5 ] unit-test
: dummy-unless-1 t [ ] unless ;
[ ] [ dummy-unless-1 ] unit-test
: dummy-unless-2 f [ ] unless ;
[ ] [ dummy-unless-2 ] unit-test
: dummy-unless-3 dup [ drop 3 ] unless ;
[ 3 ] [ f dummy-unless-3 ] unit-test
[ 4 ] [ 4 dummy-unless-3 ] unit-test
! Test cond expansion
[ "even" ] [
[
2 {
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond
] compile-call
] unit-test
[ "odd" ] [
[
3 {
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond
] compile-call
] unit-test
[ "neither" ] [
[
3 {
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
{ [ t ] [ drop "neither" ] }
} cond
] compile-call
] unit-test
[ 3 ] [
[
3 {
{ [ dup fixnum? ] [ ] }
{ [ t ] [ drop t ] }
} cond
] compile-call
] unit-test
GENERIC: single-combination-test
M: object single-combination-test drop ;
M: f single-combination-test nip ;
M: array single-combination-test drop ;
M: integer single-combination-test drop ;
[ 2 3 ] [ 2 3 t single-combination-test ] unit-test
[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
[ 2 f ] [ 2 3 f single-combination-test ] unit-test
DEFER: single-combination-test-2
: single-combination-test-4
dup [ single-combination-test-2 ] when ;
: single-combination-test-3
drop 3 ;
GENERIC: single-combination-test-2
M: object single-combination-test-2 single-combination-test-3 ;
M: f single-combination-test-2 single-combination-test-4 ;
[ 3 ] [ t single-combination-test-2 ] unit-test
[ 3 ] [ 3 single-combination-test-2 ] unit-test
[ f ] [ f single-combination-test-2 ] unit-test

0
core/compiler/test/simple/simple.factor Normal file
View File

0
core/compiler/test/stack-trace.factor → core/compiler/test/stack-trace/stack-trace-tests.factor
View File

0
core/compiler/test/stack-trace/stack-trace.factor Normal file
View File

0
core/compiler/test/templates-early.factor → core/compiler/test/templates-early/templates-early-tests.factor
View File

0
core/compiler/test/templates-early/templates-early.factor Normal file
View File

0
core/compiler/test/templates.factor → core/compiler/test/templates/templates-tests.factor
View File

0
core/compiler/test/templates/templates.factor Normal file
View File

0
core/compiler/test/tuples.factor → core/compiler/test/tuples/tuples-tests.factor
View File

0
core/compiler/test/tuples/tuples.factor Normal file
View File

2
core/continuations/continuations-docs.factor
View File

@ -169,7 +169,7 @@ HELP: rethrow
HELP: throw-restarts
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." }
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
{ $examples
"Try invoking one of the two restarts which are offered after the below code throws an error:"
{ $code

10
core/inference/class/class-tests.factor
View File

@ -263,3 +263,13 @@ cell-bits 32 = [
\ fixnum-shift inlined?
] unit-test
] when
[ t ] [
[ B{ 1 0 } *short 0 number= ]
\ number= inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 = ]
\ number= inlined?
] unit-test

17
core/inference/known-words/known-words.factor
View File

@ -414,64 +414,81 @@ t over set-effect-terminated?
\ <displaced-alien> make-flushable
\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-cell make-flushable
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-cell make-flushable
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-8 make-flushable
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-8 make-flushable
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-4 make-flushable
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-4 make-flushable
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-signed-2 make-flushable
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-2 make-flushable
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-signed-1 make-flushable
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-1 make-flushable
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
\ alien-float make-flushable
\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
\ alien-double make-flushable
\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
\ alien-cell make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
\ alien>char-string make-flushable
\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
\ string>char-alien make-flushable
\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
\ alien>u16-string make-flushable
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
\ string>u16-alien make-flushable
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
\ alien-address make-flushable

4
core/inference/transforms/transforms.factor
View File

@ -54,7 +54,9 @@ M: pair (bitfield-quot) ( spec -- quot )
\ bitfield [ bitfield-quot ] 1 define-transform
\ flags [ flags [ ] curry ] 1 define-transform
\ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform
! Tuple operations
: [get-slots] ( slots -- quot )

11
core/math/bitfields/bitfields-tests.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: math math.bitfields tools.test kernel ;
USING: math math.bitfields tools.test kernel words ;
IN: temporary
[ 0 ] [ { } bitfield ] unit-test
@ -6,3 +6,12 @@ IN: temporary
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
: a 1 ; inline
: b 2 ; inline
: foo { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
[ t ] [ \ foo compiled? ] unit-test

605
core/compiler/test/optimizer.factor → core/optimizer/optimizer-tests.factor
View File

@ -1,302 +1,303 @@
USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations growable ;
IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
] unit-test
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
] unit-test
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ integer string array reversed sbuf
slice vector quotation ]
sort-classes min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
sort-classes min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
sort-classes min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
sort-classes min-class
] unit-test
[ reversed ] [
\ reversed
[ integer reversed slice ]
sort-classes min-class
] unit-test
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ t ] [ \ xyz compiled? ] unit-test
! Test predicate inlining
: pred-test-1
dup fixnum? [
dup integer? [ "integer" ] [ "nope" ] if
] [
"not a fixnum"
] if ;
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
TUPLE: pred-test ;
: pred-test-2
dup tuple? [
dup pred-test? [ "pred-test" ] [ "nope" ] if
] [
"not a tuple"
] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
: pred-test-3
dup pred-test? [
dup tuple? [ "pred-test" ] [ "nope" ] if
] [
"not a tuple"
] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
: inline-test
"nom" = ;
[ t ] [ "nom" inline-test ] unit-test
[ f ] [ "shayin" inline-test ] unit-test
[ f ] [ 3 inline-test ] unit-test
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
[ ] [ 1000000 fixnum-declarations . ] unit-test
! regression
: literal-not-branch 0 not [ ] [ ] if ;
[ ] [ literal-not-branch ] unit-test
! regression
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
: bad-kill-2 bad-kill-1 drop ;
[ 3 ] [ t bad-kill-2 ] unit-test
! regression
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
: the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test
! regression
: (double-recursion) ( start end -- )
< [
6 1 (double-recursion)
3 2 (double-recursion)
] when ; inline
: double-recursion 0 2 (double-recursion) ;
[ ] [ double-recursion ] unit-test
! regression
: double-label-1 ( a b c -- d )
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
: double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ;
[ 0 ] [ 10 double-label-2 ] unit-test
! regression
GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test
[ breakage ] must-fail
! regression
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
: test-2 ( -- ) 5 test-1 ;
[ f ] [ f test-2 ] unit-test
: branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
: branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ;
[ 10 ] [ branch-fold-regression-1 ] unit-test
! another regression
: constant-branch-fold-0 "hey" ; foldable
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression
: foo f ;
: bar foo 4 4 = and ;
[ f ] [ bar ] unit-test
! ensure identities are working in some form
[ t ] [
[ { number } declare 0 + ] dataflow optimize
[ #push? ] node-exists? not
] unit-test
! compiling <tuple> with a non-literal class failed
: <tuple>-regression <tuple> ;
[ t ] [ \ <tuple>-regression compiled? ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
M: integer foozul ;
M: slice foozul ;
[ reversed ] [ reversed \ foozul specific-method ] unit-test
! regression
: constant-fold-2 f ; foldable
: constant-fold-3 4 ; foldable
[ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test
: constant-fold-4 f ; foldable
: constant-fold-5 f ; foldable
[ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-call
] unit-test
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
[ f ] [ 5 [ dup < ] compile-call ] unit-test
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
[ f ] [ 5 [ dup > ] compile-call ] unit-test
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
[ t ] [ 5 [ dup = ] compile-call ] unit-test
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
GENERIC: detect-number ( obj -- obj )
M: number detect-number ;
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
! Regression
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
! Regression
USE: sorting
USE: sorting.private
: old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [
slice-from
] [
[ midpoint swap call ] 3keep roll dup zero?
[ drop dup slice-from swap midpoint@ + ]
[ partition old-binsearch ] if
] if ; inline
[ 10 ] [
10 20 >vector <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
! Regression
TUPLE: silly-tuple a b ;
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
T{ silly-tuple f 1 2 }
[
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
] compile-call
] unit-test
! Regression
: empty-compound ;
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
: construct-empty-bug construct-empty ;
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics
: should-inline? method method-word flat-length 10 <= ;
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations growable ;
IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
] unit-test
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
] unit-test
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ integer string array reversed sbuf
slice vector quotation ]
sort-classes min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
sort-classes min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
sort-classes min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
sort-classes min-class
] unit-test
[ reversed ] [
\ reversed
[ integer reversed slice ]
sort-classes min-class
] unit-test
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ t ] [ \ xyz compiled? ] unit-test
! Test predicate inlining
: pred-test-1
dup fixnum? [
dup integer? [ "integer" ] [ "nope" ] if
] [
"not a fixnum"
] if ;
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
TUPLE: pred-test ;
: pred-test-2
dup tuple? [
dup pred-test? [ "pred-test" ] [ "nope" ] if
] [
"not a tuple"
] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
: pred-test-3
dup pred-test? [
dup tuple? [ "pred-test" ] [ "nope" ] if
] [
"not a tuple"
] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
: inline-test
"nom" = ;
[ t ] [ "nom" inline-test ] unit-test
[ f ] [ "shayin" inline-test ] unit-test
[ f ] [ 3 inline-test ] unit-test
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
[ ] [ 1000000 fixnum-declarations . ] unit-test
! regression
: literal-not-branch 0 not [ ] [ ] if ;
[ ] [ literal-not-branch ] unit-test
! regression
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
: bad-kill-2 bad-kill-1 drop ;
[ 3 ] [ t bad-kill-2 ] unit-test
! regression
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
: the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test
! regression
: (double-recursion) ( start end -- )
< [
6 1 (double-recursion)
3 2 (double-recursion)
] when ; inline
: double-recursion 0 2 (double-recursion) ;
[ ] [ double-recursion ] unit-test
! regression
: double-label-1 ( a b c -- d )
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
: double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ;
[ 0 ] [ 10 double-label-2 ] unit-test
! regression
GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test
[ breakage ] must-fail
! regression
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
: test-2 ( -- ) 5 test-1 ;
[ f ] [ f test-2 ] unit-test
: branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
: branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ;
[ 10 ] [ branch-fold-regression-1 ] unit-test
! another regression
: constant-branch-fold-0 "hey" ; foldable
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression
: foo f ;
: bar foo 4 4 = and ;
[ f ] [ bar ] unit-test
! ensure identities are working in some form
[ t ] [
[ { number } declare 0 + ] dataflow optimize
[ #push? ] node-exists? not
] unit-test
! compiling <tuple> with a non-literal class failed
: <tuple>-regression <tuple> ;
[ t ] [ \ <tuple>-regression compiled? ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
M: integer foozul ;
M: slice foozul ;
[ reversed ] [ reversed \ foozul specific-method ] unit-test
! regression
: constant-fold-2 f ; foldable
: constant-fold-3 4 ; foldable
[ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test
: constant-fold-4 f ; foldable
: constant-fold-5 f ; foldable
[ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-call
] unit-test
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
[ f ] [ 5 [ dup < ] compile-call ] unit-test
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
[ f ] [ 5 [ dup > ] compile-call ] unit-test
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
[ t ] [ 5 [ dup = ] compile-call ] unit-test
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
GENERIC: detect-number ( obj -- obj )
M: number detect-number ;
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
! Regression
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
! Regression
USE: sorting
USE: sorting.private
: old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [
slice-from
] [
[ midpoint swap call ] 3keep roll dup zero?
[ drop dup slice-from swap midpoint@ + ]
[ partition old-binsearch ] if
] if ; inline
[ 10 ] [
10 20 >vector <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
! Regression
TUPLE: silly-tuple a b ;
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
T{ silly-tuple f 1 2 }
[
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
] compile-call
] unit-test
! Regression
: empty-compound ;
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
: construct-empty-bug construct-empty ;
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics
: should-inline? method method-word flat-length 10 <= ;
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test

2
core/parser/parser.factor
View File

@ -18,7 +18,7 @@ TUPLE: lexer text line line-text line-length column ;
: <lexer> ( text -- lexer )
0 { set-lexer-text set-lexer-line } lexer construct
dup lexer-text empty? [ dup next-line ] unless ;
dup next-line ;
: location ( -- loc )
file get lexer get lexer-line 2dup and

1
extra/asn1/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

2
extra/benchmark/bootstrap2/bootstrap2.factor
View File

@ -9,6 +9,6 @@ IN: benchmark.bootstrap2
"-i=" my-boot-image-name append ,
"-output-image=foo.image" ,
"-no-user-init" ,
] { } make run-process drop ;
] { } make try-process ;
MAIN: bootstrap-benchmark

4
extra/bootstrap/image/download/download.factor
View File

@ -23,3 +23,7 @@ bootstrap.image sequences io ;
"Boot image up to date" print
drop
] if ;
: download-my-image ( -- ) my-arch download-image ;
MAIN: download-my-image

3
extra/bootstrap/image/upload/upload.factor Normal file → Executable file
View File

@ -16,8 +16,7 @@ bootstrap.image sequences io namespaces io.launcher math ;
: upload-images ( -- )
[
"scp" , boot-image-names % "checksums.txt" , destination ,
] { } make run-process
wait-for-process zero? [ "Upload failed" throw ] unless ;
] { } make try-process ;
: new-images ( -- )
make-images compute-checksums upload-images ;

29
extra/builder/builder.factor Executable file → Normal file
View File

@ -1,8 +1,8 @@
USING: kernel io io.files io.launcher hashtables tools.deploy.backend
USING: kernel io io.files io.launcher hashtables
system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client
combinators ;
combinators bootstrap.image bootstrap.image.download ;
IN: builder
@ -59,8 +59,12 @@ VAR: stamp
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status
: build ( -- )
"running" build-status set-global
datestamp >stamp
"/builds/factor" cd
@ -70,7 +74,6 @@ VAR: stamp
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
! "http://dharmatech.onigirihouse.com/factor.git"
"master"
}
run-process process-status
@ -82,6 +85,11 @@ VAR: stamp
]
if
{
"git" "pull" "--no-summary"
"http://dharmatech.onigirihouse.com/factor.git" "master"
} run-process drop
"/builds/" stamp> append make-directory
"/builds/" stamp> append cd
@ -94,6 +102,8 @@ VAR: stamp
{ "make" "clean" } run-process drop
! "vm" build-status set-global
`{
{ +arguments+ { "make" ,[ target ] } }
{ +stdout+ "../compile-log" }
@ -107,14 +117,17 @@ VAR: stamp
"builder: vm compile" throw
] if
[ "http://factorcode.org/images/latest/" boot-image-name append download ]
[ my-arch download-image ]
[ ]
[ "builder: image download" email-string ]
recover
cleanup
! "bootstrap" build-status set-global
`{
{ +arguments+ {
,[ factor-binary ]
,[ "-i=" boot-image-name append ]
,[ "-i=" my-boot-image-name append ]
"-no-user-init"
} }
{ +stdout+ "../boot-log" }
@ -128,6 +141,8 @@ VAR: stamp
"builder: bootstrap" throw
] if
! "test" build-status set-global
`{ ,[ factor-binary ] "-run=builder.test" } run-process drop
"../load-everything-log" exists?
@ -138,6 +153,8 @@ VAR: stamp
[ "builder: failing tests" "../failing-tests" email-file ]
when
! "ready" build-status set-global
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

68
extra/builder/server/server.factor Normal file
View File

@ -0,0 +1,68 @@
USING: kernel continuations namespaces threads match bake concurrency builder ;
IN: builder.server
! : build-server ( -- )
! receive
! {
! {
! "start"
! [ [ build ] in-thread ]
! }
! {
! { ?from ?tag "status" }
! [ `{ ?tag ,[ build-status get ] } ?from send ]
! }
! }
! match-cond
! build-server ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : build-server ( -- )
! receive
! {
! {
! "start"
! [
! [ [ build ] [ drop ] recover "idle" build-status set-global ] in-thread
! ]
! }
! {
! { ?from ?tag "status" }
! [ `{ ?tag ,[ build-status get ] } ?from send ]
! }
! }
! match-cond
! build-server ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: build-server ( -- )
receive
{
{
"start"
[
build-status get "idle" =
build-status get f =
or
[
[ [ build ] [ drop ] recover "idle" build-status set-global ]
in-thread
]
when
]
}
{
{ ?from ?tag "status" }
[ `{ ?tag ,[ build-status get ] } ?from send ]
}
}
match-cond
build-server ;

24
extra/builder/test/test.factor
View File

@ -8,27 +8,17 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader
IN: builder.test
: do-load ( -- )
[
[ load-everything ]
[ require-all-error-vocabs "../load-everything-log" log-object ]
recover
]
"../load-everything-time" log-runtime ;
[ try-everything ] "../load-everything-time" log-runtime
dup empty?
[ drop ]
[ "../load-everything-log" log-object ]
if ;
: do-tests ( -- )
"" child-vocabs
[ vocab-source-loaded? ] subset
[ vocab-tests-path ] map
[ dup [ ?resource-path exists? ] when ] subset
[ dup run-test ] { } map>assoc
[ second empty? not ] subset
run-all-tests keys
dup empty?
[ drop ]
[
"../failing-tests" <file-writer>
[ [ nl failures. ] assoc-each ]
with-stream
]
[ "../failing-tests" log-object ]
if ;
: do-all ( -- ) do-load do-tests ;

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

@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers"
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends"
{ $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":"
{ $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" }
"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':"
"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':"
{ $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" }
"Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ;

14
extra/concurrency/concurrency-tests.factor
View File

@ -112,9 +112,9 @@ SYMBOL: value
! The following unit test blocks forever if the
! exception does not propogate. Uncomment when
! this is fixed (via a timeout).
! [
! [ "this should propogate" throw ] future ?future
! ] must-fail
[
[ "this should propogate" throw ] future ?future
] must-fail
[ ] [
[ "this should not propogate" throw ] future drop
@ -127,4 +127,10 @@ SYMBOL: value
[ f ] [
[ "testing unregistering on error" throw ] spawn
100 sleep process-pid get-process
] unit-test
] unit-test
! Race condition with futures
[ 3 3 ] [
[ 3 ] future
dup ?future swap ?future
] unit-test

30
extra/concurrency/concurrency.factor
View File

@ -264,19 +264,31 @@ PRIVATE>
#! so the server continuation gets its new self updated.
self swap call ;
: future ( quot -- future )
#! Spawn a process to call the quotation and immediately return
#! a 'future' on the stack. The future can later be queried with
#! ?future. If the quotation has completed the result will be returned.
#! If not, the process will block until the quotation completes.
#! 'quot' must have stack effect ( -- X ).
[ self send ] compose spawn ;
TUPLE: future value processes ;
: ?future ( future -- result )
: notify-future ( value future -- )
tuck set-future-value
dup future-processes [ schedule-thread ] each
f swap set-future-processes ;
: future ( quot -- future )
#! Spawn a process to call the quotation and immediately return.
\ future construct-empty [
[
>r [ t 2array ] compose [ f 2array ] recover r>
notify-future
] 2curry spawn drop
] keep ;
: ?future ( future -- result )
#! Block the process until the future has completed and then
#! place the result on the stack. Return the result
#! immediately if the future has completed.
process-mailbox mailbox-get ;
dup future-value [
first2 [ throw ] unless
] [
dup [ future-processes push stop ] curry callcc0 ?future
] ?if ;
: parallel-map ( seq quot -- newseq )
#! Spawn a process to apply quot to each element of seq,

1
extra/concurrency/distributed/tags.txt
View File

@ -1 +1,2 @@
enterprise
extensions

2
extra/cpu/8080/emulator/tags.txt
View File

@ -1 +1 @@
emulator
emulators

2
extra/cpu/8080/tags.txt
View File

@ -1 +1 @@
emulator
emulators

1
extra/cryptlib/tags.txt
View File

@ -1 +1,2 @@
enterprise
bindings

1
extra/db/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
extra/db/summary.txt Normal file
View File

@ -0,0 +1 @@
Relational database abstraction layer

1
extra/db/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

2
extra/editors/emacs/emacs.factor
View File

@ -8,7 +8,7 @@ IN: editors.emacs
"--no-wait" ,
"+" swap number>string append ,
,
] { } make run-process drop ;
] { } make try-process ;
: emacs ( word -- )
where first2 emacsclient ;

2
extra/editors/textmate/textmate.factor
View File

@ -5,6 +5,6 @@ IN: editors.textmate
: textmate-location ( file line -- )
[ "mate" , "-a" , "-l" , number>string , , ] { } make
run-process drop ;
try-process ;
[ textmate-location ] edit-hook set-global

1
extra/furnace/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

11
extra/help/help.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io kernel namespaces parser prettyprint sequences
words assocs definitions generic quotations effects
slots continuations tuples debugger combinators
vocabs help.stylesheet help.topics help.crossref help.markup
sorting classes ;
words assocs definitions generic quotations effects slots
continuations tuples debugger combinators vocabs help.stylesheet
help.topics help.crossref help.markup sorting classes
vocabs.loader ;
IN: help
GENERIC: word-help* ( word -- content )
@ -96,6 +96,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
article-content print-content nl ;
: about ( vocab -- )
dup require
dup vocab [ ] [
"No such vocabulary: " swap append throw
] ?if

1
extra/http/server/tags.txt
View File

@ -1,2 +1,3 @@
enterprise
network
web

10
extra/io/launcher/launcher-docs.factor
View File

@ -116,6 +116,15 @@ HELP: run-detached
"The output value can be passed to " { $link wait-for-process } " to get an exit code."
} ;
HELP: process-failed
{ $values { "code" "an exit status" } }
{ $description "Throws a " { $link process-failed } " error." }
{ $error-description "Thrown by " { $link try-process } " if the process exited with a non-zero status code." } ;
HELP: try-process
{ $values { "desc" "a launch descriptor" } }
{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ;
HELP: kill-process
{ $values { "process" process } }
{ $description "Kills a running process. Does nothing if the process has already exited." } ;
@ -175,6 +184,7 @@ $nl
"The following words are used to launch processes:"
{ $subsection run-process }
{ $subsection run-detached }
{ $subsection try-process }
"Stopping processes:"
{ $subsection kill-process }
"Redirecting standard input and output to a pipe:"

11
extra/io/launcher/launcher.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend system kernel namespaces strings hashtables
sequences assocs combinators vocabs.loader init threads
continuations ;
continuations math ;
IN: io.launcher
! Non-blocking process exit notification facility
@ -84,6 +84,15 @@ HOOK: run-process* io-backend ( desc -- handle )
: run-detached ( desc -- process )
>descriptor H{ { +detached+ t } } union run-process ;
TUPLE: process-failed code ;
: process-failed ( code -- * )
\ process-failed construct-boa throw ;
: try-process ( desc -- )
run-process wait-for-process dup zero?
[ drop ] [ process-failed ] if ;
HOOK: kill-process* io-backend ( handle -- )
: kill-process ( process -- )

2
extra/io/unix/select/select.factor Normal file → Executable file
View File

@ -9,8 +9,6 @@ TUPLE: select-mx read-fdset write-fdset ;
! Factor's bit-arrays are an array of bytes, OS X expects
! FD_SET to be an array of cells, so we have to account for
! byte order differences on big endian platforms
: little-endian? 1 <int> *char 1 = ; foldable
: munge ( i -- i' )
little-endian? [ BIN: 11000 bitxor ] unless ; inline

1
extra/ldap/tags.txt
View File

@ -1 +1,2 @@
enterprise
network

31
extra/logging/analysis/analysis-docs.factor Normal file
View File

@ -0,0 +1,31 @@
USING: help.markup help.syntax assocs logging math ;
IN: logging.analysis
HELP: analyze-entries
{ $values { "entries" "a sequence of log entries" } { "word-names" "a sequence of strings" } { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } }
{ $description "Analyzes log entries:"
{ $list
{ "Errors (entries with level " { $link ERROR } " or " { $link CRITICAL } ") are collected into the " { $snippet "errors" } " sequence." }
{ "All logging words are tallied into " { $snippet "word-histogram" } " - for example, this can tell you about HTTP server hit counts." }
{ "All words listed in " { $snippet "word-names" } " have their messages tallied into " { $snippet "message-histogram" } " - for example, this can tell you about popular URLs on an HTTP server." }
}
} ;
HELP: analysis.
{ $values { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } }
{ $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ;
HELP: analyze-log
{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } }
{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
ARTICLE: "logging.analysis" "Log analysis"
"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logger.insomniac" } " vocabulary to e-mail daily reports."
$nl
"Print log file summary:"
{ $subsection analyze-log }
"Factors:"
{ $subsection analyze-entries }
{ $subsection analysis. } ;
ABOUT: "logging.analysis"

3
extra/logging/analysis/analysis.factor
View File

@ -11,6 +11,7 @@ SYMBOL: message-histogram
: analyze-entry ( entry -- )
dup second ERROR eq? [ dup errors get push ] when
dup second CRITICAL eq? [ dup errors get push ] when
1 over third word-histogram get at+
dup third word-names get member? [
1 over 1 tail message-histogram get at+
@ -65,5 +66,5 @@ SYMBOL: message-histogram
"==== ERRORS:" print nl
errors. ;
: log-analysis ( lines word-names -- )
: analyze-log ( lines word-names -- )
>r parse-log r> analyze-entries analysis. ;

1
extra/logging/analysis/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

44
extra/logging/insomniac/insomniac-docs.factor Normal file
View File

@ -0,0 +1,44 @@
USING: help.markup help.syntax assocs strings logging
logging.analysis smtp ;
IN: logging.insomniac
HELP: insomniac-smtp-host
{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ;
HELP: insomniac-smtp-port
{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ;
HELP: insomniac-sender
{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
HELP: insomniac-recipients
{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
HELP: ?analyze-log
{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } }
{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." }
{ $see-also analyze-log } ;
HELP: email-log-report
{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } }
{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
HELP: schedule-insomniac
{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
$nl
"Required configuration parameters:"
{ $subsection insomniac-sender }
{ $subsection insomniac-recipients }
"Optional configuration parameters:"
{ $subsection insomniac-smtp-host }
{ $subsection insomniac-smtp-port }
"E-mailing a one-off report:"
{ $subsection email-log-report }
"E-mailing reports and rotating logs on a daily basis:"
{ $subsection schedule-insomniac } ;
ABOUT: "logging.insomniac"

23
extra/logging/insomniac/insomniac.factor
View File

@ -1,19 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: logging.analysis logging.server logging smtp io.sockets
kernel io.files io.streams.string namespaces raptor.cron ;
kernel io.files io.streams.string namespaces raptor.cron assocs ;
IN: logging.insomniac
SYMBOL: insomniac-config
SYMBOL: insomniac-smtp-host
SYMBOL: insomniac-smtp-port
SYMBOL: insomniac-sender
SYMBOL: insomniac-recipients
: ?log-analysis ( service word-names -- string/f )
: ?analyze-log ( service word-names -- string/f )
>r log-path 1 log# dup exists? [
file-lines r> [ log-analysis ] string-out
file-lines r> [ analyze-log ] string-out
] [
r> 2drop f
] if ;
@ -31,7 +29,7 @@ SYMBOL: insomniac-recipients
: (email-log-report) ( service word-names -- )
[
over >r
?log-analysis dup [
?analyze-log dup [
r> email-subject
insomniac-recipients get
insomniac-sender get
@ -39,11 +37,12 @@ SYMBOL: insomniac-recipients
] [ r> 2drop ] if
] with-insomniac-smtp ;
\ (email-log-report) NOTICE add-error-logging
: email-log-report ( service word-names -- )
(email-log-report) ;
"logging.insomniac" [ (email-log-report) ] with-logging ;
\ email-log-report NOTICE add-error-logging
: schedule-insomniac ( service word-names -- )
{ 25 } { 6 } f f f <when> -rot
[ email-log-report ] 2curry schedule ;
: schedule-insomniac ( alist -- )
{ 25 } { 6 } f f f <when> -rot [
[ email-log-report ] assoc-each rotate-logs
] 2curry schedule ;

1
extra/logging/insomniac/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

130
extra/logging/logging-docs.factor Normal file
View File

@ -0,0 +1,130 @@
IN: logging
USING: help.markup help.syntax assocs math calendar
logging.server strings words quotations ;
HELP: DEBUG
{ $description "Log level for debug messages." } ;
HELP: NOTICE
{ $description "Log level for ordinary messages." } ;
HELP: ERROR
{ $description "Log level for error messages." } ;
HELP: CRITICAL
{ $description "Log level for critical errors which require immediate attention." } ;
ARTICLE: "logging.levels" "Log levels"
"Several log levels are supported, from lowest to highest:"
{ $subsection DEBUG }
{ $subsection NOTICE }
{ $subsection ERROR }
{ $subsection CRITICAL } ;
ARTICLE: "logging.files" "Log files"
"Each application that wishes to use logging must choose a log service name; the following combinator should wrap the top level of the application:"
{ $subsection with-logging }
"Log messages are written to " { $snippet "log-root/service/1.log" } ", where"
{ $list
{ { $snippet "log-root" } " is the Factor source directory by default, but can be overriden with the " { $link log-root } " variable" }
{ { $snippet "service" } " is the service name" }
}
"You can get the log path for a service:"
{ $subsection log-path }
{ $subsection log# }
"New log entries are always sent to " { $snippet "1.log" } " but " { $link "logging.rotation" } " moves " { $snippet "1.log" } " to " { $snippet "2.log" } ", " { $snippet "2.log" } " to " { $snippet "3.log" } ", and so on." ;
HELP: log-message
{ $values { "msg" string } { "word" word } { "level" "a log level" } }
{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
HELP: add-logging
{ $values { "word" word } }
{ $description "Causes the word to log a message every time it is called." } ;
HELP: add-input-logging
{ $values { "word" word } }
{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-output-logging
{ $values { "word" word } }
{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-error-logging
{ $values { "word" word } }
{ $description "Causes the word to log its input values and any errors it throws."
$nl
"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller."
$nl
"If called from a logging context, its input values are logged, and if it throws an error, the error is logged and the word returns normally. Any inputs are popped from the stack and " { $link f } " is pushed in place of each output." } ;
HELP: log-error
{ $values { "error" "an error" } { "word" word } }
{ $description "Logs an error." } ;
HELP: log-critical
{ $values { "critical" "an critical" } { "word" word } }
{ $description "Logs a critical error." } ;
HELP: LOG:
{ $syntax "LOG: name level" }
{ $values { "name" "a new word name" } { "level" "a log level" } }
{ $description "Creates a word with stack effect " { $snippet "( object -- )" } " which logs its input and does nothing else." } ;
ARTICLE: "logging.messages" "Logging messages"
"Logging messages explicitly:"
{ $subsection log-message }
{ $subsection log-error }
{ $subsection log-critical }
"A utility for defining words which just log and do nothing else:"
{ $subsection POSTPONE: LOG: }
"Annotating words to log; this uses the " { $link "tools.annotations" } " feature:"
{ $subsection add-input-logging }
{ $subsection add-output-logging }
{ $subsection add-error-logging } ;
HELP: rotate-logs
{ $description "Rotates all logs. The highest numbered log file in each log directory is deleted, and each file is renamed so that its number increments by one. Subsequent logging calls will create a new #1 log file. This keeps log files from getting too large and makes them easier to search." } ;
HELP: close-logs
{ $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ;
HELP: with-logging
{ $values { "service" "a log service name" } { "quot" quotation } }
{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ;
ARTICLE: "logging.rotation" "Log rotation"
"Log files should be rotated periodically to prevent unbounded growth."
{ $subsection rotate-logs }
{ $subsection close-logs }
"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ;
ARTICLE: "logging.server" "Log implementation"
"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion."
$nl
"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:"
{ $subsection (log-message) }
"The " { $link rotate-logs } " word sends a message to the server which results in the server executing an internal word:"
{ $subsection (rotate-logs) }
"The " { $link close-logs } " word sends a message to the server which results in the server executing an internal word:"
{ $subsection (close-logs) } ;
ARTICLE: "logging" "Logging framework"
"The " { $vocab-link "logging" } " vocabulary implements a comprehensive logging framework suitable for server-side production applications."
{ $subsection "logging.files" }
{ $subsection "logging.levels" }
{ $subsection "logging.messages" }
{ $subsection "logging.rotation" }
{ $subsection "logging.parser" }
{ $subsection "logging.analysis" }
{ $subsection "logging.insomniac" }
{ $subsection "logging.server" } ;
ABOUT: "logging"
! A workaround for circular dependency prohibition
USING: threads vocabs.loader ;
[
yield
"logging.insomniac" require
] in-thread

26
extra/logging/logging.factor
View File

@ -39,8 +39,8 @@ SYMBOL: log-service
: rotate-logs ( -- )
{ } "rotate-logs" send-to-log-server ;
: close-log-files ( -- )
{ } "close-log-files" send-to-log-server ;
: close-logs ( -- )
{ } "close-logs" send-to-log-server ;
: with-logging ( service quot -- )
log-service swap with-variable ; inline
@ -56,7 +56,7 @@ SYMBOL: log-service
[ dup first string? ]
} && nip ;
: inputs>message ( obj -- inputs>message )
: stack>message ( obj -- inputs>message )
dup one-string? [ first ] [
H{
{ string-limit f }
@ -77,9 +77,9 @@ PRIVATE>
: add-logging ( word level -- )
[ call-logging-quot ] (define-logging) ;
: log-inputs ( n word level -- )
: log-stack ( n word level -- )
log-service get [
>r >r [ ndup ] keep narray inputs>message
>r >r [ ndup ] keep narray stack>message
r> r> log-message
] [
3drop
@ -88,11 +88,19 @@ PRIVATE>
: input# stack-effect effect-in length ;
: input-logging-quot ( quot word level -- quot' )
over input# -rot [ log-inputs ] 3curry swap compose ;
over input# -rot [ log-stack ] 3curry swap compose ;
: add-input-logging ( word level -- )
[ input-logging-quot ] (define-logging) ;
: output# stack-effect effect-out length ;
: output-logging-quot ( quot word level -- quot' )
over output# -rot [ log-stack ] 3curry compose ;
: add-output-logging ( word level -- )
[ output-logging-quot ] (define-logging) ;
: (log-error) ( object word level -- )
log-service get [
>r >r [ print-error ] string-out r> r> log-message
@ -100,9 +108,9 @@ PRIVATE>
2drop rethrow
] if ;
: log-error ( object word -- ) ERROR (log-error) ;
: log-error ( error word -- ) ERROR (log-error) ;
: log-critical ( object word -- ) CRITICAL (log-error) ;
: log-critical ( error word -- ) CRITICAL (log-error) ;
: error-logging-quot ( quot word -- quot' )
dup stack-effect effect-in length
@ -118,5 +126,5 @@ PRIVATE>
CREATE
dup reset-generic
dup scan-word
[ >r >r 1array inputs>message r> r> log-message ] 2curry
[ >r >r 1array stack>message r> r> log-message ] 2curry
define ; parsing

21
extra/logging/parser/parser-docs.factor Normal file
View File

@ -0,0 +1,21 @@
IN: logging.parser
USING: help.markup help.syntax assocs logging math calendar ;
HELP: parse-log
{ $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } }
{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where"
{ $list
{ { $snippet "timestamp" } " is a " { $link timestamp } }
{ { $snippet "level" } " is a log level; see " { $link "logger.levels" } }
{ { $snippet "word-name" } " is a string" }
{ { $snippet "message" } " is a string" }
}
} ;
ARTICLE: "logging.parser" "Log file parser"
"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs."
$nl
"There is only one primary entry point:"
{ $subsection parse-log } ;
ABOUT: "logging.parser"

10
extra/logging/parser/parser.factor
View File

@ -2,13 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators memoize kernel sequences
logging arrays words strings vectors io io.files
namespaces combinators combinators.lib logging.server ;
namespaces combinators combinators.lib logging.server
calendar ;
IN: logging.parser
: string-of satisfy <!*> [ >string ] <@ ;
SYMBOL: multiline
: 'date'
[ CHAR: ] eq? not ] string-of
multiline-header token [ drop multiline ] <@
[ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|>
"[" "]" surrounded-by ;
: 'log-level'
@ -41,7 +45,7 @@ MEMO: 'log-line' ( -- parser )
first malformed eq? ;
: multiline? ( line -- ? )
first first CHAR: - = ;
first multiline eq? ;
: malformed-line
"Warning: malformed log line:" print

1
extra/logging/parser/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

4
extra/logging/server/server-docs.factor Normal file
View File

@ -0,0 +1,4 @@
IN: logging.server
USING: help.syntax ;
ABOUT: "logging.server"

16
extra/logging/server/server.factor
View File

@ -25,9 +25,11 @@ SYMBOL: log-files
: log-stream ( service -- stream )
log-files get [ open-log-stream ] cache ;
: multiline-header 20 CHAR: - <string> ; foldable
: (write-message) ( msg word-name level multi? -- )
[
"[" write 20 CHAR: - <string> write "] " write
"[" write multiline-header write "] " write
] [
"[" write now (timestamp>rfc3339) "] " write
] if
@ -50,11 +52,11 @@ SYMBOL: log-files
: try-dispose ( stream -- )
[ dispose ] curry [ error. ] recover ;
: close-log-file ( service -- )
: close-log ( service -- )
log-files get delete-at*
[ try-dispose ] [ drop ] if ;
: (close-log-files) ( -- )
: (close-logs) ( -- )
log-files get
dup values [ try-dispose ] each
clear-assoc ;
@ -73,13 +75,13 @@ SYMBOL: log-files
[ 1- log# ] 2keep log# ?rename-file ;
: rotate-log ( service -- )
dup close-log-file
dup close-log
log-path
dup delete-oldest
keep-logs 1 [a,b] [ advance-log ] with each ;
: (rotate-logs) ( -- )
(close-log-files)
(close-logs)
log-root directory [ drop rotate-log ] assoc-each ;
: log-server-loop
@ -87,9 +89,9 @@ SYMBOL: log-files
receive unclip {
{ "log-message" [ (log-message) ] }
{ "rotate-logs" [ drop (rotate-logs) ] }
{ "close-log-files" [ drop (close-log-files) ] }
{ "close-logs" [ drop (close-logs) ] }
} case
] [ error. (close-log-files) ] recover
] [ error. (close-logs) ] recover
log-server-loop ;
: log-server ( -- )

1
extra/logging/server/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

2
extra/logging/summary.txt
View File

@ -1 +1 @@
AOP Logging framework with support for log rotation and machine-readable logs
Logging framework with support for log rotation and machine-readable logs

1
extra/logging/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

12
extra/multi-methods/multi-methods-tests.factor
View File

@ -84,3 +84,15 @@ METHOD: hook-test { hashtable number } assoc-size ;
[ fixnum ] [ 3 hook-test ] unit-test
5.0 some-var set
[ 0 ] [ H{ } hook-test ] unit-test
MIXIN: busted
TUPLE: busted-1 ;
TUPLE: busted-2 ; INSTANCE: busted-2 busted
TUPLE: busted-3 ;
GENERIC: busted-sort
METHOD: busted-sort { busted-1 busted-2 } ;
METHOD: busted-sort { busted-2 busted-3 } ;
METHOD: busted-sort { busted busted } ;

117
extra/multi-methods/multi-methods.factor
View File

@ -3,12 +3,12 @@
USING: kernel math sequences vectors classes combinators
arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
debugger io compiler.units ;
debugger io compiler.units kernel.private effects ;
IN: multi-methods
TUPLE: method loc def ;
GENERIC: generic-prologue ( combination -- quot )
: <method> { set-method-def } \ method construct ;
GENERIC: method-prologue ( combination -- quot )
: maximal-element ( seq quot -- n elt )
dupd [
@ -25,6 +25,7 @@ TUPLE: method loc def ;
[
{
{ [ 2dup eq? ] [ 0 ] }
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
{ [ 2dup class< ] [ -1 ] }
{ [ 2dup swap class< ] [ 1 ] }
{ [ t ] [ 0 ] }
@ -54,8 +55,37 @@ TUPLE: method loc def ;
: methods ( word -- alist )
"multi-methods" word-prop >alist ;
: method-defs ( methods -- methods' )
[ method-def ] assoc-map ;
: make-method-def ( quot classes generic -- quot )
[
swap [ declare ] curry %
"multi-combination" word-prop method-prologue %
%
] [ ] make ;
TUPLE: method word def classes generic loc ;
PREDICATE: word method-body "multi-method" word-prop >boolean ;
M: method-body stack-effect
"multi-method" word-prop method-generic stack-effect ;
: method-word-name ( classes generic -- string )
[
word-name %
"-(" % [ "," % ] [ word-name % ] interleave ")" %
] "" make ;
: <method-word> ( quot classes generic -- word )
#! We xref here because the "multi-method" word-prop isn't
#! set yet so crossref? yields f.
[ make-method-def ] 2keep
method-word-name f <word>
dup rot define
dup xref ;
: <method> ( quot classes generic -- method )
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "multi-method" set-word-prop ;
TUPLE: no-method arguments generic ;
@ -68,8 +98,11 @@ TUPLE: no-method arguments generic ;
] if ;
: multi-dispatch-quot ( methods generic -- quot )
>r
[ [ >r multi-predicate r> ] assoc-map ] keep argument-count
>r [
[
>r multi-predicate r> method-word 1quotation
] assoc-map
] keep argument-count
r> [ no-method ] 2curry
swap reverse alist>quot ;
@ -98,36 +131,36 @@ M: no-method error.
methods congruify-methods sorted-methods keys
[ niceify-method ] map stack. ;
GENERIC: perform-combination ( word combination -- quot )
TUPLE: standard-combination ;
: standard-combination ( methods generic -- quot )
>r congruify-methods sorted-methods r> multi-dispatch-quot ;
M: standard-combination method-prologue drop [ ] ;
M: standard-combination perform-combination
drop [ methods method-defs ] keep standard-combination ;
M: standard-combination generic-prologue drop [ ] ;
: make-generic ( generic -- quot )
dup "multi-combination" word-prop generic-prologue swap
[ methods congruify-methods sorted-methods ] keep
multi-dispatch-quot append ;
TUPLE: hook-combination var ;
M: hook-combination perform-combination
hook-combination-var [ get ] curry swap methods
[ method-defs [ [ drop ] swap append ] assoc-map ] keep
standard-combination append ;
M: hook-combination method-prologue
drop [ drop ] ;
: make-generic ( word -- )
dup dup "multi-combination" word-prop perform-combination
define ;
M: hook-combination generic-prologue
hook-combination-var [ get ] curry ;
: init-methods ( word -- )
dup "multi-methods" word-prop
H{ } assoc-like
"multi-methods" set-word-prop ;
: update-generic ( word -- )
dup make-generic define ;
: define-generic ( word combination -- )
dupd "multi-combination" set-word-prop
dup init-methods
make-generic ;
over "multi-combination" word-prop over = [
2drop
] [
dupd "multi-combination" set-word-prop
dup H{ } clone "multi-methods" set-word-prop
update-generic
] if ;
: define-standard-generic ( word -- )
T{ standard-combination } define-generic ;
@ -146,29 +179,31 @@ M: hook-combination perform-combination
: with-methods ( word quot -- )
over >r >r "multi-methods" word-prop
r> call r> make-generic ; inline
r> call r> update-generic ; inline
: add-method ( method classes word -- )
: define-method ( quot classes generic -- )
>r [ bootstrap-word ] map r>
[ <method> ] 2keep
[ set-at ] with-methods ;
: forget-method ( classes word -- )
: forget-method ( classes generic -- )
[ delete-at ] with-methods ;
: parse-method ( -- method classes word method-spec )
parse-definition 2 cut
over >r
>r first2 swap r> <method> -rot
r> first2 swap add* >array ;
: method>spec ( method -- spec )
dup method-classes swap method-generic add* ;
: parse-method ( -- quot classes generic )
parse-definition dup 2 tail over second rot first ;
: METHOD:
location
>r parse-method >r add-method r> r>
>r parse-method [ define-method ] 2keep add* r>
remember-definition ; parsing
! For compatibility
: M:
scan-word 1array scan-word parse-definition <method>
-rot add-method ; parsing
scan-word 1array scan-word parse-definition
-rot define-method ; parsing
! Definition protocol. We qualify core generics here
USE: qualified
@ -202,7 +237,7 @@ PREDICATE: array method-spec
unclip generic? >r [ class? ] all? r> and ;
syntax:M: method-spec where
dup unclip method method-loc [ ] [ second where ] ?if ;
dup unclip method [ method-loc ] [ second where ] ?if ;
syntax:M: method-spec set-where
unclip method set-method-loc ;
@ -211,11 +246,11 @@ syntax:M: method-spec definer
drop \ METHOD: \ ; ;
syntax:M: method-spec definition
unclip method method-def ;
unclip method dup [ method-def ] when ;
syntax:M: method-spec synopsis*
dup definer.
unclip pprint* pprint* ;
syntax:M: method-spec forget*
unclip [ delete-at ] with-methods ;
unclip forget-method ;

1
extra/openssl/tags.txt
View File

@ -1,2 +1,3 @@
enterprise
network
bindings

1
extra/smtp/tags.txt
View File

@ -1 +1,2 @@
enterprise
network

5
extra/tools/deploy/backend/backend.factor
View File

@ -22,7 +22,10 @@ IN: tools.deploy.backend
+stdout+ +stderr+ set
] H{ } make-assoc <process-stream>
dup duplex-stream-out dispose
copy-lines ;
dup copy-lines
process-stream-process wait-for-process zero? [
"Deployment failed" throw
] unless ;
: make-boot-image ( -- )
#! If stage1 image doesn't exist, create one.

4
extra/tools/deploy/macosx/macosx.factor
View File

@ -8,10 +8,10 @@ QUALIFIED: unix
IN: tools.deploy.macosx
: touch ( path -- )
{ "touch" } swap add run-process drop ;
{ "touch" } swap add try-process ;
: rm ( path -- )
{ "rm" "-rf" } swap add run-process drop ;
{ "rm" "-rf" } swap add try-process ;
: bundle-dir ( -- dir )
vm parent-directory parent-directory ;

19
extra/tools/test/test.factor
View File

@ -61,9 +61,14 @@ M: expected-error summary
dup vocab-source-loaded? [
vocab-tests-path dup [
dup ?resource-path exists? [
[ "temporary" forget-vocab ] with-compilation-unit
[
"temporary" forget-vocab
] with-compilation-unit
dup run-file
[ dup forget-source ] with-compilation-unit
[
dup forget-source
"temporary" forget-vocab
] with-compilation-unit
] when
] when
] when drop ;
@ -81,7 +86,7 @@ M: expected-error summary
"Traceback" swap third write-object ;
: test-failures. ( assoc -- )
dup [
[
nl
dup empty? [
drop
@ -90,15 +95,15 @@ M: expected-error summary
"==== FAILING TESTS:" print
[
swap vocab-heading.
[ nl failure. nl ] each
[ failure. nl ] each
] assoc-each
] if
] [
drop "==== NOTHING TO TEST" print
] if ;
"==== NOTHING TO TEST" print
] if* ;
: run-tests ( prefix -- failures )
child-vocabs dup empty? [ f ] [
child-vocabs dup empty? [ drop f ] [
[ dup run-test ] { } map>assoc
[ second empty? not ] subset
] if ;

1
extra/xml-rpc/tags.txt
View File

@ -1 +1,2 @@
enterprise
web

1
extra/xml/tags.txt
View File

@ -1 +1,2 @@
enterprise
web

28
misc/factor.el
View File

@ -131,10 +131,30 @@
(comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
(comint-send-string "*factor*" " run-file\n"))
;; (defun factor-send-region (start end)
;; (interactive "r")
;; (comint-send-region "*factor*" start end)
;; (comint-send-string "*factor*" "\n"))
(defun factor-send-string (str)
(let ((n (length (split-string str "\n"))))
(save-excursion
(set-buffer "*factor*")
(goto-char (point-max))
(if (> n 1) (newline))
(insert str)
(comint-send-input))))
(defun factor-send-region (start end)
(interactive "r")
(comint-send-region "*factor*" start end)
(comint-send-string "*factor*" "\n"))
(let ((str (buffer-substring start end))
(n (count-lines start end)))
(save-excursion
(set-buffer "*factor*")
(goto-char (point-max))
(if (> n 1) (newline))
(insert str)
(comint-send-input))))
(defun factor-see ()
(interactive)
@ -153,6 +173,10 @@
(comint-send-string "*factor*" "\\ ")
(comint-send-string "*factor*" (thing-at-point 'sexp))
(comint-send-string "*factor*" " edit\n"))
(defun factor-clear ()
(interactive)
(factor-send-string "clear"))
(defun factor-comment-line ()
(interactive)

28
misc/integration/deploy-size-test.factor
View File

@ -1,28 +0,0 @@
USING: tools.deploy sequences io.files io.launcher io
kernel concurrency prettyprint ;
"." resource-path cd
"deploy-log" make-directory
{
"automata.ui"
"boids.ui"
"bunny"
"color-picker"
"gesture-logger"
"golden-section"
"hello-world"
"hello-ui"
"lsys.ui"
"maze"
"nehe"
"tetris"
"catalyst-talk"
} [
dup
"deploy-log/" over append <file-writer>
[ deploy ] with-stream
dup file-length 1024 /f
2array
] parallel-map .

24
misc/integration/macosx-deploy.factor
View File

@ -1,24 +0,0 @@
USING: tools.deploy.app sequences io.files io.launcher io
kernel concurrency ;
"." resource-path cd
"deploy-log" make-directory
{
"automata.ui"
"boids.ui"
"bunny"
"color-picker"
"gesture-logger"
"golden-section"
"hello-ui"
"lsys.ui"
"maze"
"nehe"
"tetris"
"catalyst-talk"
} [
"deploy-log/" over append <file-writer>
[ deploy.app ] with-stream
] parallel-each

43
misc/integration/macosx.sh
View File

@ -1,43 +0,0 @@
CPU=$1
if [ "$CPU" = "x86.32" ]; then
TARGET="macosx-x86"
elif [ "$CPU" = "ppc" ]; then
TARGET="macosx-ppc"
CPU = "macosx-ppc"
else
echo "Specify a CPU"
exit 1
fi
EXE=factor
bash misc/integration/test.sh \
$EXE \
$CPU \
$TARGET \
no \
no \
no \
"X11=1" \
"-ui-backend=x11" \
"-x11" || exit 1
echo "Testing deployment"
$EXE "misc/integration/x11-deploy.factor" -run=none </dev/null
EXE=Factor.app/Contents/MacOS/factor
bash misc/integration/test.sh \
$EXE \
$CPU \
$TARGET \
yes \
yes \
yes \
"" \
"" \
""
echo "Testing deployment"
$EXE "misc/integration/macosx-deploy.factor" -run=none </dev/null

93
misc/integration/test.sh
View File

@ -1,93 +0,0 @@
EXE=$1
CPU=$2
TARGET=$3
LOAD_P=$4
TEST_P=$5
BENCHMARK_P=$6
MAKE_FLAGS=$7
BOOT_FLAGS=$8
VARIANT=$9
PREFIX=misc/integration/results-$CPU$VARIANT
mkdir -p $PREFIX
VM_LOG=$PREFIX/vm.log
BOOT_LOG=$PREFIX/boot.log
LOAD_LOG=$PREFIX/load.log
TEST_LOG=$PREFIX/test.log
BENCHMARK_LOG=$PREFIX/benchmark.log
echo "Output files:"
echo "VM compilation: $VM_LOG"
echo "Bootstrap: $BOOT_LOG"
echo "Load everything: $LOAD_LOG"
echo "Unit tests: $TEST_LOG"
echo "Benchmarks: $BENCHMARK_LOG"
IMAGE=factor.image
echo
echo
echo
echo "Compiling VM"
${MAKE-make} clean $TARGET $MAKE_FLAGS >$VM_LOG </dev/null
if [ "$?" -ne 0 ]; then
echo "VM compile failed"
exit 1
fi
echo "Bootstrap"
rm -f $IMAGE
$EXE -i=boot.$CPU.image \
-no-user-init \
$BOOT_FLAGS \
-output-image=$IMAGE >$BOOT_LOG </dev/null
if [ ! -e "factor.image" ]; then
echo "Bootstrap failed"
exit 1
fi
# Load all modules; run tests
if [ "$LOAD_P" = "yes" ]; then
echo "Testing loading of all modules"
echo "USE: tools.browser load-everything USE: memory save USE: system 123 exit" \
>/tmp/factor-$$
$EXE -i=$IMAGE \
/tmp/factor-$$ \
-run=none \
>$LOAD_LOG </dev/null
if [ "$?" -ne 123 ]; then
echo "Load-everything failed"
exit 1
fi
# Check for parser notes
grep "automatically using" $LOAD_LOG
if [ "$?" -eq 0 ]; then
echo "Missing USE: declarations"
# exit 1
fi
fi
# Run unit tests
if [ "$TEST_P" = "yes" ]; then
echo "Running all unit tests"
$EXE -i=$IMAGE "-e=test-all" -run=none >$TEST_LOG </dev/null
fi
# Run benchmarks
if [ "$BENCHMARK_P" = "yes" ]; then
echo "Running all benchmarks"
$EXE -i=$IMAGE "-run=benchmark" >$BENCHMARK_LOG </dev/null
fi

10
misc/integration/unix-arm.sh
View File

@ -1,10 +0,0 @@
bash misc/integration/test.sh \
./factor \
ppc \
$1-arm \
no \
yes \
yes \
"" \
"" \
""

10
misc/integration/unix-ppc.sh
View File

@ -1,10 +0,0 @@
bash misc/integration/test.sh \
./factor \
ppc \
$1-ppc \
yes \
yes \
yes \
"" \
"" \
""

21
misc/integration/unix-x86.32.sh
View File

@ -1,21 +0,0 @@
bash misc/integration/test.sh \
./factor \
x86.32 \
$1-x86 \
yes \
yes \
yes \
"" \
"" \
"" || exit 1
bash misc/integration/test.sh \
./factor \
x86.32 \
$1-x86 \
yes \
yes \
yes \
"" \
"-no-sse2" \
"-no-sse2"

10
misc/integration/unix-x86.64.sh
View File

@ -1,10 +0,0 @@
bash misc/integration/test.sh \
./factor \
x86.64 \
$1-amd64 \
yes \
yes \
yes \
"" \
"" \
""

8
misc/integration/x11-deploy.factor
View File

@ -1,8 +0,0 @@
USING: tools.deploy sequences io.files io kernel ;
"." resource-path cd
"mkdir deploy-log" run-process
"factory" "deploy-log/" over append
<file-writer> [ deploy ] with-stream

35
vm/debug.c
View File

@ -38,6 +38,9 @@ void print_array(F_ARRAY* array, CELL nesting)
CELL length = array_capacity(array);
CELL i;
if(length > 10)
length = 10;
for(i = 0; i < length; i++)
{
printf(" ");
@ -201,7 +204,7 @@ void dump_objects(F_FIXNUM type)
if(type == -1 || type_of(obj) == type)
{
printf("%lx ",obj);
print_nested_obj(obj,3);
print_nested_obj(obj,1);
printf("\n");
}
}
@ -210,6 +213,36 @@ void dump_objects(F_FIXNUM type)
gc_off = false;
}
CELL obj;
CELL look_for;
void find_references_step(CELL *scan)
{
if(look_for == *scan)
{
printf("%lx ",obj);
print_nested_obj(obj,1);
printf("\n");
}
}
void find_references(CELL look_for_)
{
look_for = look_for_;
begin_scan();
CELL obj_;
while((obj_ = next_object()) != F)
{
obj = obj_;
do_slots(obj_,find_references_step);
}
/* end scan */
gc_off = false;
}
void factorbug(void)
{
reset_stdio();