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

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

db4
Doug Coleman 2008-02-09 08:46:28 -06:00
parent 934d53219a 3a22b3aaa0
commit 43225d2aef
73 changed files with 1258 additions and 1261 deletions

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

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

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

7
extra/concurrency/concurrency.factor
View File

@ -264,12 +264,19 @@ PRIVATE>
#! so the server continuation gets its new self updated.
self swap call ;
TUPLE: future status value processes ;
: 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 ).
[
[
t
] compose
] spawn drop
[ self send ] compose spawn ;
: ?future ( future -- result )

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

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

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

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

4
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

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/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();