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

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

Conflicts:

	extra/sequences/lib/lib.factor
db4
Joe Groff 2008-02-11 17:33:49 -08:00
parent 890c5702da 7fd45922f8
commit 6109335290
220 changed files with 3624 additions and 2735 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Makefile
View File

@ -123,7 +123,15 @@ solaris-x86-32:
solaris-x86-64: solaris-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.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 $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64: winnt-x86-64:

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

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

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

@ -1,356 +1,356 @@
IN: temporary IN: temporary
USING: alien alien.c-types alien.syntax compiler kernel USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads namespaces.private io io.streams.string memory system threads
tools.test ; tools.test ;
FUNCTION: void ffi_test_0 ; FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test [ ] [ ffi_test_0 ] unit-test
FUNCTION: int ffi_test_1 ; FUNCTION: int ffi_test_1 ;
[ 3 ] [ ffi_test_1 ] unit-test [ 3 ] [ ffi_test_1 ] unit-test
FUNCTION: int ffi_test_2 int x int y ; FUNCTION: int ffi_test_2 int x int y ;
[ 5 ] [ 2 3 ffi_test_2 ] unit-test [ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "hi" 3 ffi_test_2 ] must-fail [ "hi" 3 ffi_test_2 ] must-fail
FUNCTION: int ffi_test_3 int x int y int z int t ; FUNCTION: int ffi_test_3 int x int y int z int t ;
[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
FUNCTION: float ffi_test_4 ; FUNCTION: float ffi_test_4 ;
[ 1.5 ] [ ffi_test_4 ] unit-test [ 1.5 ] [ ffi_test_4 ] unit-test
FUNCTION: double ffi_test_5 ; FUNCTION: double ffi_test_5 ;
[ 1.5 ] [ ffi_test_5 ] unit-test [ 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 ; 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 [ 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 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo C-STRUCT: foo
{ "int" "x" } { "int" "x" }
{ "int" "y" } { "int" "y" }
; ;
: make-foo ( x y -- foo ) : make-foo ( x y -- foo )
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ; "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
FUNCTION: int ffi_test_11 int a foo b int c ; FUNCTION: int ffi_test_11 int a foo b int c ;
[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test [ 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 ; 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 [ 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 ; FUNCTION: foo ffi_test_14 int x int y ;
[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test [ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
FUNCTION: char* ffi_test_15 char* x char* y ; FUNCTION: char* ffi_test_15 char* x char* y ;
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail [ 1 2 ffi_test_15 ] must-fail
C-STRUCT: bar C-STRUCT: bar
{ "long" "x" } { "long" "x" }
{ "long" "y" } { "long" "y" }
{ "long" "z" } { "long" "z" }
; ;
FUNCTION: bar ffi_test_16 long x long y long z ; FUNCTION: bar ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [ [ 11 6 -7 ] [
11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
] unit-test ] unit-test
C-STRUCT: tiny C-STRUCT: tiny
{ "int" "x" } { "int" "x" }
; ;
FUNCTION: tiny ffi_test_17 int x ; FUNCTION: tiny ffi_test_17 int x ;
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test [ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1 : indirect-test-1
"int" { } "cdecl" alien-indirect ; "int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as { 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ -1 indirect-test-1 ] must-fail [ -1 indirect-test-1 ] must-fail
: indirect-test-2 : indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect data-gc ; "int" { "int" "int" } "cdecl" alien-indirect data-gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as { 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ] [ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test unit-test
: indirect-test-3 : indirect-test-3
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
data-gc ; data-gc ;
<< "f-stdcall" f "stdcall" add-library >> << "f-stdcall" f "stdcall" add-library >>
[ f ] [ "f-stdcall" load-library ] unit-test [ f ] [ "f-stdcall" load-library ] unit-test
[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test [ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
: ffi_test_18 ( w x y z -- int ) : ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
alien-invoke data-gc ; alien-invoke data-gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar ) : ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke data-gc ; alien-invoke data-gc ;
[ 11 6 -7 ] [ [ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
] unit-test ] unit-test
FUNCTION: double ffi_test_6 float x float y ; FUNCTION: double ffi_test_6 float x float y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
[ "a" "b" ffi_test_6 ] must-fail [ "a" "b" ffi_test_6 ] must-fail
FUNCTION: double ffi_test_7 double x double y ; FUNCTION: double ffi_test_7 double x double y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test [ 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 ; 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 [ 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 ; 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 [ -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, FUNCTION: void ffi_test_20 double x1, double x2, double x3,
double y1, double y2, double y3, double y1, double y2, double y3,
double z1, double z2, double z3 ; 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 [ ] [ 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 ! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31 : ffi_test_31
"void" "void"
f "ffi_test_31" 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" } { "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 ; alien-invoke code-gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test [ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ; FUNCTION: longlong ffi_test_21 long x long y ;
[ 121932631112635269 ] [ 121932631112635269 ]
[ 123456789 987654321 ffi_test_21 ] unit-test [ 123456789 987654321 ffi_test_21 ] unit-test
FUNCTION: long ffi_test_22 long x longlong y longlong z ; FUNCTION: long ffi_test_22 long x longlong y longlong z ;
[ 987655432 ] [ 987655432 ]
[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
[ 1111 f 123456789 ffi_test_22 ] must-fail [ 1111 f 123456789 ffi_test_22 ] must-fail
C-STRUCT: rect C-STRUCT: rect
{ "float" "x" } { "float" "x" }
{ "float" "y" } { "float" "y" }
{ "float" "w" } { "float" "w" }
{ "float" "h" } { "float" "h" }
; ;
: <rect> : <rect>
"rect" <c-object> "rect" <c-object>
[ set-rect-h ] keep [ set-rect-h ] keep
[ set-rect-w ] keep [ set-rect-w ] keep
[ set-rect-y ] keep [ set-rect-y ] keep
[ set-rect-x ] keep ; [ set-rect-x ] keep ;
FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; 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 [ 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 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; 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 [ 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 ! Test odd-size structs
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
FUNCTION: test-struct-1 ffi_test_24 ; FUNCTION: test-struct-1 ffi_test_24 ;
[ B{ 1 } ] [ ffi_test_24 ] unit-test [ B{ 1 } ] [ ffi_test_24 ] unit-test
C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
FUNCTION: test-struct-2 ffi_test_25 ; FUNCTION: test-struct-2 ffi_test_25 ;
[ B{ 1 2 } ] [ ffi_test_25 ] unit-test [ B{ 1 2 } ] [ ffi_test_25 ] unit-test
C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
FUNCTION: test-struct-3 ffi_test_26 ; FUNCTION: test-struct-3 ffi_test_26 ;
[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test [ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
FUNCTION: test-struct-4 ffi_test_27 ; FUNCTION: test-struct-4 ffi_test_27 ;
[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test [ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
FUNCTION: test-struct-5 ffi_test_28 ; FUNCTION: test-struct-5 ffi_test_28 ;
[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test [ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
FUNCTION: test-struct-6 ffi_test_29 ; FUNCTION: test-struct-6 ffi_test_29 ;
[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test [ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
FUNCTION: test-struct-7 ffi_test_30 ; FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test [ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ; FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-8" <c-object> "test-struct-8" <c-object>
1.0 over set-test-struct-8-x 1.0 over set-test-struct-8-x
2.0 over set-test-struct-8-y 2.0 over set-test-struct-8-y
3 ffi_test_32 3 ffi_test_32
] unit-test ] unit-test
C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ; FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-9" <c-object> "test-struct-9" <c-object>
1.0 over set-test-struct-9-x 1.0 over set-test-struct-9-x
2.0 over set-test-struct-9-y 2.0 over set-test-struct-9-y
3 ffi_test_33 3 ffi_test_33
] unit-test ] unit-test
C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ; FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-10" <c-object> "test-struct-10" <c-object>
1.0 over set-test-struct-10-x 1.0 over set-test-struct-10-x
2 over set-test-struct-10-y 2 over set-test-struct-10-y
3 ffi_test_34 3 ffi_test_34
] unit-test ] unit-test
C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ; FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-11" <c-object> "test-struct-11" <c-object>
1 over set-test-struct-11-x 1 over set-test-struct-11-x
2 over set-test-struct-11-y 2 over set-test-struct-11-y
3 ffi_test_35 3 ffi_test_35
] unit-test ] unit-test
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
: make-struct-12 : make-struct-12
"test-struct-12" <c-object> "test-struct-12" <c-object>
[ set-test-struct-12-x ] keep ; [ set-test-struct-12-x ] keep ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
! Test callbacks ! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ; : callback-1 "void" { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test [ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
[ t ] [ callback-1 alien? ] unit-test [ t ] [ callback-1 alien? ] unit-test
: callback_test_1 "void" { } "cdecl" alien-indirect ; : callback_test_1 "void" { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test [ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; : callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test [ ] [ callback-2 callback_test_1 ] unit-test
: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; : callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [ [ t ] [
namestack* namestack*
3 "x" set callback-3 callback_test_1 3 "x" set callback-3 callback_test_1
namestack* eq? namestack* eq?
] unit-test ] unit-test
[ 5 ] [ [ 5 ] [
[ [
3 "x" set callback-3 callback_test_1 "x" get 3 "x" set callback-3 callback_test_1 "x" get
] with-scope ] with-scope
] unit-test ] unit-test
: callback-4 : callback-4
"void" { } "cdecl" [ "Hello world" write ] alien-callback "void" { } "cdecl" [ "Hello world" write ] alien-callback
data-gc ; data-gc ;
[ "Hello world" ] [ [ "Hello world" ] [
[ callback-4 callback_test_1 ] string-out [ callback-4 callback_test_1 ] string-out
] unit-test ] unit-test
: callback-5 : callback-5
"void" { } "cdecl" [ data-gc ] alien-callback ; "void" { } "cdecl" [ data-gc ] alien-callback ;
[ "testing" ] [ [ "testing" ] [
"testing" callback-5 callback_test_1 "testing" callback-5 callback_test_1
] unit-test ] unit-test
: callback-5a : callback-5a
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ; "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
! Hack; if we're on ARM, we probably don't have much RAM, so ! Hack; if we're on ARM, we probably don't have much RAM, so
! skip this test. ! skip this test.
cpu "arm" = [ cpu "arm" = [
[ "testing" ] [ [ "testing" ] [
"testing" callback-5a callback_test_1 "testing" callback-5a callback_test_1
] unit-test ] unit-test
] unless ] unless
: callback-6 : callback-6
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 : callback-7
"void" { } "cdecl" [ 1000 sleep ] alien-callback ; "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test [ f ] [ namespace global eq? ] unit-test
: callback-8 : callback-8
"void" { } "cdecl" [ "void" { } "cdecl" [
[ continue ] callcc0 [ continue ] callcc0
] alien-callback ; ] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test [ ] [ callback-8 callback_test_1 ] unit-test

19
core/alien/compiler/compiler.factor
View File

@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
inference.state inference.backend inference.dataflow system inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs 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 IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect ! 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 swap alien-node-parameters parameter-sizes drop
number>string 3append ; 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 ) : (alien-invoke-dlsym) ( node -- symbol dll )
dup alien-invoke-function 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 ; TUPLE: no-such-symbol ;
@ -217,7 +230,7 @@ M: no-such-symbol summary
drop "Symbol not found" ; drop "Symbol not found" ;
: no-such-symbol ( -- ) : no-such-symbol ( -- )
\ no-such-symbol inference-error ; \ no-such-symbol +linkage+ (inference-error) ;
: alien-invoke-dlsym ( node -- symbol dll ) : alien-invoke-dlsym ( node -- symbol dll )
dup (alien-invoke-dlsym) 2dup dlsym [ dup (alien-invoke-dlsym) 2dup dlsym [

42
core/bootstrap/image/image.factor
View File

@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts
splitting growable classes tuples words.private splitting growable classes tuples words.private
io.binary io.files vocabs vocabs.loader source-files io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private definitions debugger float-arrays quotations.private
combinators.private combinators ; sequences.private combinators ;
IN: bootstrap.image IN: bootstrap.image
: my-arch ( -- arch ) : my-arch ( -- arch )
@ -136,7 +136,7 @@ SYMBOL: undefined-quot
: here-as ( tag -- pointer ) here swap bitor ; : here-as ( tag -- pointer ) here swap bitor ;
: align-here ( -- ) : 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 ; : emit-fixnum ( n -- ) tag-fixnum emit ;
@ -177,6 +177,7 @@ GENERIC: ' ( obj -- ptr )
[ dup bignum-bits neg shift swap bignum-radix bitand ] [ dup bignum-bits neg shift swap bignum-radix bitand ]
[ ] unfold nip ; [ ] unfold nip ;
USE: continuations
: emit-bignum ( n -- ) : emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
dup length 1+ emit-fixnum dup length 1+ emit-fixnum
@ -214,10 +215,6 @@ M: f '
: 1, 1 >bignum ' 1-offset fixup ; : 1, 1 >bignum ' 1-offset fixup ;
: -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 ! Words
: emit-word ( word -- ) : emit-word ( word -- )
@ -385,7 +382,10 @@ M: curry '
: fixup-header ( -- ) : fixup-header ( -- )
heap-size data-heap-size-offset fixup ; 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 "Serializing words..." print flush
emit-words emit-words
"Serializing JIT data..." print flush "Serializing JIT data..." print flush
@ -400,7 +400,8 @@ M: curry '
fixup-header fixup-header
"Image length: " write image get length . "Image length: " write image get length .
"Object cache size: " write objects get assoc-size . "Object cache size: " write objects get assoc-size .
\ word global delete-at ; \ word global delete-at
image get ;
! Image output ! Image output
@ -411,28 +412,23 @@ M: curry '
[ >le write ] curry each [ >le write ] curry each
] if ; ] if ;
: write-image ( image filename -- ) : write-image ( image -- )
"Writing image to " write dup write "..." print flush "Writing image to " write
architecture get boot-image-name resource-path
dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ; <file-writer> [ (write-image) ] with-stream ;
: prepare-image ( -- )
bootstrapping? on
load-help? off
800000 <vector> image set
20000 <hashtable> objects set ;
PRIVATE> PRIVATE>
: make-image ( arch -- ) : make-image ( arch -- )
architecture [ [
prepare-image architecture set
begin-image bootstrapping? on
load-help? off
"resource:/core/bootstrap/stage1.factor" run-file "resource:/core/bootstrap/stage1.factor" run-file
end-image build-image
image get
architecture get boot-image-name resource-path
write-image write-image
] with-variable ; ] with-scope ;
: make-images ( -- ) : make-images ( -- )
images [ make-image ] each ; images [ make-image ] each ;

7
core/bootstrap/layouts/layouts.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays hashtables vectors strings sbufs arrays bit-arrays
@ -8,7 +8,7 @@ BIN: 111 tag-mask set
8 num-tags set 8 num-tags set
3 tag-bits set 3 tag-bits set
20 num-types set 19 num-types set
H{ H{
{ fixnum BIN: 000 } { fixnum BIN: 000 }
@ -27,11 +27,10 @@ tag-numbers get H{
{ float-array 10 } { float-array 10 }
{ callstack 11 } { callstack 11 }
{ string 12 } { string 12 }
{ curry 13 } { bit-array 13 }
{ quotation 14 } { quotation 14 }
{ dll 15 } { dll 15 }
{ alien 16 } { alien 16 }
{ word 17 } { word 17 }
{ byte-array 18 } { byte-array 18 }
{ bit-array 19 }
} union type-numbers set } union type-numbers set

52
core/bootstrap/primitives.factor
View File

@ -295,23 +295,6 @@ define-builtin
"float-array?" "float-arrays" create "float-array?" "float-arrays" create
{ } define-builtin { } 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 "callstack" "kernel" create "callstack?" "kernel" create
{ } define-builtin { } define-builtin
@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class
} }
} define-tuple-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 ! Primitive words
: make-primitive ( word vocab n -- ) : 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" } { "(execute)" "words.private" }
{ "(call)" "kernel.private" } { "(call)" "kernel.private" }
{ "uncurry" "kernel.private" }
{ "bignum>fixnum" "math.private" } { "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" } { "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" } { "fixnum>bignum" "math.private" }
@ -622,7 +635,6 @@ builtins get num-tags get tail f union-class define-class
{ "become" "kernel.private" } { "become" "kernel.private" }
{ "(sleep)" "threads.private" } { "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" } { "<float-array>" "float-arrays" }
{ "curry" "kernel" }
{ "<tuple-boa>" "tuples.private" } { "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" } { "class-hash" "kernel.private" }
{ "callstack>array" "kernel" } { "callstack>array" "kernel" }

2
core/bootstrap/stage1.factor
View File

@ -38,7 +38,7 @@ vocabs.loader system ;
[ [
"resource:core/bootstrap/stage2.factor" "resource:core/bootstrap/stage2.factor"
dup ?resource-path exists? [ dup resource-exists? [
run-file run-file
] [ ] [
"Cannot find " write write "." print "Cannot find " write write "." print

4
core/classes/classes.factor
View File

@ -20,7 +20,9 @@ PREDICATE: class tuple-class
: classes ( -- seq ) class<map get keys ; : 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 ) : predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ; [ word-name "?" append ] keep word-vocabulary create ;

2
core/combinators/combinators-docs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: arrays help.markup help.syntax strings sbufs vectors USING: arrays help.markup help.syntax strings sbufs vectors
kernel quotations generic generic.standard classes kernel quotations generic generic.standard classes
math assocs sequences combinators.private ; math assocs sequences sequences.private ;
IN: combinators IN: combinators
ARTICLE: "combinators-quot" "Quotation construction utilities" ARTICLE: "combinators-quot" "Quotation construction utilities"

6
core/combinators/combinators.factor
View File

@ -4,12 +4,6 @@ IN: combinators
USING: arrays sequences sequences.private math.private USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors ; kernel kernel.private math assocs quotations vectors ;
<PRIVATE
: dispatch ( n array -- ) array-nth (call) ;
PRIVATE>
TUPLE: no-cond ; TUPLE: no-cond ;
: no-cond ( -- * ) \ no-cond construct-empty throw ; : no-cond ( -- * ) \ no-cond construct-empty throw ;

21
core/compiler/compiler-tests.factor
View File

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

29
core/compiler/errors/errors-docs.factor
View File

@ -1,14 +1,15 @@
IN: compiler.errors IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io USING: help.markup help.syntax vocabs.loader words io
quotations ; quotations compiler.errors.private ;
ARTICLE: "compiler-errors" "Compiler warnings and errors" 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 } { $subsection compiler-errors }
"The warnings and errors can be viewed later:" "These notifications can be viewed later:"
{ $subsection :warnings }
{ $subsection :errors } { $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 } ; { $link with-compiler-errors } ;
HELP: compiler-errors HELP: compiler-errors
@ -16,7 +17,7 @@ HELP: compiler-errors
HELP: compiler-error HELP: compiler-error
{ $values { "error" "an error" } { "word" word } } { $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. HELP: compiler-error.
{ $values { "error" "an error" } { "word" word } } { $values { "error" "an error" } { "word" word } }
@ -25,24 +26,18 @@ HELP: compiler-error.
HELP: compiler-errors. HELP: compiler-errors.
{ $values { "errors" "an assoc mapping words to errors" } } { $values { "errors" "an assoc mapping words to errors" } }
{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ; { $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 HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ; { $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 HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ; { $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 HELP: with-compiler-errors
{ $values { "quot" quotation } } { $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." } ; { $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;

69
core/compiler/errors/errors.factor
View File

@ -4,51 +4,66 @@ USING: kernel namespaces assocs prettyprint io sequences
sorting continuations debugger math math.parser ; sorting continuations debugger math math.parser ;
IN: compiler.errors 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: compiler-errors
SYMBOL: with-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 -- ) : compiler-error. ( error word -- )
nl nl
"While compiling " write pprint ": " print "While compiling " write pprint ": " print
nl nl
print-error ; print-error ;
: compiler-errors. ( assoc -- ) : errors-of-type ( type -- assoc )
>alist sort-keys [ swap compiler-error. ] assoc-each ;
GENERIC: compiler-warning? ( error -- ? )
M: object compiler-warning? drop f ;
: (:errors) ( -- assoc )
compiler-errors get-global 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-report) ( what type word -- )
compiler-errors get-global over errors-of-type assoc-empty? [ 3drop ] [
[ nip compiler-warning? ] assoc-subset ;
: :warnings (:warnings) compiler-errors. ;
: (compiler-report) ( what assoc -- )
length dup zero? [ 2drop ] [
[ [
":" % over % " - print " % # " compiler " % % "." % ":" %
%
" - print " %
errors-of-type assoc-size #
" " %
%
"." %
] "" make print ] "" make print
] if ; ] if ;
: compiler-report ( -- ) : compiler-report ( -- )
"errors" (:errors) (compiler-report) "semantic errors" +error+ "errors" (compiler-report)
"warnings" (:warnings) (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 ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [ with-compiler-errors? get "quiet" get or [ call ] [

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

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

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

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

287
core/compiler/test/redefine.factor
View File

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

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

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

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

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

2
core/compiler/test/intrinsics.factor → core/compiler/tests/intrinsics.factor
View File

@ -4,7 +4,7 @@ math.private sequences strings tools.test words continuations
sequences.private hashtables.private byte-arrays strings.private sequences.private hashtables.private byte-arrays strings.private
system random layouts vectors.private sbufs.private system random layouts vectors.private sbufs.private
strings.private slots.private alien alien.accessors 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. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test

229
core/compiler/tests/simple.factor Executable file
View File

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

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

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

2
core/compiler/test/templates.factor → core/compiler/tests/templates.factor
View File

@ -2,7 +2,7 @@
USING: arrays compiler kernel kernel.private math USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private 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 ; words definitions compiler.units ;
IN: temporary IN: temporary

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

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

@ -169,7 +169,7 @@ HELP: rethrow
HELP: throw-restarts HELP: throw-restarts
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } { $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 { $examples
"Try invoking one of the two restarts which are offered after the below code throws an error:" "Try invoking one of the two restarts which are offered after the below code throws an error:"
{ $code { $code

2
core/continuations/continuations.factor
View File

@ -98,7 +98,7 @@ PRIVATE>
: continue-with ( obj continuation -- ) : continue-with ( obj continuation -- )
[ [
walker-hook [ >r 2array r> ] when* (continue-with) walker-hook [ >r 2array r> ] when* (continue-with)
] 2curry (throw) ; ] 2 (throw) ;
: continue ( continuation -- ) : continue ( continuation -- )
f swap continue-with ; f swap continue-with ;

4
core/cpu/architecture/architecture.factor
View File

@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- )
! Test if vreg is 'f' or not ! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- ) HOOK: %jump-t compiler-backend ( label -- )
HOOK: %call-dispatch compiler-backend ( -- label ) HOOK: %dispatch compiler-backend ( -- )
HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- ) HOOK: %dispatch-label compiler-backend ( word -- )

23
core/cpu/ppc/architecture/architecture.factor
View File

@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- ) M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ; 0 "flag" operand f v>operand CMPI BNE ;
: (%dispatch) ( len -- ) M: ppc-backend %dispatch ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here [
"offset" operand "n" operand 1 SRAWI %epilogue-later
11 11 "offset" operand ADD 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
11 dup rot cells LWZ ; "offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
M: ppc-backend %call-dispatch ( word-table# -- ) 11 dup 6 cells LWZ
[ 7 (%dispatch) (%call) <label> dup B ] H{ (%jump)
{ +input+ { { f "n" } } } ] H{
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %jump-dispatch ( -- )
[ %epilogue-later 6 (%dispatch) (%jump) ] H{
{ +input+ { { f "n" } } } { +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } } { +scratch+ { { f "offset" } } }
} with-template ; } with-template ;

4
core/cpu/ppc/ppc.factor
View File

@ -13,3 +13,7 @@ namespaces alien.c-types kernel system combinators ;
} cond } cond
T{ ppc-backend } compiler-backend set-global T{ ppc-backend } compiler-backend set-global
macosx? [
4 "double" c-type set-c-type-align
] when

6
core/cpu/x86/32/32.factor
View File

@ -261,9 +261,9 @@ windows? [
cell "ulonglong" c-type set-c-type-align cell "ulonglong" c-type set-c-type-align
] unless ] unless
macosx? [ windows? [
cell "double" c-type set-c-type-align 4 "double" c-type set-c-type-align
] when ] unless
T{ x86-backend f 4 } compiler-backend set-global T{ x86-backend f 4 } compiler-backend set-global

3
core/cpu/x86/64/64.factor
View File

@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system 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 IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend PREDICATE: x86-backend amd64-backend

39
core/cpu/x86/architecture/architecture.factor
View File

@ -77,26 +77,29 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- ) M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ; "flag" operand f v>operand CMP JNE ;
: (%dispatch) ( n -- operand ) : code-alignment ( -- n )
! Load jump table base. We use a temporary register building get length dup cell align swap - ;
! 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 ? + [+] ;
M: x86-backend %call-dispatch ( word-table# -- ) : align-code ( n -- )
[ 5 (%dispatch) CALL <label> dup JMP ] H{ 0 <repetition> % ;
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ;
M: x86-backend %jump-dispatch ( -- ) M: x86-backend %dispatch ( -- )
[ %epilogue-later 0 (%dispatch) JMP ] H{ [
%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" } } } { +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } } { +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } } { +clobber+ { "n" } }

29
core/generator/generator.factor
View File

@ -56,13 +56,16 @@ GENERIC: generate-node ( node -- next )
: generate-nodes ( node -- ) : generate-nodes ( node -- )
[ node@ generate-node ] iterate-nodes end-basic-block ; [ 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 -- ) : generate ( word label node -- )
[ [
init-templates init-generate-nodes
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label
[ generate-nodes ] with-node-iterator [ generate-nodes ] with-node-iterator
] generate-1 ; ] generate-1 ;
@ -168,17 +171,23 @@ M: #if generate-node
] if %dispatch-label ] if %dispatch-label
] each ; ] each ;
: generate-dispatch ( node -- )
%dispatch dispatch-branches init-templates ;
M: #dispatch generate-node M: #dispatch generate-node
#! The order here is important, dispatch-branches must #! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the #! run after %dispatch, so that each branch gets the
#! correct register state #! correct register state
tail-call? [ tail-call? [
%jump-dispatch dispatch-branches generate-dispatch iterate-next
] [ ] [
0 frame-required compiling-word get gensym [
%call-dispatch >r dispatch-branches r> resolve-label rot [
] if init-generate-nodes
init-templates iterate-next ; generate-dispatch
] generate-1
] keep generate-call
] if ;
! #call ! #call
: define-intrinsics ( word intrinsics -- ) : define-intrinsics ( word intrinsics -- )

4
core/generic/math/math.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators math namespaces sequences words quotations layouts combinators
combinators.private classes definitions ; sequences.private classes definitions ;
IN: generic.math IN: generic.math
PREDICATE: class math-class ( object -- ? ) PREDICATE: class math-class ( object -- ? )
@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ;
: math-vtable* ( picker max quot -- quot ) : math-vtable* ( picker max quot -- quot )
[ [
rot , \ tag , rot , \ tag ,
[ >r [ type>class ] map r> map % ] { } make , [ >r [ bootstrap-type>class ] map r> map % ] { } make ,
\ dispatch , \ dispatch ,
] [ ] make ; inline ] [ ] make ; inline

4
core/generic/standard/standard.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel kernel.private slots.private math USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions namespaces sequences vectors words quotations definitions
hashtables layouts combinators combinators.private generic hashtables layouts combinators sequences.private generic
classes classes.private ; classes classes.private ;
IN: generic.standard IN: generic.standard
@ -97,7 +97,7 @@ TUPLE: no-method object generic ;
[ small-generic ] picker class-hash-dispatch-quot ; [ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class ) : vtable-class ( n -- class )
type>class [ hi-tag bootstrap-word ] unless* ; bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
: group-methods ( assoc -- vtable ) : group-methods ( assoc -- vtable )
#! Input is a predicate -> method association. #! Input is a predicate -> method association.

2
core/inference/backend/backend-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.syntax help.markup words effects inference.dataflow USING: help.syntax help.markup words effects inference.dataflow
inference.state inference.backend kernel sequences inference.state inference.backend kernel sequences
kernel.private combinators combinators.private ; kernel.private combinators sequences.private ;
HELP: literal-expected 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." } { $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." }

15
core/inference/backend/backend.factor
View File

@ -24,24 +24,24 @@ IN: inference.backend
: recursive-quotation? ( quot -- ? ) : recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ; local-recursive-state [ first eq? ] with contains? ;
TUPLE: inference-error rstate major? ; TUPLE: inference-error rstate type ;
M: inference-error compiler-warning? M: inference-error compiler-error-type
inference-error-major? not ; inference-error-type ;
: (inference-error) ( ... class important? -- * ) : (inference-error) ( ... class type -- * )
>r construct-boa r> >r construct-boa r>
recursive-state get { recursive-state get {
set-delegate set-delegate
set-inference-error-major? set-inference-error-type
set-inference-error-rstate set-inference-error-rstate
} \ inference-error construct throw ; inline } \ inference-error construct throw ; inline
: inference-error ( ... class -- * ) : inference-error ( ... class -- * )
t (inference-error) ; inline +error+ (inference-error) ; inline
: inference-warning ( ... class -- * ) : inference-warning ( ... class -- * )
f (inference-error) ; inline +warning+ (inference-error) ; inline
TUPLE: literal-expected ; TUPLE: literal-expected ;
@ -370,6 +370,7 @@ TUPLE: effect-error word effect ;
init-inference init-inference
dependencies off dependencies off
dup word-def over dup infer-quot-recursive dup word-def over dup infer-quot-recursive
end-infer
finish-word finish-word
current-effect current-effect
] with-scope ] with-scope

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

@ -263,3 +263,23 @@ cell-bits 32 = [
\ fixnum-shift inlined? \ fixnum-shift inlined?
] unit-test ] unit-test
] when ] 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

49
core/inference/class/class.factor
View File

@ -73,17 +73,27 @@ SYMBOL: value-intervals
! Current value --> class mapping ! Current value --> class mapping
SYMBOL: value-classes SYMBOL: value-classes
: value-interval* ( value -- interval/f )
value-intervals get at ;
: set-value-interval* ( interval value -- ) : set-value-interval* ( interval value -- )
value-intervals get set-at ; value-intervals get set-at ;
: intersect-value-interval ( interval value -- )
[ value-interval* interval-intersect ] keep
set-value-interval* ;
M: interval-constraint apply-constraint M: interval-constraint apply-constraint
dup interval-constraint-interval dup interval-constraint-interval
swap interval-constraint-value set-value-interval* ; swap interval-constraint-value intersect-value-interval ;
: set-class-interval ( class value -- ) : set-class-interval ( class value -- )
>r "interval" word-prop dup >r "interval" word-prop dup
[ r> set-value-interval* ] [ r> 2drop ] if ; [ r> set-value-interval* ] [ r> 2drop ] if ;
: value-class* ( value -- class )
value-classes get at object or ;
: set-value-class* ( class value -- ) : set-value-class* ( class value -- )
over [ over [
dup value-intervals get at [ dup value-intervals get at [
@ -93,9 +103,12 @@ M: interval-constraint apply-constraint
] when ] when
value-classes get set-at ; value-classes get set-at ;
: intersect-value-class ( class value -- )
[ value-class* class-and ] keep set-value-class* ;
M: class-constraint apply-constraint M: class-constraint apply-constraint
dup class-constraint-class dup class-constraint-class
swap class-constraint-value set-value-class* ; swap class-constraint-value intersect-value-class ;
: set-value-literal* ( literal value -- ) : set-value-literal* ( literal value -- )
over class over set-value-class* over class over set-value-class*
@ -127,16 +140,10 @@ M: literal-constraint constraint-satisfied?
dup literal-constraint-value value-literal* dup literal-constraint-value value-literal*
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ; [ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
: value-class* ( value -- class )
value-classes get at object or ;
M: class-constraint constraint-satisfied? M: class-constraint constraint-satisfied?
dup class-constraint-value value-class* dup class-constraint-value value-class*
swap class-constraint-class class< ; swap class-constraint-class class< ;
: value-interval* ( value -- interval/f )
value-intervals get at ;
M: pair apply-constraint M: pair apply-constraint
first2 2dup constraints get set-at first2 2dup constraints get set-at
constraint-satisfied? [ apply-constraint ] [ drop ] if ; constraint-satisfied? [ apply-constraint ] [ drop ] if ;
@ -159,13 +166,10 @@ M: pair constraint-satisfied?
2drop ; 2drop ;
: intersect-classes ( classes values -- ) : intersect-classes ( classes values -- )
[ [ value-class* class-and ] keep set-value-class* ] 2each ; [ intersect-value-class ] 2each ;
: intersect-intervals ( intervals values -- ) : intersect-intervals ( intervals values -- )
[ [ intersect-value-interval ] 2each ;
[ value-interval* interval-intersect ] keep
set-value-interval*
] 2each ;
: predicate-constraints ( class #call -- ) : predicate-constraints ( class #call -- )
[ [
@ -181,20 +185,14 @@ M: pair constraint-satisfied?
[ swap predicate-constraints ] [ 2drop ] if [ swap predicate-constraints ] [ 2drop ] if
] 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 ) : compute-output-classes ( node word -- classes intervals )
dup node-param "output-classes" word-prop dup dup node-param "output-classes" word-prop
[ call ] [ 2drop f f ] if ; dup [ call ] [ 2drop f f ] if ;
: output-classes ( node -- classes intervals ) : output-classes ( node -- classes intervals )
dup compute-output-classes dup compute-output-classes >r
>r [ ] [ node-param default-output-classes ] ?if r> ; [ ] [ node-param "default-output-classes" word-prop ] ?if
r> ;
M: #call infer-classes-before M: #call infer-classes-before
dup compute-constraints dup compute-constraints
@ -220,7 +218,8 @@ M: #dispatch child-constraints
] make-constraints ; ] make-constraints ;
M: #declare infer-classes-before 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) DEFER: (infer-classes)

22
core/inference/dataflow/dataflow.factor
View File

@ -256,6 +256,28 @@ SYMBOL: node-stack
] iterate-nodes drop ] iterate-nodes drop
] with-node-iterator ; inline ] 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 -- ? ) : node-literal? ( node value -- ? )
dup value? >r swap node-literals key? r> or ; dup value? >r swap node-literals key? r> or ;

8
core/inference/inference-tests.factor
View File

@ -4,7 +4,8 @@ math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate 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 IN: temporary
{ 0 2 } [ 2 "Hello" ] must-infer-as { 0 2 } [ 2 "Hello" ] must-infer-as
@ -536,3 +537,8 @@ TUPLE: custom-error ;
! This was a false trigger of the undecidable quotation ! This was a false trigger of the undecidable quotation
! recursion bug ! recursion bug
{ 2 1 } [ find-last-sep ] must-infer-as { 2 1 } [ find-last-sep ] must-infer-as
! Regression
: missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail

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

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays bit-arrays byte-arrays 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 float-arrays generic hashtables hashtables.private
inference.state inference.backend inference.dataflow io inference.state inference.backend inference.dataflow io
io.backend io.files io.files.private io.streams.c kernel 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 pop-d pop-d swap <curried> push-d
] "infer" set-word-prop ] "infer" set-word-prop
\ curry { object object } { curry } <effect> "inferred-effect" set-word-prop
\ compose [ \ compose [
2 ensure-values 2 ensure-values
pop-d pop-d swap <composed> push-d pop-d pop-d swap <composed> push-d
] "infer" set-word-prop ] "infer" set-word-prop
\ compose { object object } { curry } <effect> "inferred-effect" set-word-prop
! Variadic tuple constructor ! Variadic tuple constructor
\ <tuple-boa> [ \ <tuple-boa> [
\ <tuple-boa> \ <tuple-boa>
@ -142,440 +138,461 @@ M: object infer-call
make-call-node make-call-node
] "infer" set-word-prop ] "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 ! Non-standard control flow
\ (throw) { callable } { } <effect> \ (throw) [
t over set-effect-terminated? \ (throw)
"inferred-effect" set-word-prop 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 ! 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< make-foldable
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop \ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum<= make-foldable \ 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> make-foldable
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop \ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum>= make-foldable \ fixnum>= make-foldable
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop \ eq? { object object } { object } <effect> set-primitive-effect
\ eq? make-foldable \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ <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 \ 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>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 \ 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 \ 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>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 \ 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 \ <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+ 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+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- 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-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* 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*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/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 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/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-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-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-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-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 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 \ 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= make-foldable
\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop \ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum+ make-foldable \ 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- make-foldable
\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop \ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum* make-foldable \ 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/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 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/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-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-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-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-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-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< make-foldable
\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop \ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum<= make-foldable \ 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> make-foldable
\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop \ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum>= make-foldable \ 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-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 \ 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 \ 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= make-foldable
\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop \ float+ { float float } { float } <effect> set-primitive-effect
\ float+ make-foldable \ 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- make-foldable
\ float* { float float } { float } <effect> "inferred-effect" set-word-prop \ float* { float float } { float } <effect> set-primitive-effect
\ float* make-foldable \ 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/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< 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-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<= make-foldable
\ float> { float float } { object } <effect> "inferred-effect" set-word-prop \ float> { float float } { object } <effect> set-primitive-effect
\ float> make-foldable \ 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>= make-foldable
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop \ <word> { object object } { word } <effect> set-primitive-effect
\ <word> make-flushable \ <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 \ word-xt make-flushable
\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop \ getenv { fixnum } { object } <effect> set-primitive-effect
\ getenv make-flushable \ 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> \ exit { integer } { } <effect>
t over set-effect-terminated? 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 \ 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 \ 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 \ millis make-flushable
\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop \ type { object } { fixnum } <effect> set-primitive-effect
\ type make-foldable \ type make-foldable
\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop \ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable \ 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 \ 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 \ <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 \ <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 \ <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 \ <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 \ 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 \ 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 \ 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-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-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-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-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 \ 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 \ <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 \ 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 \ expired? make-flushable
\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop \ <wrapper> { object } { wrapper } <effect> set-primitive-effect
\ <wrapper> make-foldable \ <wrapper> make-foldable
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop \ (clone) { object } { object } <effect> set-primitive-effect
\ (clone) make-flushable \ (clone) make-flushable
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop \ <string> { integer integer } { string } <effect> set-primitive-effect
\ <string> make-flushable \ <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 \ 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 \ 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> make-flushable
\ (>tuple) { array } { tuple } <effect> "inferred-effect" set-word-prop \ (>tuple) { array } { tuple } <effect> set-primitive-effect
\ (>tuple) make-flushable \ (>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 \ tuple>array make-flushable
\ datastack { } { array } <effect> "inferred-effect" set-word-prop \ datastack { } { array } <effect> set-primitive-effect
\ datastack make-flushable \ datastack make-flushable
\ retainstack { } { array } <effect> "inferred-effect" set-word-prop \ retainstack { } { array } <effect> set-primitive-effect
\ retainstack make-flushable \ retainstack make-flushable
\ callstack { } { callstack } <effect> "inferred-effect" set-word-prop \ callstack { } { callstack } <effect> set-primitive-effect
\ callstack make-flushable \ 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 \ 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 \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop

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

@ -54,7 +54,9 @@ M: pair (bitfield-quot) ( spec -- quot )
\ bitfield [ bitfield-quot ] 1 define-transform \ bitfield [ bitfield-quot ] 1 define-transform
\ flags [ flags [ ] curry ] 1 define-transform \ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform
! Tuple operations ! Tuple operations
: [get-slots] ( slots -- quot ) : [get-slots] ( slots -- quot )
@ -91,5 +93,3 @@ M: duplicated-slots-error summary
\ construct-empty 1 1 <effect> make-call-node \ construct-empty 1 1 <effect> make-call-node
] if ] if
] "infer" set-word-prop ] "infer" set-word-prop
\ construct-empty 1 1 <effect> "inferred-effect" set-word-prop

15
core/io/files/files-docs.factor
View File

@ -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." } { $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." } ; { $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 HELP: cwd
{ $values { "path" "a pathname string" } } { $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." } { $description "Outputs the current working directory of the Factor process." }

3
core/io/files/files.factor
View File

@ -96,6 +96,9 @@ TUPLE: no-parent-directory path ;
: ?resource-path ( path -- newpath ) : ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ; "resource:" ?head [ resource-path ] when ;
: resource-exists? ( path -- ? )
?resource-path exists? ;
: make-directories ( path -- ) : make-directories ( path -- )
normalize-pathname right-trim-separators { normalize-pathname right-trim-separators {
{ [ dup "." = ] [ ] } { [ dup "." = ] [ ] }

8
core/io/io-docs.factor
View File

@ -22,8 +22,7 @@ $nl
{ $subsection make-block-stream } { $subsection make-block-stream }
{ $subsection make-cell-stream } { $subsection make-cell-stream }
{ $subsection stream-write-table } { $subsection stream-write-table }
"Optional word for network streams:" { $see-also "io.timeouts" } ;
{ $subsection set-timeout } ;
ARTICLE: "stdio" "The default stream" ARTICLE: "stdio" "The default stream"
"Various words take an implicit stream parameter from a variable to reduce stack shuffling." "Various words take an implicit stream parameter from a variable to reduce stack shuffling."
@ -73,11 +72,6 @@ ARTICLE: "streams" "Streams"
ABOUT: "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 HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } } { $values { "stream" "an input stream" } { "str" string } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." } { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }

1
core/io/io.factor
View File

@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.styles sbufs ; continuations assocs io.styles sbufs ;
IN: io IN: io
GENERIC: set-timeout ( n stream -- )
GENERIC: stream-readln ( stream -- str ) GENERIC: stream-readln ( stream -- str )
GENERIC: stream-read1 ( stream -- ch/f ) GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f ) GENERIC: stream-read ( n stream -- str/f )

5
core/io/streams/duplex/duplex.factor
View File

@ -74,8 +74,3 @@ M: duplex-stream dispose
[ dup duplex-stream-out dispose ] [ dup duplex-stream-out dispose ]
[ dup duplex-stream-in dispose ] [ ] cleanup [ dup duplex-stream-in dispose ] [ ] cleanup
] unless drop ; ] unless drop ;
M: duplex-stream set-timeout
2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;

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

@ -532,7 +532,7 @@ HELP: compose
"compose call" "compose call"
"append 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 HELP: 3compose

14
core/kernel/kernel.factor
View File

@ -17,7 +17,7 @@ IN: kernel
: clear ( -- ) { } set-datastack ; : clear ( -- ) { } set-datastack ;
! Combinators ! Combinators
: call ( callable -- ) uncurry (call) ; GENERIC: call ( callable -- )
DEFER: if DEFER: if
@ -70,6 +70,10 @@ DEFER: if
[ 2nip call ] if ; inline [ 2nip call ] if ; inline
! Quotation building ! Quotation building
USE: tuples.private
: curry ( obj quot -- curry )
\ curry 4 <tuple-boa> ;
: 2curry ( obj1 obj2 quot -- curry ) : 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline curry curry ; inline
@ -81,12 +85,10 @@ DEFER: if
swapd [ swapd call ] 2curry ; inline swapd [ swapd call ] 2curry ; inline
: compose ( quot1 quot2 -- curry ) : compose ( quot1 quot2 -- curry )
! Not inline because this is treated as a primitive by \ compose 4 <tuple-boa> ;
! the compiler
[ slip call ] 2curry ;
: 3compose ( quot1 quot2 quot3 -- curry ) : 3compose ( quot1 quot2 quot3 -- curry )
[ 2slip slip call ] 3curry ; inline compose compose ; inline
! Object protocol ! Object protocol
@ -155,7 +157,7 @@ GENERIC: construct-boa ( ... class -- tuple )
! Error handling -- defined early so that other files can ! Error handling -- defined early so that other files can
! throw errors before continuations are loaded ! throw errors before continuations are loaded
: throw ( error -- * ) 5 getenv [ die ] or curry (throw) ; : throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
<PRIVATE <PRIVATE

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

@ -1,4 +1,4 @@
USING: math math.bitfields tools.test kernel ; USING: math math.bitfields tools.test kernel words ;
IN: temporary IN: temporary
[ 0 ] [ { } bitfield ] unit-test [ 0 ] [ { } bitfield ] unit-test
@ -6,3 +6,12 @@ IN: temporary
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test [ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test [ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } 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

11
core/math/parser/parser.factor
View File

@ -41,6 +41,9 @@ DEFER: base>
<PRIVATE <PRIVATE
SYMBOL: radix SYMBOL: radix
SYMBOL: negative?
: sign negative? get "-" "+" ? ;
: with-radix ( radix quot -- ) : with-radix ( radix quot -- )
radix swap with-variable ; inline radix swap with-variable ; inline
@ -48,7 +51,7 @@ SYMBOL: radix
: (base>) ( str -- n ) radix get base> ; : (base>) ( str -- n ) radix get base> ;
: whole-part ( str -- m n ) : whole-part ( str -- m n )
"+" split1 >r (base>) r> sign split1 >r (base>) r>
dup [ (base>) ] [ drop 0 swap ] if ; dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b ) : string>ratio ( str -- a/b )
@ -70,7 +73,7 @@ PRIVATE>
: base> ( str radix -- n/f ) : base> ( str radix -- n/f )
[ [
"-" ?head >r "-" ?head dup negative? set >r
{ {
{ [ CHAR: / over member? ] [ string>ratio ] } { [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] } { [ CHAR: . over member? ] [ string>float ] }
@ -114,9 +117,9 @@ M: integer >base
M: ratio >base M: ratio >base
[ [
[ [
dup 0 < [ "-" % neg ] when dup 0 < dup negative? set [ "-" % neg ] when
1 /mod 1 /mod
>r dup zero? [ drop ] [ (>base) % "+" % ] if r> >r dup zero? [ drop ] [ (>base) % sign % ] if r>
dup numerator (>base) % dup numerator (>base) %
"/" % "/" %
denominator (>base) % denominator (>base) %

70
core/optimizer/backend/backend.factor
View File

@ -52,13 +52,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
DEFER: optimize-nodes DEFER: optimize-nodes
: optimize-children ( node -- ) : optimize-children ( node -- )
[ [ optimize-nodes ] change-children ;
dup node-children dup [
[ optimize-nodes ] map swap set-node-children
] [
2drop
] if
] when* ;
: optimize-node ( node -- node ) : optimize-node ( node -- node )
dup [ dup [
@ -76,39 +70,17 @@ DEFER: optimize-nodes
M: f set-node-successor 2drop ; 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 ) : optimize-nodes ( node -- newnode )
[ [
class-substitutions [ clone ] change class-substitutions [ clone ] change
literal-substitutions [ clone ] change literal-substitutions [ clone ] change
dup [ [ optimize-node ] transform-nodes
optimize-node optimizer-changed get
dup dup node-successor (optimize-nodes)
] when optimizer-changed get
] with-scope optimizer-changed set ; ] 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 ! Generic nodes
M: node optimize-node* drop t f ; 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? ) : cleanup-inlining ( node -- newnode changed? )
node-successor [ node-successor t ] [ t f ] if* ; node-successor [ node-successor t ] [ t f ] if* ;
@ -118,12 +90,6 @@ M: #return optimize-node* cleanup-inlining ;
! #values ! #values
M: #values optimize-node* cleanup-inlining ; 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 ! Some utilities for splicing in dataflow IR subtrees
: follow ( key assoc -- value ) : follow ( key assoc -- value )
2dup at* [ swap follow nip ] [ 2drop ] if ; 2dup at* [ swap follow nip ] [ 2drop ] if ;
@ -194,10 +160,8 @@ M: node remember-method*
! Constant branch folding ! Constant branch folding
: fold-branch ( node branch# -- node ) : fold-branch ( node branch# -- node )
over drop-inputs >r
over node-children nth over node-children nth
swap node-successor over substitute-node swap node-successor over substitute-node ;
r> [ set-node-successor ] keep ;
! #if ! #if
: known-boolean-value? ( node value -- value ? ) : known-boolean-value? ( node value -- value ? )
@ -213,12 +177,18 @@ M: node remember-method*
] if ; ] if ;
M: #if optimize-node* M: #if optimize-node*
dup dup node-in-d first known-boolean-value? dup dup node-in-d first known-boolean-value? [
[ 0 1 ? fold-branch t ] [ 2drop t f ] if ; over drop-inputs >r
0 1 ? fold-branch
r> [ set-node-successor ] keep
t
] [ 2drop t f ] if ;
M: #dispatch optimize-node* M: #dispatch optimize-node*
dup dup node-in-d first 2dup node-literal? [ 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 3drop t f
] if ; ] if ;
@ -322,9 +292,19 @@ DEFER: (flat-length)
#! Make #shuffle -> #push -> #return -> successor #! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ; dupd literal-quot splice-quot ;
: optimize-predicate ( #call -- node ) : evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r 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 ) : optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ; node-param "optimizer-hooks" word-prop ;

2
core/optimizer/def-use/def-use-tests.factor Normal file → Executable file
View File

@ -8,7 +8,7 @@ namespaces assocs kernel sequences math tools.test words ;
] unit-test ] unit-test
: kill-set ( quot -- seq ) : kill-set ( quot -- seq )
dataflow compute-def-use dead-literals keys dataflow compute-def-use compute-dead-literals keys
[ value-literal ] map ; [ value-literal ] map ;
: subset? [ member? ] curry all? ; : subset? [ member? ] curry all? ;

63
core/optimizer/def-use/def-use.factor Normal file → Executable file
View File

@ -70,19 +70,66 @@ M: #branch node-def-use
#! #values node. #! #values node.
dup branch-def-use (node-def-use) ; 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 ; def-use get [ >r value? r> empty? and ] assoc-subset ;
: kill-node* ( node values -- ) DEFER: kill-nodes
[ swap remove-all ] curry modify-values ; SYMBOL: dead-literals
: kill-node ( node values -- ) GENERIC: kill-node* ( node -- node/t )
dup assoc-empty?
[ 2drop ] [ [ kill-node* ] curry each-node ] if ;
: 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. #! 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 ) : sole-consumer ( #call -- node/f )
node-out-d first used-by node-out-d first used-by

9
core/optimizer/known-words/known-words.factor
View File

@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match 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 ! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input ! its second-to-last input
@ -19,6 +19,11 @@ float-arrays combinators.private combinators ;
] "output-classes" set-word-prop ] "output-classes" set-word-prop
] each ] 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 ! the output of clone has the same type as the input
{ clone (clone) } [ { clone (clone) } [
[ [
@ -98,7 +103,7 @@ float-arrays combinators.private combinators ;
[ [
num-types get swap [ num-types get swap [
[ [
[ type>class 0 `input class, ] keep [ type>class object or 0 `input class, ] keep
0 `output literal, 0 `output literal,
] set-constraints ] set-constraints
] curry each ] curry each

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

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

2
core/optimizer/optimizer.factor
View File

@ -10,7 +10,7 @@ IN: optimizer
H{ } clone literal-substitutions set H{ } clone literal-substitutions set
H{ } clone value-substitutions set H{ } clone value-substitutions set
dup compute-def-use dup compute-def-use
dup kill-values kill-values
dup infer-classes dup infer-classes
optimizer-changed off optimizer-changed off
optimize-nodes optimize-nodes

2
core/optimizer/specializers/specializers.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators namespaces sequences vectors words strings layouts combinators
combinators.private classes generic.standard assocs ; sequences.private classes generic.standard assocs ;
IN: optimizer.specializers IN: optimizer.specializers
: (make-specializer) ( class picker -- quot ) : (make-specializer) ( class picker -- quot )

5
core/parser/parser.factor
View File

@ -18,7 +18,7 @@ TUPLE: lexer text line line-text line-length column ;
: <lexer> ( text -- lexer ) : <lexer> ( text -- lexer )
0 { set-lexer-text set-lexer-line } lexer construct 0 { set-lexer-text set-lexer-line } lexer construct
dup lexer-text empty? [ dup next-line ] unless ; dup next-line ;
: location ( -- loc ) : location ( -- loc )
file get lexer get lexer-line 2dup and file get lexer get lexer-line 2dup and
@ -107,6 +107,7 @@ M: bad-escape summary drop "Bad escape code" ;
: escape ( escape -- ch ) : escape ( escape -- ch )
H{ H{
{ CHAR: a CHAR: \a }
{ CHAR: e CHAR: \e } { CHAR: e CHAR: \e }
{ CHAR: n CHAR: \n } { CHAR: n CHAR: \n }
{ CHAR: r CHAR: \r } { CHAR: r CHAR: \r }
@ -479,7 +480,7 @@ SYMBOL: interactive-vocabs
[ [ parse-file call ] keep ] assert-depth drop ; [ [ parse-file call ] keep ] assert-depth drop ;
: ?run-file ( path -- ) : ?run-file ( path -- )
dup ?resource-path exists? [ run-file ] [ drop ] if ; dup resource-exists? [ run-file ] [ drop ] if ;
: bootstrap-file ( path -- ) : bootstrap-file ( path -- )
[ parse-file % ] [ run-file ] if-bootstrapping ; [ parse-file % ] [ run-file ] if-bootstrapping ;

17
core/prettyprint/backend/backend.factor
View File

@ -58,6 +58,7 @@ M: f pprint* drop \ f pprint-word ;
! Strings ! Strings
: ch>ascii-escape ( ch -- str ) : ch>ascii-escape ( ch -- str )
H{ H{
{ CHAR: \a CHAR: a }
{ CHAR: \e CHAR: e } { CHAR: \e CHAR: e }
{ CHAR: \n CHAR: n } { CHAR: \n CHAR: n }
{ CHAR: \r CHAR: r } { CHAR: \r CHAR: r }
@ -135,6 +136,7 @@ GENERIC: pprint-delims ( obj -- start end )
M: quotation pprint-delims drop \ [ \ ] ; M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ; M: curry pprint-delims drop \ [ \ ] ;
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ; M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ; M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ; M: byte-vector pprint-delims drop \ BV{ \ } ;
@ -156,6 +158,8 @@ M: vector >pprint-sequence ;
M: bit-vector >pprint-sequence ; M: bit-vector >pprint-sequence ;
M: byte-vector >pprint-sequence ; M: byte-vector >pprint-sequence ;
M: float-vector >pprint-sequence ; M: float-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ; M: hashtable >pprint-sequence >alist ;
M: tuple >pprint-sequence tuple>array ; M: tuple >pprint-sequence tuple>array ;
M: wrapper >pprint-sequence wrapped 1array ; M: wrapper >pprint-sequence wrapped 1array ;
@ -178,9 +182,20 @@ M: tuple pprint-narrow? drop t ;
>pprint-sequence pprint-elements >pprint-sequence pprint-elements
block> r> pprint-word block> block> r> pprint-word block>
] check-recursion ; ] check-recursion ;
M: object pprint* pprint-object ; 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* M: wrapper pprint*
dup wrapped word? [ dup wrapped word? [
<block \ \ pprint-word wrapped pprint-word block> <block \ \ pprint-word wrapped pprint-word block>

4
core/prettyprint/prettyprint-tests.factor
View File

@ -321,3 +321,7 @@ unit-test
[ [ 2 . ] ] [ [ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints) [ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test ] unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
[ ] [ 1 \ + compose unparse drop ] unit-test

2
core/quotations/quotations-tests.factor Normal file → Executable file
View File

@ -15,4 +15,4 @@ IN: temporary
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test [ [ "hi" ] ] [ "hi" 1quotation ] unit-test
[ 1 \ + curry ] must-fail ! [ 1 \ + curry ] must-fail

30
core/quotations/quotations.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences sequences.private USING: arrays sequences sequences.private
kernel kernel.private math assocs quotations.private ; kernel kernel.private math assocs quotations.private
slots.private ;
IN: quotations 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? M: wrapper equal?
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ; over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
UNION: callable quotation curry ; UNION: callable quotation curry compose ;
M: callable equal? M: callable equal?
over callable? [ sequence= ] [ 2drop f ] if ; over callable? [ sequence= ] [ 2drop f ] if ;
@ -19,7 +26,7 @@ M: quotation nth-unsafe quotation-array nth-unsafe ;
: >quotation ( seq -- quot ) : >quotation ( seq -- quot )
>array array>quotation ; inline >array array>quotation ; inline
M: quotation like drop dup quotation? [ >quotation ] unless ; M: callable like drop dup quotation? [ >quotation ] unless ;
INSTANCE: quotation immutable-sequence INSTANCE: quotation immutable-sequence
@ -40,6 +47,17 @@ M: curry nth
>r 1- r> curry-quot nth >r 1- r> curry-quot nth
] if ; ] if ;
M: curry like drop dup callable? [ >quotation ] unless ;
INSTANCE: curry immutable-sequence 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

32
core/sequences/sequences.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
IN: sequences IN: sequences
USING: kernel kernel.private slots.private math math.private ; USING: kernel kernel.private slots.private math math.private ;
@ -77,6 +77,8 @@ PREDICATE: fixnum array-capacity
: set-array-nth ( elt n array -- ) : set-array-nth ( elt n array -- )
swap 2 fixnum+fast set-slot ; inline swap 2 fixnum+fast set-slot ; inline
: dispatch ( n array -- ) array-nth (call) ;
GENERIC: resize ( n seq -- newseq ) flushable GENERIC: resize ( n seq -- newseq ) flushable
! Unsafe sequence protocol for inner loops ! Unsafe sequence protocol for inner loops
@ -606,7 +608,29 @@ M: sequence <=>
] if ; ] if ;
: cut-slice ( seq n -- before after ) : 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 ) : cut ( seq n -- before after )
[ head ] 2keep tail ; [ head ] 2keep tail ;
@ -657,8 +681,8 @@ PRIVATE>
: trim ( seq quot -- newseq ) : trim ( seq quot -- newseq )
[ left-trim ] keep right-trim ; inline [ left-trim ] keep right-trim ; inline
: sum ( seq -- n ) 0 [ + ] reduce ; : sum ( seq -- n ) 0 [ + ] binary-reduce ;
: product ( seq -- n ) 1 [ * ] reduce ; : product ( seq -- n ) 1 [ * ] binary-reduce ;
: infimum ( seq -- n ) dup first [ min ] reduce ; : infimum ( seq -- n ) dup first [ min ] reduce ;
: supremum ( seq -- n ) dup first [ max ] reduce ; : supremum ( seq -- n ) dup first [ max ] reduce ;

10
core/sorting/sorting.factor Normal file → Executable file
View File

@ -4,8 +4,6 @@ USING: arrays kernel math sequences vectors
sequences sequences.private growable ; sequences sequences.private growable ;
IN: sorting IN: sorting
: midpoint@ ( seq -- n ) length 2/ ; inline
DEFER: sort DEFER: sort
<PRIVATE <PRIVATE
@ -38,9 +36,6 @@ DEFER: sort
rot length rot length + <vector> rot length rot length + <vector>
[ (merge) ] keep underlying ; inline [ (merge) ] keep underlying ; inline
: divide ( seq -- first second )
dup midpoint@ [ head-slice ] 2keep tail-slice ;
: conquer ( first second quot -- result ) : conquer ( first second quot -- result )
[ tuck >r >r sort r> r> sort ] keep merge ; inline [ tuck >r >r sort r> r> sort ] keep merge ; inline
@ -48,7 +43,7 @@ PRIVATE>
: sort ( seq quot -- sortedseq ) : sort ( seq quot -- sortedseq )
over length 1 <= over length 1 <=
[ drop ] [ over >r >r divide r> conquer r> like ] if ; [ drop ] [ over >r >r halves r> conquer r> like ] if ;
inline inline
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ; : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
@ -63,8 +58,7 @@ PRIVATE>
[ midpoint@ ] keep nth-unsafe ; inline [ midpoint@ ] keep nth-unsafe ; inline
: partition ( seq n -- slice ) : partition ( seq n -- slice )
>r dup midpoint@ r> 1 < [ head-slice ] [ tail-slice ] if ; 1 < swap halves ? ; inline
inline
: (binsearch) ( elt quot seq -- i ) : (binsearch) ( elt quot seq -- i )
dup length 1 <= [ dup length 1 <= [

2
core/source-files/source-files.factor
View File

@ -26,7 +26,7 @@ uses definitions ;
rot source-file-checksum rot source-file-checksum
(source-modified?) (source-modified?)
] [ ] [
?resource-path exists? resource-exists?
] ?if ; ] ?if ;
: record-modified ( source-file -- ) : record-modified ( source-file -- )

2
core/threads/threads.factor Normal file → Executable file
View File

@ -49,7 +49,7 @@ PRIVATE>
V{ } set-catchstack V{ } set-catchstack
{ } set-retainstack { } set-retainstack
[ [ print-error ] recover stop ] call-clear [ [ print-error ] recover stop ] call-clear
] (throw) ] 1 (throw)
] curry callcc0 ; ] curry callcc0 ;
<PRIVATE <PRIVATE

30
core/vocabs/loader/loader-docs.factor
View File

@ -42,23 +42,9 @@ HELP: vocab-main
HELP: vocab-roots HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ; { $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 HELP: vocab-tests
{ $values { "vocab" "a vocabulary specifier" } { "path" string } } { $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
{ $description "Outputs a pathname relative to a vocabulary root where the unit tests for " { $snippet "vocab" } " might be found." } ; { $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
{ vocab-tests vocab-tests-path } related-words
HELP: find-vocab-root HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } } { $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" } } { $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." } ; { $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 HELP: reload
{ $values { "name" "a vocabulary name" } } { $values { "name" "a vocabulary name" } }
{ $description "Loads it's source code and documentation." } { $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 } } } { $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." } ; { $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 HELP: refresh
{ $values { "prefix" string } } { $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." } ; { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;

157
core/vocabs/loader/loader.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces splitting sequences io.files kernel assocs USING: namespaces splitting sequences io.files kernel assocs
words vocabs definitions parser continuations inspector debugger words vocabs definitions parser continuations inspector debugger
@ -15,49 +15,64 @@ V{
"resource:work" "resource:work"
} clone vocab-roots set-global } clone vocab-roots set-global
! No such thing as current directory on Windows CE : vocab-dir ( vocab -- dir )
wince? [ "." vocab-roots get push ] unless vocab-name "." split "/" join ;
: vocab-dir+ ( vocab str/f -- path ) : vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r> >r vocab-name "." split r>
[ >r dup peek r> append add ] when* [ >r dup peek r> append add ] when*
"/" join ; "/" join ;
: vocab-dir ( vocab -- dir ) : vocab-path+ ( vocab path -- newpath )
f vocab-dir+ ; swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
: vocab-source ( vocab -- path ) : vocab-source-path ( vocab -- path/f )
".factor" vocab-dir+ ; dup ".factor" vocab-dir+ vocab-path+ ;
: vocab-docs ( vocab -- path ) : vocab-docs-path ( vocab -- path/f )
"-docs.factor" vocab-dir+ ; dup "-docs.factor" vocab-dir+ vocab-path+ ;
: vocab-tests ( vocab -- path ) : vocab-dir? ( root name -- ? )
"-tests.factor" vocab-dir+ ; over [
".factor" vocab-dir+ path+ resource-exists?
] [
2drop f
] if ;
: find-vocab-root ( vocab -- path/f ) : find-vocab-root ( vocab -- path/f )
vocab-dir vocab-roots get vocab-roots get swap [ vocab-dir? ] curry find nip ;
swap [ path+ ?resource-path exists? ] curry find nip ;
M: string vocab-root M: string vocab-root
dup vocab [ vocab-root ] [ find-vocab-root ] ?if ; dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
M: vocab-link vocab-root 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 ) : vocab-files ( vocab -- seq )
[ f >vocab-link [
dup vocab-root dup [ dup vocab-source-path [ , ] when*
swap dup vocab-docs-path [ , ] when*
2dup vocab-source path+ , vocab-tests %
2dup vocab-docs path+ , ] { } make ;
2dup vocab-tests path+ ,
] when 2drop
] { } make [ ?resource-path exists? ] subset ;
TUPLE: no-vocab name ; 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" ; 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? ; : source-wasn't-loaded f swap set-vocab-source-loaded? ;
: load-source ( root name -- ) : load-source ( vocab-link -- )
[ source-wasn't-loaded ] keep [ source-wasn't-loaded ] keep
[ vocab-source path+ bootstrap-file ] keep [ vocab-source-path bootstrap-file ] keep
source-was-loaded ; source-was-loaded ;
: docs-were-loaded t swap set-vocab-docs-loaded? ; : docs-were-loaded t swap set-vocab-docs-loaded? ;
: docs-weren't-loaded f 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 [ load-help? get [
[ docs-weren't-loaded ] keep [ docs-weren't-loaded ] keep
[ vocab-docs path+ ?run-file ] keep [ vocab-docs-path ?run-file ] keep
docs-were-loaded docs-were-loaded
] [ 2drop ] if ; ] [ drop ] if ;
: amend-vocab-from-root ( root name -- vocab ) : create-vocab-with-root ( vocab-link -- vocab )
dup vocab-source-loaded? [ 2dup load-source ] unless dup vocab-name create-vocab
dup vocab-docs-loaded? [ 2dup load-docs ] unless swap vocab-root over set-vocab-root ;
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 ;
: reload ( name -- ) : reload ( name -- )
[ [
dup find-vocab-root dup [ f >vocab-link
swap load-vocab-from-root dup vocab-root [
] [ dup vocab-source-path resource-exists? [
drop no-vocab create-vocab-with-root
] if dup load-source
load-docs
] [ no-vocab ] if
] [ no-vocab ] if
] with-compiler-errors ; ] with-compiler-errors ;
: require ( vocab -- ) : require ( vocab -- )
@ -122,18 +131,6 @@ SYMBOL: load-help?
[ nip ] assoc-subset [ nip ] assoc-subset
[ nip source-modified? ] assoc-subset keys ; inline [ 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 ) : modified-sources ( vocabs -- seq )
[ vocab-source-path ] modified ; [ vocab-source-path ] modified ;
@ -151,27 +148,28 @@ SYMBOL: load-help?
: vocab-heading. ( vocab -- ) : vocab-heading. ( vocab -- )
nl nl
"==== " write "==== " write
dup vocab-name swap f >vocab-link write-object ":" print dup vocab-name swap vocab write-object ":" print
nl ; nl ;
: load-error. ( triple -- ) : load-error. ( triple -- )
dup first vocab-heading. dup first vocab-heading.
dup second print-error dup second print-error
drop ; drop ;
! third "Traceback" swap write-object ;
: load-failures. ( failures -- ) : load-failures. ( failures -- )
[ load-error. nl ] each ; [ load-error. nl ] each ;
SYMBOL: blacklist
: require-all ( vocabs -- failures ) : require-all ( vocabs -- failures )
[ [
V{ } clone blacklist set
[ [
[ [ require ]
[ require ] [ >r vocab-name r> 2array blacklist get push ]
[ error-continuation get 3array , ] recover
recover ] each
] each blacklist get
] { } make
] with-compiler-errors ; ] with-compiler-errors ;
: do-refresh ( modified-sources modified-docs -- ) : do-refresh ( modified-sources modified-docs -- )
@ -185,10 +183,12 @@ SYMBOL: load-help?
: refresh-all ( -- ) "" refresh ; : refresh-all ( -- ) "" refresh ;
GENERIC: (load-vocab) ( name -- vocab ) GENERIC: (load-vocab) ( name -- vocab )
!
M: vocab (load-vocab) M: vocab (load-vocab)
dup vocab-root dup vocab-root [
[ swap vocab-name amend-vocab-from-root ] when* ; dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
] when ;
M: string (load-vocab) M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ; [ ".private" ?tail drop reload ] keep vocab ;
@ -196,8 +196,25 @@ M: string (load-vocab)
M: vocab-link (load-vocab) M: vocab-link (load-vocab)
vocab-name (load-vocab) ; vocab-name (load-vocab) ;
[ [ dup vocab [ ] [ ] ?if (load-vocab) ] with-compiler-errors ] TUPLE: blacklisted-vocab name ;
load-vocab-hook set-global
: 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-where ( vocab -- loc )
vocab-source-path dup [ 1 2array ] when ; vocab-source-path dup [ 1 2array ] when ;

11
core/vocabs/vocabs.factor
View File

@ -85,7 +85,8 @@ SYMBOL: load-vocab-hook
TUPLE: vocab-link name root ; 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? M: vocab-link equal?
over vocab-link? over vocab-link?
@ -96,7 +97,13 @@ M: vocab-link hashcode*
M: vocab-link vocab-name vocab-link-name ; 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 ; over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
UNION: vocab-spec vocab vocab-link ; UNION: vocab-spec vocab vocab-link ;

2
core/words/words.factor
View File

@ -115,7 +115,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
compiled-crossref get at ; compiled-crossref get at ;
M: word redefined* ( word -- ) M: word redefined* ( word -- )
{ "inferred-effect" "base-case" "no-effect" } reset-props ; { "inferred-effect" "no-effect" } reset-props ;
SYMBOL: changed-words SYMBOL: changed-words

2
extra/base64/base64-tests.factor
View File

@ -1,4 +1,4 @@
USING: tools.test base64 ; USING: kernel tools.test base64 strings ;
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
] unit-test ] unit-test

4
extra/base64/base64.factor
View File

@ -35,13 +35,13 @@ PRIVATE>
#! pad string with = when not enough bits #! pad string with = when not enough bits
dup length dup 3 mod - cut swap dup length dup 3 mod - cut swap
[ [
3 group [ encode3 % ] each 3 <groups> [ encode3 % ] each
dup empty? [ drop ] [ >base64-rem % ] if dup empty? [ drop ] [ >base64-rem % ] if
] "" make ; ] "" make ;
: base64> ( base64 -- str ) : base64> ( base64 -- str )
#! input length must be a multiple of 4 #! 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 ; ] SBUF" " make swap [ dup pop* ] times >string ;

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

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

2
extra/benchmark/dispatch4/dispatch4.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: kernel.private kernel sequences math combinators USING: kernel.private kernel sequences math combinators
combinators.private ; sequences.private ;
IN: benchmark.dispatch4 IN: benchmark.dispatch4
: foobar-1 : foobar-1

43
extra/benchmark/sockets/sockets.factor Executable file
View File

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

8
extra/bootstrap/help/help.factor
View File

@ -13,13 +13,7 @@ IN: bootstrap.help
vocabs vocabs
[ vocab-root ] subset [ vocab-root ] subset
[ vocab-source-loaded? ] subset [ vocab-source-loaded? ] subset
[ [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
dup vocab-docs-loaded? [
drop
] [
dup vocab-root swap load-docs
] if
] each
] with-variable ] with-variable
"help.handbook" require ; "help.handbook" require ;

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

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

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

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

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

@ -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 system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client prettyprint tools.time calendar bake vars http.client
combinators ; combinators bootstrap.image bootstrap.image.download
combinators.cleave ;
IN: builder IN: builder
@ -29,16 +30,34 @@ IN: builder
SYMBOL: builder-recipients 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 -- ) : email-file ( subject file -- )
`{ `{
{ +stdin+ , } { +stdin+ , }
{ +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } } { +arguments+
{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
} }
>hashtable run-process drop ; >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 ( -- ) : git-pull ( -- desc )
datestamp >stamp
"/builds/factor" cd
{ {
"git" "git"
"pull" "pull"
"--no-summary" "--no-summary"
"git://factorcode.org/git/factor.git" "git://factorcode.org/git/factor.git"
! "http://dharmatech.onigirihouse.com/factor.git"
"master" "master"
} } ;
run-process process-status
0 =
[ ]
[
"builder: git pull" email-string
"builder: git pull" throw
]
if
"/builds/" stamp> append make-directory : git-clone ( -- desc ) { "git" "clone" "../factor" } ;
"/builds/" stamp> append cd
{ "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 : record-git-id ( -- ) git-id "../git-id" log-object ;
"../git-id" log-object
{ "make" "clean" } run-process drop : make-clean ( -- desc ) { "make" "clean" } ;
: make-vm ( -- )
`{ `{
{ +arguments+ { "make" ,[ target ] } } { +arguments+ { "make" ,[ target ] } }
{ +stdout+ "../compile-log" } { +stdout+ "../compile-log" }
{ +stderr+ +stdout+ } { +stderr+ +stdout+ }
} }
>hashtable run-process process-status >hashtable ;
0 =
: 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 ] [ "builder: image download" email-string ]
recover cleanup
flush ;
: bootstrap ( -- desc )
`{ `{
{ +arguments+ { { +arguments+ {
,[ factor-binary ] ,[ factor-binary ]
,[ "-i=" boot-image-name append ] ,[ "-i=" my-boot-image-name append ]
"-no-user-init" "-no-user-init"
} } } }
{ +stdout+ "../boot-log" } { +stdout+ "../boot-log" }
{ +stderr+ +stdout+ } { +stderr+ +stdout+ }
} }
>hashtable [ run-process ] "../boot-time" log-runtime process-status >hashtable ;
0 =
[ ]
[
"builder: bootstrap" "../boot-log" email-file
"builder: bootstrap" throw
] if
`{ ,[ 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? ! SYMBOL: build-status
[ "builder: failing tests" "../failing-tests" email-file ]
when
; ! : 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

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

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

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

@ -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
io.files io.files
prettyprint
tools.browser tools.browser
tools.test ; tools.test
bootstrap.stage2 ;
IN: builder.test 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 ( -- ) : do-load ( -- )
[ [
[ load-everything ] "../load-everything-log" <file-writer>
[ require-all-error-vocabs "../load-everything-log" log-object ] [ try-everything* ]
recover with-stream
] ] "../load-everything-time" log-runtime
"../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 ( -- ) : 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> "../test-all-log" <file-writer>
[ [ nl failures. ] assoc-each ] [ run-all-tests keys ]
with-stream with-stream
] ] "../test-all-time" log-runtime
if ; 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 MAIN: do-all

1
extra/cocoa/cocoa.factor
View File

@ -58,6 +58,7 @@ SYMBOL: super-sent-messages
"NSPasteboard" "NSPasteboard"
"NSResponder" "NSResponder"
"NSSavePanel" "NSSavePanel"
"NSScreen"
"NSView" "NSView"
"NSWindow" "NSWindow"
"NSWorkspace" "NSWorkspace"

36
extra/combinators/lib/lib-docs.factor
View File

@ -47,42 +47,6 @@ HELP: nkeep
} }
{ $see-also keep nslip } ; { $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: && HELP: &&
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } } { $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." } ; { $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." } ;

11
extra/combinators/lib/lib-tests.factor
View File

@ -4,11 +4,7 @@ IN: temporary
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] 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 2 [ 5 + ] dip ] unit-test
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] 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 [ 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 { 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 + ] ] [ 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 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
[ [ sq ] 3apply ] must-infer [ [ sq ] 3apply ] must-infer
@ -55,5 +46,3 @@ IN: temporary
[ dup array? ] [ dup vector? ] [ dup float? ] [ dup array? ] [ dup vector? ] [ dup float? ]
} || nip } || nip
] unit-test ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

114
extra/combinators/lib/lib.factor
View File

@ -1,11 +1,9 @@
! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman, ! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
! Eduardo Cavazos, Daniel Ehrenberg. ! Eduardo Cavazos, Daniel Ehrenberg.
!
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators namespaces quotations hashtables
USING: kernel combinators namespaces quotations hashtables sequences assocs sequences assocs arrays inference effects math math.ranges
arrays inference effects math math.ranges arrays.lib shuffle macros arrays.lib shuffle macros bake combinators.cleave ;
bake combinators.cleave ;
IN: combinators.lib IN: combinators.lib
@ -51,22 +49,6 @@ MACRO: napply ( n -- )
: dipd ( x y quot -- y ) 2 ndip ; inline : 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 ) : 2with ( param1 param2 obj quot -- obj curry )
with with ; inline with with ; inline
@ -88,39 +70,23 @@ MACRO: napply ( n -- )
: assoc-map-with ( obj assoc quot -- assoc ) : assoc-map-with ( obj assoc quot -- assoc )
with* assoc-map ; inline 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 circuiting words
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : short-circuit ( quots quot default -- quot )
! >r { } map>assoc <reversed> r>
! 1quotation swap alist>quot ;
: short-circuit ( quots quot default -- quot ) : short-circuit ( quots quot default -- quot )
1quotation -rot { } map>assoc <reversed> alist>quot ; 1quotation -rot { } map>assoc <reversed> alist>quot ;
! : short-circuit ( quots quot default -- quot ) MACRO: && ( quots -- ? )
! 1quotation -rot map>alist <reversed> alist>quot ; [ [ not ] append [ f ] ] t short-circuit ;
MACRO: && ( quots -- ? ) [ [ not ] append [ f ] ] t short-circuit ;
MACRO: <-&& ( quots -- ) MACRO: <-&& ( quots -- )
[ [ dup ] swap append [ not ] append [ f ] ] t short-circuit [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
[ nip ] append ; [ nip ] append ;
MACRO: <--&& ( quots -- ) MACRO: <--&& ( quots -- )
[ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
[ 2nip ] append ; [ 2nip ] append ;
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
@ -129,25 +95,25 @@ MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: ifte ( quot quot quot -- ) MACRO: ifte ( quot quot quot -- )
pick infer effect-in pick infer effect-in
dup 1+ swap dup 1+ swap
[ >r >r , nkeep , nrot r> r> if ] [ >r >r , nkeep , nrot r> r> if ]
bake ; bake ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! switch ! switch
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: preserving ( predicate -- quot ) : preserving ( predicate -- quot )
dup infer effect-in dup infer effect-in
dup 1+ spin dup 1+ spin
[ , , nkeep , nrot ] [ , , nkeep , nrot ]
bake ; bake ;
MACRO: switch ( quot -- ) MACRO: switch ( quot -- )
[ [ preserving ] [ ] bi* ] assoc-map [ [ preserving ] [ ] bi* ] assoc-map
[ , cond ] [ , cond ]
bake ; bake ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -156,41 +122,34 @@ MACRO: switch ( quot -- )
! : pcall ( seq quots -- seq ) [ call ] 2map ; ! : pcall ( seq quots -- seq ) [ call ] 2map ;
MACRO: parallel-call ( quots -- ) MACRO: parallel-call ( quots -- )
[ [ unclip % r> dup >r push ] bake ] map concat [ [ unclip % r> dup >r push ] bake ] map concat
[ V{ } clone >r % drop r> >array ] bake ; [ 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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! map-call and friends ! map-call and friends
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (make-call-with) ( quots -- quot ) : (make-call-with) ( quots -- quot )
[ [ keep ] curry ] map concat [ drop ] append ; [ [ keep ] curry ] map concat [ drop ] append ;
MACRO: call-with ( quots -- ) MACRO: call-with ( quots -- )
(make-call-with) ; (make-call-with) ;
MACRO: map-call-with ( quots -- ) 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 ) : (make-call-with2) ( quots -- quot )
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
[ 2drop ] append ; [ 2drop ] append ;
MACRO: call-with2 ( quots -- ) MACRO: call-with2 ( quots -- )
(make-call-with2) ; (make-call-with2) ;
MACRO: map-call-with2 ( quots -- ) 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 ) MACRO: construct-slots ( assoc tuple-class -- tuple )
[ construct-empty ] curry swap [ [ construct-empty ] curry swap [
@ -208,14 +167,3 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
: and? ( obj quot1 quot2 -- ? ) : and? ( obj quot1 quot2 -- ? )
>r keep r> rot [ call ] [ 2drop f ] if ; inline >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

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

@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers"
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" 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 } ":" { $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\" }" } { $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\"" } { $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." ; "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." ;

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

@ -112,9 +112,9 @@ SYMBOL: value
! The following unit test blocks forever if the ! The following unit test blocks forever if the
! exception does not propogate. Uncomment when ! exception does not propogate. Uncomment when
! this is fixed (via a timeout). ! this is fixed (via a timeout).
! [ [
! [ "this should propogate" throw ] future ?future [ "this should propogate" throw ] future ?future
! ] must-fail ] must-fail
[ ] [ [ ] [
[ "this should not propogate" throw ] future drop [ "this should not propogate" throw ] future drop
@ -127,4 +127,15 @@ SYMBOL: value
[ f ] [ [ f ] [
[ "testing unregistering on error" throw ] spawn [ "testing unregistering on error" throw ] spawn
100 sleep process-pid get-process 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

26
extra/concurrency/concurrency.factor
View File

@ -264,19 +264,31 @@ PRIVATE>
#! so the server continuation gets its new self updated. #! so the server continuation gets its new self updated.
self swap call ; 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 ) : future ( quot -- future )
#! Spawn a process to call the quotation and immediately return #! Spawn a process to call the quotation and immediately return.
#! a 'future' on the stack. The future can later be queried with f V{ } clone \ future construct-boa [
#! ?future. If the quotation has completed the result will be returned. [
#! If not, the process will block until the quotation completes. >r [ t 2array ] compose [ f 2array ] recover r>
#! 'quot' must have stack effect ( -- X ). notify-future
[ self send ] compose spawn ; ] 2curry spawn drop
] keep ;
: ?future ( future -- result ) : ?future ( future -- result )
#! Block the process until the future has completed and then #! Block the process until the future has completed and then
#! place the result on the stack. Return the result #! place the result on the stack. Return the result
#! immediately if the future has completed. #! 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 ) : parallel-map ( seq quot -- newseq )
#! Spawn a process to apply quot to each element of seq, #! Spawn a process to apply quot to each element of seq,

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

@ -1 +1,2 @@
enterprise
extensions extensions

2
extra/cpu/8080/emulator/emulator.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@
USING: kernel math sequences words arrays io USING: kernel math sequences words arrays io
io.files namespaces math.parser kernel.private io.files namespaces math.parser kernel.private
assocs quotations parser parser-combinators tools.time assocs quotations parser parser-combinators tools.time
combinators.private compiler.units ; sequences.private compiler.units ;
IN: cpu.8080.emulator IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;

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

@ -1 +1 @@
emulator emulators

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

@ -1 +1 @@
emulator emulators

1
extra/cryptlib/tags.txt
View File

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

2
extra/crypto/md5/md5.factor
View File

@ -153,7 +153,7 @@ SYMBOL: old-d
dup S44 64 9 [ I ] BCDA ; dup S44 64 9 [ I ] BCDA ;
: (process-md5-block) ( block -- ) : (process-md5-block) ( block -- )
4 group [ le> ] map 4 <groups> [ le> ] map
(process-md5-block-F) (process-md5-block-F)
(process-md5-block-G) (process-md5-block-G)

25
extra/db/db.factor
View File

@ -4,12 +4,27 @@ USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words ; namespaces sequences sequences.lib tuples words ;
IN: db IN: db
TUPLE: db handle ; TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
C: <db> db ( handle -- obj ) : <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 -- ) 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? ; TUPLE: statement sql params handle bound? ;
@ -43,6 +58,8 @@ GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj ) GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- ? ) GENERIC: advance-row ( result-set -- ? )
HOOK: last-id db ( -- id )
: init-result-set ( result-set -- ) : init-result-set ( result-set -- )
dup #rows over set-result-set-max dup #rows over set-result-set-max
-1 swap set-result-set-n ; -1 swap set-result-set-n ;

1
extra/db/mysql/mysql.factor
View File

@ -14,7 +14,6 @@ M: mysql-db db-open ( mysql-db -- )
M: mysql-db dispose ( mysql-db -- ) M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ; mysql-db-handle mysql_close ;
M: mysql-db <simple-statement> ( str -- statement ) M: mysql-db <simple-statement> ( str -- statement )
; ;

Some files were not shown because too many files have changed in this diff Show More