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

Merge branch 'master' into unicode

db4
Daniel Ehrenberg 2008-02-11 18:42:08 -06:00
parent 8bbc144ce7 6832c634a1
commit 8c63311a0f
552 changed files with 9684 additions and 5964 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
Makefile
View File

@ -63,8 +63,9 @@ default:
@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@echo "windows-ce-arm"
@echo "windows-nt-x86-32"
@echo "wince-arm"
@echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo ""
@echo "Additional modifiers:"
@echo ""
@ -122,10 +123,21 @@ solaris-x86-32:
solaris-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
windows-nt-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
windows-ce-arm:
winnt-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
macosx.app: factor
@ -151,7 +163,7 @@ clean:
rm -f factor*.dll libfactor*.*
vm/resources.o:
windres vm/factor.rs vm/resources.o
$(WINDRES) vm/factor.rs vm/resources.o
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<

6
core/alien/alien-tests.factor
View File

@ -14,7 +14,7 @@ prettyprint ;
! Testing the various bignum accessor
10 <byte-array> "dump" set
[ "dump" get alien-address ] unit-test-fails
[ "dump" get alien-address ] must-fail
[ 123 ] [
123 "dump" get 0 set-alien-signed-1
@ -61,9 +61,9 @@ cell 8 = [
[ ] [ 0 F{ 1 2 3 } <displaced-alien> drop ] unit-test
[ ] [ 0 ?{ t f t } <displaced-alien> drop ] unit-test
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] unit-test-fails
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
[ 1 1 <displaced-alien> ] unit-test-fails
[ 1 1 <displaced-alien> ] must-fail
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test

4
core/alien/c-types/c-types-docs.factor
View File

@ -34,6 +34,10 @@ HELP: stack-size
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: byte-length
{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
HELP: c-getter
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }

2
core/alien/c-types/c-types-tests.factor
View File

@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
] unit-test-fails
] must-fail

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

@ -1,11 +1,17 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays generator.registers assocs
kernel kernel.private libc math namespaces parser sequences
strings words assocs splitting math.parser cpu.architecture
alien alien.accessors quotations system compiler.units ;
USING: bit-arrays byte-arrays float-arrays arrays
generator.registers assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
system compiler.units ;
IN: alien.c-types
DEFER: <int>
DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
boxer prep unboxer
getter setter
@ -107,6 +113,14 @@ M: string stack-size c-type stack-size ;
M: c-type stack-size c-type-size ;
GENERIC: byte-length ( seq -- n ) flushable
M: bit-array byte-length length 7 + -3 shift ;
M: byte-array byte-length length ;
M: float-array byte-length length "double" heap-size * ;
: c-getter ( name -- quot )
c-type c-type-getter [
[ "Cannot read struct fields with type" throw ]
@ -205,6 +219,9 @@ M: long-long-type box-return ( type -- )
over [ <c-object> tuck 0 ] over c-setter append swap
>r >r constructor-word r> r> add* define-inline ;
: c-bool> ( int -- ? )
zero? not ;
: >c-array ( seq type word -- )
>r >r dup length dup r> <c-array> dup -roll r>
[ execute ] 2curry 2each ; inline

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

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

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
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators ;
kernel.private threads continuations.private libc combinators
compiler.errors continuations ;
IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect
@ -207,9 +208,21 @@ M: alien-invoke-error summary
swap alien-node-parameters parameter-sizes drop
number>string 3append ;
TUPLE: no-such-library name ;
M: no-such-library summary
drop "Library not found" ;
: no-such-library ( name -- )
\ no-such-library +linkage+ (inference-error) ;
: (alien-invoke-dlsym) ( node -- symbol dll )
dup alien-invoke-function
swap alien-invoke-library load-library ;
swap alien-invoke-library [
load-library
] [
2drop no-such-library
] recover ;
TUPLE: no-such-symbol ;
@ -217,7 +230,7 @@ M: no-such-symbol summary
drop "Symbol not found" ;
: no-such-symbol ( -- )
\ no-such-symbol inference-error ;
\ no-such-symbol +linkage+ (inference-error) ;
: alien-invoke-dlsym ( node -- symbol dll )
dup (alien-invoke-dlsym) 2dup dlsym [

12
core/arrays/arrays-tests.factor
View File

@ -2,10 +2,10 @@ USING: arrays kernel sequences sequences.private growable
tools.test vectors layouts system math vectors.private ;
IN: temporary
[ -2 { "a" "b" "c" } nth ] unit-test-fails
[ 10 { "a" "b" "c" } nth ] unit-test-fails
[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails
[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails
[ -2 { "a" "b" "c" } nth ] must-fail
[ 10 { "a" "b" "c" } nth ] must-fail
[ "hi" -2 { "a" "b" "c" } set-nth ] must-fail
[ "hi" 10 { "a" "b" "c" } set-nth ] must-fail
[ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test
[ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
@ -17,5 +17,5 @@ IN: temporary
[ { "a" "b" "c" "d" "e" } ]
[ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test
[ -1 f <array> ] unit-test-fails
[ cell-bits cell log2 - 2^ f <array> ] unit-test-fails
[ -1 f <array> ] must-fail
[ cell-bits cell log2 - 2^ f <array> ] must-fail

2
core/bit-arrays/bit-arrays-tests.factor
View File

@ -51,4 +51,4 @@ IN: temporary
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
[ -10 ?{ } resize-bit-array ] unit-test-fails
[ -10 ?{ } resize-bit-array ] must-fail

3
core/bootstrap/image/image-tests.factor
View File

@ -1,6 +1,5 @@
IN: temporary
USING: bootstrap.image bootstrap.image.private
tools.test.inference ;
USING: bootstrap.image bootstrap.image.private tools.test ;
\ ' must-infer
\ write-image must-infer

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

@ -7,9 +7,26 @@ strings sbufs vectors words quotations assocs system layouts
splitting growable classes tuples words.private
io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private
combinators.private combinators ;
sequences.private combinators ;
IN: bootstrap.image
: my-arch ( -- arch )
cpu dup "ppc" = [ os "-" rot 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
: my-boot-image-name ( -- string )
my-arch boot-image-name ;
: images ( -- seq )
{
"x86.32"
"x86.64"
"linux-ppc" "macosx-ppc"
! "arm"
} ;
<PRIVATE
! Constants
@ -119,7 +136,7 @@ SYMBOL: undefined-quot
: here-as ( tag -- pointer ) here swap bitor ;
: align-here ( -- )
here 8 mod 4 = [ 0 emit ] when ;
here 8 mod 4 = [ heap-size drop 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
@ -160,6 +177,7 @@ GENERIC: ' ( obj -- ptr )
[ dup bignum-bits neg shift swap bignum-radix bitand ]
[ ] unfold nip ;
USE: continuations
: emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
dup length 1+ emit-fixnum
@ -197,13 +215,10 @@ M: f '
: 1, 1 >bignum ' 1-offset fixup ;
: -1, -1 >bignum ' -1-offset fixup ;
! Beginning of the image
: begin-image ( -- ) emit-header t, 0, 1, -1, ;
! Words
: emit-word ( word -- )
dup subwords [ emit-word ] each
[
dup hashcode ' ,
dup word-name ' ,
@ -224,7 +239,7 @@ M: f '
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word )
dup target-word [ ] [ word-name no-word ] ?if ;
dup target-word swap or ;
: fixup-word ( word -- offset )
transfer-word dup objects get at
@ -248,7 +263,7 @@ M: wrapper '
emit-seq ;
: pack-string ( string -- newstr )
dup length 1+ bootstrap-cell align 0 pad-right ;
dup length bootstrap-cell align 0 pad-right ;
: emit-string ( string -- ptr )
string type-number object tag-number [
@ -285,17 +300,20 @@ M: float-array ' float-array emit-dummy-array ;
] emit-object ;
: emit-tuple ( obj -- pointer )
objects get [
[
[ tuple>array unclip transfer-word , % ] { } make
tuple type-number dup emit-array
] cache ; inline
]
! Hack
over class word-name "tombstone" =
[ objects get swap cache ] [ call ] if ;
M: tuple ' emit-tuple ;
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first emit-tuple ;
word-def first objects get [ emit-tuple ] cache ;
M: array '
array type-number object tag-number emit-array ;
@ -313,41 +331,6 @@ M: quotation '
] emit-object
] cache ;
! Vectors and sbufs
M: vector '
dup length swap underlying '
tuple type-number tuple tag-number [
4 emit-fixnum
vector ' emit
f ' emit
emit ! array ptr
emit-fixnum ! length
] emit-object ;
M: sbuf '
dup length swap underlying '
tuple type-number tuple tag-number [
4 emit-fixnum
sbuf ' emit
f ' emit
emit ! array ptr
emit-fixnum ! length
] emit-object ;
! Hashes
M: hashtable '
[ hash-array ' ] keep
tuple type-number tuple tag-number [
5 emit-fixnum
hashtable ' emit
f ' emit
dup hash-count emit-fixnum
hash-deleted emit-fixnum
emit ! array ptr
] emit-object ;
! Curries
M: curry '
@ -399,7 +382,10 @@ M: curry '
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
: end-image ( -- )
: build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
@ -414,7 +400,8 @@ M: curry '
fixup-header
"Image length: " write image get length .
"Object cache size: " write objects get assoc-size .
\ word global delete-at ;
\ word global delete-at
image get ;
! Image output
@ -425,37 +412,23 @@ M: curry '
[ >le write ] curry each
] if ;
: image-name
"boot." architecture get ".image" 3append resource-path ;
: write-image ( image filename -- )
"Writing image to " write dup write "..." print flush
: write-image ( image -- )
"Writing image to " write
architecture get boot-image-name resource-path
dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ;
: prepare-image ( -- )
bootstrapping? on
load-help? off
800000 <vector> image set
20000 <hashtable> objects set ;
PRIVATE>
: make-image ( arch -- )
architecture [
prepare-image
begin-image
[
architecture set
bootstrapping? on
load-help? off
"resource:/core/bootstrap/stage1.factor" run-file
end-image
image get image-name write-image
] with-variable ;
: my-arch ( -- arch )
cpu dup "ppc" = [ os "-" rot 3append ] when ;
build-image
write-image
] with-scope ;
: make-images ( -- )
{
"x86.32"
"x86.64"
"linux-ppc" "macosx-ppc"
! "arm"
} [ 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.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
@ -8,7 +8,7 @@ BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
20 num-types set
19 num-types set
H{
{ fixnum BIN: 000 }
@ -27,11 +27,10 @@ tag-numbers get H{
{ float-array 10 }
{ callstack 11 }
{ string 12 }
{ curry 13 }
{ bit-array 13 }
{ quotation 14 }
{ dll 15 }
{ alien 16 }
{ word 17 }
{ byte-array 18 }
{ bit-array 19 }
} union type-numbers set

64
core/bootstrap/primitives.factor
View File

@ -118,11 +118,11 @@ H{ } clone update-map set
H{ } clone typemap set
num-types get f <array> builtins set
! These symbols are needed by the code that executes below
{
{ "object" "kernel" }
{ "null" "kernel" }
} [ create drop ] assoc-each
! Forward definitions
"object" "kernel" create t "class" set-word-prop
"object" "kernel" create union-class "metaclass" set-word-prop
"null" "kernel" create drop
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@ -295,23 +295,6 @@ define-builtin
"float-array?" "float-arrays" create
{ } define-builtin
"curry" "kernel" create
"curry?" "kernel" create
{
{
{ "object" "kernel" }
"obj"
{ "curry-obj" "kernel" }
f
}
{
{ "object" "kernel" }
"obj"
{ "curry-quot" "kernel" }
f
}
} define-builtin
"callstack" "kernel" create "callstack?" "kernel" create
{ } define-builtin
@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class
}
} define-tuple-class
"curry" "kernel" create
{
{
{ "object" "kernel" }
"obj"
{ "curry-obj" "kernel" }
f
} {
{ "object" "kernel" }
"quot"
{ "curry-quot" "kernel" }
f
}
} define-tuple-class
"compose" "kernel" create
{
{
{ "object" "kernel" }
"first"
{ "compose-first" "kernel" }
f
} {
{ "object" "kernel" }
"second"
{ "compose-second" "kernel" }
f
}
} define-tuple-class
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
>r create dup reset-word r>
[ do-primitive ] curry [ ] like define ;
{
{ "(execute)" "words.private" }
{ "(call)" "kernel.private" }
{ "uncurry" "kernel.private" }
{ "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" }
@ -553,8 +566,6 @@ builtins get num-tags get tail f union-class define-class
{ "millis" "system" }
{ "type" "kernel.private" }
{ "tag" "kernel.private" }
{ "cwd" "io.files" }
{ "cd" "io.files" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
@ -624,7 +635,6 @@ builtins get num-tags get tail f union-class define-class
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "curry" "kernel" }
{ "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }

3
core/bootstrap/stage1.factor
View File

@ -32,12 +32,13 @@ vocabs.loader system ;
"io.streams.c" require
"vocabs.loader" require
"syntax" require
"bootstrap.layouts" require
[
"resource:core/bootstrap/stage2.factor"
dup ?resource-path exists? [
dup resource-exists? [
run-file
] [
"Cannot find " write write "." print

88
core/bootstrap/stage2.factor
View File

@ -1,31 +1,70 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init command-line namespaces words debugger io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
math.parser ;
math.parser generic ;
IN: bootstrap.stage2
SYMBOL: bootstrap-time
: default-image-name ( -- string )
vm file-name windows? [ "." split1 drop ] when
".image" append ;
: do-crossref ( -- )
"Cross-referencing..." print flush
H{ } clone crossref set-global
xref-words
xref-generics
xref-sources ;
: load-components ( -- )
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each ;
: compile-remaining ( -- )
"Compiling remaining words..." print flush
vocabs [
words "compile" "compiler" lookup execute
] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;
: print-report ( time -- )
1000 /i
60 /mod swap
"Bootstrap completed in " write number>string write
" minutes and " write number>string write " seconds." print
[ compiled? ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"Bootstrapping is complete." print
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ;
! Wrap everything in a catch which starts a listener so
! you can see what went wrong, instead of dealing with a
! fep
[
vm file-name windows? [ "." split1 drop ] when
".image" append "output-image" set-global
! We time bootstrap
millis >r
"math tools help compiler ui ui.tools io" "include" set-global
default-image-name "output-image" set-global
"math help compiler tools ui ui.tools io" "include" set-global
"" "exclude" set-global
parse-command-line
"-no-crossref" cli-args member? [
"Cross-referencing..." print flush
H{ } clone crossref set-global
xref-words
xref-sources
] unless
"-no-crossref" cli-args member? [ do-crossref ] unless
! Set dll paths
wince? [ "windows.ce" require ] when
@ -39,19 +78,12 @@ IN: bootstrap.stage2
] if
[
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
[ "bootstrap." swap append require ] each
load-components
run-bootstrap-init
"Compiling remaining words..." print flush
"bootstrap.compiler" vocab [
vocabs [
words "compile" "compiler" lookup execute
] each
compile-remaining
] when
] with-compiler-errors
:errors
@ -73,19 +105,13 @@ IN: bootstrap.stage2
] [ print-error 1 exit ] recover
] set-boot-quot
: count-words ( pred -- )
all-words swap subset length number>string write ;
[ compiled? ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"Bootstrapping is complete." print
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush
millis r> - dup bootstrap-time set-global
print-report
"output-image" get resource-path save-image-and-exit
] if
] [
print-error :c "listener" vocab-main execute
print-error :c restarts.
"listener" vocab-main execute
1 exit
] recover

2
core/byte-arrays/byte-arrays-tests.factor
View File

@ -5,4 +5,4 @@ USING: tools.test byte-arrays ;
[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
[ -10 B{ } resize-byte-array ] unit-test-fails
[ -10 B{ } resize-byte-array ] must-fail

16
core/classes/classes-tests.factor
View File

@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ "union-1" ] [ 8 generic-update-test ] unit-test
[ -7 generic-update-test ] unit-test-fails
[ -7 generic-update-test ] must-fail
! Test mixins
MIXIN: sequence-mixin
@ -169,10 +169,14 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
UNION: forget-class-bug-1 integer ;
UNION: forget-class-bug-2 forget-class-bug-1 dll ;
FORGET: forget-class-bug-1
FORGET: forget-class-bug-2
[
\ forget-class-bug-1 forget
\ forget-class-bug-2 forget
] with-compilation-unit
[ t ] [ integer dll class-or interned? ] unit-test
[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
DEFER: mixin-forget-test-g
@ -191,7 +195,7 @@ DEFER: mixin-forget-test-g
] unit-test
[ { } ] [ { } mixin-forget-test-g ] unit-test
[ H{ } mixin-forget-test-g ] unit-test-fails
[ H{ } mixin-forget-test-g ] must-fail
[ ] [
{
@ -205,7 +209,7 @@ DEFER: mixin-forget-test-g
parse-stream drop
] unit-test
[ { } mixin-forget-test-g ] unit-test-fails
[ { } mixin-forget-test-g ] must-fail
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
! Method flattening interfered with mixin update

6
core/classes/classes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: classes
USING: arrays definitions assocs kernel
@ -20,7 +20,9 @@ PREDICATE: class tuple-class
: classes ( -- seq ) class<map get keys ;
: type>class ( n -- class ) builtins get nth ;
: type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;

29
core/classes/union/union.factor
View File

@ -1,19 +1,34 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
generic.standard namespaces arrays ;
generic.standard namespaces arrays math quotations ;
IN: classes.union
PREDICATE: class union-class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
: small-union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
] [
unclip first "predicate" word-prop swap
[ >r "predicate" word-prop [ dup ] swap append r> ]
assoc-map alist>quot
] if ;
: big-union-predicate-quot ( members -- quot )
[ small-union-predicate-quot ] [ dup ]
class-hash-dispatch-quot ;
: union-predicate-quot ( members -- quot )
0 (dispatch#) [
[ [ drop t ] ] { } map>assoc
object bootstrap-word [ drop f ] 2array add*
single-combination
] with-variable ;
[ [ drop t ] ] { } map>assoc
dup length 4 <= [
small-union-predicate-quot
] [
flatten-methods
big-union-predicate-quot
] if ;
: define-union-predicate ( class -- )
dup predicate-word

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
kernel quotations generic generic.standard classes
math assocs sequences combinators.private ;
math assocs sequences sequences.private ;
IN: combinators
ARTICLE: "combinators-quot" "Quotation construction utilities"

2
core/combinators/combinators-tests.factor
View File

@ -38,7 +38,7 @@ namespaces combinators words ;
! Interpreted
[ "two" ] [ 2 \ case-test-1 word-def call ] unit-test
[ "x" case-test-1 ] unit-test-fails
[ "x" case-test-1 ] must-fail
: case-test-2
{

6
core/combinators/combinators.factor
View File

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

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

2
core/compiler/compiler.factor
View File

@ -26,7 +26,7 @@ IN: compiler
>r dupd save-effect r>
f pick compiler-error
over compiled-unxref
over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
over crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[

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

@ -1,14 +1,15 @@
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
quotations ;
quotations compiler.errors.private ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"The compiler saves compile warnings and errors in a global variable:"
"The compiler saves various notifications in a global variable:"
{ $subsection compiler-errors }
"The warnings and errors can be viewed later:"
{ $subsection :warnings }
"These notifications can be viewed later:"
{ $subsection :errors }
"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:"
{ $subsection :warnings }
{ $subsection :linkage }
"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
{ $link with-compiler-errors } ;
HELP: compiler-errors
@ -16,7 +17,7 @@ HELP: compiler-errors
HELP: compiler-error
{ $values { "error" "an error" } { "word" word } }
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ;
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
HELP: compiler-error.
{ $values { "error" "an error" } { "word" word } }
@ -25,24 +26,18 @@ HELP: compiler-error.
HELP: compiler-errors.
{ $values { "errors" "an assoc mapping words to errors" } }
{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
HELP: (:errors)
{ $values { "seq" "an alist" } }
{ $description "Outputs all serious compiler errors from the most recent compile." } ;
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
HELP: (:warnings)
{ $values { "seq" "an alist" } }
{ $description "Outputs all ignorable compiler warnings from the most recent compile." } ;
HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
{ :errors (:errors) :warnings (:warnings) } related-words
HELP: :linkage
{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
{ :errors :warnings } related-words
HELP: with-compiler-errors
{ $values { "quot" quotation } }
{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." }
{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;

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 ;
IN: compiler.errors
SYMBOL: +error+
SYMBOL: +warning+
SYMBOL: +linkage+
GENERIC: compiler-error-type ( error -- ? )
M: object compiler-error-type drop +error+ ;
<PRIVATE
SYMBOL: compiler-errors
SYMBOL: with-compiler-errors?
: compiler-error ( error word -- )
with-compiler-errors? get [
compiler-errors get pick
[ set-at ] [ delete-at drop ] if
] [ 2drop ] if ;
: compiler-error. ( error word -- )
nl
"While compiling " write pprint ": " print
nl
print-error ;
: compiler-errors. ( assoc -- )
>alist sort-keys [ swap compiler-error. ] assoc-each ;
GENERIC: compiler-warning? ( error -- ? )
M: object compiler-warning? drop f ;
: (:errors) ( -- assoc )
: errors-of-type ( type -- assoc )
compiler-errors get-global
[ nip compiler-warning? not ] assoc-subset ;
swap [ >r nip compiler-error-type r> eq? ] curry
assoc-subset ;
: :errors (:errors) compiler-errors. ;
: compiler-errors. ( type -- )
errors-of-type >alist sort-keys
[ swap compiler-error. ] assoc-each ;
: (:warnings) ( -- seq )
compiler-errors get-global
[ nip compiler-warning? ] assoc-subset ;
: :warnings (:warnings) compiler-errors. ;
: (compiler-report) ( what assoc -- )
length dup zero? [ 2drop ] [
: (compiler-report) ( what type word -- )
over errors-of-type assoc-empty? [ 3drop ] [
[
":" % over % " - print " % # " compiler " % % "." %
":" %
%
" - print " %
errors-of-type assoc-size #
" " %
%
"." %
] "" make print
] if ;
: compiler-report ( -- )
"errors" (:errors) (compiler-report)
"warnings" (:warnings) (compiler-report) ;
"semantic errors" +error+ "errors" (compiler-report)
"semantic warnings" +warning+ "warnings" (compiler-report)
"linkage errors" +linkage+ "linkage" (compiler-report) ;
PRIVATE>
: compiler-error ( error word -- )
with-compiler-errors? get [
compiler-errors get pick
[ set-at ] [ delete-at drop ] if
] [ 2drop ] if ;
: :errors +error+ compiler-errors. ;
: :warnings +warning+ compiler-errors. ;
: :linkage +linkage+ compiler-errors. ;
: with-compiler-errors ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [

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

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

@ -1,252 +0,0 @@
USING: compiler definitions generic assocs inference math
namespaces parser tools.test words kernel sequences arrays io
effects tools.test.inference 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 ] unit-test-effect
[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
{ 0 6 } [ b ] unit-test-effect
\ 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 ] unit-test-effect
[ 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
[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] 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
[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] 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 ] unit-test-fails
[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
[ 2 1 ] [ defer-redefine-test-2 ] 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 ] unit-test-fails
[ [ drop ] compile-call ] unit-test-fails
! 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

6
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
system random layouts vectors.private sbufs.private
strings.private slots.private alien alien.accessors
alien.c-types alien.syntax namespaces libc combinators.private ;
alien.c-types alien.syntax namespaces libc sequences.private ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
@ -422,11 +422,11 @@ cell 8 = [
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] unit-test-fails
] must-fail
[
B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
] unit-test-fails
] must-fail
[
4 5

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

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

@ -10,7 +10,7 @@ words splitting ;
: foo 3 throw 7 ;
: bar foo 4 ;
: baz bar 5 ;
[ 3 ] [ [ baz ] catch ] unit-test
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
[ word? ] subset
@ -22,11 +22,11 @@ words splitting ;
: stack-trace-contains? symbolic-stack-trace memq? ;
[ t ] [
[ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains?
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
] unit-test
[ t f ] [
[ { "hi" } bleh ] catch drop
[ { "hi" } bleh ] ignore-errors
\ + stack-trace-contains?
\ > stack-trace-contains?
] unit-test
@ -34,6 +34,6 @@ words splitting ;
: quux [ t [ "hi" throw ] when ] times ;
[ t ] [
[ 10 quux ] catch drop
[ 10 quux ] ignore-errors
\ (each-integer) stack-trace-contains?
] unit-test

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
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
combinators.private byte-arrays alien alien.accessors layouts
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units ;
IN: temporary

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

9
core/compiler/units/units-docs.factor Normal file → Executable file
View File

@ -28,9 +28,7 @@ HELP: redefine-error
HELP: remember-definition
{ $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } }
{ $description "Saves the location of a definition and associates this definition with the current source file."
$nl
"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ;
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
HELP: old-definitions
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ;
@ -38,11 +36,6 @@ HELP: old-definitions
HELP: new-definitions
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ;
HELP: forward-error
{ $values { "word" word } }
{ $description "Throws a " { $link forward-error } "." }
{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ;
HELP: with-compilation-unit
{ $values { "quot" quotation } }
{ $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." }

5
core/compiler/units/units.factor
View File

@ -26,11 +26,6 @@ TUPLE: redefine-error def ;
over new-definitions get first key? [ dup redefine-error ] when
new-definitions get second (remember-definition) ;
TUPLE: forward-error word ;
: forward-error ( word -- )
\ forward-error construct-boa throw ;
: forward-reference? ( word -- ? )
dup old-definitions get assoc-stack
[ new-definitions get assoc-stack not ]

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

@ -23,10 +23,9 @@ $nl
"Two words raise an error in the innermost error handler for the current dynamic extent:"
{ $subsection throw }
{ $subsection rethrow }
"A set of words establish an error handler:"
"Two words for establishing an error handler:"
{ $subsection cleanup }
{ $subsection recover }
{ $subsection catch }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "errors-post-mortem" } ;
@ -147,12 +146,7 @@ HELP: throw
{ $values { "error" object } }
{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
HELP: catch
{ $values { "try" quotation } { "error/f" object } }
{ $description "Calls the " { $snippet "try" } " quotation. If an error is thrown in the dynamic extent of the quotation, restores the data stack and pushes the error. If the quotation returns successfully, outputs " { $link f } " without restoring the data stack." }
{ $notes "This word cannot differentiate between the case of " { $link f } " being thrown, and no error being thrown. You should never throw " { $link f } ", and you should also use other error handling combinators where possible." } ;
{ catch cleanup recover } related-words
{ cleanup recover } related-words
HELP: cleanup
{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
@ -166,7 +160,7 @@ HELP: rethrow
{ $values { "error" object } }
{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
{ $notes
"This word is intended to be used in conjunction with " { $link recover } " or " { $link catch } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
"This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
}
{ $examples
"The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:"
@ -175,7 +169,7 @@ HELP: rethrow
HELP: throw-restarts
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." }
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
{ $examples
"Try invoking one of the two restarts which are offered after the below code throws an error:"
{ $code

42
core/continuations/continuations-tests.factor
View File

@ -25,13 +25,11 @@ IN: temporary
[ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test
[ f ] [ [ ] catch ] unit-test
[ 5 ] [ [ 5 throw ] catch ] unit-test
[ 5 throw ] [ 5 = ] must-fail-with
[ t ] [
[ "Hello" throw ] catch drop
global [ error get ] bind
[ "Hello" throw ] ignore-errors
error get-global
"Hello" =
] unit-test
@ -41,13 +39,13 @@ IN: temporary
"!!! The following error is part of the test" print
[ [ "2 car" ] eval ] catch print-error
[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test
[ f throw ] unit-test-fails
[ f throw ] must-fail
! Weird PowerPC bug.
[ ] [
[ "4" throw ] catch drop
[ "4" throw ] ignore-errors
data-gc
data-gc
] unit-test
@ -56,10 +54,10 @@ IN: temporary
[ f ] [ { "A" "B" } kernel-error? ] unit-test
! ! See how well callstack overflow is handled
! [ clear drop ] unit-test-fails
! [ clear drop ] must-fail
!
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] unit-test-fails
! [ callstack-overflow ] must-fail
: don't-compile-me { } [ ] each ;
@ -84,24 +82,20 @@ SYMBOL: error-counter
[ 1 ] [ always-counter get ] unit-test
[ 0 ] [ error-counter get ] unit-test
[ "a" ] [
[
[ "a" throw ]
[ always-counter inc ]
[ error-counter inc ] cleanup
] catch
] unit-test
[
[ "a" throw ]
[ always-counter inc ]
[ error-counter inc ] cleanup
] [ "a" = ] must-fail-with
[ 2 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test
[ "a" ] [
[
[ ]
[ always-counter inc "a" throw ]
[ error-counter inc ] cleanup
] catch
] unit-test
[
[ ]
[ always-counter inc "a" throw ]
[ error-counter inc ] cleanup
] [ "a" = ] must-fail-with
[ 3 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test

12
core/continuations/continuations.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
namespaces math splitting sorting quotations assocs ;
@ -17,9 +17,6 @@ SYMBOL: restarts
: c> ( -- continuation ) catchstack* pop ;
: (catch) ( quot -- newquot )
[ swap >c call c> drop ] curry ; inline
: dummy ( -- obj )
#! Optimizing compiler assumes stack won't be messed with
#! in-transit. To ensure that a value is actually reified
@ -101,7 +98,7 @@ PRIVATE>
: continue-with ( obj continuation -- )
[
walker-hook [ >r 2array r> ] when* (continue-with)
] 2curry (throw) ;
] 2 (throw) ;
: continue ( continuation -- )
f swap continue-with ;
@ -120,11 +117,8 @@ PRIVATE>
catchstack* empty? [ die ] when
dup save-error c> continue-with ;
: catch ( try -- error/f )
(catch) [ f ] compose callcc1 ; inline
: recover ( try recovery -- )
>r (catch) r> ifcc ; inline
>r [ swap >c call c> drop ] curry r> ifcc ; inline
: cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry

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
HOOK: %jump-t compiler-backend ( label -- )
HOOK: %call-dispatch compiler-backend ( -- label )
HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- )

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

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

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

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

@ -261,6 +261,10 @@ windows? [
cell "ulonglong" c-type set-c-type-align
] unless
windows? [
4 "double" c-type set-c-type-align
] unless
T{ x86-backend f 4 } compiler-backend set-global
: sse2? "Intrinsic" throw ;

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.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
alien alien.compiler alien.structs slots splitting assocs ;
alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend

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 -- )
"flag" operand f v>operand CMP JNE ;
: (%dispatch) ( n -- operand )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
M: x86-backend %call-dispatch ( word-table# -- )
[ 5 (%dispatch) CALL <label> dup JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ;
: align-code ( n -- )
0 <repetition> % ;
M: x86-backend %jump-dispatch ( -- )
[ %epilogue-later 0 (%dispatch) JMP ] H{
M: x86-backend %dispatch ( -- )
[
%epilogue-later
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }

30
core/debugger/debugger.factor
View File

@ -87,7 +87,32 @@ TUPLE: assert got expect ;
: depth ( -- n ) datastack length ;
: assert-depth ( quot -- ) depth slip depth swap assert= ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
2dup [ length ] 2apply min tuck tail >r tail r> ;
TUPLE: relative-underflow stack ;
: relative-underflow ( before after -- * )
trim-datastacks nip \ relative-underflow construct-boa throw ;
M: relative-underflow summary
drop "Too many items removed from data stack" ;
TUPLE: relative-overflow stack ;
M: relative-overflow summary
drop "Superfluous items pushed to data stack" ;
: relative-overflow ( before after -- * )
trim-datastacks drop \ relative-overflow construct-boa throw ;
: assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r>
2dup [ length ] compare sgn {
{ -1 [ relative-underflow ] }
{ 0 [ 2drop ] }
{ 1 [ relative-overflow ] }
} case ; inline
: expired-error. ( obj -- )
"Object did not survive image save/load: " write third . ;
@ -222,9 +247,6 @@ M: redefine-error error.
"Re-definition of " write
redefine-error-def . ;
M: forward-error error.
"Forward reference to " write forward-error-word . ;
M: undefined summary
drop "Calling a deferred word before it has been defined" ;

4
core/definitions/definitions-docs.factor
View File

@ -52,9 +52,7 @@ $nl
$nl
"If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image."
$nl
"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used."
{ $subsection forward-error }
"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image."
"Since this is undesirable, the parser explicitly raises a " { $link no-word } " error if a source file refers to a word which is in the dictionary, but defined after it is used."
$nl
"The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case."
{ $subsection redefine-error } ;

6
core/definitions/definitions-tests.factor
View File

@ -6,12 +6,14 @@ TUPLE: combination-1 ;
M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
SYMBOL: generic-1
[
generic-1 T{ combination-1 } define-generic
[ ] <method> object \ generic-1 define-method
[ ] object \ generic-1 define-method
] with-compilation-unit
[ ] [
@ -20,7 +22,7 @@ SYMBOL: generic-1
] with-compilation-unit
] unit-test
GENERIC: some-generic
GENERIC: some-generic ( a -- b )
USE: arrays

5
core/dlists/dlists.factor
View File

@ -144,6 +144,11 @@ PRIVATE>
: dlist-delete ( obj dlist -- obj/f )
>r [ eq? ] curry r> delete-node-if ;
: dlist-delete-all ( dlist -- )
f over set-dlist-front
f over set-dlist-back
0 swap set-dlist-length ;
: dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline

16
core/effects/effects.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
combinators ;
@ -41,13 +41,13 @@ M: integer (stack-picture) drop "object" ;
")" %
] "" make ;
: stack-effect ( word -- effect/f )
dup symbol? [
drop 0 1 <effect>
] [
{ "declared-effect" "inferred-effect" }
swap word-props [ at ] curry map [ ] find nip
] if ;
GENERIC: stack-effect ( word -- effect/f )
M: symbol stack-effect drop 0 1 <effect> ;
M: word stack-effect
{ "declared-effect" "inferred-effect" }
swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
[ effect-in clone ] keep effect-out clone <effect> ;

2
core/float-arrays/float-arrays-docs.factor
View File

@ -32,7 +32,7 @@ HELP: <float-array> ( n initial -- float-array )
HELP: >float-array
{ $values { "seq" "a sequence" } { "float-array" float-array } }
{ $description "Outputs a freshly-allocated float array whose elements have the same boolean values as a given sequence." }
{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
HELP: 1float-array

2
core/float-arrays/float-arrays-tests.factor
View File

@ -7,4 +7,4 @@ USING: float-arrays tools.test ;
[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
[ -10 F{ } resize-float-array ] unit-test-fails
[ -10 F{ } resize-float-array ] must-fail

44
core/generator/generator.factor
View File

@ -3,8 +3,9 @@
USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words vectors ;
kernel.private layouts math namespaces optimizer
optimizer.specializers prettyprint quotations sequences system
threads words vectors ;
IN: generator
SYMBOL: compile-queue
@ -55,13 +56,16 @@ GENERIC: generate-node ( node -- next )
: generate-nodes ( node -- )
[ node@ generate-node ] iterate-nodes end-basic-block ;
: init-generate-nodes ( -- )
init-templates
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
: generate ( word label node -- )
[
init-templates
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label
init-generate-nodes
[ generate-nodes ] with-node-iterator
] generate-1 ;
@ -154,22 +158,36 @@ M: #if generate-node
] generate-1
] keep ;
: tail-dispatch? ( node -- ? )
#! Is the dispatch a jump to a tail call to a word?
dup #call? swap node-successor #return? and ;
: dispatch-branches ( node -- )
node-children [
compiling-word get dispatch-branch %dispatch-label
dup tail-dispatch? [
node-param
] [
compiling-word get dispatch-branch
] if %dispatch-label
] each ;
: generate-dispatch ( node -- )
%dispatch dispatch-branches init-templates ;
M: #dispatch generate-node
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
%jump-dispatch dispatch-branches
generate-dispatch iterate-next
] [
0 frame-required
%call-dispatch >r dispatch-branches r> resolve-label
] if
init-templates iterate-next ;
compiling-word get gensym [
rot [
init-generate-nodes
generate-dispatch
] generate-1
] keep generate-call
] if ;
! #call
: define-intrinsics ( word intrinsics -- )

14
core/generic/generic-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax generic.math generic.standard
words classes definitions kernel alien combinators sequences
math ;
math quotations ;
IN: generic
ARTICLE: "method-order" "Method precedence"
@ -107,10 +107,6 @@ HELP: make-generic
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
$low-level-note ;
HELP: init-methods
{ $values { "word" word } }
{ $description "Prepare to define a generic word." } ;
HELP: define-generic
{ $values { "word" word } { "combination" "a method combination" } }
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
@ -125,16 +121,12 @@ HELP: method
{ $description "Looks up a method definition." }
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
{ method method-def method-loc define-method POSTPONE: M: } related-words
{ method define-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ;
HELP: sort-methods
{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } }
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
@ -154,7 +146,7 @@ HELP: with-methods
$low-level-note ;
HELP: define-method
{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } }
{ $values { "method" quotation } { "class" class } { "generic" generic } }
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
HELP: implementors

48
core/generic/generic-tests.factor
View File

@ -16,7 +16,7 @@ M: word class-of drop "word" ;
[ "fixnum" ] [ 5 class-of ] unit-test
[ "word" ] [ \ class-of class-of ] unit-test
[ 3.4 class-of ] unit-test-fails
[ 3.4 class-of ] must-fail
[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
@ -90,7 +90,7 @@ M: number union-containment drop 2 ;
"IN: temporary GENERIC: unhappy ( x -- x )" eval
[
"IN: temporary M: dictionary unhappy ;" eval
] unit-test-fails
] must-fail
[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
@ -155,9 +155,7 @@ M: string my-hook "a string" ;
[ "an integer" ] [ 3 my-var set my-hook ] unit-test
[ "a string" ] [ my-hook my-var set my-hook ] unit-test
[ T{ no-method f 1.0 my-hook } ] [
1.0 my-var set [ my-hook ] catch
] unit-test
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
GENERIC: tag-and-f ( x -- x x )
@ -176,6 +174,9 @@ M: f tag-and-f 4 ;
! define-class hashing issue
TUPLE: debug-combination ;
M: debug-combination make-default-method
2drop [ "Oops" throw ] ;
M: debug-combination perform-combination
drop
order [ dup class-hashes ] { } map>assoc sort-keys
@ -200,3 +201,40 @@ TUPLE: redefinition-test-tuple ;
redefinition-test-generic ,
] { } make all-equal?
] unit-test
! Issues with forget
GENERIC: generic-forget-test-1
M: integer generic-forget-test-1 / ;
[ t ] [
\ / usage [ word? ] subset
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
[ ] [
[ \ generic-forget-test-1 forget ] with-compilation-unit
] unit-test
[ f ] [
\ / usage [ word? ] subset
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
GENERIC: generic-forget-test-2
M: sequence generic-forget-test-2 = ;
[ t ] [
\ = usage [ word? ] subset
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
[ ] [
[ { sequence generic-forget-test-2 } forget ] with-compilation-unit
] unit-test
[ f ] [
\ = usage [ word? ] subset
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test

115
core/generic/generic.factor
View File

@ -1,16 +1,11 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
quotations arrays vocabs ;
quotations arrays vocabs effects ;
IN: generic
PREDICATE: word generic "combination" word-prop >boolean ;
M: generic definer drop f f ;
M: generic definition drop f ;
! Method combination protocol
GENERIC: perform-combination ( word combination -- quot )
M: object perform-combination
@ -22,27 +17,22 @@ M: object perform-combination
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ;
GENERIC: method-prologue ( class combination -- quot )
M: object method-prologue 2drop [ ] ;
GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
M: generic definer drop f f ;
M: generic definition drop f ;
: make-generic ( word -- )
dup dup "combination" word-prop perform-combination define ;
: init-methods ( word -- )
dup "methods" word-prop
H{ } assoc-like
"methods" set-word-prop ;
: define-generic ( word combination -- )
dupd "combination" set-word-prop
dup init-methods make-generic ;
TUPLE: method loc def ;
: <method> ( def -- method )
{ set-method-def } \ method construct ;
M: f method-def ;
M: f method-loc ;
M: quotation method-def ;
M: quotation method-loc drop f ;
TUPLE: method word def specializer generic loc ;
: method ( class generic -- method/f )
"methods" word-prop at ;
@ -53,12 +43,10 @@ PREDICATE: pair method-spec
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
: sort-methods ( assoc -- newassoc )
[ keys sort-classes ] keep
[ dupd at method-def 2array ] curry map ;
: methods ( word -- assoc )
"methods" word-prop sort-methods ;
"methods" word-prop
[ keys sort-classes ] keep
[ dupd at method-word ] curry { } map>assoc ;
TUPLE: check-method class generic ;
@ -71,22 +59,52 @@ TUPLE: check-method class generic ;
swap [ "methods" word-prop swap call ] keep make-generic ;
inline
: define-method ( method class generic -- )
>r bootstrap-word r> check-method
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
: make-method-def ( quot word combination -- quot )
"combination" word-prop method-prologue swap append ;
PREDICATE: word method-body "method" word-prop >boolean ;
M: method-body stack-effect
"method" word-prop method-generic stack-effect ;
: <method-word> ( quot class generic -- word )
[ make-method-def ] 2keep
method-word-name f <word>
dup rot define
dup xref ;
: <method> ( quot class generic -- method )
check-method
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
[ <method> ] 2keep
[ set-at ] with-methods ;
: define-default-method ( generic combination -- )
dupd make-default-method object bootstrap-word pick <method>
"default-method" set-word-prop ;
! Definition protocol
M: method-spec where
dup first2 method method-loc [ ] [ second where ] ?if ;
dup first2 method [ method-loc ] [ second where ] ?if ;
M: method-spec set-where first2 method set-method-loc ;
M: method-spec definer drop \ M: \ ; ;
M: method-spec definition first2 method method-def ;
M: method-spec definition
first2 method dup [ method-def ] when ;
: forget-method ( class generic -- )
check-method [ delete-at ] with-methods ;
check-method
[ delete-at* ] with-methods
[ method-word forget ] [ drop ] if ;
M: method-spec forget* first2 forget-method ;
@ -109,3 +127,28 @@ M: class forget* ( class -- )
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
: define-generic ( word combination -- )
over "combination" word-prop over = [
2drop
] [
2dup "combination" set-word-prop
over H{ } clone "methods" set-word-prop
dupd define-default-method
make-generic
] if ;
GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
M: generic subwords
dup "methods" word-prop values
swap "default-method" word-prop add
[ method-word ] map ;
M: generic forget-word
dup subwords [ forget-word ] each (forget-word) ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;

15
core/generic/math/math.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
combinators.private classes definitions ;
sequences.private classes definitions ;
IN: generic.math
PREDICATE: class math-class ( object -- ? )
@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ;
: no-math-method ( left right generic -- * )
\ no-math-method construct-boa throw ;
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;
: applicable-method ( generic class -- quot )
over method method-def
[ ] [ [ no-math-method ] curry [ ] like ] ?if ;
over method
[ method-word word-def ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )
object bootstrap-word applicable-method ;
@ -57,7 +61,7 @@ TUPLE: no-math-method left right generic ;
: math-vtable* ( picker max quot -- quot )
[
rot , \ tag ,
[ >r [ type>class ] map r> map % ] { } make ,
[ >r [ bootstrap-type>class ] map r> map % ] { } make ,
\ dispatch ,
] [ ] make ; inline
@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ;
TUPLE: math-combination ;
M: math-combination make-default-method
drop default-math-method ;
M: math-combination perform-combination
drop
\ over [

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

@ -2,12 +2,16 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators combinators.private generic
hashtables layouts combinators sequences.private generic
classes classes.private ;
IN: generic.standard
TUPLE: standard-combination # ;
M: standard-combination method-prologue
standard-combination-# object
<array> swap add* [ declare ] curry ;
C: <standard-combination> standard-combination
SYMBOL: (dispatch#)
@ -31,10 +35,10 @@ TUPLE: no-method object generic ;
: no-method ( object generic -- * )
\ no-method construct-boa throw ;
: error-method ( word -- method )
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
: empty-method ( word -- method )
: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
unpicker over add ,
@ -65,13 +69,15 @@ TUPLE: no-method object generic ;
] if ;
: default-method ( word -- pair )
empty-method object bootstrap-word swap 2array ;
"default-method" word-prop method-word
object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot )
bootstrap-word swap simplify-alist
class-predicates alist>quot ;
: small-generic ( methods -- def )
[ 1quotation ] assoc-map
object method-alist>quot ;
: hash-methods ( methods -- buckets )
@ -83,12 +89,15 @@ TUPLE: no-method object generic ;
] if
] distribute-buckets ;
: class-hash-dispatch-quot ( methods quot picker -- quot )
>r >r hash-methods r> map
hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
: big-generic ( methods -- quot )
hash-methods [ small-generic ] map
hash-dispatch-quot picker [ class-hash ] rot 3append ;
[ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class )
type>class [ hi-tag bootstrap-word ] unless* ;
bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
: group-methods ( assoc -- vtable )
#! Input is a predicate -> method association.
@ -100,7 +109,8 @@ TUPLE: no-method object generic ;
: build-type-vtable ( alist-seq -- alist-seq )
dup length [
vtable-class swap simplify-alist
vtable-class
swap [ word-def ] assoc-map simplify-alist
class-predicates alist>quot
] 2map ;
@ -137,30 +147,35 @@ TUPLE: no-method object generic ;
: standard-methods ( word -- alist )
dup methods swap default-method add* ;
M: standard-combination make-default-method
standard-combination-# (dispatch#)
[ empty-method ] with-variable ;
M: standard-combination perform-combination
standard-combination-# (dispatch#) [
[ standard-methods ] keep "inline" word-prop
[ small-generic ] [ single-combination ] if
] with-variable ;
: default-hook-method ( word -- pair )
error-method object bootstrap-word swap 2array ;
: hook-methods ( word -- methods )
dup methods [ [ drop ] swap append ] assoc-map
swap default-hook-method add* ;
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
M: hook-combination perform-combination
M: hook-combination method-prologue
2drop [ drop ] ;
: with-hook ( combination quot -- quot' )
0 (dispatch#) [
[
hook-combination-var [ get ] curry %
hook-methods single-combination %
] [ ] make
] with-variable ;
swap slip
hook-combination-var [ get ] curry
swap append
] with-variable ; inline
M: hook-combination make-default-method
[ error-method ] with-hook ;
M: hook-combination perform-combination
[ standard-methods single-combination ] with-hook ;
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;

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

@ -9,16 +9,16 @@ IN: temporary
! overflow bugs
[ "hi" most-positive-fixnum 2 * 2 + V{ } clone set-nth ]
unit-test-fails
must-fail
[ most-positive-fixnum 2 * 2 + { 1 } clone nth ]
unit-test-fails
must-fail
[ most-positive-fixnum 2 * 2 + V{ } clone lengthen ]
unit-test-fails
must-fail
[ most-positive-fixnum 2 * 2 + V{ } clone set-length ]
unit-test-fails
must-fail
[ ] [
10 V{ } [ set-length ] keep

6
core/hashtables/hashtables-tests.factor
View File

@ -127,9 +127,9 @@ H{ } "x" set
! Another crash discovered by erg
[ ] [
H{ } clone
[ 1 swap set-at ] catch drop
[ 2 swap set-at ] catch drop
[ 3 swap set-at ] catch drop
[ 1 swap set-at ] ignore-errors
[ 2 swap set-at ] ignore-errors
[ 3 swap set-at ] ignore-errors
drop
] unit-test

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

@ -5,8 +5,8 @@ USING: arrays kernel math namespaces tools.test
heaps heaps.private ;
IN: temporary
[ <min-heap> heap-pop ] unit-test-fails
[ <max-heap> heap-pop ] unit-test-fails
[ <min-heap> heap-pop ] must-fail
[ <max-heap> heap-pop ] must-fail
[ t ] [ <min-heap> heap-empty? ] unit-test
[ f ] [ <min-heap> 1 t pick heap-push heap-empty? ] unit-test

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

@ -1,6 +1,6 @@
USING: help.syntax help.markup words effects inference.dataflow
inference.state inference.backend kernel sequences
kernel.private combinators combinators.private ;
kernel.private combinators sequences.private ;
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }

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

@ -9,9 +9,13 @@ IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
: inline? ( word -- ? )
dup "method" word-prop
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
[ dup word? [ "inline" word-prop ] when not ] find drop
[ dup word? [ inline? ] when not ] find drop
[ head-slice ] when* ;
: inline-recursive-label ( word -- label/f )
@ -20,24 +24,24 @@ IN: inference.backend
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ;
TUPLE: inference-error rstate major? ;
TUPLE: inference-error rstate type ;
M: inference-error compiler-warning?
inference-error-major? not ;
M: inference-error compiler-error-type
inference-error-type ;
: (inference-error) ( ... class important? -- * )
: (inference-error) ( ... class type -- * )
>r construct-boa r>
recursive-state get {
set-delegate
set-inference-error-major?
set-inference-error-type
set-inference-error-rstate
} \ inference-error construct throw ; inline
: inference-error ( ... class -- * )
t (inference-error) ; inline
+error+ (inference-error) ; inline
: inference-warning ( ... class -- * )
f (inference-error) ; inline
+warning+ (inference-error) ; inline
TUPLE: literal-expected ;
@ -157,7 +161,7 @@ TUPLE: too-many-r> ;
meta-d get push-all ;
: if-inline ( word true false -- )
>r >r dup "inline" word-prop r> r> if ; inline
>r >r dup inline? r> r> if ; inline
: consume/produce ( effect node -- )
over effect-in over consume-values
@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ;
#merge node, ; inline
: make-call-node ( word effect -- )
swap dup "inline" word-prop
swap dup inline?
over dup recursive-label eq? not and [
meta-d get clone -rot
recursive-label #call-label [ consume/produce ] keep
@ -366,6 +370,7 @@ TUPLE: effect-error word effect ;
init-inference
dependencies off
dup word-def over dup infer-quot-recursive
end-infer
finish-word
current-effect
] with-scope

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

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

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

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

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

@ -256,6 +256,28 @@ SYMBOL: node-stack
] iterate-nodes drop
] with-node-iterator ; inline
: change-children ( node quot -- )
over [
>r dup node-children dup r>
[ map swap set-node-children ] curry
[ 2drop ] if
] [
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [
dup rot set-node-successor
dup node-successor r> (transform-nodes)
] [
r> drop f swap set-node-successor drop
] if ; inline
: transform-nodes ( node quot -- new-node )
over [
[ call dup dup node-successor ] keep (transform-nodes)
] [ drop ] if ; inline
: node-literal? ( node value -- ? )
dup value? >r swap node-literals key? r> or ;

11
core/inference/inference-docs.factor
View File

@ -73,6 +73,12 @@ $nl
{ $subsection infer-quot-value }
"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph"
"The dataflow graph used by " { $link "compiler" } " can be obtained:"
{ $subsection dataflow }
"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
$nl ;
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
$nl
@ -80,14 +86,15 @@ $nl
{ $subsection infer. }
"Instead of printing the inferred information, it can be returned as objects on the stack:"
{ $subsection infer }
"The dataflow graph used by " { $link "compiler" } " can be obtained:"
{ $subsection dataflow }
"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
$nl
"The following articles describe the implementation of the stack effect inference algorithm:"
{ $subsection "inference-simple" }
{ $subsection "inference-combinators" }
{ $subsection "inference-branches" }
{ $subsection "inference-recursive" }
{ $subsection "inference-limitations" }
{ $subsection "dataflow-graphs" }
{ $subsection "compiler-transforms" } ;
ABOUT: "inference"

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

@ -4,23 +4,23 @@ math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string combinators.private
tools.test.inference ;
debugger threads.private io.streams.string io.timeouts
sequences.private ;
IN: temporary
{ 0 2 } [ 2 "Hello" ] unit-test-effect
{ 1 2 } [ dup ] unit-test-effect
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
{ 1 2 } [ [ dup ] call ] unit-test-effect
[ [ call ] infer ] unit-test-fails
{ 1 2 } [ [ dup ] call ] must-infer-as
[ [ call ] infer ] must-fail
{ 2 4 } [ 2dup ] unit-test-effect
{ 2 4 } [ 2dup ] must-infer-as
{ 1 0 } [ [ ] [ ] if ] unit-test-effect
[ [ if ] infer ] unit-test-fails
[ [ [ ] if ] infer ] unit-test-fails
[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect
{ 1 0 } [ [ ] [ ] if ] must-infer-as
[ [ if ] infer ] must-fail
[ [ [ ] if ] infer ] must-fail
[ [ [ 2 ] [ ] if ] infer ] must-fail
{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
{ 4 3 } [
[
@ -28,21 +28,21 @@ IN: temporary
] [
-rot
] if
] unit-test-effect
] must-infer-as
{ 1 1 } [ dup [ ] when ] unit-test-effect
{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect
{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect
{ 1 1 } [ dup [ ] when ] must-infer-as
{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as
{ 1 0 } [ [ drop ] when* ] unit-test-effect
{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect
{ 1 0 } [ [ drop ] when* ] must-infer-as
{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
{ 0 1 }
[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect
[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
[
[ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
] unit-test-fails
] must-fail
! Test inference of termination of control flow
: termination-test-1
@ -50,37 +50,37 @@ IN: temporary
: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
{ 1 1 } [ termination-test-2 ] unit-test-effect
{ 1 1 } [ termination-test-2 ] must-infer-as
: infinite-loop infinite-loop ;
[ [ infinite-loop ] infer ] unit-test-fails
[ [ infinite-loop ] infer ] must-fail
: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
[ [ no-base-case-1 ] infer ] unit-test-fails
[ [ no-base-case-1 ] infer ] must-fail
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
{ 1 1 } [ simple-recursion-1 ] unit-test-effect
{ 1 1 } [ simple-recursion-1 ] must-infer-as
: simple-recursion-2 ( obj -- obj )
dup [ ] [ simple-recursion-2 ] if ;
{ 1 1 } [ simple-recursion-2 ] unit-test-effect
{ 1 1 } [ simple-recursion-2 ] must-infer-as
: bad-recursion-2 ( obj -- obj )
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
[ [ bad-recursion-2 ] infer ] unit-test-fails
[ [ bad-recursion-2 ] infer ] must-fail
: funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ;
{ 1 1 } [ funny-recursion ] unit-test-effect
{ 1 1 } [ funny-recursion ] must-infer-as
! Simple combinators
{ 1 2 } [ [ first ] keep second ] unit-test-effect
{ 1 2 } [ [ first ] keep second ] must-infer-as
! Mutual recursion
DEFER: foe
@ -103,8 +103,8 @@ DEFER: foe
2drop f
] if ;
{ 2 1 } [ fie ] unit-test-effect
{ 2 1 } [ foe ] unit-test-effect
{ 2 1 } [ fie ] must-infer-as
{ 2 1 } [ foe ] must-infer-as
: nested-when ( -- )
t [
@ -113,7 +113,7 @@ DEFER: foe
] when
] when ;
{ 0 0 } [ nested-when ] unit-test-effect
{ 0 0 } [ nested-when ] must-infer-as
: nested-when* ( obj -- )
[
@ -122,11 +122,11 @@ DEFER: foe
] when*
] when* ;
{ 1 0 } [ nested-when* ] unit-test-effect
{ 1 0 } [ nested-when* ] must-infer-as
SYMBOL: sym-test
{ 0 1 } [ sym-test ] unit-test-effect
{ 0 1 } [ sym-test ] must-infer-as
: terminator-branch
dup [
@ -135,7 +135,7 @@ SYMBOL: sym-test
"foo" throw
] if ;
{ 1 1 } [ terminator-branch ] unit-test-effect
{ 1 1 } [ terminator-branch ] must-infer-as
: recursive-terminator ( obj -- )
dup [
@ -144,7 +144,7 @@ SYMBOL: sym-test
"Hi" throw
] if ;
{ 1 0 } [ recursive-terminator ] unit-test-effect
{ 1 0 } [ recursive-terminator ] must-infer-as
GENERIC: potential-hang ( obj -- obj )
M: fixnum potential-hang dup [ potential-hang ] when ;
@ -157,24 +157,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
M: f iterate drop ;
M: real iterate drop ;
{ 1 0 } [ iterate ] unit-test-effect
{ 1 0 } [ iterate ] must-infer-as
! Regression
: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
{ 3 0 } [ dog ] unit-test-effect
{ 3 0 } [ dog ] must-infer-as
! Regression
DEFER: monkey
: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
{ 3 0 } [ friend ] unit-test-effect
{ 3 0 } [ friend ] must-infer-as
! Regression -- same as above but we infer the second word first
DEFER: blah2
: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
{ 3 0 } [ blah2 ] unit-test-effect
{ 3 0 } [ blah2 ] must-infer-as
! Regression
DEFER: blah4
@ -182,7 +182,7 @@ DEFER: blah4
dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
: blah4 ( a b c -- )
dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
{ 3 0 } [ blah4 ] unit-test-effect
{ 3 0 } [ blah4 ] must-infer-as
! Regression
: bad-combinator ( obj quot -- )
@ -192,14 +192,14 @@ DEFER: blah4
[ swap slip ] keep swap bad-combinator
] if ; inline
[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
! Regression
: bad-input#
dup string? [ 2array throw ] unless
over string? [ 2array throw ] unless ;
{ 2 2 } [ bad-input# ] unit-test-effect
{ 2 2 } [ bad-input# ] must-infer-as
! Regression
@ -207,18 +207,18 @@ DEFER: blah4
DEFER: do-crap
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
[ [ do-crap ] infer ] unit-test-fails
[ [ do-crap ] infer ] must-fail
! This one does not
DEFER: do-crap*
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
[ [ do-crap* ] infer ] unit-test-fails
[ [ do-crap* ] infer ] must-fail
! Regression
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
{ 2 1 } [ too-deep ] unit-test-effect
{ 2 1 } [ too-deep ] must-infer-as
! Error reporting is wrong
MATH: xyz
@ -226,7 +226,7 @@ M: fixnum xyz 2array ;
M: float xyz
[ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
! Doug Coleman discovered this one while working on the
! calendar library
@ -258,17 +258,17 @@ DEFER: C
[ dup B C ]
} dispatch ;
{ 1 0 } [ A ] unit-test-effect
{ 1 0 } [ B ] unit-test-effect
{ 1 0 } [ C ] unit-test-effect
{ 1 0 } [ A ] must-infer-as
{ 1 0 } [ B ] must-infer-as
{ 1 0 } [ C ] must-infer-as
! I found this bug by thinking hard about the previous one
DEFER: Y
: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
: Y ( a b -- c d ) X ;
{ 2 2 } [ X ] unit-test-effect
{ 2 2 } [ Y ] unit-test-effect
{ 2 2 } [ X ] must-infer-as
{ 2 2 } [ Y ] must-infer-as
! This one comes from UI code
DEFER: #1
@ -277,78 +277,66 @@ DEFER: #1
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
[ \ #4 word-def infer ] unit-test-fails
[ [ #1 ] infer ] unit-test-fails
[ \ #4 word-def infer ] must-fail
[ [ #1 ] infer ] must-fail
! Similar
DEFER: bar
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
[ [ foo ] infer ] unit-test-fails
[ [ foo ] infer ] must-fail
[ 1234 infer ] unit-test-fails
[ 1234 infer ] must-fail
! This used to hang
[ t ] [
[ [ [ dup call ] dup call ] infer ] catch
inference-error?
] unit-test
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with
: m dup call ; inline
[ t ] [
[ [ [ m ] m ] infer ] catch inference-error?
] unit-test
[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
: m' dup curry call ; inline
[ t ] [
[ [ [ m' ] m' ] infer ] catch inference-error?
] unit-test
[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
: m'' [ dup curry ] ; inline
: m''' m'' call call ; inline
[ t ] [
[ [ [ m''' ] m''' ] infer ] catch inference-error?
] unit-test
[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
: m-if t over if ; inline
[ t ] [
[ [ [ m-if ] m-if ] infer ] catch inference-error?
] unit-test
[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
! This doesn't hang but it's also an example of the
! undedicable case
[ t ] [
[ [ [ [ drop 3 ] swap call ] dup call ] infer ] catch
inference-error?
] unit-test
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
[ inference-error? ] must-fail-with
! This form should not have a stack effect
: bad-recursion-1 ( a -- b )
dup [ drop bad-recursion-1 5 ] [ ] if ;
[ [ bad-recursion-1 ] infer ] unit-test-fails
[ [ bad-recursion-1 ] infer ] must-fail
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ [ bad-bin ] infer ] unit-test-fails
[ [ bad-bin ] infer ] must-fail
[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test
[ [ r> ] infer ] [ inference-error? ] must-fail-with
! Regression
[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test
[ [ get-slots ] infer ] [ inference-error? ] must-fail-with
! Test some curry stuff
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect
{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
! Test number protocol
\ bitor must-infer
@ -393,7 +381,7 @@ DEFER: bar
\ assoc-like must-infer
\ assoc-clone-like must-infer
\ >alist must-infer
{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
! Test some random library words
\ 1quotation must-infer
@ -416,10 +404,10 @@ DEFER: bar
\ define-predicate-class must-infer
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
\ dispose must-infer
@ -459,16 +447,16 @@ DEFER: bar
: fooxxx ( a b -- c ) over [ foo ] when ; inline
: barxxx fooxxx ;
[ [ barxxx ] infer ] unit-test-fails
[ [ barxxx ] infer ] must-fail
! A typo
{ 1 0 } [ { [ ] } dispatch ] unit-test-effect
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
DEFER: inline-recursive-2
: inline-recursive-1 ( -- ) inline-recursive-2 ;
: inline-recursive-2 ( -- ) inline-recursive-1 ;
{ 0 0 } [ inline-recursive-1 ] unit-test-effect
{ 0 0 } [ inline-recursive-1 ] must-infer-as
! Hooks
SYMBOL: my-var
@ -477,22 +465,22 @@ HOOK: my-hook my-var ( -- x )
M: integer my-hook "an integer" ;
M: string my-hook "a string" ;
{ 0 1 } [ my-hook ] unit-test-effect
{ 0 1 } [ my-hook ] must-infer-as
DEFER: deferred-word
: calls-deferred-word [ deferred-word ] [ 3 ] if ;
{ 1 1 } [ calls-deferred-word ] unit-test-effect
{ 1 1 } [ calls-deferred-word ] must-infer-as
USE: inference.dataflow
{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect
{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
{ 1 0 }
[
[ [ iterate-next ] iterate-nodes ] with-node-iterator
] unit-test-effect
] must-infer-as
: nilpotent ( quot -- )
t [ [ call ] keep nilpotent ] [ drop ] if ; inline
@ -502,11 +490,11 @@ USE: inference.dataflow
{ 0 1 }
[ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
unit-test-effect
must-infer-as
{ 0 0 } [ [ ] semisimple ] unit-test-effect
{ 0 0 } [ [ ] semisimple ] must-infer-as
{ 1 0 } [ [ drop ] each-node ] unit-test-effect
{ 1 0 } [ [ drop ] each-node ] must-infer-as
DEFER: an-inline-word
@ -522,9 +510,9 @@ DEFER: an-inline-word
: an-inline-word ( obj quot -- )
>r normal-word r> call ; inline
{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect
{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
TUPLE: custom-error ;
@ -548,4 +536,9 @@ TUPLE: custom-error ;
! This was a false trigger of the undecidable quotation
! recursion bug
{ 2 1 } [ find-last-sep ] unit-test-effect
{ 2 1 } [ find-last-sep ] must-infer-as
! Regression
: missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail

11
core/inference/inference.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inference.backend inference.state inference.dataflow
inference.known-words inference.transforms inference.errors
sequences prettyprint io effects kernel namespaces quotations
words vocabs ;
kernel io effects namespaces sequences quotations vocabs
generic words ;
IN: inference
GENERIC: infer ( quot -- effect )
@ -28,4 +28,7 @@ M: callable dataflow-with
] with-infer nip ;
: forget-errors ( -- )
all-words [ f "no-effect" set-word-prop ] each ;
all-words [
dup subwords [ f "no-effect" set-word-prop ] each
f "no-effect" set-word-prop
] each ;

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

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays bit-arrays byte-arrays
classes combinators.private continuations.private effects
classes sequences.private continuations.private effects
float-arrays generic hashtables hashtables.private
inference.state inference.backend inference.dataflow io
io.backend io.files io.files.private io.streams.c kernel
@ -126,15 +126,11 @@ M: object infer-call
pop-d pop-d swap <curried> push-d
] "infer" set-word-prop
\ curry { object object } { curry } <effect> "inferred-effect" set-word-prop
\ compose [
2 ensure-values
pop-d pop-d swap <composed> push-d
] "infer" set-word-prop
\ compose { object object } { curry } <effect> "inferred-effect" set-word-prop
! Variadic tuple constructor
\ <tuple-boa> [
\ <tuple-boa>
@ -142,440 +138,461 @@ M: object infer-call
make-call-node
] "infer" set-word-prop
! We need this for default-output-classes
\ <tuple-boa> 2 { tuple } <effect> "inferred-effect" set-word-prop
! Non-standard control flow
\ (throw) { callable } { } <effect>
t over set-effect-terminated?
"inferred-effect" set-word-prop
\ (throw) [
\ (throw)
peek-d value-literal 2 + { } <effect>
t over set-effect-terminated?
make-call-node
] "infer" set-word-prop
: set-primitive-effect ( word effect -- )
2dup effect-out "default-output-classes" set-word-prop
dupd [ make-call-node ] 2curry "infer" set-word-prop ;
! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum< make-foldable
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum<= make-foldable
\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum> make-foldable
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum>= make-foldable
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
\ eq? { object object } { object } <effect> set-primitive-effect
\ eq? make-foldable
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
\ rehash-string { string } { } <effect> set-primitive-effect
\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
\ bignum>fixnum make-foldable
\ float>fixnum { float } { fixnum } <effect> "inferred-effect" set-word-prop
\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
\ bignum>fixnum make-foldable
\ fixnum>bignum { fixnum } { bignum } <effect> "inferred-effect" set-word-prop
\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
\ fixnum>bignum make-foldable
\ float>bignum { float } { bignum } <effect> "inferred-effect" set-word-prop
\ float>bignum { float } { bignum } <effect> set-primitive-effect
\ float>bignum make-foldable
\ fixnum>float { fixnum } { float } <effect> "inferred-effect" set-word-prop
\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
\ fixnum>float make-foldable
\ bignum>float { bignum } { float } <effect> "inferred-effect" set-word-prop
\ bignum>float { bignum } { float } <effect> set-primitive-effect
\ bignum>float make-foldable
\ <ratio> { integer integer } { ratio } <effect> "inferred-effect" set-word-prop
\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
\ <ratio> make-foldable
\ string>float { string } { float } <effect> "inferred-effect" set-word-prop
\ string>float { string } { float } <effect> set-primitive-effect
\ string>float make-foldable
\ float>string { float } { string } <effect> "inferred-effect" set-word-prop
\ float>string { float } { string } <effect> set-primitive-effect
\ float>string make-foldable
\ float>bits { real } { integer } <effect> "inferred-effect" set-word-prop
\ float>bits { real } { integer } <effect> set-primitive-effect
\ float>bits make-foldable
\ double>bits { real } { integer } <effect> "inferred-effect" set-word-prop
\ double>bits { real } { integer } <effect> set-primitive-effect
\ double>bits make-foldable
\ bits>float { integer } { float } <effect> "inferred-effect" set-word-prop
\ bits>float { integer } { float } <effect> set-primitive-effect
\ bits>float make-foldable
\ bits>double { integer } { float } <effect> "inferred-effect" set-word-prop
\ bits>double { integer } { float } <effect> set-primitive-effect
\ bits>double make-foldable
\ <complex> { real real } { complex } <effect> "inferred-effect" set-word-prop
\ <complex> { real real } { complex } <effect> set-primitive-effect
\ <complex> make-foldable
\ fixnum+ { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum+ make-foldable
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum+fast make-foldable
\ fixnum- { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum- make-foldable
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-fast make-foldable
\ fixnum* { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum* make-foldable
\ fixnum*fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum*fast make-foldable
\ fixnum/i { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum/i make-foldable
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-mod make-foldable
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
\ fixnum/mod make-foldable
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-bitand make-foldable
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-bitor make-foldable
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-bitxor make-foldable
\ fixnum-bitnot { fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-bitnot make-foldable
\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum-shift make-foldable
\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-shift-fast make-foldable
\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum= make-foldable
\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum+ make-foldable
\ bignum- { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum- make-foldable
\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum* make-foldable
\ bignum/i { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum/i make-foldable
\ bignum-mod { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-mod make-foldable
\ bignum/mod { bignum bignum } { bignum bignum } <effect> "inferred-effect" set-word-prop
\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
\ bignum/mod make-foldable
\ bignum-bitand { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-bitand make-foldable
\ bignum-bitor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-bitor make-foldable
\ bignum-bitxor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-bitxor make-foldable
\ bignum-bitnot { bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
\ bignum-bitnot make-foldable
\ bignum-shift { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-shift make-foldable
\ bignum< { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
\ bignum< make-foldable
\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum<= make-foldable
\ bignum> { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
\ bignum> make-foldable
\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum>= make-foldable
\ bignum-bit? { bignum integer } { object } <effect> "inferred-effect" set-word-prop
\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
\ bignum-bit? make-foldable
\ bignum-log2 { bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
\ bignum-log2 make-foldable
\ byte-array>bignum { byte-array } { bignum } <effect> "inferred-effect" set-word-prop
\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
\ byte-array>bignum make-foldable
\ float= { float float } { object } <effect> "inferred-effect" set-word-prop
\ float= { float float } { object } <effect> set-primitive-effect
\ float= make-foldable
\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop
\ float+ { float float } { float } <effect> set-primitive-effect
\ float+ make-foldable
\ float- { float float } { float } <effect> "inferred-effect" set-word-prop
\ float- { float float } { float } <effect> set-primitive-effect
\ float- make-foldable
\ float* { float float } { float } <effect> "inferred-effect" set-word-prop
\ float* { float float } { float } <effect> set-primitive-effect
\ float* make-foldable
\ float/f { float float } { float } <effect> "inferred-effect" set-word-prop
\ float/f { float float } { float } <effect> set-primitive-effect
\ float/f make-foldable
\ float< { float float } { object } <effect> "inferred-effect" set-word-prop
\ float< { float float } { object } <effect> set-primitive-effect
\ float< make-foldable
\ float-mod { float float } { float } <effect> "inferred-effect" set-word-prop
\ float-mod { float float } { float } <effect> set-primitive-effect
\ float-mod make-foldable
\ float<= { float float } { object } <effect> "inferred-effect" set-word-prop
\ float<= { float float } { object } <effect> set-primitive-effect
\ float<= make-foldable
\ float> { float float } { object } <effect> "inferred-effect" set-word-prop
\ float> { float float } { object } <effect> set-primitive-effect
\ float> make-foldable
\ float>= { float float } { object } <effect> "inferred-effect" set-word-prop
\ float>= { float float } { object } <effect> set-primitive-effect
\ float>= make-foldable
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
\ <word> { object object } { word } <effect> set-primitive-effect
\ <word> make-flushable
\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
\ word-xt { word } { integer } <effect> set-primitive-effect
\ word-xt make-flushable
\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop
\ getenv { fixnum } { object } <effect> set-primitive-effect
\ getenv make-flushable
\ setenv { object fixnum } { } <effect> "inferred-effect" set-word-prop
\ setenv { object fixnum } { } <effect> set-primitive-effect
\ (stat) { string } { object object object object } <effect> "inferred-effect" set-word-prop
\ (stat) { string } { object object object object } <effect> set-primitive-effect
\ (directory) { string } { array } <effect> "inferred-effect" set-word-prop
\ (directory) { string } { array } <effect> set-primitive-effect
\ data-gc { } { } <effect> "inferred-effect" set-word-prop
\ data-gc { } { } <effect> set-primitive-effect
\ code-gc { } { } <effect> "inferred-effect" set-word-prop
\ code-gc { } { } <effect> set-primitive-effect
\ gc-time { } { integer } <effect> "inferred-effect" set-word-prop
\ gc-time { } { integer } <effect> set-primitive-effect
\ save-image { string } { } <effect> "inferred-effect" set-word-prop
\ save-image { string } { } <effect> set-primitive-effect
\ save-image-and-exit { string } { } <effect> "inferred-effect" set-word-prop
\ save-image-and-exit { string } { } <effect> set-primitive-effect
\ exit { integer } { } <effect>
t over set-effect-terminated?
"inferred-effect" set-word-prop
set-primitive-effect
\ data-room { } { integer array } <effect> "inferred-effect" set-word-prop
\ data-room { } { integer array } <effect> set-primitive-effect
\ data-room make-flushable
\ code-room { } { integer integer } <effect> "inferred-effect" set-word-prop
\ code-room { } { integer integer } <effect> set-primitive-effect
\ code-room make-flushable
\ os-env { string } { object } <effect> "inferred-effect" set-word-prop
\ os-env { string } { object } <effect> set-primitive-effect
\ millis { } { integer } <effect> "inferred-effect" set-word-prop
\ millis { } { integer } <effect> set-primitive-effect
\ millis make-flushable
\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop
\ type { object } { fixnum } <effect> set-primitive-effect
\ type make-foldable
\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable
\ class-hash { object } { fixnum } <effect> "inferred-effect" set-word-prop
\ class-hash { object } { fixnum } <effect> set-primitive-effect
\ class-hash make-foldable
\ cwd { } { string } <effect> "inferred-effect" set-word-prop
\ cwd { } { string } <effect> set-primitive-effect
\ cd { string } { } <effect> "inferred-effect" set-word-prop
\ cd { string } { } <effect> set-primitive-effect
\ dlopen { string } { dll } <effect> "inferred-effect" set-word-prop
\ dlopen { string } { dll } <effect> set-primitive-effect
\ dlsym { string object } { c-ptr } <effect> "inferred-effect" set-word-prop
\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
\ dlclose { dll } { } <effect> "inferred-effect" set-word-prop
\ dlclose { dll } { } <effect> set-primitive-effect
\ <byte-array> { integer } { byte-array } <effect> "inferred-effect" set-word-prop
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
\ <byte-array> make-flushable
\ <bit-array> { integer } { bit-array } <effect> "inferred-effect" set-word-prop
\ <bit-array> { integer } { bit-array } <effect> set-primitive-effect
\ <bit-array> make-flushable
\ <float-array> { integer float } { float-array } <effect> "inferred-effect" set-word-prop
\ <float-array> { integer float } { float-array } <effect> set-primitive-effect
\ <float-array> make-flushable
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "inferred-effect" set-word-prop
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
\ <displaced-alien> make-flushable
\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-signed-cell make-flushable
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-unsigned-cell make-flushable
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-signed-8 make-flushable
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-unsigned-8 make-flushable
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-signed-4 make-flushable
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-unsigned-4 make-flushable
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
\ alien-signed-2 make-flushable
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
\ alien-unsigned-2 make-flushable
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
\ alien-signed-1 make-flushable
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
\ alien-unsigned-1 make-flushable
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
\ alien-float make-flushable
\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
\ alien-double make-flushable
\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
\ alien-cell make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
\ alien>char-string make-flushable
\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
\ string>char-alien make-flushable
\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
\ alien>u16-string make-flushable
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
\ string>u16-alien make-flushable
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
\ alien-address { alien } { integer } <effect> set-primitive-effect
\ alien-address make-flushable
\ slot { object fixnum } { object } <effect> "inferred-effect" set-word-prop
\ slot { object fixnum } { object } <effect> set-primitive-effect
\ slot make-flushable
\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
\ set-slot { object object fixnum } { } <effect> set-primitive-effect
\ string-nth { fixnum string } { fixnum } <effect> "inferred-effect" set-word-prop
\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
\ string-nth make-flushable
\ set-string-nth { fixnum fixnum string } { } <effect> "inferred-effect" set-word-prop
\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
\ resize-array { integer array } { array } <effect> set-primitive-effect
\ resize-array make-flushable
\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
\ resize-byte-array make-flushable
\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
\ resize-bit-array { integer bit-array } { bit-array } <effect> set-primitive-effect
\ resize-bit-array make-flushable
\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
\ resize-float-array { integer float-array } { float-array } <effect> set-primitive-effect
\ resize-float-array make-flushable
\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
\ resize-string { integer string } { string } <effect> set-primitive-effect
\ resize-string make-flushable
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
\ <array> { integer object } { array } <effect> set-primitive-effect
\ <array> make-flushable
\ begin-scan { } { } <effect> "inferred-effect" set-word-prop
\ begin-scan { } { } <effect> set-primitive-effect
\ next-object { } { object } <effect> "inferred-effect" set-word-prop
\ next-object { } { object } <effect> set-primitive-effect
\ end-scan { } { } <effect> "inferred-effect" set-word-prop
\ end-scan { } { } <effect> set-primitive-effect
\ size { object } { fixnum } <effect> "inferred-effect" set-word-prop
\ size { object } { fixnum } <effect> set-primitive-effect
\ size make-flushable
\ die { } { } <effect> "inferred-effect" set-word-prop
\ die { } { } <effect> set-primitive-effect
\ fopen { string string } { alien } <effect> "inferred-effect" set-word-prop
\ fopen { string string } { alien } <effect> set-primitive-effect
\ fgetc { alien } { object } <effect> "inferred-effect" set-word-prop
\ fgetc { alien } { object } <effect> set-primitive-effect
\ fwrite { string alien } { } <effect> "inferred-effect" set-word-prop
\ fwrite { string alien } { } <effect> set-primitive-effect
\ fread { integer string } { object } <effect> "inferred-effect" set-word-prop
\ fread { integer string } { object } <effect> set-primitive-effect
\ fflush { alien } { } <effect> "inferred-effect" set-word-prop
\ fflush { alien } { } <effect> set-primitive-effect
\ fclose { alien } { } <effect> "inferred-effect" set-word-prop
\ fclose { alien } { } <effect> set-primitive-effect
\ expired? { object } { object } <effect> "inferred-effect" set-word-prop
\ expired? { object } { object } <effect> set-primitive-effect
\ expired? make-flushable
\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
\ <wrapper> make-foldable
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
\ (clone) { object } { object } <effect> set-primitive-effect
\ (clone) make-flushable
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
\ <string> { integer integer } { string } <effect> set-primitive-effect
\ <string> make-flushable
\ array>quotation { array } { quotation } <effect> "inferred-effect" set-word-prop
\ array>quotation { array } { quotation } <effect> set-primitive-effect
\ array>quotation make-flushable
\ quotation-xt { quotation } { integer } <effect> "inferred-effect" set-word-prop
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
\ quotation-xt make-flushable
\ <tuple> { word integer } { quotation } <effect> "inferred-effect" set-word-prop
\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
\ <tuple> make-flushable
\ (>tuple) { array } { tuple } <effect> "inferred-effect" set-word-prop
\ (>tuple) { array } { tuple } <effect> set-primitive-effect
\ (>tuple) make-flushable
\ tuple>array { tuple } { array } <effect> "inferred-effect" set-word-prop
\ tuple>array { tuple } { array } <effect> set-primitive-effect
\ tuple>array make-flushable
\ datastack { } { array } <effect> "inferred-effect" set-word-prop
\ datastack { } { array } <effect> set-primitive-effect
\ datastack make-flushable
\ retainstack { } { array } <effect> "inferred-effect" set-word-prop
\ retainstack { } { array } <effect> set-primitive-effect
\ retainstack make-flushable
\ callstack { } { callstack } <effect> "inferred-effect" set-word-prop
\ callstack { } { callstack } <effect> set-primitive-effect
\ callstack make-flushable
\ callstack>array { callstack } { array } <effect> "inferred-effect" set-word-prop
\ callstack>array { callstack } { array } <effect> set-primitive-effect
\ callstack>array make-flushable
\ (sleep) { integer } { } <effect> "inferred-effect" set-word-prop
\ (sleep) { integer } { } <effect> set-primitive-effect
\ become { array array } { } <effect> "inferred-effect" set-word-prop
\ become { array array } { } <effect> set-primitive-effect
\ innermost-frame-quot { callstack } { quotation } <effect> "inferred-effect" set-word-prop
\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
\ innermost-frame-scan { callstack } { fixnum } <effect> "inferred-effect" set-word-prop
\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop
\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
\ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop
\ (os-envs) { } { array } <effect> set-primitive-effect
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop

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

@ -1,6 +1,6 @@
IN: temporary
USING: sequences inference.transforms tools.test math kernel
quotations tools.test.inference inference ;
quotations inference ;
: compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ;
@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ;
: set-slots-test-2
{ set-a-tuple-x set-a-tuple-x } set-slots ;
[ [ set-slots-test-2 ] infer ] unit-test-fails
[ [ set-slots-test-2 ] infer ] must-fail

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

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

10
core/io/crc32/crc32-docs.factor
View File

@ -2,16 +2,16 @@ USING: help.markup help.syntax math ;
IN: io.crc32
HELP: crc32
{ $values { "seq" "a sequence" } { "n" integer } }
{ $values { "seq" "a sequence of bytes" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
HELP: file-crc32
{ $values { "path" "a pathname string" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a file's contents." } ;
HELP: lines-crc32
{ $values { "lines" "a sequence of strings" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
ARTICLE: "io.crc32" "CRC32 checksum calculation"
"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
{ $subsection crc32 }
{ $subsection file-crc32 } ;
{ $subsection lines-crc32 } ;
ABOUT: "io.crc32"

2
core/io/crc32/crc32.factor
View File

@ -23,8 +23,6 @@ IN: io.crc32
: crc32 ( seq -- n )
>r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
: file-crc32 ( path -- n ) file-contents crc32 ;
: lines-crc32 ( seq -- n )
HEX: ffffffff tuck [
[ (crc32) ] each CHAR: \n (crc32)

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

@ -52,12 +52,27 @@ HELP: <file-appender>
{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: cwd ( -- path )
HELP: with-file-in
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: with-file-out
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-appender
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
HELP: cd ( path -- )
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;

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

@ -2,7 +2,8 @@ IN: temporary
USING: tools.test io.files io threads kernel continuations ;
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ ] [
"test-foo.txt" resource-path <file-writer> [

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

@ -1,10 +1,14 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.files
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs ;
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
HOOK: <file-reader> io-backend ( path -- stream )
HOOK: <file-writer> io-backend ( path -- stream )
@ -25,12 +29,15 @@ HOOK: root-directory? io-backend ( path -- ? )
M: object root-directory? ( path -- ? ) path-separator? ;
: trim-path-separators ( str -- newstr )
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
: left-trim-separators ( str -- newstr )
[ path-separator? ] left-trim ;
: path+ ( str1 str2 -- str )
>r trim-path-separators "/" r>
[ path-separator? ] left-trim 3append ;
>r right-trim-separators "/" r>
left-trim-separators 3append ;
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
@ -57,7 +64,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
normalize-directory dup (directory) fixup-directory ;
: last-path-separator ( path -- n ? )
[ length 2 [-] ] keep [ path-separator? ] find-last* ;
[ length 1- ] keep [ path-separator? ] find-last* ;
TUPLE: no-parent-directory path ;
@ -65,7 +72,7 @@ TUPLE: no-parent-directory path ;
\ no-parent-directory construct-boa throw ;
: parent-directory ( path -- parent )
trim-path-separators {
right-trim-separators {
{ [ dup empty? ] [ drop "/" ] }
{ [ dup root-directory? ] [ ] }
{ [ dup [ path-separator? ] contains? not ] [ drop "." ] }
@ -76,7 +83,11 @@ TUPLE: no-parent-directory path ;
} cond ;
: file-name ( path -- string )
dup last-path-separator [ 1+ tail ] [ drop ] if ;
right-trim-separators {
{ [ dup empty? ] [ drop "/" ] }
{ [ dup last-path-separator ] [ 1+ tail ] }
{ [ t ] [ drop ] }
} cond ;
: resource-path ( path -- newpath )
\ resource-path get [ image parent-directory ] unless*
@ -85,8 +96,11 @@ TUPLE: no-parent-directory path ;
: ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ;
: resource-exists? ( path -- ? )
?resource-path exists? ;
: make-directories ( path -- )
normalize-pathname trim-path-separators {
normalize-pathname right-trim-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
@ -162,3 +176,12 @@ PRIVATE>
: file-contents ( path -- str )
dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;
: with-file-in ( path quot -- )
>r <file-reader> r> with-stream ; inline
: with-file-out ( path quot -- )
>r <file-writer> r> with-stream ; inline
: with-file-appender ( path quot -- )
>r <file-appender> r> with-stream ; inline

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

@ -22,8 +22,7 @@ $nl
{ $subsection make-block-stream }
{ $subsection make-cell-stream }
{ $subsection stream-write-table }
"Optional word for network streams:"
{ $subsection set-timeout } ;
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "The default stream"
"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
@ -73,11 +72,6 @@ ARTICLE: "streams" "Streams"
ABOUT: "streams"
HELP: set-timeout
{ $values { "n" "an integer" } { "stream" "a stream" } }
{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }

1
core/io/io.factor
View File

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

7
core/io/streams/c/c.factor
View File

@ -74,3 +74,10 @@ M: object <file-writer>
M: object <file-appender>
"ab" fopen <c-writer> <plain-writer> ;
: show ( msg -- )
#! A word which directly calls primitives. It is used to
#! print stuff from contexts where the I/O system would
#! otherwise not work (tools.deploy.shaker, the I/O
#! multiplexer thread).
"\r\n" append stdout-handle fwrite stdout-handle fflush ;

4
core/io/streams/duplex/duplex-tests.factor
View File

@ -28,13 +28,13 @@ M: unclosable-stream dispose
[ t ] [
<unclosable-stream> <closing-stream> [
<duplex-stream>
[ dup dispose ] catch 2drop
[ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed?
] unit-test
[ t ] [
<closing-stream> [ <unclosable-stream>
<duplex-stream>
[ dup dispose ] catch 2drop
[ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed?
] unit-test

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-in dispose ] [ ] cleanup
] 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"
"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

46
core/kernel/kernel-tests.factor
View File

@ -7,25 +7,22 @@ IN: temporary
[ t ] [ [ \ = \ = ] all-equal? ] unit-test
! Don't leak extra roots if error is thrown
[ ] [ 10000 [ [ 3 throw ] catch drop ] times ] unit-test
[ ] [ 10000 [ [ 3 throw ] ignore-errors ] times ] unit-test
[ ] [ 10000 [ [ -1 f <array> ] catch drop ] times ] unit-test
[ ] [ 10000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
! Make sure we report the correct error on stack underflow
[ { "kernel-error" 11 f f } ]
[ [ clear drop ] catch ] unit-test
[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with
[ ] [ :c ] unit-test
[ { "kernel-error" 13 f f } ]
[ [ { } set-retainstack r> ] catch ] unit-test
[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with
[ ] [ :c ] unit-test
: overflow-d 3 overflow-d ;
[ { "kernel-error" 12 f f } ]
[ [ overflow-d ] catch ] unit-test
[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ :c ] unit-test
@ -33,24 +30,17 @@ IN: temporary
: overflow-d-alt (overflow-d-alt) overflow-d-alt ;
[ { "kernel-error" 12 f f } ]
[ [ overflow-d-alt ] catch ] unit-test
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ [ :c ] string-out drop ] unit-test
: overflow-r 3 >r overflow-r ;
[ { "kernel-error" 14 f f } ]
[ [ overflow-r ] catch ] unit-test
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
[ ] [ :c ] unit-test
! : overflow-c overflow-c 3 ;
!
! [ { "kernel-error" 16 f f } ]
! [ [ overflow-c ] catch ] unit-test
[ -7 <byte-array> ] unit-test-fails
[ -7 <byte-array> ] must-fail
[ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test
[ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test
@ -61,27 +51,27 @@ IN: temporary
[ 4 ] [ 4 6 or ] unit-test
[ 6 ] [ f 6 or ] unit-test
[ slip ] unit-test-fails
[ slip ] must-fail
[ ] [ :c ] unit-test
[ 1 slip ] unit-test-fails
[ 1 slip ] must-fail
[ ] [ :c ] unit-test
[ 1 2 slip ] unit-test-fails
[ 1 2 slip ] must-fail
[ ] [ :c ] unit-test
[ 1 2 3 slip ] unit-test-fails
[ 1 2 3 slip ] must-fail
[ ] [ :c ] unit-test
[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
[ [ ] keep ] unit-test-fails
[ [ ] keep ] must-fail
[ 6 ] [ 2 [ sq ] keep + ] unit-test
[ [ ] 2keep ] unit-test-fails
[ 1 [ ] 2keep ] unit-test-fails
[ [ ] 2keep ] must-fail
[ 1 [ ] 2keep ] must-fail
[ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test
[ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test
@ -100,13 +90,13 @@ IN: temporary
[ ] [ callstack set-callstack ] unit-test
[ 3drop datastack ] unit-test-fails
[ 3drop datastack ] must-fail
[ ] [ :c ] unit-test
! Doesn't compile; important
: foo 5 + 0 [ ] each ;
[ drop foo ] unit-test-fails
[ drop foo ] must-fail
[ ] [ :c ] unit-test
! Regression
@ -117,4 +107,4 @@ IN: temporary
: loop ( obj obj -- )
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] unit-test-fails
[ loop ] must-fail

14
core/kernel/kernel.factor
View File

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

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

@ -22,7 +22,7 @@ IN: temporary
[
"\\ + 1 2 3 4" parse-interactive
"cont" get continue-with
] catch
] ignore-errors
"USE: debugger :1" eval
] callcc1
] unit-test
@ -36,7 +36,7 @@ IN: temporary
[
"USE: vocabs.loader.test.c" parse-interactive
] unit-test-fails
] must-fail
[ ] [
[

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

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

5
core/math/bitfields/bitfields.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.
USING: arrays kernel math sequences words ;
IN: math.bitfields
@ -13,3 +13,6 @@ M: pair (bitfield) ( value accum pair -- newaccum )
: bitfield ( values... bitspec -- n )
0 [ (bitfield) ] reduce ;
: flags ( values -- n )
0 [ dup word? [ execute ] when bitor ] reduce ;

4
core/math/integers/integers-tests.factor
View File

@ -121,8 +121,8 @@ unit-test
! We don't care if this fails or returns 0 (its CPU-specific)
! as long as it doesn't crash
[ ] [ [ 0 0 /i ] catch clear ] unit-test
[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test
[ ] [ [ 0 0 /i drop ] ignore-errors ] unit-test
[ ] [ [ 100000000000000000 0 /i drop ] ignore-errors ] unit-test
[ -2 ] [ 1 bitnot ] unit-test
[ -2 ] [ 1 >bignum bitnot ] unit-test

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

@ -25,14 +25,10 @@ $nl
ABOUT: "number-strings"
HELP: digits>integer
{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "n" integer } }
{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
{ $description "Converts a sequence of digits (with most significant digit first) into an integer." }
{ $notes "This is one of the factors of " { $link string>number } "." } ;
HELP: valid-digits?
{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "?" "a boolean" } }
{ $description "Tests if this sequence of integers represents a valid integer in the given radix." } ;
HELP: >digit
{ $values { "n" "an integer between 0 and 35" } { "ch" "a character" } }
{ $description "Outputs a character representation of a digit." }
@ -43,11 +39,6 @@ HELP: digit>
{ $description "Converts a character representation of a digit to an integer." }
{ $notes "This is one of the factors of " { $link string>number } "." } ;
HELP: string>integer
{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "an integer or " { $link f } } }
{ $description "Creates an integer from a string representation." }
{ $notes "The " { $link base> } " word is more general." } ;
HELP: base>
{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } }
{ $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10."

16
core/math/parser/parser-tests.factor
View File

@ -95,16 +95,6 @@ unit-test
[ f ] [ "\0." string>number ] unit-test
! [ t ] [
! { "1.0/0.0" "-1.0/0.0" "0.0/0.0" }
! [ dup string>number number>string = ] all?
! ] unit-test
!
! [ t ] [
! { 1.0/0.0 -1.0/0.0 0.0/0.0 }
! [ dup number>string string>number = ] all?
! ] unit-test
[ 1 1 >base ] unit-test-fails
[ 1 0 >base ] unit-test-fails
[ 1 -1 >base ] unit-test-fails
[ 1 1 >base ] must-fail
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail

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

@ -4,12 +4,6 @@ USING: kernel math.private namespaces sequences strings arrays
combinators splitting math assocs ;
IN: math.parser
DEFER: base>
: string>ratio ( str radix -- a/b )
>r "/" split1 r> tuck base> >r base> r>
2dup and [ / ] [ 2drop f ] if ;
: digit> ( ch -- n )
H{
{ CHAR: 0 0 }
@ -36,30 +30,57 @@ DEFER: base>
{ CHAR: f 15 }
} at ;
: digits>integer ( radix seq -- n )
0 rot [ swapd * + ] curry reduce ;
: valid-digits? ( radix seq -- ? )
{
{ [ dup empty? ] [ 2drop f ] }
{ [ f over memq? ] [ 2drop f ] }
{ [ t ] [ swap [ < ] curry all? ] }
} cond ;
: string>digits ( str -- digits )
[ digit> ] { } map-as ;
: string>integer ( str radix -- n/f )
swap "-" ?head >r
string>digits 2dup valid-digits?
[ digits>integer r> [ neg ] when ] [ r> 3drop f ] if ;
: digits>integer ( seq radix -- n )
0 swap [ swapd * + ] curry reduce ;
DEFER: base>
<PRIVATE
SYMBOL: radix
SYMBOL: negative?
: sign negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
radix swap with-variable ; inline
: (base>) ( str -- n ) radix get base> ;
: whole-part ( str -- m n )
sign split1 >r (base>) r>
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
"/" split1 (base>) >r whole-part r>
3dup and and [ / + ] [ 3drop f ] if ;
: valid-digits? ( seq -- ? )
{
{ [ dup empty? ] [ drop f ] }
{ [ f over memq? ] [ drop f ] }
{ [ t ] [ radix get [ < ] curry all? ] }
} cond ;
: string>integer ( str -- n/f )
string>digits dup valid-digits?
[ radix get digits>integer ] [ drop f ] if ;
PRIVATE>
: base> ( str radix -- n/f )
{
{ [ CHAR: / pick member? ] [ string>ratio ] }
{ [ CHAR: . pick member? ] [ drop string>float ] }
{ [ t ] [ string>integer ] }
} cond ;
[
"-" ?head dup negative? set >r
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
{ [ t ] [ string>integer ] }
} cond
r> [ dup [ neg ] when ] when
] with-radix ;
: string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ;
@ -74,8 +95,16 @@ DEFER: base>
dup >r /mod >digit , dup 0 >
[ r> integer, ] [ r> 2drop ] if ;
PRIVATE>
GENERIC# >base 1 ( n radix -- str )
<PRIVATE
: (>base) ( n -- str ) radix get >base ;
PRIVATE>
M: integer >base
[
over 0 < [
@ -87,10 +116,15 @@ M: integer >base
M: ratio >base
[
over numerator over >base %
CHAR: / ,
swap denominator swap >base %
] "" make ;
[
dup 0 < dup negative? set [ "-" % neg ] when
1 /mod
>r dup zero? [ drop ] [ (>base) % sign % ] if r>
dup numerator (>base) %
"/" %
denominator (>base) %
] "" make
] with-radix ;
: fix-float ( str -- newstr )
{

2
core/memory/memory-tests.factor
View File

@ -4,7 +4,7 @@ IN: temporary
TUPLE: testing x y z ;
[ save-image-and-exit ] unit-test-fails
[ save-image-and-exit ] must-fail
[ ] [
num-types get [

98
core/optimizer/backend/backend.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.pattern-match generic.standard ;
optimizer.pattern-match generic.standard optimizer.specializers ;
IN: optimizer.backend
SYMBOL: class-substitutions
@ -52,13 +52,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
DEFER: optimize-nodes
: optimize-children ( node -- )
[
dup node-children dup [
[ optimize-nodes ] map swap set-node-children
] [
2drop
] if
] when* ;
[ optimize-nodes ] change-children ;
: optimize-node ( node -- node )
dup [
@ -76,39 +70,17 @@ DEFER: optimize-nodes
M: f set-node-successor 2drop ;
: (optimize-nodes) ( prev node -- )
optimize-node [
dup rot set-node-successor
dup node-successor (optimize-nodes)
] [
f swap set-node-successor
] if* ;
: optimize-nodes ( node -- newnode )
[
class-substitutions [ clone ] change
literal-substitutions [ clone ] change
dup [
optimize-node
dup dup node-successor (optimize-nodes)
] when optimizer-changed get
[ optimize-node ] transform-nodes
optimizer-changed get
] with-scope optimizer-changed set ;
: prune-if ( node quot -- successor/t )
over >r call [ r> node-successor t ] [ r> drop t f ] if ;
inline
! Generic nodes
M: node optimize-node* drop t f ;
M: #shuffle optimize-node*
[
dup node-in-d empty? swap node-out-d empty? and
] prune-if ;
M: #push optimize-node*
[ node-out-d empty? ] prune-if ;
: cleanup-inlining ( node -- newnode changed? )
node-successor [ node-successor t ] [ t f ] if* ;
@ -118,12 +90,6 @@ M: #return optimize-node* cleanup-inlining ;
! #values
M: #values optimize-node* cleanup-inlining ;
! #>r
M: #>r optimize-node* [ node-in-d empty? ] prune-if ;
! #r>
M: #r> optimize-node* [ node-in-r empty? ] prune-if ;
! Some utilities for splicing in dataflow IR subtrees
: follow ( key assoc -- value )
2dup at* [ swap follow nip ] [ 2drop ] if ;
@ -194,10 +160,8 @@ M: node remember-method*
! Constant branch folding
: fold-branch ( node branch# -- node )
over drop-inputs >r
over node-children nth
swap node-successor over substitute-node
r> [ set-node-successor ] keep ;
swap node-successor over substitute-node ;
! #if
: known-boolean-value? ( node value -- value ? )
@ -213,12 +177,18 @@ M: node remember-method*
] if ;
M: #if optimize-node*
dup dup node-in-d first known-boolean-value?
[ 0 1 ? fold-branch t ] [ 2drop t f ] if ;
dup dup node-in-d first known-boolean-value? [
over drop-inputs >r
0 1 ? fold-branch
r> [ set-node-successor ] keep
t
] [ 2drop t f ] if ;
M: #dispatch optimize-node*
dup dup node-in-d first 2dup node-literal? [
node-literal fold-branch t
"Optimizing #dispatch" print
node-literal
over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
] [
3drop t f
] if ;
@ -245,11 +215,33 @@ M: #dispatch optimize-node*
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
! A heuristic to avoid excessive inlining
DEFER: (flat-length)
: word-flat-length ( word -- n )
dup get over inline? not or
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
: (flat-length) ( seq -- n )
[
{
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
{ [ t ] [ drop 1 ] }
} cond
] map sum ;
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
method method-def
method method-word
dup flat-length 10 >=
[ 1quotation ] [ word-def ] if
] [
2drop t t
] if ;
@ -300,9 +292,19 @@ M: #dispatch optimize-node*
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ;
: optimize-predicate ( #call -- node )
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
dup node-class-first r> class< 1array inline-literals ;
node-class-first r> class< ;
: optimize-predicate ( #call -- node )
dup evaluate-predicate swap
dup node-successor #if? [
dup drop-inputs >r
node-successor swap 0 1 ? fold-branch
r> [ set-node-successor ] keep
] [
swap 1array inline-literals
] if ;
: optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ;
@ -355,7 +357,7 @@ M: #dispatch optimize-node*
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> length tail*
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
] [
2drop f

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
: kill-set ( quot -- seq )
dataflow compute-def-use dead-literals keys
dataflow compute-def-use compute-dead-literals keys
[ value-literal ] map ;
: subset? [ member? ] curry all? ;

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.
dup branch-def-use (node-def-use) ;
: dead-literals ( -- values )
! : dead-literals ( -- values )
! def-use get [ >r value? r> empty? and ] assoc-subset ;
!
! : kill-node* ( node values -- )
! [ swap remove-all ] curry modify-values ;
!
! : kill-node ( node values -- )
! dup assoc-empty?
! [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
!
! : kill-values ( node -- )
! #! Remove literals which are not actually used anywhere.
! dead-literals kill-node ;
: compute-dead-literals ( -- values )
def-use get [ >r value? r> empty? and ] assoc-subset ;
: kill-node* ( node values -- )
[ swap remove-all ] curry modify-values ;
DEFER: kill-nodes
SYMBOL: dead-literals
: kill-node ( node values -- )
dup assoc-empty?
[ 2drop ] [ [ kill-node* ] curry each-node ] if ;
GENERIC: kill-node* ( node -- node/t )
: kill-values ( node -- )
M: node kill-node* drop t ;
: prune-if ( node quot -- successor/t )
over >r call [ r> node-successor ] [ r> drop t ] if ;
inline
M: #shuffle kill-node*
[
dup node-in-d empty? swap node-out-d empty? and
] prune-if ;
M: #push kill-node*
[ node-out-d empty? ] prune-if ;
M: #>r kill-node* [ node-in-d empty? ] prune-if ;
M: #r> kill-node* [ node-in-r empty? ] prune-if ;
: kill-node ( node -- node )
dup [
dup [ dead-literals get swap remove-all ] modify-values
dup kill-node* dup t eq? [
drop dup [ kill-nodes ] change-children
] [
nip kill-node
] if
] when ;
: kill-nodes ( node -- newnode )
[ kill-node ] transform-nodes ;
: kill-values ( node -- new-node )
#! Remove literals which are not actually used anywhere.
dead-literals kill-node ;
compute-dead-literals dup assoc-empty? [ drop ] [
dead-literals [ kill-nodes ] with-variable
] if ;
!
: sole-consumer ( #call -- node/f )
node-out-d first used-by

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