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

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

db4
Slava Pestov 2008-04-23 01:31:38 -05:00
parent 04e9b1c37f 6a0dc9f024
commit 4e7542860d
972 changed files with 19955 additions and 11141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -2,6 +2,7 @@
_darcs _darcs
*.obj *.obj
*.o *.o
*.s
*.exe *.exe
Factor/factor Factor/factor
*.a *.a

7
Makefile
View File

@ -45,8 +45,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
EXE_OBJS = $(PLAF_EXE_OBJS) EXE_OBJS = $(PLAF_EXE_OBJS)
default: build-support/wordsize default:
$(MAKE) `./build-support/target` $(MAKE) `./build-support/factor.sh make-target`
help: help:
@echo "Run '$(MAKE)' with one of the following parameters:" @echo "Run '$(MAKE)' with one of the following parameters:"
@ -162,9 +162,6 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
build-support/wordsize: build-support/wordsize.c
gcc build-support/wordsize.c -o build-support/wordsize
clean: clean:
rm -f vm/*.o rm -f vm/*.o
rm -f factor*.dll libfactor*.* rm -f factor*.dll libfactor*.*

109
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

83
misc/factor.sh → build-support/factor.sh
View File

@ -7,6 +7,7 @@ set +e
shopt -s nocaseglob shopt -s nocaseglob
#shopt -s nocasematch #shopt -s nocasematch
ECHO=echo
OS= OS=
ARCH= ARCH=
WORD= WORD=
@ -25,23 +26,23 @@ ensure_program_installed() {
installed=0; installed=0;
for i in $* ; for i in $* ;
do do
echo -n "Checking for $i..." $ECHO -n "Checking for $i..."
test_program_installed $i test_program_installed $i
if [[ $? -eq 0 ]]; then if [[ $? -eq 0 ]]; then
echo -n "not " echo -n "not "
else else
installed=$(( $installed + 1 )) installed=$(( $installed + 1 ))
fi fi
echo "found!" $ECHO "found!"
done done
if [[ $installed -eq 0 ]] ; then if [[ $installed -eq 0 ]] ; then
echo -n "Install " $ECHO -n "Install "
if [[ $# -eq 1 ]] ; then if [[ $# -eq 1 ]] ; then
echo -n $1 $ECHO -n $1
else else
echo -n "any of [ $* ]" $ECHO -n "any of [ $* ]"
fi fi
echo " and try again." $ECHO " and try again."
exit 1 exit 1
fi fi
} }
@ -49,22 +50,22 @@ ensure_program_installed() {
check_ret() { check_ret() {
RET=$? RET=$?
if [[ $RET -ne 0 ]] ; then if [[ $RET -ne 0 ]] ; then
echo $1 failed $ECHO $1 failed
exit 2 exit 2
fi fi
} }
check_gcc_version() { check_gcc_version() {
echo -n "Checking gcc version..." $ECHO -n "Checking gcc version..."
GCC_VERSION=`$CC --version` GCC_VERSION=`$CC --version`
check_ret gcc check_ret gcc
if [[ $GCC_VERSION == *3.3.* ]] ; then if [[ $GCC_VERSION == *3.3.* ]] ; then
echo "bad!" $ECHO "bad!"
echo "You have a known buggy version of gcc (3.3)" $ECHO "You have a known buggy version of gcc (3.3)"
echo "Install gcc 3.4 or higher and try again." $ECHO "Install gcc 3.4 or higher and try again."
exit 3 exit 3
fi fi
echo "ok." $ECHO "ok."
} }
set_downloader() { set_downloader() {
@ -125,20 +126,20 @@ check_installed_programs() {
check_library_exists() { check_library_exists() {
GCC_TEST=factor-library-test.c GCC_TEST=factor-library-test.c
GCC_OUT=factor-library-test.out GCC_OUT=factor-library-test.out
echo -n "Checking for library $1..." $ECHO -n "Checking for library $1..."
echo "int main(){return 0;}" > $GCC_TEST $ECHO "int main(){return 0;}" > $GCC_TEST
$CC $GCC_TEST -o $GCC_OUT -l $1 $CC $GCC_TEST -o $GCC_OUT -l $1
if [[ $? -ne 0 ]] ; then if [[ $? -ne 0 ]] ; then
echo "not found!" $ECHO "not found!"
echo "Warning: library $1 not found." $ECHO "Warning: library $1 not found."
echo "***Factor will compile NO_UI=1" $ECHO "***Factor will compile NO_UI=1"
NO_UI=1 NO_UI=1
fi fi
rm -f $GCC_TEST rm -f $GCC_TEST
check_ret rm check_ret rm
rm -f $GCC_OUT rm -f $GCC_OUT
check_ret rm check_ret rm
echo "found." $ECHO "found."
} }
check_X11_libraries() { check_X11_libraries() {
@ -156,14 +157,14 @@ check_libraries() {
check_factor_exists() { check_factor_exists() {
if [[ -d "factor" ]] ; then if [[ -d "factor" ]] ; then
echo "A directory called 'factor' already exists." $ECHO "A directory called 'factor' already exists."
echo "Rename or delete it and try again." $ECHO "Rename or delete it and try again."
exit 4 exit 4
fi fi
} }
find_os() { find_os() {
echo "Finding OS..." $ECHO "Finding OS..."
uname_s=`uname -s` uname_s=`uname -s`
check_ret uname check_ret uname
case $uname_s in case $uname_s in
@ -182,13 +183,14 @@ find_os() {
} }
find_architecture() { find_architecture() {
echo "Finding ARCH..." $ECHO "Finding ARCH..."
uname_m=`uname -m` uname_m=`uname -m`
check_ret uname check_ret uname
case $uname_m in case $uname_m in
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;;
@ -201,7 +203,7 @@ write_test_program() {
} }
find_word_size() { find_word_size() {
echo "Finding WORD..." $ECHO "Finding WORD..."
C_WORD=factor-word-size C_WORD=factor-word-size
write_test_program write_test_program
gcc -o $C_WORD $C_WORD.c gcc -o $C_WORD $C_WORD.c
@ -219,26 +221,26 @@ set_factor_binary() {
} }
echo_build_info() { echo_build_info() {
echo OS=$OS $ECHO OS=$OS
echo ARCH=$ARCH $ECHO ARCH=$ARCH
echo WORD=$WORD $ECHO WORD=$WORD
echo FACTOR_BINARY=$FACTOR_BINARY $ECHO FACTOR_BINARY=$FACTOR_BINARY
echo MAKE_TARGET=$MAKE_TARGET $ECHO MAKE_TARGET=$MAKE_TARGET
echo BOOT_IMAGE=$BOOT_IMAGE $ECHO BOOT_IMAGE=$BOOT_IMAGE
echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET $ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
echo GIT_PROTOCOL=$GIT_PROTOCOL $ECHO GIT_PROTOCOL=$GIT_PROTOCOL
echo GIT_URL=$GIT_URL $ECHO GIT_URL=$GIT_URL
echo DOWNLOADER=$DOWNLOADER $ECHO DOWNLOADER=$DOWNLOADER
echo CC=$CC $ECHO CC=$CC
echo MAKE=$MAKE $ECHO MAKE=$MAKE
} }
set_build_info() { set_build_info() {
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
echo "OS: $OS" $ECHO "OS: $OS"
echo "ARCH: $ARCH" $ECHO "ARCH: $ARCH"
echo "WORD: $WORD" $ECHO "WORD: $WORD"
echo "OS, ARCH, or WORD is empty. Please report this" $ECHO "OS, ARCH, or WORD is empty. Please report this"
exit 5 exit 5
fi fi
@ -437,7 +439,7 @@ install_build_system_port() {
} }
usage() { usage() {
echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap" echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
echo "If you are behind a firewall, invoke as:" echo "If you are behind a firewall, invoke as:"
echo "env GIT_PROTOCOL=http $0 <command>" echo "env GIT_PROTOCOL=http $0 <command>"
} }
@ -452,5 +454,6 @@ case "$1" in
bootstrap) get_config_info; bootstrap ;; bootstrap) get_config_info; bootstrap ;;
dlls) get_config_info; maybe_download_dlls;; dlls) get_config_info; maybe_download_dlls;;
net-bootstrap) get_config_info; update_boot_images; bootstrap ;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
*) usage ;; *) usage ;;
esac esac

2
build-support/grovel.c
View File

@ -42,6 +42,7 @@
#include <sys/socket.h> #include <sys/socket.h>
#include <sys/errno.h> #include <sys/errno.h>
#include <sys/mman.h> #include <sys/mman.h>
#include <sys/syslimits.h>
#include <fcntl.h> #include <fcntl.h>
#include <unistd.h> #include <unistd.h>
#endif #endif
@ -146,6 +147,7 @@ void unix_constants()
constant(PROT_WRITE); constant(PROT_WRITE);
constant(MAP_FILE); constant(MAP_FILE);
constant(MAP_SHARED); constant(MAP_SHARED);
constant(PATH_MAX);
grovel(pid_t); grovel(pid_t);
} }

38
build-support/target
View File

@ -1,38 +0,0 @@
#!/bin/sh
uname_s=`uname -s`
case $uname_s in
CYGWIN_NT-5.2-WOW64) OS=winnt;;
*CYGWIN_NT*) OS=winnt;;
*CYGWIN*) OS=winnt;;
*darwin*) OS=macosx;;
*Darwin*) OS=macosx;;
*linux*) OS=linux;;
*Linux*) OS=linux;;
*NetBSD*) OS=netbsd;;
*FreeBSD*) OS=freebsd;;
*OpenBSD*) OS=openbsd;;
*DragonFly*) OS=dragonflybsd;;
esac
uname_m=`uname -m`
case $uname_m in
i386) ARCH=x86;;
i686) ARCH=x86;;
amd64) ARCH=x86;;
*86) ARCH=x86;;
*86_64) ARCH=x86;;
"Power Macintosh") ARCH=ppc;;
esac
WORD=`./build-support/wordsize`
MAKE_TARGET=$OS-$ARCH-$WORD
if [[ $OS == macosx && $ARCH == ppc ]] ; then
MAKE_TARGET=$OS-$ARCH
fi
if [[ $OS == linux && $ARCH == ppc ]] ; then
MAKE_TARGET=$OS-$ARCH
fi
echo $MAKE_TARGET

8
build-support/wordsize.c
View File

@ -1,8 +0,0 @@
#include <stdio.h>
int main ()
{
printf("%d", 8*sizeof(void*));
return 0;
}

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

@ -76,9 +76,9 @@ $nl
{ $examples "Here is a typical usage of " { $link add-library } ":" { $examples "Here is a typical usage of " { $link add-library } ":"
{ $code { $code
"<< \"freetype\" {" "<< \"freetype\" {"
" { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ 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"

19
core/alien/alien.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system USING: assocs kernel math namespaces sequences system
kernel.private tuples bit-arrays byte-arrays float-arrays kernel.private bit-arrays byte-arrays float-arrays arrays ;
arrays ;
IN: alien IN: alien
! Some predicate classes used by the compiler for optimization ! Some predicate classes used by the compiler for optimization
@ -29,18 +28,12 @@ M: f expired? drop t ;
: <alien> ( address -- alien ) : <alien> ( address -- alien )
f <displaced-alien> { simple-c-ptr } declare ; inline f <displaced-alien> { simple-c-ptr } declare ; inline
: alien>native-string ( alien -- string )
windows? [ alien>u16-string ] [ alien>char-string ] if ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
M: alien equal? M: alien equal?
over alien? [ over alien? [
2dup [ expired? ] either? [ 2dup [ expired? ] either? [
[ expired? ] both? [ expired? ] both?
] [ ] [
[ alien-address ] 2apply = [ alien-address ] bi@ =
] if ] if
] [ ] [
2drop f 2drop f
@ -55,7 +48,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 ;
@ -63,22 +56,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 -- ... )

6
core/alien/arrays/arrays-docs.factor
View File

@ -18,7 +18,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
{ $subsection >c-ushort-array } { $subsection >c-ushort-array }
{ $subsection >c-void*-array } { $subsection >c-void*-array }
{ $subsection c-bool-array> } { $subsection c-bool-array> }
{ $subsection c-char*-array> }
{ $subsection c-char-array> } { $subsection c-char-array> }
{ $subsection c-double-array> } { $subsection c-double-array> }
{ $subsection c-float-array> } { $subsection c-float-array> }
@ -30,7 +29,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
{ $subsection c-uint-array> } { $subsection c-uint-array> }
{ $subsection c-ulong-array> } { $subsection c-ulong-array> }
{ $subsection c-ulonglong-array> } { $subsection c-ulonglong-array> }
{ $subsection c-ushort*-array> }
{ $subsection c-ushort-array> } { $subsection c-ushort-array> }
{ $subsection c-void*-array> } ; { $subsection c-void*-array> } ;
@ -61,9 +59,7 @@ ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
{ $subsection double-nth } { $subsection double-nth }
{ $subsection set-double-nth } { $subsection set-double-nth }
{ $subsection void*-nth } { $subsection void*-nth }
{ $subsection set-void*-nth } { $subsection set-void*-nth } ;
{ $subsection char*-nth }
{ $subsection ushort*-nth } ;
ARTICLE: "c-arrays" "C arrays" ARTICLE: "c-arrays" "C arrays"
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."

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

@ -1,8 +1,7 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs USING: alien arrays alien.c-types alien.structs
sequences math kernel generator.registers sequences math kernel namespaces libc cpu.architecture ;
namespaces libc ;
IN: alien.arrays IN: alien.arrays
UNION: value-type array struct-type ; UNION: value-type array struct-type ;
@ -25,9 +24,11 @@ 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-boxer-quot drop f ;
M: value-type c-type-unboxer-quot drop f ;
M: value-type c-type-getter M: value-type c-type-getter
drop [ swap <displaced-alien> ] ; drop [ swap <displaced-alien> ] ;

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

@ -62,28 +62,6 @@ HELP: <c-object>
{ <c-object> malloc-object } related-words { <c-object> malloc-object } related-words
HELP: string>char-alien ( string -- array )
{ $values { "string" string } { "array" byte-array } }
{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
{ string>char-alien alien>char-string malloc-char-string } related-words
HELP: alien>char-string ( c-ptr -- string )
{ $values { "c-ptr" c-ptr } { "string" string } }
{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
HELP: string>u16-alien ( string -- array )
{ $values { "string" string } { "array" byte-array } }
{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
{ $errors "Throws an error if the string contains null characters." } ;
{ string>u16-alien alien>u16-string malloc-u16-string } related-words
HELP: alien>u16-string ( c-ptr -- string )
{ $values { "c-ptr" c-ptr } { "string" string } }
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
HELP: memory>byte-array HELP: memory>byte-array
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
@ -111,18 +89,6 @@ HELP: malloc-byte-array
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ; { $errors "Throws an error if memory allocation fails." } ;
HELP: malloc-char-string
{ $values { "string" string } { "alien" c-ptr } }
{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
HELP: malloc-u16-string
{ $values { "string" string } { "alien" c-ptr } }
{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
HELP: define-nth HELP: define-nth
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } { $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." } { $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
@ -202,8 +168,6 @@ $nl
{ $subsection *float } { $subsection *float }
{ $subsection *double } { $subsection *double }
{ $subsection *void* } { $subsection *void* }
{ $subsection *char* }
{ $subsection *ushort* }
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ; "Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
ARTICLE: "c-types-specs" "C type specifiers" ARTICLE: "c-types-specs" "C type specifiers"
@ -267,26 +231,6 @@ $nl
"A wrapper for temporarily allocating a block of memory:" "A wrapper for temporarily allocating a block of memory:"
{ $subsection with-malloc } ; { $subsection with-malloc } ;
ARTICLE: "c-strings" "C strings"
"The C library interface defines two types of C strings:"
{ $table
{ "C type" "Notes" }
{ { $snippet "char*" } "8-bit per character null-terminated ASCII" }
{ { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" }
}
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>char-alien }
{ $subsection string>u16-alien }
{ $subsection malloc-char-string }
{ $subsection malloc-u16-string }
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
{ $subsection alien>char-string }
{ $subsection alien>u16-string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ARTICLE: "c-data" "Passing data between Factor and C" ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers." "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
$nl $nl

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

@ -1,30 +1,6 @@
IN: alien.c-types.tests IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ; sequences system libc alien.strings io.encodings.utf8 ;
[ "\u0000ff" ]
[ "\u0000ff" string>char-alien alien>char-string ]
unit-test
[ "hello world" ]
[ "hello world" string>char-alien alien>char-string ]
unit-test
[ "hello\u00abcdworld" ]
[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
unit-test
[ t ] [ f expired? ] unit-test
[ "hello world" ] [
"hello world" malloc-char-string
dup alien>char-string swap free
] unit-test
[ "hello world" ] [
"hello world" malloc-u16-string
dup alien>u16-string swap free
] unit-test
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ; : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
@ -67,7 +43,7 @@ TYPEDEF: int* MyIntArray
TYPEDEF: uchar* MyLPBYTE TYPEDEF: uchar* MyLPBYTE
[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test [ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
[ [
0 B{ 1 2 3 4 } <displaced-alien> <void*> 0 B{ 1 2 3 4 } <displaced-alien> <void*>

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

@ -1,10 +1,11 @@
! 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: bit-arrays byte-arrays float-arrays arrays USING: bit-arrays byte-arrays float-arrays arrays
generator.registers assocs kernel kernel.private libc math 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>
@ -13,12 +14,16 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type TUPLE: c-type
boxer prep unboxer boxer boxer-quot unboxer unboxer-quot
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
@ -45,7 +50,7 @@ GENERIC: c-type ( name -- type ) foldable
: parse-array-type ( name -- array ) : parse-array-type ( name -- array )
"[" split unclip "[" split unclip
>r [ "]" ?tail drop string>number ] map r> add* ; >r [ "]" ?tail drop string>number ] map r> prefix ;
M: string c-type ( name -- type ) M: string c-type ( name -- type )
CHAR: ] over member? [ CHAR: ] over member? [
@ -144,25 +149,14 @@ M: float-array byte-length length "double" heap-size * ;
: malloc-byte-array ( byte-array -- alien ) : malloc-byte-array ( byte-array -- alien )
dup length dup malloc [ -rot memcpy ] keep ; dup length dup malloc [ -rot memcpy ] keep ;
: malloc-char-string ( string -- alien )
string>char-alien malloc-byte-array ;
: malloc-u16-string ( string -- alien )
string>u16-alien malloc-byte-array ;
: memory>byte-array ( alien len -- byte-array ) : memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ; dup <byte-array> [ -rot memcpy ] keep ;
: byte-array>memory ( byte-array base -- ) : byte-array>memory ( byte-array base -- )
swap dup length memcpy ; swap dup length memcpy ;
DEFER: >c-ushort-array
: string>u16-memory ( string base -- )
>r >c-ushort-array r> byte-array>memory ;
: (define-nth) ( word type quot -- ) : (define-nth) ( word type quot -- )
>r heap-size [ rot * ] swap add* r> append define-inline ; >r heap-size [ rot * ] swap prefix r> append define-inline ;
: nth-word ( name vocab -- word ) : nth-word ( name vocab -- word )
>r "-nth" append r> create ; >r "-nth" append r> create ;
@ -181,10 +175,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 ;
@ -199,12 +193,12 @@ M: long-long-type box-return ( type -- )
f swap box-parameter ; f swap box-parameter ;
: define-deref ( name vocab -- ) : define-deref ( name vocab -- )
>r dup CHAR: * add* r> create >r dup CHAR: * prefix r> create
swap c-getter 0 add* define-inline ; swap c-getter 0 prefix define-inline ;
: define-out ( name vocab -- ) : define-out ( name vocab -- )
over [ <c-object> tuck 0 ] over c-setter append swap over [ <c-object> tuck 0 ] over c-setter append swap
>r >r constructor-word r> r> add* define-inline ; >r >r constructor-word r> r> prefix define-inline ;
: c-bool> ( int -- ? ) : c-bool> ( int -- ? )
zero? not ; zero? not ;
@ -235,159 +229,157 @@ 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
#! staging violations #! staging violations
dup array? [ dup array? [
unclip >r [ dup word? [ word-def call ] when ] map unclip >r [ dup word? [ word-def call ] when ] map
r> add* r> prefix
] when ; ] when ;
: malloc-file-contents ( path -- alien len ) : malloc-file-contents ( path -- alien len )
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 ] >>unboxer-quot
"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 ] >>unboxer-quot
"double" define-primitive-type "double" define-primitive-type
T{ float-regs f 8 } "double" c-type set-c-type-reg-class os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
[ >float ] "double" c-type set-c-type-prep
[ alien-cell alien>char-string ]
[ set-alien-cell ]
bootstrap-cell
"box_char_string"
"alien_offset" <primitive-type>
"char*" define-primitive-type
"char*" "uchar*" typedef
[ string>char-alien ] "char*" c-type set-c-type-prep
[ alien-cell alien>u16-string ]
[ set-alien-cell ]
4
"box_u16_string"
"alien_offset" <primitive-type>
"ushort*" define-primitive-type
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
win64? "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit ] with-compilation-unit

35
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
@ -280,6 +280,10 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks ! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ; : callback-1 "void" { } "cdecl" [ ] alien-callback ;
@ -312,14 +316,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 +358,18 @@ 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: void ffi_test_36_point_5 ( ) ;
[ ] [ ffi_test_36_point_5 ] unit-test
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test

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

@ -3,22 +3,29 @@
USING: arrays generator generator.registers generator.fixup USING: arrays generator generator.registers generator.fixup
hashtables kernel math namespaces sequences words hashtables kernel math namespaces sequences words
inference.state inference.backend inference.dataflow system inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs math.parser classes alien.arrays alien.c-types alien.strings
alien.syntax cpu.architecture alien inspector quotations assocs alien.structs alien.syntax cpu.architecture alien inspector
kernel.private threads continuations.private libc combinators quotations assocs kernel.private threads continuations.private
compiler.errors continuations layouts accessors ; libc combinators 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
] [ ] [ drop f ] if ;
drop f
] if ;
: alien-node-parameters* ( node -- seq ) : alien-node-parameters* ( node -- seq )
dup parameters>> dup parameters>>
swap return>> large-struct? [ "void*" add* ] when ; swap return>> large-struct? [ "void*" prefix ] when ;
: alien-node-return* ( node -- ctype ) : alien-node-return* ( node -- ctype )
return>> dup large-struct? [ drop "void" ] when ; return>> dup large-struct? [ drop "void" ] when ;
@ -62,29 +69,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?
@ -147,17 +161,16 @@ M: long-long-type flatten-value-type ( type -- )
dup return>> "void" = 0 1 ? dup return>> "void" = 0 1 ?
swap produce-values ; swap produce-values ;
: (make-prep-quot) ( parameters -- ) : (param-prep-quot) ( parameters -- )
dup empty? [ dup empty? [
drop drop
] [ ] [
unclip c-type c-type-prep % unclip c-type c-type-unboxer-quot %
\ >r , (make-prep-quot) \ r> , \ >r , (param-prep-quot) \ r> ,
] if ; ] if ;
: make-prep-quot ( node -- quot ) : param-prep-quot ( node -- quot )
parameters>> parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
[ <reversed> (make-prep-quot) ] [ ] make ;
: unbox-parameters ( offset node -- ) : unbox-parameters ( offset node -- )
parameters>> [ parameters>> [
@ -185,6 +198,20 @@ M: long-long-type flatten-value-type ( type -- )
: box-return* ( node -- ) : box-return* ( node -- )
return>> [ ] [ box-return ] if-void ; return>> [ ] [ box-return ] if-void ;
: (return-prep-quot) ( parameters -- )
dup empty? [
drop
] [
unclip c-type c-type-boxer-quot %
\ >r , (return-prep-quot) \ r> ,
] if ;
: callback-prep-quot ( node -- quot )
parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
: return-prep-quot ( node -- quot )
[ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
M: alien-invoke-error summary M: alien-invoke-error summary
drop drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ; "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
@ -205,7 +232,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 +244,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 +256,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 param-prep-quot f infer-quot
! Set ABI ! Set ABI
dup alien-invoke-library dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
library [ library-abi ] [ "cdecl" ] if*
over set-alien-invoke-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 dup 0 alien-invoke-stack
! Quotation which coerces return value to required type
return-prep-quot f infer-quot
] "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,20 +300,22 @@ 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 param-prep-quot [ dip ] curry f infer-quot
! Add node to IR ! Add node to IR
dup node, dup node,
! Magic #: consume the function pointer, too ! Magic #: consume the function pointer, too
1 alien-invoke-stack dup 1 alien-invoke-stack
! Quotation which coerces return value to required type
return-prep-quot f infer-quot
] "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 +344,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 ; f 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
@ -356,18 +385,19 @@ TUPLE: callback-context ;
slip slip
wait-to-return ; inline wait-to-return ; inline
: prepare-callback-return ( ctype -- quot ) : callback-return-quot ( ctype -- quot )
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-unboxer-quot ]
} cond ; } cond ;
: wrap-callback-quot ( node -- quot ) : wrap-callback-quot ( node -- quot )
[ [
dup alien-callback-quot [ callback-prep-quot ]
swap prepare-callback-return append , [ quot>> ]
[ callback-context construct-empty do-callback ] % [ callback-return-quot ] tri 3append ,
[ callback-context new do-callback ] %
] [ ] make ; ] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
@ -376,7 +406,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,16 +417,16 @@ 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 [ registers>objects ]
dup wrap-callback-quot %alien-callback [ wrap-callback-quot %alien-callback ]
%callback-return [ %callback-return ]
tri
] 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 ;

8
core/alien/remote-control/remote-control.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types parser threads words kernel.private USING: alien alien.c-types alien.strings parser threads words
kernel ; kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control IN: alien.remote-control
: eval-callback : eval-callback
"void*" { "char*" } "cdecl" "void*" { "char*" } "cdecl"
[ eval>string malloc-char-string ] alien-callback ; [ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback : yield-callback
"void" { } "cdecl" [ yield ] alien-callback ; "void" { } "cdecl" [ yield ] alien-callback ;

52
core/alien/strings/strings-docs.factor Normal file
View File

@ -0,0 +1,52 @@
USING: help.markup help.syntax strings byte-arrays alien libc
debugger ;
IN: alien.strings
HELP: string>alien
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
{ string>alien alien>string malloc-string } related-words
HELP: alien>string
{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string" string } }
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
HELP: utf16n
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $subsection malloc-string }
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsection alien>string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ABOUT: "c-strings"

30
core/alien/strings/strings-tests.factor Normal file
View File

@ -0,0 +1,30 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien ;
IN: alien.strings.tests
[ "\u0000ff" ]
[ "\u0000ff" latin1 string>alien latin1 alien>string ]
unit-test
[ "hello world" ]
[ "hello world" latin1 string>alien latin1 alien>string ]
unit-test
[ "hello\u00abcdworld" ]
[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
unit-test
[ t ] [ f expired? ] unit-test
[ "hello world" ] [
"hello world" ascii malloc-string
dup ascii alien>string swap free
] unit-test
[ "hello world" ] [
"hello world" utf16n malloc-string
dup utf16n alien>string swap free
] unit-test
[ f ] [ f utf8 alien>string ] unit-test

111
core/alien/strings/strings.factor Normal file
View File

@ -0,0 +1,111 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel accessors math alien.accessors
alien.c-types byte-arrays words io io.encodings
io.streams.byte-array io.streams.memory io.encodings.utf8
io.encodings.utf16 system alien strings cpu.architecture ;
IN: alien.strings
GENERIC# alien>string 1 ( alien encoding -- string/f )
M: c-ptr alien>string
>r <memory-stream> r> <decoder>
"\0" swap stream-read-until drop ;
M: f alien>string
drop ;
ERROR: invalid-c-string string ;
: check-string ( string -- )
0 over memq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
M: c-ptr string>alien drop ;
M: string string>alien
over check-string
<byte-writer>
[ stream-write ]
[ 0 swap stream-write1 ]
[ stream>> >byte-array ]
tri ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type c-type-align
drop "void*" c-type-align ;
M: string-type c-type-stack-align?
drop "void*" c-type-stack-align? ;
M: string-type unbox-parameter
drop "void*" unbox-parameter ;
M: string-type unbox-return
drop "void*" unbox-return ;
M: string-type box-parameter
drop "void*" box-parameter ;
M: string-type box-return
drop "void*" box-return ;
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
M: string-type c-type-boxer-quot
second [ alien>string ] curry [ ] like ;
M: string-type c-type-unboxer-quot
second [ string>alien ] curry [ ] like ;
M: string-type c-type-getter
drop [ alien-cell ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
TUPLE: utf16n ;
! Native-order UTF-16
: utf16n ( -- descriptor )
little-endian? utf16le utf16be ? ; foldable
M: utf16n <decoder> drop utf16n <decoder> ;
M: utf16n <encoder> drop utf16n <encoder> ;
: alien>native-string ( alien -- string )
os windows? [ utf16n ] [ utf8 ] if alien>string ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
: string>symbol ( str -- alien )
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
over string? [ call ] [ map ] if ;
{ "char*" utf8 } "char*" typedef
{ "char*" utf16n } "wchar_t*" typedef
"char*" "uchar*" typedef

10
core/alien/structs/structs-docs.factor
View File

@ -8,7 +8,7 @@ kernel words slots assocs namespaces ;
dup ?word-name swap 2array dup ?word-name swap 2array
over slot-spec-name over slot-spec-name
rot slot-spec-type 2array 2array rot slot-spec-type 2array 2array
[ { $instance } swap add ] assoc-map ; [ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- ) : $spec-reader-values ( slot-spec class -- )
($spec-reader-values) $values ; ($spec-reader-values) $values ;
@ -16,9 +16,9 @@ kernel words slots assocs namespaces ;
: $spec-reader-description ( slot-spec class -- ) : $spec-reader-description ( slot-spec class -- )
[ [
"Outputs the value stored in the " , "Outputs the value stored in the " ,
{ $snippet } rot slot-spec-name add , { $snippet } rot slot-spec-name suffix ,
" slot of " , " slot of " ,
{ $instance } swap add , { $instance } swap suffix ,
" instance." , " instance." ,
] { } make $description ; ] { } make $description ;
@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ;
: $spec-writer-description ( slot-spec class -- ) : $spec-writer-description ( slot-spec class -- )
[ [
"Stores a new value to the " , "Stores a new value to the " ,
{ $snippet } rot slot-spec-name add , { $snippet } rot slot-spec-name suffix ,
" slot of " , " slot of " ,
{ $instance } swap add , { $instance } swap suffix ,
" instance." , " instance." ,
] { } make $description ; ] { } make $description ;

28
core/alien/structs/structs-tests.factor
View File

@ -1,6 +1,6 @@
IN: alien.structs.tests IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces ; sequences system libc words vocabs namespaces layouts ;
C-STRUCT: bar C-STRUCT: bar
{ "int" "x" } { "int" "x" }
@ -9,20 +9,20 @@ C-STRUCT: bar
[ 36 ] [ "bar" heap-size ] unit-test [ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test [ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
! This was actually only correct on Windows/x86: C-STRUCT: align-test
{ "int" "x" }
{ "double" "y" } ;
! C-STRUCT: align-test os winnt? cpu x86? and [
! { "int" "x" } [ 16 ] [ "align-test" heap-size ] unit-test
! { "double" "y" } ;
! cell 4 = [
! [ 16 ] [ "align-test" heap-size ] unit-test C-STRUCT: one
! { "long" "a" } { "double" "b" } { "int" "c" } ;
! cell 4 = [
! C-STRUCT: one [ 24 ] [ "one" heap-size ] unit-test
! { "long" "a" } { "double" "b" } { "int" "c" } ; ] when
! ] when
! [ 24 ] [ "one" heap-size ] unit-test
! ] when
: MAX_FOOS 30 ; : MAX_FOOS 30 ;

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

@ -16,18 +16,23 @@ IN: alien.structs
] reduce ; ] reduce ;
: define-struct-slot-word ( spec word quot -- ) : define-struct-slot-word ( spec word quot -- )
rot slot-spec-offset add* define-inline ; rot slot-spec-offset prefix define-inline ;
: define-getter ( type spec -- ) : define-getter ( type spec -- )
[ set-reader-props ] keep [ set-reader-props ] keep
dup slot-spec-reader [ ]
over slot-spec-type c-getter [ slot-spec-reader ]
[
slot-spec-type
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ; define-struct-slot-word ;
: define-setter ( type spec -- ) : define-setter ( type spec -- )
[ set-writer-props ] keep [ set-writer-props ] keep
dup slot-spec-writer [ ]
over slot-spec-type c-setter [ slot-spec-writer ]
[ slot-spec-type c-setter ] tri
define-struct-slot-word ; define-struct-slot-word ;
: define-field ( type spec -- ) : define-field ( type spec -- )
@ -68,7 +73,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 )

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

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman. ! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays USING: arrays alien alien.c-types alien.structs alien.arrays
kernel math namespaces parser sequences words quotations alien.strings kernel math namespaces parser sequences words
math.parser splitting effects prettyprint prettyprint.sections quotations math.parser splitting effects prettyprint
prettyprint.backend assocs combinators ; prettyprint.sections prettyprint.backend assocs combinators ;
IN: alien.syntax IN: alien.syntax
<PRIVATE <PRIVATE
@ -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 ;

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

@ -16,6 +16,22 @@ $nl
"To make an assoc into an alist:" "To make an assoc into an alist:"
{ $subsection >alist } ; { $subsection >alist } ;
ARTICLE: "enums" "Enumerations"
"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
{ $subsection enum }
{ $subsection <enum> }
"Inverting a permutation using enumerations:"
{ $example "USING: assocs sorting prettyprint ;" ": invert <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
HELP: enum
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
$nl
"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
HELP: <enum>
{ $values { "seq" sequence } { "enum" enum } }
{ $description "Creates a new enumeration." } ;
ARTICLE: "assocs-protocol" "Associative mapping protocol" ARTICLE: "assocs-protocol" "Associative mapping protocol"
"All associative mappings must be instances of a mixin class:" "All associative mappings must be instances of a mixin class:"
{ $subsection assoc } { $subsection assoc }
@ -53,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" } ":"
@ -81,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 }
@ -190,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" } }
@ -244,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." } ;
@ -254,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

37
core/assocs/assocs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg ! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays math sequences.private vectors ; USING: kernel sequences arrays math sequences.private vectors
accessors ;
IN: assocs IN: assocs
MIXIN: assoc MIXIN: assoc
@ -108,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 ] 2apply + 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 )
@ -154,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
@ -189,3 +193,24 @@ M: f clear-assoc drop ;
M: f assoc-like drop dup assoc-empty? [ drop f ] when ; M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
INSTANCE: sequence assoc INSTANCE: sequence assoc
TUPLE: enum seq ;
C: <enum> enum
M: enum at*
seq>> 2dup bounds-check?
[ nth t ] [ 2drop f f ] if ;
M: enum set-at seq>> set-nth ;
M: enum delete-at enum-seq delete-nth ;
M: enum >alist ( enum -- alist )
seq>> [ length ] keep zip ;
M: enum assoc-size seq>> length ;
M: enum clear-assoc seq>> delete-all ;
INSTANCE: enum assoc

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

@ -21,7 +21,7 @@ IN: bit-arrays.tests
{ t f t } { f t f } { t f t } { f t f }
] [ ] [
{ t f t } >bit-array dup clone dup [ not ] change-each { t f t } >bit-array dup clone dup [ not ] change-each
[ >array ] 2apply [ >array ] bi@
] unit-test ] unit-test
[ [

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 ;

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

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: compiler cpu.architecture vocabs.loader system sequences USING: compiler cpu.architecture vocabs.loader system sequences
namespaces parser kernel kernel.private classes classes.private namespaces parser kernel kernel.private classes classes.private
arrays hashtables vectors tuples sbufs inference.dataflow arrays hashtables vectors classes.tuple sbufs inference.dataflow
hashtables.private sequences.private math tuples.private hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words generator command-line growable namespaces.private assocs words generator command-line
vocabs io prettyprint libc compiler.units ; vocabs io prettyprint libc compiler.units ;
IN: bootstrap.compiler IN: bootstrap.compiler
@ -14,18 +14,12 @@ IN: bootstrap.compiler
"alien.remote-control" require "alien.remote-control" require
] unless ] unless
"cpu." cpu append require "cpu." cpu word-name append require
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
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
@ -43,8 +37,6 @@ nl
wrap probe wrap probe
delegate
underlying underlying
find-pair-next namestack* find-pair-next namestack*
@ -61,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
@ -82,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

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

@ -4,14 +4,16 @@ 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 tuples tuples.private words.private splitting growable classes classes.builtin classes.tuple
io.binary io.files vocabs vocabs.loader source-files classes.tuple.private words.private io.binary io.files vocabs
definitions debugger float-arrays quotations.private vocabs.loader source-files definitions debugger float-arrays
sequences.private combinators io.encodings.binary ; quotations.private sequences.private combinators
io.encodings.binary ;
IN: bootstrap.image IN: bootstrap.image
: my-arch ( -- arch ) : my-arch ( -- arch )
cpu dup "ppc" = [ os "-" rot 3append ] when ; cpu word-name
dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
: boot-image-name ( arch -- string ) : boot-image-name ( arch -- string )
"boot." swap ".image" 3append ; "boot." swap ".image" 3append ;
@ -54,7 +56,7 @@ IN: bootstrap.image
: quot-xt@ 3 bootstrap-cells object tag-number - ; : quot-xt@ 3 bootstrap-cells object tag-number - ;
: jit-define ( quot rc rt offset name -- ) : jit-define ( quot rc rt offset name -- )
>r >r >r >r { } make r> r> r> 4array r> set ; >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
! The image being constructed; a vector of word-size integers ! The image being constructed; a vector of word-size integers
SYMBOL: image SYMBOL: image
@ -133,10 +135,10 @@ SYMBOL: undefined-quot
: here ( -- size ) heap-size data-base + ; : here ( -- size ) heap-size data-base + ;
: here-as ( tag -- pointer ) here swap bitor ; : here-as ( tag -- pointer ) here bitor ;
: align-here ( -- ) : align-here ( -- )
here 8 mod 4 = [ heap-size drop 0 emit ] when ; here 8 mod 4 = [ 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ; : emit-fixnum ( n -- ) tag-fixnum emit ;
@ -163,7 +165,7 @@ GENERIC: ' ( obj -- ptr )
userenv-size [ f ' emit ] times ; userenv-size [ f ' emit ] times ;
: emit-userenv ( symbol -- ) : emit-userenv ( symbol -- )
dup get ' swap userenv-offset fixup ; [ get ' ] [ userenv-offset ] bi fixup ;
! Bignums ! Bignums
@ -174,14 +176,15 @@ GENERIC: ' ( obj -- ptr )
: bignum>seq ( n -- seq ) : bignum>seq ( n -- seq )
#! n is positive or zero. #! n is positive or zero.
[ dup 0 > ] [ dup 0 > ]
[ dup bignum-bits neg shift swap bignum-radix bitand ] [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
[ ] unfold nip ; [ ] unfold nip ;
USE: continuations
: emit-bignum ( n -- ) : emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq dup dup 0 < [ neg ] when bignum>seq
dup length 1+ emit-fixnum [ nip length 1+ emit-fixnum ]
swap emit emit-seq ; [ drop 0 < 1 0 ? emit ]
[ nip emit-seq ]
2tri ;
M: bignum ' M: bignum '
bignum tag-number dup [ emit-bignum ] emit-object ; bignum tag-number dup [ emit-bignum ] emit-object ;
@ -220,28 +223,33 @@ M: f '
! Words ! Words
: emit-word ( word -- ) : emit-word ( word -- )
dup subwords [ emit-word ] each
[ [
dup hashcode ' , [ subwords [ emit-word ] each ]
dup word-name ' , [
dup word-vocabulary ' , [
dup word-def ' , {
dup word-props ' , [ hashcode , ]
f ' , [ word-name , ]
0 , ! count [ word-vocabulary , ]
0 , ! xt [ word-def , ]
0 , ! code [ word-props , ]
0 , ! profiling } cleave
] { } make f ,
\ word type-number object tag-number 0 , ! count
[ emit-seq ] emit-object 0 , ! xt
swap objects get set-at ; 0 , ! code
0 , ! profiling
] { } make [ ' ] map
] bi
\ word type-number object tag-number
[ emit-seq ] emit-object
] keep objects get set-at ;
: word-error ( word msg -- * ) : word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ; [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word ) : transfer-word ( word -- word )
dup target-word swap or ; [ target-word ] keep or ;
: fixup-word ( word -- offset ) : fixup-word ( word -- offset )
transfer-word dup objects get at transfer-word dup objects get at
@ -284,9 +292,10 @@ M: string '
length 0 assert= ; length 0 assert= ;
: emit-dummy-array ( obj type -- ptr ) : emit-dummy-array ( obj type -- ptr )
swap assert-empty [ assert-empty ] [
type-number object tag-number type-number object tag-number
[ 0 emit-fixnum ] emit-object ; [ 0 emit-fixnum ] emit-object
] bi* ;
M: byte-array ' byte-array emit-dummy-array ; M: byte-array ' byte-array emit-dummy-array ;
@ -295,29 +304,28 @@ M: bit-array ' bit-array emit-dummy-array ;
M: float-array ' float-array emit-dummy-array ; M: float-array ' float-array emit-dummy-array ;
! Tuples ! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ]
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer ) : emit-tuple ( tuple -- pointer )
[ dup class word-name "tombstone" =
[ [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
dup class transfer-word tuple-layout ' ,
tuple>array 1 tail-slice [ ' ] map %
] { } make
tuple type-number dup [ emit-seq ] emit-object
]
! Hack
over class word-name "tombstone" =
[ objects get swap cache ] [ call ] if ;
M: tuple ' emit-tuple ; M: tuple ' emit-tuple ;
M: tuple-layout ' M: tuple-layout '
objects get [ objects get [
[ [
dup layout-hashcode ' , {
dup layout-class ' , [ layout-hashcode , ]
dup layout-size ' , [ layout-class , ]
dup layout-superclasses ' , [ layout-size , ]
layout-echelon ' , [ layout-superclasses , ]
] { } make [ layout-echelon , ]
} cleave
] { } make [ ' ] map
\ tuple-layout type-number \ tuple-layout type-number
object tag-number [ emit-seq ] emit-object object tag-number [ emit-seq ] emit-object
] cache ; ] cache ;
@ -328,14 +336,9 @@ M: tombstone '
word-def first objects get [ emit-tuple ] cache ; word-def first objects get [ emit-tuple ] cache ;
! Arrays ! Arrays
: emit-array ( list type tag -- pointer )
>r >r [ ' ] map r> r> [
dup length emit-fixnum
emit-seq
] emit-object ;
M: array ' M: array '
array type-number object tag-number emit-array ; [ ' ] map array type-number object tag-number
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
! Quotations ! Quotations
@ -350,13 +353,6 @@ M: quotation '
] emit-object ] emit-object
] cache ; ] cache ;
! Curries
M: curry '
dup curry-quot ' swap curry-obj '
\ curry type-number object tag-number
[ emit emit ] emit-object ;
! End of the image ! End of the image
: emit-words ( -- ) : emit-words ( -- )
@ -436,8 +432,8 @@ M: curry '
: write-image ( image -- ) : write-image ( image -- )
"Writing image to " write "Writing image to " write
architecture get boot-image-name resource-path architecture get boot-image-name resource-path
dup write "..." print flush [ write "..." print flush ]
binary <file-writer> [ (write-image) ] with-stream ; [ binary <file-writer> [ (write-image) ] with-stream ] bi ;
PRIVATE> PRIVATE>

6
core/bootstrap/layouts/layouts.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: namespaces math words kernel alien byte-arrays USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays hashtables vectors strings sbufs arrays bit-arrays
float-arrays quotations assocs layouts tuples tuples.private ; float-arrays quotations assocs layouts classes.tuple.private
kernel.private ;
BIN: 111 tag-mask set BIN: 111 tag-mask set
8 num-tags set 8 num-tags set
@ -15,6 +16,7 @@ H{
{ bignum BIN: 001 } { bignum BIN: 001 }
{ tuple BIN: 010 } { tuple BIN: 010 }
{ object BIN: 011 } { object BIN: 011 }
{ hi-tag BIN: 011 }
{ ratio BIN: 100 } { ratio BIN: 100 }
{ float BIN: 101 } { float BIN: 101 }
{ complex BIN: 110 } { complex BIN: 110 }
@ -34,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

254
core/bootstrap/primitives.factor
View File

@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
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 tuples strings vectors words quotations assocs layouts classes
tuples.private kernel.private vocabs vocabs.loader source-files classes.builtin classes.tuple classes.tuple.private
definitions slots.deprecated classes.union compiler.units kernel.private vocabs vocabs.loader source-files definitions
bootstrap.image.private io.files ; slots.deprecated classes.union compiler.units
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
@ -29,7 +30,8 @@ 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 root-cache set H{ } clone root-cache set
H{ } clone source-files set H{ } clone source-files set
H{ } clone update-map set H{ } clone update-map set
@ -56,14 +58,13 @@ num-types get f <array> builtins set
"alien.accessors" "alien.accessors"
"arrays" "arrays"
"bit-arrays" "bit-arrays"
"bit-vectors"
"byte-arrays" "byte-arrays"
"byte-vectors"
"classes.private" "classes.private"
"classes.tuple"
"classes.tuple.private"
"compiler.units" "compiler.units"
"continuations.private" "continuations.private"
"float-arrays" "float-arrays"
"float-vectors"
"generator" "generator"
"growable" "growable"
"hashtables" "hashtables"
@ -91,8 +92,6 @@ num-types get f <array> builtins set
"system.private" "system.private"
"threads.private" "threads.private"
"tools.profiler.private" "tools.profiler.private"
"tuples"
"tuples.private"
"words" "words"
"words.private" "words.private"
"vectors" "vectors"
@ -100,42 +99,81 @@ num-types get f <array> builtins set
} [ create-vocab drop ] each } [ create-vocab drop ] each
! Builtin classes ! Builtin classes
: builtin-predicate-quot ( class -- quot ) : lo-tag-eq-quot ( n -- quot )
[ \ tag , , \ eq? , ] [ ] make ;
: hi-tag-eq-quot ( n -- quot )
[ [
"type" word-prop dup [ dup tag ] % \ hi-tag tag-number , \ eq? ,
\ tag-mask get < \ tag \ type ? , , \ eq? , [ [ hi-tag ] % , \ eq? , ] [ ] make ,
[ drop f ] ,
\ if ,
] [ ] make ; ] [ ] make ;
: builtin-predicate-quot ( class -- quot )
"type" word-prop
dup tag-mask get <
[ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
: define-builtin-predicate ( class -- ) : define-builtin-predicate ( class -- )
dup dup builtin-predicate-quot define-predicate ;
dup builtin-predicate-quot define-predicate
predicate-word make-inline ;
: lookup-type-number ( word -- n ) : lookup-type-number ( word -- n )
global [ target-word ] bind type-number ; global [ target-word ] bind type-number ;
: register-builtin ( class -- ) : register-builtin ( class -- )
dup [ dup lookup-type-number "type" set-word-prop ]
dup lookup-type-number "type" set-word-prop [ dup "type" word-prop builtins get set-nth ]
dup "type" word-prop builtins get set-nth ; [ f f builtin-class define-class ]
tri ;
: define-builtin-slots ( symbol slotspec -- ) : define-builtin-slots ( symbol slotspec -- )
dupd 1 simple-slots [ drop ] [ 1 simple-slots ] 2bi
2dup "slots" set-word-prop [ "slots" set-word-prop ] [ define-slots ] 2bi ;
define-slots ;
: define-builtin ( symbol slotspec -- ) : define-builtin ( symbol slotspec -- )
>r >r [ define-builtin-predicate ] keep
dup register-builtin
dup f f builtin-class define-class
dup define-builtin-predicate
r> define-builtin-slots ; r> define-builtin-slots ;
! Forward definitions "fixnum" "math" create register-builtin
"object" "kernel" create t "class" set-word-prop "bignum" "math" create register-builtin
"object" "kernel" create union-class "metaclass" set-word-prop "tuple" "kernel" create register-builtin
"ratio" "math" create register-builtin
"float" "math" create register-builtin
"complex" "math" create register-builtin
"f" "syntax" lookup register-builtin
"array" "arrays" create register-builtin
"wrapper" "kernel" create register-builtin
"float-array" "float-arrays" create register-builtin
"callstack" "kernel" create register-builtin
"string" "strings" create register-builtin
"bit-array" "bit-arrays" create register-builtin
"quotation" "quotations" create register-builtin
"dll" "alien" create register-builtin
"alien" "alien" create register-builtin
"word" "words" create register-builtin
"byte-array" "byte-arrays" create register-builtin
"tuple-layout" "classes.tuple.private" create register-builtin
"null" "kernel" create drop ! Catch-all class for providing a default method.
"object" "kernel" create
[ f builtins get [ ] subset union-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi
"object?" "kernel" vocab-words delete-at
! Class of objects with object tag
"hi-tag" "kernel.private" create
builtins get num-tags get tail define-union-class
! Empty class with no instances
"null" "kernel" create
[ f { } union-class define-class ]
[ [ drop f ] "predicate" set-word-prop ]
bi
"null?" "kernel" vocab-words delete-at
"fixnum" "math" create { } define-builtin "fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@ -291,81 +329,65 @@ define-builtin
"callstack" "kernel" create { } define-builtin "callstack" "kernel" create { } define-builtin
"tuple-layout" "tuples.private" create { "tuple-layout" "classes.tuple.private" create {
{ {
{ "fixnum" "math" } { "fixnum" "math" }
"hashcode" "hashcode"
{ "layout-hashcode" "tuples.private" } { "layout-hashcode" "classes.tuple.private" }
f f
} }
{ {
{ "word" "words" } { "word" "words" }
"class" "class"
{ "layout-class" "tuples.private" } { "layout-class" "classes.tuple.private" }
f f
} }
{ {
{ "fixnum" "math" } { "fixnum" "math" }
"size" "size"
{ "layout-size" "tuples.private" } { "layout-size" "classes.tuple.private" }
f f
} }
{ {
{ "array" "arrays" } { "array" "arrays" }
"superclasses" "superclasses"
{ "layout-superclasses" "tuples.private" } { "layout-superclasses" "classes.tuple.private" }
f f
} }
{ {
{ "fixnum" "math" } { "fixnum" "math" }
"echelon" "echelon"
{ "layout-echelon" "tuples.private" } { "layout-echelon" "classes.tuple.private" }
f f
} }
} define-builtin } define-builtin
"tuple" "kernel" create { } define-builtin "tuple" "kernel" create {
[ { } define-builtin ]
"tuple" "kernel" lookup [ { "delegate" } "slot-names" set-word-prop ]
{ [ define-tuple-layout ]
{ [
{ "object" "kernel" } {
"delegate" {
{ "delegate" "kernel" } { "object" "kernel" }
{ "set-delegate" "kernel" } "delegate"
} { "delegate" "kernel" }
} { "set-delegate" "kernel" }
define-tuple-slots }
}
"tuple" "kernel" lookup define-tuple-layout [ drop ] [ generate-tuple-slots ] 2bi
[ "slots" set-word-prop ]
! Define general-t type, which is any object that is not f. [ define-slots ]
"general-t" "kernel" create 2bi
"f" "syntax" lookup builtins get remove [ ] subset f union-class ]
define-class } cleave
"f" "syntax" create [ not ] "predicate" set-word-prop "f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" create "syntax" vocab-words delete-at "f?" "syntax" vocab-words delete-at
"general-t" "kernel" create [ ] "predicate" set-word-prop
"general-t?" "kernel" create "syntax" vocab-words delete-at
! Catch-all class for providing a default method.
"object" "kernel" create [ drop t ] "predicate" set-word-prop
"object" "kernel" create
builtins get [ ] subset f union-class define-class
! Class of objects with object tag
"hi-tag" "classes.private" create
builtins get num-tags get tail f union-class define-class
! Null class with no instances.
"null" "kernel" create [ drop f ] "predicate" set-word-prop
"null" "kernel" create { } f union-class define-class
! 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
@ -378,7 +400,7 @@ builtins get num-tags get tail f union-class define-class
! Some tuple classes ! Some tuple classes
"hashtable" "hashtables" create "hashtable" "hashtables" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "array-capacity" "sequences.private" } { "array-capacity" "sequences.private" }
@ -399,7 +421,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class } define-tuple-class
"sbuf" "sbufs" create "sbuf" "sbufs" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "string" "strings" } { "string" "strings" }
@ -415,7 +437,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class } define-tuple-class
"vector" "vectors" create "vector" "vectors" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "array" "arrays" } { "array" "arrays" }
@ -430,56 +452,8 @@ builtins get num-tags get tail f union-class define-class
} }
} define-tuple-class } define-tuple-class
"byte-vector" "byte-vectors" create
"tuple" "kernel" lookup
{
{
{ "byte-array" "byte-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"bit-vector" "bit-vectors" create
"tuple" "kernel" lookup
{
{
{ "bit-array" "bit-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"float-vector" "float-vectors" create
"tuple" "kernel" lookup
{
{
{ "float-array" "float-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"curry" "kernel" create "curry" "kernel" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "object" "kernel" } { "object" "kernel" }
@ -495,11 +469,12 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class } define-tuple-class
"curry" "kernel" lookup "curry" "kernel" lookup
dup f "inline" set-word-prop [ f "inline" set-word-prop ]
dup tuple-layout [ <tuple-boa> ] curry define [ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define
"compose" "kernel" create "compose" "kernel" create
"tuple" "kernel" lookup tuple
{ {
{ {
{ "object" "kernel" } { "object" "kernel" }
@ -515,8 +490,9 @@ dup tuple-layout [ <tuple-boa> ] curry define
} define-tuple-class } define-tuple-class
"compose" "kernel" lookup "compose" "kernel" lookup
dup f "inline" set-word-prop [ f "inline" set-word-prop ]
dup tuple-layout [ <tuple-boa> ] curry define [ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define
! Primitive words ! Primitive words
: make-primitive ( word vocab n -- ) : make-primitive ( word vocab n -- )
@ -613,8 +589,7 @@ dup tuple-layout [ <tuple-boa> ] curry define
{ "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" }
@ -629,7 +604,6 @@ dup tuple-layout [ <tuple-boa> ] curry define
{ "code-room" "memory" } { "code-room" "memory" }
{ "os-env" "system" } { "os-env" "system" }
{ "millis" "system" } { "millis" "system" }
{ "type" "kernel.private" }
{ "tag" "kernel.private" } { "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" } { "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" } { "dlopen" "alien" }
@ -664,10 +638,6 @@ dup tuple-layout [ <tuple-boa> ] curry define
{ "set-alien-double" "alien.accessors" } { "set-alien-double" "alien.accessors" }
{ "alien-cell" "alien.accessors" } { "alien-cell" "alien.accessors" }
{ "set-alien-cell" "alien.accessors" } { "set-alien-cell" "alien.accessors" }
{ "alien>char-string" "alien" }
{ "string>char-alien" "alien" }
{ "alien>u16-string" "alien" }
{ "string>u16-alien" "alien" }
{ "(throw)" "kernel.private" } { "(throw)" "kernel.private" }
{ "alien-address" "alien" } { "alien-address" "alien" }
{ "slot" "slots.private" } { "slot" "slots.private" }
@ -694,25 +664,27 @@ dup tuple-layout [ <tuple-boa> ] curry define
{ "<string>" "strings" } { "<string>" "strings" }
{ "array>quotation" "quotations.private" } { "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" } { "quotation-xt" "quotations" }
{ "<tuple>" "tuples.private" } { "<tuple>" "classes.tuple.private" }
{ "<tuple-layout>" "tuples.private" } { "<tuple-layout>" "classes.tuple.private" }
{ "profiling" "tools.profiler.private" } { "profiling" "tools.profiler.private" }
{ "become" "kernel.private" } { "become" "kernel.private" }
{ "(sleep)" "threads.private" } { "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" } { "<float-array>" "float-arrays" }
{ "<tuple-boa>" "tuples.private" } { "<tuple-boa>" "classes.tuple.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" } { "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" } { "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" } { "innermost-frame-scan" "kernel.private" }
{ "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

1
core/bootstrap/stage1.factor
View File

@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ;
! Rehash hashtables, since bootstrap.image creates them ! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms ! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each [ hashtable? ] instances [ rehash ] each
boot boot
] % ] %

22
core/bootstrap/stage2.factor
View File

@ -5,13 +5,13 @@ 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
: default-image-name ( -- string ) : default-image-name ( -- string )
vm file-name windows? [ "." split1 drop ] when vm file-name os windows? [ "." split1 drop ] when
".image" append resource-path ; ".image" append resource-path ;
: do-crossref ( -- ) : do-crossref ( -- )
@ -23,14 +23,10 @@ SYMBOL: bootstrap-time
: load-components ( -- ) : load-components ( -- )
"exclude" "include" "exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply [ 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
@ -65,8 +61,8 @@ parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless "-no-crossref" cli-args member? [ do-crossref ] unless
! Set dll paths ! Set dll paths
wince? [ "windows.ce" require ] when os wince? [ "windows.ce" require ] when
winnt? [ "windows.nt" require ] when os winnt? [ "windows.nt" require ] when
"deploy-vocab" get [ "deploy-vocab" get [
"stage2: deployment mode" print "stage2: deployment mode" print
@ -79,10 +75,6 @@ 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

5
core/bootstrap/syntax.factor
View File

@ -14,16 +14,13 @@ IN: bootstrap.syntax
";" ";"
"<PRIVATE" "<PRIVATE"
"?{" "?{"
"?V{"
"BIN:" "BIN:"
"B{" "B{"
"BV{"
"C:" "C:"
"CHAR:" "CHAR:"
"DEFER:" "DEFER:"
"ERROR:" "ERROR:"
"F{" "F{"
"FV{"
"FORGET:" "FORGET:"
"GENERIC#" "GENERIC#"
"GENERIC:" "GENERIC:"
@ -43,6 +40,7 @@ IN: bootstrap.syntax
"PRIMITIVE:" "PRIMITIVE:"
"PRIVATE>" "PRIVATE>"
"SBUF\"" "SBUF\""
"SINGLETON:"
"SYMBOL:" "SYMBOL:"
"TUPLE:" "TUPLE:"
"T{" "T{"
@ -66,6 +64,7 @@ IN: bootstrap.syntax
"CS{" "CS{"
"<<" "<<"
">>" ">>"
"call-next-method"
} [ "syntax" create drop ] each } [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol "t" "syntax" lookup define-symbol

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 ;

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

@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable vectors definitions source-files compiler.units growable
random inference effects ; random inference effects kernel.private sbufs ;
: class= [ class< ] 2keep swap class< and ; : class= [ class< ] 2keep swap class< and ;
@ -23,8 +23,8 @@ random inference effects ;
[ t ] [ number object number class-and* ] unit-test [ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test [ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test [ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ general-t \ f null class-and* ] unit-test [ t ] [ \ f class-not \ f null class-and* ] unit-test
[ t ] [ general-t \ f object class-or* ] unit-test [ t ] [ \ f class-not \ f object class-or* ] unit-test
TUPLE: first-one ; TUPLE: first-one ;
TUPLE: second-one ; TUPLE: second-one ;
@ -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 ;
@ -96,7 +96,7 @@ UNION: z1 b1 c1 ;
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ growable hi-tag classes-intersect? ] unit-test [ f ] [ growable \ hi-tag classes-intersect? ] unit-test
[ t ] [ [ t ] [
growable tuple sequence class-and class< growable tuple sequence class-and class<
@ -144,6 +144,48 @@ UNION: z1 b1 c1 ;
[ f ] [ null class-not null class= ] unit-test [ f ] [ null class-not null class= ] unit-test
[ t ] [
fixnum class-not
fixnum fixnum class-not class-or
class<
] unit-test
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ integer string array reversed sbuf
slice vector quotation ]
sort-classes min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
sort-classes min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
sort-classes min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
sort-classes min-class
] unit-test
[ reversed ] [
\ reversed
[ integer reversed slice ]
sort-classes min-class
] unit-test
[ f ] [ null { number fixnum null } min-class ] unit-test
! Test for hangs? ! Test for hangs?
: random-class classes random ; : random-class classes random ;

47
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
; math hashtables kernel.private sets ;
IN: classes.algebra IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value ) : 2cache ( key1 key2 assoc quot -- value )
@ -67,7 +67,7 @@ C: <anonymous-complement> anonymous-complement
members>> [ class< ] with all? ; members>> [ class< ] with all? ;
: anonymous-complement< ( first second -- ? ) : anonymous-complement< ( first second -- ? )
[ class>> ] 2apply swap class< ; [ class>> ] bi@ swap class< ;
: (class<) ( first second -- -1/0/1 ) : (class<) ( first second -- -1/0/1 )
{ {
@ -77,14 +77,14 @@ C: <anonymous-complement> anonymous-complement
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] } { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] } { [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ over members ] [ left-union-class< ] } { [ over members ] [ left-union-class< ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] } { [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] } { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ 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 -- ? )
@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
members>> [ class-and ] with map <anonymous-union> ; members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class ) : left-anonymous-intersection-and ( first second -- class )
>r members>> r> add <anonymous-intersection> ; >r members>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class ) : right-anonymous-intersection-and ( first second -- class )
members>> swap add <anonymous-intersection> ; members>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class ) : (class-and) ( first second -- class )
{ {
@ -154,14 +154,14 @@ 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 )
>r members>> r> add <anonymous-union> ; >r members>> r> suffix <anonymous-union> ;
: right-anonymous-union-or ( first second -- class ) : right-anonymous-union-or ( first second -- class )
members>> swap add <anonymous-union> ; members>> swap suffix <anonymous-union> ;
: (class-or) ( first second -- class ) : (class-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 )
@ -193,9 +193,8 @@ C: <anonymous-complement> anonymous-complement
[ ] unfold nip ; [ ] unfold nip ;
: min-class ( class seq -- class/f ) : min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [ over [ classes-intersect? ] curry subset
2drop f dup empty? [ 2drop f ] [
] [
tuck [ class< ] with all? [ peek ] [ drop f ] if tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ; ] if ;
@ -205,18 +204,12 @@ 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 )
[ (flatten-class) ] H{ } make-assoc ; [ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: flatten-builtin-class ( class -- assoc ) : flatten-builtin-class ( class -- assoc )
flatten-class [ flatten-class [
dup tuple class< [ 2drop tuple tuple ] when dup tuple class< [ 2drop tuple tuple ] when
@ -229,5 +222,5 @@ C: <anonymous-complement> anonymous-complement
: class-tags ( class -- tag/f ) : class-tags ( class -- tag/f )
class-types [ class-types [
dup num-tags get >= dup num-tags get >=
[ drop object tag-number ] when [ drop \ hi-tag tag-number ] when
] map prune ; ] map prune ;

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
@ -21,7 +13,6 @@ $nl
{ { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } } { { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
{ { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } } { { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
{ { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } } { { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
{ { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
} }
"The set of class predicate words is a class:" "The set of class predicate words is a class:"
{ $subsection predicate } { $subsection predicate }
@ -39,16 +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 "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." } ;

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

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files classes.algebra vectors definitions source-files
compiler.units ; compiler.units kernel.private ;
IN: classes.tests IN: classes.tests
! DEFER: bah ! DEFER: bah
@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
! Test generic see and parsing ! Test generic see and parsing
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] [ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test [ [ \ bah see ] with-string-writer ] unit-test
[ t ] [ 3 object instance? ] unit-test
[ t ] [ 3 fixnum instance? ] unit-test
[ f ] [ 3 float instance? ] unit-test
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
[ t ] [ "hi" \ hi-tag instance? ] unit-test

72
core/classes/classes.factor
View File

@ -25,23 +25,16 @@ SYMBOL: class-or-cache
class-and-cache get clear-assoc class-and-cache get clear-assoc
class-or-cache get clear-assoc ; class-or-cache get clear-assoc ;
PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
SYMBOL: update-map SYMBOL: update-map
SYMBOL: builtins
PREDICATE: builtin-class < class PREDICATE: class < word
"metaclass" word-prop builtin-class eq? ; "class" word-prop ;
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 ;
@ -58,7 +51,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
dup class? [ "superclass" word-prop ] [ drop f ] if ; dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers ) : superclasses ( class -- supers )
[ dup ] [ dup superclass swap ] [ ] unfold reverse nip ; [ superclass ] follow reverse ;
: members ( class -- seq ) : members ( class -- seq )
#! Output f for non-classes to work with algebra code #! Output f for non-classes to work with algebra code
@ -72,7 +65,7 @@ M: word reset-class drop ;
! update-map ! update-map
: class-uses ( class -- seq ) : class-uses ( class -- seq )
dup members swap superclass [ add ] when* ; [ members ] [ superclass ] bi [ suffix ] when* ;
: class-usages ( class -- assoc ) : class-usages ( class -- assoc )
[ update-map get at ] closure ; [ update-map get at ] closure ;
@ -83,41 +76,50 @@ M: word reset-class drop ;
: update-map- ( class -- ) : update-map- ( class -- )
dup class-uses update-map get remove-vertex ; dup class-uses update-map get remove-vertex ;
PRIVATE> : make-class-props ( superclass members metaclass -- assoc )
: define-class-props ( members superclass metaclass -- assoc )
[ [
"metaclass" set [ dup [ bootstrap-word ] when "superclass" set ]
dup [ bootstrap-word ] when "superclass" set [ [ bootstrap-word ] map "members" set ]
[ bootstrap-word ] map "members" set [ "metaclass" set ]
tri*
] H{ } make-assoc ; ] H{ } make-assoc ;
: (define-class) ( word props -- ) : (define-class) ( word props -- )
over reset-class >r
over deferred? [ over define-symbol ] when dup reset-class
>r dup word-props r> union over set-word-props dup deferred? [ dup define-symbol ] when
dup predicate-word 2dup 1quotation "predicate" set-word-prop dup word-props
over "predicating" set-word-prop r> assoc-union over set-word-props
t "class" set-word-prop ; dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
[ drop t "class" set-word-prop ]
2tri ;
GENERIC: update-predicate ( class -- ) PRIVATE>
M: class update-predicate drop ; GENERIC: update-class ( class -- )
: update-predicates ( assoc -- ) M: class update-class drop ;
[ drop update-predicate ] assoc-each ;
GENERIC: update-methods ( assoc -- ) GENERIC: update-methods ( assoc -- )
: define-class ( word members superclass metaclass -- ) : update-classes ( class -- )
class-usages
[ [ drop update-class ] assoc-each ]
[ update-methods ]
bi ;
: define-class ( word superclass members metaclass -- )
#! If it was already a class, update methods after. #! If it was already a class, update methods after.
reset-caches reset-caches
define-class-props make-class-props
over update-map- [ drop update-map- ]
dupd (define-class) [ (define-class) ]
dup update-map+ [ drop update-map+ ]
class-usages dup update-predicates update-methods ; 2tri ;
GENERIC: class ( object -- class ) inline GENERIC: class ( object -- class )
M: object class type type>class ; : instance? ( obj class -- ? )
"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." } ;

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

@ -1,13 +1,13 @@
! 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: classes classes.union words kernel sequences USING: classes classes.union words kernel sequences
definitions combinators arrays ; definitions combinators arrays accessors ;
IN: classes.mixin IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ; PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class M: mixin-class reset-class
{ "metaclass" "members" "mixin" } reset-props ; { "class" "metaclass" "members" "mixin" } reset-props ;
: redefine-mixin-class ( class members -- ) : redefine-mixin-class ( class members -- )
dupd define-union-class dupd define-union-class
@ -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 -- )
@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
swap redefine-mixin-class ; inline swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- ) : add-mixin-instance ( class mixin -- )
[ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ; [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- ) : remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ; [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
@ -47,14 +47,13 @@ TUPLE: mixin-instance loc class mixin ;
M: mixin-instance equal? M: mixin-instance equal?
{ {
{ [ over mixin-instance? not ] [ f ] } { [ over mixin-instance? not ] [ f ] }
{ [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] } { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
{ [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] } { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
{ [ t ] [ t ] } [ t ]
} cond 2nip ; } cond 2nip ;
M: mixin-instance hashcode* M: mixin-instance hashcode*
{ mixin-instance-class mixin-instance-mixin } get-slots [ class>> ] [ mixin>> ] bi 2array hashcode* ;
2array hashcode* ;
: <mixin-instance> ( class mixin -- definition ) : <mixin-instance> ( class mixin -- definition )
{ set-mixin-instance-class set-mixin-instance-mixin } { set-mixin-instance-class set-mixin-instance-mixin }

16
core/classes/predicate/predicate.factor
View File

@ -14,11 +14,19 @@ PREDICATE: predicate-class < class
] [ ] make ; ] [ ] make ;
: define-predicate-class ( class superclass definition -- ) : define-predicate-class ( class superclass definition -- )
>r >r dup f r> predicate-class define-class r> [ drop f predicate-class define-class ]
dupd "predicate-definition" set-word-prop [ nip "predicate-definition" set-word-prop ]
dup predicate-quot define-predicate ; [
2drop
[ dup predicate-quot define-predicate ]
[ update-classes ]
bi
] 3tri ;
M: predicate-class reset-class M: predicate-class reset-class
{ {
"metaclass" "predicate-definition" "superclass" "class"
"metaclass"
"predicate-definition"
"superclass"
} reset-props ; } reset-props ;

0
extra/lint/authors.txt → core/classes/singleton/authors.txt
View File

34
core/classes/singleton/singleton-docs.factor Normal file
View File

@ -0,0 +1,34 @@
USING: help.markup help.syntax kernel words ;
IN: classes.singleton
ARTICLE: "singletons" "Singleton classes"
"A singleton is a class with only one instance and with no state."
{ $subsection POSTPONE: SINGLETON: }
{ $subsection define-singleton-class }
"The set of all singleton classes is itself a class:"
{ $subsection singleton-class? }
{ $subsection singleton-class } ;
HELP: SINGLETON:
{ $syntax "SINGLETON: class" }
{ $values
{ "class" "a new singleton to define" }
}
{ $description
"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!" }
} ;
HELP: define-singleton-class
{ $values { "word" "a new word" } }
{ $description
"Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ;
{ POSTPONE: SINGLETON: define-singleton-class } related-words
HELP: singleton-class
{ $class-description "The class of singleton classes." } ;
ABOUT: "singletons"

12
core/classes/singleton/singleton-tests.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton-class? ] unit-test
[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test

11
core/classes/singleton/singleton.factor Executable file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.predicate kernel sequences words ;
IN: classes.singleton
PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
[ [ eq? ] curry ] bi sequence= ;
: define-singleton-class ( word -- )
\ word over [ eq? ] curry define-predicate-class ;

0
core/tuples/authors.txt → core/classes/tuple/authors.txt
View File

0
core/tuples/summary.txt → core/classes/tuple/summary.txt
View File

375
core/classes/tuple/tuple-docs.factor Executable file
View File

@ -0,0 +1,375 @@
USING: generic help.markup help.syntax kernel
classes.tuple.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ;
IN: classes.tuple
ARTICLE: "parametrized-constructors" "Parameterized constructors"
"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."
$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:"
{ $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:"
{ $code
"TUPLE: color red green blue alpha ;"
""
"! The following two are equivalent"
"C: <rgba> rgba"
": <rgba> color boa ;"
""
"! We can define constructors which call other constructors"
": <rgb> f <rgba> ;"
""
"! The following two are equivalent"
": <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-inheritance-anti-example" "When not to use tuple subclassing"
"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."
{ $heading "Anti-pattern #1: subclassing for has-a" }
"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."
$nl
"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
"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "."
$nl
"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."
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
"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."
{ $see-also "parametrized-constructors" } ;
ARTICLE: "tuple-subclassing" "Tuple subclassing"
"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" } "."
$nl
"To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":"
{ $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"
"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."
{ $subsection >tuple }
{ $subsection tuple>array }
{ $subsection tuple-slots }
"Tuple classes can also be defined at run time:"
{ $subsection define-tuple-class }
{ $see-also "slots" "mirrors" } ;
ARTICLE: "tuple-examples" "Tuple examples"
"An example:"
{ $code "TUPLE: employee name salary position ;" }
"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
{ $table
{ "Reader" "Writer" "Setter" "Changer" }
{ { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } }
{ { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
{ { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } }
}
"We can define a constructor which makes an empty employee:"
{ $code ": <employee> ( -- employee )"
" employee new ;" }
"Or we may wish the default constructor to always give employees a starting salary:"
{ $code
": <employee> ( -- employee )"
" employee new"
" 40000 >>salary ;"
}
"We can define more refined constructors:"
{ $code
": <manager> ( -- manager )"
" <employee> \"project manager\" >>position ;" }
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
": <employee> ( name position -- person )"
" 40000 employee boa ;"
}
"Now we can define more specific constructors:"
{ $code
": <manager> ( name -- person )"
" \"manager\" <person> ;" }
"An example using reader words:"
{ $code
"TUPLE: check to amount number ;"
""
"SYMBOL: checks"
""
": <check> ( to amount -- check )"
" checks counter check boa ;"
""
": biweekly-paycheck ( employee -- check )"
" dup name>> swap salary>> 26 / <check> ;"
}
"An example of using a changer:"
{ $code
": positions"
" {"
" \"junior programmer\""
" \"senior programmer\""
" \"project manager\""
" \"department manager\""
" \"executive\""
" \"CTO\""
" \"CEO\""
" \"enterprise Java world dictator\""
" } ;"
""
": next-position ( role -- newrole )"
" positions [ index 1+ ] keep nth ;"
""
": promote ( person -- person )"
" [ 1.2 * ] change-salary"
" [ 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"
"Tuples are user-defined classes composed of named slots."
{ $subsection "tuple-examples" }
"A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
$nl
"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
"Expressing relationships through the object system:"
{ $subsection "tuple-subclassing" }
"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" } "." ;
ABOUT: "tuples"
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
$nl
"Tuple classes have additional word properties:"
{ $list
{ { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
{ { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
{ { $snippet "\"tuple-size\"" } " - the number of slots" }
} } ;
HELP: define-tuple-predicate
{ $values { "class" tuple-class } }
{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
$low-level-note ;
HELP: redefine-tuple-class
{ $values { "class" class } { "superclass" class } { "slots" "a sequence of strings" } }
{ $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
$nl
"If the class is not a tuple class word, this word does nothing." }
$low-level-note ;
HELP: tuple-slots
{ $values { "tuple" tuple } { "seq" sequence } }
{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ;
{ tuple-slots tuple>array } related-words
HELP: define-tuple-slots
{ $values { "class" tuple-class } }
{ $description "Defines slot accessor and mutator words for the tuple." }
$low-level-note ;
HELP: check-tuple
{ $values { "class" class } }
{ $description "Throws a " { $link check-tuple } " error if " { $snippet "word" } " is not a tuple class word." }
{ $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
HELP: define-tuple-class
{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } }
{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
HELP: >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 and the remainder the declared slots."
$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 } "." }
{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
HELP: tuple>array ( tuple -- 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 remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: new
{ $values { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
{ $examples
{ $example
"USING: kernel prettyprint ;"
"TUPLE: employee number name department ;"
"employee new ."
"T{ employee f f f f }"
}
} ;
HELP: construct
{ $values { "..." "slot values" } { "slots" "a sequence of setter words" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } ", storing consecutive stack values into the slots of the new tuple using setter words in " { $snippet "slots" } ". The top-most stack element is stored in the right-most slot." }
{ $examples
"We can define a class:"
{ $code "TUPLE: color red green blue alpha ;" }
"Together with two constructors:"
{ $code
": <rgb> ( r g b -- color )"
" { set-color-red set-color-green set-color-blue }"
" color construct ;"
""
": <rgba> ( r g b a -- color )"
" { set-color-red set-color-green set-color-blue set-color-alpha }"
" color construct ;"
}
"The last definition is actually equivalent to the following:"
{ $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
"Which can be abbreviated further:"
{ $code "C: <rgba> color" }
} ;
HELP: boa
{ $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." }
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;

544
core/classes/tuple/tuple-tests.factor Executable file
View File

@ -0,0 +1,544 @@
USING: definitions generic kernel kernel.private math
math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
columns ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
: <rect> rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
[ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ;
C: <redefinition-test> redefinition-test
<redefinition-test> "redefinition-test" set
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
! Make sure we handle changing shapes!
TUPLE: point x y ;
C: <point> point
[ ] [ 100 200 <point> "p" set ] unit-test
! Use eval to sequence parsing explicitly
[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test
[ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
[ 4 ] [ "p" get tuple-size ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
[ 3 ] [ "p" get tuple-size ] unit-test
[ "p" get x>> ] must-fail
[ 200 ] [ "p" get y>> ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
TUPLE: predicate-test ;
C: <predicate-test> predicate-test
: predicate-test drop f ;
[ t ] [ <predicate-test> predicate-test? ] unit-test
PREDICATE: silly-pred < tuple
class \ rect = ;
GENERIC: area
M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ;
M: circle area radius>> sq pi * ;
[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
! Hashcode breakage
TUPLE: empty ;
C: <empty> empty
[ t ] [ <empty> hashcode fixnum? ] unit-test
! Compiler regression
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
TUPLE: size-test a b c d ;
[ t ] [
T{ size-test } tuple-size
size-test tuple-size =
] unit-test
GENERIC: <yo-momma>
TUPLE: yo-momma ;
"IN: classes.tuple.tests C: <yo-momma> yo-momma" eval
[ f ] [ \ <yo-momma> generic? ] unit-test
! Test forget
[
[ t ] [ \ yo-momma class? ] unit-test
[ ] [ \ yo-momma forget ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
[ f ] [ \ yo-momma crossref get at ] unit-test
] with-compilation-unit
TUPLE: loc-recording ;
[ f ] [ \ loc-recording where not ] unit-test
! 'forget' wasn't robust enough
TUPLE: forget-robustness ;
GENERIC: forget-robustness-generic
M: forget-robustness forget-robustness-generic ;
M: integer forget-robustness-generic ;
[
[ ] [ \ forget-robustness-generic forget ] unit-test
[ ] [ \ forget-robustness forget ] unit-test
[ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
] with-compilation-unit
! rapido found this one
GENERIC# m1 0 ( s n -- n )
GENERIC# m2 1 ( s n -- v )
TUPLE: t1 ;
M: t1 m1 drop ;
M: t1 m2 nip ;
TUPLE: t2 ;
M: t2 m1 drop ;
M: t2 m2 nip ;
TUPLE: t3 ;
M: t3 m1 drop ;
M: t3 m2 nip ;
TUPLE: t4 ;
M: t4 m1 drop ;
M: t4 m2 nip ;
C: <t4> t4
[ 1 ] [ 1 <t4> m1 ] unit-test
[ 1 ] [ <t4> 1 m2 ] unit-test
! another combination issue
GENERIC: silly
UNION: my-union slice repetition column array vector reversed ;
M: my-union silly "x" ;
M: array silly "y" ;
M: column silly "fdsfds" ;
M: repetition silly "zzz" ;
M: reversed silly "zz" ;
M: slice silly "tt" ;
M: string silly "t" ;
M: vector silly "z" ;
[ "zz" ] [ 123 <reversed> silly nip ] unit-test
! Typo
SYMBOL: not-a-tuple-class
[
"IN: classes.tuple.tests C: <not-a-tuple-class> not-a-tuple-class"
eval
] must-fail
[ t ] [
"not-a-tuple-class" "classes.tuple.tests" lookup symbol?
] unit-test
! Missing check
[ not-a-tuple-class boa ] must-fail
[ not-a-tuple-class new ] must-fail
TUPLE: erg's-reshape-problem a b c d ;
C: <erg's-reshape-problem> erg's-reshape-problem
! We want to make sure constructors are recompiled when
! tuples are reshaped
: cons-test-1 \ erg's-reshape-problem new ;
: cons-test-2 \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ error>> no-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
C: <computer> computer
[ "TUPLE: computer cpu ram ;" ] [
[ \ computer see ] with-string-writer string-lines second
] unit-test
TUPLE: laptop < computer battery ;
C: <laptop> laptop
[ t ] [ laptop tuple-class? ] unit-test
[ t ] [ laptop tuple class< ] unit-test
[ t ] [ laptop computer class< ] unit-test
[ t ] [ laptop computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
[ t ] [ "laptop" get laptop? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
: test-laptop-slot-values
[ laptop ] [ "laptop" get class ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test
[ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
test-laptop-slot-values
[ laptop ] [
"laptop" get tuple-layout
dup layout-echelon swap
layout-superclasses nth
] unit-test
[ "TUPLE: laptop < computer battery ;" ] [
[ \ laptop see ] with-string-writer string-lines second
] unit-test
[ { tuple computer laptop } ] [ laptop superclasses ] unit-test
TUPLE: server < computer rackmount ;
C: <server> server
[ t ] [ server tuple-class? ] unit-test
[ t ] [ server tuple class< ] unit-test
[ t ] [ server computer class< ] unit-test
[ t ] [ server computer classes-intersect? ] unit-test
[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
[ t ] [ "server" get server? ] unit-test
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
: test-server-slot-values
[ server ] [ "server" get class ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
[ "1U" ] [ "server" get rackmount>> ] unit-test ;
test-server-slot-values
[ f ] [ "server" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test
[ f ] [ server laptop class< ] unit-test
[ f ] [ laptop server class< ] unit-test
[ f ] [ laptop server classes-intersect? ] unit-test
[ f ] [ 1 2 <computer> laptop? ] unit-test
[ f ] [ \ + server? ] unit-test
[ "TUPLE: server < computer rackmount ;" ] [
[ \ server see ] with-string-writer string-lines second
] unit-test
[
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
] must-fail
! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ;
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
[ f ] [ electronic-device laptop class< ] unit-test
[ t ] [ server electronic-device class< ] unit-test
[ t ] [ laptop server class-or electronic-device class< ] unit-test
[ t ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test
[ t ] [ "server" get electronic-device? ] unit-test
[ t ] [ "server" get computer? ] unit-test
[ f ] [ "server" get laptop? ] unit-test
[ t ] [ "server" get server? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
[ f ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
TUPLE: make-me-some-accessors voltage grounded? ;
[ f ] [ "laptop" get voltage>> ] unit-test
[ f ] [ "server" get voltage>> ] unit-test
[ ] [ "laptop" get 220 >>voltage drop ] unit-test
[ ] [ "server" get 110 >>voltage drop ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously
"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
test-laptop-slot-values
test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
C: <test2> test2
"a" "b" <test2> "test" set
: test-a/b
[ "a" ] [ "test" get a>> ] unit-test
[ "b" ] [ "test" get b>> ] unit-test ;
test-a/b
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
test-a/b
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
test-a/b
! Twice in the same compilation unit
[
test1 tuple { "a" "x" "y" } define-tuple-class
test1 tuple { "a" "y" } define-tuple-class
] with-compilation-unit
test-a/b
! Moving slots up and down
TUPLE: move-up-1 a b ;
TUPLE: move-up-2 < move-up-1 c ;
T{ move-up-2 f "a" "b" "c" } "move-up" set
: test-move-up
[ "a" ] [ "move-up" get a>> ] unit-test
[ "b" ] [ "move-up" get b>> ] unit-test
[ "c" ] [ "move-up" get c>> ] unit-test ;
test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
! Constructors must be recompiled when changing superclass
TUPLE: constructor-update-1 xxx ;
TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
C: <constructor-update-2> constructor-update-2
{ 3 1 } [ <constructor-update-2> ] must-infer-as
[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
{ 5 1 } [ <constructor-update-2> ] must-infer-as
[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
! Redefinition problem
TUPLE: redefinition-problem ;
UNION: redefinition-problem' redefinition-problem integer ;
[ t ] [ 3 redefinition-problem'? ] unit-test
TUPLE: redefinition-problem-2 ;
"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval
[ t ] [ 3 redefinition-problem'? ] unit-test
! Hardcore unit tests
USE: threads
\ thread slot-names "slot-names" set
[ ] [
[
\ thread tuple { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop
[
\ thread tuple "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test
USE: vocabs
\ vocab slot-names "slot-names" set
[ ] [
[
\ vocab tuple { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
\ vocab tuple "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test
[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
"IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
: accessor-exists? ( class name -- ? )
>r "forget-accessors-test" "classes.tuple.tests" lookup r>
">>" append "accessors" lookup method >boolean ;
[ t ] [ "x" accessor-exists? ] unit-test
[ t ] [ "y" accessor-exists? ] unit-test
[ t ] [ "z" accessor-exists? ] unit-test
[ [ ] ] [
"IN: classes.tuple.tests GENERIC: forget-accessors-test"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
[ f ] [ "x" accessor-exists? ] unit-test
[ f ] [ "y" accessor-exists? ] unit-test
[ f ] [ "z" accessor-exists? ] unit-test
TUPLE: another-forget-accessors-test ;
[ [ ] ] [
"IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
<string-reader>
"another-forget-accessors-test" parse-stream
] 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

252
core/classes/tuple/tuple.factor Executable file
View File

@ -0,0 +1,252 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ;
IN: classes.tuple
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ;
<PRIVATE
GENERIC: tuple-layout ( object -- layout )
M: tuple-class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
M: tuple-layout tuple-layout ;
: tuple-size tuple-layout layout-size ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
[ tuple-size ] [ ] [ tuple-layout ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
PRIVATE>
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
layout-class prefix ;
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array )
tuple-layout <tuple> [
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
] keep ;
: >tuple ( tuple -- seq )
unclip slots>tuple ;
: slot-names ( class -- seq )
"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
: tuple= ( tuple1 tuple2 -- ? )
2dup [ tuple-layout ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
] [
2drop f
] if ;
! Predicate generation. We optimize at the expense of simplicity
: (tuple-predicate-quot) ( class -- quot )
#! 4 slot == layout-superclasses
#! 5 slot == layout-echelon
[
[ 1 slot dup 5 slot ] %
dup tuple-layout layout-echelon ,
[ fixnum>= ] %
[
dup tuple-layout layout-echelon ,
[ swap 4 slot array-nth ] %
literalize ,
[ eq? ] %
] [ ] make ,
[ drop f ] ,
\ if ,
] [ ] make ;
: tuple-predicate-quot ( class -- quot )
[
[ dup tuple? ] %
(tuple-predicate-quot) ,
[ drop f ] ,
\ if ,
] [ ] make ;
: define-tuple-predicate ( class -- )
dup tuple-predicate-quot define-predicate ;
: superclass-size ( class -- n )
superclasses 1 head-slice*
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs )
over superclass-size 2 + simple-slots ;
: define-tuple-slots ( class -- )
dup dup "slot-names" word-prop generate-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ] ! new
[ define-slots ] ! old
2tri ;
: make-tuple-layout ( class -- layout )
[ ]
[ [ superclass-size ] [ slot-names length ] bi + ]
[ superclasses dup length 1- ] tri
<tuple-layout> ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;
: apply-slot-permutation ( old-values permutation -- new-values )
[ [ swap ?nth ] [ drop f ] if* ] with map ;
: permute-slots ( old-values -- new-values )
dup first dup outdated-tuples get at
compute-slot-permutation
apply-slot-permutation ;
: change-tuple ( tuple quot -- newtuple )
>r tuple>array r> call >tuple ; inline
: update-tuple ( tuple -- newtuple )
[ permute-slots ] change-tuple ;
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
[ >r class r> key? ] curry instances
dup [ update-tuple ] map become
] if ;
[ update-tuples ] update-tuples-hook set-global
: update-tuples-after ( class -- )
outdated-tuples get [ all-slot-names ] cache drop ;
M: tuple-class update-class
[ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ]
tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ nip "slot-names" set-word-prop ]
[ 2drop update-classes ]
3tri ;
: subclasses ( class -- classes )
class-usages keys [ tuple-class? ] subset ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline
: redefine-tuple-class ( class superclass slots -- )
[
2drop
[
[ update-tuples-after ]
[ changed-definition ]
[ redefined ]
tri
] each-subclass
]
[ define-new-tuple-class ]
3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
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>
GENERIC# define-tuple-class 2 ( class superclass slots -- )
M: word define-tuple-class
over check-superclass
define-new-tuple-class ;
M: tuple-class define-tuple-class
3dup tuple-class-unchanged?
[ over check-superclass 3dup redefine-tuple-class ] unless
3drop ;
: define-error-class ( class superclass slots -- )
[ define-tuple-class ] [ 2drop ] 3bi
dup [ boa throw ] curry define ;
M: tuple-class reset-class
[
dup "slot-names" word-prop [
[ reader-word method forget ]
[ writer-word method forget ] 2bi
] with each
] [
{
"class"
"metaclass"
"superclass"
"layout"
"slots"
} reset-props
] bi ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
M: tuple equal?
over tuple? [ tuple= ] [ 2drop f ] if ;
M: tuple hashcode*
[
[ class hashcode ] [ tuple-size ] [ ] tri
>r rot r> [
swapd array-nth hashcode* sequence-hashcode-step
] 2curry each
] recursive-hashcode ;
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
: delegates ( obj -- seq ) [ delegate ] follow ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline

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"

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

@ -1,42 +1,32 @@
! 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: words sequences kernel assocs combinators classes USING: words sequences kernel assocs combinators classes
generic.standard namespaces arrays math quotations ; namespaces arrays math quotations ;
IN: classes.union IN: classes.union
PREDICATE: union-class < class PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ; "metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes. ! Union classes for dispatch on multiple classes.
: small-union-predicate-quot ( members -- quot ) : union-predicate-quot ( members -- quot )
dup empty? [ dup empty? [
drop [ drop f ] drop [ drop f ]
] [ ] [
unclip first "predicate" word-prop swap unclip "predicate" word-prop swap [
[ >r "predicate" word-prop [ dup ] prepend r> ] "predicate" word-prop [ dup ] prepend
assoc-map alist>quot [ drop t ]
] if ; ] { } map>assoc alist>quot
: big-union-predicate-quot ( members -- quot )
[ small-union-predicate-quot ] [ dup ]
class-hash-dispatch-quot ;
: union-predicate-quot ( members -- quot )
[ [ drop t ] ] { } map>assoc
dup length 4 <= [
small-union-predicate-quot
] [
flatten-methods
big-union-predicate-quot
] if ; ] if ;
: define-union-predicate ( class -- ) : define-union-predicate ( class -- )
dup members union-predicate-quot define-predicate ; dup members union-predicate-quot define-predicate ;
M: union-class update-predicate define-union-predicate ; M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- ) : define-union-class ( class members -- )
dupd f union-class define-class define-union-predicate ; [ f swap union-class define-class ]
[ drop update-classes ]
2bi ;
M: union-class reset-class M: union-class reset-class
{ "metaclass" "members" } reset-props ; { "class" "metaclass" "members" } reset-props ;

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

@ -10,27 +10,63 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
{ $subsection alist>quot } ; { $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators" ARTICLE: "combinators" "Additional combinators"
"The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":" "The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary."
$nl
"Generalization of " { $link bi } " and " { $link tri } ":"
{ $subsection cleave }
"Generalization of " { $link bi* } " and " { $link tri* } ":"
{ $subsection spread }
"Two combinators which abstract out nested chains of " { $link if } ":"
{ $subsection cond } { $subsection cond }
{ $subsection case } { $subsection case }
"The " { $vocab-link "combinators" } " also provides some less frequently-used features."
$nl
"A combinator which can help with implementing methods on " { $link hashcode* } ":" "A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode } { $subsection recursive-hashcode }
"An oddball combinator:" "An oddball combinator:"
{ $subsection with-datastack } { $subsection with-datastack }
{ $subsection "combinators-quot" } { $subsection "combinators-quot" }
{ $see-also "quotations" "basic-combinators" } ; { $see-also "quotations" "dataflow" } ;
ABOUT: "combinators" ABOUT: "combinators"
HELP: cleave
{ $values { "x" object } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } }
{ $description "Applies each quotation to the object in turn." }
{ $examples
"The " { $link bi } " combinator takes one value and two quotations; the " { $link tri } " combinator takes one value and three quotations. The " { $link cleave } " combinator takes one value and any number of quotations, and is essentially equivalent to a chain of " { $link keep } " forms:"
{ $code
"! Equivalent"
"{ [ p ] [ q ] [ r ] [ s ] } cleave"
"[ p ] keep [ q ] keep [ r ] keep s"
}
} ;
{ bi tri cleave } related-words
HELP: spread
{ $values { "objs..." "objects" } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } }
{ $description "Applies each quotation to the object in turn." }
{ $examples
"The " { $link bi* } " combinator takes two values and two quotations; the " { $link tri* } " combinator takes three values and three quotations. The " { $link spread } " combinator takes " { $snippet "n" } " values and " { $snippet "n" } " quotations, where " { $snippet "n" } " is the length of the input sequence, and is essentially equivalent to series of retain stack manipulations:"
{ $code
"! Equivalent"
"{ [ p ] [ q ] [ r ] [ s ] } spread"
">r >r >r p r> q r> r r> s"
}
} ;
{ bi* tri* spread } related-words
HELP: alist>quot HELP: alist>quot
{ $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } } { $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } }
{ $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." } { $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." }
{ $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" }
@ -42,7 +78,7 @@ HELP: cond
"{" "{"
" { [ dup 0 > ] [ \"positive\" ] }" " { [ dup 0 > ] [ \"positive\" ] }"
" { [ dup 0 < ] [ \"negative\" ] }" " { [ dup 0 < ] [ \"negative\" ] }"
" { [ dup zero? ] [ \"zero\" ] }" " [ \"zero\" ]"
"} cond" "} cond"
} }
} ; } ;
@ -52,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

62
core/combinators/combinators.factor
View File

@ -3,18 +3,55 @@
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 -- )
[ call ] with each ;
: cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
: 2cleave ( x seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
append [ ] like ;
: spread ( objs... seq -- )
spread>quot call ;
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 ] }
@ -23,7 +60,7 @@ ERROR: no-case ;
: with-datastack ( stack quot -- newstack ) : with-datastack ( stack quot -- newstack )
datastack >r datastack >r
>r >array set-datastack r> call >r >array set-datastack r> call
datastack r> swap add set-datastack 2nip ; inline datastack r> swap suffix set-datastack 2nip ; inline
: recursive-hashcode ( n obj quot -- code ) : recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
@ -33,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=
@ -43,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 add* ] 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? [
@ -105,7 +149,9 @@ M: hashtable hashcode*
dup empty? [ dup empty? [
drop drop
] [ ] [
dup length 4 <= [ dup length 4 <=
over keys [ [ word? ] [ wrapper? ] bi or ] 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" }
} }

2
core/command-line/command-line.factor
View File

@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook
] bind ; ] bind ;
: ignore-cli-args? ( -- ? ) : ignore-cli-args? ( -- ? )
macosx? "run" get "ui" = and ; os macosx? "run" get "ui" = and ;
: script-mode ( -- ) : script-mode ( -- )
t "quiet" set-global t "quiet" set-global

15
core/compiler/compiler-docs.factor
View File

@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser
assocs words.private sequences compiler.units ; assocs words.private sequences compiler.units ;
IN: compiler IN: compiler
HELP: enable-compiler
{ $description "Enables the optimizing compiler." } ;
HELP: disable-compiler
{ $description "Enables the optimizing compiler." } ;
ARTICLE: "compiler-usage" "Calling the optimizing compiler" ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly." "Normally, new word definitions are recompiled automatically. This can be changed:"
$nl { $subsection disable-compiler }
"The main entry point to the optimizing compiler:" { $subsection enable-compiler }
"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
{ $subsection optimized-recompile-hook } { $subsection optimized-recompile-hook }
"Removing a word's optimized definition:" "Removing a word's optimized definition:"
{ $subsection decompile } { $subsection decompile }
"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ; "Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler" ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:" "Factor is a fully compiled language implementation with two distinct compilers:"

16
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 )
[ [
@ -56,5 +56,11 @@ IN: compiler
compiled get >alist compiled get >alist
] with-scope ; ] with-scope ;
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
: recompile-all ( -- ) : recompile-all ( -- )
forget-errors all-words compile ; forget-errors all-words compile ;

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

@ -10,7 +10,7 @@ IN: compiler.tests
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test [ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test [ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test
[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-call ] unit-test [ -10 -20 ] [ 10 20 -1 [ [ * ] curry bi@ ] compile-call ] unit-test
[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test [ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test [ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test

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

18
core/compiler/tests/intrinsics.factor
View File

@ -4,8 +4,8 @@ math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien sbufs.private strings.private slots.private alien
alien.accessors alien.c-types alien.syntax namespaces libc alien.accessors alien.c-types alien.syntax alien.strings
sequences.private ; namespaces libc sequences.private io.encodings.ascii ;
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test
@ -174,11 +174,6 @@ sequences.private ;
[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
[ t ] [ f type f [ type ] compile-call eq? ] unit-test
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
@ -223,9 +218,6 @@ sequences.private ;
[ t ] [ f [ f eq? ] compile-call ] unit-test [ t ] [ f [ f eq? ] compile-call ] unit-test
! regression
[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
! regression ! regression
[ 3 ] [ [ 3 ] [
100001 f <array> 3 100000 pick set-nth 100001 f <array> 3 100000 pick set-nth
@ -369,11 +361,11 @@ cell 8 = [
[ ] [ "b" get free ] unit-test [ ] [ "b" get free ] unit-test
] when ] when
[ ] [ "hello world" malloc-char-string "s" set ] unit-test [ ] [ "hello world" ascii malloc-string "s" set ] unit-test
"s" get [ "s" get [
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
[ ] [ "s" get free ] unit-test [ ] [ "s" get free ] unit-test
] when ] when

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

@ -1,6 +1,6 @@
USING: compiler.units tools.test kernel kernel.private USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings sequences.private math.private math combinators strings
alien arrays memory ; alien arrays memory vocabs parser ;
IN: compiler.tests IN: compiler.tests
! Test empty word ! Test empty word
@ -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
@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ;
! Regression ! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
! Regression
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
] unit-test
] times

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

@ -2,9 +2,10 @@
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
cpu.architecture ;
: <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 +16,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 +174,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

67
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!
@ -26,10 +26,6 @@ IN: compiler.tests
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ] [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test unit-test
[ { 1 2 3 } { 1 4 3 } 8 8 ]
[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
unit-test
! Test literals in either side of a shuffle ! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
@ -72,13 +68,13 @@ unit-test
] unit-test ] unit-test
[ 12 13 ] [ [ 12 13 ] [
-12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
] unit-test ] unit-test
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test [ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
[ 12 13 ] [ [ 12 13 ] [
-12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
] unit-test ] unit-test
[ 1 ] [ [ 1 ] [
@ -176,14 +172,14 @@ TUPLE: my-tuple ;
[ 1 t ] [ [ 1 t ] [
B{ 1 2 3 4 } [ B{ 1 2 3 4 } [
{ c-ptr } declare { c-ptr } declare
[ 0 alien-unsigned-1 ] keep type [ 0 alien-unsigned-1 ] keep hi-tag
] compile-call byte-array type-number = ] compile-call byte-array type-number =
] unit-test ] unit-test
[ t ] [ [ t ] [
B{ 1 2 3 4 } [ B{ 1 2 3 4 } [
{ c-ptr } declare { c-ptr } declare
0 alien-cell type 0 alien-cell hi-tag
] compile-call alien type-number = ] compile-call alien type-number =
] unit-test ] unit-test
@ -206,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

30
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,42 +56,40 @@ 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: post-compile-tasks SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: after-compilation ( quot -- )
post-compile-tasks get push ;
: 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-post-compile-tasks ( -- ) : call-update-tuples-hook ( -- )
post-compile-tasks get [ call ] each ; update-tuples-hook get call ;
: finish-compilation-unit ( -- ) : finish-compilation-unit ( -- )
call-recompile-hook call-recompile-hook
call-post-compile-tasks 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
V{ } clone post-compile-tasks set H{ } clone outdated-tuples set
<definitions> new-definitions set <definitions> new-definitions set
<definitions> old-definitions set <definitions> old-definitions set
[ finish-compilation-unit ] [ finish-compilation-unit ]

34
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,9 +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 "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 } ;
@ -60,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

39
core/continuations/continuations.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences USING: arrays vectors kernel kernel.private sequences
namespaces math splitting sorting quotations assocs ; namespaces math splitting sorting quotations assocs
combinators accessors ;
IN: continuations IN: continuations
SYMBOL: error SYMBOL: error
@ -43,12 +44,12 @@ C: <continuation> continuation
: >continuation< ( continuation -- data call retain name catch ) : >continuation< ( continuation -- data call retain name catch )
{ {
continuation-data [ data>> ]
continuation-call [ call>> ]
continuation-retain [ retain>> ]
continuation-name [ name>> ]
continuation-catch [ catch>> ]
} get-slots ; } cleave ;
: ifcc ( capture restore -- ) : ifcc ( capture restore -- )
#! After continuation is being captured, the stacks looks #! After continuation is being captured, the stacks looks
@ -140,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 ;
@ -160,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 ;

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

@ -1,14 +1,19 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: 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
SYMBOL: compiler-backend ! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
! 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 )
@ -26,122 +31,122 @@ GENERIC: vregs ( register-class -- regs )
! Load a literal (immediate or indirect) ! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- ) GENERIC# load-literal 1 ( obj vreg -- )
HOOK: load-indirect compiler-backend ( obj reg -- ) HOOK: load-indirect cpu ( obj reg -- )
HOOK: stack-frame compiler-backend ( frame-size -- n ) HOOK: stack-frame cpu ( frame-size -- n )
: stack-frame* ( -- n ) : stack-frame* ( -- n )
\ stack-frame get stack-frame ; \ stack-frame get stack-frame ;
! Set up caller stack frame ! Set up caller stack frame
HOOK: %prologue compiler-backend ( n -- ) HOOK: %prologue cpu ( n -- )
: %prologue-later \ %prologue-later , ; : %prologue-later \ %prologue-later , ;
! Tear down stack frame ! Tear down stack frame
HOOK: %epilogue compiler-backend ( n -- ) HOOK: %epilogue cpu ( n -- )
: %epilogue-later \ %epilogue-later , ; : %epilogue-later \ %epilogue-later , ;
! Store word XT in stack frame ! Store word XT in stack frame
HOOK: %save-word-xt compiler-backend ( -- ) HOOK: %save-word-xt cpu ( -- )
! Store dispatch branch XT in stack frame ! Store dispatch branch XT in stack frame
HOOK: %save-dispatch-xt compiler-backend ( -- ) HOOK: %save-dispatch-xt cpu ( -- )
M: object %save-dispatch-xt %save-word-xt ; M: object %save-dispatch-xt %save-word-xt ;
! Call another word ! Call another word
HOOK: %call compiler-backend ( word -- ) HOOK: %call cpu ( word -- )
! Local jump for branches ! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- ) HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not ! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- ) HOOK: %jump-f cpu ( label -- )
HOOK: %dispatch compiler-backend ( -- ) HOOK: %dispatch cpu ( -- )
HOOK: %dispatch-label compiler-backend ( word -- ) HOOK: %dispatch-label cpu ( word -- )
! Return to caller ! Return to caller
HOOK: %return compiler-backend ( -- ) HOOK: %return cpu ( -- )
! Change datastack height ! Change datastack height
HOOK: %inc-d compiler-backend ( n -- ) HOOK: %inc-d cpu ( n -- )
! Change callstack height ! Change callstack height
HOOK: %inc-r compiler-backend ( n -- ) HOOK: %inc-r cpu ( n -- )
! Load stack into vreg ! Load stack into vreg
HOOK: %peek compiler-backend ( vreg loc -- ) HOOK: %peek cpu ( vreg loc -- )
! Store vreg to stack ! Store vreg to stack
HOOK: %replace compiler-backend ( vreg loc -- ) HOOK: %replace cpu ( vreg loc -- )
! Box and unbox floats ! Box and unbox floats
HOOK: %unbox-float compiler-backend ( dst src -- ) HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float compiler-backend ( dst src -- ) HOOK: %box-float cpu ( dst src -- )
! FFI stuff ! FFI stuff
! Is this integer small enough to appear in value template ! Is this integer small enough to appear in value template
! slots? ! slots?
HOOK: small-enough? compiler-backend ( n -- ? ) HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers? ! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? compiler-backend ( size -- ? ) HOOK: struct-small-enough? cpu ( size -- ? )
! Do we pass explode value structs? ! Do we pass explode value structs?
HOOK: value-structs? compiler-backend ( -- ? ) HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters ! If t, fp parameters are shadowed by dummy int parameters
HOOK: fp-shadows-int? compiler-backend ( -- ? ) HOOK: fp-shadows-int? cpu ( -- ? )
HOOK: %prepare-unbox compiler-backend ( -- ) HOOK: %prepare-unbox cpu ( -- )
HOOK: %unbox compiler-backend ( n reg-class func -- ) HOOK: %unbox cpu ( n reg-class func -- )
HOOK: %unbox-long-long compiler-backend ( n func -- ) HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-small-struct compiler-backend ( size -- ) HOOK: %unbox-small-struct cpu ( size -- )
HOOK: %unbox-large-struct compiler-backend ( n size -- ) HOOK: %unbox-large-struct cpu ( n size -- )
HOOK: %box compiler-backend ( n reg-class func -- ) HOOK: %box cpu ( n reg-class func -- )
HOOK: %box-long-long compiler-backend ( n func -- ) HOOK: %box-long-long cpu ( n func -- )
HOOK: %prepare-box-struct compiler-backend ( size -- ) HOOK: %prepare-box-struct cpu ( size -- )
HOOK: %box-small-struct compiler-backend ( size -- ) HOOK: %box-small-struct cpu ( size -- )
HOOK: %box-large-struct compiler-backend ( n size -- ) HOOK: %box-large-struct cpu ( n size -- )
GENERIC: %save-param-reg ( stack reg reg-class -- ) GENERIC: %save-param-reg ( stack reg reg-class -- )
GENERIC: %load-param-reg ( stack reg reg-class -- ) GENERIC: %load-param-reg ( stack reg reg-class -- )
HOOK: %prepare-alien-invoke compiler-backend ( -- ) HOOK: %prepare-alien-invoke cpu ( -- )
HOOK: %prepare-var-args compiler-backend ( -- ) HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ; M: object %prepare-var-args ;
HOOK: %alien-invoke compiler-backend ( function library -- ) HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup compiler-backend ( alien-node -- ) HOOK: %cleanup cpu ( alien-node -- )
HOOK: %alien-callback compiler-backend ( quot -- ) HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value compiler-backend ( ctype -- ) HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86) ! Return to caller with stdcall unwinding (only for x86)
HOOK: %unwind compiler-backend ( n -- ) HOOK: %unwind cpu ( n -- )
HOOK: %prepare-alien-indirect compiler-backend ( -- ) HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect compiler-backend ( -- ) HOOK: %alien-indirect cpu ( -- )
M: stack-params param-reg drop ; M: stack-params param-reg drop ;
@ -179,15 +184,18 @@ PREDICATE: inline-array < integer 32 < ;
] if-small-struct ; ] if-small-struct ;
! Alien accessors ! Alien accessors
HOOK: %unbox-byte-array compiler-backend ( dst src -- ) HOOK: %unbox-byte-array cpu ( dst src -- )
HOOK: %unbox-alien compiler-backend ( dst src -- ) HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-f compiler-backend ( dst src -- ) HOOK: %unbox-f cpu ( dst src -- )
HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- ) HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien compiler-backend ( dst src -- ) HOOK: %box-alien cpu ( dst src -- )
! GC check
HOOK: %gc cpu
: operand ( var -- op ) get v>operand ; inline : operand ( var -- op ) get v>operand ; inline

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

@ -63,7 +63,7 @@ M: arm-backend load-indirect ( obj reg -- )
M: immediate load-literal M: immediate load-literal
over v>operand small-enough? [ over v>operand small-enough? [
[ v>operand ] 2apply swap MOV [ v>operand ] bi@ swap MOV
] [ ] [
v>operand load-indirect v>operand load-indirect
] if ; ] if ;
@ -322,10 +322,10 @@ M: arm-backend fp-shadows-int? ( -- ? ) f ;
! Alien intrinsics ! Alien intrinsics
M: arm-backend %unbox-byte-array ( dst src -- ) M: arm-backend %unbox-byte-array ( dst src -- )
[ v>operand ] 2apply byte-array-offset ADD ; [ v>operand ] bi@ byte-array-offset ADD ;
M: arm-backend %unbox-alien ( dst src -- ) M: arm-backend %unbox-alien ( dst src -- )
[ v>operand ] 2apply alien-offset <+> LDR ; [ v>operand ] bi@ alien-offset <+> LDR ;
M: arm-backend %unbox-f ( dst src -- ) M: arm-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ; drop v>operand 0 MOV ;

4
core/cpu/arm/intrinsics/intrinsics.factor
View File

@ -5,8 +5,8 @@ cpu.arm.architecture cpu.arm.allot kernel kernel.private math
math.private namespaces sequences words math.private namespaces sequences words
quotations byte-arrays hashtables.private hashtables generator quotations byte-arrays hashtables.private hashtables generator
generator.registers generator.fixup sequences.private sbufs generator.registers generator.fixup sequences.private sbufs
sbufs.private vectors vectors.private system tuples.private sbufs.private vectors vectors.private system
layouts strings.private slots.private ; classes.tuple.private layouts strings.private slots.private ;
IN: cpu.arm.intrinsics IN: cpu.arm.intrinsics
: %slot-literal-known-tag : %slot-literal-known-tag

23
core/cpu/ppc/allot/allot.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays kernel.private namespaces math sequences generic arrays
@ -7,7 +7,7 @@ cpu.architecture alien ;
IN: cpu.ppc.allot IN: cpu.ppc.allot
: load-zone-ptr ( reg -- ) : load-zone-ptr ( reg -- )
"nursery" f pick %load-dlsym dup 0 LWZ ; >r "nursery" f r> %load-dlsym ;
: %allot ( header size -- ) : %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the #! Store a pointer to 'size' bytes allocated from the
@ -25,6 +25,19 @@ IN: cpu.ppc.allot
: %store-tagged ( reg tag -- ) : %store-tagged ( reg tag -- )
>r dup fresh-object v>operand 11 r> tag-number ORI ; >r dup fresh-object v>operand 11 r> tag-number ORI ;
M: ppc %gc
"end" define-label
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: %allot-float ( reg -- ) : %allot-float ( reg -- )
#! exits with tagged ptr to object in r12, untagged in r11 #! exits with tagged ptr to object in r12, untagged in r11
float 16 %allot float 16 %allot
@ -32,8 +45,8 @@ IN: cpu.ppc.allot
12 11 float tag-number ORI 12 11 float tag-number ORI
f fresh-object ; f fresh-object ;
M: ppc-backend %box-float ( dst src -- ) M: ppc %box-float ( dst src -- )
[ v>operand ] 2apply %allot-float 12 MR ; [ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- ) : %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits #! 1 cell header, 1 cell length, 1 cell sign, + digits
@ -78,7 +91,7 @@ M: ppc-backend %box-float ( dst src -- )
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;
M: ppc-backend %box-alien ( dst src -- ) M: ppc %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each { "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI 0 over v>operand 0 CMPI
"f" get BEQ "f" get BEQ

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

@ -7,8 +7,6 @@ layouts classes words.private alien combinators
compiler.constants ; compiler.constants ;
IN: cpu.ppc.architecture IN: cpu.ppc.architecture
TUPLE: ppc-backend ;
! PowerPC register assignments ! PowerPC register assignments
! r3-r10, r16-r31: integer vregs ! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs ! f0-f13: float vregs
@ -21,14 +19,14 @@ TUPLE: ppc-backend ;
: reserved-area-size : reserved-area-size
os { os {
{ "linux" [ 2 ] } { linux [ 2 ] }
{ "macosx" [ 6 ] } { macosx [ 6 ] }
} case cells ; foldable } case cells ; foldable
: lr-save : lr-save
os { os {
{ "linux" [ 1 ] } { linux [ 1 ] }
{ "macosx" [ 2 ] } { macosx [ 2 ] }
} case cells ; foldable } case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline : param@ ( n -- x ) reserved-area-size + ; inline
@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
: xt-save ( n -- i ) 2 cells - ; : xt-save ( n -- i ) 2 cells - ;
M: ppc-backend stack-frame ( n -- i ) M: ppc stack-frame ( n -- i )
local@ factor-area-size + 4 cells align ; local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ; M: temp-reg v>operand drop 11 ;
@ -60,8 +58,8 @@ M: int-regs vregs
M: float-regs return-reg drop 1 ; M: float-regs return-reg drop 1 ;
M: float-regs param-regs M: float-regs param-regs
drop os H{ drop os H{
{ "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ "linux" { 1 2 3 4 5 6 7 8 } } { linux { 1 2 3 4 5 6 7 8 } }
} at ; } at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
@ -71,16 +69,16 @@ M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ;
M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ; M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
M: immediate load-literal M: immediate load-literal
[ v>operand ] 2apply LOAD ; [ v>operand ] bi@ LOAD ;
M: ppc-backend load-indirect ( obj reg -- ) M: ppc load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
dup 0 LWZ ; dup 0 LWZ ;
M: ppc-backend %save-word-xt ( -- ) M: ppc %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ; 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
M: ppc-backend %prologue ( n -- ) M: ppc %prologue ( n -- )
0 MFLR 0 MFLR
1 1 pick neg ADDI 1 1 pick neg ADDI
11 1 pick xt-save STW 11 1 pick xt-save STW
@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
11 1 pick next-save STW 11 1 pick next-save STW
0 1 rot lr-save + STW ; 0 1 rot lr-save + STW ;
M: ppc-backend %epilogue ( n -- ) M: ppc %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store #! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off #! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0, #! the stack, set the link register to the contents of r0,
@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- )
: %load-dlsym ( symbol dll register -- ) : %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
M: ppc-backend %call ( label -- ) BL ; M: ppc %call ( label -- ) BL ;
M: ppc-backend %jump-label ( label -- ) B ; M: ppc %jump-label ( label -- ) B ;
M: ppc-backend %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-backend %dispatch ( -- ) M: ppc %dispatch ( -- )
[ [
%epilogue-later %epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
@ -124,35 +122,43 @@ M: ppc-backend %dispatch ( -- )
{ +scratch+ { { f "offset" } } } { +scratch+ { { f "offset" } } }
} with-template ; } with-template ;
M: ppc-backend %dispatch-label ( word -- ) M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ; 0 , rc-absolute-cell rel-word ;
M: ppc-backend %return ( -- ) %epilogue-later BLR ; M: ppc %return ( -- ) %epilogue-later BLR ;
M: ppc-backend %unwind drop %return ; M: ppc %unwind drop %return ;
M: ppc-backend %peek ( vreg loc -- ) M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ; >r v>operand r> loc>operand LWZ ;
M: ppc-backend %replace M: ppc %replace
>r v>operand r> loc>operand STW ; >r v>operand r> loc>operand STW ;
M: ppc-backend %unbox-float ( dst src -- ) M: ppc %unbox-float ( dst src -- )
[ v>operand ] 2apply float-offset LFD ; [ v>operand ] bi@ float-offset LFD ;
M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ; M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ; M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: int-regs %save-param-reg drop 1 rot local@ STW ; 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 ;
@ -166,19 +172,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
0 1 rot param@ stack-frame* + LWZ 0 1 rot param@ stack-frame* + LWZ
0 1 rot local@ STW ; 0 1 rot local@ STW ;
M: ppc-backend %prepare-unbox ( -- ) M: ppc %prepare-unbox ( -- )
! First parameter is top of stack ! First parameter is top of stack
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup cell SUBI ; ds-reg dup cell SUBI ;
M: ppc-backend %unbox ( n reg-class func -- ) M: ppc %unbox ( n reg-class func -- )
! Value must be in r3 ! Value must be in r3
! Call the unboxer ! Call the unboxer
f %alien-invoke f %alien-invoke
! Store the return value on the C stack ! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: ppc-backend %unbox-long-long ( n func -- ) M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4 ! Value must be in r3:r4
! Call the unboxer ! Call the unboxer
f %alien-invoke f %alien-invoke
@ -188,7 +194,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
4 1 rot cell + local@ STW 4 1 rot cell + local@ STW
] when* ; ] when* ;
M: ppc-backend %unbox-large-struct ( n size -- ) M: ppc %unbox-large-struct ( n size -- )
! Value must be in r3 ! Value must be in r3
! Compute destination address ! Compute destination address
4 1 roll local@ ADDI 4 1 roll local@ ADDI
@ -197,7 +203,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
! Call the function ! Call the function
"to_value_struct" f %alien-invoke ; "to_value_struct" f %alien-invoke ;
M: ppc-backend %box ( n reg-class func -- ) M: ppc %box ( n reg-class func -- )
! If the source is a stack location, load it into freg #0. ! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in ! If the source is f, then we assume the value is already in
! freg #0. ! freg #0.
@ -205,7 +211,7 @@ M: ppc-backend %box ( n reg-class func -- )
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ; r> f %alien-invoke ;
M: ppc-backend %box-long-long ( n func -- ) M: ppc %box-long-long ( n func -- )
>r [ >r [
3 1 pick local@ LWZ 3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ 4 1 rot cell + local@ LWZ
@ -215,12 +221,12 @@ M: ppc-backend %box-long-long ( n func -- )
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ; : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
M: ppc-backend %prepare-box-struct ( size -- ) M: ppc %prepare-box-struct ( size -- )
#! Compute target address for value struct return #! Compute target address for value struct return
3 1 rot f struct-return@ ADDI 3 1 rot f struct-return@ ADDI
3 1 0 local@ STW ; 3 1 0 local@ STW ;
M: ppc-backend %box-large-struct ( n size -- ) M: ppc %box-large-struct ( n size -- )
#! If n = f, then we're boxing a returned struct #! If n = f, then we're boxing a returned struct
[ swap struct-return@ ] keep [ swap struct-return@ ] keep
! Compute destination address ! Compute destination address
@ -230,7 +236,7 @@ M: ppc-backend %box-large-struct ( n size -- )
! Call the function ! Call the function
"box_value_struct" f %alien-invoke ; "box_value_struct" f %alien-invoke ;
M: ppc-backend %prepare-alien-invoke M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a #! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace #! callback which does a GC, which must reliably trace
#! all roots. #! all roots.
@ -240,20 +246,20 @@ M: ppc-backend %prepare-alien-invoke
ds-reg 11 8 STW ds-reg 11 8 STW
rs-reg 11 12 STW ; rs-reg 11 12 STW ;
M: ppc-backend %alien-invoke ( symbol dll -- ) M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym (%call) ; 11 %load-dlsym (%call) ;
M: ppc-backend %alien-callback ( quot -- ) M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ; 3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc-backend %prepare-alien-indirect ( -- ) M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke "unbox_alien" f %alien-invoke
3 1 cell temp@ STW ; 3 1 cell temp@ STW ;
M: ppc-backend %alien-indirect ( -- ) M: ppc %alien-indirect ( -- )
11 1 cell temp@ LWZ (%call) ; 11 1 cell temp@ LWZ (%call) ;
M: ppc-backend %callback-value ( ctype -- ) M: ppc %callback-value ( ctype -- )
! Save top of data stack ! Save top of data stack
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
3 1 0 local@ STW 3 1 0 local@ STW
@ -264,7 +270,7 @@ M: ppc-backend %callback-value ( ctype -- )
! Unbox former top of data stack to return registers ! Unbox former top of data stack to return registers
unbox-return ; unbox-return ;
M: ppc-backend %cleanup ( alien-node -- ) drop ; M: ppc %cleanup ( alien-node -- ) drop ;
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ; : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
@ -272,34 +278,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ; : %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
M: ppc-backend value-structs? M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way #! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first. #! as reference structs, we just have to make a copy first.
linux? not ; os linux? not ;
M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ; M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ; M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc-backend struct-small-enough? ( size -- ? ) drop f ; M: ppc struct-small-enough? ( size -- ? ) drop f ;
M: ppc-backend %box-small-struct M: ppc %box-small-struct
drop "No small structs" throw ; drop "No small structs" throw ;
M: ppc-backend %unbox-small-struct M: ppc %unbox-small-struct
drop "No small structs" throw ; drop "No small structs" throw ;
! Alien intrinsics ! Alien intrinsics
M: ppc-backend %unbox-byte-array ( dst src -- ) M: ppc %unbox-byte-array ( dst src -- )
[ v>operand ] 2apply byte-array-offset ADDI ; [ v>operand ] bi@ byte-array-offset ADDI ;
M: ppc-backend %unbox-alien ( dst src -- ) M: ppc %unbox-alien ( dst src -- )
[ v>operand ] 2apply alien-offset LWZ ; [ v>operand ] bi@ alien-offset LWZ ;
M: ppc-backend %unbox-f ( dst src -- ) M: ppc %unbox-f ( dst src -- )
drop 0 swap v>operand LI ; drop 0 swap v>operand LI ;
M: ppc-backend %unbox-any-c-ptr ( dst src -- ) M: ppc %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each { "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12 ! Address is computed in R12
0 12 LI 0 12 LI

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

@ -6,9 +6,9 @@ kernel.private math math.private namespaces sequences words
generic quotations byte-arrays hashtables hashtables.private generic quotations byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private generator generator.registers generator.fixup sequences.private
sbufs vectors system layouts math.floats.private sbufs vectors system layouts math.floats.private
classes tuples tuples.private sbufs.private vectors.private classes classes.tuple classes.tuple.private sbufs.private
strings.private slots.private combinators bit-arrays vectors.private strings.private slots.private combinators
float-arrays compiler.constants ; bit-arrays float-arrays compiler.constants ;
IN: cpu.ppc.intrinsics IN: cpu.ppc.intrinsics
: %slot-literal-known-tag : %slot-literal-known-tag
@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics
} define-intrinsics } define-intrinsics
: fixnum-register-op ( op -- pair ) : fixnum-register-op ( op -- pair )
[ "out" operand "y" operand "x" operand ] swap add H{ [ "out" operand "y" operand "x" operand ] swap suffix H{
{ +input+ { { f "x" } { f "y" } } } { +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } } { +scratch+ { { f "out" } } }
{ +output+ { "out" } } { +output+ { "out" } }
} 2array ; } 2array ;
: fixnum-value-op ( op -- pair ) : fixnum-value-op ( op -- pair )
[ "out" operand "x" operand "y" operand ] swap add H{ [ "out" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } } { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } } { +scratch+ { { f "out" } } }
{ +output+ { "out" } } { +output+ { "out" } }
@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics
} define-intrinsic } define-intrinsic
: fixnum-register-jump ( op -- pair ) : fixnum-register-jump ( op -- pair )
[ "x" operand 0 "y" operand CMP ] swap add [ "x" operand 0 "y" operand CMP ] swap suffix
{ { f "x" } { f "y" } } 2array ; { { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair ) : fixnum-value-jump ( op -- pair )
[ 0 "x" operand "y" operand CMPI ] swap add [ 0 "x" operand "y" operand CMPI ] swap suffix
{ { f "x" } { [ small-tagged? ] "y" } } 2array ; { { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- ) : define-fixnum-jump ( word op -- )
@ -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
@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics
} define-intrinsic } define-intrinsic
: define-float-op ( word op -- ) : define-float-op ( word op -- )
[ "z" operand "x" operand "y" operand ] swap add H{ [ "z" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } } { +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } } { +scratch+ { { float "z" } } }
{ +output+ { "z" } } { +output+ { "z" } }
@ -352,15 +352,15 @@ IN: cpu.ppc.intrinsics
] each ] each
: define-float-jump ( word op -- ) : define-float-jump ( word op -- )
[ "x" operand 0 "y" operand FCMPU ] swap add [ "x" operand 0 "y" operand FCMPU ] swap suffix
{ { 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
@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } } { +output+ { "out" } }
} define-intrinsic } define-intrinsic
\ type [
"end" define-label
! Get the tag
"y" operand "obj" operand tag-mask get ANDI
! Tag the tag
"y" operand "x" operand %tag-fixnum
! Compare with object tag number (3).
0 "y" operand object tag-number CMPI
! Jump if the object doesn't store type info in its header
"end" get BNE
! It does store type info in its header
"x" operand "obj" operand header-offset LWZ
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
{ +output+ { "x" } }
} define-intrinsic
\ class-hash [
"end" define-label
"tuple" define-label
"object" define-label
! Get the tag
"y" operand "obj" operand tag-mask get ANDI
! Compare with tuple tag number (2).
0 "y" operand tuple tag-number CMPI
"tuple" get BEQ
! Compare with object tag number (3).
0 "y" operand object tag-number CMPI
"object" get BEQ
! Tag the tag
"y" operand "x" operand %tag-fixnum
"end" get B
"object" get resolve-label
! Load header type
"x" operand "obj" operand header-offset LWZ
"end" get B
"tuple" get resolve-label
! Load class hash
"x" operand "obj" operand tuple-class-offset LWZ
"x" operand dup class-hash-offset LWZ
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
{ +output+ { "x" } }
} define-intrinsic
: userenv ( reg -- ) : userenv ( reg -- )
#! Load the userenv pointer in a register. #! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ; "userenv" f rot %load-dlsym ;

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

@ -2,18 +2,13 @@ USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
namespaces alien.c-types kernel system combinators ; namespaces alien.c-types kernel system combinators ;
{ {
{ [ macosx? ] [ { [ os macosx? ] [
4 "longlong" c-type set-c-type-align 4 "longlong" c-type set-c-type-align
4 "ulonglong" c-type set-c-type-align 4 "ulonglong" c-type set-c-type-align
4 "double" c-type set-c-type-align
] } ] }
{ [ linux? ] [ { [ os linux? ] [
t "longlong" c-type set-c-type-stack-align? t "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align? t "ulonglong" c-type set-c-type-stack-align?
] } ] }
} cond } cond
T{ ppc-backend } compiler-backend set-global
macosx? [
4 "double" c-type set-c-type-align
] when

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

@ -8,23 +8,21 @@ alien.compiler combinators command-line
compiler compiler.units io vocabs.loader accessors ; compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32 IN: cpu.x86.32
PREDICATE: x86-32-backend < x86-backend
x86-backend-cell 4 = ;
! We implement the FFI for Linux, OS X and Windows all at once. ! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned, and we do ! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for ! this on all platforms, sacrificing some stack space for
! code simplicity. ! code simplicity.
M: x86-32-backend ds-reg ESI ; M: x86.32 ds-reg ESI ;
M: x86-32-backend rs-reg EDI ; M: x86.32 rs-reg EDI ;
M: x86-32-backend stack-reg ESP ; M: x86.32 stack-reg ESP ;
M: x86-32-backend xt-reg ECX ; M: x86.32 stack-save-reg EDX ;
M: x86-32-backend stack-save-reg EDX ; M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M: temp-reg v>operand drop EBX ; M: temp-reg v>operand drop EBX ;
M: x86-32-backend %alien-invoke ( symbol dll -- ) M: x86.32 %alien-invoke ( symbol dll -- )
(CALL) rel-dlsym ; (CALL) rel-dlsym ;
! On x86, parameters are never passed in registers. ! On x86, parameters are never passed in registers.
@ -61,20 +59,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
! On x86, we can always use an address as an operand ! On x86, we can always use an address as an operand
! directly. ! directly.
M: x86-32-backend address-operand ; M: x86.32 address-operand ;
M: x86-32-backend fixnum>slot@ 1 SHR ; M: x86.32 fixnum>slot@ 1 SHR ;
M: x86-32-backend prepare-division CDQ ; M: x86.32 prepare-division CDQ ;
M: x86-32-backend load-indirect M: x86.32 load-indirect
0 [] MOV rc-absolute-cell rel-literal ; 0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ; M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ; M: object %save-param-reg 3drop ;
M: x86-32-backend %prepare-unbox ( -- ) M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX. #! Move top of data stack to EAX.
EAX ESI [] MOV EAX ESI [] MOV
ESI 4 SUB ; ESI 4 SUB ;
@ -87,7 +85,7 @@ M: x86-32-backend %prepare-unbox ( -- )
f %alien-invoke f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %unbox ( n reg-class func -- ) M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX. #! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be #! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing #! returned by the callback. Otherwise, we're unboxing
@ -96,7 +94,7 @@ M: x86-32-backend %unbox ( n reg-class func -- )
! Store the return value on the C stack ! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ; over [ store-return-reg ] [ 2drop ] if ;
M: x86-32-backend %unbox-long-long ( n func -- ) M: x86.32 %unbox-long-long ( n func -- )
(%unbox) (%unbox)
! Store the return value on the C stack ! Store the return value on the C stack
[ [
@ -104,7 +102,7 @@ M: x86-32-backend %unbox-long-long ( n func -- )
cell + stack@ EDX MOV cell + stack@ EDX MOV
] when* ; ] when* ;
M: x86-32-backend %unbox-struct-2 M: x86.32 %unbox-struct-2
#! Alien must be in EAX. #! Alien must be in EAX.
4 [ 4 [
EAX PUSH EAX PUSH
@ -115,7 +113,7 @@ M: x86-32-backend %unbox-struct-2
EAX EAX [] MOV EAX EAX [] MOV
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %unbox-large-struct ( n size -- ) M: x86.32 %unbox-large-struct ( n size -- )
#! Alien must be in EAX. #! Alien must be in EAX.
! Compute destination address ! Compute destination address
ECX ESP roll [+] LEA ECX ESP roll [+] LEA
@ -147,7 +145,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- )
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
push-return-reg ; push-return-reg ;
M: x86-32-backend %box ( n reg-class func -- ) M: x86.32 %box ( n reg-class func -- )
over reg-size [ over reg-size [
>r (%box) r> f %alien-invoke >r (%box) r> f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
@ -158,19 +156,19 @@ M: x86-32-backend %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*
EDX PUSH EDX PUSH
EAX PUSH ; EAX PUSH ;
M: x86-32-backend %box-long-long ( n func -- ) M: x86.32 %box-long-long ( n func -- )
8 [ 8 [
>r (%box-long-long) r> f %alien-invoke >r (%box-long-long) r> f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %box-large-struct ( n size -- ) M: x86.32 %box-large-struct ( n size -- )
! Compute destination address ! Compute destination address
[ swap struct-return@ ] keep [ swap struct-return@ ] keep
ECX ESP roll [+] LEA ECX ESP roll [+] LEA
@ -183,13 +181,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
"box_value_struct" f %alien-invoke "box_value_struct" f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %prepare-box-struct ( size -- ) M: x86.32 %prepare-box-struct ( size -- )
! Compute target address for value struct return ! Compute target address for value struct return
EAX ESP rot f struct-return@ [+] LEA EAX ESP rot f struct-return@ [+] LEA
! Store it as the first parameter ! Store it as the first parameter
ESP [] EAX MOV ; ESP [] EAX MOV ;
M: x86-32-backend %unbox-struct-1 M: x86.32 %unbox-struct-1
#! Alien must be in EAX. #! Alien must be in EAX.
4 [ 4 [
EAX PUSH EAX PUSH
@ -198,7 +196,7 @@ M: x86-32-backend %unbox-struct-1
EAX EAX [] MOV EAX EAX [] MOV
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %box-small-struct ( size -- ) M: x86.32 %box-small-struct ( size -- )
#! Box a <= 8-byte struct returned in EAX:DX. OS X only. #! Box a <= 8-byte struct returned in EAX:DX. OS X only.
12 [ 12 [
PUSH PUSH
@ -207,21 +205,21 @@ M: x86-32-backend %box-small-struct ( size -- )
"box_small_struct" f %alien-invoke "box_small_struct" f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %prepare-alien-indirect ( -- ) M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke "unbox_alien" f %alien-invoke
cell temp@ EAX MOV ; cell temp@ EAX MOV ;
M: x86-32-backend %alien-indirect ( -- ) M: x86.32 %alien-indirect ( -- )
cell temp@ CALL ; cell temp@ CALL ;
M: x86-32-backend %alien-callback ( quot -- ) M: x86.32 %alien-callback ( quot -- )
4 [ 4 [
EAX load-indirect EAX load-indirect
EAX PUSH EAX PUSH
"c_to_factor" f %alien-invoke "c_to_factor" f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %callback-value ( ctype -- ) M: x86.32 %callback-value ( ctype -- )
! Align C stack ! Align C stack
ESP 12 SUB ESP 12 SUB
! Save top of data stack ! Save top of data stack
@ -236,7 +234,7 @@ M: x86-32-backend %callback-value ( ctype -- )
! Unbox EAX ! Unbox EAX
unbox-return ; unbox-return ;
M: x86-32-backend %cleanup ( alien-node -- ) M: x86.32 %cleanup ( alien-node -- )
#! a) If we just called an stdcall function in Windows, it #! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that #! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue. #! so we 'undo' the cleanup since we do that in %epilogue.
@ -249,24 +247,18 @@ M: x86-32-backend %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-backend %unwind ( n -- ) %epilogue-later RET ; M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
windows? [ os windows? [
cell "longlong" c-type set-c-type-align cell "longlong" c-type set-c-type-align
cell "ulonglong" c-type set-c-type-align cell "ulonglong" c-type set-c-type-align
] unless
windows? [
4 "double" c-type set-c-type-align 4 "double" c-type set-c-type-align
] unless ] unless
T{ x86-backend f 4 } compiler-backend set-global
: sse2? "Intrinsic" throw ; : sse2? "Intrinsic" throw ;
\ sse2? [ \ sse2? [
@ -276,7 +268,7 @@ T{ x86-backend f 4 } compiler-backend set-global
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? [

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

@ -8,14 +8,12 @@ layouts alien alien.accessors alien.compiler alien.structs slots
splitting assocs ; splitting assocs ;
IN: cpu.x86.64 IN: cpu.x86.64
PREDICATE: amd64-backend < x86-backend M: x86.64 ds-reg R14 ;
x86-backend-cell 8 = ; M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: amd64-backend ds-reg R14 ; M: x86.64 stack-save-reg RSI ;
M: amd64-backend rs-reg R15 ; M: x86.64 temp-reg-1 RAX ;
M: amd64-backend stack-reg RSP ; M: x86.64 temp-reg-2 RCX ;
M: amd64-backend xt-reg RCX ;
M: amd64-backend stack-save-reg RSI ;
M: temp-reg v>operand drop RBX ; M: temp-reg v>operand drop RBX ;
@ -34,18 +32,18 @@ M: float-regs vregs
M: float-regs param-regs M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: amd64-backend address-operand ( address -- operand ) M: x86.64 address-operand ( address -- operand )
#! On AMD64, we have to load 64-bit addresses into a #! On AMD64, we have to load 64-bit addresses into a
#! scratch register first. The usage of R11 here is a hack. #! scratch register first. The usage of R11 here is a hack.
#! This word can only be called right before a subroutine #! This word can only be called right before a subroutine
#! call, where all vregs have been flushed anyway. #! call, where all vregs have been flushed anyway.
temp-reg v>operand [ swap MOV ] keep ; temp-reg v>operand [ swap MOV ] keep ;
M: amd64-backend fixnum>slot@ drop ; M: x86.64 fixnum>slot@ drop ;
M: amd64-backend prepare-division CQO ; M: x86.64 prepare-division CQO ;
M: amd64-backend load-indirect ( literal reg -- ) M: x86.64 load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ; 0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg M: stack-params %load-param-reg
@ -56,27 +54,27 @@ M: stack-params %load-param-reg
M: stack-params %save-param-reg M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ; >r stack-frame* + cell + swap r> %load-param-reg ;
M: amd64-backend %prepare-unbox ( -- ) M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack ! First parameter is top of stack
RDI R14 [] MOV RDI R14 [] MOV
R14 cell SUB ; R14 cell SUB ;
M: amd64-backend %unbox ( n reg-class func -- ) M: x86.64 %unbox ( n reg-class func -- )
! Call the unboxer ! Call the unboxer
f %alien-invoke f %alien-invoke
! Store the return value on the C stack ! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: amd64-backend %unbox-long-long ( n func -- ) M: x86.64 %unbox-long-long ( n func -- )
T{ int-regs } swap %unbox ; int-regs swap %unbox ;
M: amd64-backend %unbox-struct-1 ( -- ) M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI. #! Alien must be in RDI.
"alien_offset" f %alien-invoke "alien_offset" f %alien-invoke
! Load first cell ! Load first cell
RAX RAX [] MOV ; RAX RAX [] MOV ;
M: amd64-backend %unbox-struct-2 ( -- ) M: x86.64 %unbox-struct-2 ( -- )
#! Alien must be in RDI. #! Alien must be in RDI.
"alien_offset" f %alien-invoke "alien_offset" f %alien-invoke
! Load second cell ! Load second cell
@ -84,7 +82,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
! Load first cell ! Load first cell
RAX RAX [] MOV ; RAX RAX [] MOV ;
M: amd64-backend %unbox-large-struct ( n size -- ) M: x86.64 %unbox-large-struct ( n size -- )
! Source is in RDI ! Source is in RDI
! Load destination address ! Load destination address
RSI RSP roll [+] LEA RSI RSP roll [+] LEA
@ -97,7 +95,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
0 over param-reg swap return-reg 0 over param-reg swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ; 2dup eq? [ 2drop ] [ MOV ] if ;
M: amd64-backend %box ( n reg-class func -- ) M: x86.64 %box ( n reg-class func -- )
rot [ rot [
rot [ 0 swap param-reg ] keep %load-param-reg rot [ 0 swap param-reg ] keep %load-param-reg
] [ ] [
@ -105,19 +103,19 @@ M: amd64-backend %box ( n reg-class func -- )
] if* ] if*
f %alien-invoke ; f %alien-invoke ;
M: amd64-backend %box-long-long ( n func -- ) M: x86.64 %box-long-long ( n func -- )
T{ int-regs } swap %box ; int-regs swap %box ;
M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ; M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
M: amd64-backend %box-small-struct ( size -- ) M: x86.64 %box-small-struct ( size -- )
#! Box a <= 16-byte struct returned in RAX:RDX. #! Box a <= 16-byte struct returned in RAX:RDX.
RDI RAX MOV RDI RAX MOV
RSI RDX MOV RSI RDX MOV
RDX swap MOV RDX swap MOV
"box_small_struct" f %alien-invoke ; "box_small_struct" f %alien-invoke ;
M: amd64-backend %box-large-struct ( n size -- ) M: x86.64 %box-large-struct ( n size -- )
! Struct size is parameter 2 ! Struct size is parameter 2
RSI over MOV RSI over MOV
! Compute destination address ! Compute destination address
@ -125,27 +123,27 @@ M: amd64-backend %box-large-struct ( n size -- )
! Copy the struct from the C stack ! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ; "box_value_struct" f %alien-invoke ;
M: amd64-backend %prepare-box-struct ( size -- ) M: x86.64 %prepare-box-struct ( size -- )
! Compute target address for value struct return ! Compute target address for value struct return
RAX RSP rot f struct-return@ [+] LEA RAX RSP rot f struct-return@ [+] LEA
RSP 0 [+] RAX MOV ; RSP 0 [+] RAX MOV ;
M: amd64-backend %prepare-var-args RAX RAX XOR ; M: x86.64 %prepare-var-args RAX RAX XOR ;
M: amd64-backend %alien-invoke ( symbol dll -- ) M: x86.64 %alien-invoke ( symbol dll -- )
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ; 0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
M: amd64-backend %prepare-alien-indirect ( -- ) M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke "unbox_alien" f %alien-invoke
cell temp@ RAX MOV ; cell temp@ RAX MOV ;
M: amd64-backend %alien-indirect ( -- ) M: x86.64 %alien-indirect ( -- )
cell temp@ CALL ; cell temp@ CALL ;
M: amd64-backend %alien-callback ( quot -- ) M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ; RDI load-indirect "c_to_factor" f %alien-invoke ;
M: amd64-backend %callback-value ( ctype -- ) M: x86.64 %callback-value ( ctype -- )
! Save top of data stack ! Save top of data stack
%prepare-unbox %prepare-unbox
! Put former top of data stack in RDI ! Put former top of data stack in RDI
@ -157,9 +155,9 @@ M: amd64-backend %callback-value ( ctype -- )
! Unbox former top of data stack to return registers ! Unbox former top of data stack to return registers
unbox-return ; unbox-return ;
M: amd64-backend %cleanup ( alien-node -- ) drop ; M: x86.64 %cleanup ( alien-node -- ) drop ;
M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ; M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
USE: cpu.x86.intrinsics USE: cpu.x86.intrinsics
@ -171,11 +169,9 @@ USE: cpu.x86.intrinsics
\ alien-signed-4 small-reg-32 define-signed-getter \ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter \ set-alien-signed-4 small-reg-32 define-setter
T{ x86-backend f 8 } compiler-backend set-global
! 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 [
@ -197,7 +193,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 ;

25
core/cpu/x86/allot/allot.factor
View File

@ -16,12 +16,12 @@ IN: cpu.x86.allot
: object@ ( n -- operand ) cells (object@) ; : object@ ( n -- operand ) cells (object@) ;
: load-zone-ptr ( -- ) : load-zone-ptr ( reg -- )
#! Load pointer to start of zone array #! Load pointer to start of zone array
"nursery" f allot-reg %alien-global ; 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( -- ) : load-allot-ptr ( -- )
load-zone-ptr allot-reg load-zone-ptr
allot-reg PUSH allot-reg PUSH
allot-reg dup cell [+] MOV ; allot-reg dup cell [+] MOV ;
@ -29,6 +29,19 @@ IN: cpu.x86.allot
allot-reg POP allot-reg POP
allot-reg cell [+] swap 8 align ADD ; allot-reg cell [+] swap 8 align ADD ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: store-header ( header -- ) : store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ; 0 object@ swap type-number tag-fixnum MOV ;
@ -46,7 +59,7 @@ IN: cpu.x86.allot
allot-reg swap tag-number OR allot-reg swap tag-number OR
allot-reg MOV ; allot-reg MOV ;
M: x86-backend %box-float ( dst src -- ) M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction #! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg #! dest is a loc or a vreg
float 16 [ float 16 [
@ -86,7 +99,7 @@ M: x86-backend %box-float ( dst src -- )
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;
M: x86-backend %box-alien ( dst src -- ) M: x86 %box-alien ( dst src -- )
[ [
{ "end" "f" } [ define-label ] each { "end" "f" } [ define-label ] each
dup v>operand 0 CMP dup v>operand 0 CMP
@ -101,6 +114,6 @@ M: x86-backend %box-alien ( dst src -- )
] %allot ] %allot
"end" get JMP "end" get JMP
"f" resolve-label "f" resolve-label
f [ v>operand ] 2apply MOV f [ v>operand ] bi@ MOV
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;

97
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
@ -6,13 +6,10 @@ memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators compiler.constants ; generator.fixup system layouts combinators compiler.constants ;
IN: cpu.x86.architecture IN: cpu.x86.architecture
TUPLE: x86-backend cell ; HOOK: ds-reg cpu
HOOK: rs-reg cpu
HOOK: ds-reg compiler-backend HOOK: stack-reg cpu
HOOK: rs-reg compiler-backend HOOK: stack-save-reg cpu
HOOK: stack-reg compiler-backend
HOOK: xt-reg compiler-backend
HOOK: stack-save-reg compiler-backend
: stack@ stack-reg swap [+] ; : stack@ stack-reg swap [+] ;
@ -24,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 ;
@ -33,34 +34,38 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- ) GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- ) GENERIC: store-return-reg ( stack@ reg-class -- )
HOOK: address-operand compiler-backend ( address -- operand ) ! Only used by inline allocation
HOOK: temp-reg-1 cpu
HOOK: temp-reg-2 cpu
HOOK: fixnum>slot@ compiler-backend HOOK: address-operand cpu ( address -- operand )
HOOK: prepare-division compiler-backend HOOK: fixnum>slot@ cpu
HOOK: prepare-division cpu
M: immediate load-literal v>operand swap v>operand MOV ; M: immediate load-literal v>operand swap v>operand MOV ;
M: x86-backend stack-frame ( n -- i ) M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ; 3 cells + 16 align cell - ;
M: x86-backend %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-backend %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-backend %epilogue ( n -- ) M: x86 %epilogue ( n -- )
stack-reg swap ADD ; stack-reg swap ADD ;
: %alien-global ( symbol dll register -- ) : %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ; [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
M: x86-backend %prepare-alien-invoke M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a #! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace #! callback which does a GC, which must reliably trace
#! all roots. #! all roots.
@ -70,12 +75,12 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ; temp-reg v>operand 3 cells [+] rs-reg MOV ;
M: x86-backend %call ( label -- ) CALL ; M: x86 %call ( label -- ) CALL ;
M: x86-backend %jump-label ( label -- ) JMP ; M: x86 %jump-label ( label -- ) JMP ;
M: x86-backend %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 - ;
@ -83,7 +88,7 @@ M: x86-backend %jump-t ( label -- )
: align-code ( n -- ) : align-code ( n -- )
0 <repetition> % ; 0 <repetition> % ;
M: x86-backend %dispatch ( -- ) M: x86 %dispatch ( -- )
[ [
%epilogue-later %epilogue-later
! Load jump table base. We use a temporary register ! Load jump table base. We use a temporary register
@ -105,27 +110,27 @@ M: x86-backend %dispatch ( -- )
{ +clobber+ { "n" } } { +clobber+ { "n" } }
} with-template ; } with-template ;
M: x86-backend %dispatch-label ( word -- ) M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ; 0 cell, rc-absolute-cell rel-word ;
M: x86-backend %unbox-float ( dst src -- ) M: x86 %unbox-float ( dst src -- )
[ v>operand ] 2apply float-offset [+] MOVSD ; [ v>operand ] bi@ float-offset [+] MOVSD ;
M: x86-backend %peek [ v>operand ] 2apply MOV ; M: x86 %peek [ v>operand ] bi@ MOV ;
M: x86-backend %replace swap %peek ; M: x86 %replace swap %peek ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ; M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ; M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
M: x86-backend fp-shadows-int? ( -- ? ) f ; M: x86 fp-shadows-int? ( -- ? ) f ;
M: x86-backend value-structs? t ; M: x86 value-structs? t ;
M: x86-backend small-enough? ( n -- ? ) M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ; HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ; : %untag ( reg -- ) tag-mask get bitnot AND ;
@ -143,34 +148,34 @@ M: x86-backend small-enough? ( n -- ? )
\ stack-frame get swap - \ stack-frame get swap -
] ?if ; ] ?if ;
HOOK: %unbox-struct-1 compiler-backend ( -- ) HOOK: %unbox-struct-1 cpu ( -- )
HOOK: %unbox-struct-2 compiler-backend ( -- ) HOOK: %unbox-struct-2 cpu ( -- )
M: x86-backend %unbox-small-struct ( size -- ) M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX. #! Alien must be in EAX.
cell align cell /i { cell align cell /i {
{ 1 [ %unbox-struct-1 ] } { 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] } { 2 [ %unbox-struct-2 ] }
} case ; } case ;
M: x86-backend struct-small-enough? ( size -- ? ) M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member? { 1 2 4 8 } member?
os { "linux" "netbsd" "solaris" } member? not and ; os { linux netbsd solaris } member? not and ;
M: x86-backend %return ( -- ) 0 %unwind ; M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics ! Alien intrinsics
M: x86-backend %unbox-byte-array ( dst src -- ) M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] 2apply byte-array-offset [+] LEA ; [ v>operand ] bi@ byte-array-offset [+] LEA ;
M: x86-backend %unbox-alien ( dst src -- ) M: x86 %unbox-alien ( dst src -- )
[ v>operand ] 2apply alien-offset [+] MOV ; [ v>operand ] bi@ alien-offset [+] MOV ;
M: x86-backend %unbox-f ( dst src -- ) M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ; drop v>operand 0 MOV ;
M: x86-backend %unbox-any-c-ptr ( dst src -- ) M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each { "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg ! Address is computed in ds-reg
ds-reg PUSH ds-reg PUSH

6
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
@ -230,7 +230,7 @@ UNION: operand register indirect ;
: opcode-or ( opcode mask -- opcode' ) : opcode-or ( opcode mask -- opcode' )
swap dup array? swap dup array?
[ 1 cut* first rot bitor add ] [ bitor ] if ; [ 1 cut* first rot bitor suffix ] [ bitor ] if ;
: 1-operand ( op reg rex.w opcode -- ) : 1-operand ( op reg rex.w opcode -- )
#! The 'reg' is not really a register, but a value for the #! The 'reg' is not really a register, but a value for the

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

@ -6,8 +6,8 @@ kernel.private math math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system sbufs sbufs.private vectors vectors.private layouts system
tuples.private strings.private slots.private compiler.constants classes.tuple.private strings.private slots.private
; compiler.constants ;
IN: cpu.x86.intrinsics IN: cpu.x86.intrinsics
! Type checks ! Type checks
@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "in" } } { +output+ { "in" } }
} define-intrinsic } define-intrinsic
\ type [
"end" define-label
! Make a copy
"x" operand "obj" operand MOV
! Get the tag
"x" operand tag-mask get AND
! Tag the tag
"x" operand %tag-fixnum
! Compare with object tag number (3).
"x" operand object tag-number tag-fixnum CMP
"end" get JNE
! If we have equality, load type from header
"x" operand "obj" operand -3 [+] MOV
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
\ class-hash [
"end" define-label
"tuple" define-label
"object" define-label
! Make a copy
"x" operand "obj" operand MOV
! Get the tag
"x" operand tag-mask get AND
! Tag the tag
"x" operand %tag-fixnum
! Compare with tuple tag number (2).
"x" operand tuple tag-number tag-fixnum CMP
"tuple" get JE
! Compare with object tag number (3).
"x" operand object tag-number tag-fixnum CMP
"object" get JE
"end" get JMP
"object" get resolve-label
! Load header type
"x" operand "obj" operand header-offset [+] MOV
"end" get JMP
"tuple" get resolve-label
! Load class hash
"x" operand "obj" operand tuple-class-offset [+] MOV
"x" operand dup class-hash-offset [+] MOV
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
! Slots ! Slots
: %slot-literal-known-tag : %slot-literal-known-tag
"obj" operand "obj" operand
@ -156,7 +104,7 @@ IN: cpu.x86.intrinsics
! Fixnums ! Fixnums
: fixnum-op ( op hash -- pair ) : fixnum-op ( op hash -- pair )
>r [ "x" operand "y" operand ] swap add r> 2array ; >r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair ) : fixnum-value-op ( op -- pair )
H{ H{
@ -251,7 +199,7 @@ IN: cpu.x86.intrinsics
\ fixnum- \ SUB overflow-template \ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair ) : fixnum-jump ( op inputs -- pair )
>r [ "x" operand "y" operand CMP ] swap add r> 2array ; >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair ) : fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ; { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
@ -264,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

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

@ -8,7 +8,7 @@ math.floats.private layouts quotations ;
IN: cpu.x86.sse2 IN: cpu.x86.sse2
: define-float-op ( word op -- ) : define-float-op ( word op -- )
[ "x" operand "y" operand ] swap add H{ [ "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } } { +input+ { { float "x" } { float "y" } } }
{ +output+ { "x" } } { +output+ { "x" } }
} define-intrinsic ; } define-intrinsic ;
@ -23,15 +23,15 @@ IN: cpu.x86.sse2
] each ] each
: define-float-jump ( word op -- ) : define-float-jump ( word op -- )
[ "x" operand "y" operand UCOMISD ] swap add [ "x" operand "y" operand UCOMISD ] swap suffix
{ { 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

13
core/debugger/debugger-docs.factor
View File

@ -1,6 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system debugger.private ; help generic.standard continuations system debugger.private
io.files.private ;
IN: debugger IN: debugger
ARTICLE: "errors-assert" "Assertions" ARTICLE: "errors-assert" "Assertions"
@ -86,7 +87,15 @@ HELP: error-hook
HELP: try HELP: try
{ $values { "quot" "a quotation" } } { $values { "quot" "a quotation" } }
{ $description "Calls the quotation. If it throws an error, calls " { $link error-hook } " with the error and restores the data stack." } ; { $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
{ $examples
"The following example prints an error and keeps going:"
{ $code
"[ \"error\" throw ] try"
"\"still running...\" print"
}
{ $link "listener" } " uses " { $link try } " to recover from user errors."
} ;
HELP: expired-error. HELP: expired-error.
{ $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." } { $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." }

29
core/debugger/debugger.factor
View File

@ -3,10 +3,10 @@
USING: arrays definitions generic hashtables inspector io kernel 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
tuples 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 -- )
@ -82,7 +82,7 @@ ERROR: assert got expect ;
: depth ( -- n ) datastack length ; : depth ( -- n ) datastack length ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' ) : trim-datastacks ( seq1 seq2 -- seq1' seq2' )
2dup [ length ] 2apply min tuck tail >r tail r> ; 2dup [ length ] bi@ min tuck tail >r tail r> ;
ERROR: relative-underflow stack ; ERROR: relative-underflow stack ;
@ -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 2drop [ ] ;
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 ;

6
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
@ -63,7 +63,7 @@ IN: dlists.tests
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test [ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
: assert-same-elements : assert-same-elements
[ prune natural-sort ] 2apply assert= ; [ prune natural-sort ] bi@ assert= ;
: dlist-push-all [ push-front ] curry each ; : dlist-push-all [ push-front ] curry each ;
@ -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 ? )

8
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 - ;
@ -18,9 +18,9 @@ TUPLE: effect in out terminated? ;
{ [ dup not ] [ t ] } { [ dup not ] [ t ] }
{ [ over effect-terminated? ] [ t ] } { [ over effect-terminated? ] [ t ] }
{ [ dup effect-terminated? ] [ f ] } { [ dup effect-terminated? ] [ f ] }
{ [ 2dup [ effect-in length ] 2apply > ] [ f ] } { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] 2apply = 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 )

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