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
core
alien
arrays
bit-arrays
bootstrap
byte-arrays
classes
combinators
compiler
continuations
cpu
debugger
definitions
dlists
effects
float-arrays
generator
generic
growable
hashtables
heaps
inference
io
kernel
listener
math
memory
optimizer
Show More

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