Merge git://factorcode.org/git/factor
commit
bea4848232
30
Makefile
30
Makefile
|
@ -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 $@ $<
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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?
|
||||||
|
|
||||||
|
|
|
@ -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." }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 [
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
|
||||||
|
|
|
@ -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" }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
{
|
{
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
|
|
@ -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 )
|
||||||
[
|
[
|
||||||
|
|
|
@ -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 - ;
|
||||||
|
|
|
@ -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." } ;
|
||||||
|
|
|
@ -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 ] [
|
||||||
|
|
|
@ -1,30 +0,0 @@
|
||||||
IN: temporary
|
|
||||||
USING: compiler generic tools.test math kernel words arrays
|
|
||||||
sequences quotations ;
|
|
||||||
|
|
||||||
GENERIC: single-combination-test
|
|
||||||
|
|
||||||
M: object single-combination-test drop ;
|
|
||||||
M: f single-combination-test nip ;
|
|
||||||
M: array single-combination-test drop ;
|
|
||||||
M: integer single-combination-test drop ;
|
|
||||||
|
|
||||||
[ 2 3 ] [ 2 3 t single-combination-test ] unit-test
|
|
||||||
[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
|
|
||||||
[ 2 f ] [ 2 3 f single-combination-test ] unit-test
|
|
||||||
|
|
||||||
DEFER: single-combination-test-2
|
|
||||||
|
|
||||||
: single-combination-test-4
|
|
||||||
dup [ single-combination-test-2 ] when ;
|
|
||||||
|
|
||||||
: single-combination-test-3
|
|
||||||
drop 3 ;
|
|
||||||
|
|
||||||
GENERIC: single-combination-test-2
|
|
||||||
M: object single-combination-test-2 single-combination-test-3 ;
|
|
||||||
M: f single-combination-test-2 single-combination-test-4 ;
|
|
||||||
|
|
||||||
[ 3 ] [ t single-combination-test-2 ] unit-test
|
|
||||||
[ 3 ] [ 3 single-combination-test-2 ] unit-test
|
|
||||||
[ f ] [ f single-combination-test-2 ] unit-test
|
|
|
@ -1,131 +0,0 @@
|
||||||
IN: temporary
|
|
||||||
USING: alien strings compiler tools.test math kernel words
|
|
||||||
math.private combinators ;
|
|
||||||
|
|
||||||
: dummy-if-1 t [ ] [ ] if ;
|
|
||||||
|
|
||||||
[ ] [ dummy-if-1 ] unit-test
|
|
||||||
|
|
||||||
: dummy-if-2 f [ ] [ ] if ;
|
|
||||||
|
|
||||||
[ ] [ dummy-if-2 ] unit-test
|
|
||||||
|
|
||||||
: dummy-if-3 t [ 1 ] [ 2 ] if ;
|
|
||||||
|
|
||||||
[ 1 ] [ dummy-if-3 ] unit-test
|
|
||||||
|
|
||||||
: dummy-if-4 f [ 1 ] [ 2 ] if ;
|
|
||||||
|
|
||||||
[ 2 ] [ dummy-if-4 ] unit-test
|
|
||||||
|
|
||||||
: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
|
|
||||||
|
|
||||||
[ 1 ] [ dummy-if-5 ] unit-test
|
|
||||||
|
|
||||||
: dummy-if-6
|
|
||||||
dup 1 fixnum<= [
|
|
||||||
drop 1
|
|
||||||
] [
|
|
||||||
1 fixnum- dup 1 fixnum- fixnum+
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
[ 17 ] [ 10 dummy-if-6 ] unit-test
|
|
||||||
|
|
||||||
: dead-code-rec
|
|
||||||
t [
|
|
||||||
3.2
|
|
||||||
] [
|
|
||||||
dead-code-rec
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
[ 3.2 ] [ dead-code-rec ] unit-test
|
|
||||||
|
|
||||||
: one-rec [ f one-rec ] [ "hi" ] if ;
|
|
||||||
|
|
||||||
[ "hi" ] [ t one-rec ] unit-test
|
|
||||||
|
|
||||||
: after-if-test
|
|
||||||
t [ ] [ ] if 5 ;
|
|
||||||
|
|
||||||
[ 5 ] [ after-if-test ] unit-test
|
|
||||||
|
|
||||||
DEFER: countdown-b
|
|
||||||
|
|
||||||
: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ;
|
|
||||||
: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ;
|
|
||||||
|
|
||||||
[ ] [ 10 countdown-b ] unit-test
|
|
||||||
|
|
||||||
: dummy-when-1 t [ ] when ;
|
|
||||||
|
|
||||||
[ ] [ dummy-when-1 ] unit-test
|
|
||||||
|
|
||||||
: dummy-when-2 f [ ] when ;
|
|
||||||
|
|
||||||
[ ] [ dummy-when-2 ] unit-test
|
|
||||||
|
|
||||||
: dummy-when-3 dup [ dup fixnum* ] when ;
|
|
||||||
|
|
||||||
[ 16 ] [ 4 dummy-when-3 ] unit-test
|
|
||||||
[ f ] [ f dummy-when-3 ] unit-test
|
|
||||||
|
|
||||||
: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
|
|
||||||
|
|
||||||
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
|
|
||||||
[ f t ] [ t f dummy-when-4 ] unit-test
|
|
||||||
|
|
||||||
: dummy-when-5 f [ dup fixnum* ] when ;
|
|
||||||
|
|
||||||
[ f ] [ f dummy-when-5 ] unit-test
|
|
||||||
|
|
||||||
: dummy-unless-1 t [ ] unless ;
|
|
||||||
|
|
||||||
[ ] [ dummy-unless-1 ] unit-test
|
|
||||||
|
|
||||||
: dummy-unless-2 f [ ] unless ;
|
|
||||||
|
|
||||||
[ ] [ dummy-unless-2 ] unit-test
|
|
||||||
|
|
||||||
: dummy-unless-3 dup [ drop 3 ] unless ;
|
|
||||||
|
|
||||||
[ 3 ] [ f dummy-unless-3 ] unit-test
|
|
||||||
[ 4 ] [ 4 dummy-unless-3 ] unit-test
|
|
||||||
|
|
||||||
! Test cond expansion
|
|
||||||
[ "even" ] [
|
|
||||||
[
|
|
||||||
2 {
|
|
||||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
|
||||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
|
||||||
} cond
|
|
||||||
] compile-call
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ "odd" ] [
|
|
||||||
[
|
|
||||||
3 {
|
|
||||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
|
||||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
|
||||||
} cond
|
|
||||||
] compile-call
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ "neither" ] [
|
|
||||||
[
|
|
||||||
3 {
|
|
||||||
{ [ dup string? ] [ drop "string" ] }
|
|
||||||
{ [ dup float? ] [ drop "float" ] }
|
|
||||||
{ [ dup alien? ] [ drop "alien" ] }
|
|
||||||
{ [ t ] [ drop "neither" ] }
|
|
||||||
} cond
|
|
||||||
] compile-call
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ 3 ] [
|
|
||||||
[
|
|
||||||
3 {
|
|
||||||
{ [ dup fixnum? ] [ ] }
|
|
||||||
{ [ t ] [ drop t ] }
|
|
||||||
} cond
|
|
||||||
] compile-call
|
|
||||||
] unit-test
|
|
|
@ -1,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
|
|
|
@ -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
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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!
|
|
@ -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." }
|
||||||
|
|
|
@ -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,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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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" } } }
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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" } }
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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" ;
|
||||||
|
|
||||||
|
|
|
@ -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 } ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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." } ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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> ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 [
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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" } }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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." }
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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." } ;
|
||||||
|
|
|
@ -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 ] [
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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." }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 } "." } ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
|
||||||
|
|
|
@ -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
Loading…
Reference in New Issue