Merge git://factorcode.org/git/factor

db4
Joe Groff 2008-02-11 12:43:26 -08:00
commit bea4848232
794 changed files with 11216 additions and 19340 deletions

View File

@ -56,13 +56,16 @@ default:
@echo "linux-arm" @echo "linux-arm"
@echo "openbsd-x86-32" @echo "openbsd-x86-32"
@echo "openbsd-x86-64" @echo "openbsd-x86-64"
@echo "netbsd-x86-32"
@echo "netbsd-x86-64"
@echo "macosx-x86-32" @echo "macosx-x86-32"
@echo "macosx-x86-64" @echo "macosx-x86-64"
@echo "macosx-ppc" @echo "macosx-ppc"
@echo "solaris-x86-32" @echo "solaris-x86-32"
@echo "solaris-x86-64" @echo "solaris-x86-64"
@echo "windows-ce-arm" @echo "wince-arm"
@echo "windows-nt-x86-32" @echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo "" @echo ""
@echo "Additional modifiers:" @echo "Additional modifiers:"
@echo "" @echo ""
@ -83,6 +86,12 @@ freebsd-x86-32:
freebsd-x86-64: freebsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64 $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.64
macosx-freetype: macosx-freetype:
ln -sf libfreetype.6.dylib \ ln -sf libfreetype.6.dylib \
Factor.app/Contents/Frameworks/libfreetype.dylib Factor.app/Contents/Frameworks/libfreetype.dylib
@ -114,10 +123,21 @@ solaris-x86-32:
solaris-x86-64: solaris-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
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 $(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 $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
macosx.app: factor macosx.app: factor
@ -143,7 +163,7 @@ clean:
rm -f factor*.dll libfactor*.* rm -f factor*.dll libfactor*.*
vm/resources.o: vm/resources.o:
windres vm/factor.rs vm/resources.o $(WINDRES) vm/factor.rs vm/resources.o
.c.o: .c.o:
$(CC) -c $(CFLAGS) -o $@ $< $(CC) -c $(CFLAGS) -o $@ $<

View File

@ -1,6 +1,7 @@
USING: byte-arrays arrays help.syntax help.markup USING: byte-arrays arrays help.syntax help.markup
alien.syntax compiler definitions math libc alien.syntax compiler definitions math libc
debugger parser io io.backend system bit-arrays float-arrays ; debugger parser io io.backend system bit-arrays float-arrays
alien.accessors ;
IN: alien IN: alien
HELP: alien HELP: alien

12
core/alien/alien-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
IN: temporary IN: temporary
USING: alien byte-arrays USING: alien alien.accessors byte-arrays arrays kernel
arrays kernel kernel.private namespaces tools.test sequences kernel.private namespaces tools.test sequences libc math system
libc math system prettyprint ; prettyprint ;
[ t ] [ -1 <alien> alien-address 0 > ] unit-test [ t ] [ -1 <alien> alien-address 0 > ] unit-test
@ -14,7 +14,7 @@ libc math system prettyprint ;
! Testing the various bignum accessor ! Testing the various bignum accessor
10 <byte-array> "dump" set 10 <byte-array> "dump" set
[ "dump" get alien-address ] unit-test-fails [ "dump" get alien-address ] must-fail
[ 123 ] [ [ 123 ] [
123 "dump" get 0 set-alien-signed-1 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 F{ 1 2 3 } <displaced-alien> drop ] unit-test
[ ] [ 0 ?{ t f t } <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 [ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test

View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system USING: assocs kernel math namespaces sequences system
kernel.private tuples ; kernel.private tuples bit-arrays byte-arrays float-arrays ;
IN: alien IN: alien
! Some predicate classes used by the compiler for optimization ! Some predicate classes used by the compiler for optimization
@ -9,16 +9,11 @@ IN: alien
PREDICATE: alien simple-alien PREDICATE: alien simple-alien
underlying-alien not ; underlying-alien not ;
! These mixins are not intended to be extended by user code. UNION: simple-c-ptr
! They are not unions, because if they were we'd have a circular simple-alien POSTPONE: f byte-array bit-array float-array ;
! dependency between alien and {byte,bit,float}-arrays.
MIXIN: simple-c-ptr
INSTANCE: simple-alien simple-c-ptr
INSTANCE: f simple-c-ptr
MIXIN: c-ptr UNION: c-ptr
INSTANCE: alien c-ptr alien POSTPONE: f byte-array bit-array float-array ;
INSTANCE: f c-ptr
DEFER: pinned-c-ptr? DEFER: pinned-c-ptr?

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." } { $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." } ; { $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 HELP: c-getter
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } } { $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." } { $description "Outputs a quotation which reads values of this C type from a C structure." }

10
core/alien/c-types/c-types-tests.factor Normal file → Executable file
View File

@ -2,16 +2,16 @@ IN: temporary
USING: alien alien.syntax alien.c-types kernel tools.test USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ; sequences system libc ;
[ "\u00ff" ] [ "\u0000ff" ]
[ "\u00ff" string>char-alien alien>char-string ] [ "\u0000ff" string>char-alien alien>char-string ]
unit-test unit-test
[ "hello world" ] [ "hello world" ]
[ "hello world" string>char-alien alien>char-string ] [ "hello world" string>char-alien alien>char-string ]
unit-test unit-test
[ "hello\uabcdworld" ] [ "hello\u00abcdworld" ]
[ "hello\uabcdworld" string>u16-alien alien>u16-string ] [ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
unit-test unit-test
[ t ] [ f expired? ] unit-test [ t ] [ f expired? ] unit-test
@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE
[ [
0 B{ 1 2 3 4 } <displaced-alien> <void*> 0 B{ 1 2 3 4 } <displaced-alien> <void*>
] unit-test-fails ] must-fail

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

View File

@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads namespaces.private io io.streams.string memory system threads
tools.test.inference ; tools.test ;
FUNCTION: void ffi_test_0 ; FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test [ ] [ ffi_test_0 ] unit-test
@ -13,7 +13,7 @@ FUNCTION: int ffi_test_1 ;
FUNCTION: int ffi_test_2 int x int y ; FUNCTION: int ffi_test_2 int x int y ;
[ 5 ] [ 2 3 ffi_test_2 ] unit-test [ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "hi" 3 ffi_test_2 ] unit-test-fails [ "hi" 3 ffi_test_2 ] must-fail
FUNCTION: int ffi_test_3 int x int y int z int t ; FUNCTION: int ffi_test_3 int x int y int z int t ;
[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
@ -26,8 +26,8 @@ FUNCTION: double ffi_test_5 ;
FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
[ "a" 2 3 4 5 6 7 ffi_test_9 ] unit-test-fails [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] unit-test-fails [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo C-STRUCT: foo
{ "int" "x" } { "int" "x" }
@ -53,7 +53,7 @@ FUNCTION: char* ffi_test_15 char* x char* y ;
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] unit-test-fails [ 1 2 ffi_test_15 ] must-fail
C-STRUCT: bar C-STRUCT: bar
{ "long" "x" } { "long" "x" }
@ -75,21 +75,21 @@ FUNCTION: tiny ffi_test_17 int x ;
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test [ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
[ t ] [ [ [ alien-indirect ] infer ] catch inference-error? ] unit-test [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1 : indirect-test-1
"int" { } "cdecl" alien-indirect ; "int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] unit-test-effect { 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ -1 indirect-test-1 ] unit-test-fails [ -1 indirect-test-1 ] must-fail
: indirect-test-2 : indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect data-gc ; "int" { "int" "int" } "cdecl" alien-indirect data-gc ;
{ 3 1 } [ indirect-test-2 ] unit-test-effect { 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ] [ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
@ -120,7 +120,7 @@ unit-test
FUNCTION: double ffi_test_6 float x float y ; FUNCTION: double ffi_test_6 float x float y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
[ "a" "b" ffi_test_6 ] unit-test-fails [ "a" "b" ffi_test_6 ] must-fail
FUNCTION: double ffi_test_7 double x double y ; FUNCTION: double ffi_test_7 double x double y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
@ -157,7 +157,7 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ;
[ 987655432 ] [ 987655432 ]
[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
[ 1111 f 123456789 ffi_test_22 ] unit-test-fails [ 1111 f 123456789 ffi_test_22 ] must-fail
C-STRUCT: rect C-STRUCT: rect
{ "float" "x" } { "float" "x" }
@ -177,7 +177,7 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] unit-test-fails [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
@ -270,6 +270,16 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ;
3 ffi_test_35 3 ffi_test_35
] unit-test ] 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 ! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ; : callback-1 "void" { } "cdecl" [ ] alien-callback ;
@ -282,7 +292,7 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ ] [ callback-1 callback_test_1 ] unit-test [ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ; : callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test [ ] [ callback-2 callback_test_1 ] unit-test

View File

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

View File

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

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 [ ?{ 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

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math alien kernel kernel.private sequences USING: math alien.accessors kernel kernel.private sequences
sequences.private ; sequences.private ;
IN: bit-arrays IN: bit-arrays
@ -52,5 +52,3 @@ M: bit-array resize
resize-bit-array ; resize-bit-array ;
INSTANCE: bit-array sequence INSTANCE: bit-array sequence
INSTANCE: bit-array simple-c-ptr
INSTANCE: bit-array c-ptr

View File

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

View File

@ -7,9 +7,26 @@ strings sbufs vectors words quotations assocs system layouts
splitting growable classes tuples words.private splitting growable classes tuples words.private
io.binary io.files vocabs vocabs.loader source-files io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private definitions debugger float-arrays quotations.private
combinators.private combinators ; sequences.private combinators ;
IN: bootstrap.image IN: bootstrap.image
: my-arch ( -- arch )
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 <PRIVATE
! Constants ! Constants
@ -17,8 +34,6 @@ IN: bootstrap.image
: image-magic HEX: 0f0e0d0c ; inline : image-magic HEX: 0f0e0d0c ; inline
: image-version 4 ; inline : image-version 4 ; inline
: char bootstrap-cell 2/ ; inline
: data-base 1024 ; inline : data-base 1024 ; inline
: userenv-size 40 ; inline : userenv-size 40 ; inline
@ -121,7 +136,7 @@ SYMBOL: undefined-quot
: here-as ( tag -- pointer ) here swap bitor ; : here-as ( tag -- pointer ) here swap bitor ;
: align-here ( -- ) : align-here ( -- )
here 8 mod 4 = [ 0 emit ] when ; here 8 mod 4 = [ heap-size drop 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ; : emit-fixnum ( n -- ) tag-fixnum emit ;
@ -162,6 +177,7 @@ GENERIC: ' ( obj -- ptr )
[ dup bignum-bits neg shift swap bignum-radix bitand ] [ dup bignum-bits neg shift swap bignum-radix bitand ]
[ ] unfold nip ; [ ] unfold nip ;
USE: continuations
: emit-bignum ( n -- ) : emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
dup length 1+ emit-fixnum dup length 1+ emit-fixnum
@ -199,13 +215,10 @@ M: f '
: 1, 1 >bignum ' 1-offset fixup ; : 1, 1 >bignum ' 1-offset fixup ;
: -1, -1 >bignum ' -1-offset fixup ; : -1, -1 >bignum ' -1-offset fixup ;
! Beginning of the image
: begin-image ( -- ) emit-header t, 0, 1, -1, ;
! Words ! Words
: emit-word ( word -- ) : emit-word ( word -- )
dup subwords [ emit-word ] each
[ [
dup hashcode ' , dup hashcode ' ,
dup word-name ' , dup word-name ' ,
@ -226,7 +239,7 @@ M: f '
[ % dup word-vocabulary % " " % word-name % ] "" make throw ; [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word ) : transfer-word ( word -- word )
dup target-word [ ] [ word-name no-word ] ?if ; dup target-word swap or ;
: fixup-word ( word -- offset ) : fixup-word ( word -- offset )
transfer-word dup objects get at transfer-word dup objects get at
@ -244,21 +257,19 @@ M: wrapper '
[ emit ] emit-object ; [ emit ] emit-object ;
! Strings ! Strings
: 16be> 0 [ swap 16 shift bitor ] reduce ;
: 16le> <reversed> 16be> ;
: emit-chars ( seq -- ) : emit-chars ( seq -- )
char <groups> bootstrap-cell <groups>
big-endian get [ [ 16be> ] map ] [ [ 16le> ] map ] if big-endian get [ [ be> ] map ] [ [ le> ] map ] if
emit-seq ; emit-seq ;
: pack-string ( string -- newstr ) : pack-string ( string -- newstr )
dup length 1+ char align 0 pad-right ; dup length bootstrap-cell align 0 pad-right ;
: emit-string ( string -- ptr ) : emit-string ( string -- ptr )
string type-number object tag-number [ string type-number object tag-number [
dup length emit-fixnum dup length emit-fixnum
f ' emit f ' emit
f ' emit
pack-string emit-chars pack-string emit-chars
] emit-object ; ] emit-object ;
@ -289,17 +300,20 @@ M: float-array ' float-array emit-dummy-array ;
] emit-object ; ] emit-object ;
: emit-tuple ( obj -- pointer ) : emit-tuple ( obj -- pointer )
objects get [ [
[ tuple>array unclip transfer-word , % ] { } make [ tuple>array unclip transfer-word , % ] { } make
tuple type-number dup emit-array 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: tuple ' emit-tuple ;
M: tombstone ' M: tombstone '
delegate delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup "((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first emit-tuple ; word-def first objects get [ emit-tuple ] cache ;
M: array ' M: array '
array type-number object tag-number emit-array ; array type-number object tag-number emit-array ;
@ -317,41 +331,6 @@ M: quotation '
] emit-object ] emit-object
] cache ; ] 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 ! Curries
M: curry ' M: curry '
@ -403,7 +382,10 @@ M: curry '
: fixup-header ( -- ) : fixup-header ( -- )
heap-size data-heap-size-offset fixup ; heap-size data-heap-size-offset fixup ;
: end-image ( -- ) : build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
"Serializing words..." print flush "Serializing words..." print flush
emit-words emit-words
"Serializing JIT data..." print flush "Serializing JIT data..." print flush
@ -418,7 +400,8 @@ M: curry '
fixup-header fixup-header
"Image length: " write image get length . "Image length: " write image get length .
"Object cache size: " write objects get assoc-size . "Object cache size: " write objects get assoc-size .
\ word global delete-at ; \ word global delete-at
image get ;
! Image output ! Image output
@ -429,37 +412,23 @@ M: curry '
[ >le write ] curry each [ >le write ] curry each
] if ; ] if ;
: image-name : write-image ( image -- )
"boot." architecture get ".image" 3append resource-path ; "Writing image to " write
architecture get boot-image-name resource-path
: write-image ( image filename -- ) dup write "..." print flush
"Writing image to " write dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ; <file-writer> [ (write-image) ] with-stream ;
: prepare-image ( -- )
bootstrapping? on
load-help? off
800000 <vector> image set
20000 <hashtable> objects set ;
PRIVATE> PRIVATE>
: make-image ( arch -- ) : make-image ( arch -- )
architecture [ [
prepare-image architecture set
begin-image bootstrapping? on
load-help? off
"resource:/core/bootstrap/stage1.factor" run-file "resource:/core/bootstrap/stage1.factor" run-file
end-image build-image
image get image-name write-image write-image
] with-variable ; ] with-scope ;
: my-arch ( -- arch )
cpu dup "ppc" = [ os "-" rot 3append ] when ;
: make-images ( -- ) : make-images ( -- )
{ images [ make-image ] each ;
"x86.32"
"x86.64"
"linux-ppc" "macosx-ppc"
! "arm"
} [ make-image ] each ;

View File

@ -40,6 +40,7 @@ call
! classes will go ! classes will go
{ {
"alien" "alien"
"alien.accessors"
"arrays" "arrays"
"bit-arrays" "bit-arrays"
"bit-vectors" "bit-vectors"
@ -117,11 +118,11 @@ H{ } clone update-map set
H{ } clone typemap set H{ } clone typemap set
num-types get f <array> builtins set num-types get f <array> builtins set
! These symbols are needed by the code that executes below ! Forward definitions
{ "object" "kernel" create t "class" set-word-prop
{ "object" "kernel" } "object" "kernel" create union-class "metaclass" set-word-prop
{ "null" "kernel" }
} [ create drop ] assoc-each "null" "kernel" create drop
"fixnum" "math" create "fixnum?" "math" create { } define-builtin "fixnum" "math" create "fixnum?" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@ -190,6 +191,11 @@ num-types get f <array> builtins set
"length" "length"
{ "length" "sequences" } { "length" "sequences" }
f f
} {
{ "object" "kernel" }
"aux"
{ "string-aux" "strings.private" }
{ "set-string-aux" "strings.private" }
} }
} define-builtin } define-builtin
@ -547,8 +553,6 @@ builtins get num-tags get tail f union-class define-class
{ "millis" "system" } { "millis" "system" }
{ "type" "kernel.private" } { "type" "kernel.private" }
{ "tag" "kernel.private" } { "tag" "kernel.private" }
{ "cwd" "io.files" }
{ "cd" "io.files" }
{ "modify-code-heap" "compiler.units" } { "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" } { "dlopen" "alien" }
{ "dlsym" "alien" } { "dlsym" "alien" }
@ -556,32 +560,32 @@ builtins get num-tags get tail f union-class define-class
{ "<byte-array>" "byte-arrays" } { "<byte-array>" "byte-arrays" }
{ "<bit-array>" "bit-arrays" } { "<bit-array>" "bit-arrays" }
{ "<displaced-alien>" "alien" } { "<displaced-alien>" "alien" }
{ "alien-signed-cell" "alien" } { "alien-signed-cell" "alien.accessors" }
{ "set-alien-signed-cell" "alien" } { "set-alien-signed-cell" "alien.accessors" }
{ "alien-unsigned-cell" "alien" } { "alien-unsigned-cell" "alien.accessors" }
{ "set-alien-unsigned-cell" "alien" } { "set-alien-unsigned-cell" "alien.accessors" }
{ "alien-signed-8" "alien" } { "alien-signed-8" "alien.accessors" }
{ "set-alien-signed-8" "alien" } { "set-alien-signed-8" "alien.accessors" }
{ "alien-unsigned-8" "alien" } { "alien-unsigned-8" "alien.accessors" }
{ "set-alien-unsigned-8" "alien" } { "set-alien-unsigned-8" "alien.accessors" }
{ "alien-signed-4" "alien" } { "alien-signed-4" "alien.accessors" }
{ "set-alien-signed-4" "alien" } { "set-alien-signed-4" "alien.accessors" }
{ "alien-unsigned-4" "alien" } { "alien-unsigned-4" "alien.accessors" }
{ "set-alien-unsigned-4" "alien" } { "set-alien-unsigned-4" "alien.accessors" }
{ "alien-signed-2" "alien" } { "alien-signed-2" "alien.accessors" }
{ "set-alien-signed-2" "alien" } { "set-alien-signed-2" "alien.accessors" }
{ "alien-unsigned-2" "alien" } { "alien-unsigned-2" "alien.accessors" }
{ "set-alien-unsigned-2" "alien" } { "set-alien-unsigned-2" "alien.accessors" }
{ "alien-signed-1" "alien" } { "alien-signed-1" "alien.accessors" }
{ "set-alien-signed-1" "alien" } { "set-alien-signed-1" "alien.accessors" }
{ "alien-unsigned-1" "alien" } { "alien-unsigned-1" "alien.accessors" }
{ "set-alien-unsigned-1" "alien" } { "set-alien-unsigned-1" "alien.accessors" }
{ "alien-float" "alien" } { "alien-float" "alien.accessors" }
{ "set-alien-float" "alien" } { "set-alien-float" "alien.accessors" }
{ "alien-double" "alien" } { "alien-double" "alien.accessors" }
{ "set-alien-double" "alien" } { "set-alien-double" "alien.accessors" }
{ "alien-cell" "alien" } { "alien-cell" "alien.accessors" }
{ "set-alien-cell" "alien" } { "set-alien-cell" "alien.accessors" }
{ "alien>char-string" "alien" } { "alien>char-string" "alien" }
{ "string>char-alien" "alien" } { "string>char-alien" "alien" }
{ "alien>u16-string" "alien" } { "alien>u16-string" "alien" }
@ -590,8 +594,8 @@ builtins get num-tags get tail f union-class define-class
{ "alien-address" "alien" } { "alien-address" "alien" }
{ "slot" "slots.private" } { "slot" "slots.private" }
{ "set-slot" "slots.private" } { "set-slot" "slots.private" }
{ "char-slot" "strings.private" } { "string-nth" "strings.private" }
{ "set-char-slot" "strings.private" } { "set-string-nth" "strings.private" }
{ "resize-array" "arrays" } { "resize-array" "arrays" }
{ "resize-string" "strings" } { "resize-string" "strings" }
{ "<array>" "arrays" } { "<array>" "arrays" }

View File

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

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

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

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private alien sequences sequences.private USING: kernel kernel.private alien.accessors sequences
math ; sequences.private math ;
IN: byte-arrays IN: byte-arrays
M: byte-array clone (clone) ; M: byte-array clone (clone) ;
@ -19,5 +19,3 @@ M: byte-array resize
resize-byte-array ; resize-byte-array ;
INSTANCE: byte-array sequence INSTANCE: byte-array sequence
INSTANCE: byte-array simple-c-ptr
INSTANCE: byte-array c-ptr

View File

@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ f ] [ union-1 union-class? ] unit-test [ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test
[ "union-1" ] [ 8 generic-update-test ] 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 ! Test mixins
MIXIN: sequence-mixin 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-1 integer ;
UNION: forget-class-bug-2 forget-class-bug-1 dll ; 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 DEFER: mixin-forget-test-g
@ -191,7 +195,7 @@ DEFER: mixin-forget-test-g
] unit-test ] unit-test
[ { } ] [ { } 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,5 +209,16 @@ DEFER: mixin-forget-test-g
parse-stream drop parse-stream drop
] unit-test ] unit-test
[ { } mixin-forget-test-g ] unit-test-fails [ { } mixin-forget-test-g ] must-fail
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
! Method flattening interfered with mixin update
MIXIN: flat-mx-1
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test

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. ! See http://factorcode.org/license.txt for BSD license.
IN: classes IN: classes
USING: arrays definitions assocs kernel USING: arrays definitions assocs kernel
@ -20,7 +20,9 @@ PREDICATE: class tuple-class
: classes ( -- seq ) class<map get keys ; : classes ( -- seq ) class<map get keys ;
: type>class ( n -- class ) builtins get nth ; : type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
: predicate-word ( word -- predicate ) : predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ; [ word-name "?" append ] keep word-vocabulary create ;
@ -255,7 +257,14 @@ PRIVATE>
>r dup word-props r> union over set-word-props >r dup word-props r> union over set-word-props
t "class" set-word-prop ; t "class" set-word-prop ;
GENERIC: update-methods ( class -- ) GENERIC: update-predicate ( class -- )
M: class update-predicate drop ;
: update-predicates ( assoc -- )
[ drop update-predicate ] assoc-each ;
GENERIC: update-methods ( assoc -- )
: define-class ( word members superclass metaclass -- ) : define-class ( word members superclass metaclass -- )
#! If it was already a class, update methods after. #! If it was already a class, update methods after.
@ -264,8 +273,9 @@ GENERIC: update-methods ( class -- )
over class-usages [ over class-usages [
uncache-classes uncache-classes
dupd (define-class) dupd (define-class)
] keep cache-classes ] keep cache-classes r>
r> [ update-methods ] [ drop ] if ; [ class-usages dup update-predicates update-methods ]
[ drop ] if ;
GENERIC: class ( object -- class ) inline GENERIC: class ( object -- class ) inline

29
core/classes/union/union.factor Normal file → Executable file
View File

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

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

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

View File

@ -38,7 +38,7 @@ namespaces combinators words ;
! Interpreted ! Interpreted
[ "two" ] [ 2 \ case-test-1 word-def call ] unit-test [ "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 : case-test-2
{ {

View File

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

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

View File

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

View File

@ -10,7 +10,7 @@ IN: compiler.constants
! These constants must match vm/layouts.h ! These constants must match vm/layouts.h
: header-offset object tag-number neg ; : header-offset object tag-number neg ;
: float-offset 8 float tag-number - ; : float-offset 8 float tag-number - ;
: string-offset 3 bootstrap-cells object tag-number - ; : string-offset 4 bootstrap-cells object tag-number - ;
: profile-count-offset 7 bootstrap-cells object tag-number - ; : profile-count-offset 7 bootstrap-cells object tag-number - ;
: byte-array-offset 2 bootstrap-cells object tag-number - ; : byte-array-offset 2 bootstrap-cells object tag-number - ;
: alien-offset 3 bootstrap-cells object tag-number - ; : alien-offset 3 bootstrap-cells object tag-number - ;

View File

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

View File

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

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

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

View File

@ -1,240 +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

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

View File

@ -1,10 +1,10 @@
IN: temporary IN: temporary
USING: arrays compiler kernel kernel.private math USING: arrays compiler kernel kernel.private math math.constants
math.constants math.private sequences strings tools.test words math.private sequences strings tools.test words continuations
continuations sequences.private hashtables.private byte-arrays sequences.private hashtables.private byte-arrays strings.private
strings.private system random layouts vectors.private system random layouts vectors.private sbufs.private
sbufs.private strings.private slots.private alien alien.c-types strings.private slots.private alien alien.accessors
alien.syntax namespaces libc combinators.private ; alien.c-types alien.syntax namespaces libc sequences.private ;
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test
@ -36,13 +36,13 @@ alien.syntax namespaces libc combinators.private ;
! Write barrier hits on the wrong value were causing segfaults ! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test ! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test ! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test ! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
!
[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test ! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test ! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test ! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test [ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
@ -334,10 +334,6 @@ cell 8 = [
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
[ H{ } ] [
100 [ (hashtable) ] compile-call [ reset-hash ] keep
] unit-test
[ B{ 0 0 0 0 0 } ] [ [ B{ 0 0 0 0 0 } ] [
[ 5 <byte-array> ] compile-call [ 5 <byte-array> ] compile-call
] unit-test ] unit-test
@ -426,11 +422,11 @@ cell 8 = [
[ [
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call 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 B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
] unit-test-fails ] must-fail
[ [
4 5 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

View File

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

View File

@ -2,8 +2,8 @@
USING: arrays compiler kernel kernel.private math USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private sequences.private tools.test namespaces.private slots.private
combinators.private byte-arrays alien layouts words definitions sequences.private byte-arrays alien alien.accessors layouts
compiler.units ; words definitions compiler.units ;
IN: temporary IN: temporary
! Oops! ! Oops!

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

@ -28,9 +28,7 @@ HELP: redefine-error
HELP: remember-definition HELP: remember-definition
{ $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } } { $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." { $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 } "." } ;
HELP: old-definitions 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." } ; { $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 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 } "." } ; { $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 HELP: with-compilation-unit
{ $values { "quot" quotation } } { $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." } { $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." }

View File

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

23
core/continuations/continuations-docs.factor Normal file → Executable file
View File

@ -23,10 +23,9 @@ $nl
"Two words raise an error in the innermost error handler for the current dynamic extent:" "Two words raise an error in the innermost error handler for the current dynamic extent:"
{ $subsection throw } { $subsection throw }
{ $subsection rethrow } { $subsection rethrow }
"A set of words establish an error handler:" "Two words for establishing an error handler:"
{ $subsection cleanup } { $subsection cleanup }
{ $subsection recover } { $subsection recover }
{ $subsection catch }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" } { $subsection "errors-restartable" }
{ $subsection "errors-post-mortem" } ; { $subsection "errors-post-mortem" } ;
@ -68,6 +67,15 @@ $nl
ABOUT: "continuations" ABOUT: "continuations"
HELP: dispose
{ $values { "object" "a disposable object" } }
{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
HELP: with-disposal
{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
HELP: catchstack* HELP: catchstack*
{ $values { "catchstack" "a vector of continuations" } } { $values { "catchstack" "a vector of continuations" } }
{ $description "Outputs the current catchstack." } ; { $description "Outputs the current catchstack." } ;
@ -138,12 +146,7 @@ HELP: throw
{ $values { "error" object } } { $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." } ; { $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 { cleanup recover } related-words
{ $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
HELP: cleanup HELP: cleanup
{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } } { $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
@ -157,7 +160,7 @@ HELP: rethrow
{ $values { "error" object } } { $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." } { $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 { $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 { $examples
"The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:" "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:"
@ -166,7 +169,7 @@ HELP: rethrow
HELP: throw-restarts HELP: throw-restarts
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." } { $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
{ $examples { $examples
"Try invoking one of the two restarts which are offered after the below code throws an error:" "Try invoking one of the two restarts which are offered after the below code throws an error:"
{ $code { $code

View File

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences USING: arrays vectors kernel kernel.private sequences
namespaces math splitting sorting quotations assocs ; namespaces math splitting sorting quotations assocs ;
@ -17,9 +17,6 @@ SYMBOL: restarts
: c> ( -- continuation ) catchstack* pop ; : c> ( -- continuation ) catchstack* pop ;
: (catch) ( quot -- newquot )
[ swap >c call c> drop ] curry ; inline
: dummy ( -- obj ) : dummy ( -- obj )
#! Optimizing compiler assumes stack won't be messed with #! Optimizing compiler assumes stack won't be messed with
#! in-transit. To ensure that a value is actually reified #! in-transit. To ensure that a value is actually reified
@ -120,11 +117,8 @@ PRIVATE>
catchstack* empty? [ die ] when catchstack* empty? [ die ] when
dup save-error c> continue-with ; dup save-error c> continue-with ;
: catch ( try -- error/f )
(catch) [ f ] compose callcc1 ; inline
: recover ( try recovery -- ) : recover ( try recovery -- )
>r (catch) r> ifcc ; inline >r [ swap >c call c> drop ] curry r> ifcc ; inline
: cleanup ( try cleanup-always cleanup-error -- ) : cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry over >r compose [ dip rethrow ] curry
@ -135,6 +129,11 @@ PRIVATE>
[ [ , f ] compose [ , drop t ] recover ] curry all? [ [ , f ] compose [ , drop t ] recover ] curry all?
] { } make peek swap [ rethrow ] when ; inline ] { } make peek swap [ rethrow ] when ; inline
GENERIC: dispose ( object -- )
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
TUPLE: condition restarts continuation ; TUPLE: condition restarts continuation ;
: <condition> ( error restarts cc -- condition ) : <condition> ( error restarts cc -- condition )

View File

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

View File

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

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays cpu.ppc.assembler USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler
cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
kernel.private math math.private namespaces sequences words kernel.private math math.private namespaces sequences words
generic quotations byte-arrays hashtables hashtables.private generic quotations byte-arrays hashtables hashtables.private
@ -93,30 +93,6 @@ IN: cpu.ppc.intrinsics
} }
} define-intrinsics } define-intrinsics
: (%char-slot)
"offset" operand "n" operand 2 SRAWI
"offset" operand dup "obj" operand ADD ;
\ char-slot [
(%char-slot)
"out" operand "offset" operand string-offset LHZ
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +scratch+ { { f "out" } { f "offset" } } }
{ +output+ { "out" } }
} define-intrinsic
\ set-char-slot [
(%char-slot)
"val" operand dup %untag-fixnum
"val" operand "offset" operand string-offset STH
] H{
{ +input+ { { f "val" } { f "n" } { f "obj" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "val" } }
} define-intrinsic
: fixnum-register-op ( op -- pair ) : fixnum-register-op ( op -- pair )
[ "out" operand "y" operand "x" operand ] swap add H{ [ "out" operand "y" operand "x" operand ] swap add H{
{ +input+ { { f "x" } { f "y" } } } { +input+ { { f "x" } { f "y" } } }

View File

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

View File

@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system namespaces sequences generator.registers generator.fixup system
alien alien.compiler alien.structs slots splitting assocs ; alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64 IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend PREDICATE: x86-backend amd64-backend

View File

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

View File

@ -1,12 +1,13 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.x86.assembler cpu.x86.allot USING: alien alien.accessors arrays cpu.x86.assembler
cpu.x86.architecture cpu.architecture kernel kernel.private math cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
math.private namespaces quotations sequences kernel.private math math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system sbufs sbufs.private vectors vectors.private layouts system
tuples.private strings.private slots.private compiler.constants ; tuples.private strings.private slots.private compiler.constants
;
IN: cpu.x86.intrinsics IN: cpu.x86.intrinsics
! Type checks ! Type checks
@ -153,34 +154,6 @@ IN: cpu.x86.intrinsics
: small-reg-16 BX ; inline : small-reg-16 BX ; inline
: small-reg-32 EBX ; inline : small-reg-32 EBX ; inline
\ char-slot [
small-reg PUSH
"n" operand 2 SHR
small-reg dup XOR
"obj" operand "n" operand ADD
small-reg-16 "obj" operand string-offset [+] MOV
small-reg %tag-fixnum
"obj" operand small-reg MOV
small-reg POP
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +output+ { "obj" } }
{ +clobber+ { "obj" "n" } }
} define-intrinsic
\ set-char-slot [
small-reg PUSH
"val" operand %untag-fixnum
"slot" operand 2 SHR
"obj" operand "slot" operand ADD
small-reg "val" operand MOV
"obj" operand string-offset [+] small-reg-16 MOV
small-reg POP
] H{
{ +input+ { { f "val" } { f "slot" } { f "obj" } } }
{ +clobber+ { "val" "slot" "obj" } }
} define-intrinsic
! Fixnums ! Fixnums
: fixnum-op ( op hash -- pair ) : fixnum-op ( op hash -- pair )
>r [ "x" operand "y" operand ] swap add r> 2array ; >r [ "x" operand "y" operand ] swap add r> 2array ;

10
core/cpu/x86/sse2/sse2.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.x86.assembler cpu.x86.architecture USING: alien alien.accessors arrays cpu.x86.assembler
cpu.x86.intrinsics generic kernel kernel.private math cpu.x86.architecture cpu.x86.intrinsics generic kernel
math.private memory namespaces sequences words generator kernel.private math math.private memory namespaces sequences
generator.registers cpu.architecture math.floats.private layouts words generator generator.registers cpu.architecture
quotations ; math.floats.private layouts quotations ;
IN: cpu.x86.sse2 IN: cpu.x86.sse2
: define-float-op ( word op -- ) : define-float-op ( word op -- )

View File

@ -87,7 +87,32 @@ TUPLE: assert got expect ;
: depth ( -- n ) datastack length ; : 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 -- ) : expired-error. ( obj -- )
"Object did not survive image save/load: " write third . ; "Object did not survive image save/load: " write third . ;
@ -222,9 +247,6 @@ M: redefine-error error.
"Re-definition of " write "Re-definition of " write
redefine-error-def . ; redefine-error-def . ;
M: forward-error error.
"Forward reference to " write forward-error-word . ;
M: undefined summary M: undefined summary
drop "Calling a deferred word before it has been defined" ; drop "Calling a deferred word before it has been defined" ;

View File

@ -52,9 +52,7 @@ $nl
$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." "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 $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." "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."
{ $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."
$nl $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." "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 } ; { $subsection redefine-error } ;

View File

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

34
core/dlists/dlists-docs.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax kernel ; USING: help.markup help.syntax kernel quotations ;
IN: dlists IN: dlists
ARTICLE: "dlists" "Doubly-linked lists" ARTICLE: "dlists" "Doubly-linked lists"
@ -13,23 +13,31 @@ $nl
{ $subsection dlist? } { $subsection dlist? }
"Constructing a dlist:" "Constructing a dlist:"
{ $subsection <dlist> } { $subsection <dlist> }
"Double-ended queue protocol:" "Working with the front of the list:"
{ $subsection dlist-empty? }
{ $subsection push-front } { $subsection push-front }
{ $subsection push-front* }
{ $subsection peek-front }
{ $subsection pop-front } { $subsection pop-front }
{ $subsection pop-front* } { $subsection pop-front* }
"Working with the back of the list:"
{ $subsection push-back } { $subsection push-back }
{ $subsection push-back* }
{ $subsection peek-back }
{ $subsection pop-back } { $subsection pop-back }
{ $subsection pop-back* } { $subsection pop-back* }
"Finding out the length:" "Finding out the length:"
{ $subsection dlist-empty? }
{ $subsection dlist-length } { $subsection dlist-length }
"Iterating over elements:" "Iterating over elements:"
{ $subsection dlist-each } { $subsection dlist-each }
{ $subsection dlist-find } { $subsection dlist-find }
{ $subsection dlist-contains? } { $subsection dlist-contains? }
"Deleting a node matching a predicate:" "Deleting a node:"
{ $subsection delete-node* }
{ $subsection delete-node } { $subsection delete-node }
{ $subsection dlist-delete }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
{ $subsection delete-node-if }
"Consuming all nodes:" "Consuming all nodes:"
{ $subsection dlist-slurp } ; { $subsection dlist-slurp } ;
@ -77,7 +85,7 @@ HELP: pop-back*
{ $see-also push-front push-back pop-front pop-front* pop-back } ; { $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find HELP: dlist-find
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
{ $notes "Returns a boolean to allow dlists to store " { $link f } "." { $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl $nl
@ -85,20 +93,20 @@ HELP: dlist-find
} ; } ;
HELP: dlist-contains? HELP: dlist-contains?
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } } { $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." } { $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ; { $notes "This operation is O(n)." } ;
HELP: delete-node* HELP: delete-node-if*
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." } { $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
{ $notes "This operation is O(n)." } ; { $notes "This operation is O(n)." } ;
HELP: delete-node HELP: delete-node-if
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } { $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." } { $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
{ $notes "This operation is O(n)." } ; { $notes "This operation is O(n)." } ;
HELP: dlist-each HELP: dlist-each
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } } { $values { "quot" quotation } { "dlist" { $link dlist } } }
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ; { $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

View File

@ -49,14 +49,14 @@ IN: temporary
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test [ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test [ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node ] unit-test [ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test [ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test [ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test [ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test [ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test [ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test [ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test [ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
[ 0 ] [ <dlist> dlist-length ] unit-test [ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test [ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test

View File

@ -63,12 +63,22 @@ C: <dlist-node> dlist-node
>r dlist-front r> (dlist-each-node) ; inline >r dlist-front r> (dlist-each-node) ; inline
PRIVATE> PRIVATE>
: push-front ( obj dlist -- ) : push-front* ( obj dlist -- dlist-node )
[ dlist-front f swap <dlist-node> dup set-next-prev ] keep [ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
[ set-dlist-front ] keep [ set-dlist-front ] keep
[ set-back-to-front ] keep [ set-back-to-front ] keep
inc-length ; inc-length ;
: push-front ( obj dlist -- )
push-front* drop ;
: push-back* ( obj dlist -- dlist-node )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
[ set-dlist-back ] 2keep
[ set-front-to-back ] keep
inc-length ;
: push-back ( obj dlist -- ) : push-back ( obj dlist -- )
[ dlist-back f <dlist-node> ] keep [ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep [ dlist-back set-next-when ] 2keep
@ -76,6 +86,9 @@ PRIVATE>
[ set-front-to-back ] keep [ set-front-to-back ] keep
inc-length ; inc-length ;
: peek-front ( dlist -- obj )
dlist-front dlist-node-obj ;
: pop-front ( dlist -- obj ) : pop-front ( dlist -- obj )
dup dlist-front [ dup dlist-front [
dup dlist-node-next dup dlist-node-next
@ -87,6 +100,9 @@ PRIVATE>
: pop-front* ( dlist -- ) pop-front drop ; : pop-front* ( dlist -- ) pop-front drop ;
: peek-back ( dlist -- obj )
dlist-back dlist-node-obj ;
: pop-back ( dlist -- obj ) : pop-back ( dlist -- obj )
dup dlist-back [ dup dlist-back [
dup dlist-node-prev dup dlist-node-prev
@ -108,25 +124,30 @@ PRIVATE>
dup dlist-node-prev over dlist-node-next set-prev-when dup dlist-node-prev over dlist-node-next set-prev-when
dup dlist-node-next swap dlist-node-prev set-next-when ; dup dlist-node-next swap dlist-node-prev set-next-when ;
: (delete-node) ( dlist dlist-node -- ) : delete-node ( dlist dlist-node -- )
{ {
{ [ over dlist-front over eq? ] [ drop pop-front* ] } { [ over dlist-front over eq? ] [ drop pop-front* ] }
{ [ over dlist-back over eq? ] [ drop pop-back* ] } { [ over dlist-back over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] } { [ t ] [ unlink-node dec-length ] }
} cond ; } cond ;
: delete-node* ( quot dlist -- obj/f ? ) : delete-node-if* ( quot dlist -- obj/f ? )
tuck dlist-find-node [ tuck dlist-find-node [
[ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if* [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
] [ ] [
2drop f f 2drop f f
] if ; inline ] if ; inline
: delete-node ( quot dlist -- obj/f ) : delete-node-if ( quot dlist -- obj/f )
delete-node* drop ; inline delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f ) : dlist-delete ( obj dlist -- obj/f )
>r [ eq? ] curry r> delete-node ; >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-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline [ dlist-node-obj ] swap compose dlist-each-node ; inline

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

View File

@ -32,7 +32,7 @@ HELP: <float-array> ( n initial -- float-array )
HELP: >float-array HELP: >float-array
{ $values { "seq" "a sequence" } { "float-array" 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." } ; { $errors "Throws an error if the sequence contains elements other than real numbers." } ;
HELP: 1float-array HELP: 1float-array

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

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private alien sequences USING: kernel kernel.private alien.accessors sequences
sequences.private math math.private ; sequences.private math math.private ;
IN: float-arrays IN: float-arrays
@ -33,8 +33,6 @@ M: float-array resize
resize-float-array ; resize-float-array ;
INSTANCE: float-array sequence INSTANCE: float-array sequence
INSTANCE: float-array simple-c-ptr
INSTANCE: float-array c-ptr
: 1float-array ( x -- array ) 1 swap <float-array> ; flushable : 1float-array ( x -- array ) 1 swap <float-array> ; flushable

View File

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

View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax generic.math generic.standard USING: help.markup help.syntax generic.math generic.standard
words classes definitions kernel alien combinators sequences words classes definitions kernel alien combinators sequences
math ; math quotations ;
IN: generic IN: generic
ARTICLE: "method-order" "Method precedence" 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." } { $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
$low-level-note ; $low-level-note ;
HELP: init-methods
{ $values { "word" word } }
{ $description "Prepare to define a generic word." } ;
HELP: define-generic HELP: define-generic
{ $values { "word" word } { "combination" "a method combination" } } { $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." } { $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." } { $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." } ; { $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> HELP: <method>
{ $values { "def" "a quotation" } { "method" "a new method definition" } } { $values { "def" "a quotation" } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ; { $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 HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } { $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 } "." } ; { $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 ; $low-level-note ;
HELP: define-method 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: } "." } ; { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
HELP: implementors HELP: implementors

View File

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private definitions kernel.private classes classes.private
quotations arrays vocabs ; quotations arrays vocabs effects ;
IN: generic IN: generic
PREDICATE: word generic "combination" word-prop >boolean ; ! Method combination protocol
M: generic definer drop f f ;
M: generic definition drop f ;
GENERIC: perform-combination ( word combination -- quot ) GENERIC: perform-combination ( word combination -- quot )
M: object perform-combination M: object perform-combination
@ -22,27 +17,22 @@ M: object perform-combination
#! the method will throw an error. We don't want that. #! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ; 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 -- ) : make-generic ( word -- )
dup dup "combination" word-prop perform-combination define ; dup dup "combination" word-prop perform-combination define ;
: init-methods ( word -- ) TUPLE: method word def specializer generic loc ;
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 ;
: method ( class generic -- method/f ) : method ( class generic -- method/f )
"methods" word-prop at ; "methods" word-prop at ;
@ -53,12 +43,10 @@ PREDICATE: pair method-spec
: order ( generic -- seq ) : order ( generic -- seq )
"methods" word-prop keys sort-classes ; "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 -- 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 ; TUPLE: check-method class generic ;
@ -71,22 +59,52 @@ TUPLE: check-method class generic ;
swap [ "methods" word-prop swap call ] keep make-generic ; swap [ "methods" word-prop swap call ] keep make-generic ;
inline inline
: define-method ( method class generic -- ) : method-word-name ( class word -- string )
>r bootstrap-word r> check-method 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 ; [ 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 ! Definition protocol
M: method-spec where 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 set-where first2 method set-method-loc ;
M: method-spec definer drop \ M: \ ; ; 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 -- ) : 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 ; M: method-spec forget* first2 forget-method ;
@ -107,5 +125,30 @@ M: class forget* ( class -- )
dup uncache-class dup uncache-class
forget-word ; forget-word ;
M: class update-methods ( class -- ) M: assoc update-methods ( assoc -- )
class-usages implementors* [ make-generic ] each ; 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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators math namespaces sequences words quotations layouts combinators
combinators.private classes definitions ; sequences.private classes definitions ;
IN: generic.math IN: generic.math
PREDICATE: class math-class ( object -- ? ) PREDICATE: class math-class ( object -- ? )
@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ;
: no-math-method ( left right generic -- * ) : no-math-method ( left right generic -- * )
\ no-math-method construct-boa throw ; \ no-math-method construct-boa throw ;
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;
: applicable-method ( generic class -- quot ) : applicable-method ( generic class -- quot )
over method method-def over method
[ ] [ [ no-math-method ] curry [ ] like ] ?if ; [ method-word word-def ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot ) : object-method ( generic -- quot )
object bootstrap-word applicable-method ; object bootstrap-word applicable-method ;
@ -57,7 +61,7 @@ TUPLE: no-math-method left right generic ;
: math-vtable* ( picker max quot -- quot ) : math-vtable* ( picker max quot -- quot )
[ [
rot , \ tag , rot , \ tag ,
[ >r [ type>class ] map r> map % ] { } make , [ >r [ bootstrap-type>class ] map r> map % ] { } make ,
\ dispatch , \ dispatch ,
] [ ] make ; inline ] [ ] make ; inline
@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ;
TUPLE: math-combination ; TUPLE: math-combination ;
M: math-combination make-default-method
drop default-math-method ;
M: math-combination perform-combination M: math-combination perform-combination
drop drop
\ over [ \ over [

View File

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

4
core/growable/growable-docs.factor Normal file → Executable file
View File

@ -21,7 +21,7 @@ HELP: set-fill
{ $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } } { $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } }
{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." } { $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." }
{ $side-effects "seq" } { $side-effects "seq" }
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; { $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
HELP: underlying HELP: underlying
{ $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } } { $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } }
@ -30,7 +30,7 @@ HELP: underlying
HELP: set-underlying HELP: set-underlying
{ $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } } { $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } }
{ $contract "Modifies the underlying storage of a resizable sequence." } { $contract "Modifies the underlying storage of a resizable sequence." }
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; { $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
HELP: capacity HELP: capacity
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } } { $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -73,6 +73,12 @@ $nl
{ $subsection infer-quot-value } { $subsection infer-quot-value }
"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ; "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" 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." "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 $nl
@ -80,14 +86,15 @@ $nl
{ $subsection infer. } { $subsection infer. }
"Instead of printing the inferred information, it can be returned as objects on the stack:" "Instead of printing the inferred information, it can be returned as objects on the stack:"
{ $subsection infer } { $subsection infer }
"The dataflow graph used by " { $link "compiler" } " can be obtained:" "Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
{ $subsection dataflow } $nl
"The following articles describe the implementation of the stack effect inference algorithm:" "The following articles describe the implementation of the stack effect inference algorithm:"
{ $subsection "inference-simple" } { $subsection "inference-simple" }
{ $subsection "inference-combinators" } { $subsection "inference-combinators" }
{ $subsection "inference-branches" } { $subsection "inference-branches" }
{ $subsection "inference-recursive" } { $subsection "inference-recursive" }
{ $subsection "inference-limitations" } { $subsection "inference-limitations" }
{ $subsection "dataflow-graphs" }
{ $subsection "compiler-transforms" } ; { $subsection "compiler-transforms" } ;
ABOUT: "inference" ABOUT: "inference"

View File

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: inference.backend inference.state inference.dataflow USING: inference.backend inference.state inference.dataflow
inference.known-words inference.transforms inference.errors inference.known-words inference.transforms inference.errors
sequences prettyprint io effects kernel namespaces quotations kernel io effects namespaces sequences quotations vocabs
words vocabs ; generic words ;
IN: inference IN: inference
GENERIC: infer ( quot -- effect ) GENERIC: infer ( quot -- effect )
@ -28,4 +28,7 @@ M: callable dataflow-with
] with-infer nip ; ] with-infer nip ;
: forget-errors ( -- ) : 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 ;

View File

@ -1,15 +1,16 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays byte-arrays classes USING: alien alien.accessors arrays bit-arrays byte-arrays
combinators.private continuations.private effects float-arrays classes sequences.private continuations.private effects
generic hashtables hashtables.private inference.state float-arrays generic hashtables hashtables.private
inference.backend inference.dataflow io io.backend io.files inference.state inference.backend inference.dataflow io
io.files.private io.streams.c kernel kernel.private math io.backend io.files io.files.private io.streams.c kernel
math.private memory namespaces namespaces.private parser kernel.private math math.private memory namespaces
prettyprint quotations quotations.private sbufs sbufs.private namespaces.private parser prettyprint quotations
sequences sequences.private slots.private strings quotations.private sbufs sbufs.private sequences
strings.private system threads.private tuples tuples.private sequences.private slots.private strings strings.private system
vectors vectors.private words words.private assocs inspector ; threads.private tuples tuples.private vectors vectors.private
words words.private assocs inspector ;
IN: inference.known-words IN: inference.known-words
! Shuffle words ! Shuffle words
@ -413,64 +414,81 @@ t over set-effect-terminated?
\ <displaced-alien> make-flushable \ <displaced-alien> make-flushable
\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop \ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ 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> "inferred-effect" set-word-prop
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop \ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-cell make-flushable
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop \ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-8 make-flushable
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop \ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-8 make-flushable
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop \ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-4 make-flushable
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop \ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-4 make-flushable
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop \ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-signed-2 make-flushable
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop \ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-2 make-flushable
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop \ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-signed-1 make-flushable
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop \ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-1 make-flushable
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop \ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
\ alien-float make-flushable
\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop \ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
\ alien-double make-flushable
\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop \ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
\ alien-cell make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop \ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop \ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
\ alien>char-string make-flushable
\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop \ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
\ string>char-alien make-flushable
\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop \ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
\ alien>u16-string make-flushable
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop \ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
\ string>u16-alien make-flushable
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop \ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
\ alien-address make-flushable \ alien-address make-flushable
@ -480,10 +498,10 @@ t over set-effect-terminated?
\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop \ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
\ char-slot { fixnum object } { fixnum } <effect> "inferred-effect" set-word-prop \ string-nth { fixnum string } { fixnum } <effect> "inferred-effect" set-word-prop
\ char-slot make-flushable \ string-nth make-flushable
\ set-char-slot { fixnum fixnum object } { } <effect> "inferred-effect" set-word-prop \ set-string-nth { fixnum fixnum string } { } <effect> "inferred-effect" set-word-prop
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop \ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
\ resize-array make-flushable \ resize-array make-flushable

View File

@ -1,6 +1,6 @@
IN: temporary IN: temporary
USING: sequences inference.transforms tools.test math kernel USING: sequences inference.transforms tools.test math kernel
quotations tools.test.inference inference ; quotations inference ;
: compose-n-quot <repetition> >quotation ; : compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ; : compose-n compose-n-quot call ;
@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ;
: set-slots-test-2 : set-slots-test-2
{ set-a-tuple-x set-a-tuple-x } set-slots ; { 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

View File

@ -54,6 +54,10 @@ M: pair (bitfield-quot) ( spec -- quot )
\ bitfield [ bitfield-quot ] 1 define-transform \ bitfield [ bitfield-quot ] 1 define-transform
\ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform
! Tuple operations ! Tuple operations
: [get-slots] ( slots -- quot ) : [get-slots] ( slots -- quot )
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ; [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;

4
core/io/binary/binary-tests.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
USING: io.binary tools.test ; USING: io.binary tools.test ;
IN: temporary IN: temporary
[ "\0\0\u0004\u00d2" ] [ 1234 4 >be ] unit-test [ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
[ "\u00d2\u0004\0\0" ] [ 1234 4 >le ] unit-test [ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test
[ 1234 ] [ 1234 4 >be be> ] unit-test [ 1234 ] [ 1234 4 >be be> ] unit-test
[ 1234 ] [ 1234 4 >le le> ] unit-test [ 1234 ] [ 1234 4 >le le> ] unit-test

View File

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

View File

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

9
core/io/encodings/encodings.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg. ! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors USING: math kernel sequences sbufs vectors
namespaces ; namespaces unicode.syntax ;
IN: io.encodings IN: io.encodings
TUPLE: encode-error ; TUPLE: encode-error ;
@ -17,9 +17,12 @@ SYMBOL: begin
: decoded ( buf ch -- buf ch state ) : decoded ( buf ch -- buf ch state )
over push 0 begin ; over push 0 begin ;
: push-replacement ( buf -- buf ch state )
UNICHAR: replacement-character decoded ;
: finish-decoding ( buf ch state -- str ) : finish-decoding ( buf ch state -- str )
begin eq? [ decode-error ] unless drop { } like ; begin eq? [ decode-error ] unless drop "" like ;
: decode ( seq quot -- str ) : decode ( seq quot -- str )
>r [ length <vector> 0 begin ] keep r> each >r [ length <sbuf> 0 begin ] keep r> each
finish-decoding ; inline finish-decoding ; inline

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." } { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
{ $errors "Throws an error if the file cannot be opened for writing." } ; { $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: 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" } } { $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." } { $description "Outputs the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; { $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" } } { $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." } { $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." } ; { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;

7
core/io/files/files-tests.factor Normal file → Executable file
View File

@ -1,8 +1,9 @@
IN: temporary IN: temporary
USING: tools.test io.files io threads kernel ; USING: tools.test io.files io threads kernel continuations ;
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "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> [ "test-foo.txt" resource-path <file-writer> [
@ -41,7 +42,7 @@ USING: tools.test io.files io threads kernel ;
[ ] [ "test-blah" resource-path make-directory ] unit-test [ ] [ "test-blah" resource-path make-directory ] unit-test
[ ] [ [ ] [
"test-blah/fooz" resource-path <file-writer> stream-close "test-blah/fooz" resource-path <file-writer> dispose
] unit-test ] unit-test
[ t ] [ [ t ] [

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

View File

@ -1,12 +1,12 @@
USING: help.markup help.syntax quotations hashtables kernel USING: help.markup help.syntax quotations hashtables kernel
classes strings ; classes strings continuations ;
IN: io IN: io
ARTICLE: "stream-protocol" "Stream protocol" ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional." "The stream protocol consists of a large number of generic words, many of which are optional."
$nl $nl
"A word required to be implemented for all streams:" "All streams must implement the " { $link dispose } " word in addition to the stream protocol."
{ $subsection stream-close } $nl
"Three words are required for input streams:" "Three words are required for input streams:"
{ $subsection stream-read1 } { $subsection stream-read1 }
{ $subsection stream-read } { $subsection stream-read }
@ -22,8 +22,7 @@ $nl
{ $subsection make-block-stream } { $subsection make-block-stream }
{ $subsection make-cell-stream } { $subsection make-cell-stream }
{ $subsection stream-write-table } { $subsection stream-write-table }
"Optional word for network streams:" { $see-also "io.timeouts" } ;
{ $subsection set-timeout } ;
ARTICLE: "stdio" "The default stream" ARTICLE: "stdio" "The default stream"
"Various words take an implicit stream parameter from a variable to reduce stack shuffling." "Various words take an implicit stream parameter from a variable to reduce stack shuffling."
@ -73,17 +72,6 @@ ARTICLE: "streams" "Streams"
ABOUT: "streams" ABOUT: "streams"
HELP: stream-close
{ $values { "stream" "a stream" } }
{ $contract "Closes the stream. This releases any external resources associated with the stream, such as file handles and network connections. No further operations can be performed on the stream after this call." }
{ $notes "You must close streams after you are finished working with them. A convenient way to automate this is by using the " { $link with-stream } " word." }
$io-error ;
HELP: set-timeout
{ $values { "n" "an integer" } { "stream" "a stream" } }
{ $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." }
$io-error ;
HELP: stream-readln HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } } { $values { "stream" "an input stream" } { "str" string } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." } { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }

View File

@ -4,8 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.styles sbufs ; continuations assocs io.styles sbufs ;
IN: io IN: io
GENERIC: stream-close ( stream -- )
GENERIC: set-timeout ( n stream -- )
GENERIC: stream-readln ( stream -- str ) GENERIC: stream-readln ( stream -- str )
GENERIC: stream-read1 ( stream -- ch/f ) GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f ) GENERIC: stream-read ( n stream -- str/f )
@ -29,7 +27,7 @@ GENERIC: stream-write-table ( table-cells style stream -- )
[ over stream-write (stream-copy) ] [ 2drop ] if* ; [ over stream-write (stream-copy) ] [ 2drop ] if* ;
: stream-copy ( in out -- ) : stream-copy ( in out -- )
[ 2dup (stream-copy) ] [ stream-close stream-close ] [ ] [ 2dup (stream-copy) ] [ dispose dispose ] [ ]
cleanup ; cleanup ;
! Default stream ! Default stream
@ -54,9 +52,7 @@ SYMBOL: stderr
stdio swap with-variable ; inline stdio swap with-variable ; inline
: with-stream ( stream quot -- ) : with-stream ( stream quot -- )
swap [ [ with-stream* ] curry with-disposal ; inline
[ stdio get stream-close ] [ ] cleanup
] with-stream* ; inline
: tabular-output ( style quot -- ) : tabular-output ( style quot -- )
swap >r { } make r> stdio get stream-write-table ; inline swap >r { } make r> stdio get stream-write-table ; inline

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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io USING: kernel kernel.private namespaces io
strings sequences math generic threads.private classes strings sequences math generic threads.private classes
io.backend io.streams.lines io.streams.plain io.streams.duplex io.backend io.streams.lines io.streams.plain io.streams.duplex
io.files ; io.files continuations ;
IN: io.streams.c IN: io.streams.c
TUPLE: c-writer handle ; TUPLE: c-writer handle ;
@ -19,7 +19,7 @@ M: c-writer stream-write
M: c-writer stream-flush M: c-writer stream-flush
c-writer-handle fflush ; c-writer-handle fflush ;
M: c-writer stream-close M: c-writer dispose
c-writer-handle fclose ; c-writer-handle fclose ;
TUPLE: c-reader handle ; TUPLE: c-reader handle ;
@ -46,7 +46,7 @@ M: c-reader stream-read-until
[ swap read-until-loop ] "" make swap [ swap read-until-loop ] "" make swap
over empty? over not and [ 2drop f f ] when ; over empty? over not and [ 2drop f f ] when ;
M: c-reader stream-close M: c-reader dispose
c-reader-handle fclose ; c-reader-handle fclose ;
: <duplex-c-stream> ( in out -- stream ) : <duplex-c-stream> ( in out -- stream )
@ -74,3 +74,10 @@ M: object <file-writer>
M: object <file-appender> M: object <file-appender>
"ab" fopen <c-writer> <plain-writer> ; "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-docs.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io ; USING: help.markup help.syntax io continuations ;
IN: io.streams.duplex IN: io.streams.duplex
ARTICLE: "io.streams.duplex" "Duplex streams" ARTICLE: "io.streams.duplex" "Duplex streams"
@ -19,4 +19,4 @@ HELP: <duplex-stream>
HELP: check-closed HELP: check-closed
{ $values { "stream" "a duplex stream" } } { $values { "stream" "a duplex stream" } }
{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." } { $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link stream-close } "." } ; { $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;

10
core/io/streams/duplex/duplex-tests.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ TUPLE: closing-stream closed? ;
: <closing-stream> closing-stream construct-empty ; : <closing-stream> closing-stream construct-empty ;
M: closing-stream stream-close M: closing-stream dispose
dup closing-stream-closed? [ dup closing-stream-closed? [
"Closing twice!" throw "Closing twice!" throw
] [ ] [
@ -17,24 +17,24 @@ TUPLE: unclosable-stream ;
: <unclosable-stream> unclosable-stream construct-empty ; : <unclosable-stream> unclosable-stream construct-empty ;
M: unclosable-stream stream-close M: unclosable-stream dispose
"Can't close me!" throw ; "Can't close me!" throw ;
[ ] [ [ ] [
<closing-stream> <closing-stream> <duplex-stream> <closing-stream> <closing-stream> <duplex-stream>
dup stream-close stream-close dup dispose dispose
] unit-test ] unit-test
[ t ] [ [ t ] [
<unclosable-stream> <closing-stream> [ <unclosable-stream> <closing-stream> [
<duplex-stream> <duplex-stream>
[ dup stream-close ] catch 2drop [ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed? ] keep closing-stream-closed?
] unit-test ] unit-test
[ t ] [ [ t ] [
<closing-stream> [ <unclosable-stream> <closing-stream> [ <unclosable-stream>
<duplex-stream> <duplex-stream>
[ dup stream-close ] catch 2drop [ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed? ] keep closing-stream-closed?
] unit-test ] unit-test

11
core/io/streams/duplex/duplex.factor Normal file → Executable file
View File

@ -65,17 +65,12 @@ M: duplex-stream make-cell-stream
M: duplex-stream stream-write-table M: duplex-stream stream-write-table
duplex-stream-out+ stream-write-table ; duplex-stream-out+ stream-write-table ;
M: duplex-stream stream-close M: duplex-stream dispose
#! The output stream is closed first, in case both streams #! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output #! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd. #! buffer needs to be flushed before we close the fd.
dup duplex-stream-closed? [ dup duplex-stream-closed? [
t over set-duplex-stream-closed? t over set-duplex-stream-closed?
[ dup duplex-stream-out stream-close ] [ dup duplex-stream-out dispose ]
[ dup duplex-stream-in stream-close ] [ ] cleanup [ dup duplex-stream-in dispose ] [ ] cleanup
] unless drop ; ] unless drop ;
M: duplex-stream set-timeout
2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;

8
core/io/streams/nested/nested.factor Normal file → Executable file
View File

@ -1,14 +1,14 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.nested IN: io.streams.nested
USING: arrays generic assocs kernel namespaces strings USING: arrays generic assocs kernel namespaces strings
quotations io ; quotations io continuations ;
TUPLE: ignore-close-stream ; TUPLE: ignore-close-stream ;
: <ignore-close-stream> ignore-close-stream construct-delegate ; : <ignore-close-stream> ignore-close-stream construct-delegate ;
M: ignore-close-stream stream-close drop ; M: ignore-close-stream dispose drop ;
TUPLE: style-stream style ; TUPLE: style-stream style ;
@ -44,4 +44,4 @@ TUPLE: block-stream ;
: <block-stream> block-stream construct-delegate ; : <block-stream> block-stream construct-delegate ;
M: block-stream stream-close drop ; M: block-stream dispose drop ;

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