Merge branch 'master' of git://factorcode.org/git/factor
commit
43225d2aef
10
Makefile
10
Makefile
|
@ -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:
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
@ -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." ;
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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 +1,2 @@
|
|||
enterprise
|
||||
extensions
|
||||
|
|
|
@ -1 +1 @@
|
|||
emulator
|
||||
emulators
|
||||
|
|
|
@ -1 +1 @@
|
|||
emulator
|
||||
emulators
|
||||
|
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
bindings
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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,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,2 +1,3 @@
|
|||
enterprise
|
||||
network
|
||||
web
|
||||
|
|
|
@ -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:"
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 +1,2 @@
|
|||
enterprise
|
||||
network
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 } ;
|
||||
|
|
|
@ -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,2 +1,3 @@
|
|||
enterprise
|
||||
network
|
||||
bindings
|
||||
|
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
network
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 +1,2 @@
|
|||
enterprise
|
||||
web
|
||||
|
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
web
|
||||
|
|
|
@ -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 .
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -1,10 +0,0 @@
|
|||
bash misc/integration/test.sh \
|
||||
./factor \
|
||||
ppc \
|
||||
$1-arm \
|
||||
no \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"" \
|
||||
""
|
|
@ -1,10 +0,0 @@
|
|||
bash misc/integration/test.sh \
|
||||
./factor \
|
||||
ppc \
|
||||
$1-ppc \
|
||||
yes \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"" \
|
||||
""
|
|
@ -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"
|
|
@ -1,10 +0,0 @@
|
|||
bash misc/integration/test.sh \
|
||||
./factor \
|
||||
x86.64 \
|
||||
$1-amd64 \
|
||||
yes \
|
||||
yes \
|
||||
yes \
|
||||
"" \
|
||||
"" \
|
||||
""
|
|
@ -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
35
vm/debug.c
|
@ -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();
|
||||
|
|
Loading…
Reference in New Issue