Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: extra/sequences/lib/lib.factordb4
commit
6109335290
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
|
|
@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
|
|||
inference.state inference.backend inference.dataflow system
|
||||
math.parser classes alien.arrays alien.c-types alien.structs
|
||||
alien.syntax cpu.architecture alien inspector quotations assocs
|
||||
kernel.private threads continuations.private libc combinators ;
|
||||
kernel.private threads continuations.private libc combinators
|
||||
compiler.errors continuations ;
|
||||
IN: alien.compiler
|
||||
|
||||
! Common protocol for alien-invoke/alien-callback/alien-indirect
|
||||
|
@ -207,9 +208,21 @@ M: alien-invoke-error summary
|
|||
swap alien-node-parameters parameter-sizes drop
|
||||
number>string 3append ;
|
||||
|
||||
TUPLE: no-such-library name ;
|
||||
|
||||
M: no-such-library summary
|
||||
drop "Library not found" ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library +linkage+ (inference-error) ;
|
||||
|
||||
: (alien-invoke-dlsym) ( node -- symbol dll )
|
||||
dup alien-invoke-function
|
||||
swap alien-invoke-library load-library ;
|
||||
swap alien-invoke-library [
|
||||
load-library
|
||||
] [
|
||||
2drop no-such-library
|
||||
] recover ;
|
||||
|
||||
TUPLE: no-such-symbol ;
|
||||
|
||||
|
@ -217,7 +230,7 @@ M: no-such-symbol summary
|
|||
drop "Symbol not found" ;
|
||||
|
||||
: no-such-symbol ( -- )
|
||||
\ no-such-symbol inference-error ;
|
||||
\ no-such-symbol +linkage+ (inference-error) ;
|
||||
|
||||
: alien-invoke-dlsym ( node -- symbol dll )
|
||||
dup (alien-invoke-dlsym) 2dup dlsym [
|
||||
|
|
|
@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts
|
|||
splitting growable classes tuples words.private
|
||||
io.binary io.files vocabs vocabs.loader source-files
|
||||
definitions debugger float-arrays quotations.private
|
||||
combinators.private combinators ;
|
||||
sequences.private combinators ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: my-arch ( -- arch )
|
||||
|
@ -136,7 +136,7 @@ SYMBOL: undefined-quot
|
|||
: here-as ( tag -- pointer ) here swap bitor ;
|
||||
|
||||
: align-here ( -- )
|
||||
here 8 mod 4 = [ 0 emit ] when ;
|
||||
here 8 mod 4 = [ heap-size drop 0 emit ] when ;
|
||||
|
||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||
|
||||
|
@ -177,6 +177,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
[ dup bignum-bits neg shift swap bignum-radix bitand ]
|
||||
[ ] unfold nip ;
|
||||
|
||||
USE: continuations
|
||||
: emit-bignum ( n -- )
|
||||
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
|
||||
dup length 1+ emit-fixnum
|
||||
|
@ -214,10 +215,6 @@ M: f '
|
|||
: 1, 1 >bignum ' 1-offset fixup ;
|
||||
: -1, -1 >bignum ' -1-offset fixup ;
|
||||
|
||||
! Beginning of the image
|
||||
|
||||
: begin-image ( -- ) emit-header t, 0, 1, -1, ;
|
||||
|
||||
! Words
|
||||
|
||||
: emit-word ( word -- )
|
||||
|
@ -385,7 +382,10 @@ M: curry '
|
|||
: fixup-header ( -- )
|
||||
heap-size data-heap-size-offset fixup ;
|
||||
|
||||
: end-image ( -- )
|
||||
: build-image ( -- image )
|
||||
800000 <vector> image set
|
||||
20000 <hashtable> objects set
|
||||
emit-header t, 0, 1, -1,
|
||||
"Serializing words..." print flush
|
||||
emit-words
|
||||
"Serializing JIT data..." print flush
|
||||
|
@ -400,7 +400,8 @@ M: curry '
|
|||
fixup-header
|
||||
"Image length: " write image get length .
|
||||
"Object cache size: " write objects get assoc-size .
|
||||
\ word global delete-at ;
|
||||
\ word global delete-at
|
||||
image get ;
|
||||
|
||||
! Image output
|
||||
|
||||
|
@ -411,28 +412,23 @@ M: curry '
|
|||
[ >le write ] curry each
|
||||
] if ;
|
||||
|
||||
: write-image ( image filename -- )
|
||||
"Writing image to " write dup write "..." print flush
|
||||
: write-image ( image -- )
|
||||
"Writing image to " write
|
||||
architecture get boot-image-name resource-path
|
||||
dup write "..." print flush
|
||||
<file-writer> [ (write-image) ] with-stream ;
|
||||
|
||||
: prepare-image ( -- )
|
||||
bootstrapping? on
|
||||
load-help? off
|
||||
800000 <vector> image set
|
||||
20000 <hashtable> objects set ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: make-image ( arch -- )
|
||||
architecture [
|
||||
prepare-image
|
||||
begin-image
|
||||
[
|
||||
architecture set
|
||||
bootstrapping? on
|
||||
load-help? off
|
||||
"resource:/core/bootstrap/stage1.factor" run-file
|
||||
end-image
|
||||
image get
|
||||
architecture get boot-image-name resource-path
|
||||
build-image
|
||||
write-image
|
||||
] with-variable ;
|
||||
] with-scope ;
|
||||
|
||||
: make-images ( -- )
|
||||
images [ make-image ] each ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math words kernel alien byte-arrays
|
||||
hashtables vectors strings sbufs arrays bit-arrays
|
||||
|
@ -8,7 +8,7 @@ BIN: 111 tag-mask set
|
|||
8 num-tags set
|
||||
3 tag-bits set
|
||||
|
||||
20 num-types set
|
||||
19 num-types set
|
||||
|
||||
H{
|
||||
{ fixnum BIN: 000 }
|
||||
|
@ -27,11 +27,10 @@ tag-numbers get H{
|
|||
{ float-array 10 }
|
||||
{ callstack 11 }
|
||||
{ string 12 }
|
||||
{ curry 13 }
|
||||
{ bit-array 13 }
|
||||
{ quotation 14 }
|
||||
{ dll 15 }
|
||||
{ alien 16 }
|
||||
{ word 17 }
|
||||
{ byte-array 18 }
|
||||
{ bit-array 19 }
|
||||
} union type-numbers set
|
||||
|
|
|
@ -295,23 +295,6 @@ define-builtin
|
|||
"float-array?" "float-arrays" create
|
||||
{ } define-builtin
|
||||
|
||||
"curry" "kernel" create
|
||||
"curry?" "kernel" create
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"obj"
|
||||
{ "curry-obj" "kernel" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"obj"
|
||||
{ "curry-quot" "kernel" }
|
||||
f
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
"callstack" "kernel" create "callstack?" "kernel" create
|
||||
{ } define-builtin
|
||||
|
||||
|
@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class
|
|||
}
|
||||
} define-tuple-class
|
||||
|
||||
"curry" "kernel" create
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"obj"
|
||||
{ "curry-obj" "kernel" }
|
||||
f
|
||||
} {
|
||||
{ "object" "kernel" }
|
||||
"quot"
|
||||
{ "curry-quot" "kernel" }
|
||||
f
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"compose" "kernel" create
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"first"
|
||||
{ "compose-first" "kernel" }
|
||||
f
|
||||
} {
|
||||
{ "object" "kernel" }
|
||||
"second"
|
||||
{ "compose-second" "kernel" }
|
||||
f
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
>r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
|
||||
>r create dup reset-word r>
|
||||
[ do-primitive ] curry [ ] like define ;
|
||||
|
||||
{
|
||||
{ "(execute)" "words.private" }
|
||||
{ "(call)" "kernel.private" }
|
||||
{ "uncurry" "kernel.private" }
|
||||
{ "bignum>fixnum" "math.private" }
|
||||
{ "float>fixnum" "math.private" }
|
||||
{ "fixnum>bignum" "math.private" }
|
||||
|
@ -622,7 +635,6 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "become" "kernel.private" }
|
||||
{ "(sleep)" "threads.private" }
|
||||
{ "<float-array>" "float-arrays" }
|
||||
{ "curry" "kernel" }
|
||||
{ "<tuple-boa>" "tuples.private" }
|
||||
{ "class-hash" "kernel.private" }
|
||||
{ "callstack>array" "kernel" }
|
||||
|
|
|
@ -38,7 +38,7 @@ vocabs.loader system ;
|
|||
|
||||
[
|
||||
"resource:core/bootstrap/stage2.factor"
|
||||
dup ?resource-path exists? [
|
||||
dup resource-exists? [
|
||||
run-file
|
||||
] [
|
||||
"Cannot find " write write "." print
|
||||
|
|
|
@ -20,7 +20,9 @@ PREDICATE: class tuple-class
|
|||
|
||||
: classes ( -- seq ) class<map get keys ;
|
||||
|
||||
: type>class ( n -- class ) builtins get nth ;
|
||||
: type>class ( n -- class ) builtins get-global nth ;
|
||||
|
||||
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
||||
|
||||
: predicate-word ( word -- predicate )
|
||||
[ word-name "?" append ] keep word-vocabulary create ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays help.markup help.syntax strings sbufs vectors
|
||||
kernel quotations generic generic.standard classes
|
||||
math assocs sequences combinators.private ;
|
||||
math assocs sequences sequences.private ;
|
||||
IN: combinators
|
||||
|
||||
ARTICLE: "combinators-quot" "Quotation construction utilities"
|
||||
|
|
|
@ -4,12 +4,6 @@ IN: combinators
|
|||
USING: arrays sequences sequences.private math.private
|
||||
kernel kernel.private math assocs quotations vectors ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: dispatch ( n array -- ) array-nth (call) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: no-cond ;
|
||||
|
||||
: no-cond ( -- * ) \ no-cond construct-empty throw ;
|
||||
|
|
|
@ -1,21 +0,0 @@
|
|||
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
|
|
@ -1,14 +1,15 @@
|
|||
IN: compiler.errors
|
||||
USING: help.markup help.syntax vocabs.loader words io
|
||||
quotations ;
|
||||
quotations compiler.errors.private ;
|
||||
|
||||
ARTICLE: "compiler-errors" "Compiler warnings and errors"
|
||||
"The compiler saves compile warnings and errors in a global variable:"
|
||||
"The compiler saves various notifications in a global variable:"
|
||||
{ $subsection compiler-errors }
|
||||
"The warnings and errors can be viewed later:"
|
||||
{ $subsection :warnings }
|
||||
"These notifications can be viewed later:"
|
||||
{ $subsection :errors }
|
||||
"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:"
|
||||
{ $subsection :warnings }
|
||||
{ $subsection :linkage }
|
||||
"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
|
||||
{ $link with-compiler-errors } ;
|
||||
|
||||
HELP: compiler-errors
|
||||
|
@ -16,7 +17,7 @@ HELP: compiler-errors
|
|||
|
||||
HELP: compiler-error
|
||||
{ $values { "error" "an error" } { "word" word } }
|
||||
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ;
|
||||
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
|
||||
|
||||
HELP: compiler-error.
|
||||
{ $values { "error" "an error" } { "word" word } }
|
||||
|
@ -25,24 +26,18 @@ HELP: compiler-error.
|
|||
HELP: compiler-errors.
|
||||
{ $values { "errors" "an assoc mapping words to errors" } }
|
||||
{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
|
||||
|
||||
HELP: (:errors)
|
||||
{ $values { "seq" "an alist" } }
|
||||
{ $description "Outputs all serious compiler errors from the most recent compile." } ;
|
||||
|
||||
HELP: :errors
|
||||
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
|
||||
|
||||
HELP: (:warnings)
|
||||
{ $values { "seq" "an alist" } }
|
||||
{ $description "Outputs all ignorable compiler warnings from the most recent compile." } ;
|
||||
|
||||
HELP: :warnings
|
||||
{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
|
||||
|
||||
{ :errors (:errors) :warnings (:warnings) } related-words
|
||||
HELP: :linkage
|
||||
{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
|
||||
|
||||
{ :errors :warnings } related-words
|
||||
|
||||
HELP: with-compiler-errors
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." }
|
||||
{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
|
||||
{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;
|
||||
|
|
|
@ -4,51 +4,66 @@ USING: kernel namespaces assocs prettyprint io sequences
|
|||
sorting continuations debugger math math.parser ;
|
||||
IN: compiler.errors
|
||||
|
||||
SYMBOL: +error+
|
||||
SYMBOL: +warning+
|
||||
SYMBOL: +linkage+
|
||||
|
||||
GENERIC: compiler-error-type ( error -- ? )
|
||||
|
||||
M: object compiler-error-type drop +error+ ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: compiler-errors
|
||||
|
||||
SYMBOL: with-compiler-errors?
|
||||
|
||||
: compiler-error ( error word -- )
|
||||
with-compiler-errors? get [
|
||||
compiler-errors get pick
|
||||
[ set-at ] [ delete-at drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: compiler-error. ( error word -- )
|
||||
nl
|
||||
"While compiling " write pprint ": " print
|
||||
nl
|
||||
print-error ;
|
||||
|
||||
: compiler-errors. ( assoc -- )
|
||||
>alist sort-keys [ swap compiler-error. ] assoc-each ;
|
||||
|
||||
GENERIC: compiler-warning? ( error -- ? )
|
||||
|
||||
M: object compiler-warning? drop f ;
|
||||
|
||||
: (:errors) ( -- assoc )
|
||||
: errors-of-type ( type -- assoc )
|
||||
compiler-errors get-global
|
||||
[ nip compiler-warning? not ] assoc-subset ;
|
||||
swap [ >r nip compiler-error-type r> eq? ] curry
|
||||
assoc-subset ;
|
||||
|
||||
: :errors (:errors) compiler-errors. ;
|
||||
: compiler-errors. ( type -- )
|
||||
errors-of-type >alist sort-keys
|
||||
[ swap compiler-error. ] assoc-each ;
|
||||
|
||||
: (:warnings) ( -- seq )
|
||||
compiler-errors get-global
|
||||
[ nip compiler-warning? ] assoc-subset ;
|
||||
|
||||
: :warnings (:warnings) compiler-errors. ;
|
||||
|
||||
: (compiler-report) ( what assoc -- )
|
||||
length dup zero? [ 2drop ] [
|
||||
: (compiler-report) ( what type word -- )
|
||||
over errors-of-type assoc-empty? [ 3drop ] [
|
||||
[
|
||||
":" % over % " - print " % # " compiler " % % "." %
|
||||
":" %
|
||||
%
|
||||
" - print " %
|
||||
errors-of-type assoc-size #
|
||||
" " %
|
||||
%
|
||||
"." %
|
||||
] "" make print
|
||||
] if ;
|
||||
|
||||
: compiler-report ( -- )
|
||||
"errors" (:errors) (compiler-report)
|
||||
"warnings" (:warnings) (compiler-report) ;
|
||||
"semantic errors" +error+ "errors" (compiler-report)
|
||||
"semantic warnings" +warning+ "warnings" (compiler-report)
|
||||
"linkage errors" +linkage+ "linkage" (compiler-report) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compiler-error ( error word -- )
|
||||
with-compiler-errors? get [
|
||||
compiler-errors get pick
|
||||
[ set-at ] [ delete-at drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: :errors +error+ compiler-errors. ;
|
||||
|
||||
: :warnings +warning+ compiler-errors. ;
|
||||
|
||||
: :linkage +linkage+ compiler-errors. ;
|
||||
|
||||
: with-compiler-errors ( quot -- )
|
||||
with-compiler-errors? get "quiet" get or [ call ] [
|
||||
|
|
|
@ -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,287 +0,0 @@
|
|||
USING: compiler definitions generic assocs inference math
|
||||
namespaces parser tools.test words kernel sequences arrays io
|
||||
effects tools.test compiler.units inference.state ;
|
||||
IN: temporary
|
||||
|
||||
DEFER: x-1
|
||||
DEFER: x-2
|
||||
|
||||
[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [
|
||||
"IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval
|
||||
"IN: temporary : x-2 3 x-1 ;" eval
|
||||
|
||||
[ t ] [
|
||||
{ x-2 } compile
|
||||
|
||||
\ x-2 word-xt
|
||||
|
||||
{ x-1 } compile
|
||||
|
||||
\ x-2 word-xt =
|
||||
] unit-test
|
||||
] with-variable
|
||||
|
||||
DEFER: b
|
||||
DEFER: c
|
||||
|
||||
[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test
|
||||
|
||||
[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
|
||||
|
||||
{ 0 4 } [ b ] must-infer-as
|
||||
|
||||
[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
|
||||
|
||||
[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
|
||||
|
||||
{ 0 6 } [ b ] must-infer-as
|
||||
|
||||
\ b word-xt "b-xt" set
|
||||
|
||||
[ ] [ "IN: temporary : c b ;" eval ] unit-test
|
||||
|
||||
[ t ] [ "b-xt" get \ b word-xt = ] unit-test
|
||||
|
||||
\ c word-xt "c-xt" set
|
||||
|
||||
[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test
|
||||
|
||||
[ t ] [ "c-xt" get \ c word-xt = ] unit-test
|
||||
|
||||
[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
|
||||
|
||||
{ 0 4 } [ c ] must-infer-as
|
||||
|
||||
[ f ] [ "c-xt" get \ c word-xt = ] unit-test
|
||||
|
||||
[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : e d d ;" eval ] unit-test
|
||||
|
||||
[ 3 3 ] [ "USE: temporary e" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test
|
||||
|
||||
[ 4 4 ] [ "USE: temporary e" eval ] unit-test
|
||||
|
||||
DEFER: x-3
|
||||
|
||||
[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test
|
||||
|
||||
DEFER: x-4
|
||||
|
||||
[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test
|
||||
|
||||
[ t ] [ \ x-4 compiled? ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test
|
||||
|
||||
[ f ] [ \ x-3 compiled? ] unit-test
|
||||
|
||||
[ f ] [ \ x-4 compiled? ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test
|
||||
|
||||
[ t ] [ \ x-3 compiled? ] unit-test
|
||||
|
||||
[ t ] [ \ x-4 compiled? ] unit-test
|
||||
|
||||
[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
|
||||
|
||||
DEFER: g-test-1
|
||||
|
||||
DEFER: g-test-3
|
||||
|
||||
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test
|
||||
|
||||
[ 25 ] [ 5 g-test-1 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test
|
||||
|
||||
[ 5 ] [ 5 g-test-1 ] unit-test
|
||||
|
||||
[ t ] [
|
||||
\ g-test-3 word-xt
|
||||
|
||||
"IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
|
||||
|
||||
\ g-test-3 word-xt =
|
||||
] unit-test
|
||||
|
||||
DEFER: g-test-5
|
||||
|
||||
[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test
|
||||
|
||||
[ 6 ] [ g-test-5 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test
|
||||
|
||||
[ 13 ] [ g-test-5 ] unit-test
|
||||
|
||||
DEFER: g-test-6
|
||||
|
||||
[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test
|
||||
|
||||
DEFER: g-test-7
|
||||
|
||||
[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test
|
||||
|
||||
[ 133 ] [ g-test-7 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test
|
||||
|
||||
[ 138 ] [ g-test-7 ] unit-test
|
||||
|
||||
USE: macros
|
||||
|
||||
DEFER: macro-test-3
|
||||
|
||||
[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) <array> >quotation ;" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test
|
||||
|
||||
[ 625 ] [ 5 macro-test-3 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test
|
||||
|
||||
[ 8 ] [ 5 macro-test-3 ] unit-test
|
||||
|
||||
USE: hints
|
||||
|
||||
DEFER: hints-test-2
|
||||
|
||||
[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test
|
||||
|
||||
[ 8 ] [ hints-test-2 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test
|
||||
|
||||
[ 10 ] [ hints-test-2 ] unit-test
|
||||
|
||||
DEFER: inline-then-not-inline-test-1
|
||||
DEFER: inline-then-not-inline-test-2
|
||||
|
||||
[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : inline-then-not-inline-test-2 inline-then-not-inline-test-1 ;" eval ] unit-test
|
||||
|
||||
[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test
|
||||
|
||||
\ inline-then-not-inline-test-2 word-xt "a" set
|
||||
|
||||
[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test
|
||||
|
||||
[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
|
||||
|
||||
[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
|
||||
|
||||
DEFER: generic-then-not-generic-test-1
|
||||
DEFER: generic-then-not-generic-test-2
|
||||
|
||||
[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test
|
||||
|
||||
[ 9 ] [ generic-then-not-generic-test-2 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
|
||||
|
||||
[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
|
||||
|
||||
DEFER: foldable-test-1
|
||||
DEFER: foldable-test-2
|
||||
|
||||
[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
|
||||
|
||||
[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test
|
||||
|
||||
[ 3 ] [ foldable-test-2 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
|
||||
|
||||
[ 4 ] [ foldable-test-2 ] unit-test
|
||||
|
||||
DEFER: flushable-test-2
|
||||
|
||||
[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
|
||||
|
||||
[ V{ } ] [ flushable-test-2 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
|
||||
|
||||
[ V{ 3 } ] [ flushable-test-2 ] unit-test
|
||||
|
||||
: ax ;
|
||||
: bx ax ;
|
||||
[ \ bx forget ] with-compilation-unit
|
||||
|
||||
[ f ] [ \ bx \ ax compiled-usage key? ] unit-test
|
||||
|
||||
DEFER: defer-redefine-test-2
|
||||
|
||||
[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
|
||||
|
||||
[ defer-redefine-test-2 ] must-fail
|
||||
|
||||
[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
|
||||
|
||||
[ 2 1 ] [ defer-redefine-test-2 ] unit-test
|
||||
|
||||
! Cross-referencing issue
|
||||
: compiled-xref-a ;
|
||||
|
||||
: compiled-xref-c ; inline
|
||||
|
||||
GENERIC: compiled-xref-b ( a -- b )
|
||||
|
||||
TUPLE: c-1 ;
|
||||
|
||||
M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ;
|
||||
|
||||
TUPLE: c-2 ;
|
||||
|
||||
M: c-2 compiled-xref-b drop 3 ;
|
||||
|
||||
[ t ] [
|
||||
\ compiled-xref-a compiled-crossref get key?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ compiled-xref-a forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
\ compiled-xref-a compiled-crossref get key?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
\ compiled-xref-a compiled-crossref get key?
|
||||
] 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
|
|
@ -4,7 +4,7 @@ math.private sequences strings tools.test words continuations
|
|||
sequences.private hashtables.private byte-arrays strings.private
|
||||
system random layouts vectors.private sbufs.private
|
||||
strings.private slots.private alien alien.accessors
|
||||
alien.c-types alien.syntax namespaces libc combinators.private ;
|
||||
alien.c-types alien.syntax namespaces libc sequences.private ;
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
[ ] [ 1 [ drop ] compile-call ] unit-test
|
|
@ -0,0 +1,229 @@
|
|||
USING: compiler tools.test kernel kernel.private
|
||||
sequences.private math.private math combinators strings
|
||||
alien arrays memory ;
|
||||
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
|
||||
|
||||
[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } 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
|
|
@ -2,7 +2,7 @@
|
|||
USING: arrays compiler kernel kernel.private math
|
||||
hashtables.private math.private namespaces sequences
|
||||
sequences.private tools.test namespaces.private slots.private
|
||||
combinators.private byte-arrays alien alien.accessors layouts
|
||||
sequences.private byte-arrays alien alien.accessors layouts
|
||||
words definitions compiler.units ;
|
||||
IN: temporary
|
||||
|
|
@ -169,7 +169,7 @@ HELP: rethrow
|
|||
|
||||
HELP: throw-restarts
|
||||
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
|
||||
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." }
|
||||
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
|
||||
{ $examples
|
||||
"Try invoking one of the two restarts which are offered after the below code throws an error:"
|
||||
{ $code
|
||||
|
|
|
@ -98,7 +98,7 @@ PRIVATE>
|
|||
: continue-with ( obj continuation -- )
|
||||
[
|
||||
walker-hook [ >r 2array r> ] when* (continue-with)
|
||||
] 2curry (throw) ;
|
||||
] 2 (throw) ;
|
||||
|
||||
: continue ( continuation -- )
|
||||
f swap continue-with ;
|
||||
|
|
|
@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- )
|
|||
! Test if vreg is 'f' or not
|
||||
HOOK: %jump-t compiler-backend ( label -- )
|
||||
|
||||
HOOK: %call-dispatch compiler-backend ( -- label )
|
||||
|
||||
HOOK: %jump-dispatch compiler-backend ( -- )
|
||||
HOOK: %dispatch compiler-backend ( -- )
|
||||
|
||||
HOOK: %dispatch-label compiler-backend ( word -- )
|
||||
|
||||
|
|
|
@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ;
|
|||
M: ppc-backend %jump-t ( label -- )
|
||||
0 "flag" operand f v>operand CMPI BNE ;
|
||||
|
||||
: (%dispatch) ( len -- )
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
|
||||
"offset" operand "n" operand 1 SRAWI
|
||||
11 11 "offset" operand ADD
|
||||
11 dup rot cells LWZ ;
|
||||
|
||||
M: ppc-backend %call-dispatch ( word-table# -- )
|
||||
[ 7 (%dispatch) (%call) <label> dup B ] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
} with-template ;
|
||||
|
||||
M: ppc-backend %jump-dispatch ( -- )
|
||||
[ %epilogue-later 6 (%dispatch) (%jump) ] H{
|
||||
M: ppc-backend %dispatch ( -- )
|
||||
[
|
||||
%epilogue-later
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
|
||||
"offset" operand "n" operand 1 SRAWI
|
||||
11 11 "offset" operand ADD
|
||||
11 dup 6 cells LWZ
|
||||
(%jump)
|
||||
] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
} with-template ;
|
||||
|
|
|
@ -13,3 +13,7 @@ namespaces alien.c-types kernel system combinators ;
|
|||
} cond
|
||||
|
||||
T{ ppc-backend } compiler-backend set-global
|
||||
|
||||
macosx? [
|
||||
4 "double" c-type set-c-type-align
|
||||
] when
|
||||
|
|
|
@ -261,9 +261,9 @@ windows? [
|
|||
cell "ulonglong" c-type set-c-type-align
|
||||
] unless
|
||||
|
||||
macosx? [
|
||||
cell "double" c-type set-c-type-align
|
||||
] when
|
||||
windows? [
|
||||
4 "double" c-type set-c-type-align
|
||||
] unless
|
||||
|
||||
T{ x86-backend f 4 } compiler-backend set-global
|
||||
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
|
|||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||
cpu.x86.allot cpu.architecture kernel kernel.private math
|
||||
namespaces sequences generator.registers generator.fixup system
|
||||
alien alien.compiler alien.structs slots splitting assocs ;
|
||||
alien alien.accessors alien.compiler alien.structs slots
|
||||
splitting assocs ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
PREDICATE: x86-backend amd64-backend
|
||||
|
|
|
@ -77,26 +77,29 @@ M: x86-backend %jump-label ( label -- ) JMP ;
|
|||
M: x86-backend %jump-t ( label -- )
|
||||
"flag" operand f v>operand CMP JNE ;
|
||||
|
||||
: (%dispatch) ( n -- operand )
|
||||
! Load jump table base. We use a temporary register
|
||||
! since on AMD64 we have to load a 64-bit immediate. On
|
||||
! x86, this is redundant.
|
||||
! Untag and multiply to get a jump table offset
|
||||
"n" operand fixnum>slot@
|
||||
! Add jump table base
|
||||
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||
"n" operand "offset" operand ADD
|
||||
"n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
|
||||
: code-alignment ( -- n )
|
||||
building get length dup cell align swap - ;
|
||||
|
||||
M: x86-backend %call-dispatch ( word-table# -- )
|
||||
[ 5 (%dispatch) CALL <label> dup JMP ] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
{ +clobber+ { "n" } }
|
||||
} with-template ;
|
||||
: align-code ( n -- )
|
||||
0 <repetition> % ;
|
||||
|
||||
M: x86-backend %jump-dispatch ( -- )
|
||||
[ %epilogue-later 0 (%dispatch) JMP ] H{
|
||||
M: x86-backend %dispatch ( -- )
|
||||
[
|
||||
%epilogue-later
|
||||
! Load jump table base. We use a temporary register
|
||||
! since on AMD64 we have to load a 64-bit immediate. On
|
||||
! x86, this is redundant.
|
||||
! Untag and multiply to get a jump table offset
|
||||
"n" operand fixnum>slot@
|
||||
! Add jump table base
|
||||
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||
"n" operand "offset" operand ADD
|
||||
"n" operand HEX: 7f [+] JMP
|
||||
! Fix up the displacement above
|
||||
code-alignment dup bootstrap-cell 8 = 15 9 ? +
|
||||
building get dup pop* push
|
||||
align-code
|
||||
] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
{ +clobber+ { "n" } }
|
||||
|
|
|
@ -56,13 +56,16 @@ GENERIC: generate-node ( node -- next )
|
|||
: generate-nodes ( node -- )
|
||||
[ node@ generate-node ] iterate-nodes end-basic-block ;
|
||||
|
||||
: init-generate-nodes ( -- )
|
||||
init-templates
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label ;
|
||||
|
||||
: generate ( word label node -- )
|
||||
[
|
||||
init-templates
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label
|
||||
init-generate-nodes
|
||||
[ generate-nodes ] with-node-iterator
|
||||
] generate-1 ;
|
||||
|
||||
|
@ -168,17 +171,23 @@ M: #if generate-node
|
|||
] if %dispatch-label
|
||||
] each ;
|
||||
|
||||
: generate-dispatch ( node -- )
|
||||
%dispatch dispatch-branches init-templates ;
|
||||
|
||||
M: #dispatch generate-node
|
||||
#! The order here is important, dispatch-branches must
|
||||
#! run after %dispatch, so that each branch gets the
|
||||
#! correct register state
|
||||
tail-call? [
|
||||
%jump-dispatch dispatch-branches
|
||||
generate-dispatch iterate-next
|
||||
] [
|
||||
0 frame-required
|
||||
%call-dispatch >r dispatch-branches r> resolve-label
|
||||
] if
|
||||
init-templates iterate-next ;
|
||||
compiling-word get gensym [
|
||||
rot [
|
||||
init-generate-nodes
|
||||
generate-dispatch
|
||||
] generate-1
|
||||
] keep generate-call
|
||||
] if ;
|
||||
|
||||
! #call
|
||||
: define-intrinsics ( word intrinsics -- )
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic hashtables kernel kernel.private
|
||||
math namespaces sequences words quotations layouts combinators
|
||||
combinators.private classes definitions ;
|
||||
sequences.private classes definitions ;
|
||||
IN: generic.math
|
||||
|
||||
PREDICATE: class math-class ( object -- ? )
|
||||
|
@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ;
|
|||
: math-vtable* ( picker max quot -- quot )
|
||||
[
|
||||
rot , \ tag ,
|
||||
[ >r [ type>class ] map r> map % ] { } make ,
|
||||
[ >r [ bootstrap-type>class ] map r> map % ] { } make ,
|
||||
\ dispatch ,
|
||||
] [ ] make ; inline
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs kernel kernel.private slots.private math
|
||||
namespaces sequences vectors words quotations definitions
|
||||
hashtables layouts combinators combinators.private generic
|
||||
hashtables layouts combinators sequences.private generic
|
||||
classes classes.private ;
|
||||
IN: generic.standard
|
||||
|
||||
|
@ -97,7 +97,7 @@ TUPLE: no-method object generic ;
|
|||
[ small-generic ] picker class-hash-dispatch-quot ;
|
||||
|
||||
: vtable-class ( n -- class )
|
||||
type>class [ hi-tag bootstrap-word ] unless* ;
|
||||
bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
|
||||
|
||||
: group-methods ( assoc -- vtable )
|
||||
#! Input is a predicate -> method association.
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.syntax help.markup words effects inference.dataflow
|
||||
inference.state inference.backend kernel sequences
|
||||
kernel.private combinators combinators.private ;
|
||||
kernel.private combinators sequences.private ;
|
||||
|
||||
HELP: literal-expected
|
||||
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
|
||||
|
|
|
@ -24,24 +24,24 @@ IN: inference.backend
|
|||
: recursive-quotation? ( quot -- ? )
|
||||
local-recursive-state [ first eq? ] with contains? ;
|
||||
|
||||
TUPLE: inference-error rstate major? ;
|
||||
TUPLE: inference-error rstate type ;
|
||||
|
||||
M: inference-error compiler-warning?
|
||||
inference-error-major? not ;
|
||||
M: inference-error compiler-error-type
|
||||
inference-error-type ;
|
||||
|
||||
: (inference-error) ( ... class important? -- * )
|
||||
: (inference-error) ( ... class type -- * )
|
||||
>r construct-boa r>
|
||||
recursive-state get {
|
||||
set-delegate
|
||||
set-inference-error-major?
|
||||
set-inference-error-type
|
||||
set-inference-error-rstate
|
||||
} \ inference-error construct throw ; inline
|
||||
|
||||
: inference-error ( ... class -- * )
|
||||
t (inference-error) ; inline
|
||||
+error+ (inference-error) ; inline
|
||||
|
||||
: inference-warning ( ... class -- * )
|
||||
f (inference-error) ; inline
|
||||
+warning+ (inference-error) ; inline
|
||||
|
||||
TUPLE: literal-expected ;
|
||||
|
||||
|
@ -370,6 +370,7 @@ TUPLE: effect-error word effect ;
|
|||
init-inference
|
||||
dependencies off
|
||||
dup word-def over dup infer-quot-recursive
|
||||
end-infer
|
||||
finish-word
|
||||
current-effect
|
||||
] with-scope
|
||||
|
|
|
@ -263,3 +263,23 @@ 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 number } declare number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 = ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
|
|
@ -73,17 +73,27 @@ SYMBOL: value-intervals
|
|||
! Current value --> class mapping
|
||||
SYMBOL: value-classes
|
||||
|
||||
: value-interval* ( value -- interval/f )
|
||||
value-intervals get at ;
|
||||
|
||||
: set-value-interval* ( interval value -- )
|
||||
value-intervals get set-at ;
|
||||
|
||||
: intersect-value-interval ( interval value -- )
|
||||
[ value-interval* interval-intersect ] keep
|
||||
set-value-interval* ;
|
||||
|
||||
M: interval-constraint apply-constraint
|
||||
dup interval-constraint-interval
|
||||
swap interval-constraint-value set-value-interval* ;
|
||||
swap interval-constraint-value intersect-value-interval ;
|
||||
|
||||
: set-class-interval ( class value -- )
|
||||
>r "interval" word-prop dup
|
||||
[ r> set-value-interval* ] [ r> 2drop ] if ;
|
||||
|
||||
: value-class* ( value -- class )
|
||||
value-classes get at object or ;
|
||||
|
||||
: set-value-class* ( class value -- )
|
||||
over [
|
||||
dup value-intervals get at [
|
||||
|
@ -93,9 +103,12 @@ M: interval-constraint apply-constraint
|
|||
] when
|
||||
value-classes get set-at ;
|
||||
|
||||
: intersect-value-class ( class value -- )
|
||||
[ value-class* class-and ] keep set-value-class* ;
|
||||
|
||||
M: class-constraint apply-constraint
|
||||
dup class-constraint-class
|
||||
swap class-constraint-value set-value-class* ;
|
||||
swap class-constraint-value intersect-value-class ;
|
||||
|
||||
: set-value-literal* ( literal value -- )
|
||||
over class over set-value-class*
|
||||
|
@ -127,16 +140,10 @@ M: literal-constraint constraint-satisfied?
|
|||
dup literal-constraint-value value-literal*
|
||||
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
|
||||
|
||||
: value-class* ( value -- class )
|
||||
value-classes get at object or ;
|
||||
|
||||
M: class-constraint constraint-satisfied?
|
||||
dup class-constraint-value value-class*
|
||||
swap class-constraint-class class< ;
|
||||
|
||||
: value-interval* ( value -- interval/f )
|
||||
value-intervals get at ;
|
||||
|
||||
M: pair apply-constraint
|
||||
first2 2dup constraints get set-at
|
||||
constraint-satisfied? [ apply-constraint ] [ drop ] if ;
|
||||
|
@ -159,13 +166,10 @@ M: pair constraint-satisfied?
|
|||
2drop ;
|
||||
|
||||
: intersect-classes ( classes values -- )
|
||||
[ [ value-class* class-and ] keep set-value-class* ] 2each ;
|
||||
[ intersect-value-class ] 2each ;
|
||||
|
||||
: intersect-intervals ( intervals values -- )
|
||||
[
|
||||
[ value-interval* interval-intersect ] keep
|
||||
set-value-interval*
|
||||
] 2each ;
|
||||
[ intersect-value-interval ] 2each ;
|
||||
|
||||
: predicate-constraints ( class #call -- )
|
||||
[
|
||||
|
@ -181,20 +185,14 @@ M: pair constraint-satisfied?
|
|||
[ swap predicate-constraints ] [ 2drop ] if
|
||||
] if* ;
|
||||
|
||||
: default-output-classes ( word -- classes )
|
||||
"inferred-effect" word-prop {
|
||||
{ [ dup not ] [ drop f ] }
|
||||
{ [ dup effect-out [ class? ] all? not ] [ drop f ] }
|
||||
{ [ t ] [ effect-out ] }
|
||||
} cond ;
|
||||
|
||||
: compute-output-classes ( node word -- classes intervals )
|
||||
dup node-param "output-classes" word-prop dup
|
||||
[ call ] [ 2drop f f ] if ;
|
||||
dup node-param "output-classes" word-prop
|
||||
dup [ call ] [ 2drop f f ] if ;
|
||||
|
||||
: output-classes ( node -- classes intervals )
|
||||
dup compute-output-classes
|
||||
>r [ ] [ node-param default-output-classes ] ?if r> ;
|
||||
dup compute-output-classes >r
|
||||
[ ] [ node-param "default-output-classes" word-prop ] ?if
|
||||
r> ;
|
||||
|
||||
M: #call infer-classes-before
|
||||
dup compute-constraints
|
||||
|
@ -220,7 +218,8 @@ M: #dispatch child-constraints
|
|||
] make-constraints ;
|
||||
|
||||
M: #declare infer-classes-before
|
||||
dup node-param swap node-in-d [ set-value-class* ] 2each ;
|
||||
dup node-param swap node-in-d
|
||||
[ intersect-value-class ] 2each ;
|
||||
|
||||
DEFER: (infer-classes)
|
||||
|
||||
|
|
|
@ -256,6 +256,28 @@ SYMBOL: node-stack
|
|||
] iterate-nodes drop
|
||||
] with-node-iterator ; inline
|
||||
|
||||
: change-children ( node quot -- )
|
||||
over [
|
||||
>r dup node-children dup r>
|
||||
[ map swap set-node-children ] curry
|
||||
[ 2drop ] if
|
||||
] [
|
||||
2drop
|
||||
] if ; inline
|
||||
|
||||
: (transform-nodes) ( prev node quot -- )
|
||||
dup >r call dup [
|
||||
dup rot set-node-successor
|
||||
dup node-successor r> (transform-nodes)
|
||||
] [
|
||||
r> drop f swap set-node-successor drop
|
||||
] if ; inline
|
||||
|
||||
: transform-nodes ( node quot -- new-node )
|
||||
over [
|
||||
[ call dup dup node-successor ] keep (transform-nodes)
|
||||
] [ drop ] if ; inline
|
||||
|
||||
: node-literal? ( node value -- ? )
|
||||
dup value? >r swap node-literals key? r> or ;
|
||||
|
||||
|
|
|
@ -4,7 +4,8 @@ math.parser math.private namespaces namespaces.private parser
|
|||
sequences strings vectors words quotations effects tools.test
|
||||
continuations generic.standard sorting assocs definitions
|
||||
prettyprint io inspector tuples classes.union classes.predicate
|
||||
debugger threads.private io.streams.string combinators.private ;
|
||||
debugger threads.private io.streams.string io.timeouts
|
||||
sequences.private ;
|
||||
IN: temporary
|
||||
|
||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||
|
@ -536,3 +537,8 @@ TUPLE: custom-error ;
|
|||
! This was a false trigger of the undecidable quotation
|
||||
! recursion bug
|
||||
{ 2 1 } [ find-last-sep ] must-infer-as
|
||||
|
||||
! Regression
|
||||
: missing->r-check >r ;
|
||||
|
||||
[ [ missing->r-check ] infer ] must-fail
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.accessors arrays bit-arrays byte-arrays
|
||||
classes combinators.private continuations.private effects
|
||||
classes sequences.private continuations.private effects
|
||||
float-arrays generic hashtables hashtables.private
|
||||
inference.state inference.backend inference.dataflow io
|
||||
io.backend io.files io.files.private io.streams.c kernel
|
||||
|
@ -126,15 +126,11 @@ M: object infer-call
|
|||
pop-d pop-d swap <curried> push-d
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ curry { object object } { curry } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ compose [
|
||||
2 ensure-values
|
||||
pop-d pop-d swap <composed> push-d
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ compose { object object } { curry } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
! Variadic tuple constructor
|
||||
\ <tuple-boa> [
|
||||
\ <tuple-boa>
|
||||
|
@ -142,440 +138,461 @@ M: object infer-call
|
|||
make-call-node
|
||||
] "infer" set-word-prop
|
||||
|
||||
! We need this for default-output-classes
|
||||
\ <tuple-boa> 2 { tuple } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
! Non-standard control flow
|
||||
\ (throw) { callable } { } <effect>
|
||||
t over set-effect-terminated?
|
||||
"inferred-effect" set-word-prop
|
||||
\ (throw) [
|
||||
\ (throw)
|
||||
peek-d value-literal 2 + { } <effect>
|
||||
t over set-effect-terminated?
|
||||
make-call-node
|
||||
] "infer" set-word-prop
|
||||
|
||||
: set-primitive-effect ( word effect -- )
|
||||
2dup effect-out "default-output-classes" set-word-prop
|
||||
dupd [ make-call-node ] 2curry "infer" set-word-prop ;
|
||||
|
||||
! Stack effects for all primitives
|
||||
\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
\ fixnum< make-foldable
|
||||
|
||||
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
\ fixnum<= make-foldable
|
||||
|
||||
\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
\ fixnum> make-foldable
|
||||
|
||||
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
\ fixnum>= make-foldable
|
||||
|
||||
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ eq? { object object } { object } <effect> set-primitive-effect
|
||||
\ eq? make-foldable
|
||||
|
||||
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
|
||||
\ rehash-string { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
|
||||
\ bignum>fixnum make-foldable
|
||||
|
||||
\ float>fixnum { float } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
|
||||
\ bignum>fixnum make-foldable
|
||||
|
||||
\ fixnum>bignum { fixnum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
|
||||
\ fixnum>bignum make-foldable
|
||||
|
||||
\ float>bignum { float } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ float>bignum { float } { bignum } <effect> set-primitive-effect
|
||||
\ float>bignum make-foldable
|
||||
|
||||
\ fixnum>float { fixnum } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
|
||||
\ fixnum>float make-foldable
|
||||
|
||||
\ bignum>float { bignum } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum>float { bignum } { float } <effect> set-primitive-effect
|
||||
\ bignum>float make-foldable
|
||||
|
||||
\ <ratio> { integer integer } { ratio } <effect> "inferred-effect" set-word-prop
|
||||
\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
|
||||
\ <ratio> make-foldable
|
||||
|
||||
\ string>float { string } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ string>float { string } { float } <effect> set-primitive-effect
|
||||
\ string>float make-foldable
|
||||
|
||||
\ float>string { float } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ float>string { float } { string } <effect> set-primitive-effect
|
||||
\ float>string make-foldable
|
||||
|
||||
\ float>bits { real } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ float>bits { real } { integer } <effect> set-primitive-effect
|
||||
\ float>bits make-foldable
|
||||
|
||||
\ double>bits { real } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ double>bits { real } { integer } <effect> set-primitive-effect
|
||||
\ double>bits make-foldable
|
||||
|
||||
\ bits>float { integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ bits>float { integer } { float } <effect> set-primitive-effect
|
||||
\ bits>float make-foldable
|
||||
|
||||
\ bits>double { integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ bits>double { integer } { float } <effect> set-primitive-effect
|
||||
\ bits>double make-foldable
|
||||
|
||||
\ <complex> { real real } { complex } <effect> "inferred-effect" set-word-prop
|
||||
\ <complex> { real real } { complex } <effect> set-primitive-effect
|
||||
\ <complex> make-foldable
|
||||
|
||||
\ fixnum+ { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum+ make-foldable
|
||||
|
||||
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum+fast make-foldable
|
||||
|
||||
\ fixnum- { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum- make-foldable
|
||||
|
||||
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-fast make-foldable
|
||||
|
||||
\ fixnum* { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum* make-foldable
|
||||
|
||||
\ fixnum*fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum*fast make-foldable
|
||||
|
||||
\ fixnum/i { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum/i make-foldable
|
||||
|
||||
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-mod make-foldable
|
||||
|
||||
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
|
||||
\ fixnum/mod make-foldable
|
||||
|
||||
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-bitand make-foldable
|
||||
|
||||
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-bitor make-foldable
|
||||
|
||||
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-bitxor make-foldable
|
||||
|
||||
\ fixnum-bitnot { fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-bitnot make-foldable
|
||||
|
||||
\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
|
||||
\ fixnum-shift make-foldable
|
||||
|
||||
\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
|
||||
\ fixnum-shift-fast make-foldable
|
||||
|
||||
\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum= make-foldable
|
||||
|
||||
\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum+ make-foldable
|
||||
|
||||
\ bignum- { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum- make-foldable
|
||||
|
||||
\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum* make-foldable
|
||||
|
||||
\ bignum/i { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum/i make-foldable
|
||||
|
||||
\ bignum-mod { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-mod make-foldable
|
||||
|
||||
\ bignum/mod { bignum bignum } { bignum bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
|
||||
\ bignum/mod make-foldable
|
||||
|
||||
\ bignum-bitand { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-bitand make-foldable
|
||||
|
||||
\ bignum-bitor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-bitor make-foldable
|
||||
|
||||
\ bignum-bitxor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-bitxor make-foldable
|
||||
|
||||
\ bignum-bitnot { bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-bitnot make-foldable
|
||||
|
||||
\ bignum-shift { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-shift make-foldable
|
||||
|
||||
\ bignum< { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum< make-foldable
|
||||
|
||||
\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum<= make-foldable
|
||||
|
||||
\ bignum> { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum> make-foldable
|
||||
|
||||
\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
|
||||
\ bignum>= make-foldable
|
||||
|
||||
\ bignum-bit? { bignum integer } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
|
||||
\ bignum-bit? make-foldable
|
||||
|
||||
\ bignum-log2 { bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
|
||||
\ bignum-log2 make-foldable
|
||||
|
||||
\ byte-array>bignum { byte-array } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
|
||||
\ byte-array>bignum make-foldable
|
||||
|
||||
\ float= { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float= { float float } { object } <effect> set-primitive-effect
|
||||
\ float= make-foldable
|
||||
|
||||
\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float+ { float float } { float } <effect> set-primitive-effect
|
||||
\ float+ make-foldable
|
||||
|
||||
\ float- { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float- { float float } { float } <effect> set-primitive-effect
|
||||
\ float- make-foldable
|
||||
|
||||
\ float* { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float* { float float } { float } <effect> set-primitive-effect
|
||||
\ float* make-foldable
|
||||
|
||||
\ float/f { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float/f { float float } { float } <effect> set-primitive-effect
|
||||
\ float/f make-foldable
|
||||
|
||||
\ float< { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float< { float float } { object } <effect> set-primitive-effect
|
||||
\ float< make-foldable
|
||||
|
||||
\ float-mod { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float-mod { float float } { float } <effect> set-primitive-effect
|
||||
\ float-mod make-foldable
|
||||
|
||||
\ float<= { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float<= { float float } { object } <effect> set-primitive-effect
|
||||
\ float<= make-foldable
|
||||
|
||||
\ float> { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float> { float float } { object } <effect> set-primitive-effect
|
||||
\ float> make-foldable
|
||||
|
||||
\ float>= { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float>= { float float } { object } <effect> set-primitive-effect
|
||||
\ float>= make-foldable
|
||||
|
||||
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
|
||||
\ <word> { object object } { word } <effect> set-primitive-effect
|
||||
\ <word> make-flushable
|
||||
|
||||
\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ word-xt { word } { integer } <effect> set-primitive-effect
|
||||
\ word-xt make-flushable
|
||||
|
||||
\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ getenv { fixnum } { object } <effect> set-primitive-effect
|
||||
\ getenv make-flushable
|
||||
|
||||
\ setenv { object fixnum } { } <effect> "inferred-effect" set-word-prop
|
||||
\ setenv { object fixnum } { } <effect> set-primitive-effect
|
||||
|
||||
\ (stat) { string } { object object object object } <effect> "inferred-effect" set-word-prop
|
||||
\ (stat) { string } { object object object object } <effect> set-primitive-effect
|
||||
|
||||
\ (directory) { string } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ (directory) { string } { array } <effect> set-primitive-effect
|
||||
|
||||
\ data-gc { } { } <effect> "inferred-effect" set-word-prop
|
||||
\ data-gc { } { } <effect> set-primitive-effect
|
||||
|
||||
\ code-gc { } { } <effect> "inferred-effect" set-word-prop
|
||||
\ code-gc { } { } <effect> set-primitive-effect
|
||||
|
||||
\ gc-time { } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ gc-time { } { integer } <effect> set-primitive-effect
|
||||
|
||||
\ save-image { string } { } <effect> "inferred-effect" set-word-prop
|
||||
\ save-image { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ save-image-and-exit { string } { } <effect> "inferred-effect" set-word-prop
|
||||
\ save-image-and-exit { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ exit { integer } { } <effect>
|
||||
t over set-effect-terminated?
|
||||
"inferred-effect" set-word-prop
|
||||
set-primitive-effect
|
||||
|
||||
\ data-room { } { integer array } <effect> "inferred-effect" set-word-prop
|
||||
\ data-room { } { integer array } <effect> set-primitive-effect
|
||||
\ data-room make-flushable
|
||||
|
||||
\ code-room { } { integer integer } <effect> "inferred-effect" set-word-prop
|
||||
\ code-room { } { integer integer } <effect> set-primitive-effect
|
||||
\ code-room make-flushable
|
||||
|
||||
\ os-env { string } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ os-env { string } { object } <effect> set-primitive-effect
|
||||
|
||||
\ millis { } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ millis { } { integer } <effect> set-primitive-effect
|
||||
\ millis make-flushable
|
||||
|
||||
\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ type { object } { fixnum } <effect> set-primitive-effect
|
||||
\ type make-foldable
|
||||
|
||||
\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ tag { object } { fixnum } <effect> set-primitive-effect
|
||||
\ tag make-foldable
|
||||
|
||||
\ class-hash { object } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ class-hash { object } { fixnum } <effect> set-primitive-effect
|
||||
\ class-hash make-foldable
|
||||
|
||||
\ cwd { } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ cwd { } { string } <effect> set-primitive-effect
|
||||
|
||||
\ cd { string } { } <effect> "inferred-effect" set-word-prop
|
||||
\ cd { string } { } <effect> set-primitive-effect
|
||||
|
||||
\ dlopen { string } { dll } <effect> "inferred-effect" set-word-prop
|
||||
\ dlopen { string } { dll } <effect> set-primitive-effect
|
||||
|
||||
\ dlsym { string object } { c-ptr } <effect> "inferred-effect" set-word-prop
|
||||
\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
|
||||
|
||||
\ dlclose { dll } { } <effect> "inferred-effect" set-word-prop
|
||||
\ dlclose { dll } { } <effect> set-primitive-effect
|
||||
|
||||
\ <byte-array> { integer } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
|
||||
\ <byte-array> make-flushable
|
||||
|
||||
\ <bit-array> { integer } { bit-array } <effect> "inferred-effect" set-word-prop
|
||||
\ <bit-array> { integer } { bit-array } <effect> set-primitive-effect
|
||||
\ <bit-array> make-flushable
|
||||
|
||||
\ <float-array> { integer float } { float-array } <effect> "inferred-effect" set-word-prop
|
||||
\ <float-array> { integer float } { float-array } <effect> set-primitive-effect
|
||||
\ <float-array> make-flushable
|
||||
|
||||
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "inferred-effect" set-word-prop
|
||||
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
|
||||
\ <displaced-alien> make-flushable
|
||||
|
||||
\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-signed-cell make-flushable
|
||||
|
||||
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-unsigned-cell make-flushable
|
||||
|
||||
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-signed-8 make-flushable
|
||||
|
||||
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-unsigned-8 make-flushable
|
||||
|
||||
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-signed-4 make-flushable
|
||||
|
||||
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
|
||||
\ alien-unsigned-4 make-flushable
|
||||
|
||||
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
|
||||
\ alien-signed-2 make-flushable
|
||||
|
||||
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
|
||||
\ alien-unsigned-2 make-flushable
|
||||
|
||||
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
|
||||
\ alien-signed-1 make-flushable
|
||||
|
||||
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
|
||||
\ alien-unsigned-1 make-flushable
|
||||
|
||||
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
|
||||
\ alien-float make-flushable
|
||||
|
||||
\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
|
||||
\ alien-double make-flushable
|
||||
|
||||
\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
|
||||
\ alien-cell make-flushable
|
||||
|
||||
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
|
||||
\ alien>char-string make-flushable
|
||||
|
||||
\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
|
||||
\ string>char-alien make-flushable
|
||||
|
||||
\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
|
||||
\ alien>u16-string make-flushable
|
||||
|
||||
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
|
||||
\ string>u16-alien make-flushable
|
||||
|
||||
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-address { alien } { integer } <effect> set-primitive-effect
|
||||
\ alien-address make-flushable
|
||||
|
||||
\ slot { object fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ slot { object fixnum } { object } <effect> set-primitive-effect
|
||||
\ slot make-flushable
|
||||
|
||||
\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-slot { object object fixnum } { } <effect> set-primitive-effect
|
||||
|
||||
\ string-nth { fixnum string } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
|
||||
\ string-nth make-flushable
|
||||
|
||||
\ set-string-nth { fixnum fixnum string } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
|
||||
|
||||
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-array { integer array } { array } <effect> set-primitive-effect
|
||||
\ resize-array make-flushable
|
||||
|
||||
\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
|
||||
\ resize-byte-array make-flushable
|
||||
|
||||
\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-bit-array { integer bit-array } { bit-array } <effect> set-primitive-effect
|
||||
\ resize-bit-array make-flushable
|
||||
|
||||
\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-float-array { integer float-array } { float-array } <effect> set-primitive-effect
|
||||
\ resize-float-array make-flushable
|
||||
|
||||
\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-string { integer string } { string } <effect> set-primitive-effect
|
||||
\ resize-string make-flushable
|
||||
|
||||
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ <array> { integer object } { array } <effect> set-primitive-effect
|
||||
\ <array> make-flushable
|
||||
|
||||
\ begin-scan { } { } <effect> "inferred-effect" set-word-prop
|
||||
\ begin-scan { } { } <effect> set-primitive-effect
|
||||
|
||||
\ next-object { } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ next-object { } { object } <effect> set-primitive-effect
|
||||
|
||||
\ end-scan { } { } <effect> "inferred-effect" set-word-prop
|
||||
\ end-scan { } { } <effect> set-primitive-effect
|
||||
|
||||
\ size { object } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ size { object } { fixnum } <effect> set-primitive-effect
|
||||
\ size make-flushable
|
||||
|
||||
\ die { } { } <effect> "inferred-effect" set-word-prop
|
||||
\ die { } { } <effect> set-primitive-effect
|
||||
|
||||
\ fopen { string string } { alien } <effect> "inferred-effect" set-word-prop
|
||||
\ fopen { string string } { alien } <effect> set-primitive-effect
|
||||
|
||||
\ fgetc { alien } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fgetc { alien } { object } <effect> set-primitive-effect
|
||||
|
||||
\ fwrite { string alien } { } <effect> "inferred-effect" set-word-prop
|
||||
\ fwrite { string alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ fread { integer string } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fread { integer string } { object } <effect> set-primitive-effect
|
||||
|
||||
\ fflush { alien } { } <effect> "inferred-effect" set-word-prop
|
||||
\ fflush { alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ fclose { alien } { } <effect> "inferred-effect" set-word-prop
|
||||
\ fclose { alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ expired? { object } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ expired? { object } { object } <effect> set-primitive-effect
|
||||
\ expired? make-flushable
|
||||
|
||||
\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop
|
||||
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
|
||||
\ <wrapper> make-foldable
|
||||
|
||||
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ (clone) { object } { object } <effect> set-primitive-effect
|
||||
\ (clone) make-flushable
|
||||
|
||||
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ <string> { integer integer } { string } <effect> set-primitive-effect
|
||||
\ <string> make-flushable
|
||||
|
||||
\ array>quotation { array } { quotation } <effect> "inferred-effect" set-word-prop
|
||||
\ array>quotation { array } { quotation } <effect> set-primitive-effect
|
||||
\ array>quotation make-flushable
|
||||
|
||||
\ quotation-xt { quotation } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
|
||||
\ quotation-xt make-flushable
|
||||
|
||||
\ <tuple> { word integer } { quotation } <effect> "inferred-effect" set-word-prop
|
||||
\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
|
||||
\ <tuple> make-flushable
|
||||
|
||||
\ (>tuple) { array } { tuple } <effect> "inferred-effect" set-word-prop
|
||||
\ (>tuple) { array } { tuple } <effect> set-primitive-effect
|
||||
\ (>tuple) make-flushable
|
||||
|
||||
\ tuple>array { tuple } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ tuple>array { tuple } { array } <effect> set-primitive-effect
|
||||
\ tuple>array make-flushable
|
||||
|
||||
\ datastack { } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ datastack { } { array } <effect> set-primitive-effect
|
||||
\ datastack make-flushable
|
||||
|
||||
\ retainstack { } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ retainstack { } { array } <effect> set-primitive-effect
|
||||
\ retainstack make-flushable
|
||||
|
||||
\ callstack { } { callstack } <effect> "inferred-effect" set-word-prop
|
||||
\ callstack { } { callstack } <effect> set-primitive-effect
|
||||
\ callstack make-flushable
|
||||
|
||||
\ callstack>array { callstack } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ callstack>array { callstack } { array } <effect> set-primitive-effect
|
||||
\ callstack>array make-flushable
|
||||
|
||||
\ (sleep) { integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ (sleep) { integer } { } <effect> set-primitive-effect
|
||||
|
||||
\ become { array array } { } <effect> "inferred-effect" set-word-prop
|
||||
\ become { array array } { } <effect> set-primitive-effect
|
||||
|
||||
\ innermost-frame-quot { callstack } { quotation } <effect> "inferred-effect" set-word-prop
|
||||
\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
|
||||
|
||||
\ innermost-frame-scan { callstack } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
|
||||
|
||||
\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop
|
||||
\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
|
||||
|
||||
\ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ (os-envs) { } { array } <effect> set-primitive-effect
|
||||
|
||||
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
|
||||
|
|
|
@ -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 )
|
||||
|
@ -91,5 +93,3 @@ M: duplicated-slots-error summary
|
|||
\ construct-empty 1 1 <effect> make-call-node
|
||||
] if
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ construct-empty 1 1 <effect> "inferred-effect" set-word-prop
|
||||
|
|
|
@ -52,6 +52,21 @@ HELP: <file-appender>
|
|||
{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
||||
HELP: with-file-in
|
||||
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
|
||||
{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
|
||||
{ $errors "Throws an error if the file is unreadable." } ;
|
||||
|
||||
HELP: with-file-out
|
||||
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
|
||||
{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
||||
HELP: with-file-appender
|
||||
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
|
||||
{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
||||
HELP: cwd
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Outputs the current working directory of the Factor process." }
|
||||
|
|
|
@ -96,6 +96,9 @@ TUPLE: no-parent-directory path ;
|
|||
: ?resource-path ( path -- newpath )
|
||||
"resource:" ?head [ resource-path ] when ;
|
||||
|
||||
: resource-exists? ( path -- ? )
|
||||
?resource-path exists? ;
|
||||
|
||||
: make-directories ( path -- )
|
||||
normalize-pathname right-trim-separators {
|
||||
{ [ dup "." = ] [ ] }
|
||||
|
|
|
@ -22,8 +22,7 @@ $nl
|
|||
{ $subsection make-block-stream }
|
||||
{ $subsection make-cell-stream }
|
||||
{ $subsection stream-write-table }
|
||||
"Optional word for network streams:"
|
||||
{ $subsection set-timeout } ;
|
||||
{ $see-also "io.timeouts" } ;
|
||||
|
||||
ARTICLE: "stdio" "The default stream"
|
||||
"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
|
||||
|
@ -73,11 +72,6 @@ ARTICLE: "streams" "Streams"
|
|||
|
||||
ABOUT: "streams"
|
||||
|
||||
HELP: set-timeout
|
||||
{ $values { "n" "an integer" } { "stream" "a stream" } }
|
||||
{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
|
||||
{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
|
||||
|
||||
HELP: stream-readln
|
||||
{ $values { "stream" "an input stream" } { "str" string } }
|
||||
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
|
|
|
@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
|
|||
continuations assocs io.styles sbufs ;
|
||||
IN: io
|
||||
|
||||
GENERIC: set-timeout ( n stream -- )
|
||||
GENERIC: stream-readln ( stream -- str )
|
||||
GENERIC: stream-read1 ( stream -- ch/f )
|
||||
GENERIC: stream-read ( n stream -- str/f )
|
||||
|
|
|
@ -74,8 +74,3 @@ M: duplex-stream dispose
|
|||
[ dup duplex-stream-out dispose ]
|
||||
[ dup duplex-stream-in dispose ] [ ] cleanup
|
||||
] unless drop ;
|
||||
|
||||
M: duplex-stream set-timeout
|
||||
2dup
|
||||
duplex-stream-in set-timeout
|
||||
duplex-stream-out set-timeout ;
|
||||
|
|
|
@ -532,7 +532,7 @@ HELP: compose
|
|||
"compose call"
|
||||
"append call"
|
||||
}
|
||||
"However, " { $link compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
|
||||
"However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
|
||||
} ;
|
||||
|
||||
HELP: 3compose
|
||||
|
|
|
@ -17,7 +17,7 @@ IN: kernel
|
|||
: clear ( -- ) { } set-datastack ;
|
||||
|
||||
! Combinators
|
||||
: call ( callable -- ) uncurry (call) ;
|
||||
GENERIC: call ( callable -- )
|
||||
|
||||
DEFER: if
|
||||
|
||||
|
@ -70,6 +70,10 @@ DEFER: if
|
|||
[ 2nip call ] if ; inline
|
||||
|
||||
! Quotation building
|
||||
USE: tuples.private
|
||||
|
||||
: curry ( obj quot -- curry )
|
||||
\ curry 4 <tuple-boa> ;
|
||||
|
||||
: 2curry ( obj1 obj2 quot -- curry )
|
||||
curry curry ; inline
|
||||
|
@ -81,12 +85,10 @@ DEFER: if
|
|||
swapd [ swapd call ] 2curry ; inline
|
||||
|
||||
: compose ( quot1 quot2 -- curry )
|
||||
! Not inline because this is treated as a primitive by
|
||||
! the compiler
|
||||
[ slip call ] 2curry ;
|
||||
\ compose 4 <tuple-boa> ;
|
||||
|
||||
: 3compose ( quot1 quot2 quot3 -- curry )
|
||||
[ 2slip slip call ] 3curry ; inline
|
||||
compose compose ; inline
|
||||
|
||||
! Object protocol
|
||||
|
||||
|
@ -155,7 +157,7 @@ GENERIC: construct-boa ( ... class -- tuple )
|
|||
|
||||
! Error handling -- defined early so that other files can
|
||||
! throw errors before continuations are loaded
|
||||
: throw ( error -- * ) 5 getenv [ die ] or curry (throw) ;
|
||||
: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -41,6 +41,9 @@ DEFER: base>
|
|||
<PRIVATE
|
||||
|
||||
SYMBOL: radix
|
||||
SYMBOL: negative?
|
||||
|
||||
: sign negative? get "-" "+" ? ;
|
||||
|
||||
: with-radix ( radix quot -- )
|
||||
radix swap with-variable ; inline
|
||||
|
@ -48,7 +51,7 @@ SYMBOL: radix
|
|||
: (base>) ( str -- n ) radix get base> ;
|
||||
|
||||
: whole-part ( str -- m n )
|
||||
"+" split1 >r (base>) r>
|
||||
sign split1 >r (base>) r>
|
||||
dup [ (base>) ] [ drop 0 swap ] if ;
|
||||
|
||||
: string>ratio ( str -- a/b )
|
||||
|
@ -70,7 +73,7 @@ PRIVATE>
|
|||
|
||||
: base> ( str radix -- n/f )
|
||||
[
|
||||
"-" ?head >r
|
||||
"-" ?head dup negative? set >r
|
||||
{
|
||||
{ [ CHAR: / over member? ] [ string>ratio ] }
|
||||
{ [ CHAR: . over member? ] [ string>float ] }
|
||||
|
@ -114,9 +117,9 @@ M: integer >base
|
|||
M: ratio >base
|
||||
[
|
||||
[
|
||||
dup 0 < [ "-" % neg ] when
|
||||
dup 0 < dup negative? set [ "-" % neg ] when
|
||||
1 /mod
|
||||
>r dup zero? [ drop ] [ (>base) % "+" % ] if r>
|
||||
>r dup zero? [ drop ] [ (>base) % sign % ] if r>
|
||||
dup numerator (>base) %
|
||||
"/" %
|
||||
denominator (>base) %
|
||||
|
|
|
@ -52,13 +52,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
|
|||
DEFER: optimize-nodes
|
||||
|
||||
: optimize-children ( node -- )
|
||||
[
|
||||
dup node-children dup [
|
||||
[ optimize-nodes ] map swap set-node-children
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] when* ;
|
||||
[ optimize-nodes ] change-children ;
|
||||
|
||||
: optimize-node ( node -- node )
|
||||
dup [
|
||||
|
@ -76,39 +70,17 @@ DEFER: optimize-nodes
|
|||
|
||||
M: f set-node-successor 2drop ;
|
||||
|
||||
: (optimize-nodes) ( prev node -- )
|
||||
optimize-node [
|
||||
dup rot set-node-successor
|
||||
dup node-successor (optimize-nodes)
|
||||
] [
|
||||
f swap set-node-successor
|
||||
] if* ;
|
||||
|
||||
: optimize-nodes ( node -- newnode )
|
||||
[
|
||||
class-substitutions [ clone ] change
|
||||
literal-substitutions [ clone ] change
|
||||
dup [
|
||||
optimize-node
|
||||
dup dup node-successor (optimize-nodes)
|
||||
] when optimizer-changed get
|
||||
[ optimize-node ] transform-nodes
|
||||
optimizer-changed get
|
||||
] with-scope optimizer-changed set ;
|
||||
|
||||
: prune-if ( node quot -- successor/t )
|
||||
over >r call [ r> node-successor t ] [ r> drop t f ] if ;
|
||||
inline
|
||||
|
||||
! Generic nodes
|
||||
M: node optimize-node* drop t f ;
|
||||
|
||||
M: #shuffle optimize-node*
|
||||
[
|
||||
dup node-in-d empty? swap node-out-d empty? and
|
||||
] prune-if ;
|
||||
|
||||
M: #push optimize-node*
|
||||
[ node-out-d empty? ] prune-if ;
|
||||
|
||||
: cleanup-inlining ( node -- newnode changed? )
|
||||
node-successor [ node-successor t ] [ t f ] if* ;
|
||||
|
||||
|
@ -118,12 +90,6 @@ M: #return optimize-node* cleanup-inlining ;
|
|||
! #values
|
||||
M: #values optimize-node* cleanup-inlining ;
|
||||
|
||||
! #>r
|
||||
M: #>r optimize-node* [ node-in-d empty? ] prune-if ;
|
||||
|
||||
! #r>
|
||||
M: #r> optimize-node* [ node-in-r empty? ] prune-if ;
|
||||
|
||||
! Some utilities for splicing in dataflow IR subtrees
|
||||
: follow ( key assoc -- value )
|
||||
2dup at* [ swap follow nip ] [ 2drop ] if ;
|
||||
|
@ -194,10 +160,8 @@ M: node remember-method*
|
|||
|
||||
! Constant branch folding
|
||||
: fold-branch ( node branch# -- node )
|
||||
over drop-inputs >r
|
||||
over node-children nth
|
||||
swap node-successor over substitute-node
|
||||
r> [ set-node-successor ] keep ;
|
||||
swap node-successor over substitute-node ;
|
||||
|
||||
! #if
|
||||
: known-boolean-value? ( node value -- value ? )
|
||||
|
@ -213,12 +177,18 @@ M: node remember-method*
|
|||
] if ;
|
||||
|
||||
M: #if optimize-node*
|
||||
dup dup node-in-d first known-boolean-value?
|
||||
[ 0 1 ? fold-branch t ] [ 2drop t f ] if ;
|
||||
dup dup node-in-d first known-boolean-value? [
|
||||
over drop-inputs >r
|
||||
0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep
|
||||
t
|
||||
] [ 2drop t f ] if ;
|
||||
|
||||
M: #dispatch optimize-node*
|
||||
dup dup node-in-d first 2dup node-literal? [
|
||||
node-literal fold-branch t
|
||||
"Optimizing #dispatch" print
|
||||
node-literal
|
||||
over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
|
||||
] [
|
||||
3drop t f
|
||||
] if ;
|
||||
|
@ -322,9 +292,19 @@ DEFER: (flat-length)
|
|||
#! Make #shuffle -> #push -> #return -> successor
|
||||
dupd literal-quot splice-quot ;
|
||||
|
||||
: optimize-predicate ( #call -- node )
|
||||
: evaluate-predicate ( #call -- ? )
|
||||
dup node-param "predicating" word-prop >r
|
||||
dup node-class-first r> class< 1array inline-literals ;
|
||||
node-class-first r> class< ;
|
||||
|
||||
: optimize-predicate ( #call -- node )
|
||||
dup evaluate-predicate swap
|
||||
dup node-successor #if? [
|
||||
dup drop-inputs >r
|
||||
node-successor swap 0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep
|
||||
] [
|
||||
swap 1array inline-literals
|
||||
] if ;
|
||||
|
||||
: optimizer-hooks ( node -- conditions )
|
||||
node-param "optimizer-hooks" word-prop ;
|
||||
|
|
|
@ -8,7 +8,7 @@ namespaces assocs kernel sequences math tools.test words ;
|
|||
] unit-test
|
||||
|
||||
: kill-set ( quot -- seq )
|
||||
dataflow compute-def-use dead-literals keys
|
||||
dataflow compute-def-use compute-dead-literals keys
|
||||
[ value-literal ] map ;
|
||||
|
||||
: subset? [ member? ] curry all? ;
|
||||
|
|
|
@ -70,19 +70,66 @@ M: #branch node-def-use
|
|||
#! #values node.
|
||||
dup branch-def-use (node-def-use) ;
|
||||
|
||||
: dead-literals ( -- values )
|
||||
! : dead-literals ( -- values )
|
||||
! def-use get [ >r value? r> empty? and ] assoc-subset ;
|
||||
!
|
||||
! : kill-node* ( node values -- )
|
||||
! [ swap remove-all ] curry modify-values ;
|
||||
!
|
||||
! : kill-node ( node values -- )
|
||||
! dup assoc-empty?
|
||||
! [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
|
||||
!
|
||||
! : kill-values ( node -- )
|
||||
! #! Remove literals which are not actually used anywhere.
|
||||
! dead-literals kill-node ;
|
||||
|
||||
: compute-dead-literals ( -- values )
|
||||
def-use get [ >r value? r> empty? and ] assoc-subset ;
|
||||
|
||||
: kill-node* ( node values -- )
|
||||
[ swap remove-all ] curry modify-values ;
|
||||
DEFER: kill-nodes
|
||||
SYMBOL: dead-literals
|
||||
|
||||
: kill-node ( node values -- )
|
||||
dup assoc-empty?
|
||||
[ 2drop ] [ [ kill-node* ] curry each-node ] if ;
|
||||
GENERIC: kill-node* ( node -- node/t )
|
||||
|
||||
: kill-values ( node -- )
|
||||
M: node kill-node* drop t ;
|
||||
|
||||
: prune-if ( node quot -- successor/t )
|
||||
over >r call [ r> node-successor ] [ r> drop t ] if ;
|
||||
inline
|
||||
|
||||
M: #shuffle kill-node*
|
||||
[
|
||||
dup node-in-d empty? swap node-out-d empty? and
|
||||
] prune-if ;
|
||||
|
||||
M: #push kill-node*
|
||||
[ node-out-d empty? ] prune-if ;
|
||||
|
||||
M: #>r kill-node* [ node-in-d empty? ] prune-if ;
|
||||
|
||||
M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
||||
|
||||
: kill-node ( node -- node )
|
||||
dup [
|
||||
dup [ dead-literals get swap remove-all ] modify-values
|
||||
dup kill-node* dup t eq? [
|
||||
drop dup [ kill-nodes ] change-children
|
||||
] [
|
||||
nip kill-node
|
||||
] if
|
||||
] when ;
|
||||
|
||||
: kill-nodes ( node -- newnode )
|
||||
[ kill-node ] transform-nodes ;
|
||||
|
||||
: kill-values ( node -- new-node )
|
||||
#! Remove literals which are not actually used anywhere.
|
||||
dead-literals kill-node ;
|
||||
compute-dead-literals dup assoc-empty? [ drop ] [
|
||||
dead-literals [ kill-nodes ] with-variable
|
||||
] if ;
|
||||
|
||||
!
|
||||
|
||||
: sole-consumer ( #call -- node/f )
|
||||
node-out-d first used-by
|
||||
|
|
|
@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
|
|||
io.streams.string layouts splitting math.intervals
|
||||
math.floats.private tuples tuples.private classes
|
||||
optimizer.def-use optimizer.backend optimizer.pattern-match
|
||||
float-arrays combinators.private combinators ;
|
||||
float-arrays sequences.private combinators ;
|
||||
|
||||
! the output of <tuple> and <tuple-boa> has the class which is
|
||||
! its second-to-last input
|
||||
|
@ -19,6 +19,11 @@ float-arrays combinators.private combinators ;
|
|||
] "output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
\ construct-empty [
|
||||
dup node-in-d peek node-literal
|
||||
dup class? [ drop tuple ] unless 1array f
|
||||
] "output-classes" set-word-prop
|
||||
|
||||
! the output of clone has the same type as the input
|
||||
{ clone (clone) } [
|
||||
[
|
||||
|
@ -98,7 +103,7 @@ float-arrays combinators.private combinators ;
|
|||
[
|
||||
num-types get swap [
|
||||
[
|
||||
[ type>class 0 `input class, ] keep
|
||||
[ type>class object or 0 `input class, ] keep
|
||||
0 `output literal,
|
||||
] set-constraints
|
||||
] curry each
|
||||
|
|
|
@ -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 ] dataflow optimize drop ] unit-test
|
||||
|
||||
[ ] [ [ <tuple> ] 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
|
|
@ -10,7 +10,7 @@ IN: optimizer
|
|||
H{ } clone literal-substitutions set
|
||||
H{ } clone value-substitutions set
|
||||
dup compute-def-use
|
||||
dup kill-values
|
||||
kill-values
|
||||
dup infer-classes
|
||||
optimizer-changed off
|
||||
optimize-nodes
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic hashtables kernel kernel.private math
|
||||
namespaces sequences vectors words strings layouts combinators
|
||||
combinators.private classes generic.standard assocs ;
|
||||
sequences.private classes generic.standard assocs ;
|
||||
IN: optimizer.specializers
|
||||
|
||||
: (make-specializer) ( class picker -- quot )
|
||||
|
|
|
@ -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
|
||||
|
@ -107,6 +107,7 @@ M: bad-escape summary drop "Bad escape code" ;
|
|||
|
||||
: escape ( escape -- ch )
|
||||
H{
|
||||
{ CHAR: a CHAR: \a }
|
||||
{ CHAR: e CHAR: \e }
|
||||
{ CHAR: n CHAR: \n }
|
||||
{ CHAR: r CHAR: \r }
|
||||
|
@ -479,7 +480,7 @@ SYMBOL: interactive-vocabs
|
|||
[ [ parse-file call ] keep ] assert-depth drop ;
|
||||
|
||||
: ?run-file ( path -- )
|
||||
dup ?resource-path exists? [ run-file ] [ drop ] if ;
|
||||
dup resource-exists? [ run-file ] [ drop ] if ;
|
||||
|
||||
: bootstrap-file ( path -- )
|
||||
[ parse-file % ] [ run-file ] if-bootstrapping ;
|
||||
|
|
|
@ -58,6 +58,7 @@ M: f pprint* drop \ f pprint-word ;
|
|||
! Strings
|
||||
: ch>ascii-escape ( ch -- str )
|
||||
H{
|
||||
{ CHAR: \a CHAR: a }
|
||||
{ CHAR: \e CHAR: e }
|
||||
{ CHAR: \n CHAR: n }
|
||||
{ CHAR: \r CHAR: r }
|
||||
|
@ -135,6 +136,7 @@ GENERIC: pprint-delims ( obj -- start end )
|
|||
|
||||
M: quotation pprint-delims drop \ [ \ ] ;
|
||||
M: curry pprint-delims drop \ [ \ ] ;
|
||||
M: compose pprint-delims drop \ [ \ ] ;
|
||||
M: array pprint-delims drop \ { \ } ;
|
||||
M: byte-array pprint-delims drop \ B{ \ } ;
|
||||
M: byte-vector pprint-delims drop \ BV{ \ } ;
|
||||
|
@ -156,6 +158,8 @@ M: vector >pprint-sequence ;
|
|||
M: bit-vector >pprint-sequence ;
|
||||
M: byte-vector >pprint-sequence ;
|
||||
M: float-vector >pprint-sequence ;
|
||||
M: curry >pprint-sequence ;
|
||||
M: compose >pprint-sequence ;
|
||||
M: hashtable >pprint-sequence >alist ;
|
||||
M: tuple >pprint-sequence tuple>array ;
|
||||
M: wrapper >pprint-sequence wrapped 1array ;
|
||||
|
@ -178,9 +182,20 @@ M: tuple pprint-narrow? drop t ;
|
|||
>pprint-sequence pprint-elements
|
||||
block> r> pprint-word block>
|
||||
] check-recursion ;
|
||||
|
||||
|
||||
M: object pprint* pprint-object ;
|
||||
|
||||
M: curry pprint*
|
||||
dup curry-quot callable? [ pprint-object ] [
|
||||
"( invalid curry )" swap present-text
|
||||
] if ;
|
||||
|
||||
M: compose pprint*
|
||||
dup compose-first over compose-second [ callable? ] both?
|
||||
[ pprint-object ] [
|
||||
"( invalid compose )" swap present-text
|
||||
] if ;
|
||||
|
||||
M: wrapper pprint*
|
||||
dup wrapped word? [
|
||||
<block \ \ pprint-word wrapped pprint-word block>
|
||||
|
|
|
@ -321,3 +321,7 @@ unit-test
|
|||
[ [ 2 . ] ] [
|
||||
[ 2 \ break (step-into) . ] (remove-breakpoints)
|
||||
] unit-test
|
||||
|
||||
[ ] [ 1 \ + curry unparse drop ] unit-test
|
||||
|
||||
[ ] [ 1 \ + compose unparse drop ] unit-test
|
||||
|
|
|
@ -15,4 +15,4 @@ IN: temporary
|
|||
|
||||
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
|
||||
|
||||
[ 1 \ + curry ] must-fail
|
||||
! [ 1 \ + curry ] must-fail
|
||||
|
|
|
@ -1,13 +1,20 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays sequences sequences.private
|
||||
kernel kernel.private math assocs quotations.private ;
|
||||
kernel kernel.private math assocs quotations.private
|
||||
slots.private ;
|
||||
IN: quotations
|
||||
|
||||
M: quotation call (call) ;
|
||||
|
||||
M: curry call dup 4 slot swap 5 slot call ;
|
||||
|
||||
M: compose call dup 4 slot swap 5 slot slip call ;
|
||||
|
||||
M: wrapper equal?
|
||||
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
|
||||
|
||||
UNION: callable quotation curry ;
|
||||
UNION: callable quotation curry compose ;
|
||||
|
||||
M: callable equal?
|
||||
over callable? [ sequence= ] [ 2drop f ] if ;
|
||||
|
@ -19,7 +26,7 @@ M: quotation nth-unsafe quotation-array nth-unsafe ;
|
|||
: >quotation ( seq -- quot )
|
||||
>array array>quotation ; inline
|
||||
|
||||
M: quotation like drop dup quotation? [ >quotation ] unless ;
|
||||
M: callable like drop dup quotation? [ >quotation ] unless ;
|
||||
|
||||
INSTANCE: quotation immutable-sequence
|
||||
|
||||
|
@ -40,6 +47,17 @@ M: curry nth
|
|||
>r 1- r> curry-quot nth
|
||||
] if ;
|
||||
|
||||
M: curry like drop dup callable? [ >quotation ] unless ;
|
||||
|
||||
INSTANCE: curry immutable-sequence
|
||||
|
||||
M: compose length
|
||||
dup compose-first length
|
||||
swap compose-second length + ;
|
||||
|
||||
M: compose nth
|
||||
2dup compose-first length < [
|
||||
compose-first
|
||||
] [
|
||||
[ compose-first length - ] keep compose-second
|
||||
] if nth ;
|
||||
|
||||
INSTANCE: compose immutable-sequence
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: sequences
|
||||
USING: kernel kernel.private slots.private math math.private ;
|
||||
|
@ -77,6 +77,8 @@ PREDICATE: fixnum array-capacity
|
|||
: set-array-nth ( elt n array -- )
|
||||
swap 2 fixnum+fast set-slot ; inline
|
||||
|
||||
: dispatch ( n array -- ) array-nth (call) ;
|
||||
|
||||
GENERIC: resize ( n seq -- newseq ) flushable
|
||||
|
||||
! Unsafe sequence protocol for inner loops
|
||||
|
@ -606,7 +608,29 @@ M: sequence <=>
|
|||
] if ;
|
||||
|
||||
: cut-slice ( seq n -- before after )
|
||||
[ head ] 2keep tail-slice ;
|
||||
[ head-slice ] 2keep tail-slice ;
|
||||
|
||||
: midpoint@ ( seq -- n ) length 2/ ; inline
|
||||
|
||||
: halves ( seq -- first second )
|
||||
dup midpoint@ cut-slice ;
|
||||
|
||||
: binary-reduce ( seq start quot -- value )
|
||||
#! We can't use case here since combinators depends on
|
||||
#! sequences
|
||||
pick length dup 0 3 between? [
|
||||
>fixnum {
|
||||
[ drop nip ]
|
||||
[ 2drop first ]
|
||||
[ >r drop first2 r> call ]
|
||||
[ >r drop first3 r> 2apply ]
|
||||
} dispatch
|
||||
] [
|
||||
drop
|
||||
>r >r halves r> r>
|
||||
[ [ binary-reduce ] 2curry 2apply ] keep
|
||||
call
|
||||
] if ; inline
|
||||
|
||||
: cut ( seq n -- before after )
|
||||
[ head ] 2keep tail ;
|
||||
|
@ -657,8 +681,8 @@ PRIVATE>
|
|||
: trim ( seq quot -- newseq )
|
||||
[ left-trim ] keep right-trim ; inline
|
||||
|
||||
: sum ( seq -- n ) 0 [ + ] reduce ;
|
||||
: product ( seq -- n ) 1 [ * ] reduce ;
|
||||
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
|
||||
: product ( seq -- n ) 1 [ * ] binary-reduce ;
|
||||
|
||||
: infimum ( seq -- n ) dup first [ min ] reduce ;
|
||||
: supremum ( seq -- n ) dup first [ max ] reduce ;
|
||||
|
|
|
@ -4,8 +4,6 @@ USING: arrays kernel math sequences vectors
|
|||
sequences sequences.private growable ;
|
||||
IN: sorting
|
||||
|
||||
: midpoint@ ( seq -- n ) length 2/ ; inline
|
||||
|
||||
DEFER: sort
|
||||
|
||||
<PRIVATE
|
||||
|
@ -38,9 +36,6 @@ DEFER: sort
|
|||
rot length rot length + <vector>
|
||||
[ (merge) ] keep underlying ; inline
|
||||
|
||||
: divide ( seq -- first second )
|
||||
dup midpoint@ [ head-slice ] 2keep tail-slice ;
|
||||
|
||||
: conquer ( first second quot -- result )
|
||||
[ tuck >r >r sort r> r> sort ] keep merge ; inline
|
||||
|
||||
|
@ -48,7 +43,7 @@ PRIVATE>
|
|||
|
||||
: sort ( seq quot -- sortedseq )
|
||||
over length 1 <=
|
||||
[ drop ] [ over >r >r divide r> conquer r> like ] if ;
|
||||
[ drop ] [ over >r >r halves r> conquer r> like ] if ;
|
||||
inline
|
||||
|
||||
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
|
||||
|
@ -63,8 +58,7 @@ PRIVATE>
|
|||
[ midpoint@ ] keep nth-unsafe ; inline
|
||||
|
||||
: partition ( seq n -- slice )
|
||||
>r dup midpoint@ r> 1 < [ head-slice ] [ tail-slice ] if ;
|
||||
inline
|
||||
1 < swap halves ? ; inline
|
||||
|
||||
: (binsearch) ( elt quot seq -- i )
|
||||
dup length 1 <= [
|
||||
|
|
|
@ -26,7 +26,7 @@ uses definitions ;
|
|||
rot source-file-checksum
|
||||
(source-modified?)
|
||||
] [
|
||||
?resource-path exists?
|
||||
resource-exists?
|
||||
] ?if ;
|
||||
|
||||
: record-modified ( source-file -- )
|
||||
|
|
|
@ -49,7 +49,7 @@ PRIVATE>
|
|||
V{ } set-catchstack
|
||||
{ } set-retainstack
|
||||
[ [ print-error ] recover stop ] call-clear
|
||||
] (throw)
|
||||
] 1 (throw)
|
||||
] curry callcc0 ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -42,23 +42,9 @@ HELP: vocab-main
|
|||
HELP: vocab-roots
|
||||
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
|
||||
|
||||
HELP: vocab-source
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
|
||||
{ $description "Outputs a pathname relative to a vocabulary root where the source code for " { $snippet "vocab" } " might be found." } ;
|
||||
|
||||
{ vocab-source vocab-source-path } related-words
|
||||
|
||||
HELP: vocab-docs
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
|
||||
{ $description "Outputs a pathname relative to a vocabulary root where the documentation for " { $snippet "vocab" } " might be found." } ;
|
||||
|
||||
{ vocab-docs vocab-docs-path } related-words
|
||||
|
||||
HELP: vocab-tests
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
|
||||
{ $description "Outputs a pathname relative to a vocabulary root where the unit tests for " { $snippet "vocab" } " might be found." } ;
|
||||
|
||||
{ vocab-tests vocab-tests-path } related-words
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
|
||||
{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
|
||||
|
||||
HELP: find-vocab-root
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
|
||||
|
@ -86,14 +72,6 @@ HELP: load-docs
|
|||
{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } }
|
||||
{ $description "If " { $link load-help? } " is on, loads a vocabulary's documentation from the specified vocabulary root." } ;
|
||||
|
||||
HELP: amend-vocab-from-root
|
||||
{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } { "vocab" vocab } }
|
||||
{ $description "Loads a vocabulary's source code and documentation if they have not already been loaded, and outputs the vocabulary." } ;
|
||||
|
||||
HELP: load-vocab-from-root
|
||||
{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } }
|
||||
{ $description "Loads a vocabulary's source code and documentation." } ;
|
||||
|
||||
HELP: reload
|
||||
{ $values { "name" "a vocabulary name" } }
|
||||
{ $description "Loads it's source code and documentation." }
|
||||
|
@ -116,10 +94,6 @@ HELP: vocab-docs-path
|
|||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
|
||||
{ $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
|
||||
|
||||
HELP: vocab-tests-path
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
|
||||
{ $description "Outputs a pathname where the unit tests for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
|
||||
|
||||
HELP: refresh
|
||||
{ $values { "prefix" string } }
|
||||
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Eduardo Cavazos, Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces splitting sequences io.files kernel assocs
|
||||
words vocabs definitions parser continuations inspector debugger
|
||||
|
@ -15,49 +15,64 @@ V{
|
|||
"resource:work"
|
||||
} clone vocab-roots set-global
|
||||
|
||||
! No such thing as current directory on Windows CE
|
||||
wince? [ "." vocab-roots get push ] unless
|
||||
: vocab-dir ( vocab -- dir )
|
||||
vocab-name "." split "/" join ;
|
||||
|
||||
: vocab-dir+ ( vocab str/f -- path )
|
||||
>r vocab-name "." split r>
|
||||
[ >r dup peek r> append add ] when*
|
||||
"/" join ;
|
||||
|
||||
: vocab-dir ( vocab -- dir )
|
||||
f vocab-dir+ ;
|
||||
: vocab-path+ ( vocab path -- newpath )
|
||||
swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
|
||||
|
||||
: vocab-source ( vocab -- path )
|
||||
".factor" vocab-dir+ ;
|
||||
: vocab-source-path ( vocab -- path/f )
|
||||
dup ".factor" vocab-dir+ vocab-path+ ;
|
||||
|
||||
: vocab-docs ( vocab -- path )
|
||||
"-docs.factor" vocab-dir+ ;
|
||||
: vocab-docs-path ( vocab -- path/f )
|
||||
dup "-docs.factor" vocab-dir+ vocab-path+ ;
|
||||
|
||||
: vocab-tests ( vocab -- path )
|
||||
"-tests.factor" vocab-dir+ ;
|
||||
: vocab-dir? ( root name -- ? )
|
||||
over [
|
||||
".factor" vocab-dir+ path+ resource-exists?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: find-vocab-root ( vocab -- path/f )
|
||||
vocab-dir vocab-roots get
|
||||
swap [ path+ ?resource-path exists? ] curry find nip ;
|
||||
vocab-roots get swap [ vocab-dir? ] curry find nip ;
|
||||
|
||||
M: string vocab-root
|
||||
dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
|
||||
|
||||
M: vocab-link vocab-root
|
||||
dup vocab-link-root [ ] [ vocab-link-name vocab-root ] ?if ;
|
||||
vocab-link-root ;
|
||||
|
||||
: vocab-tests ( vocab -- tests )
|
||||
dup vocab-root [
|
||||
[
|
||||
f >vocab-link dup
|
||||
|
||||
dup "-tests.factor" vocab-dir+ vocab-path+
|
||||
dup resource-exists? [ , ] [ drop ] if
|
||||
|
||||
dup vocab-dir "tests" path+ vocab-path+ dup
|
||||
?resource-path directory keys [ ".factor" tail? ] subset
|
||||
[ path+ , ] with each
|
||||
] { } make
|
||||
] [ drop f ] if ;
|
||||
|
||||
: vocab-files ( vocab -- seq )
|
||||
[
|
||||
dup vocab-root dup [
|
||||
swap
|
||||
2dup vocab-source path+ ,
|
||||
2dup vocab-docs path+ ,
|
||||
2dup vocab-tests path+ ,
|
||||
] when 2drop
|
||||
] { } make [ ?resource-path exists? ] subset ;
|
||||
f >vocab-link [
|
||||
dup vocab-source-path [ , ] when*
|
||||
dup vocab-docs-path [ , ] when*
|
||||
vocab-tests %
|
||||
] { } make ;
|
||||
|
||||
TUPLE: no-vocab name ;
|
||||
|
||||
: no-vocab ( name -- * ) \ no-vocab construct-boa throw ;
|
||||
: no-vocab ( name -- * )
|
||||
vocab-name \ no-vocab construct-boa throw ;
|
||||
|
||||
M: no-vocab summary drop "Vocabulary does not exist" ;
|
||||
|
||||
|
@ -67,42 +82,36 @@ SYMBOL: load-help?
|
|||
|
||||
: source-wasn't-loaded f swap set-vocab-source-loaded? ;
|
||||
|
||||
: load-source ( root name -- )
|
||||
: load-source ( vocab-link -- )
|
||||
[ source-wasn't-loaded ] keep
|
||||
[ vocab-source path+ bootstrap-file ] keep
|
||||
[ vocab-source-path bootstrap-file ] keep
|
||||
source-was-loaded ;
|
||||
|
||||
: docs-were-loaded t swap set-vocab-docs-loaded? ;
|
||||
|
||||
: docs-weren't-loaded f swap set-vocab-docs-loaded? ;
|
||||
|
||||
: load-docs ( root name -- )
|
||||
: load-docs ( vocab-link -- )
|
||||
load-help? get [
|
||||
[ docs-weren't-loaded ] keep
|
||||
[ vocab-docs path+ ?run-file ] keep
|
||||
[ vocab-docs-path ?run-file ] keep
|
||||
docs-were-loaded
|
||||
] [ 2drop ] if ;
|
||||
] [ drop ] if ;
|
||||
|
||||
: amend-vocab-from-root ( root name -- vocab )
|
||||
dup vocab-source-loaded? [ 2dup load-source ] unless
|
||||
dup vocab-docs-loaded? [ 2dup load-docs ] unless
|
||||
nip vocab ;
|
||||
|
||||
: load-vocab-from-root ( root name -- )
|
||||
2dup vocab-source path+ ?resource-path exists? [
|
||||
2dup create-vocab set-vocab-root
|
||||
2dup load-source load-docs
|
||||
] [
|
||||
nip no-vocab
|
||||
] if ;
|
||||
: create-vocab-with-root ( vocab-link -- vocab )
|
||||
dup vocab-name create-vocab
|
||||
swap vocab-root over set-vocab-root ;
|
||||
|
||||
: reload ( name -- )
|
||||
[
|
||||
dup find-vocab-root dup [
|
||||
swap load-vocab-from-root
|
||||
] [
|
||||
drop no-vocab
|
||||
] if
|
||||
f >vocab-link
|
||||
dup vocab-root [
|
||||
dup vocab-source-path resource-exists? [
|
||||
create-vocab-with-root
|
||||
dup load-source
|
||||
load-docs
|
||||
] [ no-vocab ] if
|
||||
] [ no-vocab ] if
|
||||
] with-compiler-errors ;
|
||||
|
||||
: require ( vocab -- )
|
||||
|
@ -122,18 +131,6 @@ SYMBOL: load-help?
|
|||
[ nip ] assoc-subset
|
||||
[ nip source-modified? ] assoc-subset keys ; inline
|
||||
|
||||
: vocab-path+ ( vocab path -- newpath )
|
||||
swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
|
||||
|
||||
: vocab-source-path ( vocab -- path/f )
|
||||
dup vocab-source vocab-path+ ;
|
||||
|
||||
: vocab-tests-path ( vocab -- path/f )
|
||||
dup vocab-tests vocab-path+ ;
|
||||
|
||||
: vocab-docs-path ( vocab -- path/f )
|
||||
dup vocab-docs vocab-path+ ;
|
||||
|
||||
: modified-sources ( vocabs -- seq )
|
||||
[ vocab-source-path ] modified ;
|
||||
|
||||
|
@ -151,27 +148,28 @@ SYMBOL: load-help?
|
|||
: vocab-heading. ( vocab -- )
|
||||
nl
|
||||
"==== " write
|
||||
dup vocab-name swap f >vocab-link write-object ":" print
|
||||
dup vocab-name swap vocab write-object ":" print
|
||||
nl ;
|
||||
|
||||
: load-error. ( triple -- )
|
||||
dup first vocab-heading.
|
||||
dup second print-error
|
||||
drop ;
|
||||
! third "Traceback" swap write-object ;
|
||||
|
||||
: load-failures. ( failures -- )
|
||||
[ load-error. nl ] each ;
|
||||
|
||||
SYMBOL: blacklist
|
||||
|
||||
: require-all ( vocabs -- failures )
|
||||
[
|
||||
V{ } clone blacklist set
|
||||
[
|
||||
[
|
||||
[ require ]
|
||||
[ error-continuation get 3array , ]
|
||||
recover
|
||||
] each
|
||||
] { } make
|
||||
[ require ]
|
||||
[ >r vocab-name r> 2array blacklist get push ]
|
||||
recover
|
||||
] each
|
||||
blacklist get
|
||||
] with-compiler-errors ;
|
||||
|
||||
: do-refresh ( modified-sources modified-docs -- )
|
||||
|
@ -185,10 +183,12 @@ SYMBOL: load-help?
|
|||
: refresh-all ( -- ) "" refresh ;
|
||||
|
||||
GENERIC: (load-vocab) ( name -- vocab )
|
||||
|
||||
!
|
||||
M: vocab (load-vocab)
|
||||
dup vocab-root
|
||||
[ swap vocab-name amend-vocab-from-root ] when* ;
|
||||
dup vocab-root [
|
||||
dup vocab-source-loaded? [ dup load-source ] unless
|
||||
dup vocab-docs-loaded? [ dup load-docs ] unless
|
||||
] when ;
|
||||
|
||||
M: string (load-vocab)
|
||||
[ ".private" ?tail drop reload ] keep vocab ;
|
||||
|
@ -196,8 +196,25 @@ M: string (load-vocab)
|
|||
M: vocab-link (load-vocab)
|
||||
vocab-name (load-vocab) ;
|
||||
|
||||
[ [ dup vocab [ ] [ ] ?if (load-vocab) ] with-compiler-errors ]
|
||||
load-vocab-hook set-global
|
||||
TUPLE: blacklisted-vocab name ;
|
||||
|
||||
: blacklisted-vocab ( name -- * )
|
||||
\ blacklisted-vocab construct-boa throw ;
|
||||
|
||||
M: blacklisted-vocab error.
|
||||
"This vocabulary depends on the " write
|
||||
blacklisted-vocab-name write
|
||||
" vocabulary which failed to load" print ;
|
||||
|
||||
[
|
||||
dup vocab-name blacklist get key? [
|
||||
vocab-name blacklisted-vocab
|
||||
] [
|
||||
[
|
||||
dup vocab [ ] [ ] ?if (load-vocab)
|
||||
] with-compiler-errors
|
||||
] if
|
||||
] load-vocab-hook set-global
|
||||
|
||||
: vocab-where ( vocab -- loc )
|
||||
vocab-source-path dup [ 1 2array ] when ;
|
||||
|
|
|
@ -85,7 +85,8 @@ SYMBOL: load-vocab-hook
|
|||
|
||||
TUPLE: vocab-link name root ;
|
||||
|
||||
C: <vocab-link> vocab-link
|
||||
: <vocab-link> ( name root -- vocab-link )
|
||||
[ dup vocab-root ] unless* vocab-link construct-boa ;
|
||||
|
||||
M: vocab-link equal?
|
||||
over vocab-link?
|
||||
|
@ -96,7 +97,13 @@ M: vocab-link hashcode*
|
|||
|
||||
M: vocab-link vocab-name vocab-link-name ;
|
||||
|
||||
: >vocab-link ( name root -- vocab )
|
||||
GENERIC# >vocab-link 1 ( name root -- vocab )
|
||||
|
||||
M: vocab >vocab-link drop ;
|
||||
|
||||
M: vocab-link >vocab-link drop ;
|
||||
|
||||
M: string >vocab-link
|
||||
over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
|
||||
|
||||
UNION: vocab-spec vocab vocab-link ;
|
||||
|
|
|
@ -115,7 +115,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
|
|||
compiled-crossref get at ;
|
||||
|
||||
M: word redefined* ( word -- )
|
||||
{ "inferred-effect" "base-case" "no-effect" } reset-props ;
|
||||
{ "inferred-effect" "no-effect" } reset-props ;
|
||||
|
||||
SYMBOL: changed-words
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.test base64 ;
|
||||
USING: kernel tools.test base64 strings ;
|
||||
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
|
||||
] unit-test
|
||||
|
|
|
@ -35,13 +35,13 @@ PRIVATE>
|
|||
#! pad string with = when not enough bits
|
||||
dup length dup 3 mod - cut swap
|
||||
[
|
||||
3 group [ encode3 % ] each
|
||||
3 <groups> [ encode3 % ] each
|
||||
dup empty? [ drop ] [ >base64-rem % ] if
|
||||
] "" make ;
|
||||
|
||||
: base64> ( base64 -- str )
|
||||
#! input length must be a multiple of 4
|
||||
[
|
||||
[ 4 group [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
|
||||
[ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
|
||||
] SBUF" " make swap [ dup pop* ] times >string ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel.private kernel sequences math combinators
|
||||
combinators.private ;
|
||||
sequences.private ;
|
||||
IN: benchmark.dispatch4
|
||||
|
||||
: foobar-1
|
||||
|
|
|
@ -0,0 +1,43 @@
|
|||
USING: io.sockets io.server io kernel math threads debugger
|
||||
concurrency tools.time prettyprint ;
|
||||
IN: benchmark.sockets
|
||||
|
||||
: simple-server ( -- )
|
||||
7777 local-server "benchmark.sockets" [
|
||||
read1 CHAR: x = [
|
||||
stop-server
|
||||
] [
|
||||
20 [ read1 write1 flush ] times
|
||||
] if
|
||||
] with-server ;
|
||||
|
||||
: simple-client ( -- )
|
||||
"localhost" 7777 <inet> <client> [
|
||||
CHAR: b write1 flush
|
||||
20 [ CHAR: a dup write1 flush read1 assert= ] times
|
||||
] with-stream ;
|
||||
|
||||
: stop-server ( -- )
|
||||
"localhost" 7777 <inet> <client> [
|
||||
CHAR: x write1
|
||||
] with-stream ;
|
||||
|
||||
: socket-benchmark ( n -- )
|
||||
dup pprint " clients: " write
|
||||
[
|
||||
[ simple-server ] in-thread
|
||||
100 sleep
|
||||
[ drop simple-client ] parallel-each
|
||||
stop-server
|
||||
yield yield
|
||||
] time ;
|
||||
|
||||
: socket-benchmarks
|
||||
10 socket-benchmark
|
||||
20 socket-benchmark
|
||||
40 socket-benchmark
|
||||
80 socket-benchmark
|
||||
160 socket-benchmark
|
||||
320 socket-benchmark ;
|
||||
|
||||
MAIN: socket-benchmarks
|
|
@ -13,13 +13,7 @@ IN: bootstrap.help
|
|||
vocabs
|
||||
[ vocab-root ] subset
|
||||
[ vocab-source-loaded? ] subset
|
||||
[
|
||||
dup vocab-docs-loaded? [
|
||||
drop
|
||||
] [
|
||||
dup vocab-root swap load-docs
|
||||
] if
|
||||
] each
|
||||
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
|
||||
] with-variable
|
||||
|
||||
"help.handbook" require ;
|
||||
|
|
|
@ -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,9 @@
|
|||
|
||||
USING: kernel io io.files io.launcher hashtables tools.deploy.backend
|
||||
USING: kernel io io.files io.launcher io.sockets hashtables math threads
|
||||
system continuations namespaces sequences splitting math.parser
|
||||
prettyprint tools.time calendar bake vars http.client
|
||||
combinators ;
|
||||
combinators bootstrap.image bootstrap.image.download
|
||||
combinators.cleave ;
|
||||
|
||||
IN: builder
|
||||
|
||||
|
@ -29,16 +30,34 @@ IN: builder
|
|||
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
: host-name* ( -- name ) host-name "." split first ;
|
||||
|
||||
: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
|
||||
|
||||
: email-string ( subject -- )
|
||||
`{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
|
||||
[ ] with-process-stream drop ;
|
||||
|
||||
: email-file ( subject file -- )
|
||||
`{
|
||||
{ +stdin+ , }
|
||||
{ +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } }
|
||||
{ +arguments+
|
||||
{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
|
||||
}
|
||||
>hashtable run-process drop ;
|
||||
|
||||
: email-string ( subject -- )
|
||||
`{ "mutt" "-s" , %[ builder-recipients get ] }
|
||||
[ ] with-process-stream drop ;
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: run-or-notify ( desc message -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ email-string throw ] curry ]
|
||||
bi*
|
||||
recover ;
|
||||
|
||||
: run-or-send-file ( desc message file -- )
|
||||
>r >r [ try-process ] curry
|
||||
r> r> [ email-file throw ] 2curry
|
||||
recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -59,87 +78,231 @@ VAR: stamp
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: build ( -- )
|
||||
|
||||
datestamp >stamp
|
||||
|
||||
"/builds/factor" cd
|
||||
|
||||
: git-pull ( -- desc )
|
||||
{
|
||||
"git"
|
||||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
! "http://dharmatech.onigirihouse.com/factor.git"
|
||||
"master"
|
||||
}
|
||||
run-process process-status
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: git pull" email-string
|
||||
"builder: git pull" throw
|
||||
]
|
||||
if
|
||||
} ;
|
||||
|
||||
"/builds/" stamp> append make-directory
|
||||
"/builds/" stamp> append cd
|
||||
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
|
||||
|
||||
{ "git" "clone" "../factor" } run-process drop
|
||||
: enter-build-dir ( -- )
|
||||
datestamp >stamp
|
||||
"/builds" cd
|
||||
stamp> make-directory
|
||||
stamp> cd ;
|
||||
|
||||
"factor" cd
|
||||
: git-id ( -- id )
|
||||
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
|
||||
|
||||
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second
|
||||
"../git-id" log-object
|
||||
: record-git-id ( -- ) git-id "../git-id" log-object ;
|
||||
|
||||
{ "make" "clean" } run-process drop
|
||||
: make-clean ( -- desc ) { "make" "clean" } ;
|
||||
|
||||
: make-vm ( -- )
|
||||
`{
|
||||
{ +arguments+ { "make" ,[ target ] } }
|
||||
{ +stdout+ "../compile-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable run-process process-status
|
||||
0 =
|
||||
>hashtable ;
|
||||
|
||||
: retrieve-boot-image ( -- )
|
||||
[ my-arch download-image ]
|
||||
[ ]
|
||||
[
|
||||
"builder: vm compile" "../compile-log" email-file
|
||||
"builder: vm compile" throw
|
||||
] if
|
||||
|
||||
[ "http://factorcode.org/images/latest/" boot-image-name append download ]
|
||||
[ "builder: image download" email-string ]
|
||||
recover
|
||||
cleanup
|
||||
flush ;
|
||||
|
||||
: bootstrap ( -- desc )
|
||||
`{
|
||||
{ +arguments+ {
|
||||
,[ factor-binary ]
|
||||
,[ "-i=" boot-image-name append ]
|
||||
,[ "-i=" my-boot-image-name append ]
|
||||
"-no-user-init"
|
||||
} }
|
||||
{ +stdout+ "../boot-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable [ run-process ] "../boot-time" log-runtime process-status
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: bootstrap" "../boot-log" email-file
|
||||
"builder: bootstrap" throw
|
||||
] if
|
||||
>hashtable ;
|
||||
|
||||
`{ ,[ factor-binary ] "-run=builder.test" } run-process drop
|
||||
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
|
||||
|
||||
"../load-everything-log" exists?
|
||||
[ "builder: load-everything" "../load-everything-log" email-file ]
|
||||
when
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
"../failing-tests" exists?
|
||||
[ "builder: failing tests" "../failing-tests" email-file ]
|
||||
when
|
||||
! SYMBOL: build-status
|
||||
|
||||
;
|
||||
! : build ( -- )
|
||||
|
||||
! enter-build-dir
|
||||
|
||||
! git-clone "git clone error" run-or-notify
|
||||
|
||||
! "factor" cd
|
||||
|
||||
! record-git-id
|
||||
|
||||
! make-clean "make clean error" run-or-notify
|
||||
|
||||
! make-vm "vm compile error" "../compile-log" run-or-send-file
|
||||
|
||||
! retrieve-boot-image
|
||||
|
||||
! bootstrap "bootstrap error" "../boot-log" run-or-send-file
|
||||
|
||||
! builder-test "builder.test fatal error" run-or-notify
|
||||
|
||||
! "../load-everything-log" exists?
|
||||
! [ "load-everything" "../load-everything-log" email-file ]
|
||||
! when
|
||||
|
||||
! "../failing-tests" exists?
|
||||
! [ "failing tests" "../failing-tests" email-file ]
|
||||
! when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MAIN: build
|
||||
SYMBOL: report
|
||||
|
||||
: (build) ( -- )
|
||||
|
||||
enter-build-dir
|
||||
|
||||
"report" <file-writer> report set
|
||||
|
||||
report get [ "Build machine: " write host-name write nl ] with-stream*
|
||||
|
||||
report get [ "Build directory: " write cwd write nl ] with-stream*
|
||||
|
||||
[ git-clone try-process ]
|
||||
[
|
||||
report get
|
||||
[ "Builder fatal error: git clone failed" write nl ]
|
||||
with-stream*
|
||||
throw
|
||||
]
|
||||
recover
|
||||
|
||||
"factor" cd
|
||||
|
||||
record-git-id
|
||||
|
||||
make-clean run-process drop
|
||||
|
||||
[ make-vm try-process ]
|
||||
[
|
||||
report get
|
||||
[
|
||||
"Builder fatal error: vm compile error" write nl
|
||||
"../compile-log" <file-reader> contents write
|
||||
]
|
||||
with-stream*
|
||||
throw
|
||||
]
|
||||
recover
|
||||
|
||||
[ my-arch download-image ]
|
||||
[
|
||||
report get
|
||||
[ "Builder fatal error: image download" write nl ]
|
||||
with-stream*
|
||||
throw
|
||||
]
|
||||
recover
|
||||
|
||||
[ bootstrap try-process ]
|
||||
[
|
||||
report get
|
||||
[
|
||||
"Bootstrap error" write nl
|
||||
"../boot-log" <file-reader> contents write
|
||||
]
|
||||
with-stream*
|
||||
throw
|
||||
]
|
||||
recover
|
||||
|
||||
[ builder-test try-process ]
|
||||
[
|
||||
report get
|
||||
[
|
||||
"Builder test error" write nl
|
||||
"../load-everything-log" exists?
|
||||
[ "../load-everything-log" <file-reader> contents write nl ]
|
||||
when
|
||||
"../test-all-log" exists?
|
||||
[ "../test-all-log" <file-reader> contents write nl ]
|
||||
when
|
||||
]
|
||||
with-stream*
|
||||
throw
|
||||
]
|
||||
recover
|
||||
|
||||
report get
|
||||
[
|
||||
"Bootstrap time: " write
|
||||
"../bootstrap-time" <file-reader> contents write nl
|
||||
]
|
||||
with-stream*
|
||||
|
||||
"../load-everything-vocabs" exists?
|
||||
[
|
||||
report get
|
||||
[
|
||||
"Did not pass load-everything: " write nl
|
||||
"../load-everything-vocabs" <file-reader> contents write nl
|
||||
]
|
||||
with-stream*
|
||||
]
|
||||
when
|
||||
|
||||
"../test-all-vocabs" exists?
|
||||
[
|
||||
report get
|
||||
[
|
||||
"Did not pass test-all: " write nl
|
||||
"../test-all-vocabs" <file-reader> contents write nl
|
||||
]
|
||||
with-stream*
|
||||
]
|
||||
when ;
|
||||
|
||||
: send-report ( -- )
|
||||
report get dispose
|
||||
"report" "../report" email-file ;
|
||||
|
||||
: build ( -- )
|
||||
[ (build) ]
|
||||
[ drop ]
|
||||
recover
|
||||
send-report ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: minutes>ms ( min -- ms ) 60 * 1000 * ;
|
||||
|
||||
: updates-available? ( -- ? )
|
||||
git-id
|
||||
git-pull run-process drop
|
||||
git-id
|
||||
= not ;
|
||||
|
||||
: build-loop ( -- )
|
||||
[
|
||||
"/builds/factor" cd
|
||||
updates-available?
|
||||
[ build ]
|
||||
when
|
||||
]
|
||||
[ drop ]
|
||||
recover
|
||||
5 minutes>ms sleep
|
||||
build-loop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MAIN: build-loop
|
|
@ -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 ;
|
||||
|
|
@ -1,36 +1,63 @@
|
|||
|
||||
USING: kernel sequences assocs builder continuations vocabs vocabs.loader
|
||||
USING: kernel namespaces sequences assocs builder continuations
|
||||
vocabs vocabs.loader
|
||||
io
|
||||
io.files
|
||||
prettyprint
|
||||
tools.browser
|
||||
tools.test ;
|
||||
tools.test
|
||||
bootstrap.stage2 ;
|
||||
|
||||
IN: builder.test
|
||||
|
||||
: record-bootstrap-time ( -- )
|
||||
"../bootstrap-time" <file-writer>
|
||||
[ bootstrap-time get . ]
|
||||
with-stream ;
|
||||
|
||||
: try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ;
|
||||
|
||||
! : do-load ( -- )
|
||||
! [ try-everything* ] "../load-everything-time" log-runtime
|
||||
! dup empty?
|
||||
! [ drop ]
|
||||
! [ "../load-everything-log" log-object ]
|
||||
! if ;
|
||||
|
||||
: do-load ( -- )
|
||||
[
|
||||
[ load-everything ]
|
||||
[ require-all-error-vocabs "../load-everything-log" log-object ]
|
||||
recover
|
||||
]
|
||||
"../load-everything-time" log-runtime ;
|
||||
"../load-everything-log" <file-writer>
|
||||
[ try-everything* ]
|
||||
with-stream
|
||||
] "../load-everything-time" log-runtime
|
||||
dup empty?
|
||||
[ drop ]
|
||||
[ "../load-everything-vocabs" log-object ]
|
||||
if
|
||||
"../load-everything-log" delete-file ;
|
||||
|
||||
! : do-tests ( -- )
|
||||
! run-all-tests keys
|
||||
! dup empty?
|
||||
! [ drop ]
|
||||
! [ "../failing-tests" 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
|
||||
dup empty?
|
||||
[ drop ]
|
||||
[
|
||||
"../failing-tests" <file-writer>
|
||||
[ [ nl failures. ] assoc-each ]
|
||||
"../test-all-log" <file-writer>
|
||||
[ run-all-tests keys ]
|
||||
with-stream
|
||||
]
|
||||
if ;
|
||||
] "../test-all-time" log-runtime
|
||||
dup empty?
|
||||
[ drop ]
|
||||
[ "../test-all-vocabs" log-object ]
|
||||
if
|
||||
"../test-all-log" delete-file ;
|
||||
|
||||
: do-all ( -- ) do-load do-tests ;
|
||||
: do-all ( -- )
|
||||
record-bootstrap-time
|
||||
do-load
|
||||
do-tests ;
|
||||
|
||||
MAIN: do-all
|
|
@ -58,6 +58,7 @@ SYMBOL: super-sent-messages
|
|||
"NSPasteboard"
|
||||
"NSResponder"
|
||||
"NSSavePanel"
|
||||
"NSScreen"
|
||||
"NSView"
|
||||
"NSWindow"
|
||||
"NSWorkspace"
|
||||
|
|
|
@ -47,42 +47,6 @@ HELP: nkeep
|
|||
}
|
||||
{ $see-also keep nslip } ;
|
||||
|
||||
HELP: map-withn
|
||||
{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }
|
||||
{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "
|
||||
"passed to the quotation given to map-withn for each element in the sequence."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }
|
||||
}
|
||||
{ $see-also each-withn } ;
|
||||
|
||||
HELP: each-withn
|
||||
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
|
||||
{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "
|
||||
"passed to the quotation given to each-withn for each element in the sequence."
|
||||
}
|
||||
{ $see-also map-withn } ;
|
||||
|
||||
HELP: sigma
|
||||
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
|
||||
{ $description "Like map sum, but without creating an intermediate sequence." }
|
||||
{ $example
|
||||
"! Find the sum of the squares [0,99]"
|
||||
"USING: math.ranges combinators.lib ;"
|
||||
"100 [1,b] [ sq ] sigma ."
|
||||
"338350"
|
||||
} ;
|
||||
|
||||
HELP: count
|
||||
{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
|
||||
{ $description "Efficiently returns the number of elements that the predicate quotation matches." }
|
||||
{ $example
|
||||
"USING: math.ranges combinators.lib ;"
|
||||
"100 [1,b] [ even? ] count ."
|
||||
"50"
|
||||
} ;
|
||||
|
||||
HELP: &&
|
||||
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
|
||||
{ $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ;
|
||||
|
|
|
@ -4,11 +4,7 @@ IN: temporary
|
|||
|
||||
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
|
||||
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
|
||||
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
|
||||
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
|
||||
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
|
||||
|
||||
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
|
||||
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
|
||||
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
|
||||
|
||||
|
@ -17,11 +13,6 @@ IN: temporary
|
|||
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
|
||||
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
|
||||
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
|
||||
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
|
||||
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
|
||||
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
|
||||
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
|
||||
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
|
||||
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
|
||||
[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
|
||||
[ [ sq ] 3apply ] must-infer
|
||||
|
@ -55,5 +46,3 @@ IN: temporary
|
|||
[ dup array? ] [ dup vector? ] [ dup float? ]
|
||||
} || nip
|
||||
] unit-test
|
||||
|
||||
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
|
||||
|
|
|
@ -1,11 +1,9 @@
|
|||
! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
|
||||
! Eduardo Cavazos, Daniel Ehrenberg.
|
||||
!
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel combinators namespaces quotations hashtables sequences assocs
|
||||
arrays inference effects math math.ranges arrays.lib shuffle macros
|
||||
bake combinators.cleave ;
|
||||
USING: kernel combinators namespaces quotations hashtables
|
||||
sequences assocs arrays inference effects math math.ranges
|
||||
arrays.lib shuffle macros bake combinators.cleave ;
|
||||
|
||||
IN: combinators.lib
|
||||
|
||||
|
@ -51,22 +49,6 @@ MACRO: napply ( n -- )
|
|||
|
||||
: dipd ( x y quot -- y ) 2 ndip ; inline
|
||||
|
||||
! each-with
|
||||
|
||||
: each-withn ( seq quot n -- ) nwith each ; inline
|
||||
|
||||
: each-with ( seq quot -- ) with each ; inline
|
||||
|
||||
: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
|
||||
|
||||
! map-with
|
||||
|
||||
: map-withn ( seq quot n -- newseq ) nwith map ; inline
|
||||
|
||||
: map-with ( seq quot -- ) with map ; inline
|
||||
|
||||
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
|
||||
|
||||
: 2with ( param1 param2 obj quot -- obj curry )
|
||||
with with ; inline
|
||||
|
||||
|
@ -88,39 +70,23 @@ MACRO: napply ( n -- )
|
|||
: assoc-map-with ( obj assoc quot -- assoc )
|
||||
with* assoc-map ; inline
|
||||
|
||||
|
||||
MACRO: nfirst ( n -- )
|
||||
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; inline
|
||||
|
||||
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! short circuiting words
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : short-circuit ( quots quot default -- quot )
|
||||
! >r { } map>assoc <reversed> r>
|
||||
! 1quotation swap alist>quot ;
|
||||
|
||||
: short-circuit ( quots quot default -- quot )
|
||||
1quotation -rot { } map>assoc <reversed> alist>quot ;
|
||||
|
||||
! : short-circuit ( quots quot default -- quot )
|
||||
! 1quotation -rot map>alist <reversed> alist>quot ;
|
||||
|
||||
MACRO: && ( quots -- ? ) [ [ not ] append [ f ] ] t short-circuit ;
|
||||
MACRO: && ( quots -- ? )
|
||||
[ [ not ] append [ f ] ] t short-circuit ;
|
||||
|
||||
MACRO: <-&& ( quots -- )
|
||||
[ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
|
||||
[ nip ] append ;
|
||||
[ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
|
||||
[ nip ] append ;
|
||||
|
||||
MACRO: <--&& ( quots -- )
|
||||
[ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
|
||||
[ 2nip ] append ;
|
||||
[ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
|
||||
[ 2nip ] append ;
|
||||
|
||||
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
||||
|
||||
|
@ -129,25 +95,25 @@ MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MACRO: ifte ( quot quot quot -- )
|
||||
pick infer effect-in
|
||||
dup 1+ swap
|
||||
[ >r >r , nkeep , nrot r> r> if ]
|
||||
bake ;
|
||||
pick infer effect-in
|
||||
dup 1+ swap
|
||||
[ >r >r , nkeep , nrot r> r> if ]
|
||||
bake ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! switch
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: preserving ( predicate -- quot )
|
||||
dup infer effect-in
|
||||
dup 1+ spin
|
||||
[ , , nkeep , nrot ]
|
||||
bake ;
|
||||
dup infer effect-in
|
||||
dup 1+ spin
|
||||
[ , , nkeep , nrot ]
|
||||
bake ;
|
||||
|
||||
MACRO: switch ( quot -- )
|
||||
[ [ preserving ] [ ] bi* ] assoc-map
|
||||
[ , cond ]
|
||||
bake ;
|
||||
[ [ preserving ] [ ] bi* ] assoc-map
|
||||
[ , cond ]
|
||||
bake ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -156,41 +122,34 @@ MACRO: switch ( quot -- )
|
|||
! : pcall ( seq quots -- seq ) [ call ] 2map ;
|
||||
|
||||
MACRO: parallel-call ( quots -- )
|
||||
[ [ unclip % r> dup >r push ] bake ] map concat
|
||||
[ V{ } clone >r % drop r> >array ] bake ;
|
||||
|
||||
! MACRO: parallel-call ( quots -- )
|
||||
! [ [ unclip ] swap append ] map
|
||||
! [ [ r> swap add >r ] append ] map
|
||||
! concat
|
||||
! [ { } >r ] swap append ! pre
|
||||
! [ drop r> ] append ; ! post
|
||||
|
||||
[ [ unclip % r> dup >r push ] bake ] map concat
|
||||
[ V{ } clone >r % drop r> >array ] bake ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! map-call and friends
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (make-call-with) ( quots -- quot )
|
||||
[ [ keep ] curry ] map concat [ drop ] append ;
|
||||
[ [ keep ] curry ] map concat [ drop ] append ;
|
||||
|
||||
MACRO: call-with ( quots -- )
|
||||
(make-call-with) ;
|
||||
(make-call-with) ;
|
||||
|
||||
MACRO: map-call-with ( quots -- )
|
||||
[ (make-call-with) ] keep length [ narray ] curry compose ;
|
||||
[ (make-call-with) ] keep length [ narray ] curry compose ;
|
||||
|
||||
: (make-call-with2) ( quots -- quot )
|
||||
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
[ 2drop ] append ;
|
||||
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
[ 2drop ] append ;
|
||||
|
||||
MACRO: call-with2 ( quots -- )
|
||||
(make-call-with2) ;
|
||||
(make-call-with2) ;
|
||||
|
||||
MACRO: map-call-with2 ( quots -- )
|
||||
dup >r (make-call-with2) r> length [ narray ] curry append ;
|
||||
[ (make-call-with2) ] keep length [ narray ] curry append ;
|
||||
|
||||
MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ;
|
||||
MACRO: map-exec-with ( words -- )
|
||||
[ 1quotation ] map [ map-call-with ] curry ;
|
||||
|
||||
MACRO: construct-slots ( assoc tuple-class -- tuple )
|
||||
[ construct-empty ] curry swap [
|
||||
|
@ -208,14 +167,3 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
|
|||
|
||||
: and? ( obj quot1 quot2 -- ? )
|
||||
>r keep r> rot [ call ] [ 2drop f ] if ; inline
|
||||
|
||||
: prepare-index ( seq quot -- seq n quot )
|
||||
>r dup length r> ; inline
|
||||
|
||||
: each-index ( seq quot -- )
|
||||
#! quot: ( elt index -- )
|
||||
prepare-index 2each ; inline
|
||||
|
||||
: map-index ( seq quot -- )
|
||||
#! quot: ( elt index -- obj )
|
||||
prepare-index 2map ; inline
|
||||
|
|
|
@ -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,15 @@ 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
|
||||
|
||||
! Another race
|
||||
[ 3 ] [
|
||||
[ 3 yield ] future ?future
|
||||
] unit-test
|
|
@ -264,19 +264,31 @@ PRIVATE>
|
|||
#! so the server continuation gets its new self updated.
|
||||
self swap call ;
|
||||
|
||||
TUPLE: future value processes ;
|
||||
|
||||
: notify-future ( value future -- )
|
||||
tuck set-future-value
|
||||
dup future-processes [ schedule-thread ] each
|
||||
f swap set-future-processes ;
|
||||
|
||||
: future ( quot -- future )
|
||||
#! Spawn a process to call the quotation and immediately return
|
||||
#! a 'future' on the stack. The future can later be queried with
|
||||
#! ?future. If the quotation has completed the result will be returned.
|
||||
#! If not, the process will block until the quotation completes.
|
||||
#! 'quot' must have stack effect ( -- X ).
|
||||
[ self send ] compose spawn ;
|
||||
#! Spawn a process to call the quotation and immediately return.
|
||||
f V{ } clone \ future construct-boa [
|
||||
[
|
||||
>r [ t 2array ] compose [ f 2array ] recover r>
|
||||
notify-future
|
||||
] 2curry spawn drop
|
||||
] keep ;
|
||||
|
||||
: ?future ( future -- result )
|
||||
#! Block the process until the future has completed and then
|
||||
#! place the result on the stack. Return the result
|
||||
#! immediately if the future has completed.
|
||||
process-mailbox mailbox-get ;
|
||||
dup future-value [
|
||||
first2 [ throw ] unless
|
||||
] [
|
||||
dup [ future-processes push stop ] curry callcc0 ?future
|
||||
] ?if ;
|
||||
|
||||
: parallel-map ( seq quot -- newseq )
|
||||
#! Spawn a process to apply quot to each element of seq,
|
||||
|
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
extensions
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
USING: kernel math sequences words arrays io
|
||||
io.files namespaces math.parser kernel.private
|
||||
assocs quotations parser parser-combinators tools.time
|
||||
combinators.private compiler.units ;
|
||||
sequences.private compiler.units ;
|
||||
IN: cpu.8080.emulator
|
||||
|
||||
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
|
||||
|
|
|
@ -1 +1 @@
|
|||
emulator
|
||||
emulators
|
||||
|
|
|
@ -1 +1 @@
|
|||
emulator
|
||||
emulators
|
||||
|
|
|
@ -1 +1,2 @@
|
|||
enterprise
|
||||
bindings
|
||||
|
|
|
@ -153,7 +153,7 @@ SYMBOL: old-d
|
|||
dup S44 64 9 [ I ] BCDA ;
|
||||
|
||||
: (process-md5-block) ( block -- )
|
||||
4 group [ le> ] map
|
||||
4 <groups> [ le> ] map
|
||||
|
||||
(process-md5-block-F)
|
||||
(process-md5-block-G)
|
||||
|
|
|
@ -4,12 +4,27 @@ USING: arrays assocs classes continuations kernel math
|
|||
namespaces sequences sequences.lib tuples words ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db handle ;
|
||||
C: <db> db ( handle -- obj )
|
||||
TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
|
||||
: <db> ( handle -- obj )
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
db construct-boa ;
|
||||
|
||||
! HOOK: db-create db ( str -- )
|
||||
! HOOK: db-drop db ( str -- )
|
||||
GENERIC: db-open ( db -- )
|
||||
HOOK: db-close db ( handle -- )
|
||||
|
||||
: dispose-statements [ dispose drop ] assoc-each ;
|
||||
|
||||
: dispose-db ( db -- )
|
||||
dup db [
|
||||
dup db-insert-statements dispose-statements
|
||||
dup db-update-statements dispose-statements
|
||||
dup db-delete-statements dispose-statements
|
||||
dup db-select-statements dispose-statements
|
||||
db-handle db-close
|
||||
] with-variable ;
|
||||
|
||||
TUPLE: statement sql params handle bound? ;
|
||||
|
||||
|
@ -43,6 +58,8 @@ GENERIC: #columns ( result-set -- n )
|
|||
GENERIC# row-column 1 ( result-set n -- obj )
|
||||
GENERIC: advance-row ( result-set -- ? )
|
||||
|
||||
HOOK: last-id db ( -- id )
|
||||
|
||||
: init-result-set ( result-set -- )
|
||||
dup #rows over set-result-set-max
|
||||
-1 swap set-result-set-n ;
|
||||
|
|
|
@ -14,7 +14,6 @@ M: mysql-db db-open ( mysql-db -- )
|
|||
M: mysql-db dispose ( mysql-db -- )
|
||||
mysql-db-handle mysql_close ;
|
||||
|
||||
|
||||
M: mysql-db <simple-statement> ( str -- statement )
|
||||
;
|
||||
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue