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

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

Conflicts:

	extra/delegate/delegate-tests.factor
	extra/delegate/delegate.factor
db4
Daniel Ehrenberg 2008-04-17 23:20:17 -05:00
parent 4823509dfd 6fb437c6d5
commit 3ac4931969
657 changed files with 11990 additions and 5590 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
README.txt
View File

@ -6,7 +6,6 @@ implementation. It is not an introduction to the language itself.
* Contents * Contents
- Platform support
- Compiling the Factor VM - Compiling the Factor VM
- Libraries needed for compilation - Libraries needed for compilation
- Bootstrapping the Factor image - Bootstrapping the Factor image
@ -19,80 +18,50 @@ implementation. It is not an introduction to the language itself.
- Source organization - Source organization
- Community - Community
* Platform support
Factor supports the following platforms:
Linux/x86
Linux/AMD64
Linux/PowerPC
Linux/ARM
Mac OS X/x86
Mac OS X/PowerPC
FreeBSD/x86
FreeBSD/AMD64
OpenBSD/x86
OpenBSD/AMD64
Solaris/x86
Solaris/AMD64
MS Windows/x86 (XP and above)
MS Windows CE/ARM
Please donate time or hardware if you wish to see Factor running on
other platforms. In particular, we are interested in:
Windows/AMD64
Mac OS X/AMD64
Solaris/UltraSPARC
Linux/MIPS
* Compiling the Factor VM * Compiling the Factor VM
The Factor runtime is written in GNU C99, and is built with GNU make and The Factor runtime is written in GNU C99, and is built with GNU make and
gcc. gcc.
Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc Factor supports various platforms. For an up-to-date list, see
3.3 or earlier. If you are using gcc 4.3, you might get an unusable <http://factorcode.org/getfactor.fhtml>.
Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
command-line arguments for make.
Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of Factor requires gcc 3.4 or later.
targets and build options. Then run 'make' with the appropriate target
for your platform. On x86, Factor /will not/ build using gcc 3.3 or earlier.
If you are using gcc 4.3, you might get an unusable Factor binary unless
you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
arguments for make.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
Compilation will yield an executable named 'factor' on Unix, Compilation will yield an executable named 'factor' on Unix,
'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. 'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
* Libraries needed for compilation * Libraries needed for compilation
For X11 support, you need recent development libraries for libc, Freetype, For X11 support, you need recent development libraries for libc,
X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu), Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
you can use the line (like Ubuntu), you can use the line
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
to grab everything (if you're on a non-debian-derived distro please tell us to grab everything (if you're on a non-debian-derived distro please tell
what the equivalent command is on there and it can be added :) us what the equivalent command is on there and it can be added).
* Bootstrapping the Factor image * Bootstrapping the Factor image
The boot images are no longer included with the Factor distribution
due to size concerns. Instead, download a boot image from:
http://factorcode.org/images/
Once you have compiled the Factor runtime, you must bootstrap the Factor Once you have compiled the Factor runtime, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture. system using the image that corresponds to your CPU architecture.
Once you download the right image, bootstrap the system with the Boot images can be obtained from <http://factorcode.org/images/latest/>.
Once you download the right image, bootstrap Factor with the
following command line: following command line:
./factor -i=boot.<cpu>.image ./factor -i=boot.<cpu>.image
Or this command for Mac OS X systems:
./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
Bootstrap can take a while, depending on your system. When the process Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between is both CPU and OS-specific, so in general cannot be shared between
@ -122,9 +91,8 @@ The latter keeps the terminal listener running.
* Running Factor on Mac OS X - Cocoa UI * Running Factor on Mac OS X - Cocoa UI
On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the On Mac OS X, a Cocoa UI is available in addition to the terminal
terminal listener. If you are using Mac OS X 10.3, you can only run the listener.
X11 UI, as documented in the next section.
The 'factor' executable runs the terminal listener: The 'factor' executable runs the terminal listener:
@ -136,17 +104,16 @@ contains factor.image and the library sources.
* Running Factor on Mac OS X - X11 UI * Running Factor on Mac OS X - X11 UI
The X11 UI is available on Mac OS X, however its use is not recommended The X11 UI is also available on Mac OS X, however its use is not
since it does not integrate with the host OS. However, if you are recommended since it does not integrate with the host OS.
running Mac OS X 10.3, it is your only choice.
When compiling Factor, pass the X11=1 parameter: When compiling Factor, pass the X11=1 parameter:
make macosx-ppc X11=1 make X11=1
Then bootstrap with the following switches: Then bootstrap with the following switches:
./factor -i=boot.ppc.image -ui-backend=x11 ./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI. Now if $DISPLAY is set, running ./factor will start the UI.
@ -155,40 +122,36 @@ Now if $DISPLAY is set, running ./factor will start the UI.
If you did not download the binary package, you can bootstrap Factor in If you did not download the binary package, you can bootstrap Factor in
the command prompt: the command prompt:
factor-nt.exe -i=boot.x86.32.image factor.exe -i=boot.<cpu>.image
Once bootstrapped, double-clicking factor.exe starts the Factor UI. Once bootstrapped, double-clicking factor.exe starts the Factor UI.
To run the listener in the command prompt: To run the listener in the command prompt:
factor-nt.exe -run=listener factor.exe -run=listener
* The Factor FAQ * The Factor FAQ
The Factor FAQ lives online at http://factorcode.org/faq.fhtml The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
* Command line usage * Command line usage
The Factor VM supports a number of command line switches. To read Factor supports a number of command line switches. To read command line
command line usage documentation, either enter the following in the UI usage documentation, enter the following in the UI listener:
listener:
"command-line" about "command-line" about
* Source organization * Source organization
The following two directories are managed by the module system; consult The Factor source tree is organized as follows:
the documentation for details:
build-support/ - scripts used for compiling Factor
core/ - Factor core library and compiler core/ - Factor core library and compiler
extra/ - more libraries extra/ - more libraries
The following directories contain additional files:
misc/ - editor modes, icons, etc
vm/ - sources for the Factor runtime, written in C
fonts/ - TrueType fonts used by UI fonts/ - TrueType fonts used by UI
misc/ - editor modes, icons, etc
unmaintained/ - unmaintained contributions, please help! unmaintained/ - unmaintained contributions, please help!
vm/ - sources for the Factor VM, written in C
* Community * Community

1
build-support/factor.sh
View File

@ -190,6 +190,7 @@ find_architecture() {
i386) ARCH=x86;; i386) ARCH=x86;;
i686) ARCH=x86;; i686) ARCH=x86;;
amd64) ARCH=x86;; amd64) ARCH=x86;;
ppc64) ARCH=ppc;;
*86) ARCH=x86;; *86) ARCH=x86;;
*86_64) ARCH=x86;; *86_64) ARCH=x86;;
"Power Macintosh") ARCH=ppc;; "Power Macintosh") ARCH=ppc;;

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

@ -78,7 +78,7 @@ $nl
"<< \"freetype\" {" "<< \"freetype\" {"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ t ] [ drop ] }" " [ drop ]"
"} cond >>" "} cond >>"
} }
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ; "Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
@ -204,7 +204,7 @@ ARTICLE: "alien-callback-gc" "Callbacks and code GC"
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body." "A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
$nl $nl
"This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:" "This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:"
{ $code "USE: alien callbacks get clear-hash code-gc" } { $code "USE: alien callbacks get clear-hash gc" }
"This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ; "This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ;
ARTICLE: "alien-callback" "Calling Factor from C" ARTICLE: "alien-callback" "Calling Factor from C"

8
core/alien/alien.factor
View File

@ -54,7 +54,7 @@ TUPLE: library path abi dll ;
: library ( name -- library ) libraries get at ; : library ( name -- library ) libraries get at ;
: <library> ( path abi -- library ) : <library> ( path abi -- library )
over dup [ dlopen ] when \ library construct-boa ; over dup [ dlopen ] when \ library boa ;
: load-library ( name -- dll ) : load-library ( name -- dll )
library dup [ library-dll ] when ; library dup [ library-dll ] when ;
@ -62,22 +62,16 @@ TUPLE: library path abi dll ;
: add-library ( name path abi -- ) : add-library ( name path abi -- )
<library> swap libraries get set-at ; <library> swap libraries get set-at ;
TUPLE: alien-callback return parameters abi quot xt ;
ERROR: alien-callback-error ; ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien ) : alien-callback ( return parameters abi quot -- alien )
alien-callback-error ; alien-callback-error ;
TUPLE: alien-indirect return parameters abi ;
ERROR: alien-indirect-error ; ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- ) : alien-indirect ( ... funcptr return parameters abi -- )
alien-indirect-error ; alien-indirect-error ;
TUPLE: alien-invoke library function return parameters abi ;
ERROR: alien-invoke-error library symbol ; ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... ) : alien-invoke ( ... return library function parameters -- ... )

2
core/alien/arrays/arrays.factor
View File

@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ; M: array stack-size drop "void*" stack-size ;
M: value-type c-type-reg-class drop T{ int-regs } ; M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-prep drop f ; M: value-type c-type-prep drop f ;

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

@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays
generator.registers assocs kernel kernel.private libc math generator.registers assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary ; layouts system compiler.units io.files io.encodings.binary
accessors combinators ;
IN: alien.c-types IN: alien.c-types
DEFER: <int> DEFER: <int>
@ -17,8 +18,12 @@ boxer prep unboxer
getter setter getter setter
reg-class size align stack-align? ; reg-class size align stack-align? ;
: new-c-type ( class -- type )
new
int-regs >>reg-class ;
: <c-type> ( -- type ) : <c-type> ( -- type )
T{ int-regs } { set-c-type-reg-class } \ c-type construct ; \ c-type new-c-type ;
SYMBOL: c-types SYMBOL: c-types
@ -181,10 +186,10 @@ DEFER: >c-ushort-array
: define-c-type ( type name vocab -- ) : define-c-type ( type name vocab -- )
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ; >r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
TUPLE: long-long-type ; TUPLE: long-long-type < c-type ;
: <long-long-type> ( type -- type ) : <long-long-type> ( -- type )
long-long-type construct-delegate ; long-long-type new-c-type ;
M: long-long-type unbox-parameter ( n type -- ) M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ; c-type-unboxer %unbox-long-long ;
@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- )
: define-from-array ( type vocab -- ) : define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define ; [ from-array-word ] 2keep c-array>quot define ;
: <primitive-type> ( getter setter width boxer unboxer -- type )
<c-type>
[ set-c-type-unboxer ] keep
[ set-c-type-boxer ] keep
[ set-c-type-size ] 2keep
[ set-c-type-align ] keep
[ set-c-type-setter ] keep
[ set-c-type-getter ] keep ;
: define-primitive-type ( type name -- ) : define-primitive-type ( type name -- )
"alien.c-types" "alien.c-types"
[ define-c-type ] 2keep {
[ define-deref ] 2keep [ define-c-type ]
[ define-to-array ] 2keep [ define-deref ]
[ define-from-array ] 2keep [ define-to-array ]
define-out ; [ define-from-array ]
[ define-out ]
} 2cleave ;
: expand-constants ( c-type -- c-type' ) : expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around #! We use word-def call instead of execute to get around
@ -264,130 +262,157 @@ M: long-long-type box-return ( type -- )
binary file-contents dup malloc-byte-array swap length ; binary file-contents dup malloc-byte-array swap length ;
[ [
[ alien-cell ] <c-type>
[ set-alien-cell ] [ alien-cell ] >>getter
bootstrap-cell [ set-alien-cell ] >>setter
"box_alien" bootstrap-cell >>size
"alien_offset" <primitive-type> bootstrap-cell >>align
"box_alien" >>boxer
"alien_offset" >>unboxer
"void*" define-primitive-type "void*" define-primitive-type
[ alien-signed-8 ] <long-long-type>
[ set-alien-signed-8 ] [ alien-signed-8 ] >>getter
8 [ set-alien-signed-8 ] >>setter
"box_signed_8" 8 >>size
"to_signed_8" <primitive-type> <long-long-type> 8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
"longlong" define-primitive-type "longlong" define-primitive-type
[ alien-unsigned-8 ] <long-long-type>
[ set-alien-unsigned-8 ] [ alien-unsigned-8 ] >>getter
8 [ set-alien-unsigned-8 ] >>setter
"box_unsigned_8" 8 >>size
"to_unsigned_8" <primitive-type> <long-long-type> 8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
"ulonglong" define-primitive-type "ulonglong" define-primitive-type
[ alien-signed-cell ] <c-type>
[ set-alien-signed-cell ] [ alien-signed-cell ] >>getter
bootstrap-cell [ set-alien-signed-cell ] >>setter
"box_signed_cell" bootstrap-cell >>size
"to_fixnum" <primitive-type> bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
"long" define-primitive-type "long" define-primitive-type
[ alien-unsigned-cell ] <c-type>
[ set-alien-unsigned-cell ] [ alien-unsigned-cell ] >>getter
bootstrap-cell [ set-alien-unsigned-cell ] >>setter
"box_unsigned_cell" bootstrap-cell >>size
"to_cell" <primitive-type> bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
"ulong" define-primitive-type "ulong" define-primitive-type
[ alien-signed-4 ] <c-type>
[ set-alien-signed-4 ] [ alien-signed-4 ] >>getter
4 [ set-alien-signed-4 ] >>setter
"box_signed_4" 4 >>size
"to_fixnum" <primitive-type> 4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
"int" define-primitive-type "int" define-primitive-type
[ alien-unsigned-4 ] <c-type>
[ set-alien-unsigned-4 ] [ alien-unsigned-4 ] >>getter
4 [ set-alien-unsigned-4 ] >>setter
"box_unsigned_4" 4 >>size
"to_cell" <primitive-type> 4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
"uint" define-primitive-type "uint" define-primitive-type
[ alien-signed-2 ] <c-type>
[ set-alien-signed-2 ] [ alien-signed-2 ] >>getter
2 [ set-alien-signed-2 ] >>setter
"box_signed_2" 2 >>size
"to_fixnum" <primitive-type> 2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
"short" define-primitive-type "short" define-primitive-type
[ alien-unsigned-2 ] <c-type>
[ set-alien-unsigned-2 ] [ alien-unsigned-2 ] >>getter
2 [ set-alien-unsigned-2 ] >>setter
"box_unsigned_2" 2 >>size
"to_cell" <primitive-type> 2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
"ushort" define-primitive-type "ushort" define-primitive-type
[ alien-signed-1 ] <c-type>
[ set-alien-signed-1 ] [ alien-signed-1 ] >>getter
1 [ set-alien-signed-1 ] >>setter
"box_signed_1" 1 >>size
"to_fixnum" <primitive-type> 1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
"char" define-primitive-type "char" define-primitive-type
[ alien-unsigned-1 ] <c-type>
[ set-alien-unsigned-1 ] [ alien-unsigned-1 ] >>getter
1 [ set-alien-unsigned-1 ] >>setter
"box_unsigned_1" 1 >>size
"to_cell" <primitive-type> 1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
"uchar" define-primitive-type "uchar" define-primitive-type
[ alien-unsigned-4 zero? not ] <c-type>
[ 1 0 ? set-alien-unsigned-4 ] [ alien-unsigned-4 zero? not ] >>getter
4 [ 1 0 ? set-alien-unsigned-4 ] >>setter
"box_boolean" 4 >>size
"to_boolean" <primitive-type> 4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type "bool" define-primitive-type
[ alien-float ] <c-type>
[ >r >r >float r> r> set-alien-float ] [ alien-float ] >>getter
4 [ >r >r >float r> r> set-alien-float ] >>setter
"box_float" 4 >>size
"to_float" <primitive-type> 4 >>align
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
[ >float ] >>prep
"float" define-primitive-type "float" define-primitive-type
T{ float-regs f 4 } "float" c-type set-c-type-reg-class <c-type>
[ >float ] "float" c-type set-c-type-prep [ alien-double ] >>getter
[ >r >r >float r> r> set-alien-double ] >>setter
[ alien-double ] 8 >>size
[ >r >r >float r> r> set-alien-double ] 8 >>align
8 "box_double" >>boxer
"box_double" "to_double" >>unboxer
"to_double" <primitive-type> double-float-regs >>reg-class
[ >float ] >>prep
"double" define-primitive-type "double" define-primitive-type
T{ float-regs f 8 } "double" c-type set-c-type-reg-class <c-type>
[ >float ] "double" c-type set-c-type-prep [ alien-cell alien>char-string ] >>getter
[ set-alien-cell ] >>setter
[ alien-cell alien>char-string ] bootstrap-cell >>size
[ set-alien-cell ] bootstrap-cell >>align
bootstrap-cell "box_char_string" >>boxer
"box_char_string" "alien_offset" >>unboxer
"alien_offset" <primitive-type> [ string>char-alien ] >>prep
"char*" define-primitive-type "char*" define-primitive-type
"char*" "uchar*" typedef "char*" "uchar*" typedef
[ string>char-alien ] "char*" c-type set-c-type-prep <c-type>
[ alien-cell alien>u16-string ] >>getter
[ alien-cell alien>u16-string ] [ set-alien-cell ] >>setter
[ set-alien-cell ] 4 >>size
4 4 >>align
"box_u16_string" "box_u16_string" >>boxer
"alien_offset" <primitive-type> "alien_offset" >>unboxer
[ string>u16-alien ] >>prep
"ushort*" define-primitive-type "ushort*" define-primitive-type
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit ] with-compilation-unit

27
core/alien/compiler/compiler-tests.factor
View File

@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads namespaces.private io io.streams.string memory system threads
tools.test ; tools.test math ;
FUNCTION: void ffi_test_0 ; FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test [ ] [ ffi_test_0 ] unit-test
@ -87,7 +87,7 @@ FUNCTION: tiny ffi_test_17 int x ;
[ -1 indirect-test-1 ] must-fail [ -1 indirect-test-1 ] must-fail
: indirect-test-2 : indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect data-gc ; "int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as { 3 1 } [ indirect-test-2 ] must-infer-as
@ -97,7 +97,7 @@ unit-test
: indirect-test-3 : indirect-test-3
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
data-gc ; gc ;
<< "f-stdcall" f "stdcall" add-library >> << "f-stdcall" f "stdcall" add-library >>
@ -106,13 +106,13 @@ unit-test
: ffi_test_18 ( w x y z -- int ) : ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
alien-invoke data-gc ; alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar ) : ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke data-gc ; alien-invoke gc ;
[ 11 6 -7 ] [ [ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
@ -143,7 +143,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
"void" "void"
f "ffi_test_31" f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke code-gc 3 ; alien-invoke gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test [ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
@ -312,14 +312,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
: callback-4 : callback-4
"void" { } "cdecl" [ "Hello world" write ] alien-callback "void" { } "cdecl" [ "Hello world" write ] alien-callback
data-gc ; gc ;
[ "Hello world" ] [ [ "Hello world" ] [
[ callback-4 callback_test_1 ] with-string-writer [ callback-4 callback_test_1 ] with-string-writer
] unit-test ] unit-test
: callback-5 : callback-5
"void" { } "cdecl" [ data-gc ] alien-callback ; "void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [ [ "testing" ] [
"testing" callback-5 callback_test_1 "testing" callback-5 callback_test_1
@ -354,3 +354,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
] alien-callback ; ] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test [ ] [ callback-8 callback_test_1 ] unit-test
: callback-9
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test

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

@ -9,6 +9,14 @@ kernel.private threads continuations.private libc combinators
compiler.errors continuations layouts accessors ; compiler.errors continuations layouts accessors ;
IN: alien.compiler IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
TUPLE: #alien-callback < #alien-node quot xt ;
TUPLE: #alien-indirect < #alien-node ;
TUPLE: #alien-invoke < #alien-node library function ;
: large-struct? ( ctype -- ? ) : large-struct? ( ctype -- ? )
dup c-struct? [ dup c-struct? [
heap-size struct-small-enough? not heap-size struct-small-enough? not
@ -62,29 +70,36 @@ GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ; M: int-regs reg-size drop cell ;
M: float-regs reg-size float-regs-size ; M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- ) GENERIC: inc-reg-class ( register-class -- )
: (inc-reg-class) M: reg-class inc-reg-class
dup class inc dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
M: int-regs inc-reg-class
(inc-reg-class) ;
M: float-regs inc-reg-class M: float-regs inc-reg-class
dup (inc-reg-class) dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? ) : reg-class-full? ( class -- ? )
dup class get swap param-regs length >= ; [ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class ) : spill-param ( reg-class -- n reg-class )
reg-size stack-params dup get -rot +@ T{ stack-params } ; stack-params get
>r reg-size stack-params +@ r>
stack-params ;
: fastcall-param ( reg-class -- n reg-class ) : fastcall-param ( reg-class -- n reg-class )
[ dup class get swap inc-reg-class ] keep ; [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class ) : alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full? c-type-reg-class dup reg-class-full?
@ -205,7 +220,7 @@ M: no-such-library compiler-error-type
drop +linkage+ ; drop +linkage+ ;
: no-such-library ( name -- ) : no-such-library ( name -- )
\ no-such-library construct-boa \ no-such-library boa
compiling-word get compiler-error ; compiling-word get compiler-error ;
TUPLE: no-such-symbol name ; TUPLE: no-such-symbol name ;
@ -217,7 +232,7 @@ M: no-such-symbol compiler-error-type
drop +linkage+ ; drop +linkage+ ;
: no-such-symbol ( name -- ) : no-such-symbol ( name -- )
\ no-such-symbol construct-boa \ no-such-symbol boa
compiling-word get compiler-error ; compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- ) : check-dlsym ( symbols dll -- )
@ -229,32 +244,32 @@ M: no-such-symbol compiler-error-type
] if ; ] if ;
: alien-invoke-dlsym ( node -- symbols dll ) : alien-invoke-dlsym ( node -- symbols dll )
dup alien-invoke-function dup pick stdcall-mangle 2array dup function>> dup pick stdcall-mangle 2array
swap alien-invoke-library library dup [ library-dll ] when swap library>> library dup [ dll>> ] when
2dup check-dlsym ; 2dup check-dlsym ;
\ alien-invoke [ \ alien-invoke [
! Four literals ! Four literals
4 ensure-values 4 ensure-values
\ alien-invoke empty-node #alien-invoke new
! Compile-time parameters ! Compile-time parameters
pop-parameters over set-alien-invoke-parameters pop-parameters >>parameters
pop-literal nip over set-alien-invoke-function pop-literal nip >>function
pop-literal nip over set-alien-invoke-library pop-literal nip >>library
pop-literal nip over set-alien-invoke-return pop-literal nip >>return
! Quotation which coerces parameters to required types ! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot dup make-prep-quot recursive-state get infer-quot
! Set ABI ! Set ABI
dup alien-invoke-library dup library>>
library [ library-abi ] [ "cdecl" ] if* library [ abi>> ] [ "cdecl" ] if*
over set-alien-invoke-abi >>abi
! Add node to IR ! Add node to IR
dup node, dup node,
! Magic #: consume exactly the number of inputs ! Magic #: consume exactly the number of inputs
0 alien-invoke-stack 0 alien-invoke-stack
] "infer" set-word-prop ] "infer" set-word-prop
M: alien-invoke generate-node M: #alien-invoke generate-node
dup alien-invoke-frame [ dup alien-invoke-frame [
end-basic-block end-basic-block
%prepare-alien-invoke %prepare-alien-invoke
@ -273,11 +288,11 @@ M: alien-indirect-error summary
! Three literals and function pointer ! Three literals and function pointer
4 ensure-values 4 ensure-values
4 reify-curries 4 reify-curries
\ alien-indirect empty-node #alien-indirect new
! Compile-time parameters ! Compile-time parameters
pop-literal nip over set-alien-indirect-abi pop-literal nip >>abi
pop-parameters over set-alien-indirect-parameters pop-parameters >>parameters
pop-literal nip over set-alien-indirect-return pop-literal nip >>return
! Quotation which coerces parameters to required types ! Quotation which coerces parameters to required types
dup make-prep-quot [ dip ] curry recursive-state get infer-quot dup make-prep-quot [ dip ] curry recursive-state get infer-quot
! Add node to IR ! Add node to IR
@ -286,7 +301,7 @@ M: alien-indirect-error summary
1 alien-invoke-stack 1 alien-invoke-stack
] "infer" set-word-prop ] "infer" set-word-prop
M: alien-indirect generate-node M: #alien-indirect generate-node
dup alien-invoke-frame [ dup alien-invoke-frame [
! Flush registers ! Flush registers
end-basic-block end-basic-block
@ -315,17 +330,17 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- ) : callback-bottom ( node -- )
alien-callback-xt [ word-xt drop <alien> ] curry xt>> [ word-xt drop <alien> ] curry
recursive-state get infer-quot ; recursive-state get infer-quot ;
\ alien-callback [ \ alien-callback [
4 ensure-values 4 ensure-values
\ alien-callback empty-node dup node, #alien-callback new dup node,
pop-literal nip over set-alien-callback-quot pop-literal nip >>quot
pop-literal nip over set-alien-callback-abi pop-literal nip >>abi
pop-parameters over set-alien-callback-parameters pop-parameters >>parameters
pop-literal nip over set-alien-callback-return pop-literal nip >>return
gensym dup register-callback over set-alien-callback-xt gensym dup register-callback >>xt
callback-bottom callback-bottom
] "infer" set-word-prop ] "infer" set-word-prop
@ -360,14 +375,13 @@ TUPLE: callback-context ;
return>> { return>> {
{ [ dup "void" = ] [ drop [ ] ] } { [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
{ [ t ] [ c-type c-type-prep ] } [ c-type c-type-prep ]
} cond ; } cond ;
: wrap-callback-quot ( node -- quot ) : wrap-callback-quot ( node -- quot )
[ [
dup alien-callback-quot [ quot>> ] [ prepare-callback-return ] bi append ,
swap prepare-callback-return append , [ callback-context new do-callback ] %
[ callback-context construct-empty do-callback ] %
] [ ] make ; ] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
@ -376,7 +390,7 @@ TUPLE: callback-context ;
{ {
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
{ [ dup return>> large-struct? ] [ drop 4 ] } { [ dup return>> large-struct? ] [ drop 4 ] }
{ [ t ] [ drop 0 ] } [ drop 0 ]
} cond ; } cond ;
: %callback-return ( node -- ) : %callback-return ( node -- )
@ -387,9 +401,8 @@ TUPLE: callback-context ;
callback-unwind %unwind ; callback-unwind %unwind ;
: generate-callback ( node -- ) : generate-callback ( node -- )
dup alien-callback-xt dup [ dup xt>> dup [
init-templates init-templates
%save-word-xt
%prologue-later %prologue-later
dup alien-stack-frame [ dup alien-stack-frame [
dup registers>objects dup registers>objects
@ -398,5 +411,5 @@ TUPLE: callback-context ;
] with-stack-frame ] with-stack-frame
] with-generator ; ] with-generator ;
M: alien-callback generate-node M: #alien-callback generate-node
end-basic-block generate-callback iterate-next ; end-basic-block generate-callback iterate-next ;

2
core/alien/structs/structs.factor
View File

@ -68,7 +68,7 @@ M: struct-type stack-size
: (define-struct) ( name vocab size align fields -- ) : (define-struct) ( name vocab size align fields -- )
>r [ align ] keep r> >r [ align ] keep r>
struct-type construct-boa struct-type boa
-rot define-c-type ; -rot define-c-type ;
: make-field ( struct-name vocab type field-name -- spec ) : make-field ( struct-name vocab type field-name -- spec )

2
core/alien/syntax/syntax.factor
View File

@ -68,7 +68,7 @@ M: alien pprint*
{ {
{ [ dup expired? ] [ drop "( alien expired )" text ] } { [ dup expired? ] [ drop "( alien expired )" text ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
{ [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ; } cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

4
core/arrays/arrays.factor
View File

@ -12,9 +12,9 @@ M: array resize resize-array ;
: >array ( seq -- array ) { } clone-like ; : >array ( seq -- array ) { } clone-like ;
M: object new drop f <array> ; M: object new-sequence drop f <array> ;
M: f new drop dup zero? [ drop f ] [ f <array> ] if ; M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
M: array like drop dup array? [ >array ] unless ; M: array like drop dup array? [ >array ] unless ;

21
core/assocs/assocs-docs.factor
View File

@ -69,14 +69,14 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
{ $subsection subassoc? } { $subsection subassoc? }
{ $subsection intersect } { $subsection assoc-intersect }
{ $subsection update } { $subsection update }
{ $subsection union } { $subsection assoc-union }
{ $subsection diff } { $subsection assoc-diff }
{ $subsection remove-all } { $subsection remove-all }
{ $subsection substitute } { $subsection substitute }
{ $subsection substitute-here } { $subsection substitute-here }
{ $see-also key? } ; { $see-also key? assoc-contains? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs" ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":" "Utility operations built up from the " { $link "assocs-protocol" } ":"
@ -97,6 +97,7 @@ $nl
{ $subsection assoc-map } { $subsection assoc-map }
{ $subsection assoc-push-if } { $subsection assoc-push-if }
{ $subsection assoc-subset } { $subsection assoc-subset }
{ $subsection assoc-contains? }
{ $subsection assoc-all? } { $subsection assoc-all? }
"Three additional combinators:" "Three additional combinators:"
{ $subsection cache } { $subsection cache }
@ -206,9 +207,13 @@ HELP: assoc-subset
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } } { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ; { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
HELP: assoc-contains?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
HELP: assoc-all? HELP: assoc-all?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } } { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ; { $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: subassoc? HELP: subassoc?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } } { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
@ -260,7 +265,7 @@ HELP: values
{ keys values } related-words { keys values } related-words
HELP: intersect HELP: assoc-intersect
{ $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } } { $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." } { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ; { $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
@ -270,11 +275,11 @@ HELP: update
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." } { $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
{ $side-effects "assoc1" } ; { $side-effects "assoc1" } ;
HELP: union HELP: assoc-union
{ $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } } { $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } }
{ $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ; { $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ;
HELP: diff HELP: assoc-diff
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } } { $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." } { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
; ;

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

@ -58,24 +58,24 @@ H{ } clone "cache-test" set
] [ ] [
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } } H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } } H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
intersect assoc-intersect
] unit-test ] unit-test
[ [
H{ { 1 2 } { 2 3 } { 6 5 } } H{ { 1 2 } { 2 3 } { 6 5 } }
] [ ] [
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } } H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
union assoc-union
] unit-test ] unit-test
[ H{ { 1 2 } { 2 3 } } t ] [ [ H{ { 1 2 } { 2 3 } } t ] [
f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd = f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
] unit-test ] unit-test
[ [
H{ { 1 f } } H{ { 1 f } }
] [ ] [
H{ { 1 f } } H{ { 1 f } } intersect H{ { 1 f } } H{ { 1 f } } assoc-intersect
] unit-test ] unit-test
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test [ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test

11
core/assocs/assocs.factor
View File

@ -109,17 +109,17 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
>r over r> hashcode* 2/ >r dupd hashcode* r> bitxor >r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
] { } assoc>map hashcode* ; ] { } assoc>map hashcode* ;
: intersect ( assoc1 assoc2 -- intersection ) : assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-subset ; swap [ nip key? ] curry assoc-subset ;
: update ( assoc1 assoc2 -- ) : update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ; swap [ swapd set-at ] curry assoc-each ;
: union ( assoc1 assoc2 -- union ) : assoc-union ( assoc1 assoc2 -- union )
2dup [ assoc-size ] bi@ + pick new-assoc 2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ; [ rot update ] keep [ swap update ] keep ;
: diff ( assoc1 assoc2 -- diff ) : assoc-diff ( assoc1 assoc2 -- diff )
swap [ nip key? not ] curry assoc-subset ; swap [ nip key? not ] curry assoc-subset ;
: remove-all ( assoc seq -- subseq ) : remove-all ( assoc seq -- subseq )
@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f ) : value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ; swap [ = nip ] curry assoc-find 2drop ;
: zip ( keys values -- alist )
2array flip ; inline
: search-alist ( key alist -- pair i ) : search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline [ first = ] with find swap ; inline
@ -204,7 +207,7 @@ M: enum set-at seq>> set-nth ;
M: enum delete-at enum-seq delete-nth ; M: enum delete-at enum-seq delete-nth ;
M: enum >alist ( enum -- alist ) M: enum >alist ( enum -- alist )
seq>> [ length ] keep 2array flip ; seq>> [ length ] keep zip ;
M: enum assoc-size seq>> length ; M: enum assoc-size seq>> length ;

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

@ -43,7 +43,7 @@ M: bit-array clone (clone) ;
M: bit-array like drop dup bit-array? [ >bit-array ] unless ; M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
M: bit-array new drop <bit-array> ; M: bit-array new-sequence drop <bit-array> ;
M: bit-array equal? M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ; over bit-array? [ sequence= ] [ 2drop f ] if ;

4
core/bit-vectors/bit-vectors.factor
View File

@ -7,7 +7,7 @@ IN: bit-vectors
<PRIVATE <PRIVATE
: bit-array>vector ( bit-array length -- bit-vector ) : bit-array>vector ( bit-array length -- bit-vector )
bit-vector construct-boa ; inline bit-vector boa ; inline
PRIVATE> PRIVATE>
@ -22,7 +22,7 @@ M: bit-vector like
[ dup length bit-array>vector ] [ >bit-vector ] if [ dup length bit-array>vector ] [ >bit-vector ] if
] unless ; ] unless ;
M: bit-vector new M: bit-vector new-sequence
drop [ <bit-array> ] keep >fixnum bit-array>vector ; drop [ <bit-array> ] keep >fixnum bit-array>vector ;
M: bit-vector equal? M: bit-vector equal?

1
core/bit-vectors/summary.txt Normal file
View File

@ -0,0 +1 @@
Growable bit arrays

1
core/bit-vectors/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

8
core/bootstrap/compiler/compiler.factor
View File

@ -19,7 +19,7 @@ IN: bootstrap.compiler
enable-compiler enable-compiler
nl nl
"Compiling some words to speed up bootstrap..." write flush "Compiling..." write flush
! Compile a set of words ahead of the full compile. ! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically ! This set of words was determined semi-empirically
@ -37,8 +37,6 @@ nl
wrap probe wrap probe
delegate
underlying underlying
find-pair-next namestack* find-pair-next namestack*
@ -55,7 +53,7 @@ nl
"." write flush "." write flush
{ {
new nth push pop peek new-sequence nth push pop peek
} compile } compile
"." write flush "." write flush
@ -76,4 +74,6 @@ nl
malloc calloc free memcpy malloc calloc free memcpy
} compile } compile
vocabs [ words [ compiled? not ] subset compile "." write flush ] each
" done" print flush " done" print flush

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

@ -4,9 +4,9 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts strings sbufs vectors words quotations assocs system layouts
splitting growable classes classes.tuple classes.tuple.private splitting growable classes classes.builtin classes.tuple
words.private io.binary io.files vocabs vocabs.loader classes.tuple.private words.private io.binary io.files vocabs
source-files definitions debugger float-arrays vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators quotations.private sequences.private combinators
io.encodings.binary ; io.encodings.binary ;
IN: bootstrap.image IN: bootstrap.image

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

@ -36,4 +36,4 @@ tag-numbers get H{
{ word 17 } { word 17 }
{ byte-array 18 } { byte-array 18 }
{ tuple-layout 19 } { tuple-layout 19 }
} union type-numbers set } assoc-union type-numbers set

34
core/bootstrap/primitives.factor
View File

@ -3,10 +3,10 @@
USING: alien arrays byte-arrays generic hashtables USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes strings vectors words quotations assocs layouts classes
classes.tuple classes.tuple.private kernel.private vocabs classes.builtin classes.tuple classes.tuple.private
vocabs.loader source-files definitions slots.deprecated kernel.private vocabs vocabs.loader source-files definitions
classes.union compiler.units bootstrap.image.private io.files slots.deprecated classes.union compiler.units
accessors combinators ; bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush "Creating primitives and basic runtime structures..." print flush
@ -30,7 +30,7 @@ crossref off
! Bring up a bare cross-compiling vocabulary. ! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set "syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set H{ } clone dictionary set
H{ } clone changed-words set H{ } clone changed-definitions set
H{ } clone forgotten-definitions set H{ } clone forgotten-definitions set
H{ } clone root-cache set H{ } clone root-cache set
H{ } clone source-files set H{ } clone source-files set
@ -390,7 +390,7 @@ define-builtin
! Create special tombstone values ! Create special tombstone values
"tombstone" "hashtables.private" create "tombstone" "hashtables.private" create
"tuple" "kernel" lookup tuple
{ } define-tuple-class { } define-tuple-class
"((empty))" "hashtables.private" create "((empty))" "hashtables.private" create
@ -403,7 +403,7 @@ define-builtin
! Some tuple classes ! Some tuple classes
"hashtable" "hashtables" create "hashtable" "hashtables" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "array-capacity" "sequences.private" } { "array-capacity" "sequences.private" }
@ -424,7 +424,7 @@ define-builtin
} define-tuple-class } define-tuple-class
"sbuf" "sbufs" create "sbuf" "sbufs" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "string" "strings" } { "string" "strings" }
@ -440,7 +440,7 @@ define-builtin
} define-tuple-class } define-tuple-class
"vector" "vectors" create "vector" "vectors" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "array" "arrays" } { "array" "arrays" }
@ -456,7 +456,7 @@ define-builtin
} define-tuple-class } define-tuple-class
"byte-vector" "byte-vectors" create "byte-vector" "byte-vectors" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "byte-array" "byte-arrays" } { "byte-array" "byte-arrays" }
@ -472,7 +472,7 @@ define-builtin
} define-tuple-class } define-tuple-class
"bit-vector" "bit-vectors" create "bit-vector" "bit-vectors" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "bit-array" "bit-arrays" } { "bit-array" "bit-arrays" }
@ -488,7 +488,7 @@ define-builtin
} define-tuple-class } define-tuple-class
"float-vector" "float-vectors" create "float-vector" "float-vectors" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "float-array" "float-arrays" } { "float-array" "float-arrays" }
@ -504,7 +504,7 @@ define-builtin
} define-tuple-class } define-tuple-class
"curry" "kernel" create "curry" "kernel" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "object" "kernel" } { "object" "kernel" }
@ -525,7 +525,7 @@ define-builtin
[ tuple-layout [ <tuple-boa> ] curry ] tri define [ tuple-layout [ <tuple-boa> ] curry ] tri define
"compose" "kernel" create "compose" "kernel" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "object" "kernel" } { "object" "kernel" }
@ -640,8 +640,7 @@ define-builtin
{ "setenv" "kernel.private" } { "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" } { "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" } { "(directory)" "io.files.private" }
{ "data-gc" "memory" } { "gc" "memory" }
{ "code-gc" "memory" }
{ "gc-time" "memory" } { "gc-time" "memory" }
{ "save-image" "memory" } { "save-image" "memory" }
{ "save-image-and-exit" "memory" } { "save-image-and-exit" "memory" }
@ -733,11 +732,14 @@ define-builtin
{ "set-innermost-frame-quot" "kernel.private" } { "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" } { "call-clear" "kernel" }
{ "(os-envs)" "system.private" } { "(os-envs)" "system.private" }
{ "set-os-env" "system" }
{ "unset-os-env" "system" }
{ "(set-os-envs)" "system.private" } { "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" } { "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" } { "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" } { "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" } { "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
} }
dup length [ >r first2 r> make-primitive ] 2each dup length [ >r first2 r> make-primitive ] 2each

14
core/bootstrap/stage2.factor
View File

@ -5,7 +5,7 @@ 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 generic ; math.parser generic sets ;
IN: bootstrap.stage2 IN: bootstrap.stage2
SYMBOL: bootstrap-time SYMBOL: bootstrap-time
@ -24,13 +24,9 @@ SYMBOL: bootstrap-time
: load-components ( -- ) : load-components ( -- )
"exclude" "include" "exclude" "include"
[ get-global " " split [ empty? not ] subset ] bi@ [ get-global " " split [ empty? not ] subset ] bi@
seq-diff diff
[ "bootstrap." prepend require ] each ; [ "bootstrap." prepend require ] each ;
: compile-remaining ( -- )
"Compiling remaining words..." print flush
vocabs [ words [ compiled? not ] subset compile ] each ;
: count-words ( pred -- ) : count-words ( pred -- )
all-words swap subset length number>string write ; all-words swap subset length number>string write ;
@ -57,7 +53,7 @@ millis >r
default-image-name "output-image" set-global default-image-name "output-image" set-global
"math help handbook compiler random tools ui ui.tools io" "include" set-global "math compiler help random tools ui ui.tools io handbook" "include" set-global
"" "exclude" set-global "" "exclude" set-global
parse-command-line parse-command-line
@ -79,10 +75,6 @@ os winnt? [ "windows.nt" require ] when
load-components load-components
run-bootstrap-init run-bootstrap-init
"bootstrap.compiler" vocab [
compile-remaining
] when
] with-compiler-errors ] with-compiler-errors
:errors :errors

2
core/boxes/boxes.factor
View File

@ -5,7 +5,7 @@ IN: boxes
TUPLE: box value full? ; TUPLE: box value full? ;
: <box> ( -- box ) box construct-empty ; : <box> ( -- box ) box new ;
: >box ( value box -- ) : >box ( value box -- )
dup box-full? [ "Box already has a value" throw ] when dup box-full? [ "Box already has a value" throw ] when

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

@ -10,7 +10,7 @@ M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
M: byte-array like drop dup byte-array? [ >byte-array ] unless ; M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
M: byte-array new drop <byte-array> ; M: byte-array new-sequence drop <byte-array> ;
M: byte-array equal? M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ; over byte-array? [ sequence= ] [ 2drop f ] if ;

4
core/byte-vectors/byte-vectors.factor
View File

@ -7,7 +7,7 @@ IN: byte-vectors
<PRIVATE <PRIVATE
: byte-array>vector ( byte-array length -- byte-vector ) : byte-array>vector ( byte-array length -- byte-vector )
byte-vector construct-boa ; inline byte-vector boa ; inline
PRIVATE> PRIVATE>
@ -22,7 +22,7 @@ M: byte-vector like
[ dup length byte-array>vector ] [ >byte-vector ] if [ dup length byte-array>vector ] [ >byte-vector ] if
] unless ; ] unless ;
M: byte-vector new M: byte-vector new-sequence
drop [ <byte-array> ] keep >fixnum byte-array>vector ; drop [ <byte-array> ] keep >fixnum byte-array>vector ;
M: byte-vector equal? M: byte-vector equal?

1
core/byte-vectors/summary.txt Normal file
View File

@ -0,0 +1 @@
Growable byte arrays

1
core/byte-vectors/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

12
core/classes/algebra/algebra-tests.factor
View File

@ -68,13 +68,13 @@ UNION: c a b ;
[ t ] [ \ tuple-class \ class class< ] unit-test [ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test [ f ] [ \ class \ tuple-class class< ] unit-test
TUPLE: delegate-clone ; TUPLE: tuple-example ;
[ t ] [ \ null \ delegate-clone class< ] unit-test [ t ] [ \ null \ tuple-example class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test [ f ] [ \ object \ tuple-example class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test [ f ] [ \ object \ tuple-example class< ] unit-test
[ t ] [ \ delegate-clone \ tuple class< ] unit-test [ t ] [ \ tuple-example \ tuple class< ] unit-test
[ f ] [ \ tuple \ delegate-clone class< ] unit-test [ f ] [ \ tuple \ tuple-example class< ] unit-test
TUPLE: a1 ; TUPLE: a1 ;
TUPLE: b1 ; TUPLE: b1 ;

22
core/classes/algebra/algebra.factor
View File

@ -1,8 +1,8 @@
! 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: kernel classes combinators accessors sequences arrays USING: kernel classes classes.builtin combinators accessors
vectors assocs namespaces words sorting layouts math hashtables sequences arrays vectors assocs namespaces words sorting layouts
kernel.private ; math hashtables kernel.private sets ;
IN: classes.algebra IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value ) : 2cache ( key1 key2 assoc quot -- value )
@ -84,7 +84,7 @@ C: <anonymous-complement> anonymous-complement
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class< ] } { [ dup members ] [ right-union-class< ] }
{ [ over superclass ] [ superclass< ] } { [ over superclass ] [ superclass< ] }
{ [ t ] [ 2drop f ] } [ 2drop f ]
} cond ; } cond ;
: anonymous-union-intersect? ( first second -- ? ) : anonymous-union-intersect? ( first second -- ? )
@ -103,15 +103,15 @@ C: <anonymous-complement> anonymous-complement
{ {
{ [ over tuple eq? ] [ 2drop t ] } { [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] } { [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] } { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
{ [ t ] [ swap classes-intersect? ] } [ swap classes-intersect? ]
} cond ; } cond ;
: builtin-class-intersect? ( first second -- ? ) : builtin-class-intersect? ( first second -- ? )
{ {
{ [ 2dup eq? ] [ 2drop t ] } { [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] } { [ over builtin-class? ] [ 2drop f ] }
{ [ t ] [ swap classes-intersect? ] } [ swap classes-intersect? ]
} cond ; } cond ;
: (classes-intersect?) ( first second -- ? ) : (classes-intersect?) ( first second -- ? )
@ -154,7 +154,7 @@ C: <anonymous-complement> anonymous-complement
{ [ over members ] [ left-union-and ] } { [ over members ] [ left-union-and ] }
{ [ over anonymous-union? ] [ left-anonymous-union-and ] } { [ over anonymous-union? ] [ left-anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
{ [ t ] [ 2array <anonymous-intersection> ] } [ 2array <anonymous-intersection> ]
} cond ; } cond ;
: left-anonymous-union-or ( first second -- class ) : left-anonymous-union-or ( first second -- class )
@ -169,7 +169,7 @@ C: <anonymous-complement> anonymous-complement
{ [ 2dup swap class< ] [ drop ] } { [ 2dup swap class< ] [ drop ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] } { [ dup anonymous-union? ] [ right-anonymous-union-or ] }
{ [ over anonymous-union? ] [ left-anonymous-union-or ] } { [ over anonymous-union? ] [ left-anonymous-union-or ] }
{ [ t ] [ 2array <anonymous-union> ] } [ 2array <anonymous-union> ]
} cond ; } cond ;
: (class-not) ( class -- complement ) : (class-not) ( class -- complement )
@ -177,7 +177,7 @@ C: <anonymous-complement> anonymous-complement
{ [ dup anonymous-complement? ] [ class>> ] } { [ dup anonymous-complement? ] [ class>> ] }
{ [ dup object eq? ] [ drop null ] } { [ dup object eq? ] [ drop null ] }
{ [ dup null eq? ] [ drop object ] } { [ dup null eq? ] [ drop object ] }
{ [ t ] [ <anonymous-complement> ] } [ <anonymous-complement> ]
} cond ; } cond ;
: largest-class ( seq -- n elt ) : largest-class ( seq -- n elt )
@ -205,7 +205,7 @@ C: <anonymous-complement> anonymous-complement
{ [ dup builtin-class? ] [ dup set ] } { [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] } { [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-class) ] } { [ dup superclass ] [ superclass (flatten-class) ] }
{ [ t ] [ drop ] } [ drop ]
} cond ; } cond ;
: flatten-class ( class -- assoc ) : flatten-class ( class -- assoc )

28
core/classes/builtin/builtin-docs.factor Normal file
View File

@ -0,0 +1,28 @@
USING: help.syntax help.markup classes layouts ;
IN: classes.builtin
ARTICLE: "builtin-classes" "Built-in classes"
"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
$nl
"The set of built-in classes is a class:"
{ $subsection builtin-class }
{ $subsection builtin-class? }
"See " { $link "type-index" } " for a list of built-in classes." ;
HELP: builtin-class
{ $class-description "The class of built-in classes." }
{ $examples
"The class of arrays is a built-in class:"
{ $example "USING: arrays classes.builtin prettyprint ;" "array builtin-class? ." "t" }
"However, an instance of the array class is not a built-in class; it is not even a class:"
{ $example "USING: classes.builtin prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
} ;
HELP: builtins
{ $var-description "Vector mapping type numbers to builtin class words." } ;
HELP: type>class
{ $values { "n" "a non-negative integer" } { "class" class } }
{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;

18
core/classes/builtin/builtin.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
sequences ;
IN: classes.builtin
SYMBOL: builtins
PREDICATE: builtin-class < class
"metaclass" word-prop builtin-class eq? ;
: type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;

35
core/classes/classes-docs.factor
View File

@ -4,14 +4,6 @@ layouts classes.private classes.union classes.mixin
classes.predicate quotations ; classes.predicate quotations ;
IN: classes IN: classes
ARTICLE: "builtin-classes" "Built-in classes"
"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
$nl
"The set of built-in classes is a class:"
{ $subsection builtin-class }
{ $subsection builtin-class? }
"See " { $link "type-index" } " for a list of built-in classes." ;
ARTICLE: "class-predicates" "Class predicate words" ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property." "With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl $nl
@ -38,17 +30,21 @@ $nl
{ $subsection class? } { $subsection class? }
"You can ask an object for its class:" "You can ask an object for its class:"
{ $subsection class } { $subsection class }
"Testing if an object is an instance of a class:"
{ $subsection instance? }
"There is a universal class which all objects are an instance of, and an empty class with no instances:" "There is a universal class which all objects are an instance of, and an empty class with no instances:"
{ $subsection object } { $subsection object }
{ $subsection null } { $subsection null }
"Obtaining a list of all defined classes:" "Obtaining a list of all defined classes:"
{ $subsection classes } { $subsection classes }
"Other sorts of classes:" "There are several sorts of classes:"
{ $subsection "builtin-classes" } { $subsection "builtin-classes" }
{ $subsection "unions" } { $subsection "unions" }
{ $subsection "singletons" }
{ $subsection "mixins" } { $subsection "mixins" }
{ $subsection "predicates" } { $subsection "predicates" }
{ $subsection "singletons" }
{ $link "tuples" } " are documented in their own section."
$nl
"Classes can be inspected and operated upon:" "Classes can be inspected and operated upon:"
{ $subsection "class-operations" } { $subsection "class-operations" }
{ $see-also "class-index" } ; { $see-also "class-index" } ;
@ -58,37 +54,20 @@ ABOUT: "classes"
HELP: class HELP: class
{ $values { "object" object } { "class" class } } { $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." } { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." } { $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; { $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes HELP: classes
{ $values { "seq" "a sequence of class words" } } { $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ; { $description "Finds all class words in the dictionary." } ;
HELP: builtin-class
{ $class-description "The class of built-in classes." }
{ $examples
"The class of arrays is a built-in class:"
{ $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
"However, an instance of the array class is not a built-in class; it is not even a class:"
{ $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
} ;
HELP: tuple-class HELP: tuple-class
{ $class-description "The class of tuple class words." } { $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; { $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: builtins
{ $var-description "Vector mapping type numbers to builtin class words." } ;
HELP: update-map HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; { $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
HELP: type>class
{ $values { "n" "a non-negative integer" } { "class" class } }
{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
HELP: predicate-word HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } } { $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ; { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;

15
core/classes/classes.factor
View File

@ -30,20 +30,11 @@ SYMBOL: update-map
PREDICATE: class < word PREDICATE: class < word
"class" word-prop ; "class" word-prop ;
SYMBOL: builtins
PREDICATE: builtin-class < class
"metaclass" word-prop builtin-class eq? ;
PREDICATE: tuple-class < class PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ; "metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ; : classes ( -- seq ) all-words [ class? ] subset ;
: 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 ;
@ -98,7 +89,7 @@ M: word reset-class drop ;
dup reset-class dup reset-class
dup deferred? [ dup define-symbol ] when dup deferred? [ dup define-symbol ] when
dup word-props dup word-props
r> union over set-word-props r> assoc-union over set-word-props
dup predicate-word dup predicate-word
[ 1quotation "predicate" set-word-prop ] [ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ] [ swap "predicating" set-word-prop ]
@ -130,9 +121,5 @@ GENERIC: update-methods ( assoc -- )
GENERIC: class ( object -- class ) GENERIC: class ( object -- class )
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
: instance? ( obj class -- ? ) : instance? ( obj class -- ? )
"predicate" word-prop call ; "predicate" word-prop call ;

8
core/classes/mixin/mixin-docs.factor
View File

@ -1,16 +1,18 @@
USING: help.markup help.syntax help words compiler.units USING: help.markup help.syntax help words compiler.units
classes ; classes sequences ;
IN: classes.mixin IN: classes.mixin
ARTICLE: "mixins" "Mixin classes" ARTICLE: "mixins" "Mixin classes"
"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, new classes can be made into instances of a mixin class after the original definition of the mixin." "An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, mixin classes have the additional property that they are " { $emphasis "open" } "; new classes can be added to the mixin after the original definition of the mixin."
{ $subsection POSTPONE: MIXIN: } { $subsection POSTPONE: MIXIN: }
{ $subsection POSTPONE: INSTANCE: } { $subsection POSTPONE: INSTANCE: }
{ $subsection define-mixin-class } { $subsection define-mixin-class }
{ $subsection add-mixin-instance } { $subsection add-mixin-instance }
"The set of mixin classes is a class:" "The set of mixin classes is a class:"
{ $subsection mixin-class } { $subsection mixin-class }
{ $subsection mixin-class? } ; { $subsection mixin-class? }
"Mixins are used to defines suites of behavior which are generally useful and can be applied to user-defined classes. For example, the " { $link immutable-sequence } " mixin can be used with user-defined sequences to make them immutable."
{ $see-also "unions" "tuple-subclassing" } ;
HELP: mixin-class HELP: mixin-class
{ $class-description "The class of mixin classes." } ; { $class-description "The class of mixin classes." } ;

4
core/classes/mixin/mixin.factor
View File

@ -24,7 +24,7 @@ TUPLE: check-mixin-class mixin ;
: check-mixin-class ( mixin -- mixin ) : check-mixin-class ( mixin -- mixin )
dup mixin-class? [ dup mixin-class? [
\ check-mixin-class construct-boa throw \ check-mixin-class boa throw
] unless ; ] unless ;
: if-mixin-member? ( class mixin true false -- ) : if-mixin-member? ( class mixin true false -- )
@ -49,7 +49,7 @@ M: mixin-instance equal?
{ [ over mixin-instance? not ] [ f ] } { [ over mixin-instance? not ] [ f ] }
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
{ [ t ] [ t ] } [ t ]
} cond 2nip ; } cond 2nip ;
M: mixin-instance hashcode* M: mixin-instance hashcode*

26
core/classes/singleton/singleton-docs.factor
View File

@ -2,27 +2,33 @@ USING: help.markup help.syntax kernel words ;
IN: classes.singleton IN: classes.singleton
ARTICLE: "singletons" "Singleton classes" ARTICLE: "singletons" "Singleton classes"
"A singleton is a class with only one instance and with no state. Methods may dispatch off of singleton classes." "A singleton is a class with only one instance and with no state."
{ $subsection POSTPONE: SINGLETON: } { $subsection POSTPONE: SINGLETON: }
{ $subsection define-singleton-class } ; { $subsection define-singleton-class }
"The set of all singleton classes is itself a class:"
{ $subsection singleton-class? }
{ $subsection singleton-class } ;
HELP: SINGLETON: HELP: SINGLETON:
{ $syntax "SINGLETON: class" { $syntax "SINGLETON: class" }
} { $values { $values
{ "class" "a new singleton to define" } { "class" "a new singleton to define" }
} { $description }
"Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton." { $description
} { $examples "Defines a new singleton class. The class word itself is the sole instance of the singleton class."
}
{ $examples
{ $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
} { $see-also
POSTPONE: PREDICATE:
} ; } ;
HELP: define-singleton-class HELP: define-singleton-class
{ $values { "word" "a new word" } } { $values { "word" "a new word" } }
{ $description { $description
"Defines a newly created word to be a singleton class." } ; "Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ;
{ POSTPONE: SINGLETON: define-singleton-class } related-words { POSTPONE: SINGLETON: define-singleton-class } related-words
HELP: singleton-class
{ $class-description "The class of singleton classes." } ;
ABOUT: "singletons" ABOUT: "singletons"

233
core/classes/tuple/tuple-docs.factor
View File

@ -3,48 +3,148 @@ classes.tuple.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ; generic.standard sequences definitions compiler.units ;
IN: classes.tuple IN: classes.tuple
ARTICLE: "tuple-constructors" "Constructors" ARTICLE: "parametrized-constructors" "Parameterized constructors"
"Tuples are created by calling one of two words:" "A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
{ $subsection construct-empty }
{ $subsection construct-boa }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
$nl $nl
"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
{ $code
"TUPLE: vehicle max-speed occupants ;"
""
": add-occupant ( person vehicle -- ) occupants>> push ;"
""
"TUPLE: car < vehicle engine ;"
": <car> ( max-speed engine -- car )"
" car new"
" V{ } clone >>occupants"
" swap >>engine"
" swap >>max-speed ;"
""
"TUPLE: aeroplane < vehicle max-altitude ;"
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
" aeroplane new"
" V{ } clone >>occupants"
" swap >>max-altitude"
" swap >>max-speed ;"
}
"The two constructors depend on the implementation of " { $snippet "vehicle" } " because they are responsible for initializing the " { $snippet "occupants" } " slot to an empty vector. If this slot is changed to contain a hashtable instead, there will be two places instead of one. A better approach is to use a parametrized constructor for vehicles:"
{ $code
"TUPLE: vehicle max-speed occupants ;"
""
": add-occupant ( person vehicle -- ) occupants>> push ;"
""
": new-vehicle ( class -- vehicle )"
" new"
" V{ } clone >>occupants ;"
""
"TUPLE: car < vehicle engine ;"
": <car> ( max-speed engine -- car )"
" car new-vehicle"
" swap >>engine"
" swap >>max-speed ;"
""
"TUPLE: aeroplane < vehicle max-altitude ;"
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
" aeroplane new-vehicle"
" swap >>max-altitude"
" swap >>max-speed ;"
}
"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ;
ARTICLE: "tuple-constructors" "Tuple constructors"
"Tuples are created by calling one of two constructor primitives:"
{ $subsection new }
{ $subsection boa }
"A shortcut for defining BOA constructors:" "A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: } { $subsection POSTPONE: C: }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
$nl
"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
$nl
"Examples of constructors:" "Examples of constructors:"
{ $code { $code
"TUPLE: color red green blue alpha ;" "TUPLE: color red green blue alpha ;"
"" ""
"! The following two are equivalent"
"C: <rgba> rgba" "C: <rgba> rgba"
": <rgba> color construct-boa ; ! identical to above" ": <rgba> color boa ;"
"" ""
"! We can define constructors which call other constructors"
": <rgb> f <rgba> ;" ": <rgb> f <rgba> ;"
"" ""
": <color> construct-empty ;" "! The following two are equivalent"
": <color> f f f f <rgba> ; ! identical to above" ": <color> color new ;"
": <color> f f f f <rgba> ;"
}
{ $subsection "parametrized-constructors" } ;
ARTICLE: "tuple-inheritance-example" "Tuple subclassing example"
"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:"
{ $list
"Computing the area"
"Computing the perimiter"
}
"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
{ $code
"GENERIC: area ( shape -- n )"
"GENERIC: perimiter ( shape -- n )"
""
"TUPLE: shape ;"
""
"TUPLE: circle < shape radius ;"
"M: area circle radius>> sq pi * ;"
"M: perimiter circle radius>> 2 * pi * ;"
""
"TUPLE: quad < shape width height"
"M: area quad [ width>> ] [ height>> ] bi * ;"
""
"TUPLE: rectangle < quad ;"
"M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;"
""
": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;"
""
"TUPLE: parallelogram < quad skew ;"
"M: parallelogram perimiter"
" [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;"
} ; } ;
ARTICLE: "tuple-delegation" "Tuple delegation" ARTICLE: "tuple-inheritance-anti-example" "When not to use tuple subclassing"
"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown." "Tuple subclassing should only be used for " { $emphasis "is-a" } " relationships; for example, a car " { $emphasis "is a" } " vehicle, and a circle " { $emphasis "is a" } " shape."
{ $subsection delegate } { $heading "Anti-pattern #1: subclassing for has-a" }
{ $subsection set-delegate } "Subclassing should not be used for " { $emphasis "has-a" } " relationships. For example, if a shape " { $emphasis "has a" } " color, then " { $snippet "shape" } " should not subclass " { $snippet "color" } ". Using tuple subclassing in inappropriate situations leads to code which is more brittle and less flexible than it should be."
"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution."
$nl $nl
"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object." "For example, suppose that " { $snippet "shape" } " inherits from " { $snippet "color" } ":"
{ $code
"TUPLE: color r g b ;"
"TUPLE: shape < color ... ;"
}
"Now, the implementation of " { $snippet "shape" } " depends on a specific representation of colors as RGB colors. If a new generic color protocol is devised which also allows HSB and YUV colors to be used, the shape class will not be able to take advantage of them without changes. A better approach is to store the color in a slot:"
{ $code
"TUPLE: rgb-color r g b ;"
"TUPLE: hsv-color h s v ;"
"..."
"TUPLE: shape color ... ;"
}
"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships."
{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
$nl $nl
"A pair of words examine delegation chains:" "There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "."
{ $subsection delegates } $nl
{ $subsection is? } "The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
"An example:" { $heading "Anti-pattern #3: subclassing to override a method definition" }
{ $example "While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
"TUPLE: ellipse center radius ;" { $see-also "parametrized-constructors" } ;
"TUPLE: colored color ;"
"{ 0 0 } 10 <ellipse> \"my-ellipse\" set" ARTICLE: "tuple-subclassing" "Tuple subclassing"
"{ 1 0 0 } <colored> \"my-shape\" set" "Tuple subclassing can be used to express natural relationships between classes at the language level. For example, every car " { $emphasis "is a" } " vehicle, so if the " { $snippet "car" } " class subclasses the " { $snippet "vehicle" } " class, it can " { $emphasis "inherit" } " the slots and methods of " { $snippet "vehicle" } "."
"\"my-ellipse\" get \"my-shape\" get set-delegate" $nl
"\"my-shape\" get dup color>> swap center>> .s" "To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":"
"{ 0 0 }\n{ 1 0 0 }" { $code
} ; "TUPLE: subclass < superclass ... ;"
}
{ $subsection "tuple-inheritance-example" }
{ $subsection "tuple-inheritance-anti-example" }
{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection" ARTICLE: "tuple-introspection" "Tuple introspection"
"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way." "In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
@ -67,11 +167,11 @@ ARTICLE: "tuple-examples" "Tuple examples"
} }
"We can define a constructor which makes an empty employee:" "We can define a constructor which makes an empty employee:"
{ $code ": <employee> ( -- employee )" { $code ": <employee> ( -- employee )"
" employee construct-empty ;" } " employee new ;" }
"Or we may wish the default constructor to always give employees a starting salary:" "Or we may wish the default constructor to always give employees a starting salary:"
{ $code { $code
": <employee> ( -- employee )" ": <employee> ( -- employee )"
" employee construct-empty" " employee new"
" 40000 >>salary ;" " 40000 >>salary ;"
} }
"We can define more refined constructors:" "We can define more refined constructors:"
@ -81,7 +181,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
"An alternative strategy is to define the most general BOA constructor first:" "An alternative strategy is to define the most general BOA constructor first:"
{ $code { $code
": <employee> ( name position -- person )" ": <employee> ( name position -- person )"
" 40000 employee construct-boa ;" " 40000 employee boa ;"
} }
"Now we can define more specific constructors:" "Now we can define more specific constructors:"
{ $code { $code
@ -94,7 +194,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
"SYMBOL: checks" "SYMBOL: checks"
"" ""
": <check> ( to amount -- check )" ": <check> ( to amount -- check )"
" checks counter check construct-boa ;" " checks counter check boa ;"
"" ""
": biweekly-paycheck ( employee -- check )" ": biweekly-paycheck ( employee -- check )"
" dup name>> swap salary>> 26 / <check> ;" " dup name>> swap salary>> 26 / <check> ;"
@ -119,7 +219,28 @@ ARTICLE: "tuple-examples" "Tuple examples"
": promote ( person -- person )" ": promote ( person -- person )"
" [ 1.2 * ] change-salary" " [ 1.2 * ] change-salary"
" [ next-position ] change-position ;" " [ next-position ] change-position ;"
} ; }
"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ;
ARTICLE: "tuple-redefinition" "Tuple redefinition"
"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses."
$nl
"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "."
$nl
"There are three ways to change the list of effective slots of a class:"
{ $list
"Adding or removing direct slots of the class"
"Adding or removing direct slots of a superclass of the class"
"Changing the inheritance hierarchy by redefining a class to have a different superclass"
}
"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:"
{ $list
"If any slots were removed, the values are removed from the instance and are lost forever."
{ "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." }
"If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory."
"If the number or order of effective slots changes, any BOA constructors are recompiled."
}
"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ;
ARTICLE: "tuples" "Tuples" ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots." "Tuples are user-defined classes composed of named slots."
@ -132,22 +253,16 @@ $nl
{ $subsection "accessors" } { $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:" "Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" } { $subsection "tuple-constructors" }
"Further topics:" "Expressing relationships through the object system:"
{ $subsection "tuple-delegation" } { $subsection "tuple-subclassing" }
"Introspection:"
{ $subsection "tuple-introspection" } { $subsection "tuple-introspection" }
"Tuple classes can be redefined; this updates existing instances:"
{ $subsection "tuple-redefinition" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ; "Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples" ABOUT: "tuples"
HELP: delegate
{ $values { "obj" object } { "delegate" object } }
{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
HELP: set-delegate
{ $values { "delegate" object } { "tuple" tuple } }
{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
HELP: tuple= HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." } { $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
@ -179,12 +294,12 @@ $low-level-note ;
HELP: tuple-slots HELP: tuple-slots
{ $values { "tuple" tuple } { "seq" sequence } } { $values { "tuple" tuple } { "seq" sequence } }
{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ; { $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ;
{ tuple-slots tuple>array } related-words { tuple-slots tuple>array } related-words
HELP: define-tuple-slots HELP: define-tuple-slots
{ $values { "class" tuple-class } { "slots" "a sequence of strings" } } { $values { "class" tuple-class } }
{ $description "Defines slot accessor and mutator words for the tuple." } { $description "Defines slot accessor and mutator words for the tuple." }
$low-level-note ; $low-level-note ;
@ -201,43 +316,33 @@ HELP: define-tuple-class
{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words { tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
HELP: delegates
{ $values { "obj" object } { "seq" sequence } }
{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
HELP: is?
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
$nl
"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
HELP: >tuple HELP: >tuple
{ $values { "seq" sequence } { "tuple" tuple } } { $values { "seq" sequence } { "tuple" tuple } }
{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots." { $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
$nl $nl
"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." } "If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ; { $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
HELP: tuple>array ( tuple -- array ) HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } } { $values { "tuple" tuple } { "array" array } }
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ; { $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple ) HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } } { $values { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ; { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple ) HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } } { $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ; { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: construct-empty HELP: new
{ $values { "class" tuple-class } { "tuple" tuple } } { $values { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." } { $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
{ $examples { $examples
{ $example { $example
"USING: kernel prettyprint ;" "USING: kernel prettyprint ;"
"TUPLE: employee number name department ;" "TUPLE: employee number name department ;"
"employee construct-empty ." "employee new ."
"T{ employee f f f f }" "T{ employee f f f f }"
} }
} ; } ;
@ -259,12 +364,12 @@ HELP: construct
" color construct ;" " color construct ;"
} }
"The last definition is actually equivalent to the following:" "The last definition is actually equivalent to the following:"
{ $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" } { $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
"Which can be abbreviated further:" "Which can be abbreviated further:"
{ $code "C: <rgba> color" } { $code "C: <rgba> color" }
} ; } ;
HELP: construct-boa HELP: boa
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } } { $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." } { $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ; { $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;

50
core/classes/tuple/tuple-tests.factor
View File

@ -7,7 +7,7 @@ calendar prettyprint io.streams.string splitting inspector ;
IN: classes.tuple.tests IN: classes.tuple.tests
TUPLE: rect x y w h ; TUPLE: rect x y w h ;
: <rect> rect construct-boa ; : <rect> rect boa ;
: move ( x rect -- rect ) : move ( x rect -- rect )
[ + ] change-x ; [ + ] change-x ;
@ -16,25 +16,6 @@ TUPLE: rect x y w h ;
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test [ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
GENERIC: delegation-test
M: object delegation-test drop 3 ;
TUPLE: quux-tuple ;
: <quux-tuple> quux-tuple construct-empty ;
M: quux-tuple delegation-test drop 4 ;
TUPLE: quuux-tuple ;
: <quuux-tuple> { set-delegate } quuux-tuple construct ;
[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
GENERIC: delegation-test-2
TUPLE: quux-tuple-2 ;
: <quux-tuple-2> quux-tuple-2 construct-empty ;
M: quux-tuple-2 delegation-test-2 drop 4 ;
TUPLE: quuux-tuple-2 ;
: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
! Make sure we handle tuple class redefinition ! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ; TUPLE: redefinition-test ;
@ -102,11 +83,6 @@ C: <empty> empty
[ t ] [ <empty> hashcode fixnum? ] unit-test [ t ] [ <empty> hashcode fixnum? ] unit-test
TUPLE: delegate-clone ;
[ T{ delegate-clone T{ empty f } } ]
[ T{ delegate-clone T{ empty f } } clone ] unit-test
! Compiler regression ! Compiler regression
[ t length ] [ object>> t eq? ] must-fail-with [ t length ] [ object>> t eq? ] must-fail-with
@ -222,8 +198,8 @@ SYMBOL: not-a-tuple-class
] unit-test ] unit-test
! Missing check ! Missing check
[ not-a-tuple-class construct-boa ] must-fail [ not-a-tuple-class boa ] must-fail
[ not-a-tuple-class construct-empty ] must-fail [ not-a-tuple-class new ] must-fail
TUPLE: erg's-reshape-problem a b c d ; TUPLE: erg's-reshape-problem a b c d ;
@ -231,8 +207,8 @@ C: <erg's-reshape-problem> erg's-reshape-problem
! We want to make sure constructors are recompiled when ! We want to make sure constructors are recompiled when
! tuples are reshaped ! tuples are reshaped
: cons-test-1 \ erg's-reshape-problem construct-empty ; : cons-test-1 \ erg's-reshape-problem new ;
: cons-test-2 \ erg's-reshape-problem construct-boa ; : cons-test-2 \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
@ -242,7 +218,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[ [
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval "IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ no-tuple-class? ] is? ] must-fail-with ] [ error>> no-tuple-class? ] must-fail-with
! Inheritance ! Inheritance
TUPLE: computer cpu ram ; TUPLE: computer cpu ram ;
@ -512,7 +488,7 @@ USE: vocabs
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with [ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
! Accessors not being forgotten... ! Accessors not being forgotten...
[ [ ] ] [ [ [ ] ] [
@ -553,3 +529,15 @@ TUPLE: another-forget-accessors-test ;
] unit-test ] unit-test
[ t ] [ \ another-forget-accessors-test class? ] unit-test [ t ] [ \ another-forget-accessors-test class? ] unit-test
! Shadowing test
[ f ] [
t parser-notes? [
[
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
] with-string-writer empty?
] with-variable
] unit-test
! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail

41
core/classes/tuple/tuple.factor
View File

@ -7,10 +7,6 @@ classes classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ; compiler.units math.private accessors assocs ;
IN: classes.tuple IN: classes.tuple
M: tuple delegate 2 slot ;
M: tuple set-delegate 2 set-slot ;
M: tuple class 1 slot 2 slot { word } declare ; M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ; ERROR: no-tuple-class class ;
@ -44,7 +40,7 @@ PRIVATE>
>r copy-tuple-slots r> >r copy-tuple-slots r>
layout-class prefix ; layout-class prefix ;
: tuple-slots ( tuple -- array ) : tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ; prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array ) : slots>tuple ( tuple class -- array )
@ -52,11 +48,17 @@ PRIVATE>
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
] keep ; ] keep ;
: >tuple ( tuple -- array ) : >tuple ( tuple -- seq )
unclip slots>tuple ; unclip slots>tuple ;
: slot-names ( class -- seq ) : slot-names ( class -- seq )
"slot-names" word-prop ; "slot-names" word-prop
[ dup array? [ second ] when ] map ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
ERROR: bad-superclass class ;
<PRIVATE <PRIVATE
@ -107,7 +109,7 @@ PRIVATE>
over superclass-size 2 + simple-slots ; over superclass-size 2 + simple-slots ;
: define-tuple-slots ( class -- ) : define-tuple-slots ( class -- )
dup dup slot-names generate-tuple-slots dup dup "slot-names" word-prop generate-tuple-slots
[ "slots" set-word-prop ] [ "slots" set-word-prop ]
[ define-accessors ] ! new [ define-accessors ] ! new
[ define-slots ] ! old [ define-slots ] ! old
@ -122,9 +124,6 @@ PRIVATE>
: define-tuple-layout ( class -- ) : define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ; dup make-tuple-layout "layout" set-word-prop ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
: compute-slot-permutation ( class old-slot-names -- permutation ) : compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ; >r all-slot-names r> [ index ] curry map ;
@ -177,7 +176,7 @@ M: tuple-class update-class
2drop 2drop
[ [
[ update-tuples-after ] [ update-tuples-after ]
[ changed-word ] [ changed-definition ]
[ redefined ] [ redefined ]
tri tri
] each-subclass ] each-subclass
@ -188,21 +187,28 @@ M: tuple-class update-class
: tuple-class-unchanged? ( class superclass slots -- ? ) : tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
: valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ;
: check-superclass ( superclass -- )
dup valid-superclass? [ bad-superclass ] unless drop ;
PRIVATE> PRIVATE>
GENERIC# define-tuple-class 2 ( class superclass slots -- ) GENERIC# define-tuple-class 2 ( class superclass slots -- )
M: word define-tuple-class M: word define-tuple-class
over check-superclass
define-new-tuple-class ; define-new-tuple-class ;
M: tuple-class define-tuple-class M: tuple-class define-tuple-class
3dup tuple-class-unchanged? 3dup tuple-class-unchanged?
[ 3dup redefine-tuple-class ] unless [ over check-superclass 3dup redefine-tuple-class ] unless
3drop ; 3drop ;
: define-error-class ( class superclass slots -- ) : define-error-class ( class superclass slots -- )
[ define-tuple-class ] [ 2drop ] 3bi [ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ; dup [ boa throw ] curry define ;
M: tuple-class reset-class M: tuple-class reset-class
[ [
@ -228,9 +234,10 @@ M: tuple equal?
M: tuple hashcode* M: tuple hashcode*
[ [
dup tuple-size -rot 0 -rot [ [ class hashcode ] [ tuple-size ] [ ] tri
swapd array-nth hashcode* bitxor >r rot r> [
] 2curry reduce swapd array-nth hashcode* sequence-hashcode-step
] 2curry each
] recursive-hashcode ; ] recursive-hashcode ;
! Deprecated ! Deprecated

4
core/classes/union/union-docs.factor
View File

@ -11,7 +11,9 @@ ARTICLE: "unions" "Union classes"
{ $subsection members } { $subsection members }
"The set of union classes is a class:" "The set of union classes is a class:"
{ $subsection union-class } { $subsection union-class }
{ $subsection union-class? } ; { $subsection union-class? }
"Unions are used to define behavior shared between a fixed set of classes."
{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions" ABOUT: "unions"

10
core/combinators/combinators-docs.factor
View File

@ -64,9 +64,9 @@ HELP: alist>quot
{ $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ; { $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ;
HELP: cond HELP: cond
{ $values { "assoc" "a sequence of quotation pairs" } } { $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
{ $description { $description
"Calls the second quotation in the first pair whose first quotation yields a true value." "Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value."
$nl $nl
"The following two phrases are equivalent:" "The following two phrases are equivalent:"
{ $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" } { $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" }
@ -78,7 +78,7 @@ HELP: cond
"{" "{"
" { [ dup 0 > ] [ \"positive\" ] }" " { [ dup 0 > ] [ \"positive\" ] }"
" { [ dup 0 < ] [ \"negative\" ] }" " { [ dup 0 < ] [ \"negative\" ] }"
" { [ dup zero? ] [ \"zero\" ] }" " [ \"zero\" ]"
"} cond" "} cond"
} }
} ; } ;
@ -88,9 +88,9 @@ HELP: no-cond
{ $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ; { $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ;
HELP: case HELP: case
{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } } { $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } }
{ $description { $description
"Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." "Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
$nl $nl
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied." "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
$nl $nl

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

@ -1,7 +1,54 @@
IN: combinators.tests
USING: alien strings kernel math tools.test io prettyprint USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words ; namespaces combinators words classes sequences ;
IN: combinators.tests
! Compiled
: cond-test-1 ( obj -- str )
{
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond ;
\ cond-test-1 must-infer
[ "even" ] [ 2 cond-test-1 ] unit-test
[ "odd" ] [ 3 cond-test-1 ] unit-test
: cond-test-2 ( obj -- str )
{
{ [ dup t = ] [ drop "true" ] }
{ [ dup f = ] [ drop "false" ] }
[ drop "something else" ]
} cond ;
\ cond-test-2 must-infer
[ "true" ] [ t cond-test-2 ] unit-test
[ "false" ] [ f cond-test-2 ] unit-test
[ "something else" ] [ "ohio" cond-test-2 ] unit-test
: cond-test-3 ( obj -- str )
{
[ drop "something else" ]
{ [ dup t = ] [ drop "true" ] }
{ [ dup f = ] [ drop "false" ] }
} cond ;
\ cond-test-3 must-infer
[ "something else" ] [ t cond-test-3 ] unit-test
[ "something else" ] [ f cond-test-3 ] unit-test
[ "something else" ] [ "ohio" cond-test-3 ] unit-test
: cond-test-4 ( -- )
{
} cond ;
\ cond-test-4 must-infer
[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
! Interpreted
[ "even" ] [ [ "even" ] [
2 { 2 {
{ [ dup 2 mod 0 = ] [ drop "even" ] } { [ dup 2 mod 0 = ] [ drop "even" ] }
@ -21,11 +68,66 @@ namespaces combinators words ;
{ [ dup string? ] [ drop "string" ] } { [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] } { [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] } { [ dup alien? ] [ drop "alien" ] }
{ [ t ] [ drop "neither" ] } [ drop "neither" ]
} cond } cond
] unit-test ] unit-test
: case-test-1 [ "neither" ] [
3 {
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
[ drop "neither" ]
} cond
] unit-test
[ "neither" ] [
3 {
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
[ drop "neither" ]
} cond
] unit-test
[ "early" ] [
2 {
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
[ drop "early" ]
{ [ dup 2 mod 0 = ] [ drop "even" ] }
} cond
] unit-test
[ "really early" ] [
2 {
[ drop "really early" ]
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
{ [ dup 2 mod 0 = ] [ drop "even" ] }
} cond
] unit-test
[ { } cond ] [ class \ no-cond = ] must-fail-with
[ "early" ] [
2 {
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
[ drop "early" ]
{ [ dup 2 mod 0 = ] [ drop "even" ] }
} cond
] unit-test
[ "really early" ] [
2 {
[ drop "really early" ]
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
{ [ dup 2 mod 0 = ] [ drop "even" ] }
} cond
] unit-test
[ { } cond ] [ class \ no-cond = ] must-fail-with
! Compiled
: case-test-1 ( obj -- obj' )
{ {
{ 1 [ "one" ] } { 1 [ "one" ] }
{ 2 [ "two" ] } { 2 [ "two" ] }
@ -33,6 +135,8 @@ namespaces combinators words ;
{ 4 [ "four" ] } { 4 [ "four" ] }
} case ; } case ;
\ case-test-1 must-infer
[ "two" ] [ 2 case-test-1 ] unit-test [ "two" ] [ 2 case-test-1 ] unit-test
! Interpreted ! Interpreted
@ -40,7 +144,7 @@ namespaces combinators words ;
[ "x" case-test-1 ] must-fail [ "x" case-test-1 ] must-fail
: case-test-2 : case-test-2 ( obj -- obj' )
{ {
{ 1 [ "one" ] } { 1 [ "one" ] }
{ 2 [ "two" ] } { 2 [ "two" ] }
@ -49,12 +153,14 @@ namespaces combinators words ;
[ sq ] [ sq ]
} case ; } case ;
\ case-test-2 must-infer
[ 25 ] [ 5 case-test-2 ] unit-test [ 25 ] [ 5 case-test-2 ] unit-test
! Interpreted ! Interpreted
[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test [ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
: case-test-3 : case-test-3 ( obj -- obj' )
{ {
{ 1 [ "one" ] } { 1 [ "one" ] }
{ 2 [ "two" ] } { 2 [ "two" ] }
@ -65,8 +171,122 @@ namespaces combinators words ;
[ sq ] [ sq ]
} case ; } case ;
\ case-test-3 must-infer
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
: case-const-1 1 ;
: case-const-2 2 ; inline
! Compiled
: case-test-4 ( obj -- str )
{
{ case-const-1 [ "uno" ] }
{ case-const-2 [ "dos" ] }
{ 3 [ "tres" ] }
{ 4 [ "cuatro" ] }
{ 5 [ "cinco" ] }
[ drop "demasiado" ]
} case ;
\ case-test-4 must-infer
[ "uno" ] [ 1 case-test-4 ] unit-test
[ "dos" ] [ 2 case-test-4 ] unit-test
[ "tres" ] [ 3 case-test-4 ] unit-test
[ "demasiado" ] [ 100 case-test-4 ] unit-test
: case-test-5 ( obj -- )
{
{ case-const-1 [ "uno" print ] }
{ case-const-2 [ "dos" print ] }
{ 3 [ "tres" print ] }
{ 4 [ "cuatro" print ] }
{ 5 [ "cinco" print ] }
[ drop "demasiado" print ]
} case ;
\ case-test-5 must-infer
[ ] [ 1 case-test-5 ] unit-test
! Interpreted
[ "uno" ] [
1 {
{ case-const-1 [ "uno" ] }
{ case-const-2 [ "dos" ] }
{ 3 [ "tres" ] }
{ 4 [ "cuatro" ] }
{ 5 [ "cinco" ] }
[ drop "demasiado" ]
} case
] unit-test
[ "dos" ] [
2 {
{ case-const-1 [ "uno" ] }
{ case-const-2 [ "dos" ] }
{ 3 [ "tres" ] }
{ 4 [ "cuatro" ] }
{ 5 [ "cinco" ] }
[ drop "demasiado" ]
} case
] unit-test
[ "tres" ] [
3 {
{ case-const-1 [ "uno" ] }
{ case-const-2 [ "dos" ] }
{ 3 [ "tres" ] }
{ 4 [ "cuatro" ] }
{ 5 [ "cinco" ] }
[ drop "demasiado" ]
} case
] unit-test
[ "demasiado" ] [
100 {
{ case-const-1 [ "uno" ] }
{ case-const-2 [ "dos" ] }
{ 3 [ "tres" ] }
{ 4 [ "cuatro" ] }
{ 5 [ "cinco" ] }
[ drop "demasiado" ]
} case
] unit-test
: do-not-call "do not call" throw ;
: test-case-6
{
{ \ do-not-call [ "do-not-call" ] }
{ 3 [ "three" ] }
} case ;
[ "three" ] [ 3 test-case-6 ] unit-test
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
[ "three" ] [
3 {
{ \ do-not-call [ "do-not-call" ] }
{ 3 [ "three" ] }
} case
] unit-test
[ "do-not-call" ] [
[ do-not-call ] first {
{ \ do-not-call [ "do-not-call" ] }
{ 3 [ "three" ] }
} case
] unit-test
[ "do-not-call" ] [
\ do-not-call {
{ \ do-not-call [ "do-not-call" ] }
{ 3 [ "three" ] }
} case
] unit-test
! Interpreted ! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test

34
core/combinators/combinators.factor
View File

@ -3,7 +3,7 @@
IN: combinators 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
hashtables sorting ; hashtables sorting words sets ;
: cleave ( x seq -- ) : cleave ( x seq -- )
[ call ] with each ; [ call ] with each ;
@ -34,13 +34,24 @@ hashtables sorting ;
ERROR: no-cond ; ERROR: no-cond ;
: cond ( assoc -- ) : cond ( assoc -- )
[ first call ] find nip dup [ second call ] [ no-cond ] if ; [ dup callable? [ drop t ] [ first call ] if ] find nip
[ dup callable? [ call ] [ second call ] if ]
[ no-cond ] if* ;
ERROR: no-case ; ERROR: no-case ;
: case-find ( obj assoc -- obj' )
[
dup array? [
dupd first dup word? [
execute
] [
dup wrapper? [ wrapped ] when
] if =
] [ quotation? ] if
] find nip ;
: case ( obj assoc -- ) : case ( obj assoc -- )
[ dup array? [ dupd first = ] [ quotation? ] if ] find nip case-find {
{
{ [ dup array? ] [ nip second call ] } { [ dup array? ] [ nip second call ] }
{ [ dup quotation? ] [ call ] } { [ dup quotation? ] [ call ] }
{ [ dup not ] [ no-case ] } { [ dup not ] [ no-case ] }
@ -59,6 +70,10 @@ ERROR: no-case ;
M: sequence hashcode* M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ; [ sequence-hashcode ] recursive-hashcode ;
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode* M: hashtable hashcode*
[ [
dup assoc-size 1 number= dup assoc-size 1 number=
@ -69,11 +84,14 @@ M: hashtable hashcode*
[ rot \ if 3array append [ ] like ] assoc-each ; [ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot ) : cond>quot ( assoc -- quot )
[ dup callable? [ [ t ] swap 2array ] when ] map
reverse [ no-cond ] swap alist>quot ; reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot ) : linear-case-quot ( default assoc -- quot )
[ >r [ dupd = ] curry r> \ drop prefix ] assoc-map [
alist>quot ; [ 1quotation \ dup prefix \ = suffix ]
[ \ drop prefix ] bi*
] assoc-map alist>quot ;
: (distribute-buckets) ( buckets pair keys -- ) : (distribute-buckets) ( buckets pair keys -- )
dup t eq? [ dup t eq? [
@ -131,7 +149,9 @@ M: hashtable hashcode*
dup empty? [ dup empty? [
drop drop
] [ ] [
dup length 4 <= [ dup length 4 <=
over keys [ word? ] contains? or
[
linear-case-quot linear-case-quot
] [ ] [
dup keys contiguous-range? [ dup keys contiguous-range? [

7
core/command-line/command-line-docs.factor
View File

@ -7,9 +7,10 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } } { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" } { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" } { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" } { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } } { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" } { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
} }

10
core/compiler/compiler.factor
View File

@ -1,10 +1,10 @@
! 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: kernel namespaces arrays sequences io inference.backend USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger math.parser prettyprint words inference.state generator debugger words compiler.units
compiler.units continuations vocabs assocs alien.compiler dlists continuations vocabs assocs alien.compiler dlists optimizer
optimizer definitions math compiler.errors threads graphs definitions math compiler.errors threads graphs generic
generic inference ; inference ;
IN: compiler IN: compiler
: ripple-up ( word -- ) : ripple-up ( word -- )
@ -20,7 +20,7 @@ IN: compiler
: finish-compile ( word effect dependencies -- ) : finish-compile ( word effect dependencies -- )
>r dupd save-effect r> >r dupd save-effect r>
over compiled-unxref over compiled-unxref
over crossref? [ compiled-xref ] [ 2drop ] if ; over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies ) : compile-succeeded ( word -- effect dependencies )
[ [

2
core/compiler/tests/float.factor
View File

@ -2,7 +2,7 @@ IN: compiler.tests
USING: compiler.units kernel kernel.private memory math USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test [ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test

6
core/compiler/tests/simple.factor
View File

@ -48,7 +48,7 @@ IN: compiler.tests
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] 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 [ 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 [ 2 3 ] [ 1 [ { [ gc 1 ] [ gc 2 ] } dispatch 3 ] compile-call ] unit-test
! Labels ! Labels
@ -187,7 +187,7 @@ DEFER: countdown-b
{ [ dup string? ] [ drop "string" ] } { [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] } { [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] } { [ dup alien? ] [ drop "alien" ] }
{ [ t ] [ drop "neither" ] } [ drop "neither" ]
} cond } cond
] compile-call ] compile-call
] unit-test ] unit-test
@ -196,7 +196,7 @@ DEFER: countdown-b
[ [
3 { 3 {
{ [ dup fixnum? ] [ ] } { [ dup fixnum? ] [ ] }
{ [ t ] [ drop t ] } [ drop t ]
} cond } cond
] compile-call ] compile-call
] unit-test ] unit-test

14
core/compiler/tests/templates-early.factor
View File

@ -2,9 +2,9 @@
IN: compiler.tests IN: compiler.tests
USING: compiler generator generator.registers USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units ; words kernel math effects definitions compiler.units accessors ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ; : <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[ [
[ ] [ init-templates ] unit-test [ ] [ init-templates ] unit-test
@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ;
[ ] [ compute-free-vregs ] unit-test [ ] [ compute-free-vregs ] unit-test
[ f ] [ 0 <int-vreg> T{ int-regs } free-vregs member? ] unit-test [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [ [ f ] [
[ [
copy-templates copy-templates
1 <int-vreg> phantom-push 1 <int-vreg> phantom-push
compute-free-vregs compute-free-vregs
1 <int-vreg> T{ int-regs } free-vregs member? 1 <int-vreg> int-regs free-vregs member?
] with-scope ] with-scope
] unit-test ] unit-test
[ t ] [ 1 <int-vreg> T{ int-regs } free-vregs member? ] unit-test [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope ] with-scope
[ [
@ -173,12 +173,12 @@ SYMBOL: template-chosen
] unit-test ] unit-test
[ ] [ [ ] [
2 phantom-d get phantom-input 2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop [ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test ] unit-test
[ t ] [ [ t ] [
phantom-d get [ cached? ] all? phantom-datastack get stack>> [ cached? ] all?
] unit-test ] unit-test
! >r ! >r

55
core/compiler/tests/templates.factor
View File

@ -3,7 +3,7 @@ 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
sequences.private byte-arrays alien alien.accessors layouts sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators ; words definitions compiler.units io combinators vectors ;
IN: compiler.tests IN: compiler.tests
! Oops! ! Oops!
@ -202,3 +202,56 @@ TUPLE: my-tuple ;
] [ 2drop no-case ] if ] [ 2drop no-case ] if
] compile-call ] compile-call
] unit-test ] unit-test
: float-spill-bug
{
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
} cleave ;
[ t ] [ \ float-spill-bug compiled? ] unit-test
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test

16
core/compiler/tests/tuples.factor
View File

@ -4,16 +4,16 @@ USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ; TUPLE: color red green blue ;
[ T{ color f 1 2 3 } ] [ T{ color f 1 2 3 } ]
[ 1 2 3 [ color construct-boa ] compile-call ] unit-test [ 1 2 3 [ color boa ] compile-call ] unit-test
[ 1 3 ] [ [ 1 3 ] [
1 2 3 color construct-boa 1 2 3 color boa
[ { color-red color-blue } get-slots ] compile-call [ { color-red color-blue } get-slots ] compile-call
] unit-test ] unit-test
[ T{ color f 10 2 20 } ] [ [ T{ color f 10 2 20 } ] [
10 20 10 20
1 2 3 color construct-boa [ 1 2 3 color boa [
[ [
{ set-color-red set-color-blue } set-slots { set-color-red set-color-blue } set-slots
] compile-call ] compile-call
@ -21,12 +21,4 @@ TUPLE: color red green blue ;
] unit-test ] unit-test
[ T{ color f f f f } ] [ T{ color f f f f } ]
[ [ color construct-empty ] compile-call ] unit-test [ [ color new ] compile-call ] unit-test
[ T{ color "a" f "b" f } ] [
"a" "b"
[ { set-delegate set-color-green } color construct ]
compile-call
] unit-test
[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test

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

@ -10,7 +10,7 @@ SYMBOL: new-definitions
TUPLE: redefine-error def ; TUPLE: redefine-error def ;
: redefine-error ( definition -- ) : redefine-error ( definition -- )
\ redefine-error construct-boa \ redefine-error boa
{ { "Continue" t } } throw-restarts drop ; { { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- ) : add-once ( key assoc -- )
@ -56,24 +56,24 @@ GENERIC: definitions-changed ( assoc obj -- )
[ drop word? ] assoc-subset [ drop word? ] assoc-subset
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ; [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
: changed-definitions ( -- assoc ) : updated-definitions ( -- assoc )
H{ } clone H{ } clone
dup forgotten-definitions get update dup forgotten-definitions get update
dup new-definitions get first update dup new-definitions get first update
dup new-definitions get second update dup new-definitions get second update
dup changed-words get update dup changed-definitions get update
dup dup changed-vocabs update ; dup dup changed-vocabs update ;
: compile ( words -- ) : compile ( words -- )
recompile-hook get call recompile-hook get call
dup [ drop crossref? ] assoc-contains? dup [ drop compiled-crossref? ] assoc-contains?
modify-code-heap ; modify-code-heap ;
SYMBOL: outdated-tuples SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook SYMBOL: update-tuples-hook
: call-recompile-hook ( -- ) : call-recompile-hook ( -- )
changed-words get keys changed-definitions get keys [ word? ] subset
compiled-usages recompile-hook get call ; compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- ) : call-update-tuples-hook ( -- )
@ -82,12 +82,12 @@ SYMBOL: update-tuples-hook
: finish-compilation-unit ( -- ) : finish-compilation-unit ( -- )
call-recompile-hook call-recompile-hook
call-update-tuples-hook call-update-tuples-hook
dup [ drop crossref? ] assoc-contains? modify-code-heap dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
changed-definitions notify-definition-observers ; updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- ) : with-compilation-unit ( quot -- )
[ [
H{ } clone changed-words set H{ } clone changed-definitions set
H{ } clone forgotten-definitions set H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set H{ } clone outdated-tuples set
<definitions> new-definitions set <definitions> new-definitions set

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

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces continuations.private parser vectors arrays namespaces
assocs words quotations ; assocs words quotations io ;
IN: continuations IN: continuations
ARTICLE: "errors-restartable" "Restartable errors" ARTICLE: "errors-restartable" "Restartable errors"
@ -17,6 +17,25 @@ ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
{ $subsection error-continuation } { $subsection error-continuation }
"Developer tools for inspecting these values are found in " { $link "debugger" } "." ; "Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
{ $heading "Anti-pattern #1: Ignoring errors" }
"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
{ $heading "Anti-pattern #2: Catching errors too early" }
"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
$nl
"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
{ $heading "Anti-pattern #3: Dropping and rethrowing" }
"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
{ $heading "Anti-pattern #4: Logging and rethrowing" }
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
{ $heading "Anti-pattern #5: Leaking external resources" }
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
{ $code
"<external-resource> ... do stuff ... dispose"
}
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
ARTICLE: "errors" "Error handling" ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl $nl
@ -27,10 +46,13 @@ $nl
{ $subsection cleanup } { $subsection cleanup }
{ $subsection recover } { $subsection recover }
{ $subsection ignore-errors } { $subsection ignore-errors }
"Syntax sugar for defining errors:"
{ $subsection POSTPONE: ERROR: }
"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 "debugger" } { $subsection "debugger" }
{ $subsection "errors-post-mortem" } { $subsection "errors-post-mortem" }
{ $subsection "errors-anti-examples" }
"When Factor encouters a critical error, it calls the following word:" "When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ; { $subsection die } ;
@ -61,15 +83,18 @@ $nl
"Another two words resume continuations:" "Another two words resume continuations:"
{ $subsection continue } { $subsection continue }
{ $subsection continue-with } { $subsection continue-with }
"Continuations serve as the building block for a number of higher-level abstractions." "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "errors" }
{ $subsection "continuations.private" } ; { $subsection "continuations.private" } ;
ABOUT: "continuations" ABOUT: "continuations"
HELP: dispose HELP: dispose
{ $values { "object" "a disposable object" } } { $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." } { $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
$nl
"No further operations can be performed on a disposable object after this call."
$nl
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
{ $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." } ; { $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 HELP: with-disposal

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

@ -46,8 +46,8 @@ IN: continuations.tests
! Weird PowerPC bug. ! Weird PowerPC bug.
[ ] [ [ ] [
[ "4" throw ] ignore-errors [ "4" throw ] ignore-errors
data-gc gc
data-gc gc
] unit-test ] unit-test
[ f ] [ { } kernel-error? ] unit-test [ f ] [ { } kernel-error? ] unit-test

24
core/continuations/continuations.factor
View File

@ -141,14 +141,9 @@ GENERIC: dispose ( object -- )
: with-disposal ( object quot -- ) : with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline over [ dispose ] curry [ ] cleanup ; inline
TUPLE: condition restarts continuation ; TUPLE: condition error restarts continuation ;
: <condition> ( error restarts cc -- condition ) C: <condition> condition ( error restarts cc -- condition )
{
set-delegate
set-condition-restarts
set-condition-continuation
} condition construct ;
: throw-restarts ( error restarts -- restart ) : throw-restarts ( error restarts -- restart )
[ <condition> throw ] callcc1 2nip ; [ <condition> throw ] callcc1 2nip ;
@ -161,15 +156,14 @@ TUPLE: restart name obj continuation ;
C: <restart> restart C: <restart> restart
: restart ( restart -- ) : restart ( restart -- )
dup restart-obj swap restart-continuation continue-with ; [ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ; M: object compute-restarts drop { } ;
M: tuple compute-restarts delegate compute-restarts ;
M: condition compute-restarts M: condition compute-restarts
[ delegate compute-restarts ] keep [ error>> compute-restarts ]
[ condition-restarts ] keep [
condition-continuation [ restarts>> ]
[ <restart> ] curry { } assoc>map [ condition-continuation [ <restart> ] curry ] bi
append ; { } assoc>map
] bi append ;

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

@ -2,11 +2,11 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words ; byte-arrays bit-arrays float-arrays combinators words sets ;
IN: cpu.architecture IN: cpu.architecture
! A pseudo-register class for parameters spilled on the stack ! A pseudo-register class for parameters spilled on the stack
TUPLE: stack-params ; SINGLETON: stack-params
! Return values of this class go here ! Return values of this class go here
GENERIC: return-reg ( register-class -- reg ) GENERIC: return-reg ( register-class -- reg )
@ -56,7 +56,7 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- ) HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not ! Test if vreg is 'f' or not
HOOK: %jump-t cpu ( label -- ) HOOK: %jump-f cpu ( label -- )
HOOK: %dispatch cpu ( -- ) HOOK: %dispatch cpu ( -- )

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

@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ; M: ppc %jump-label ( label -- ) B ;
M: ppc %jump-t ( label -- ) M: ppc %jump-f ( label -- )
0 "flag" operand f v>operand CMPI BNE ; 0 "flag" operand f v>operand CMPI BEQ ;
M: ppc %dispatch ( -- ) M: ppc %dispatch ( -- )
[ [
@ -146,11 +146,19 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ; M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
: STF float-regs-size 4 = [ STFS ] [ STFD ] if ; GENERIC: STF ( src dst off reg-class -- )
M: single-float-regs STF drop STFS ;
M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ; M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
: LF float-regs-size 4 = [ LFS ] [ LFD ] if ; GENERIC: LF ( dst src off reg-class -- )
M: single-float-regs LF drop LFS ;
M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ; M: float-regs %load-param-reg >r 1 rot local@ r> LF ;

20
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics
2array define-if-intrinsics ; 2array define-if-intrinsics ;
{ {
{ fixnum< BLT } { fixnum< BGE }
{ fixnum<= BLE } { fixnum<= BGT }
{ fixnum> BGT } { fixnum> BLE }
{ fixnum>= BGE } { fixnum>= BLT }
{ eq? BEQ } { eq? BNE }
} [ } [
first2 define-fixnum-jump first2 define-fixnum-jump
] each ] each
@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics
{ { float "x" } { float "y" } } define-if-intrinsic ; { { float "x" } { float "y" } } define-if-intrinsic ;
{ {
{ float< BLT } { float< BGE }
{ float<= BLE } { float<= BGT }
{ float> BGT } { float> BLE }
{ float>= BGE } { float>= BLT }
{ float= BEQ } { float= BNE }
} [ } [
first2 define-float-jump first2 define-float-jump
] each ] each

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

@ -16,7 +16,6 @@ IN: cpu.x86.32
M: x86.32 ds-reg ESI ; M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ; M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ; M: x86.32 stack-reg ESP ;
M: x86.32 xt-reg ECX ;
M: x86.32 stack-save-reg EDX ; M: x86.32 stack-save-reg EDX ;
M: temp-reg v>operand drop EBX ; M: temp-reg v>operand drop EBX ;
@ -155,7 +154,7 @@ M: x86.32 %box ( n reg-class func -- )
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C. #! boxing a parameter being passed to a callback from C.
[ [
T{ int-regs } box@ int-regs box@
EDX over stack@ MOV EDX over stack@ MOV
EAX swap cell - stack@ MOV EAX swap cell - stack@ MOV
] when* ] when*
@ -246,9 +245,8 @@ M: x86.32 %cleanup ( alien-node -- )
} { } {
[ dup return>> large-struct? ] [ dup return>> large-struct? ]
[ drop EAX PUSH ] [ drop EAX PUSH ]
} {
[ t ] [ drop ]
} }
[ drop ]
} cond ; } cond ;
M: x86.32 %unwind ( n -- ) %epilogue-later RET ; M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
@ -268,7 +266,7 @@ os windows? [
EDX 26 SHR EDX 26 SHR
EDX 1 AND EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each { EAX EBX ECX EDX } [ POP ] each
JNE JE
] { } define-if-intrinsic ] { } define-if-intrinsic
"-no-sse2" cli-args member? [ "-no-sse2" cli-args member? [

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

@ -11,7 +11,6 @@ IN: cpu.x86.64
M: x86.64 ds-reg R14 ; M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ; M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ; M: x86.64 stack-reg RSP ;
M: x86.64 xt-reg RCX ;
M: x86.64 stack-save-reg RSI ; M: x86.64 stack-save-reg RSI ;
M: temp-reg v>operand drop RBX ; M: temp-reg v>operand drop RBX ;
@ -65,7 +64,7 @@ M: x86.64 %unbox ( n reg-class func -- )
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: x86.64 %unbox-long-long ( n func -- ) M: x86.64 %unbox-long-long ( n func -- )
T{ int-regs } swap %unbox ; int-regs swap %unbox ;
M: x86.64 %unbox-struct-1 ( -- ) M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI. #! Alien must be in RDI.
@ -103,7 +102,7 @@ M: x86.64 %box ( n reg-class func -- )
f %alien-invoke ; f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- ) M: x86.64 %box-long-long ( n func -- )
T{ int-regs } swap %box ; int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ; M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
@ -170,7 +169,7 @@ USE: cpu.x86.intrinsics
! The ABI for passing structs by value is pretty messed up ! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type << "void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >> stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs ) : struct-types&offset ( struct-type -- pairs )
struct-type-fields [ struct-type-fields [
@ -192,7 +191,7 @@ M: struct-type flatten-value-type ( type -- seq )
] [ ] [
struct-types&offset split-struct [ struct-types&offset split-struct [
[ c-type c-type-reg-class ] map [ c-type c-type-reg-class ] map
T{ int-regs } swap member? int-regs swap member?
"void*" "double" ? c-type , "void*" "double" ? c-type ,
] each ] each
] if ; ] if ;

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

@ -1,4 +1,4 @@
! 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 alien.compiler arrays USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math cpu.x86.assembler cpu.architecture kernel kernel.private math
@ -9,7 +9,6 @@ IN: cpu.x86.architecture
HOOK: ds-reg cpu HOOK: ds-reg cpu
HOOK: rs-reg cpu HOOK: rs-reg cpu
HOOK: stack-reg cpu HOOK: stack-reg cpu
HOOK: xt-reg cpu
HOOK: stack-save-reg cpu HOOK: stack-save-reg cpu
: stack@ stack-reg swap [+] ; : stack@ stack-reg swap [+] ;
@ -22,7 +21,11 @@ M: rs-loc v>operand rs-loc-n rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ; M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ; M: int-regs %load-param-reg drop swap stack@ MOV ;
: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ; GENERIC: MOVSS/D ( dst src reg-class -- )
M: single-float-regs MOVSS/D drop MOVSS ;
M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
@ -43,13 +46,13 @@ M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ; 3 cells + 16 align cell - ;
M: x86 %save-word-xt ( -- ) M: x86 %save-word-xt ( -- )
xt-reg 0 MOV rc-absolute-cell rel-this ; temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ; : factor-area-size 4 cells ;
M: x86 %prologue ( n -- ) M: x86 %prologue ( n -- )
dup cell + PUSH dup cell + PUSH
xt-reg PUSH temp-reg v>operand PUSH
stack-reg swap 2 cells - SUB ; stack-reg swap 2 cells - SUB ;
M: x86 %epilogue ( n -- ) M: x86 %epilogue ( n -- )
@ -72,8 +75,8 @@ M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ; M: x86 %jump-label ( label -- ) JMP ;
M: x86 %jump-t ( label -- ) M: x86 %jump-f ( label -- )
"flag" operand f v>operand CMP JNE ; "flag" operand f v>operand CMP JE ;
: code-alignment ( -- n ) : code-alignment ( -- n )
building get length dup cell align swap - ; building get length dup cell align swap - ;

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

@ -104,7 +104,7 @@ M: indirect extended? indirect-base extended? ;
canonicalize-ESP ; canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect ) : <indirect> ( base index scale displacement -- indirect )
indirect construct-boa dup canonicalize ; indirect boa dup canonicalize ;
: reg-code "register" word-prop 7 bitand ; : reg-code "register" word-prop 7 bitand ;
@ -189,7 +189,7 @@ UNION: operand register indirect ;
{ {
{ [ dup register-128? ] [ drop operand-64? ] } { [ dup register-128? ] [ drop operand-64? ] }
{ [ dup not ] [ drop operand-64? ] } { [ dup not ] [ drop operand-64? ] }
{ [ t ] [ nip operand-64? ] } [ nip operand-64? ]
} cond and ; } cond and ;
: rex.r : rex.r

10
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics
2array define-if-intrinsics ; 2array define-if-intrinsics ;
{ {
{ fixnum< JL } { fixnum< JGE }
{ fixnum<= JLE } { fixnum<= JG }
{ fixnum> JG } { fixnum> JLE }
{ fixnum>= JGE } { fixnum>= JL }
{ eq? JE } { eq? JNE }
} [ } [
first2 define-fixnum-jump first2 define-fixnum-jump
] each ] each

10
core/cpu/x86/sse2/sse2.factor
View File

@ -27,11 +27,11 @@ IN: cpu.x86.sse2
{ { float "x" } { float "y" } } define-if-intrinsic ; { { float "x" } { float "y" } } define-if-intrinsic ;
{ {
{ float< JB } { float< JAE }
{ float<= JBE } { float<= JA }
{ float> JA } { float> JBE }
{ float>= JAE } { float>= JB }
{ float= JE } { float= JNE }
} [ } [
first2 define-float-jump first2 define-float-jump
] each ] each

25
core/debugger/debugger.factor
View File

@ -4,9 +4,9 @@ USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators classes.tuple continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units generic.math io.streams.duplex classes.builtin classes
generic.standard vocabs threads threads.private init compiler.units generic.standard vocabs threads threads.private
kernel.private libc io.encodings ; init kernel.private libc io.encodings accessors ;
IN: debugger IN: debugger
GENERIC: error. ( error -- ) GENERIC: error. ( error -- )
@ -160,7 +160,7 @@ PREDICATE: kernel-error < array
{ {
{ [ dup empty? ] [ drop f ] } { [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] }
{ [ t ] [ second 0 15 between? ] } [ second 0 15 between? ]
} cond ; } cond ;
: kernel-errors : kernel-errors
@ -202,6 +202,12 @@ M: no-method error.
M: no-math-method summary M: no-math-method summary
drop "No suitable arithmetic method" ; drop "No suitable arithmetic method" ;
M: no-next-method summary
drop "Executing call-next-method from least-specific method" ;
M: inconsistent-next-method summary
drop "Executing call-next-method with inconsistent parameters" ;
M: stream-closed-twice summary M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ; drop "Attempt to perform I/O on closed stream" ;
@ -209,7 +215,10 @@ M: check-method summary
drop "Invalid parameters for create-method" ; drop "Invalid parameters for create-method" ;
M: no-tuple-class summary M: no-tuple-class summary
drop "Invalid class for define-constructor" ; drop "BOA constructors can only be defined for tuple classes" ;
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
M: no-cond summary M: no-cond summary
drop "Fall-through in cond" ; drop "Fall-through in cond" ;
@ -223,9 +232,11 @@ M: slice-error error.
M: bounds-error summary drop "Sequence index out of bounds" ; M: bounds-error summary drop "Sequence index out of bounds" ;
M: condition error. delegate error. ; M: condition error. error>> error. ;
M: condition error-help drop f ; M: condition summary error>> summary ;
M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ; M: assert summary drop "Assertion failed" ;

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

@ -12,8 +12,6 @@ $nl
{ $subsection forget } { $subsection forget }
"Definitions can answer a sequence of definitions they directly depend on:" "Definitions can answer a sequence of definitions they directly depend on:"
{ $subsection uses } { $subsection uses }
"When a definition is changed, all definitions which depend on it are notified via a hook:"
{ $subsection redefined* }
"Definitions must implement a few operations used for printing them in source form:" "Definitions must implement a few operations used for printing them in source form:"
{ $subsection synopsis* } { $subsection synopsis* }
{ $subsection definer } { $subsection definer }
@ -108,11 +106,6 @@ HELP: usage
{ $description "Outputs a sequence of definitions that directly call the given definition." } { $description "Outputs a sequence of definitions that directly call the given definition." }
{ $notes "The sequence might include the definition itself, if it is a recursive word." } ; { $notes "The sequence might include the definition itself, if it is a recursive word." } ;
HELP: redefined*
{ $values { "defspec" "a definition specifier" } }
{ $contract "Updates the definition to cope with a callee being redefined." }
$low-level-note ;
HELP: unxref HELP: unxref
{ $values { "defspec" "a definition specifier" } } { $values { "defspec" "a definition specifier" } }
{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." } { $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." }

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

@ -2,26 +2,6 @@ IN: definitions.tests
USING: tools.test generic kernel definitions sequences USING: tools.test generic kernel definitions sequences
compiler.units words ; compiler.units words ;
TUPLE: combination-1 ;
M: combination-1 perform-combination drop [ ] define ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
SYMBOL: generic-1
[
generic-1 T{ combination-1 } define-generic
object \ generic-1 create-method [ ] define
] with-compilation-unit
[ ] [
[
{ combination-1 { object generic-1 } } forget-all
] with-compilation-unit
] unit-test
GENERIC: some-generic ( a -- b ) GENERIC: some-generic ( a -- b )
USE: arrays USE: arrays

14
core/definitions/definitions.factor
View File

@ -5,6 +5,13 @@ USING: kernel sequences namespaces assocs graphs ;
ERROR: no-compilation-unit definition ; ERROR: no-compilation-unit definition ;
SYMBOL: changed-definitions
: changed-definition ( defspec -- )
dup changed-definitions get
[ no-compilation-unit ] unless*
set-at ;
GENERIC: where ( defspec -- loc ) GENERIC: where ( defspec -- loc )
M: object where drop f ; M: object where drop f ;
@ -42,13 +49,6 @@ M: object uses drop f ;
: usage ( defspec -- seq ) \ f or crossref get at keys ; : usage ( defspec -- seq ) \ f or crossref get at keys ;
GENERIC: redefined* ( defspec -- )
M: object redefined* drop ;
: redefined ( defspec -- )
[ crossref get at ] closure [ drop redefined* ] assoc-each ;
: unxref ( defspec -- ) : unxref ( defspec -- )
dup uses crossref get remove-vertex ; dup uses crossref get remove-vertex ;

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

@ -1,5 +1,5 @@
USING: dlists dlists.private kernel tools.test random assocs USING: dlists dlists.private kernel tools.test random assocs
hashtables sequences namespaces sorting debugger io prettyprint sets sequences namespaces sorting debugger io prettyprint
math ; math ;
IN: dlists.tests IN: dlists.tests
@ -79,7 +79,7 @@ IN: dlists.tests
[ dlist-push-all ] keep [ dlist-push-all ] keep
[ dlist-delete-all ] keep [ dlist-delete-all ] keep
dlist>array dlist>array
] 2keep seq-diff assert-same-elements ] 2keep diff assert-same-elements
] unit-test ] unit-test
[ ] [ [ ] [

4
core/dlists/dlists.factor
View File

@ -7,7 +7,7 @@ IN: dlists
TUPLE: dlist front back length ; TUPLE: dlist front back length ;
: <dlist> ( -- obj ) : <dlist> ( -- obj )
dlist construct-empty dlist new
0 >>length ; 0 >>length ;
: dlist-empty? ( dlist -- ? ) front>> not ; : dlist-empty? ( dlist -- ? ) front>> not ;
@ -126,7 +126,7 @@ PRIVATE>
{ {
{ [ over front>> over eq? ] [ drop pop-front* ] } { [ over front>> over eq? ] [ drop pop-front* ] }
{ [ over back>> over eq? ] [ drop pop-back* ] } { [ over back>> over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] } [ unlink-node dec-length ]
} cond ; } cond ;
: delete-node-if* ( dlist quot -- obj/f ? ) : delete-node-if* ( dlist quot -- obj/f ? )

4
core/effects/effects.factor
View File

@ -8,7 +8,7 @@ TUPLE: effect in out terminated? ;
: <effect> ( in out -- effect ) : <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if dup { "*" } sequence= [ drop { } t ] [ f ] if
effect construct-boa ; effect boa ;
: effect-height ( effect -- n ) : effect-height ( effect -- n )
dup effect-out length swap effect-in length - ; dup effect-out length swap effect-in length - ;
@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ;
{ [ dup effect-terminated? ] [ f ] } { [ dup effect-terminated? ] [ f ] }
{ [ 2dup [ effect-in length ] bi@ > ] [ f ] } { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
{ [ t ] [ t ] } [ t ]
} cond 2nip ; } cond 2nip ;
GENERIC: (stack-picture) ( obj -- str ) GENERIC: (stack-picture) ( obj -- str )

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

@ -24,7 +24,7 @@ M: float-array set-nth-unsafe
M: float-array like M: float-array like
drop dup float-array? [ >float-array ] unless ; drop dup float-array? [ >float-array ] unless ;
M: float-array new drop 0.0 <float-array> ; M: float-array new-sequence drop 0.0 <float-array> ;
M: float-array equal? M: float-array equal?
over float-array? [ sequence= ] [ 2drop f ] if ; over float-array? [ sequence= ] [ 2drop f ] if ;

4
core/float-vectors/float-vectors.factor
View File

@ -7,7 +7,7 @@ IN: float-vectors
<PRIVATE <PRIVATE
: float-array>vector ( float-array length -- float-vector ) : float-array>vector ( float-array length -- float-vector )
float-vector construct-boa ; inline float-vector boa ; inline
PRIVATE> PRIVATE>
@ -22,7 +22,7 @@ M: float-vector like
[ dup length float-array>vector ] [ >float-vector ] if [ dup length float-array>vector ] [ >float-vector ] if
] unless ; ] unless ;
M: float-vector new M: float-vector new-sequence
drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ; drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;
M: float-vector equal? M: float-vector equal?

1
core/float-vectors/summary.txt Normal file
View File

@ -0,0 +1 @@
Growable float arrays

1
core/float-vectors/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

12
core/generator/fixup/fixup.factor
View File

@ -10,7 +10,7 @@ IN: generator.fixup
TUPLE: frame-required n ; TUPLE: frame-required n ;
: frame-required ( n -- ) \ frame-required construct-boa , ; : frame-required ( n -- ) \ frame-required boa , ;
: stack-frame-size ( code -- n ) : stack-frame-size ( code -- n )
no-stack-frame [ no-stack-frame [
@ -25,7 +25,7 @@ GENERIC: fixup* ( frame-size obj -- frame-size )
TUPLE: label offset ; TUPLE: label offset ;
: <label> ( -- label ) label construct-empty ; : <label> ( -- label ) label new ;
M: label fixup* M: label fixup*
compiled-offset swap set-label-offset ; compiled-offset swap set-label-offset ;
@ -40,8 +40,8 @@ M: label fixup*
M: word fixup* M: word fixup*
{ {
{ %prologue-later [ dup [ %prologue ] if-stack-frame ] } { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
{ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] } { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ; } case ;
SYMBOL: relocation-table SYMBOL: relocation-table
@ -74,7 +74,7 @@ SYMBOL: label-table
TUPLE: label-fixup label class ; TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup construct-boa , ; : label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup* M: label-fixup fixup*
dup label-fixup-class rc-absolute? dup label-fixup-class rc-absolute?
@ -84,7 +84,7 @@ M: label-fixup fixup*
TUPLE: rel-fixup arg class type ; TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup construct-boa , ; : rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: (rel-fixup) ( arg class type offset -- pair ) : (rel-fixup) ( arg class type offset -- pair )
pick rc-absolute-cell = cell 4 ? - pick rc-absolute-cell = cell 4 ? -

18
core/generator/generator.factor
View File

@ -16,7 +16,7 @@ SYMBOL: compiled
{ [ dup compiled get key? ] [ drop ] } { [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] } { [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] } { [ dup primitive? ] [ drop ] }
{ [ t ] [ dup compile-queue get set-at ] } [ dup compile-queue get set-at ]
} cond ; } cond ;
: maybe-compile ( word -- ) : maybe-compile ( word -- )
@ -131,14 +131,14 @@ M: #loop generate-node
: generate-if ( node label -- next ) : generate-if ( node label -- next )
<label> [ <label> [
>r >r node-children first2 generate-branch >r >r node-children first2 swap generate-branch
r> r> end-false-branch resolve-label r> r> end-false-branch resolve-label
generate-branch generate-branch
init-templates init-templates
] keep resolve-label iterate-next ; ] keep resolve-label iterate-next ;
M: #if generate-node M: #if generate-node
[ <label> dup %jump-t ] [ <label> dup %jump-f ]
H{ { +input+ { { f "flag" } } } } H{ { +input+ { { f "flag" } } } }
with-template with-template
generate-if ; generate-if ;
@ -189,20 +189,20 @@ M: #dispatch generate-node
"if-intrinsics" set-word-prop ; "if-intrinsics" set-word-prop ;
: if>boolean-intrinsic ( quot -- ) : if>boolean-intrinsic ( quot -- )
"true" define-label "false" define-label
"end" define-label "end" define-label
"true" get swap call "false" get swap call
f "if-scratch" get load-literal
"end" get %jump-label
"true" resolve-label
t "if-scratch" get load-literal t "if-scratch" get load-literal
"end" get %jump-label
"false" resolve-label
f "if-scratch" get load-literal
"end" resolve-label "end" resolve-label
"if-scratch" get phantom-push ; inline "if-scratch" get phantom-push ; inline
: define-if>boolean-intrinsics ( word intrinsics -- ) : define-if>boolean-intrinsics ( word intrinsics -- )
[ [
>r [ if>boolean-intrinsic ] curry r> >r [ if>boolean-intrinsic ] curry r>
{ { f "if-scratch" } } +scratch+ associate union { { f "if-scratch" } } +scratch+ associate assoc-union
] assoc-map "intrinsics" set-word-prop ; ] assoc-map "intrinsics" set-word-prop ;
: define-if-intrinsics ( word intrinsics -- ) : define-if-intrinsics ( word intrinsics -- )

203
core/generator/registers/registers.factor
View File

@ -3,7 +3,8 @@
USING: arrays assocs classes classes.private classes.algebra USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays ; words effects alien byte-arrays bit-arrays float-arrays
accessors sets ;
IN: generator.registers IN: generator.registers
SYMBOL: +input+ SYMBOL: +input+
@ -13,9 +14,11 @@ SYMBOL: +clobber+
SYMBOL: known-tag SYMBOL: known-tag
! Register classes ! Register classes
TUPLE: int-regs ; SINGLETON: int-regs
SINGLETON: single-float-regs
TUPLE: float-regs size ; SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
<PRIVATE <PRIVATE
@ -48,13 +51,13 @@ M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ; M: value lazy-store 2drop ;
! A scratch register for computations ! A scratch register for computations
TUPLE: vreg n ; TUPLE: vreg n reg-class ;
: <vreg> ( n reg-class -- vreg ) C: <vreg> vreg ( n reg-class -- vreg )
{ set-vreg-n set-delegate } vreg construct ;
M: vreg v>operand dup vreg-n swap vregs nth ; M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ; M: vreg live-vregs* , ;
M: vreg move-spec reg-class>> move-spec ;
INSTANCE: vreg value INSTANCE: vreg value
@ -62,9 +65,7 @@ M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ; M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling ! Temporary register for stack shuffling
TUPLE: temp-reg ; SINGLETON: temp-reg
: temp-reg T{ temp-reg T{ int-regs } } ;
M: temp-reg move-spec drop f ; M: temp-reg move-spec drop f ;
@ -73,7 +74,7 @@ INSTANCE: temp-reg value
! A data stack location. ! A data stack location.
TUPLE: ds-loc n class ; TUPLE: ds-loc n class ;
: <ds-loc> { set-ds-loc-n } ds-loc construct ; : <ds-loc> f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ; M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ; M: ds-loc operand-class* ds-loc-class ;
@ -84,8 +85,7 @@ M: ds-loc live-loc?
! A retain stack location. ! A retain stack location.
TUPLE: rs-loc n class ; TUPLE: rs-loc n class ;
: <rs-loc> { set-rs-loc-n } rs-loc construct ; : <rs-loc> f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ; M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ; M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc? M: rs-loc live-loc?
@ -126,7 +126,7 @@ INSTANCE: cached value
TUPLE: tagged vreg class ; TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged ) : <tagged> ( vreg -- tagged )
{ set-tagged-vreg } tagged construct ; f tagged boa ;
M: tagged v>operand tagged-vreg v>operand ; M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ; M: tagged set-operand-class set-tagged-class ;
@ -193,7 +193,7 @@ INSTANCE: constant value
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] } { [ dup byte-array class< ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] } { [ dup bit-array class< ] [ drop %unbox-byte-array ] }
{ [ dup float-array class< ] [ drop %unbox-byte-array ] } { [ dup float-array class< ] [ drop %unbox-byte-array ] }
{ [ t ] [ drop %unbox-any-c-ptr ] } [ drop %unbox-any-c-ptr ]
} cond ; inline } cond ; inline
: %move-via-temp ( dst src -- ) : %move-via-temp ( dst src -- )
@ -228,48 +228,44 @@ INSTANCE: constant value
} case ; } case ;
! A compile-time stack ! A compile-time stack
TUPLE: phantom-stack height ; TUPLE: phantom-stack height stack ;
M: phantom-stack clone
call-next-method [ clone ] change-stack ;
GENERIC: finalize-height ( stack -- ) GENERIC: finalize-height ( stack -- )
SYMBOL: phantom-d : new-phantom-stack ( class -- stack )
SYMBOL: phantom-r >r 0 V{ } clone r> boa ; inline
: <phantom-stack> ( class -- stack )
>r
V{ } clone 0
{ set-delegate set-phantom-stack-height }
phantom-stack construct
r> construct-delegate ;
: (loc) : (loc)
#! Utility for methods on <loc> #! Utility for methods on <loc>
phantom-stack-height - ; height>> - ;
: (finalize-height) ( stack word -- ) : (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the #! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing #! last moment, and we emit the final height changing
#! instruction here. #! instruction here.
swap [ [
phantom-stack-height over zero? [ 2drop ] [ execute ] if 0
dup zero? [ 2drop ] [ swap execute ] if ] curry change-height drop ; inline
0
] keep set-phantom-stack-height ; inline
GENERIC: <loc> ( n stack -- loc ) GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack ; TUPLE: phantom-datastack < phantom-stack ;
: <phantom-datastack> phantom-datastack <phantom-stack> ; : <phantom-datastack> ( -- stack )
phantom-datastack new-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ; M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ; \ %inc-d (finalize-height) ;
TUPLE: phantom-retainstack ; TUPLE: phantom-retainstack < phantom-stack ;
: <phantom-retainstack> phantom-retainstack <phantom-stack> ; : <phantom-retainstack> ( -- stack )
phantom-retainstack new-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ; M: phantom-retainstack <loc> (loc) <rs-loc> ;
@ -281,34 +277,33 @@ M: phantom-retainstack finalize-height
>r <reversed> r> [ <loc> ] curry map ; >r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs ) : phantom-locs* ( phantom -- locs )
dup length swap phantom-locs ; [ stack>> length ] keep phantom-locs ;
: phantoms ( -- phantom phantom )
phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- ) : (each-loc) ( phantom quot -- )
>r dup phantom-locs* swap r> 2each ; inline >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- ) : each-loc ( quot -- )
>r phantom-d get r> phantom-r get over phantoms 2array swap [ (each-loc) ] curry each ; inline
>r >r (each-loc) r> r> (each-loc) ; inline
: adjust-phantom ( n phantom -- ) : adjust-phantom ( n phantom -- )
[ phantom-stack-height + ] keep set-phantom-stack-height ; swap [ + ] curry change-height drop ;
GENERIC: cut-phantom ( n phantom -- seq ) : cut-phantom ( n phantom -- seq )
swap [ cut* swap ] curry change-stack drop ;
M: phantom-stack cut-phantom
[ delegate swap cut* swap ] keep set-delegate ;
: phantom-append ( seq stack -- ) : phantom-append ( seq stack -- )
over length over adjust-phantom push-all ; over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- ) : add-locs ( n phantom -- )
2dup length <= [ 2dup stack>> length <= [
2drop 2drop
] [ ] [
[ phantom-locs ] keep [ phantom-locs ] keep
[ length head-slice* ] keep [ stack>> length head-slice* ] keep
[ append >vector ] keep [ append >vector ] change-stack drop
delegate set-delegate
] if ; ] if ;
: phantom-input ( n phantom -- seq ) : phantom-input ( n phantom -- seq )
@ -316,18 +311,16 @@ M: phantom-stack cut-phantom
2dup cut-phantom 2dup cut-phantom
>r >r neg r> adjust-phantom r> ; >r >r neg r> adjust-phantom r> ;
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: each-phantom ( quot -- ) phantoms rot bi@ ; inline : each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ; : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq ) : live-vregs ( -- seq )
[ [ [ live-vregs* ] each ] each-phantom ] { } make ; [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq ) : (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved #! Discard locs which haven't moved
dup phantom-locs* swap 2array flip [ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset [ live-loc? ] assoc-subset
values ; values ;
@ -340,15 +333,14 @@ SYMBOL: fresh-objects
! Computing free registers and initializing allocator ! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class ) : reg-spec>class ( spec -- class )
float eq? float eq? double-float-regs int-regs ? ;
T{ float-regs f 8 } T{ int-regs } ? ;
: free-vregs ( reg-class -- seq ) : free-vregs ( reg-class -- seq )
#! Free vregs in a given register class #! Free vregs in a given register class
\ free-vregs get at ; \ free-vregs get at ;
: alloc-vreg ( spec -- reg ) : alloc-vreg ( spec -- reg )
dup reg-spec>class free-vregs pop swap { [ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] } { f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] } { unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] } { unboxed-byte-array [ <unboxed-byte-array> ] }
@ -363,19 +355,19 @@ SYMBOL: fresh-objects
{ [ dup unboxed-c-ptr eq? ] [ { [ dup unboxed-c-ptr eq? ] [
over { unboxed-byte-array unboxed-alien } member? over { unboxed-byte-array unboxed-alien } member?
] } ] }
{ [ t ] [ f ] } [ f ]
} cond 2nip ; } cond 2nip ;
: allocation ( value spec -- reg-class ) : allocation ( value spec -- reg-class )
{ {
{ [ dup quotation? ] [ 2drop f ] } { [ dup quotation? ] [ 2drop f ] }
{ [ 2dup compatible? ] [ 2drop f ] } { [ 2dup compatible? ] [ 2drop f ] }
{ [ t ] [ nip reg-spec>class ] } [ nip reg-spec>class ]
} cond ; } cond ;
: alloc-vreg-for ( value spec -- vreg ) : alloc-vreg-for ( value spec -- vreg )
swap operand-class swap alloc-vreg alloc-vreg swap operand-class
dup tagged? [ tuck set-tagged-class ] [ nip ] if ; over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load) M: value (lazy-load)
2dup allocation [ 2dup allocation [
@ -387,13 +379,13 @@ M: value (lazy-load)
: (compute-free-vregs) ( used class -- vector ) : (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'. #! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep [ vregs length reverse ] keep
[ <vreg> ] curry map seq-diff [ <vreg> ] curry map diff
>vector ; >vector ;
: compute-free-vregs ( -- ) : compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable. #! Create a new hashtable for thee free-vregs variable.
live-vregs live-vregs
{ T{ int-regs } T{ float-regs f 8 } } { int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc [ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set \ free-vregs set
drop ; drop ;
@ -418,7 +410,7 @@ M: loc lazy-store
#! When shuffling more values than can fit in registers, we #! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in #! need to find an area on the data stack which isn't in
#! use. #! use.
dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ; [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n ) : find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced #! Find an area of the data stack which is not referenced
@ -427,7 +419,7 @@ M: loc lazy-store
: slow-shuffle-mapping ( locs tmp -- pairs ) : slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r> >r dup length r>
[ swap - <ds-loc> ] curry map 2array flip ; [ swap - <ds-loc> ] curry map zip ;
: slow-shuffle ( locs -- ) : slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle #! We don't have enough free registers to load all shuffle
@ -442,7 +434,7 @@ M: loc lazy-store
: fast-shuffle? ( live-locs -- ? ) : fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all #! Test if we have enough free registers to load all
#! shuffle inputs at once. #! shuffle inputs at once.
T{ int-regs } free-vregs [ length ] bi@ <= ; int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- ) : finalize-locs ( -- )
#! Perform any deferred stack shuffling. #! Perform any deferred stack shuffling.
@ -462,13 +454,13 @@ M: loc lazy-store
#! Kill register assignments but preserve constants and #! Kill register assignments but preserve constants and
#! class information. #! class information.
dup phantom-locs* dup phantom-locs*
over [ over stack>> [
dup constant? [ nip ] [ dup constant? [ nip ] [
operand-class over set-operand-class operand-class over set-operand-class
] if ] if
] 2map ] 2map
over delete-all over stack>> delete-all
swap push-all ; swap stack>> push-all ;
: reset-phantoms ( -- ) : reset-phantoms ( -- )
[ reset-phantom ] each-phantom ; [ reset-phantom ] each-phantom ;
@ -483,10 +475,11 @@ M: loc lazy-store
! Loading stacks to vregs ! Loading stacks to vregs
: free-vregs? ( int# float# -- ? ) : free-vregs? ( int# float# -- ? )
T{ float-regs f 8 } free-vregs length <= double-float-regs free-vregs length <=
>r T{ int-regs } free-vregs length <= r> and ; >r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' ) : phantom&spec ( phantom spec -- phantom' spec' )
>r stack>> r>
[ length f pad-left ] keep [ length f pad-left ] keep
[ <reversed> ] bi@ ; inline [ <reversed> ] bi@ ; inline
@ -504,7 +497,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- ) : substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map [ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable [ substitute-vreg? ] assoc-subset >hashtable
[ substitute-here ] curry each-phantom ; [ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- ) : set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ; >r dup constant? [ constant-value ] when r> set ;
@ -516,14 +509,15 @@ M: loc lazy-store
substitute-vregs ; substitute-vregs ;
: load-inputs ( -- ) : load-inputs ( -- )
+input+ get dup length phantom-d get phantom-input +input+ get
swap lazy-load ; [ length phantom-datastack get phantom-input ] keep
lazy-load ;
: output-vregs ( -- seq seq ) : output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] bi@ ; +output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? ) : clash? ( seq -- ? )
phantoms append [ phantoms [ stack>> ] bi@ append [
dup cached? [ cached-vreg ] when swap member? dup cached? [ cached-vreg ] when swap member?
] with contains? ; ] with contains? ;
@ -534,22 +528,21 @@ M: loc lazy-store
: count-input-vregs ( phantom spec -- ) : count-input-vregs ( phantom spec -- )
phantom&spec [ phantom&spec [
>r dup cached? [ cached-vreg ] when r> allocation >r dup cached? [ cached-vreg ] when r> first allocation
] 2map count-vregs ; ] 2map count-vregs ;
: count-scratch-regs ( spec -- ) : count-scratch-regs ( spec -- )
[ first reg-spec>class ] map count-vregs ; [ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# ) : guess-vregs ( dinput rinput scratch -- int# float# )
H{ [
{ T{ int-regs } 0 } 0 int-regs set
{ T{ float-regs 8 } 0 } 0 double-float-regs set
} clone [
count-scratch-regs count-scratch-regs
phantom-r get swap count-input-vregs phantom-retainstack get swap count-input-vregs
phantom-d get swap count-input-vregs phantom-datastack get swap count-input-vregs
T{ int-regs } get T{ float-regs 8 } get int-regs get double-float-regs get
] bind ; ] with-scope ;
: alloc-scratch ( -- ) : alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ; +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
@ -566,7 +559,7 @@ M: loc lazy-store
outputs-clash? [ finalize-contents ] when ; outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- ) : template-outputs ( -- )
+output+ get [ get ] map phantom-d get phantom-append ; +output+ get [ get ] map phantom-datastack get phantom-append ;
: value-matches? ( value spec -- ? ) : value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal #! If the spec is a quotation and the value is a literal
@ -581,12 +574,6 @@ M: loc lazy-store
2drop t 2drop t
] if ; ] if ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;
: class-tag ( class -- tag/f ) : class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ; class-tags dup length 1 = [ first ] [ drop f ] if ;
@ -602,7 +589,7 @@ M: loc lazy-store
>r >r operand-class 2 r> ?nth class-matches? r> and ; >r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? ) : template-matches? ( spec -- ? )
phantom-d get +input+ rot at phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ; [ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- ) : ensure-template-vregs ( -- )
@ -611,14 +598,14 @@ M: loc lazy-store
] unless ; ] unless ;
: clear-phantoms ( -- ) : clear-phantoms ( -- )
[ delete-all ] each-phantom ; [ stack>> delete-all ] each-phantom ;
PRIVATE> PRIVATE>
: set-operand-classes ( classes -- ) : set-operand-classes ( classes -- )
phantom-d get phantom-datastack get
over length over add-locs over length over add-locs
[ set-operand-class ] 2reverse-each ; stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- ) : end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the #! Commit all deferred stacking shuffling, and ensure the
@ -627,7 +614,7 @@ PRIVATE>
finalize-contents finalize-contents
clear-phantoms clear-phantoms
finalize-heights finalize-heights
fresh-objects get dup empty? swap delete-all [ %gc ] unless ; fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- ) : with-template ( quot hash -- )
clone [ clone [
@ -647,16 +634,16 @@ PRIVATE>
: init-templates ( -- ) : init-templates ( -- )
#! Initialize register allocator. #! Initialize register allocator.
V{ } clone fresh-objects set V{ } clone fresh-objects set
<phantom-datastack> phantom-d set <phantom-datastack> phantom-datastack set
<phantom-retainstack> phantom-r set <phantom-retainstack> phantom-retainstack set
compute-free-vregs ; compute-free-vregs ;
: copy-templates ( -- ) : copy-templates ( -- )
#! Copies register allocator state, used when compiling #! Copies register allocator state, used when compiling
#! branches. #! branches.
fresh-objects [ clone ] change fresh-objects [ clone ] change
phantom-d [ clone ] change phantom-datastack [ clone ] change
phantom-r [ clone ] change phantom-retainstack [ clone ] change
compute-free-vregs ; compute-free-vregs ;
: find-template ( templates -- pair/f ) : find-template ( templates -- pair/f )
@ -672,17 +659,17 @@ UNION: immediate fixnum POSTPONE: f ;
operand-class immediate class< ; operand-class immediate class< ;
: phantom-push ( obj -- ) : phantom-push ( obj -- )
1 phantom-d get adjust-phantom 1 phantom-datastack get adjust-phantom
phantom-d get push ; phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- ) : phantom-shuffle ( shuffle -- )
[ effect-in length phantom-d get phantom-input ] keep [ effect-in length phantom-datastack get phantom-input ] keep
shuffle* phantom-d get phantom-append ; shuffle* phantom-datastack get phantom-append ;
: phantom->r ( n -- ) : phantom->r ( n -- )
phantom-d get phantom-input phantom-datastack get phantom-input
phantom-r get phantom-append ; phantom-retainstack get phantom-append ;
: phantom-r> ( n -- ) : phantom-r> ( n -- )
phantom-r get phantom-input phantom-retainstack get phantom-input
phantom-d get phantom-append ; phantom-datastack get phantom-append ;

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

@ -37,6 +37,8 @@ $nl
{ $subsection create-method } { $subsection create-method }
"Method definitions can be looked up:" "Method definitions can be looked up:"
{ $subsection method } { $subsection method }
"Finding the most specific method for an object:"
{ $subsection effective-method }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:" "A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors } { $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:" "Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@ -64,6 +66,19 @@ $nl
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation." "The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
{ $see-also "generic-introspection" } ; { $see-also "generic-introspection" } ;
ARTICLE: "call-next-method" "Calling less-specific methods"
"If a generic word is called with an object and multiple methods specialize on classes that this object is an instance of, usually the most specific method is called (" { $link "method-order" } ")."
$nl
"Less-specific methods can be called directly:"
{ $subsection POSTPONE: call-next-method }
"A lower-level word which the above expands into:"
{ $subsection (call-next-method) }
"To look up the next applicable method reflectively:"
{ $subsection next-method }
"Errors thrown by improper calls to " { $link POSTPONE: call-next-method } ":"
{ $subsection inconsistent-next-method }
{ $subsection no-next-method } ;
ARTICLE: "generic" "Generic words and methods" ARTICLE: "generic" "Generic words and methods"
"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition." "A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition."
$nl $nl
@ -81,6 +96,7 @@ $nl
{ $subsection POSTPONE: M: } { $subsection POSTPONE: M: }
"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "." "Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "."
{ $subsection "method-order" } { $subsection "method-order" }
{ $subsection "call-next-method" }
{ $subsection "generic-introspection" } { $subsection "generic-introspection" }
{ $subsection "method-combination" } { $subsection "method-combination" }
"Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ; "Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ;
@ -147,3 +163,8 @@ HELP: forget-methods
{ $description "Remove all method definitions which specialize on the class." } ; { $description "Remove all method definitions which specialize on the class." } ;
{ sort-classes order } related-words { sort-classes order } related-words
HELP: (call-next-method)
{ $values { "class" class } { "generic" generic } }
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;

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

@ -123,17 +123,6 @@ M: integer wii drop 6 ;
[ 3 ] [ T{ first-one } wii ] unit-test [ 3 ] [ T{ first-one } wii ] unit-test
! Hooks
SYMBOL: my-var
HOOK: my-hook my-var ( -- x )
M: integer my-hook "an integer" ;
M: string my-hook "a string" ;
[ "an integer" ] [ 3 my-var set my-hook ] unit-test
[ "a string" ] [ my-hook my-var set my-hook ] unit-test
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
GENERIC: tag-and-f ( x -- x x ) GENERIC: tag-and-f ( x -- x x )
M: fixnum tag-and-f 1 ; M: fixnum tag-and-f 1 ;

9
core/generic/generic.factor
View File

@ -29,6 +29,8 @@ PREDICATE: method-spec < pair
: order ( generic -- seq ) : order ( generic -- seq )
"methods" word-prop keys sort-classes ; "methods" word-prop keys sort-classes ;
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f ) : next-method-class ( class generic -- class/f )
order [ class< ] with subset reverse dup length 1 = order [ class< ] with subset reverse dup length 1 =
[ drop f ] [ second ] if ; [ drop f ] [ second ] if ;
@ -36,7 +38,10 @@ PREDICATE: method-spec < pair
: next-method ( class generic -- class/f ) : next-method ( class generic -- class/f )
[ next-method-class ] keep method ; [ next-method-class ] keep method ;
GENERIC: next-method-quot ( class generic -- quot ) GENERIC: next-method-quot* ( class generic -- quot )
: next-method-quot ( class generic -- quot )
dup "combination" word-prop next-method-quot* ;
: (call-next-method) ( class generic -- ) : (call-next-method) ( class generic -- )
next-method-quot call ; next-method-quot call ;
@ -45,7 +50,7 @@ TUPLE: check-method class generic ;
: check-method ( class generic -- class generic ) : check-method ( class generic -- class generic )
over class? over generic? and [ over class? over generic? and [
\ check-method construct-boa throw \ check-method boa throw
] unless ; inline ] unless ; inline
: with-methods ( generic quot -- ) : with-methods ( generic quot -- )

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

@ -2,7 +2,8 @@
! 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
sequences.private classes classes.algebra definitions ; sequences.private classes classes.builtin classes.algebra
definitions ;
IN: generic.math IN: generic.math
PREDICATE: math-class < class PREDICATE: math-class < class
@ -18,7 +19,7 @@ PREDICATE: math-class < class
{ {
{ [ dup null class< ] [ drop { -1 -1 } ] } { [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] } { [ dup math-class? ] [ class-types last/first ] }
{ [ t ] [ drop { 100 100 } ] } [ drop { 100 100 } ]
} cond ; } cond ;
: math-class-max ( class class -- class ) : math-class-max ( class class -- class )

2
core/generic/standard/engines/engines.factor
View File

@ -47,3 +47,5 @@ SYMBOL: (dispatch#)
} case ; } case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ; : picker ( -- quot ) \ (dispatch#) get (picker) ;
GENERIC: extra-values ( generic -- n )

2
core/generic/standard/engines/predicate/predicate.factor
View File

@ -18,7 +18,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ first second { } ] } { [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] } { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
{ [ t ] [ [ first second ] [ 1 tail-slice ] bi ] } [ [ first second ] [ 1 tail-slice ] bi ]
} cond ; } cond ;
: sort-methods ( assoc -- assoc' ) : sort-methods ( assoc -- assoc' )

118
core/generic/standard/engines/tuple/tuple.factor
View File

@ -1,8 +1,11 @@
IN: generic.standard.engines.tuple ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes.tuple.private hashtables assocs sorting USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines effects namespaces generic generic.standard.engines
classes.algebra math math.private quotations arrays ; classes.algebra math math.private kernel.private
quotations arrays ;
IN: generic.standard.engines.tuple
TUPLE: echelon-dispatch-engine n methods ; TUPLE: echelon-dispatch-engine n methods ;
@ -27,15 +30,8 @@ TUPLE: tuple-dispatch-engine echelons ;
: <tuple-dispatch-engine> ( methods -- engine ) : <tuple-dispatch-engine> ( methods -- engine )
echelon-sort echelon-sort
[ [ dupd <echelon-dispatch-engine> ] assoc-map
over zero? [ \ tuple-dispatch-engine boa ;
dup assoc-empty?
[ drop f ] [ values first ] if
] [
dupd <echelon-dispatch-engine>
] if
] assoc-map [ nip ] assoc-subset
\ tuple-dispatch-engine construct-boa ;
: convert-tuple-methods ( assoc -- assoc' ) : convert-tuple-methods ( assoc -- assoc' )
tuple bootstrap-word tuple bootstrap-word
@ -48,52 +44,51 @@ M: trivial-tuple-dispatch-engine engine>quot
>alist V{ } clone [ hashcode 1array ] distribute-buckets >alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ; [ <trivial-tuple-dispatch-engine> ] map ;
: word-hashcode% [ 1 slot ] % ;
: class-hash-dispatch-quot ( methods -- quot ) : class-hash-dispatch-quot ( methods -- quot )
#! 1 slot == word hashcode
[ [
[ dup 1 slot ] % \ dup ,
word-hashcode%
hash-methods [ engine>quot ] map hash-dispatch-quot % hash-methods [ engine>quot ] map hash-dispatch-quot %
] [ ] make ; ] [ ] make ;
: tuple-dispatch-engine-word-name ( engine -- string ) : engine-word-name ( -- string )
[ generic get word-name "/tuple-dispatch-engine" append ;
generic get word-name %
"/tuple-dispatch-engine/" %
n>> #
] "" make ;
PREDICATE: tuple-dispatch-engine-word < word PREDICATE: engine-word < word
"tuple-dispatch-engine" word-prop ; "tuple-dispatch-generic" word-prop generic? ;
M: tuple-dispatch-engine-word stack-effect M: engine-word stack-effect
"tuple-dispatch-generic" word-prop stack-effect ; "tuple-dispatch-generic" word-prop
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: tuple-dispatch-engine-word crossref? M: engine-word compiled-crossref?
drop t ; drop t ;
: remember-engine ( word -- ) : remember-engine ( word -- )
generic get "engines" word-prop push ; generic get "engines" word-prop push ;
: <tuple-dispatch-engine-word> ( engine -- word ) : <engine-word> ( -- word )
tuple-dispatch-engine-word-name f <word> engine-word-name f <word>
{ dup generic get "tuple-dispatch-generic" set-word-prop ;
[ t "tuple-dispatch-engine" set-word-prop ]
[ generic get "tuple-dispatch-generic" set-word-prop ]
[ remember-engine ]
[ ]
} cleave ;
: define-tuple-dispatch-engine-word ( engine quot -- word ) : define-engine-word ( quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ; >r <engine-word> dup r> define ;
: array-nth% 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare ; inline
: tuple-dispatch-engine-body ( engine -- quot ) : tuple-dispatch-engine-body ( engine -- quot )
#! 1 slot == tuple-layout
#! 2 slot == 0 array-nth
#! 4 slot == layout-superclasses
[ [
picker % picker %
[ 1 slot 4 slot ] % [ tuple-layout-superclasses ] %
[ n>> 2 + , [ slot ] % ] [ n>> array-nth% ]
[ [
methods>> [ methods>> [
<trivial-tuple-dispatch-engine> engine>quot <trivial-tuple-dispatch-engine> engine>quot
@ -104,25 +99,54 @@ M: tuple-dispatch-engine-word crossref?
] [ ] make ; ] [ ] make ;
M: echelon-dispatch-engine engine>quot M: echelon-dispatch-engine engine>quot
dup tuple-dispatch-engine-body dup n>> zero? [
define-tuple-dispatch-engine-word methods>> dup assoc-empty?
1quotation ; [ drop default get ] [ values first engine>quot ] if
] [
[
picker %
[ tuple-layout-superclasses ] %
[ n>> array-nth% ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
] [
class-hash-dispatch-quot
] if-small? %
] bi
] [ ] make
] if ;
: >=-case-quot ( alist -- quot ) : >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
alist>quot ; alist>quot ;
: tuple-layout-echelon ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
5 slot ; inline
: unclip-last [ 1 head* ] [ peek ] bi ;
M: tuple-dispatch-engine engine>quot M: tuple-dispatch-engine engine>quot
#! 1 slot == tuple-layout
#! 5 slot == layout-echelon
[ [
picker % picker %
[ 1 slot 5 slot ] % [ tuple-layout-echelon ] %
echelons>>
[ [
tuple assumed set tuple assumed set
[ engine>quot dup default set ] assoc-map echelons>> dup empty? [
unclip-last
[
[
engine>quot define-engine-word
[ remember-engine ] [ 1quotation ] bi
dup default set
] assoc-map
]
[ first2 engine>quot 2array ] bi*
suffix
] unless
] with-scope ] with-scope
>=-case-quot % >=-case-quot %
] [ ] make ; ] [ ] make ;

40
core/generic/standard/standard-docs.factor
View File

@ -1,4 +1,5 @@
USING: generic help.markup help.syntax sequences ; USING: generic help.markup help.syntax sequences math
math.parser ;
IN: generic.standard IN: generic.standard
HELP: no-method HELP: no-method
@ -10,7 +11,7 @@ HELP: standard-combination
{ $class-description { $class-description
"Performs standard method combination." "Performs standard method combination."
$nl $nl
"Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown." "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. A " { $link no-method } " error is thrown if no suitable method is defined on the class."
} }
{ $examples { $examples
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:" "A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
@ -31,3 +32,38 @@ HELP: define-simple-generic
{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; { $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
{ standard-combination hook-combination } related-words { standard-combination hook-combination } related-words
HELP: no-next-method
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
{ $examples
"The following code throws this error:"
{ $code
"GENERIC: error-test ( object -- )"
""
"M: number error-test 3 + call-next-method ;"
""
"M: integer error-test recip call-next-method ;"
""
"123 error-test"
}
"This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
} ;
HELP: inconsistent-next-method
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
{ $examples
"The following code throws this error:"
{ $code
"GENERIC: error-test ( object -- )"
""
"M: string error-test print ;"
""
"M: integer error-test number>string call-next-method ;"
""
"123 error-test"
}
"This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
$nl
"This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
{ $code "M: integer error-test number>string error-test ;" }
} ;

74
core/generic/standard/standard-tests.factor
View File

@ -1,7 +1,9 @@
IN: generic.standard.tests IN: generic.standard.tests
USING: tools.test math math.functions math.constants USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces ; words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable hashtables sbufs
prettyprint ;
GENERIC: lo-tag-test GENERIC: lo-tag-test
@ -181,22 +183,22 @@ M: ceo salary
[ salary ] must-infer [ salary ] must-infer
[ 24000 ] [ employee construct-boa salary ] unit-test [ 24000 ] [ employee boa salary ] unit-test
[ 24000 ] [ tape-monkey construct-boa salary ] unit-test [ 24000 ] [ tape-monkey boa salary ] unit-test
[ 36000 ] [ junior-manager construct-boa salary ] unit-test [ 36000 ] [ junior-manager boa salary ] unit-test
[ 41000 ] [ middle-manager construct-boa salary ] unit-test [ 41000 ] [ middle-manager boa salary ] unit-test
[ 51000 ] [ senior-manager construct-boa salary ] unit-test [ 51000 ] [ senior-manager boa salary ] unit-test
[ 102000 ] [ executive construct-boa salary ] unit-test [ 102000 ] [ executive boa salary ] unit-test
[ ceo construct-boa salary ] [ ceo boa salary ]
[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with [ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
[ intern construct-boa salary ] [ intern boa salary ]
[ T{ no-next-method f intern salary } = ] must-fail-with [ T{ no-next-method f intern salary } = ] must-fail-with
! Weird shit ! Weird shit
@ -233,3 +235,55 @@ M: c funky* "c" , call-next-method ;
T{ a } funky T{ a } funky
{ { "a" "x" "z" } { "a" "y" "z" } } member? { { "a" "x" "z" } { "a" "y" "z" } } member?
] unit-test ] unit-test
! Hooks
SYMBOL: my-var
HOOK: my-hook my-var ( -- x )
M: integer my-hook "an integer" ;
M: string my-hook "a string" ;
[ "an integer" ] [ 3 my-var set my-hook ] unit-test
[ "a string" ] [ my-hook my-var set my-hook ] unit-test
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
HOOK: my-tuple-hook my-var ( -- x )
M: sequence my-tuple-hook my-hook ;
TUPLE: m-t-h-a ;
M: m-t-h-a my-tuple-hook "foo" ;
TUPLE: m-t-h-b < m-t-h-a ;
M: m-t-h-b my-tuple-hook "bar" ;
[ f ] [
\ my-tuple-hook [ "engines" word-prop ] keep prefix
[ 1quotation infer ] map all-equal?
] unit-test
HOOK: call-next-hooker my-var ( -- x )
M: sequence call-next-hooker "sequence" ;
M: array call-next-hooker call-next-method "array " prepend ;
M: vector call-next-hooker call-next-method "vector " prepend ;
M: growable call-next-hooker call-next-method "growable " prepend ;
[ "vector growable sequence" ] [
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
GENERIC: no-stack-effect-decl
M: hashtable no-stack-effect-decl ;
M: vector no-stack-effect-decl ;
M: sbuf no-stack-effect-decl ;
[ ] [ \ no-stack-effect-decl see ] unit-test
[ ] [ \ no-stack-effect-decl word-def . ] unit-test

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

@ -67,7 +67,9 @@ ERROR: no-method object generic ;
drop generic get "default-method" word-prop 1quotation drop generic get "default-method" word-prop 1quotation
] unless ; ] unless ;
GENERIC: mangle-method ( method generic -- quot ) : mangle-method ( method generic -- quot )
[ 1quotation ] [ extra-values \ drop <repetition> ] bi*
prepend [ ] like ;
: single-combination ( word -- quot ) : single-combination ( word -- quot )
[ [
@ -91,6 +93,26 @@ GENERIC: mangle-method ( method generic -- quot )
} cleave } cleave
] with-scope ; ] with-scope ;
ERROR: inconsistent-next-method class generic ;
ERROR: no-next-method class generic ;
: single-next-method-quot ( class generic -- quot )
[
[ drop [ instance? ] curry % ]
[
2dup next-method
[ 2nip 1quotation ]
[ [ no-next-method ] 2curry ] if* ,
]
[ [ inconsistent-next-method ] 2curry , ]
2tri
\ if ,
] [ ] make ;
: single-effective-method ( obj word -- method )
[ order [ instance? ] with find-last nip ] keep method ;
TUPLE: standard-combination # ; TUPLE: standard-combination # ;
C: <standard-combination> standard-combination C: <standard-combination> standard-combination
@ -107,8 +129,7 @@ PREDICATE: simple-generic < standard-generic
: with-standard ( combination quot -- quot' ) : with-standard ( combination quot -- quot' )
>r #>> (dispatch#) r> with-variable ; inline >r #>> (dispatch#) r> with-variable ; inline
M: standard-generic mangle-method M: standard-generic extra-values drop 0 ;
drop 1quotation ;
M: standard-combination make-default-method M: standard-combination make-default-method
[ empty-method ] with-standard ; [ empty-method ] with-standard ;
@ -118,25 +139,13 @@ M: standard-combination perform-combination
M: standard-combination dispatch# #>> ; M: standard-combination dispatch# #>> ;
ERROR: inconsistent-next-method object class generic ; M: standard-combination next-method-quot*
[
single-next-method-quot picker prepend
] with-standard ;
ERROR: no-next-method class generic ; M: standard-generic effective-method
[ dispatch# (picker) call ] keep single-effective-method ;
M: standard-generic next-method-quot
[
[
[ [ instance? ] curry ]
[ dispatch# (picker) ] bi* prepend %
]
[
2dup next-method
[ 2nip 1quotation ]
[ [ no-next-method ] 2curry ] if* ,
]
[ [ inconsistent-next-method ] 2curry , ]
2tri
\ if ,
] [ ] make ;
TUPLE: hook-combination var ; TUPLE: hook-combination var ;
@ -152,8 +161,11 @@ PREDICATE: hook-generic < generic
M: hook-combination dispatch# drop 0 ; M: hook-combination dispatch# drop 0 ;
M: hook-generic mangle-method M: hook-generic extra-values drop 1 ;
drop 1quotation [ drop ] prepend ;
M: hook-generic effective-method
[ "combination" word-prop var>> get ] keep
single-effective-method ;
M: hook-combination make-default-method M: hook-combination make-default-method
[ error-method ] with-hook ; [ error-method ] with-hook ;
@ -161,6 +173,9 @@ M: hook-combination make-default-method
M: hook-combination perform-combination M: hook-combination perform-combination
[ drop ] [ [ single-combination ] with-hook ] 2bi define ; [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
M: hook-combination next-method-quot*
[ single-next-method-quot ] with-hook ;
M: simple-generic definer drop \ GENERIC: f ; M: simple-generic definer drop \ GENERIC: f ;
M: standard-generic definer drop \ GENERIC# f ; M: standard-generic definer drop \ GENERIC# f ;

22
core/hashtables/hashtables-docs.factor
View File

@ -49,11 +49,7 @@ $nl
ARTICLE: "hashtables.utilities" "Hashtable utilities" ARTICLE: "hashtables.utilities" "Hashtable utilities"
"Utility words to create a new hashtable from a single key/value pair:" "Utility words to create a new hashtable from a single key/value pair:"
{ $subsection associate } { $subsection associate }
{ $subsection ?set-at } { $subsection ?set-at } ;
"The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:"
{ $subsection prune }
"Test if a sequence contains duplicates in linear time:"
{ $subsection all-unique? } ;
ABOUT: "hashtables" ABOUT: "hashtables"
@ -138,22 +134,6 @@ HELP: >hashtable
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } } { $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
{ $description "Constructs a hashtable from any assoc." } ; { $description "Constructs a hashtable from any assoc." } ;
HELP: prune
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
} ;
HELP: all-unique?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." }
{ $example
"USING: hashtables prettyprint ;"
"{ 0 1 1 2 3 5 } all-unique? ."
"f"
} ;
HELP: rehash HELP: rehash
{ $values { "hash" hashtable } } { $values { "hash" hashtable } }
{ $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ; { $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ;

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

@ -164,6 +164,3 @@ H{ } "x" set
[ { "one" "two" 3 } ] [ [ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute { 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test ] unit-test
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test

16
core/hashtables/hashtables.factor
View File

@ -116,7 +116,7 @@ IN: hashtables
PRIVATE> PRIVATE>
: <hashtable> ( n -- hash ) : <hashtable> ( n -- hash )
hashtable construct-empty [ reset-hash ] keep ; hashtable new [ reset-hash ] keep ;
M: hashtable at* ( key hash -- value ? ) M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ; key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
@ -174,18 +174,4 @@ M: hashtable assoc-like
: ?set-at ( value key assoc/f -- assoc ) : ?set-at ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ; [ [ set-at ] keep ] [ associate ] if* ;
: (prune) ( hash vec elt -- )
rot 2dup key?
[ 3drop ] [ dupd dupd set-at swap push ] if ; inline
: prune ( seq -- newseq )
[ length <hashtable> ]
[ length <vector> ]
[ ] tri
[ >r 2dup r> (prune) ] each nip ;
: all-unique? ( seq -- ? )
[ length ]
[ prune length ] bi = ;
INSTANCE: hashtable assoc INSTANCE: hashtable assoc

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

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting ; heaps heaps.private math.parser random assocs sequences sorting
accessors ;
IN: heaps.tests IN: heaps.tests
[ <min-heap> heap-pop ] must-fail [ <min-heap> heap-pop ] must-fail
@ -47,7 +48,7 @@ IN: heaps.tests
: test-entry-indices ( n -- ? ) : test-entry-indices ( n -- ? )
random-alist random-alist
<min-heap> [ heap-push-all ] keep <min-heap> [ heap-push-all ] keep
heap-data dup length swap [ entry-index ] map sequence= ; data>> dup length swap [ entry-index ] map sequence= ;
14 [ 14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test [ t ] swap [ 2^ test-entry-indices ] curry unit-test
@ -63,9 +64,9 @@ IN: heaps.tests
[ [
random-alist random-alist
<min-heap> [ heap-push-all ] keep <min-heap> [ heap-push-all ] keep
dup heap-data clone swap dup data>> clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
heap-data data>>
[ [ entry-key ] map ] bi@ [ [ entry-key ] map ] bi@
[ natural-sort ] bi@ ; [ natural-sort ] bi@ ;

28
core/heaps/heaps.factor
View File

@ -17,22 +17,22 @@ GENERIC: heap-size ( heap -- n )
<PRIVATE <PRIVATE
: heap-data delegate ; inline TUPLE: heap data ;
: <heap> ( class -- heap ) : <heap> ( class -- heap )
>r V{ } clone r> construct-delegate ; inline >r V{ } clone r> boa ; inline
TUPLE: entry value key heap index ; TUPLE: entry value key heap index ;
: <entry> ( value key heap -- entry ) f entry construct-boa ; : <entry> ( value key heap -- entry ) f entry boa ;
PRIVATE> PRIVATE>
TUPLE: min-heap ; TUPLE: min-heap < heap ;
: <min-heap> ( -- min-heap ) min-heap <heap> ; : <min-heap> ( -- min-heap ) min-heap <heap> ;
TUPLE: max-heap ; TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ; : <max-heap> ( -- max-heap ) max-heap <heap> ;
@ -40,10 +40,10 @@ INSTANCE: min-heap priority-queue
INSTANCE: max-heap priority-queue INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? ) M: priority-queue heap-empty? ( heap -- ? )
heap-data empty? ; data>> empty? ;
M: priority-queue heap-size ( heap -- n ) M: priority-queue heap-size ( heap -- n )
heap-data length ; data>> length ;
<PRIVATE <PRIVATE
@ -54,7 +54,7 @@ M: priority-queue heap-size ( heap -- n )
: up ( n -- m ) 1- 2/ ; inline : up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry ) : data-nth ( n heap -- entry )
heap-data nth-unsafe ; inline data>> nth-unsafe ; inline
: up-value ( n heap -- entry ) : up-value ( n heap -- entry )
>r up r> data-nth ; inline >r up r> data-nth ; inline
@ -67,24 +67,24 @@ M: priority-queue heap-size ( heap -- n )
: data-set-nth ( entry n heap -- ) : data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r> >r [ swap set-entry-index ] 2keep r>
heap-data set-nth-unsafe ; data>> set-nth-unsafe ;
: data-push ( entry heap -- n ) : data-push ( entry heap -- n )
dup heap-size [ dup heap-size [
swap 2dup heap-data ensure 2drop data-set-nth swap 2dup data>> ensure 2drop data-set-nth
] keep ; inline ] keep ; inline
: data-pop ( heap -- entry ) : data-pop ( heap -- entry )
heap-data pop ; inline data>> pop ; inline
: data-pop* ( heap -- ) : data-pop* ( heap -- )
heap-data pop* ; inline data>> pop* ; inline
: data-peek ( heap -- entry ) : data-peek ( heap -- entry )
heap-data peek ; inline data>> peek ; inline
: data-first ( heap -- entry ) : data-first ( heap -- entry )
heap-data first ; inline data>> first ; inline
: data-exchange ( m n heap -- ) : data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep [ tuck data-nth >r data-nth r> ] 3keep

1
core/heaps/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

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

@ -1,10 +1,11 @@
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 kernel sequences
kernel.private combinators sequences.private ; kernel.private combinators sequences.private ;
IN: inference.backend
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." }
{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ; { $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
HELP: too-many->r HELP: too-many->r
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." } { $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }

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

@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple ; generic.standard.engines.tuple accessors ;
IN: inference.backend IN: inference.backend
: recursive-label ( word -- label/f ) : recursive-label ( word -- label/f )
@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? )
M: method-body inline? M: method-body inline?
"method-generic" word-prop inline? ; "method-generic" word-prop inline? ;
M: tuple-dispatch-engine-word inline? M: engine-word inline?
"tuple-dispatch-generic" word-prop inline? ; "tuple-dispatch-generic" word-prop inline? ;
M: word inline? M: word inline?
@ -32,18 +32,16 @@ M: word inline?
: recursive-quotation? ( quot -- ? ) : recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ; local-recursive-state [ first eq? ] with contains? ;
TUPLE: inference-error rstate type ; TUPLE: inference-error error type rstate ;
M: inference-error compiler-error-type M: inference-error compiler-error-type type>> ;
inference-error-type ;
M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * ) : (inference-error) ( ... class type -- * )
>r construct-boa r> >r boa r>
recursive-state get { recursive-state get
set-delegate \ inference-error boa throw ; inline
set-inference-error-type
set-inference-error-rstate
} \ inference-error construct throw ; inline
: inference-error ( ... class -- * ) : inference-error ( ... class -- * )
+error+ (inference-error) ; inline +error+ (inference-error) ; inline
@ -132,25 +130,27 @@ TUPLE: too-many->r ;
TUPLE: too-many-r> ; TUPLE: too-many-r> ;
: check-r> ( -- ) : check-r> ( n -- )
meta-r get empty? meta-r get length >
[ \ too-many-r> inference-error ] when ; [ \ too-many-r> inference-error ] when ;
: infer->r ( -- ) : infer->r ( n -- )
1 ensure-values dup ensure-values
#>r #>r
1 0 pick node-inputs over 0 pick node-inputs
pop-d push-r over [ drop pop-d ] map reverse [ push-r ] each
0 1 pick node-outputs 0 pick pick node-outputs
node, ; node,
drop ;
: infer-r> ( -- ) : infer-r> ( n -- )
check-r> dup check-r>
#r> #r>
0 1 pick node-inputs 0 pick pick node-inputs
pop-r push-d over [ drop pop-r ] map reverse [ push-d ] each
1 0 pick node-outputs over 0 pick node-outputs
node, ; node,
drop ;
: undo-infer ( -- ) : undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ; recorded get [ f "inferred-effect" set-word-prop ] each ;
@ -201,18 +201,18 @@ M: object constructor drop f ;
dup infer-uncurry dup infer-uncurry
constructor [ constructor [
peek-d reify-curry peek-d reify-curry
infer->r 1 infer->r
peek-d reify-curry peek-d reify-curry
infer-r> 1 infer-r>
2 1 <effect> swap #call consume/produce 2 1 <effect> swap #call consume/produce
] when* ; ] when* ;
: reify-curries ( n -- ) : reify-curries ( n -- )
meta-d get reverse [ meta-d get reverse [
dup special? [ dup special? [
over [ infer->r ] times over infer->r
dup reify-curry dup reify-curry
over [ infer-r> ] times over infer-r>
] when 2drop ] when 2drop
] 2each ; ] 2each ;
@ -253,7 +253,7 @@ TUPLE: cannot-unify-specials ;
{ [ dup [ curried? ] all? ] [ unify-curries ] } { [ dup [ curried? ] all? ] [ unify-curries ] }
{ [ dup [ composed? ] all? ] [ unify-composed ] } { [ dup [ composed? ] all? ] [ unify-composed ] }
{ [ dup [ special? ] contains? ] [ cannot-unify-specials ] } { [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
{ [ t ] [ drop <computed> ] } [ drop <computed> ]
} cond ; } cond ;
: unify-stacks ( seq -- stack ) : unify-stacks ( seq -- stack )
@ -363,7 +363,7 @@ TUPLE: effect-error word effect ;
\ effect-error inference-error ; \ effect-error inference-error ;
: check-effect ( word effect -- ) : check-effect ( word effect -- )
dup pick "declared-effect" word-prop effect<= dup pick stack-effect effect<=
[ 2drop ] [ effect-error ] if ; [ 2drop ] [ effect-error ] if ;
: finish-word ( word -- ) : finish-word ( word -- )
@ -397,7 +397,7 @@ TUPLE: effect-error word effect ;
{ [ dup "infer" word-prop ] [ custom-infer ] } { [ dup "infer" word-prop ] [ custom-infer ] }
{ [ dup "no-effect" word-prop ] [ no-effect ] } { [ dup "no-effect" word-prop ] [ no-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] } { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
{ [ t ] [ dup infer-word make-call-node ] } [ dup infer-word make-call-node ]
} cond ; } cond ;
TUPLE: recursive-declare-error word ; TUPLE: recursive-declare-error word ;

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes sequences words vectors math.intervals effects classes
inference.state ; inference.state accessors combinators ;
IN: inference.dataflow IN: inference.dataflow
! Computed value ! Computed value
@ -12,7 +12,7 @@ IN: inference.dataflow
TUPLE: value < identity-tuple literal uid recursion ; TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value ) : <value> ( obj -- value )
<computed> recursive-state get value construct-boa ; <computed> recursive-state get value boa ;
M: value hashcode* nip value-uid ; M: value hashcode* nip value-uid ;
@ -39,12 +39,12 @@ M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- ) GENERIC: flatten-curry ( value -- )
M: curried flatten-curry M: curried flatten-curry
dup curried-obj flatten-curry [ obj>> flatten-curry ]
curried-quot flatten-curry ; [ quot>> flatten-curry ] bi ;
M: composed flatten-curry M: composed flatten-curry
dup composed-quot1 flatten-curry [ quot1>> flatten-curry ]
composed-quot2 flatten-curry ; [ quot2>> flatten-curry ] bi ;
M: object flatten-curry , ; M: object flatten-curry , ;
@ -57,31 +57,27 @@ M: object flatten-curry , ;
meta-d get clone flatten-curries ; meta-d get clone flatten-curries ;
: modify-values ( node quot -- ) : modify-values ( node quot -- )
[ swap [ node-in-d swap call ] keep set-node-in-d ] 2keep {
[ swap [ node-in-r swap call ] keep set-node-in-r ] 2keep [ change-in-d ]
[ swap [ node-out-d swap call ] keep set-node-out-d ] 2keep [ change-in-r ]
swap [ node-out-r swap call ] keep set-node-out-r ; inline [ change-out-d ]
[ change-out-r ]
} cleave drop ; inline
: node-shuffle ( node -- shuffle ) : node-shuffle ( node -- shuffle )
dup node-in-d swap node-out-d <effect> ; [ in-d>> ] [ out-d>> ] bi <effect> ;
: make-node ( slots class -- node )
>r node construct r> construct-delegate ; inline
: empty-node ( class -- node )
{ } swap make-node ; inline
: param-node ( param class -- node ) : param-node ( param class -- node )
{ set-node-param } swap make-node ; inline new swap >>param ; inline
: in-node ( seq class -- node ) : in-node ( seq class -- node )
{ set-node-in-d } swap make-node ; inline new swap >>in-d ; inline
: all-in-node ( class -- node ) : all-in-node ( class -- node )
flatten-meta-d swap in-node ; inline flatten-meta-d swap in-node ; inline
: out-node ( seq class -- node ) : out-node ( seq class -- node )
{ set-node-out-d } swap make-node ; inline new swap >>out-d ; inline
: all-out-node ( class -- node ) : all-out-node ( class -- node )
flatten-meta-d swap out-node ; inline flatten-meta-d swap out-node ; inline
@ -94,81 +90,81 @@ M: object flatten-curry , ;
: node-child node-children first ; : node-child node-children first ;
TUPLE: #label word loop? ; TUPLE: #label < node word loop? ;
: #label ( word label -- node ) : #label ( word label -- node )
\ #label param-node [ set-#label-word ] keep ; \ #label param-node swap >>word ;
PREDICATE: #loop < #label #label-loop? ; PREDICATE: #loop < #label #label-loop? ;
TUPLE: #entry ; TUPLE: #entry < node ;
: #entry ( -- node ) \ #entry all-out-node ; : #entry ( -- node ) \ #entry all-out-node ;
TUPLE: #call ; TUPLE: #call < node ;
: #call ( word -- node ) \ #call param-node ; : #call ( word -- node ) \ #call param-node ;
TUPLE: #call-label ; TUPLE: #call-label < node ;
: #call-label ( label -- node ) \ #call-label param-node ; : #call-label ( label -- node ) \ #call-label param-node ;
TUPLE: #push ; TUPLE: #push < node ;
: #push ( -- node ) \ #push empty-node ; : #push ( -- node ) \ #push new ;
TUPLE: #shuffle ; TUPLE: #shuffle < node ;
: #shuffle ( -- node ) \ #shuffle empty-node ; : #shuffle ( -- node ) \ #shuffle new ;
TUPLE: #>r ; TUPLE: #>r < node ;
: #>r ( -- node ) \ #>r empty-node ; : #>r ( -- node ) \ #>r new ;
TUPLE: #r> ; TUPLE: #r> < node ;
: #r> ( -- node ) \ #r> empty-node ; : #r> ( -- node ) \ #r> new ;
TUPLE: #values ; TUPLE: #values < node ;
: #values ( -- node ) \ #values all-in-node ; : #values ( -- node ) \ #values all-in-node ;
TUPLE: #return ; TUPLE: #return < node ;
: #return ( label -- node ) : #return ( label -- node )
\ #return all-in-node [ set-node-param ] keep ; \ #return all-in-node swap >>param ;
TUPLE: #if ; TUPLE: #branch < node ;
TUPLE: #if < #branch ;
: #if ( -- node ) peek-d 1array \ #if in-node ; : #if ( -- node ) peek-d 1array \ #if in-node ;
TUPLE: #dispatch ; TUPLE: #dispatch < #branch ;
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ; : #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
TUPLE: #merge ; TUPLE: #merge < node ;
: #merge ( -- node ) \ #merge all-out-node ; : #merge ( -- node ) \ #merge all-out-node ;
TUPLE: #terminate ; TUPLE: #terminate < node ;
: #terminate ( -- node ) \ #terminate empty-node ; : #terminate ( -- node ) \ #terminate new ;
TUPLE: #declare ; TUPLE: #declare < node ;
: #declare ( classes -- node ) \ #declare param-node ; : #declare ( classes -- node ) \ #declare param-node ;
UNION: #branch #if #dispatch ;
: node-inputs ( d-count r-count node -- ) : node-inputs ( d-count r-count node -- )
tuck tuck
>r r-tail flatten-curries r> set-node-in-r [ swap d-tail flatten-curries >>in-d drop ]
>r d-tail flatten-curries r> set-node-in-d ; [ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
: node-outputs ( d-count r-count node -- ) : node-outputs ( d-count r-count node -- )
tuck tuck
>r r-tail flatten-curries r> set-node-out-r [ swap d-tail flatten-curries >>out-d drop ]
>r d-tail flatten-curries r> set-node-out-d ; [ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
: node, ( node -- ) : node, ( node -- )
dataflow-graph get [ dataflow-graph get [
@ -178,17 +174,15 @@ UNION: #branch #if #dispatch ;
] if ; ] if ;
: node-values ( node -- values ) : node-values ( node -- values )
dup node-in-d { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
over node-out-d 4array concat ;
pick node-in-r
roll node-out-r 4array concat ;
: last-node ( node -- last ) : last-node ( node -- last )
dup node-successor [ last-node ] [ ] ?if ; dup successor>> [ last-node ] [ ] ?if ;
: penultimate-node ( node -- penultimate ) : penultimate-node ( node -- penultimate )
dup node-successor dup [ dup successor>> dup [
dup node-successor dup successor>>
[ nip penultimate-node ] [ drop ] if [ nip penultimate-node ] [ drop ] if
] [ ] [
2drop f 2drop f
@ -202,7 +196,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [ 2dup 2slip rot [
2drop t 2drop t
] [ ] [
>r dup node-children swap node-successor suffix r> >r [ children>> ] [ successor>> ] bi suffix r>
[ node-exists? ] curry contains? [ node-exists? ] curry contains?
] if ] if
] [ ] [
@ -213,13 +207,13 @@ GENERIC: calls-label* ( label node -- ? )
M: node calls-label* 2drop f ; M: node calls-label* 2drop f ;
M: #call-label calls-label* node-param eq? ; M: #call-label calls-label* param>> eq? ;
: calls-label? ( label node -- ? ) : calls-label? ( label node -- ? )
[ calls-label* ] with node-exists? ; [ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? ) : recursive-label? ( node -- ? )
dup node-param swap calls-label? ; [ param>> ] keep calls-label? ;
SYMBOL: node-stack SYMBOL: node-stack
@ -227,7 +221,7 @@ SYMBOL: node-stack
: node> node-stack get pop ; : node> node-stack get pop ;
: node@ node-stack get peek ; : node@ node-stack get peek ;
: iterate-next ( -- node ) node@ node-successor ; : iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- ) : iterate-nodes ( node quot -- )
over [ over [
@ -255,54 +249,55 @@ SYMBOL: node-stack
] iterate-nodes drop ] iterate-nodes drop
] with-node-iterator ; inline ] with-node-iterator ; inline
: change-children ( node quot -- ) : map-children ( node quot -- )
over [ over [
>r dup node-children dup r> over children>> [
[ map swap set-node-children ] curry [ map ] curry change-children drop
[ 2drop ] if ] [
2drop
] if
] [ ] [
2drop 2drop
] if ; inline ] if ; inline
: (transform-nodes) ( prev node quot -- ) : (transform-nodes) ( prev node quot -- )
dup >r call dup [ dup >r call dup [
dup rot set-node-successor >>successor
dup node-successor r> (transform-nodes) successor>> dup successor>>
r> (transform-nodes)
] [ ] [
r> drop f swap set-node-successor drop r> 2drop f >>successor drop
] if ; inline ] if ; inline
: transform-nodes ( node quot -- new-node ) : transform-nodes ( node quot -- new-node )
over [ over [
[ call dup dup node-successor ] keep (transform-nodes) [ call dup dup successor>> ] keep (transform-nodes)
] [ drop ] if ; inline ] [ drop ] if ; inline
: node-literal? ( node value -- ? ) : node-literal? ( node value -- ? )
dup value? >r swap node-literals key? r> or ; dup value? >r swap literals>> key? r> or ;
: node-literal ( node value -- obj ) : node-literal ( node value -- obj )
dup value? dup value?
[ nip value-literal ] [ swap node-literals at ] if ; [ nip value-literal ] [ swap literals>> at ] if ;
: node-interval ( node value -- interval ) : node-interval ( node value -- interval )
swap node-intervals at ; swap intervals>> at ;
: node-class ( node value -- class ) : node-class ( node value -- class )
swap node-classes at object or ; swap classes>> at object or ;
: node-input-classes ( node -- seq ) : node-input-classes ( node -- seq )
dup node-in-d [ node-class ] with map ; dup in-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq ) : node-input-intervals ( node -- seq )
dup node-in-d [ node-interval ] with map ; dup in-d>> [ node-interval ] with map ;
: node-class-first ( node -- class ) : node-class-first ( node -- class )
dup node-in-d first node-class ; dup in-d>> first node-class ;
: active-children ( node -- seq ) : active-children ( node -- seq )
node-children children>> [ last-node ] map [ #terminate? not ] subset ;
[ last-node ] map
[ #terminate? not ] subset ;
DEFER: #tail? DEFER: #tail?
@ -317,5 +312,5 @@ UNION: #tail
#! We don't consider calls which do non-local exits to be #! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces. #! tail calls, because this gives better error traces.
node-stack get [ node-stack get [
node-successor dup #tail? swap #terminate? not and successor>> [ #tail? ] [ #terminate? not ] bi and
] all? ; ] all? ;

8
core/inference/errors/errors.factor
View File

@ -1,15 +1,15 @@
! 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: inference.errors IN: inference.errors
USING: inference.backend inference.dataflow kernel generic USING: inference.backend inference.dataflow kernel generic
sequences prettyprint io words arrays inspector effects debugger sequences prettyprint io words arrays inspector effects debugger
assocs ; assocs accessors ;
M: inference-error error. M: inference-error error.
dup inference-error-rstate dup rstate>>
keys [ dup value? [ value-literal ] when ] map keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless dup empty? [ "Word: " write dup peek . ] unless
swap delegate error. "Nesting: " write . ; swap error>> error. "Nesting: " write . ;
M: inference-error error-help drop f ; M: inference-error error-help drop f ;

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

@ -79,6 +79,18 @@ ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph"
"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form." "The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
$nl ; $nl ;
ARTICLE: "inference-errors" "Inference errors"
"Main wrapper for all inference errors:"
{ $subsection inference-error }
"Specific inference errors:"
{ $subsection no-effect }
{ $subsection literal-expected }
{ $subsection too-many->r }
{ $subsection too-many-r> }
{ $subsection unbalanced-branches-error }
{ $subsection effect-error }
{ $subsection recursive-declare-error } ;
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
@ -94,6 +106,7 @@ $nl
{ $subsection "inference-branches" } { $subsection "inference-branches" }
{ $subsection "inference-recursive" } { $subsection "inference-recursive" }
{ $subsection "inference-limitations" } { $subsection "inference-limitations" }
{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" } { $subsection "dataflow-graphs" }
{ $subsection "compiler-transforms" } ; { $subsection "compiler-transforms" } ;
@ -105,16 +118,7 @@ HELP: inference-error
{ $error-description { $error-description
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred." "Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
$nl $nl
"This error always delegates to one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:" "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
{ $list
{ $link no-effect }
{ $link literal-expected }
{ $link too-many->r }
{ $link too-many-r> }
{ $link unbalanced-branches-error }
{ $link effect-error }
{ $link recursive-declare-error }
}
} ; } ;

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

@ -8,6 +8,9 @@ classes.predicate debugger threads.private io.streams.string
io.timeouts io.thread sequences.private ; io.timeouts io.thread sequences.private ;
IN: inference.tests IN: inference.tests
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
{ 0 2 } [ 2 "Hello" ] must-infer-as { 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as { 1 2 } [ dup ] must-infer-as
@ -542,3 +545,5 @@ ERROR: custom-error ;
: missing->r-check >r ; : missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail [ [ missing->r-check ] infer ] must-fail
{ 1 0 } [ [ ] map-children ] must-infer-as

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