Merge branch 'master' of git://factorcode.org/git/factor
U-CUTLER\dharmatech
commit
a48467af91
|
|
@ -18,4 +18,4 @@ factor
|
|||
temp
|
||||
logs
|
||||
work
|
||||
buildsupport/wordsize
|
||||
build-support/wordsize
|
||||
|
|
|
|||
7
Makefile
7
Makefile
|
|
@ -45,8 +45,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
|
||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||
|
||||
default: build-support/wordsize
|
||||
$(MAKE) `./build-support/target`
|
||||
default:
|
||||
$(MAKE) `./build-support/factor.sh make-target`
|
||||
|
||||
help:
|
||||
@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) \
|
||||
$(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:
|
||||
rm -f vm/*.o
|
||||
rm -f factor*.dll libfactor*.*
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ set +e
|
|||
shopt -s nocaseglob
|
||||
#shopt -s nocasematch
|
||||
|
||||
ECHO=echo
|
||||
OS=
|
||||
ARCH=
|
||||
WORD=
|
||||
|
|
@ -25,23 +26,23 @@ ensure_program_installed() {
|
|||
installed=0;
|
||||
for i in $* ;
|
||||
do
|
||||
echo -n "Checking for $i..."
|
||||
$ECHO -n "Checking for $i..."
|
||||
test_program_installed $i
|
||||
if [[ $? -eq 0 ]]; then
|
||||
echo -n "not "
|
||||
else
|
||||
installed=$(( $installed + 1 ))
|
||||
fi
|
||||
echo "found!"
|
||||
$ECHO "found!"
|
||||
done
|
||||
if [[ $installed -eq 0 ]] ; then
|
||||
echo -n "Install "
|
||||
$ECHO -n "Install "
|
||||
if [[ $# -eq 1 ]] ; then
|
||||
echo -n $1
|
||||
$ECHO -n $1
|
||||
else
|
||||
echo -n "any of [ $* ]"
|
||||
$ECHO -n "any of [ $* ]"
|
||||
fi
|
||||
echo " and try again."
|
||||
$ECHO " and try again."
|
||||
exit 1
|
||||
fi
|
||||
}
|
||||
|
|
@ -49,22 +50,22 @@ ensure_program_installed() {
|
|||
check_ret() {
|
||||
RET=$?
|
||||
if [[ $RET -ne 0 ]] ; then
|
||||
echo $1 failed
|
||||
$ECHO $1 failed
|
||||
exit 2
|
||||
fi
|
||||
}
|
||||
|
||||
check_gcc_version() {
|
||||
echo -n "Checking gcc version..."
|
||||
$ECHO -n "Checking gcc version..."
|
||||
GCC_VERSION=`$CC --version`
|
||||
check_ret gcc
|
||||
if [[ $GCC_VERSION == *3.3.* ]] ; then
|
||||
echo "bad!"
|
||||
echo "You have a known buggy version of gcc (3.3)"
|
||||
echo "Install gcc 3.4 or higher and try again."
|
||||
$ECHO "bad!"
|
||||
$ECHO "You have a known buggy version of gcc (3.3)"
|
||||
$ECHO "Install gcc 3.4 or higher and try again."
|
||||
exit 3
|
||||
fi
|
||||
echo "ok."
|
||||
$ECHO "ok."
|
||||
}
|
||||
|
||||
set_downloader() {
|
||||
|
|
@ -90,6 +91,8 @@ set_gcc() {
|
|||
openbsd) ensure_program_installed egcc; CC=egcc;;
|
||||
netbsd) if [[ $WORD -eq 64 ]] ; then
|
||||
CC=/usr/pkg/gcc34/bin/gcc
|
||||
else
|
||||
CC=gcc
|
||||
fi ;;
|
||||
*) CC=gcc;;
|
||||
esac
|
||||
|
|
@ -123,20 +126,20 @@ check_installed_programs() {
|
|||
check_library_exists() {
|
||||
GCC_TEST=factor-library-test.c
|
||||
GCC_OUT=factor-library-test.out
|
||||
echo -n "Checking for library $1..."
|
||||
echo "int main(){return 0;}" > $GCC_TEST
|
||||
$ECHO -n "Checking for library $1..."
|
||||
$ECHO "int main(){return 0;}" > $GCC_TEST
|
||||
$CC $GCC_TEST -o $GCC_OUT -l $1
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
echo "not found!"
|
||||
echo "Warning: library $1 not found."
|
||||
echo "***Factor will compile NO_UI=1"
|
||||
$ECHO "not found!"
|
||||
$ECHO "Warning: library $1 not found."
|
||||
$ECHO "***Factor will compile NO_UI=1"
|
||||
NO_UI=1
|
||||
fi
|
||||
rm -f $GCC_TEST
|
||||
check_ret rm
|
||||
rm -f $GCC_OUT
|
||||
check_ret rm
|
||||
echo "found."
|
||||
$ECHO "found."
|
||||
}
|
||||
|
||||
check_X11_libraries() {
|
||||
|
|
@ -154,14 +157,14 @@ check_libraries() {
|
|||
|
||||
check_factor_exists() {
|
||||
if [[ -d "factor" ]] ; then
|
||||
echo "A directory called 'factor' already exists."
|
||||
echo "Rename or delete it and try again."
|
||||
$ECHO "A directory called 'factor' already exists."
|
||||
$ECHO "Rename or delete it and try again."
|
||||
exit 4
|
||||
fi
|
||||
}
|
||||
|
||||
find_os() {
|
||||
echo "Finding OS..."
|
||||
$ECHO "Finding OS..."
|
||||
uname_s=`uname -s`
|
||||
check_ret uname
|
||||
case $uname_s in
|
||||
|
|
@ -180,7 +183,7 @@ find_os() {
|
|||
}
|
||||
|
||||
find_architecture() {
|
||||
echo "Finding ARCH..."
|
||||
$ECHO "Finding ARCH..."
|
||||
uname_m=`uname -m`
|
||||
check_ret uname
|
||||
case $uname_m in
|
||||
|
|
@ -199,7 +202,7 @@ write_test_program() {
|
|||
}
|
||||
|
||||
find_word_size() {
|
||||
echo "Finding WORD..."
|
||||
$ECHO "Finding WORD..."
|
||||
C_WORD=factor-word-size
|
||||
write_test_program
|
||||
gcc -o $C_WORD $C_WORD.c
|
||||
|
|
@ -217,26 +220,26 @@ set_factor_binary() {
|
|||
}
|
||||
|
||||
echo_build_info() {
|
||||
echo OS=$OS
|
||||
echo ARCH=$ARCH
|
||||
echo WORD=$WORD
|
||||
echo FACTOR_BINARY=$FACTOR_BINARY
|
||||
echo MAKE_TARGET=$MAKE_TARGET
|
||||
echo BOOT_IMAGE=$BOOT_IMAGE
|
||||
echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
|
||||
echo GIT_PROTOCOL=$GIT_PROTOCOL
|
||||
echo GIT_URL=$GIT_URL
|
||||
echo DOWNLOADER=$DOWNLOADER
|
||||
echo CC=$CC
|
||||
echo MAKE=$MAKE
|
||||
$ECHO OS=$OS
|
||||
$ECHO ARCH=$ARCH
|
||||
$ECHO WORD=$WORD
|
||||
$ECHO FACTOR_BINARY=$FACTOR_BINARY
|
||||
$ECHO MAKE_TARGET=$MAKE_TARGET
|
||||
$ECHO BOOT_IMAGE=$BOOT_IMAGE
|
||||
$ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
|
||||
$ECHO GIT_PROTOCOL=$GIT_PROTOCOL
|
||||
$ECHO GIT_URL=$GIT_URL
|
||||
$ECHO DOWNLOADER=$DOWNLOADER
|
||||
$ECHO CC=$CC
|
||||
$ECHO MAKE=$MAKE
|
||||
}
|
||||
|
||||
set_build_info() {
|
||||
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
|
||||
echo "OS: $OS"
|
||||
echo "ARCH: $ARCH"
|
||||
echo "WORD: $WORD"
|
||||
echo "OS, ARCH, or WORD is empty. Please report this"
|
||||
$ECHO "OS: $OS"
|
||||
$ECHO "ARCH: $ARCH"
|
||||
$ECHO "WORD: $WORD"
|
||||
$ECHO "OS, ARCH, or WORD is empty. Please report this"
|
||||
exit 5
|
||||
fi
|
||||
|
||||
|
|
@ -304,7 +307,7 @@ update_boot_images() {
|
|||
echo "Deleting old images..."
|
||||
rm checksums.txt* > /dev/null 2>&1
|
||||
rm $BOOT_IMAGE.* > /dev/null 2>&1
|
||||
rm staging.*.image > /dev/null 2>&1
|
||||
rm temp/staging.*.image > /dev/null 2>&1
|
||||
if [[ -f $BOOT_IMAGE ]] ; then
|
||||
get_url http://factorcode.org/images/latest/checksums.txt
|
||||
factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
|
||||
|
|
@ -346,10 +349,25 @@ maybe_download_dlls() {
|
|||
get_url http://factorcode.org/dlls/zlib1.dll
|
||||
get_url http://factorcode.org/dlls/OpenAL32.dll
|
||||
get_url http://factorcode.org/dlls/alut.dll
|
||||
get_url http://factorcode.org/dlls/comerr32.dll
|
||||
get_url http://factorcode.org/dlls/gssapi32.dll
|
||||
get_url http://factorcode.org/dlls/iconv.dll
|
||||
get_url http://factorcode.org/dlls/k5sprt32.dll
|
||||
get_url http://factorcode.org/dlls/krb5_32.dll
|
||||
get_url http://factorcode.org/dlls/libcairo-2.dll
|
||||
get_url http://factorcode.org/dlls/libeay32.dll
|
||||
get_url http://factorcode.org/dlls/libiconv2.dll
|
||||
get_url http://factorcode.org/dlls/libintl3.dll
|
||||
get_url http://factorcode.org/dlls/libpq.dll
|
||||
get_url http://factorcode.org/dlls/libxml2.dll
|
||||
get_url http://factorcode.org/dlls/libxslt.dll
|
||||
get_url http://factorcode.org/dlls/msvcr71.dll
|
||||
get_url http://factorcode.org/dlls/ogg.dll
|
||||
get_url http://factorcode.org/dlls/pgaevent.dll
|
||||
get_url http://factorcode.org/dlls/sqlite3.dll
|
||||
get_url http://factorcode.org/dlls/ssleay32.dll
|
||||
get_url http://factorcode.org/dlls/theora.dll
|
||||
get_url http://factorcode.org/dlls/vorbis.dll
|
||||
get_url http://factorcode.org/dlls/sqlite3.dll
|
||||
chmod 777 *.dll
|
||||
check_ret chmod
|
||||
fi
|
||||
|
|
@ -420,7 +438,7 @@ install_build_system_port() {
|
|||
}
|
||||
|
||||
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|net-bootstrap|make-target"
|
||||
echo "If you are behind a firewall, invoke as:"
|
||||
echo "env GIT_PROTOCOL=http $0 <command>"
|
||||
}
|
||||
|
|
@ -433,6 +451,8 @@ case "$1" in
|
|||
quick-update) update; refresh_image ;;
|
||||
update) update; update_bootstrap ;;
|
||||
bootstrap) get_config_info; bootstrap ;;
|
||||
dlls) get_config_info; maybe_download_dlls;;
|
||||
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
|
||||
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
|
||||
*) usage ;;
|
||||
esac
|
||||
|
|
@ -1,4 +1,5 @@
|
|||
#include <stdio.h>
|
||||
#include <sys/event.h>
|
||||
|
||||
#if defined(__FreeBSD__)
|
||||
#define BSD
|
||||
|
|
@ -41,6 +42,7 @@
|
|||
#include <sys/socket.h>
|
||||
#include <sys/errno.h>
|
||||
#include <sys/mman.h>
|
||||
#include <sys/syslimits.h>
|
||||
#include <fcntl.h>
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
|
|
@ -141,10 +143,13 @@ void unix_constants()
|
|||
constant(EINTR);
|
||||
constant(EAGAIN);
|
||||
constant(EINPROGRESS);
|
||||
constant(PROT_READ);
|
||||
constant(PROT_READ);
|
||||
constant(PROT_WRITE);
|
||||
constant(MAP_FILE);
|
||||
constant(MAP_SHARED);
|
||||
constant(PATH_MAX);
|
||||
grovel(pid_t);
|
||||
|
||||
}
|
||||
|
||||
int main() {
|
||||
|
|
@ -158,7 +163,13 @@ int main() {
|
|||
openbsd_stat();
|
||||
openbsd_types();
|
||||
#endif
|
||||
grovel(blkcnt_t);
|
||||
grovel(blksize_t);
|
||||
//grovel(fflags_t);
|
||||
grovel(ssize_t);
|
||||
|
||||
grovel(size_t);
|
||||
grovel(struct kevent);
|
||||
#ifdef UNIX
|
||||
unix_types();
|
||||
unix_constants();
|
||||
|
|
|
|||
|
|
@ -1,38 +0,0 @@
|
|||
#!/bin/sh
|
||||
|
||||
if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ]
|
||||
then
|
||||
echo freebsd-x86-32
|
||||
elif [ \( `uname -s` = FreeBSD \) -a \( `uname -m` = amd64 \) ]
|
||||
then
|
||||
echo freebsd-x86-64
|
||||
elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ]
|
||||
then
|
||||
echo openbsd-x86-32
|
||||
elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ]
|
||||
then
|
||||
echo openbsd-x86-64
|
||||
elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ]
|
||||
then
|
||||
echo netbsd-x86-32
|
||||
elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = x86_64 \) ]
|
||||
then
|
||||
echo netbsd-x86-64
|
||||
elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
|
||||
then
|
||||
echo macosx-ppc
|
||||
elif [ `uname -s` = Darwin ]
|
||||
then
|
||||
echo macosx-x86-`./build-support/wordsize`
|
||||
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
|
||||
then
|
||||
echo linux-x86-32
|
||||
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ]
|
||||
then
|
||||
echo linux-x86-64
|
||||
elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
|
||||
then
|
||||
echo winnt-x86-`./build-support/wordsize`
|
||||
else
|
||||
echo help
|
||||
fi
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
|
||||
#include <stdio.h>
|
||||
|
||||
int main ()
|
||||
{
|
||||
printf("%d", 8*sizeof(void*));
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -1,13 +1,12 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math namespaces sequences system
|
||||
kernel.private tuples bit-arrays byte-arrays float-arrays
|
||||
arrays ;
|
||||
kernel.private bit-arrays byte-arrays float-arrays arrays ;
|
||||
IN: alien
|
||||
|
||||
! Some predicate classes used by the compiler for optimization
|
||||
! purposes
|
||||
PREDICATE: alien simple-alien
|
||||
PREDICATE: simple-alien < alien
|
||||
underlying-alien not ;
|
||||
|
||||
UNION: simple-c-ptr
|
||||
|
|
@ -18,7 +17,7 @@ alien POSTPONE: f byte-array bit-array float-array ;
|
|||
|
||||
DEFER: pinned-c-ptr?
|
||||
|
||||
PREDICATE: alien pinned-alien
|
||||
PREDICATE: pinned-alien < alien
|
||||
underlying-alien pinned-c-ptr? ;
|
||||
|
||||
UNION: pinned-c-ptr
|
||||
|
|
@ -40,7 +39,7 @@ M: alien equal?
|
|||
2dup [ expired? ] either? [
|
||||
[ expired? ] both?
|
||||
] [
|
||||
[ alien-address ] 2apply =
|
||||
[ alien-address ] bi@ =
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable
|
|||
|
||||
: parse-array-type ( name -- array )
|
||||
"[" split unclip
|
||||
>r [ "]" ?tail drop string>number ] map r> add* ;
|
||||
>r [ "]" ?tail drop string>number ] map r> prefix ;
|
||||
|
||||
M: string c-type ( name -- type )
|
||||
CHAR: ] over member? [
|
||||
|
|
@ -162,7 +162,7 @@ DEFER: >c-ushort-array
|
|||
>r >c-ushort-array r> byte-array>memory ;
|
||||
|
||||
: (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 )
|
||||
>r "-nth" append r> create ;
|
||||
|
|
@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- )
|
|||
f swap box-parameter ;
|
||||
|
||||
: define-deref ( name vocab -- )
|
||||
>r dup CHAR: * add* r> create
|
||||
swap c-getter 0 add* define-inline ;
|
||||
>r dup CHAR: * prefix r> create
|
||||
swap c-getter 0 prefix define-inline ;
|
||||
|
||||
: define-out ( name vocab -- )
|
||||
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 -- ? )
|
||||
zero? not ;
|
||||
|
|
@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- )
|
|||
#! staging violations
|
||||
dup array? [
|
||||
unclip >r [ dup word? [ word-def call ] when ] map
|
||||
r> add*
|
||||
r> prefix
|
||||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ IN: alien.compiler
|
|||
|
||||
: alien-node-parameters* ( node -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ "void*" add* ] when ;
|
||||
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||
|
||||
: alien-node-return* ( node -- ctype )
|
||||
return>> dup large-struct? [ drop "void" ] when ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ kernel words slots assocs namespaces ;
|
|||
dup ?word-name swap 2array
|
||||
over slot-spec-name
|
||||
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) $values ;
|
||||
|
|
@ -16,9 +16,9 @@ kernel words slots assocs namespaces ;
|
|||
: $spec-reader-description ( slot-spec class -- )
|
||||
[
|
||||
"Outputs the value stored in the " ,
|
||||
{ $snippet } rot slot-spec-name add ,
|
||||
{ $snippet } rot slot-spec-name suffix ,
|
||||
" slot of " ,
|
||||
{ $instance } swap add ,
|
||||
{ $instance } swap suffix ,
|
||||
" instance." ,
|
||||
] { } make $description ;
|
||||
|
||||
|
|
@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ;
|
|||
: $spec-writer-description ( slot-spec class -- )
|
||||
[
|
||||
"Stores a new value to the " ,
|
||||
{ $snippet } rot slot-spec-name add ,
|
||||
{ $snippet } rot slot-spec-name suffix ,
|
||||
" slot of " ,
|
||||
{ $instance } swap add ,
|
||||
{ $instance } swap suffix ,
|
||||
" instance." ,
|
||||
] { } make $description ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: alien.structs
|
|||
] reduce ;
|
||||
|
||||
: 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 -- )
|
||||
[ set-reader-props ] keep
|
||||
|
|
|
|||
|
|
@ -31,4 +31,4 @@ INSTANCE: array sequence
|
|||
|
||||
: 4array ( w x y z -- array ) { } 4sequence ; flushable
|
||||
|
||||
PREDICATE: array pair length 2 number= ;
|
||||
PREDICATE: pair < array length 2 number= ;
|
||||
|
|
|
|||
|
|
@ -93,3 +93,14 @@ unit-test
|
|||
] [
|
||||
F{ 1.0 2.0 } [ dup ] H{ } map>assoc
|
||||
] unit-test
|
||||
|
||||
[ { 3 } ] [
|
||||
[
|
||||
3
|
||||
H{ } clone
|
||||
2 [
|
||||
2dup [ , f ] cache drop
|
||||
] times
|
||||
2drop
|
||||
] { } make
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
swap [ swapd set-at ] curry assoc-each ;
|
||||
|
||||
: union ( assoc1 assoc2 -- union )
|
||||
2dup [ assoc-size ] 2apply + pick new-assoc
|
||||
2dup [ assoc-size ] bi@ + pick new-assoc
|
||||
[ rot update ] keep [ swap update ] keep ;
|
||||
|
||||
: diff ( assoc1 assoc2 -- diff )
|
||||
|
|
@ -134,11 +134,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
(substitute) map ;
|
||||
|
||||
: cache ( key assoc quot -- value )
|
||||
2over at [
|
||||
2over at* [
|
||||
>r 3drop r>
|
||||
] [
|
||||
pick rot >r >r call dup r> r> set-at
|
||||
] if* ; inline
|
||||
drop pick rot >r >r call dup r> r> set-at
|
||||
] if ; inline
|
||||
|
||||
: change-at ( key assoc quot -- )
|
||||
[ >r at r> call ] 3keep drop set-at ; inline
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: bit-arrays.tests
|
|||
{ t f t } { f t f }
|
||||
] [
|
||||
{ t f t } >bit-array dup clone dup [ not ] change-each
|
||||
[ >array ] 2apply
|
||||
[ >array ] bi@
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler cpu.architecture vocabs.loader system sequences
|
||||
namespaces parser kernel kernel.private classes classes.private
|
||||
arrays hashtables vectors tuples sbufs inference.dataflow
|
||||
hashtables.private sequences.private math tuples.private
|
||||
arrays hashtables vectors classes.tuple sbufs inference.dataflow
|
||||
hashtables.private sequences.private math classes.tuple.private
|
||||
growable namespaces.private assocs words generator command-line
|
||||
vocabs io prettyprint libc compiler.units ;
|
||||
IN: bootstrap.compiler
|
||||
|
|
@ -36,7 +36,7 @@ nl
|
|||
{
|
||||
roll -roll declare not
|
||||
|
||||
tuple-class-eq? array? hashtable? vector?
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? node? tombstone?
|
||||
|
||||
array-capacity array-nth set-array-nth
|
||||
|
|
|
|||
|
|
@ -4,14 +4,15 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
|
|||
hashtables assocs hashtables.private io kernel kernel.private
|
||||
math namespaces parser prettyprint sequences sequences.private
|
||||
strings sbufs vectors words quotations assocs system layouts
|
||||
splitting growable classes tuples words.private
|
||||
io.binary io.files vocabs vocabs.loader source-files
|
||||
definitions debugger float-arrays quotations.private
|
||||
sequences.private combinators io.encodings.binary ;
|
||||
splitting growable classes classes.tuple classes.tuple.private
|
||||
words.private io.binary io.files vocabs vocabs.loader
|
||||
source-files definitions debugger float-arrays
|
||||
quotations.private sequences.private combinators
|
||||
io.encodings.binary ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: my-arch ( -- arch )
|
||||
cpu dup "ppc" = [ os "-" rot 3append ] when ;
|
||||
cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
|
||||
|
||||
: boot-image-name ( arch -- string )
|
||||
"boot." swap ".image" 3append ;
|
||||
|
|
@ -54,7 +55,7 @@ IN: bootstrap.image
|
|||
: quot-xt@ 3 bootstrap-cells object tag-number - ;
|
||||
|
||||
: 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
|
||||
SYMBOL: image
|
||||
|
|
@ -133,10 +134,10 @@ SYMBOL: undefined-quot
|
|||
|
||||
: here ( -- size ) heap-size data-base + ;
|
||||
|
||||
: here-as ( tag -- pointer ) here swap bitor ;
|
||||
: here-as ( tag -- pointer ) here bitor ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
|
@ -163,7 +164,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
userenv-size [ f ' emit ] times ;
|
||||
|
||||
: emit-userenv ( symbol -- )
|
||||
dup get ' swap userenv-offset fixup ;
|
||||
[ get ' ] [ userenv-offset ] bi fixup ;
|
||||
|
||||
! Bignums
|
||||
|
||||
|
|
@ -174,14 +175,15 @@ GENERIC: ' ( obj -- ptr )
|
|||
: bignum>seq ( n -- seq )
|
||||
#! n is positive or zero.
|
||||
[ dup 0 > ]
|
||||
[ dup bignum-bits neg shift swap bignum-radix bitand ]
|
||||
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
|
||||
[ ] unfold nip ;
|
||||
|
||||
USE: continuations
|
||||
: emit-bignum ( n -- )
|
||||
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
|
||||
dup length 1+ emit-fixnum
|
||||
swap emit emit-seq ;
|
||||
dup dup 0 < [ neg ] when bignum>seq
|
||||
[ nip length 1+ emit-fixnum ]
|
||||
[ drop 0 < 1 0 ? emit ]
|
||||
[ nip emit-seq ]
|
||||
2tri ;
|
||||
|
||||
M: bignum '
|
||||
bignum tag-number dup [ emit-bignum ] emit-object ;
|
||||
|
|
@ -220,28 +222,33 @@ M: f '
|
|||
! Words
|
||||
|
||||
: emit-word ( word -- )
|
||||
dup subwords [ emit-word ] each
|
||||
[
|
||||
dup hashcode ' ,
|
||||
dup word-name ' ,
|
||||
dup word-vocabulary ' ,
|
||||
dup word-def ' ,
|
||||
dup word-props ' ,
|
||||
f ' ,
|
||||
0 , ! count
|
||||
0 , ! xt
|
||||
0 , ! code
|
||||
0 , ! profiling
|
||||
] { } make
|
||||
\ word type-number object tag-number
|
||||
[ emit-seq ] emit-object
|
||||
swap objects get set-at ;
|
||||
[ subwords [ emit-word ] each ]
|
||||
[
|
||||
[
|
||||
{
|
||||
[ hashcode , ]
|
||||
[ word-name , ]
|
||||
[ word-vocabulary , ]
|
||||
[ word-def , ]
|
||||
[ word-props , ]
|
||||
} cleave
|
||||
f ,
|
||||
0 , ! count
|
||||
0 , ! xt
|
||||
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 -- * )
|
||||
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
|
||||
|
||||
: transfer-word ( word -- word )
|
||||
dup target-word swap or ;
|
||||
[ target-word ] keep or ;
|
||||
|
||||
: fixup-word ( word -- offset )
|
||||
transfer-word dup objects get at
|
||||
|
|
@ -284,9 +291,10 @@ M: string '
|
|||
length 0 assert= ;
|
||||
|
||||
: emit-dummy-array ( obj type -- ptr )
|
||||
swap assert-empty
|
||||
type-number object tag-number
|
||||
[ 0 emit-fixnum ] emit-object ;
|
||||
[ assert-empty ] [
|
||||
type-number object tag-number
|
||||
[ 0 emit-fixnum ] emit-object
|
||||
] bi* ;
|
||||
|
||||
M: byte-array ' byte-array emit-dummy-array ;
|
||||
|
||||
|
|
@ -294,31 +302,42 @@ M: bit-array ' bit-array emit-dummy-array ;
|
|||
|
||||
M: float-array ' float-array emit-dummy-array ;
|
||||
|
||||
! Arrays
|
||||
: emit-array ( list type tag -- pointer )
|
||||
>r >r [ ' ] map r> r> [
|
||||
dup length emit-fixnum
|
||||
emit-seq
|
||||
] emit-object ;
|
||||
! 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 ( obj -- pointer )
|
||||
[
|
||||
[ tuple>array unclip transfer-word , % ] { } make
|
||||
tuple type-number dup emit-array
|
||||
]
|
||||
! Hack
|
||||
over class word-name "tombstone" =
|
||||
[ objects get swap cache ] [ call ] if ;
|
||||
: emit-tuple ( tuple -- pointer )
|
||||
dup class word-name "tombstone" =
|
||||
[ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
|
||||
|
||||
M: tuple ' emit-tuple ;
|
||||
|
||||
M: tuple-layout '
|
||||
objects get [
|
||||
[
|
||||
{
|
||||
[ layout-hashcode , ]
|
||||
[ layout-class , ]
|
||||
[ layout-size , ]
|
||||
[ layout-superclasses , ]
|
||||
[ layout-echelon , ]
|
||||
} cleave
|
||||
] { } make [ ' ] map
|
||||
\ tuple-layout type-number
|
||||
object tag-number [ emit-seq ] emit-object
|
||||
] cache ;
|
||||
|
||||
M: tombstone '
|
||||
delegate
|
||||
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||
word-def first objects get [ emit-tuple ] cache ;
|
||||
|
||||
! Arrays
|
||||
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
|
||||
|
||||
|
|
@ -333,13 +352,6 @@ M: quotation '
|
|||
] emit-object
|
||||
] cache ;
|
||||
|
||||
! Curries
|
||||
|
||||
M: curry '
|
||||
dup curry-quot ' swap curry-obj '
|
||||
\ curry type-number object tag-number
|
||||
[ emit emit ] emit-object ;
|
||||
|
||||
! End of the image
|
||||
|
||||
: emit-words ( -- )
|
||||
|
|
@ -419,8 +431,8 @@ M: curry '
|
|||
: write-image ( image -- )
|
||||
"Writing image to " write
|
||||
architecture get boot-image-name resource-path
|
||||
dup write "..." print flush
|
||||
binary <file-writer> [ (write-image) ] with-stream ;
|
||||
[ write "..." print flush ]
|
||||
[ binary <file-writer> [ (write-image) ] with-stream ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -2,13 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math words kernel alien byte-arrays
|
||||
hashtables vectors strings sbufs arrays bit-arrays
|
||||
float-arrays quotations assocs layouts tuples ;
|
||||
float-arrays quotations assocs layouts classes.tuple.private ;
|
||||
|
||||
BIN: 111 tag-mask set
|
||||
8 num-tags set
|
||||
3 tag-bits set
|
||||
|
||||
19 num-types set
|
||||
20 num-types set
|
||||
|
||||
H{
|
||||
{ fixnum BIN: 000 }
|
||||
|
|
@ -33,4 +33,5 @@ tag-numbers get H{
|
|||
{ alien 16 }
|
||||
{ word 17 }
|
||||
{ byte-array 18 }
|
||||
{ tuple-layout 19 }
|
||||
} union type-numbers set
|
||||
|
|
|
|||
|
|
@ -2,10 +2,11 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays byte-arrays generic hashtables
|
||||
hashtables.private io kernel math namespaces parser sequences
|
||||
strings vectors words quotations assocs layouts classes tuples
|
||||
kernel.private vocabs vocabs.loader source-files definitions
|
||||
slots.deprecated classes.union compiler.units
|
||||
bootstrap.image.private io.files ;
|
||||
strings vectors words quotations assocs layouts classes
|
||||
classes.tuple classes.tuple.private kernel.private vocabs
|
||||
vocabs.loader source-files definitions slots.deprecated
|
||||
classes.union compiler.units bootstrap.image.private io.files
|
||||
accessors combinators ;
|
||||
IN: bootstrap.primitives
|
||||
|
||||
"Creating primitives and basic runtime structures..." print flush
|
||||
|
|
@ -33,7 +34,6 @@ H{ } clone changed-words set
|
|||
H{ } clone root-cache set
|
||||
H{ } clone source-files set
|
||||
H{ } clone update-map set
|
||||
num-types get f <array> builtins set
|
||||
init-caches
|
||||
|
||||
! Vocabulary for slot accessors
|
||||
|
|
@ -47,6 +47,9 @@ call
|
|||
call
|
||||
call
|
||||
|
||||
! After we execute bootstrap/layouts
|
||||
num-types get f <array> builtins set
|
||||
|
||||
! Create some empty vocabs where the below primitives and
|
||||
! classes will go
|
||||
{
|
||||
|
|
@ -58,6 +61,8 @@ call
|
|||
"byte-arrays"
|
||||
"byte-vectors"
|
||||
"classes.private"
|
||||
"classes.tuple"
|
||||
"classes.tuple.private"
|
||||
"compiler.units"
|
||||
"continuations.private"
|
||||
"float-arrays"
|
||||
|
|
@ -89,8 +94,6 @@ call
|
|||
"system.private"
|
||||
"threads.private"
|
||||
"tools.profiler.private"
|
||||
"tuples"
|
||||
"tuples.private"
|
||||
"words"
|
||||
"words.private"
|
||||
"vectors"
|
||||
|
|
@ -100,33 +103,36 @@ call
|
|||
! Builtin classes
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
[
|
||||
"type" word-prop dup
|
||||
\ tag-mask get < \ tag \ type ? , , \ eq? ,
|
||||
"type" word-prop
|
||||
[ tag-mask get < \ tag \ type ? , ] [ , ] bi
|
||||
\ eq? ,
|
||||
] [ ] make ;
|
||||
|
||||
: define-builtin-predicate ( class -- )
|
||||
dup
|
||||
dup builtin-predicate-quot define-predicate
|
||||
predicate-word make-inline ;
|
||||
[ dup builtin-predicate-quot define-predicate ]
|
||||
[ predicate-word make-inline ]
|
||||
bi ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
||||
: register-builtin ( class -- )
|
||||
dup
|
||||
dup lookup-type-number "type" set-word-prop
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
[ dup lookup-type-number "type" set-word-prop ]
|
||||
[ dup "type" word-prop builtins get set-nth ]
|
||||
bi ;
|
||||
|
||||
: define-builtin-slots ( symbol slotspec -- )
|
||||
dupd 1 simple-slots
|
||||
2dup "slots" set-word-prop
|
||||
define-slots ;
|
||||
[ drop ] [ 1 simple-slots ] 2bi
|
||||
[ "slots" set-word-prop ] [ define-slots ] 2bi ;
|
||||
|
||||
: define-builtin ( symbol slotspec -- )
|
||||
>r
|
||||
dup register-builtin
|
||||
dup f f builtin-class define-class
|
||||
dup define-builtin-predicate
|
||||
{
|
||||
[ register-builtin ]
|
||||
[ f f builtin-class define-class ]
|
||||
[ define-builtin-predicate ]
|
||||
[ ]
|
||||
} cleave
|
||||
r> define-builtin-slots ;
|
||||
|
||||
! Forward definitions
|
||||
|
|
@ -141,8 +147,6 @@ call
|
|||
"bignum" "math" create { } define-builtin
|
||||
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"tuple" "kernel" create { } define-builtin
|
||||
|
||||
"ratio" "math" create {
|
||||
{
|
||||
{ "integer" "math" }
|
||||
|
|
@ -178,8 +182,6 @@ call
|
|||
|
||||
"f" "syntax" lookup { } define-builtin
|
||||
|
||||
! do not word...
|
||||
|
||||
"array" "arrays" create { } define-builtin
|
||||
|
||||
"wrapper" "kernel" create {
|
||||
|
|
@ -293,9 +295,60 @@ define-builtin
|
|||
|
||||
"callstack" "kernel" create { } define-builtin
|
||||
|
||||
"tuple-layout" "classes.tuple.private" create {
|
||||
{
|
||||
{ "fixnum" "math" }
|
||||
"hashcode"
|
||||
{ "layout-hashcode" "classes.tuple.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "word" "words" }
|
||||
"class"
|
||||
{ "layout-class" "classes.tuple.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "fixnum" "math" }
|
||||
"size"
|
||||
{ "layout-size" "classes.tuple.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "array" "arrays" }
|
||||
"superclasses"
|
||||
{ "layout-superclasses" "classes.tuple.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "fixnum" "math" }
|
||||
"echelon"
|
||||
{ "layout-echelon" "classes.tuple.private" }
|
||||
f
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
"tuple" "kernel" create { } define-builtin
|
||||
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"delegate"
|
||||
{ "delegate" "kernel" }
|
||||
{ "set-delegate" "kernel" }
|
||||
}
|
||||
}
|
||||
[ drop ] [ generate-tuple-slots ] 2bi
|
||||
[ [ name>> ] map "slot-names" set-word-prop ]
|
||||
[ "slots" set-word-prop ]
|
||||
[ define-slots ] 2tri
|
||||
|
||||
"tuple" "kernel" lookup define-tuple-layout
|
||||
|
||||
! Define general-t type, which is any object that is not f.
|
||||
"general-t" "kernel" create
|
||||
"f" "syntax" lookup builtins get remove [ ] subset f union-class
|
||||
f "f" "syntax" lookup builtins get remove [ ] subset union-class
|
||||
define-class
|
||||
|
||||
"f" "syntax" create [ not ] "predicate" set-word-prop
|
||||
|
|
@ -307,18 +360,20 @@ define-class
|
|||
! 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
|
||||
f builtins get [ ] subset 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
|
||||
f builtins get num-tags get tail 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
|
||||
"null" "kernel" create f { } union-class define-class
|
||||
|
||||
! Create special tombstone values
|
||||
"tombstone" "hashtables.private" create { } define-tuple-class
|
||||
"tombstone" "hashtables.private" create
|
||||
"tuple" "kernel" lookup
|
||||
{ } define-tuple-class
|
||||
|
||||
"((empty))" "hashtables.private" create
|
||||
"tombstone" "hashtables.private" lookup f
|
||||
|
|
@ -330,6 +385,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
|
||||
! Some tuple classes
|
||||
"hashtable" "hashtables" create
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
|
|
@ -350,6 +406,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
} define-tuple-class
|
||||
|
||||
"sbuf" "sbufs" create
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "string" "strings" }
|
||||
|
|
@ -365,6 +422,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
} define-tuple-class
|
||||
|
||||
"vector" "vectors" create
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "array" "arrays" }
|
||||
|
|
@ -380,6 +438,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
} define-tuple-class
|
||||
|
||||
"byte-vector" "byte-vectors" create
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "byte-array" "byte-arrays" }
|
||||
|
|
@ -395,6 +454,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
} define-tuple-class
|
||||
|
||||
"bit-vector" "bit-vectors" create
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "bit-array" "bit-arrays" }
|
||||
|
|
@ -410,6 +470,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
} define-tuple-class
|
||||
|
||||
"float-vector" "float-vectors" create
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "float-array" "float-arrays" }
|
||||
|
|
@ -425,6 +486,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
} define-tuple-class
|
||||
|
||||
"curry" "kernel" create
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
|
|
@ -439,7 +501,13 @@ builtins get num-tags get tail f union-class define-class
|
|||
}
|
||||
} define-tuple-class
|
||||
|
||||
"curry" "kernel" lookup
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
|
||||
"compose" "kernel" create
|
||||
"tuple" "kernel" lookup
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
|
|
@ -454,6 +522,11 @@ builtins get num-tags get tail f union-class define-class
|
|||
}
|
||||
} define-tuple-class
|
||||
|
||||
"compose" "kernel" lookup
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
>r create dup reset-word r>
|
||||
|
|
@ -628,16 +701,15 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "<wrapper>" "kernel" }
|
||||
{ "(clone)" "kernel" }
|
||||
{ "<string>" "strings" }
|
||||
{ "(>tuple)" "tuples.private" }
|
||||
{ "array>quotation" "quotations.private" }
|
||||
{ "quotation-xt" "quotations" }
|
||||
{ "<tuple>" "tuples.private" }
|
||||
{ "tuple>array" "tuples" }
|
||||
{ "<tuple>" "classes.tuple.private" }
|
||||
{ "<tuple-layout>" "classes.tuple.private" }
|
||||
{ "profiling" "tools.profiler.private" }
|
||||
{ "become" "kernel.private" }
|
||||
{ "(sleep)" "threads.private" }
|
||||
{ "<float-array>" "float-arrays" }
|
||||
{ "<tuple-boa>" "tuples.private" }
|
||||
{ "<tuple-boa>" "classes.tuple.private" }
|
||||
{ "class-hash" "kernel.private" }
|
||||
{ "callstack>array" "kernel" }
|
||||
{ "innermost-frame-quot" "kernel.private" }
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ vocabs.loader system debugger continuations ;
|
|||
|
||||
[
|
||||
"resource:core/bootstrap/stage2.factor"
|
||||
dup resource-exists? [
|
||||
dup exists? [
|
||||
[ run-file ]
|
||||
[
|
||||
:c
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
|
|||
|
||||
: load-components ( -- )
|
||||
"exclude" "include"
|
||||
[ get-global " " split [ empty? not ] subset ] 2apply
|
||||
[ get-global " " split [ empty? not ] subset ] bi@
|
||||
seq-diff
|
||||
[ "bootstrap." prepend require ] each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ HELP: class-types
|
|||
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
|
||||
|
||||
HELP: class<
|
||||
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
|
||||
{ $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
|
||||
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
|
||||
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
|
||||
|
||||
|
|
@ -39,15 +39,15 @@ HELP: sort-classes
|
|||
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
|
||||
|
||||
HELP: class-or
|
||||
{ $values { "class1" class } { "class2" class } { "class" class } }
|
||||
{ $values { "first" class } { "second" class } { "class" class } }
|
||||
{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
|
||||
|
||||
HELP: class-and
|
||||
{ $values { "class1" class } { "class2" class } { "class" class } }
|
||||
{ $values { "first" class } { "second" class } { "class" class } }
|
||||
{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
|
||||
|
||||
HELP: classes-intersect?
|
||||
{ $values { "class1" class } { "class2" class } { "?" "a boolean" } }
|
||||
{ $values { "first" class } { "second" class } { "?" "a boolean" } }
|
||||
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
|
||||
|
||||
HELP: min-class
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ UNION: both first-one union-class ;
|
|||
[ f ] [ \ reversed \ slice class< ] unit-test
|
||||
[ f ] [ \ slice \ reversed class< ] unit-test
|
||||
|
||||
PREDICATE: word no-docs "documentation" word-prop not ;
|
||||
PREDICATE: no-docs < word "documentation" word-prop not ;
|
||||
|
||||
UNION: no-docs-union no-docs integer ;
|
||||
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
members>> [ class< ] with all? ;
|
||||
|
||||
: anonymous-complement< ( first second -- ? )
|
||||
[ class>> ] 2apply swap class< ;
|
||||
[ class>> ] bi@ swap class< ;
|
||||
|
||||
: (class<) ( first second -- -1/0/1 )
|
||||
{
|
||||
|
|
@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
|
|||
members>> [ class-and ] with map <anonymous-union> ;
|
||||
|
||||
: 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 )
|
||||
members>> swap add <anonymous-intersection> ;
|
||||
members>> swap suffix <anonymous-intersection> ;
|
||||
|
||||
: (class-and) ( first second -- class )
|
||||
{
|
||||
|
|
@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
|
|||
} cond ;
|
||||
|
||||
: 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 )
|
||||
members>> swap add <anonymous-union> ;
|
||||
members>> swap suffix <anonymous-union> ;
|
||||
|
||||
: (class-or) ( first second -- class )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ M: union-1 generic-update-test drop "union-1" ;
|
|||
[ f ] [ union-1 number class< ] unit-test
|
||||
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
|
||||
|
||||
"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
|
||||
"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
|
||||
|
||||
[ f ] [ union-1 union-class? ] unit-test
|
||||
[ t ] [ union-1 predicate-class? ] unit-test
|
||||
|
|
|
|||
|
|
@ -25,15 +25,15 @@ SYMBOL: class-or-cache
|
|||
class-and-cache get clear-assoc
|
||||
class-or-cache get clear-assoc ;
|
||||
|
||||
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
|
||||
PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
|
||||
|
||||
SYMBOL: update-map
|
||||
SYMBOL: builtins
|
||||
|
||||
PREDICATE: class builtin-class
|
||||
PREDICATE: builtin-class < class
|
||||
"metaclass" word-prop builtin-class eq? ;
|
||||
|
||||
PREDICATE: class tuple-class
|
||||
PREDICATE: tuple-class < class
|
||||
"metaclass" word-prop tuple-class eq? ;
|
||||
|
||||
: classes ( -- seq ) all-words [ class? ] subset ;
|
||||
|
|
@ -47,7 +47,7 @@ PREDICATE: class tuple-class
|
|||
|
||||
: predicate-effect 1 { "?" } <effect> ;
|
||||
|
||||
PREDICATE: word predicate "predicating" word-prop >boolean ;
|
||||
PREDICATE: predicate < word "predicating" word-prop >boolean ;
|
||||
|
||||
: define-predicate ( class quot -- )
|
||||
>r "predicate" word-prop first
|
||||
|
|
@ -57,6 +57,9 @@ PREDICATE: word predicate "predicating" word-prop >boolean ;
|
|||
#! Output f for non-classes to work with algebra code
|
||||
dup class? [ "superclass" word-prop ] [ drop f ] if ;
|
||||
|
||||
: superclasses ( class -- supers )
|
||||
[ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
|
||||
|
||||
: members ( class -- seq )
|
||||
#! Output f for non-classes to work with algebra code
|
||||
dup class? [ "members" word-prop ] [ drop f ] if ;
|
||||
|
|
@ -69,7 +72,7 @@ M: word reset-class drop ;
|
|||
|
||||
! update-map
|
||||
: class-uses ( class -- seq )
|
||||
dup members swap superclass [ add ] when* ;
|
||||
dup members swap superclass [ suffix ] when* ;
|
||||
|
||||
: class-usages ( class -- assoc )
|
||||
[ update-map get at ] closure ;
|
||||
|
|
@ -80,13 +83,12 @@ M: word reset-class drop ;
|
|||
: update-map- ( class -- )
|
||||
dup class-uses update-map get remove-vertex ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-class-props ( members superclass metaclass -- assoc )
|
||||
: define-class-props ( superclass members metaclass -- assoc )
|
||||
[
|
||||
"metaclass" set
|
||||
dup [ bootstrap-word ] when "superclass" set
|
||||
[ bootstrap-word ] map "members" set
|
||||
[ dup [ bootstrap-word ] when "superclass" set ]
|
||||
[ [ bootstrap-word ] map "members" set ]
|
||||
[ "metaclass" set ]
|
||||
tri*
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: (define-class) ( word props -- )
|
||||
|
|
@ -97,31 +99,31 @@ PRIVATE>
|
|||
over "predicating" set-word-prop
|
||||
t "class" set-word-prop ;
|
||||
|
||||
GENERIC: update-predicate ( class -- )
|
||||
PRIVATE>
|
||||
|
||||
M: class update-predicate drop ;
|
||||
GENERIC: update-class ( class -- )
|
||||
|
||||
: update-predicates ( assoc -- )
|
||||
[ drop update-predicate ] assoc-each ;
|
||||
M: class update-class drop ;
|
||||
|
||||
: update-classes ( assoc -- )
|
||||
[ drop update-class ] assoc-each ;
|
||||
|
||||
GENERIC: update-methods ( assoc -- )
|
||||
|
||||
: define-class ( word members superclass metaclass -- )
|
||||
: define-class ( word superclass members metaclass -- )
|
||||
#! If it was already a class, update methods after.
|
||||
reset-caches
|
||||
define-class-props
|
||||
over update-map-
|
||||
dupd (define-class)
|
||||
dup update-map+
|
||||
class-usages dup update-predicates update-methods ;
|
||||
[ drop update-map- ]
|
||||
[ (define-class) ] [
|
||||
drop
|
||||
[ update-map+ ] [
|
||||
class-usages
|
||||
[ update-classes ]
|
||||
[ update-methods ] bi
|
||||
] bi
|
||||
] 2tri ;
|
||||
|
||||
GENERIC: class ( object -- class ) inline
|
||||
|
||||
M: object class type type>class ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: class-of-tuple ( obj -- class )
|
||||
2 slot { word } declare ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.union words kernel sequences
|
||||
definitions combinators arrays ;
|
||||
definitions combinators arrays accessors ;
|
||||
IN: classes.mixin
|
||||
|
||||
PREDICATE: union-class mixin-class "mixin" word-prop ;
|
||||
PREDICATE: mixin-class < union-class "mixin" word-prop ;
|
||||
|
||||
M: mixin-class reset-class
|
||||
{ "metaclass" "members" "mixin" } reset-props ;
|
||||
|
|
@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
|
|||
swap redefine-mixin-class ; inline
|
||||
|
||||
: 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 -- )
|
||||
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
|
||||
|
|
@ -47,14 +47,13 @@ TUPLE: mixin-instance loc class mixin ;
|
|||
M: mixin-instance equal?
|
||||
{
|
||||
{ [ over mixin-instance? not ] [ f ] }
|
||||
{ [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] }
|
||||
{ [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] }
|
||||
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
|
||||
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
} cond 2nip ;
|
||||
|
||||
M: mixin-instance hashcode*
|
||||
{ mixin-instance-class mixin-instance-mixin } get-slots
|
||||
2array hashcode* ;
|
||||
[ class>> ] [ mixin>> ] bi 2array hashcode* ;
|
||||
|
||||
: <mixin-instance> ( class mixin -- definition )
|
||||
{ set-mixin-instance-class set-mixin-instance-mixin }
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ ARTICLE: "predicates" "Predicate classes"
|
|||
ABOUT: "predicates"
|
||||
|
||||
HELP: define-predicate-class
|
||||
{ $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
|
||||
{ $values { "class" class } { "superclass" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
|
||||
{ $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." }
|
||||
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
|
||||
{ $side-effects "class" } ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes kernel namespaces words ;
|
||||
IN: classes.predicate
|
||||
|
||||
PREDICATE: class predicate-class
|
||||
PREDICATE: predicate-class < class
|
||||
"metaclass" word-prop predicate-class eq? ;
|
||||
|
||||
: predicate-quot ( class -- quot )
|
||||
|
|
@ -13,9 +13,9 @@ PREDICATE: class predicate-class
|
|||
"predicate-definition" word-prop , [ drop f ] , \ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: define-predicate-class ( superclass class definition -- )
|
||||
>r dup f roll predicate-class define-class r>
|
||||
dupd "predicate-definition" set-word-prop
|
||||
: define-predicate-class ( class superclass definition -- )
|
||||
>r dupd f predicate-class define-class
|
||||
r> dupd "predicate-definition" set-word-prop
|
||||
dup predicate-quot define-predicate ;
|
||||
|
||||
M: predicate-class reset-class
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: generic help.markup help.syntax kernel
|
||||
tuples.private classes slots quotations words arrays
|
||||
classes.tuple.private classes slots quotations words arrays
|
||||
generic.standard sequences definitions compiler.units ;
|
||||
IN: tuples
|
||||
IN: classes.tuple
|
||||
|
||||
ARTICLE: "tuple-constructors" "Constructors"
|
||||
"Tuples are created by calling one of two words:"
|
||||
|
|
@ -151,30 +151,14 @@ HELP: set-delegate
|
|||
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 "tuples.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
|
||||
{ $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-eq?
|
||||
{ $values { "obj" object } { "class" tuple-class } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "obj" } " is an instance of " { $snippet "class" } "." } ;
|
||||
|
||||
HELP: permutation
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
|
||||
{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
|
||||
|
||||
HELP: reshape-tuple
|
||||
{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
|
||||
{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
|
||||
|
||||
HELP: reshape-tuples
|
||||
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
|
||||
{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
|
||||
|
||||
HELP: old-slots
|
||||
HELP: removed-slots
|
||||
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
|
||||
{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
|
||||
|
||||
HELP: forget-slots
|
||||
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
|
||||
HELP: forget-removed-slots
|
||||
{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
|
||||
{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
|
||||
|
||||
HELP: tuple
|
||||
|
|
@ -194,8 +178,8 @@ HELP: define-tuple-predicate
|
|||
{ $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: check-shape
|
||||
{ $values { "class" class } { "newslots" "a sequence of strings" } }
|
||||
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." }
|
||||
|
|
@ -218,8 +202,8 @@ HELP: check-tuple
|
|||
{ $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 } { "slots" "a sequence of strings" } }
|
||||
{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
|
||||
{ $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" } ;
|
||||
|
||||
|
|
@ -246,9 +230,13 @@ 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 the second is the delegate; the remainder are declared slots." } ;
|
||||
|
||||
HELP: <tuple> ( class n -- tuple )
|
||||
{ $values { "class" tuple-class } { "n" "a non-negative integer" } { "tuple" tuple } }
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use the constructor word which is defined for each tuple. See " { $link "tuples" } "." } ;
|
||||
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 construct-empty } "." } ;
|
||||
|
||||
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 construct-boa } "." } ;
|
||||
|
||||
HELP: construct-empty
|
||||
{ $values { "class" tuple-class } { "tuple" tuple } }
|
||||
|
|
@ -0,0 +1,511 @@
|
|||
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 ;
|
||||
IN: classes.tuple.tests
|
||||
|
||||
TUPLE: rect x y w h ;
|
||||
: <rect> rect construct-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
|
||||
|
||||
GENERIC: delegation-test
|
||||
M: object delegation-test drop 3 ;
|
||||
TUPLE: quux-tuple ;
|
||||
: <quux-tuple> quux-tuple construct-empty ;
|
||||
M: quux-tuple delegation-test drop 4 ;
|
||||
TUPLE: quuux-tuple ;
|
||||
: <quuux-tuple> { set-delegate } quuux-tuple construct ;
|
||||
|
||||
[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
|
||||
|
||||
GENERIC: delegation-test-2
|
||||
TUPLE: quux-tuple-2 ;
|
||||
: <quux-tuple-2> quux-tuple-2 construct-empty ;
|
||||
M: quux-tuple-2 delegation-test-2 drop 4 ;
|
||||
TUPLE: quuux-tuple-2 ;
|
||||
: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
|
||||
|
||||
[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
|
||||
|
||||
! Make sure we handle tuple class redefinition
|
||||
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
|
||||
|
||||
[ 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
|
||||
|
||||
[ 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
|
||||
|
||||
TUPLE: delegate-clone ;
|
||||
|
||||
[ T{ delegate-clone T{ empty f } } ]
|
||||
[ T{ delegate-clone T{ empty f } } clone ] 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 construct-boa ] must-fail
|
||||
[ not-a-tuple-class construct-empty ] 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 construct-empty ;
|
||||
: cons-test-2 \ erg's-reshape-problem construct-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
|
||||
] [ [ no-tuple-class? ] is? ] 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 ;
|
||||
|
||||
T{ test2 f "a" "b" } "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
|
||||
|
|
@ -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 delegate 2 slot ;
|
||||
|
||||
M: tuple set-delegate 2 set-slot ;
|
||||
|
||||
M: tuple class 1 slot 2 slot { word } declare ;
|
||||
|
||||
ERROR: no-tuple-class class ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: tuple-layout ( object -- layout )
|
||||
|
||||
M: 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 -- array )
|
||||
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 -- array )
|
||||
unclip slots>tuple ;
|
||||
|
||||
: slot-names ( class -- seq )
|
||||
"slot-names" word-prop ;
|
||||
|
||||
<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 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 ;
|
||||
|
||||
: removed-slots ( class newslots -- seq )
|
||||
swap slot-names seq-diff ;
|
||||
|
||||
: forget-removed-slots ( class slots -- )
|
||||
dupd removed-slots [
|
||||
[ reader-word forget-method ]
|
||||
[ writer-word forget-method ] 2bi
|
||||
] with each ;
|
||||
|
||||
: all-slot-names ( class -- slots )
|
||||
superclasses [ slot-names ] map concat \ class prefix ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: subclasses ( class -- classes )
|
||||
class-usages keys [ tuple-class? ] subset ;
|
||||
|
||||
: each-subclass ( class quot -- )
|
||||
>r subclasses r> each ; inline
|
||||
|
||||
: define-tuple-shape ( class -- )
|
||||
[ define-tuple-slots ]
|
||||
[ define-tuple-layout ]
|
||||
[ define-tuple-predicate ]
|
||||
tri ;
|
||||
|
||||
: define-new-tuple-class ( class superclass slots -- )
|
||||
[ drop f tuple-class define-class ]
|
||||
[ nip "slot-names" set-word-prop ]
|
||||
[
|
||||
2drop
|
||||
[ define-tuple-shape ] each-subclass
|
||||
] 3tri ;
|
||||
|
||||
: redefine-tuple-class ( class superclass slots -- )
|
||||
[
|
||||
2drop
|
||||
[
|
||||
[ update-tuples-after ]
|
||||
[ changed-word ]
|
||||
[ redefined ]
|
||||
tri
|
||||
] each-subclass
|
||||
]
|
||||
[ nip forget-removed-slots ]
|
||||
[ define-new-tuple-class ]
|
||||
3tri ;
|
||||
|
||||
: tuple-class-unchanged? ( class superclass slots -- ? )
|
||||
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# define-tuple-class 2 ( class superclass slots -- )
|
||||
|
||||
M: word define-tuple-class
|
||||
define-new-tuple-class ;
|
||||
|
||||
M: tuple-class define-tuple-class
|
||||
3dup tuple-class-unchanged?
|
||||
[ 3dup redefine-tuple-class ] unless
|
||||
3drop ;
|
||||
|
||||
: define-error-class ( class superclass slots -- )
|
||||
[ define-tuple-class ] [ 2drop ] 3bi
|
||||
dup [ construct-boa throw ] curry define ;
|
||||
|
||||
M: tuple clone
|
||||
(clone) dup delegate clone over set-delegate ;
|
||||
|
||||
M: tuple equal?
|
||||
over tuple? [ tuple= ] [ 2drop f ] if ;
|
||||
|
||||
M: tuple hashcode*
|
||||
[
|
||||
dup tuple-size -rot 0 -rot [
|
||||
swapd array-nth hashcode* bitxor
|
||||
] 2curry reduce
|
||||
] recursive-hashcode ;
|
||||
|
||||
M: tuple-class reset-class
|
||||
{ "metaclass" "superclass" "slots" "layout" } reset-props ;
|
||||
|
||||
M: object get-slots ( obj slots -- ... )
|
||||
[ execute ] with each ;
|
||||
|
||||
M: object construct-empty ( class -- tuple )
|
||||
tuple-layout <tuple> ;
|
||||
|
||||
M: object construct-boa ( ... class -- tuple )
|
||||
tuple-layout <tuple-boa> ;
|
||||
|
||||
! Deprecated
|
||||
M: object set-slots ( ... obj slots -- )
|
||||
<reversed> get-slots ;
|
||||
|
||||
M: object construct ( ... slots class -- tuple )
|
||||
construct-empty [ swap set-slots ] keep ;
|
||||
|
||||
: delegates ( obj -- seq )
|
||||
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
|
||||
|
||||
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
|
||||
|
|
@ -4,7 +4,7 @@ USING: words sequences kernel assocs combinators classes
|
|||
generic.standard namespaces arrays math quotations ;
|
||||
IN: classes.union
|
||||
|
||||
PREDICATE: class union-class
|
||||
PREDICATE: union-class < class
|
||||
"metaclass" word-prop union-class eq? ;
|
||||
|
||||
! Union classes for dispatch on multiple classes.
|
||||
|
|
@ -33,10 +33,10 @@ PREDICATE: class union-class
|
|||
: define-union-predicate ( class -- )
|
||||
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 -- )
|
||||
dupd f union-class define-class define-union-predicate ;
|
||||
f swap union-class define-class ;
|
||||
|
||||
M: union-class reset-class
|
||||
{ "metaclass" "members" } reset-props ;
|
||||
|
|
|
|||
|
|
@ -10,18 +10,54 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
|
|||
{ $subsection alist>quot } ;
|
||||
|
||||
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 case }
|
||||
"The " { $vocab-link "combinators" } " also provides some less frequently-used features."
|
||||
$nl
|
||||
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
|
||||
{ $subsection recursive-hashcode }
|
||||
"An oddball combinator:"
|
||||
{ $subsection with-datastack }
|
||||
{ $subsection "combinators-quot" }
|
||||
{ $see-also "quotations" "basic-combinators" } ;
|
||||
{ $see-also "quotations" "dataflow" } ;
|
||||
|
||||
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
|
||||
{ $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." }
|
||||
|
|
|
|||
|
|
@ -5,6 +5,26 @@ USING: arrays sequences sequences.private math.private
|
|||
kernel kernel.private math assocs quotations vectors
|
||||
hashtables sorting ;
|
||||
|
||||
: cleave ( x seq -- )
|
||||
[ call ] with each ;
|
||||
|
||||
: cleave>quot ( seq -- quot )
|
||||
[ [ keep ] curry ] map concat [ drop ] append ;
|
||||
|
||||
: 2cleave ( x seq -- )
|
||||
[ [ call ] 3keep drop ] each 2drop ;
|
||||
|
||||
: 2cleave>quot ( seq -- quot )
|
||||
[ [ 2keep ] curry ] map concat [ 2drop ] append ;
|
||||
|
||||
: spread>quot ( seq -- quot )
|
||||
[ length [ >r ] <repetition> concat ]
|
||||
[ [ [ r> ] prepend ] map concat ] bi
|
||||
append ;
|
||||
|
||||
: spread ( objs... seq -- )
|
||||
spread>quot call ;
|
||||
|
||||
ERROR: no-cond ;
|
||||
|
||||
: cond ( assoc -- )
|
||||
|
|
@ -23,7 +43,7 @@ ERROR: no-case ;
|
|||
: with-datastack ( stack quot -- newstack )
|
||||
datastack >r
|
||||
>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 )
|
||||
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
|
||||
|
|
@ -46,7 +66,7 @@ M: hashtable hashcode*
|
|||
reverse [ no-cond ] swap alist>quot ;
|
||||
|
||||
: linear-case-quot ( default assoc -- quot )
|
||||
[ >r [ dupd = ] curry r> \ drop add* ] assoc-map
|
||||
[ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
|
||||
alist>quot ;
|
||||
|
||||
: (distribute-buckets) ( buckets pair keys -- )
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: compiler.constants
|
|||
: byte-array-offset 2 bootstrap-cells object tag-number - ;
|
||||
: alien-offset 3 bootstrap-cells object tag-number - ;
|
||||
: underlying-alien-offset bootstrap-cell object tag-number - ;
|
||||
: tuple-class-offset 2 bootstrap-cells tuple tag-number - ;
|
||||
: tuple-class-offset bootstrap-cell tuple tag-number - ;
|
||||
: class-hash-offset bootstrap-cell object tag-number - ;
|
||||
: word-xt-offset 8 bootstrap-cells object tag-number - ;
|
||||
: word-code-offset 9 bootstrap-cells object tag-number - ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: compiler.tests
|
|||
[ 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
|
||||
|
||||
[ -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
|
||||
|
|
|
|||
|
|
@ -72,17 +72,17 @@ unit-test
|
|||
] unit-test
|
||||
|
||||
[ 12 13 ] [
|
||||
-12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call
|
||||
-12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
|
||||
|
||||
[ 12 13 ] [
|
||||
-12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
|
||||
-12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [
|
||||
SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip
|
||||
[ 1 ] [
|
||||
SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
|
||||
] unit-test
|
||||
|
||||
! Test slow shuffles
|
||||
|
|
|
|||
|
|
@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
dup [ drop crossref? ] assoc-contains?
|
||||
modify-code-heap ;
|
||||
|
||||
SYMBOL: post-compile-tasks
|
||||
|
||||
: after-compilation ( quot -- )
|
||||
post-compile-tasks get push ;
|
||||
SYMBOL: outdated-tuples
|
||||
SYMBOL: update-tuples-hook
|
||||
|
||||
: call-recompile-hook ( -- )
|
||||
changed-words get keys
|
||||
compiled-usages recompile-hook get call ;
|
||||
|
||||
: call-post-compile-tasks ( -- )
|
||||
post-compile-tasks get [ call ] each ;
|
||||
: call-update-tuples-hook ( -- )
|
||||
update-tuples-hook get call ;
|
||||
|
||||
: finish-compilation-unit ( -- )
|
||||
call-recompile-hook
|
||||
call-post-compile-tasks
|
||||
call-update-tuples-hook
|
||||
dup [ drop crossref? ] assoc-contains? modify-code-heap
|
||||
changed-definitions notify-definition-observers ;
|
||||
|
||||
|
|
@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks
|
|||
[
|
||||
H{ } clone changed-words set
|
||||
H{ } clone forgotten-definitions set
|
||||
V{ } clone post-compile-tasks set
|
||||
H{ } clone outdated-tuples set
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[ finish-compilation-unit ]
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ $nl
|
|||
{ $subsection ignore-errors }
|
||||
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
|
||||
{ $subsection "errors-restartable" }
|
||||
{ $subsection "debugger" }
|
||||
{ $subsection "errors-post-mortem" }
|
||||
"When Factor encouters a critical error, it calls the following word:"
|
||||
{ $subsection die } ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays vectors kernel kernel.private sequences
|
||||
namespaces math splitting sorting quotations assocs ;
|
||||
namespaces math splitting sorting quotations assocs
|
||||
combinators accessors ;
|
||||
IN: continuations
|
||||
|
||||
SYMBOL: error
|
||||
|
|
@ -43,12 +44,12 @@ C: <continuation> continuation
|
|||
|
||||
: >continuation< ( continuation -- data call retain name catch )
|
||||
{
|
||||
continuation-data
|
||||
continuation-call
|
||||
continuation-retain
|
||||
continuation-name
|
||||
continuation-catch
|
||||
} get-slots ;
|
||||
[ data>> ]
|
||||
[ call>> ]
|
||||
[ retain>> ]
|
||||
[ name>> ]
|
||||
[ catch>> ]
|
||||
} cleave ;
|
||||
|
||||
: ifcc ( capture restore -- )
|
||||
#! After continuation is being captured, the stacks looks
|
||||
|
|
|
|||
|
|
@ -153,11 +153,11 @@ M: f v>operand drop \ f tag-number ;
|
|||
|
||||
M: object load-literal v>operand load-indirect ;
|
||||
|
||||
PREDICATE: integer small-slot cells small-enough? ;
|
||||
PREDICATE: small-slot < integer cells small-enough? ;
|
||||
|
||||
PREDICATE: integer small-tagged v>operand small-enough? ;
|
||||
PREDICATE: small-tagged < integer v>operand small-enough? ;
|
||||
|
||||
PREDICATE: integer inline-array 32 < ;
|
||||
PREDICATE: inline-array < integer 32 < ;
|
||||
|
||||
: if-small-struct ( n size true false -- ? )
|
||||
>r >r over not over struct-small-enough? and
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ M: arm-backend load-indirect ( obj reg -- )
|
|||
|
||||
M: immediate load-literal
|
||||
over v>operand small-enough? [
|
||||
[ v>operand ] 2apply swap MOV
|
||||
[ v>operand ] bi@ swap MOV
|
||||
] [
|
||||
v>operand load-indirect
|
||||
] if ;
|
||||
|
|
@ -322,10 +322,10 @@ M: arm-backend fp-shadows-int? ( -- ? ) f ;
|
|||
|
||||
! Alien intrinsics
|
||||
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 -- )
|
||||
[ v>operand ] 2apply alien-offset <+> LDR ;
|
||||
[ v>operand ] bi@ alien-offset <+> LDR ;
|
||||
|
||||
M: arm-backend %unbox-f ( dst src -- )
|
||||
drop v>operand 0 MOV ;
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ SYMBOL: R15
|
|||
{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
|
||||
define-registers
|
||||
|
||||
PREDICATE: word register register >boolean ;
|
||||
PREDICATE: register < word register >boolean ;
|
||||
|
||||
GENERIC: register ( register -- n )
|
||||
M: word register "register" word-prop ;
|
||||
|
|
|
|||
|
|
@ -5,8 +5,8 @@ cpu.arm.architecture cpu.arm.allot kernel kernel.private math
|
|||
math.private namespaces sequences words
|
||||
quotations byte-arrays hashtables.private hashtables generator
|
||||
generator.registers generator.fixup sequences.private sbufs
|
||||
sbufs.private vectors vectors.private system tuples.private
|
||||
layouts strings.private slots.private ;
|
||||
sbufs.private vectors vectors.private system
|
||||
classes.tuple.private layouts strings.private slots.private ;
|
||||
IN: cpu.arm.intrinsics
|
||||
|
||||
: %slot-literal-known-tag
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ IN: cpu.ppc.allot
|
|||
f fresh-object ;
|
||||
|
||||
M: ppc-backend %box-float ( dst src -- )
|
||||
[ v>operand ] 2apply %allot-float 12 MR ;
|
||||
[ v>operand ] bi@ %allot-float 12 MR ;
|
||||
|
||||
: %allot-bignum ( #digits -- )
|
||||
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ 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: immediate load-literal
|
||||
[ v>operand ] 2apply LOAD ;
|
||||
[ v>operand ] bi@ LOAD ;
|
||||
|
||||
M: ppc-backend load-indirect ( obj reg -- )
|
||||
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
|
||||
|
|
@ -138,7 +138,7 @@ M: ppc-backend %replace
|
|||
>r v>operand r> loc>operand STW ;
|
||||
|
||||
M: ppc-backend %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 ;
|
||||
|
||||
|
|
@ -291,10 +291,10 @@ M: ppc-backend %unbox-small-struct
|
|||
|
||||
! Alien intrinsics
|
||||
M: ppc-backend %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 -- )
|
||||
[ v>operand ] 2apply alien-offset LWZ ;
|
||||
[ v>operand ] bi@ alien-offset LWZ ;
|
||||
|
||||
M: ppc-backend %unbox-f ( dst src -- )
|
||||
drop 0 swap v>operand LI ;
|
||||
|
|
|
|||
|
|
@ -6,9 +6,9 @@ kernel.private math math.private namespaces sequences words
|
|||
generic quotations byte-arrays hashtables hashtables.private
|
||||
generator generator.registers generator.fixup sequences.private
|
||||
sbufs vectors system layouts math.floats.private
|
||||
classes tuples tuples.private sbufs.private vectors.private
|
||||
strings.private slots.private combinators bit-arrays
|
||||
float-arrays compiler.constants ;
|
||||
classes classes.tuple classes.tuple.private sbufs.private
|
||||
vectors.private strings.private slots.private combinators
|
||||
bit-arrays float-arrays compiler.constants ;
|
||||
IN: cpu.ppc.intrinsics
|
||||
|
||||
: %slot-literal-known-tag
|
||||
|
|
@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics
|
|||
} define-intrinsics
|
||||
|
||||
: 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" } } }
|
||||
{ +scratch+ { { f "out" } } }
|
||||
{ +output+ { "out" } }
|
||||
} 2array ;
|
||||
|
||||
: 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" } } }
|
||||
{ +scratch+ { { f "out" } } }
|
||||
{ +output+ { "out" } }
|
||||
|
|
@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics
|
|||
} define-intrinsic
|
||||
|
||||
: 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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: define-fixnum-jump ( word op -- )
|
||||
|
|
@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics
|
|||
} define-intrinsic
|
||||
|
||||
: 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" } } }
|
||||
{ +scratch+ { { float "z" } } }
|
||||
{ +output+ { "z" } }
|
||||
|
|
@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics
|
|||
] each
|
||||
|
||||
: 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 ;
|
||||
|
||||
{
|
||||
|
|
@ -479,19 +479,17 @@ IN: cpu.ppc.intrinsics
|
|||
} define-intrinsic
|
||||
|
||||
\ <tuple> [
|
||||
tuple "n" get 2 + cells %allot
|
||||
! Store length
|
||||
"n" operand 12 LI
|
||||
tuple "layout" get layout-size 2 + cells %allot
|
||||
! Store layout
|
||||
"layout" get 12 load-indirect
|
||||
12 11 cell STW
|
||||
! Store class
|
||||
"class" operand 11 2 cells STW
|
||||
! Zero out the rest of the tuple
|
||||
f v>operand 12 LI
|
||||
"n" get 1- [ 12 11 rot 3 + cells STW ] each
|
||||
"layout" get layout-size [ 12 11 rot 2 + cells STW ] each
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] H{
|
||||
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
|
||||
{ +input+ { { [ tuple-layout? ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ alien.compiler combinators command-line
|
|||
compiler compiler.units io vocabs.loader accessors ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
PREDICATE: x86-backend x86-32-backend
|
||||
PREDICATE: x86-32-backend < x86-backend
|
||||
x86-backend-cell 4 = ;
|
||||
|
||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ layouts alien alien.accessors alien.compiler alien.structs slots
|
|||
splitting assocs ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
PREDICATE: x86-backend amd64-backend
|
||||
PREDICATE: amd64-backend < x86-backend
|
||||
x86-backend-cell 8 = ;
|
||||
|
||||
M: amd64-backend ds-reg R14 ;
|
||||
|
|
|
|||
|
|
@ -101,6 +101,6 @@ M: x86-backend %box-alien ( dst src -- )
|
|||
] %allot
|
||||
"end" get JMP
|
||||
"f" resolve-label
|
||||
f [ v>operand ] 2apply MOV
|
||||
f [ v>operand ] bi@ MOV
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -109,9 +109,9 @@ M: x86-backend %dispatch-label ( word -- )
|
|||
0 cell, rc-absolute-cell rel-word ;
|
||||
|
||||
M: x86-backend %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-backend %peek [ v>operand ] bi@ MOV ;
|
||||
|
||||
M: x86-backend %replace swap %peek ;
|
||||
|
||||
|
|
@ -156,16 +156,16 @@ M: x86-backend %unbox-small-struct ( size -- )
|
|||
|
||||
M: x86-backend struct-small-enough? ( size -- ? )
|
||||
{ 1 2 4 8 } member?
|
||||
os { "linux" "solaris" } member? not and ;
|
||||
os { "linux" "netbsd" "solaris" } member? not and ;
|
||||
|
||||
M: x86-backend %return ( -- ) 0 %unwind ;
|
||||
|
||||
! Alien intrinsics
|
||||
M: x86-backend %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 -- )
|
||||
[ v>operand ] 2apply alien-offset [+] MOV ;
|
||||
[ v>operand ] bi@ alien-offset [+] MOV ;
|
||||
|
||||
M: x86-backend %unbox-f ( dst src -- )
|
||||
drop v>operand 0 MOV ;
|
||||
|
|
|
|||
|
|
@ -52,13 +52,23 @@ GENERIC: extended? ( op -- ? )
|
|||
|
||||
M: object extended? drop f ;
|
||||
|
||||
PREDICATE: word register "register" word-prop ;
|
||||
PREDICATE: register < word
|
||||
"register" word-prop ;
|
||||
|
||||
PREDICATE: register register-8 "register-size" word-prop 8 = ;
|
||||
PREDICATE: register register-16 "register-size" word-prop 16 = ;
|
||||
PREDICATE: register register-32 "register-size" word-prop 32 = ;
|
||||
PREDICATE: register register-64 "register-size" word-prop 64 = ;
|
||||
PREDICATE: register register-128 "register-size" word-prop 128 = ;
|
||||
PREDICATE: register-8 < register
|
||||
"register-size" word-prop 8 = ;
|
||||
|
||||
PREDICATE: register-16 < register
|
||||
"register-size" word-prop 16 = ;
|
||||
|
||||
PREDICATE: register-32 < register
|
||||
"register-size" word-prop 32 = ;
|
||||
|
||||
PREDICATE: register-64 < register
|
||||
"register-size" word-prop 64 = ;
|
||||
|
||||
PREDICATE: register-128 < register
|
||||
"register-size" word-prop 128 = ;
|
||||
|
||||
M: register extended? "register" word-prop 7 > ;
|
||||
|
||||
|
|
@ -220,7 +230,7 @@ UNION: operand register indirect ;
|
|||
|
||||
: opcode-or ( opcode mask -- opcode' )
|
||||
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 -- )
|
||||
#! The 'reg' is not really a register, but a value for the
|
||||
|
|
@ -285,7 +295,7 @@ GENERIC: (MOV-I) ( src dst -- )
|
|||
M: register (MOV-I) t HEX: b8 short-operand cell, ;
|
||||
M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
|
||||
|
||||
PREDICATE: word callable register? not ;
|
||||
PREDICATE: callable < word register? not ;
|
||||
|
||||
GENERIC: MOV ( dst src -- )
|
||||
M: integer MOV swap (MOV-I) ;
|
||||
|
|
|
|||
|
|
@ -6,8 +6,8 @@ kernel.private math math.private namespaces quotations sequences
|
|||
words generic byte-arrays hashtables hashtables.private
|
||||
generator generator.registers generator.fixup sequences.private
|
||||
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
|
||||
|
||||
! Type checks
|
||||
|
|
@ -156,7 +156,7 @@ IN: cpu.x86.intrinsics
|
|||
|
||||
! Fixnums
|
||||
: 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 )
|
||||
H{
|
||||
|
|
@ -251,7 +251,7 @@ IN: cpu.x86.intrinsics
|
|||
\ fixnum- \ SUB overflow-template
|
||||
|
||||
: 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 )
|
||||
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
|
||||
|
|
@ -336,19 +336,20 @@ IN: cpu.x86.intrinsics
|
|||
} define-intrinsic
|
||||
|
||||
\ <tuple> [
|
||||
tuple "n" get 2 + cells [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store class
|
||||
2 object@ "class" operand MOV
|
||||
tuple "layout" get layout-size 2 + cells [
|
||||
! Store layout
|
||||
"layout" get "scratch" get load-literal
|
||||
1 object@ "scratch" operand MOV
|
||||
! Zero out the rest of the tuple
|
||||
"n" operand 1- [ 3 + object@ f v>operand MOV ] each
|
||||
"layout" get layout-size [
|
||||
2 + object@ f v>operand MOV
|
||||
] each
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
|
||||
{ +scratch+ { { f "tuple" } } }
|
||||
{ +input+ { { [ tuple-layout? ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } { f "scratch" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ math.floats.private layouts quotations ;
|
|||
IN: cpu.x86.sse2
|
||||
|
||||
: define-float-op ( word op -- )
|
||||
[ "x" operand "y" operand ] swap add H{
|
||||
[ "x" operand "y" operand ] swap suffix H{
|
||||
{ +input+ { { float "x" } { float "y" } } }
|
||||
{ +output+ { "x" } }
|
||||
} define-intrinsic ;
|
||||
|
|
@ -23,7 +23,7 @@ IN: cpu.x86.sse2
|
|||
] each
|
||||
|
||||
: 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 ;
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -86,7 +86,15 @@ HELP: error-hook
|
|||
|
||||
HELP: try
|
||||
{ $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.
|
||||
{ $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." }
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays definitions generic hashtables inspector io kernel
|
||||
math namespaces prettyprint sequences assocs sequences.private
|
||||
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.standard vocabs threads threads.private init
|
||||
kernel.private libc io.encodings ;
|
||||
|
|
@ -82,7 +82,7 @@ ERROR: assert got expect ;
|
|||
: depth ( -- n ) datastack length ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
|
@ -156,7 +156,7 @@ M: relative-overflow summary
|
|||
: primitive-error.
|
||||
"Unimplemented primitive" print drop ;
|
||||
|
||||
PREDICATE: array kernel-error ( obj -- ? )
|
||||
PREDICATE: kernel-error < array
|
||||
{
|
||||
{ [ dup empty? ] [ drop f ] }
|
||||
{ [ dup first "kernel-error" = not ] [ drop f ] }
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ IN: dlists.tests
|
|||
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
|
||||
|
||||
: assert-same-elements
|
||||
[ prune natural-sort ] 2apply assert= ;
|
||||
[ prune natural-sort ] bi@ assert= ;
|
||||
|
||||
: dlist-push-all [ push-front ] curry each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -18,8 +18,8 @@ TUPLE: effect in out terminated? ;
|
|||
{ [ dup not ] [ t ] }
|
||||
{ [ over effect-terminated? ] [ t ] }
|
||||
{ [ dup effect-terminated? ] [ f ] }
|
||||
{ [ 2dup [ effect-in length ] 2apply > ] [ f ] }
|
||||
{ [ 2dup [ effect-height ] 2apply = not ] [ f ] }
|
||||
{ [ 2dup [ effect-in length ] bi@ > ] [ f ] }
|
||||
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
} cond 2nip ;
|
||||
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ M: ds-loc minimal-ds-loc* ds-loc-n min ;
|
|||
M: ds-loc operand-class* ds-loc-class ;
|
||||
M: ds-loc set-operand-class set-ds-loc-class ;
|
||||
M: ds-loc live-loc?
|
||||
over ds-loc? [ [ ds-loc-n ] 2apply = not ] [ 2drop t ] if ;
|
||||
over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
! A retain stack location.
|
||||
TUPLE: rs-loc n class ;
|
||||
|
|
@ -89,7 +89,7 @@ TUPLE: rs-loc n class ;
|
|||
M: rs-loc operand-class* rs-loc-class ;
|
||||
M: rs-loc set-operand-class set-rs-loc-class ;
|
||||
M: rs-loc live-loc?
|
||||
over rs-loc? [ [ rs-loc-n ] 2apply = not ] [ 2drop t ] if ;
|
||||
over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
UNION: loc ds-loc rs-loc ;
|
||||
|
||||
|
|
@ -206,7 +206,7 @@ INSTANCE: constant value
|
|||
%move ;
|
||||
|
||||
: %move ( dst src -- )
|
||||
2dup [ move-spec ] 2apply 2array {
|
||||
2dup [ move-spec ] bi@ 2array {
|
||||
{ { f f } [ %move-bug ] }
|
||||
{ { f unboxed-c-ptr } [ %move-bug ] }
|
||||
{ { f unboxed-byte-array } [ %move-bug ] }
|
||||
|
|
@ -318,7 +318,7 @@ M: phantom-stack cut-phantom
|
|||
|
||||
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
|
||||
|
||||
: each-phantom ( quot -- ) phantoms rot 2apply ; inline
|
||||
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
|
||||
|
||||
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
|
||||
|
||||
|
|
@ -442,7 +442,7 @@ M: loc lazy-store
|
|||
: fast-shuffle? ( live-locs -- ? )
|
||||
#! Test if we have enough free registers to load all
|
||||
#! shuffle inputs at once.
|
||||
T{ int-regs } free-vregs [ length ] 2apply <= ;
|
||||
T{ int-regs } free-vregs [ length ] bi@ <= ;
|
||||
|
||||
: finalize-locs ( -- )
|
||||
#! Perform any deferred stack shuffling.
|
||||
|
|
@ -488,7 +488,7 @@ M: loc lazy-store
|
|||
|
||||
: phantom&spec ( phantom spec -- phantom' spec' )
|
||||
[ length f pad-left ] keep
|
||||
[ <reversed> ] 2apply ; inline
|
||||
[ <reversed> ] bi@ ; inline
|
||||
|
||||
: phantom&spec-agree? ( phantom spec quot -- ? )
|
||||
>r phantom&spec r> 2all? ; inline
|
||||
|
|
@ -520,7 +520,7 @@ M: loc lazy-store
|
|||
swap lazy-load ;
|
||||
|
||||
: output-vregs ( -- seq seq )
|
||||
+output+ +clobber+ [ get [ get ] map ] 2apply ;
|
||||
+output+ +clobber+ [ get [ get ] map ] bi@ ;
|
||||
|
||||
: clash? ( seq -- ? )
|
||||
phantoms append [
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ M: object funny drop 0 ;
|
|||
[ 2 ] [ [ { } ] funny ] unit-test
|
||||
[ 0 ] [ { } funny ] unit-test
|
||||
|
||||
PREDICATE: funnies very-funny number? ;
|
||||
PREDICATE: very-funny < funnies number? ;
|
||||
|
||||
GENERIC: gooey ( x -- y )
|
||||
M: very-funny gooey sq ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,8 @@ M: object perform-combination
|
|||
|
||||
GENERIC: make-default-method ( generic combination -- method )
|
||||
|
||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||
PREDICATE: generic < word
|
||||
"combination" word-prop >boolean ;
|
||||
|
||||
M: generic definition drop f ;
|
||||
|
||||
|
|
@ -30,7 +31,7 @@ M: generic definition drop f ;
|
|||
: method ( class generic -- method/f )
|
||||
"methods" word-prop at ;
|
||||
|
||||
PREDICATE: pair method-spec
|
||||
PREDICATE: method-spec < pair
|
||||
first2 generic? swap class? and ;
|
||||
|
||||
: order ( generic -- seq )
|
||||
|
|
@ -55,7 +56,7 @@ TUPLE: check-method class generic ;
|
|||
: method-word-name ( class word -- string )
|
||||
word-name "/" rot word-name 3append ;
|
||||
|
||||
PREDICATE: word method-body
|
||||
PREDICATE: method-body < word
|
||||
"method-generic" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
|
|
@ -156,7 +157,7 @@ M: assoc update-methods ( assoc -- )
|
|||
|
||||
M: generic subwords
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add ;
|
||||
swap "default-method" word-prop suffix ;
|
||||
|
||||
M: generic forget-word
|
||||
dup subwords [ forget ] each (forget-word) ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ math namespaces sequences words quotations layouts combinators
|
|||
sequences.private classes classes.algebra definitions ;
|
||||
IN: generic.math
|
||||
|
||||
PREDICATE: class math-class ( object -- ? )
|
||||
PREDICATE: math-class < class
|
||||
dup null bootstrap-word eq? [
|
||||
drop f
|
||||
] [
|
||||
|
|
@ -79,7 +79,7 @@ M: math-combination perform-combination
|
|||
] if nip
|
||||
] math-vtable nip ;
|
||||
|
||||
PREDICATE: generic math-generic ( word -- ? )
|
||||
PREDICATE: math-generic < generic ( word -- ? )
|
||||
"combination" word-prop math-combination? ;
|
||||
|
||||
M: math-generic definer drop \ MATH: f ;
|
||||
|
|
|
|||
|
|
@ -34,8 +34,8 @@ ERROR: no-method object generic ;
|
|||
: empty-method ( word -- quot )
|
||||
[
|
||||
picker % [ delegate dup ] %
|
||||
unpicker over add ,
|
||||
error-method \ drop add* , \ if ,
|
||||
unpicker over suffix ,
|
||||
error-method \ drop prefix , \ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: class-predicates ( assoc -- assoc )
|
||||
|
|
@ -137,7 +137,7 @@ ERROR: no-method object generic ;
|
|||
] if ;
|
||||
|
||||
: standard-methods ( word -- alist )
|
||||
dup methods swap default-method add*
|
||||
dup methods swap default-method prefix
|
||||
[ 1quotation ] assoc-map ;
|
||||
|
||||
M: standard-combination make-default-method
|
||||
|
|
@ -174,13 +174,13 @@ M: hook-combination perform-combination
|
|||
: define-simple-generic ( word -- )
|
||||
T{ standard-combination f 0 } define-generic ;
|
||||
|
||||
PREDICATE: generic standard-generic
|
||||
PREDICATE: standard-generic < generic
|
||||
"combination" word-prop standard-combination? ;
|
||||
|
||||
PREDICATE: standard-generic simple-generic
|
||||
PREDICATE: simple-generic < standard-generic
|
||||
"combination" word-prop standard-combination-# zero? ;
|
||||
|
||||
PREDICATE: generic hook-generic
|
||||
PREDICATE: hook-generic < generic
|
||||
"combination" word-prop hook-combination? ;
|
||||
|
||||
GENERIC: dispatch# ( word -- n )
|
||||
|
|
|
|||
|
|
@ -32,14 +32,28 @@ $nl
|
|||
{ $code "H{ } clone" }
|
||||
"To convert an assoc to a hashtable:"
|
||||
{ $subsection >hashtable }
|
||||
"Further topics:"
|
||||
{ $subsection "hashtables.keys" }
|
||||
{ $subsection "hashtables.utilities" }
|
||||
{ $subsection "hashtables.private" } ;
|
||||
|
||||
ARTICLE: "hashtables.keys" "Hashtable keys"
|
||||
"Hashtables rely on the " { $link hashcode } " word to rapidly locate values associated with keys. The objects used as keys in a hashtable must obey certain restrictions."
|
||||
$nl
|
||||
"The " { $link hashcode } " of a key is a function of the its slot values, and if the hashcode changes then the hashtable will be left in an inconsistent state. The easiest way to avoid this problem is to never mutate objects used as hashtable keys."
|
||||
$nl
|
||||
"In certain advanced applications, this cannot be avoided and the best design involves mutating hashtable keys. In this case, a custom " { $link hashcode* } " method must be defined which only depends on immutable slots."
|
||||
$nl
|
||||
"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words." ;
|
||||
|
||||
ARTICLE: "hashtables.utilities" "Hashtable utilities"
|
||||
"Utility words to create a new hashtable from a single key/value pair:"
|
||||
{ $subsection associate }
|
||||
{ $subsection ?set-at }
|
||||
"The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:"
|
||||
{ $subsection prune }
|
||||
"Test if a sequence contains duplicates in linear time:"
|
||||
{ $subsection all-unique? }
|
||||
{ $subsection "hashtables.private" } ;
|
||||
{ $subsection all-unique? } ;
|
||||
|
||||
ABOUT: "hashtables"
|
||||
|
||||
|
|
|
|||
|
|
@ -18,14 +18,9 @@ IN: hashtables
|
|||
: (key@) ( key keys i -- array n ? )
|
||||
3dup swap array-nth
|
||||
dup ((empty)) eq?
|
||||
[ 3drop nip f f ]
|
||||
[
|
||||
=
|
||||
[ rot drop t ]
|
||||
[ probe (key@) ]
|
||||
if
|
||||
]
|
||||
if ; inline
|
||||
[ 3drop nip f f ] [
|
||||
= [ rot drop t ] [ probe (key@) ] if
|
||||
] if ; inline
|
||||
|
||||
: key@ ( key hash -- array n ? )
|
||||
hash-array 2dup hash@ (key@) ; inline
|
||||
|
|
@ -89,17 +84,18 @@ IN: hashtables
|
|||
] if
|
||||
] if ; inline
|
||||
|
||||
: find-pair ( array quot -- key value ? ) 0 rot (find-pair) ; inline
|
||||
: find-pair ( array quot -- key value ? )
|
||||
0 rot (find-pair) ; inline
|
||||
|
||||
: (rehash) ( hash array -- )
|
||||
[ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
|
||||
|
||||
: hash-large? ( hash -- ? )
|
||||
dup hash-count 3 fixnum*fast
|
||||
swap hash-array array-capacity > ;
|
||||
[ hash-count 3 fixnum*fast ]
|
||||
[ hash-array array-capacity ] bi > ;
|
||||
|
||||
: hash-stale? ( hash -- ? )
|
||||
dup hash-deleted 10 fixnum*fast swap hash-count fixnum> ;
|
||||
[ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
|
||||
|
||||
: grow-hash ( hash -- )
|
||||
[ dup hash-array swap assoc-size 1+ ] keep
|
||||
|
|
@ -160,7 +156,7 @@ M: hashtable clone
|
|||
|
||||
M: hashtable equal?
|
||||
over hashtable? [
|
||||
2dup [ assoc-size ] 2apply number=
|
||||
2dup [ assoc-size ] bi@ number=
|
||||
[ assoc= ] [ 2drop f ] if
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
|
|
@ -183,10 +179,13 @@ M: hashtable assoc-like
|
|||
[ 3drop ] [ dupd dupd set-at swap push ] if ; inline
|
||||
|
||||
: prune ( seq -- newseq )
|
||||
dup length <hashtable> over length <vector>
|
||||
rot [ >r 2dup r> (prune) ] each nip ;
|
||||
[ length <hashtable> ]
|
||||
[ length <vector> ]
|
||||
[ ] tri
|
||||
[ >r 2dup r> (prune) ] each nip ;
|
||||
|
||||
: all-unique? ( seq -- ? )
|
||||
dup prune [ length ] 2apply = ;
|
||||
[ length ]
|
||||
[ prune length ] bi = ;
|
||||
|
||||
INSTANCE: hashtable assoc
|
||||
|
|
|
|||
|
|
@ -66,8 +66,8 @@ IN: heaps.tests
|
|||
dup heap-data clone swap
|
||||
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
|
||||
heap-data
|
||||
[ [ entry-key ] map ] 2apply
|
||||
[ natural-sort ] 2apply ;
|
||||
[ [ entry-key ] map ] bi@
|
||||
[ natural-sort ] bi@ ;
|
||||
|
||||
11 [
|
||||
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences arrays assocs sequences.private
|
||||
growable ;
|
||||
growable accessors ;
|
||||
IN: heaps
|
||||
|
||||
MIXIN: priority-queue
|
||||
|
|
@ -161,7 +161,7 @@ M: priority-queue heap-push* ( value key heap -- entry )
|
|||
[ swapd heap-push ] curry assoc-each ;
|
||||
|
||||
: >entry< ( entry -- key value )
|
||||
{ entry-value entry-key } get-slots ;
|
||||
[ value>> ] [ key>> ] bi ;
|
||||
|
||||
M: priority-queue heap-peek ( heap -- value key )
|
||||
data-first >entry< ;
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ M: wrapper apply-object
|
|||
r> recursive-state set ;
|
||||
|
||||
: infer-quot-recursive ( quot word label -- )
|
||||
recursive-state get -rot 2array add* infer-quot ;
|
||||
recursive-state get -rot 2array prefix infer-quot ;
|
||||
|
||||
: time-bomb ( error -- )
|
||||
[ throw ] curry recursive-state get infer-quot ;
|
||||
|
|
@ -109,7 +109,7 @@ TUPLE: recursive-quotation-error quot ;
|
|||
dup value-literal callable? [
|
||||
dup value-literal
|
||||
over value-recursion
|
||||
rot f 2array add* infer-quot
|
||||
rot f 2array prefix infer-quot
|
||||
] [
|
||||
drop bad-call
|
||||
] if
|
||||
|
|
@ -430,7 +430,7 @@ M: #call-label collect-recursion*
|
|||
[ [ swap collect-recursion* ] curry each-node ] { } make ;
|
||||
|
||||
: join-values ( node -- )
|
||||
collect-recursion [ node-in-d ] map meta-d get add
|
||||
collect-recursion [ node-in-d ] map meta-d get suffix
|
||||
unify-lengths unify-stacks
|
||||
meta-d [ length tail* ] change ;
|
||||
|
||||
|
|
|
|||
|
|
@ -26,8 +26,8 @@ C: <literal-constraint> literal-constraint
|
|||
M: literal-constraint equal?
|
||||
over literal-constraint? [
|
||||
2dup
|
||||
[ literal-constraint-literal ] 2apply eql? >r
|
||||
[ literal-constraint-value ] 2apply = r> and
|
||||
[ literal-constraint-literal ] bi@ eql? >r
|
||||
[ literal-constraint-value ] bi@ = r> and
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
|
@ -289,7 +289,7 @@ M: #label infer-classes-around ( #label -- )
|
|||
dup annotate-node
|
||||
dup infer-classes-before
|
||||
dup infer-children
|
||||
dup collect-recursion over add
|
||||
dup collect-recursion over suffix
|
||||
pick annotate-entry
|
||||
node-child (infer-classes) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ TUPLE: #label word loop? ;
|
|||
: #label ( word label -- node )
|
||||
\ #label param-node [ set-#label-word ] keep ;
|
||||
|
||||
PREDICATE: #label #loop #label-loop? ;
|
||||
PREDICATE: #loop < #label #label-loop? ;
|
||||
|
||||
TUPLE: #entry ;
|
||||
|
||||
|
|
@ -205,7 +205,7 @@ UNION: #branch #if #dispatch ;
|
|||
2dup 2slip rot [
|
||||
2drop t
|
||||
] [
|
||||
>r dup node-children swap node-successor add r>
|
||||
>r dup node-children swap node-successor suffix r>
|
||||
[ node-exists? ] curry contains?
|
||||
] if
|
||||
] [
|
||||
|
|
@ -309,9 +309,9 @@ SYMBOL: node-stack
|
|||
|
||||
DEFER: #tail?
|
||||
|
||||
PREDICATE: #merge #tail-merge node-successor #tail? ;
|
||||
PREDICATE: #tail-merge < #merge node-successor #tail? ;
|
||||
|
||||
PREDICATE: #values #tail-values node-successor #tail? ;
|
||||
PREDICATE: #tail-values < #values node-successor #tail? ;
|
||||
|
||||
UNION: #tail
|
||||
POSTPONE: f #return #tail-values #tail-merge #terminate ;
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@ inference.dataflow kernel classes kernel.private math
|
|||
math.parser math.private namespaces namespaces.private parser
|
||||
sequences strings vectors words quotations effects tools.test
|
||||
continuations generic.standard sorting assocs definitions
|
||||
prettyprint io inspector tuples classes.union classes.predicate
|
||||
debugger threads.private io.streams.string io.timeouts
|
||||
io.thread sequences.private ;
|
||||
prettyprint io inspector classes.tuple classes.union
|
||||
classes.predicate debugger threads.private io.streams.string
|
||||
io.timeouts io.thread sequences.private ;
|
||||
IN: inference.tests
|
||||
|
||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||
|
|
@ -224,7 +224,7 @@ DEFER: do-crap*
|
|||
MATH: xyz
|
||||
M: fixnum xyz 2array ;
|
||||
M: float xyz
|
||||
[ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
|
||||
[ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
|
||||
|
||||
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@ kernel.private math math.private memory namespaces
|
|||
namespaces.private parser prettyprint quotations
|
||||
quotations.private sbufs sbufs.private sequences
|
||||
sequences.private slots.private strings strings.private system
|
||||
threads.private tuples tuples.private vectors vectors.private
|
||||
words words.private assocs inspector compiler.units
|
||||
system.private ;
|
||||
threads.private classes.tuple classes.tuple.private vectors
|
||||
vectors.private words words.private assocs inspector
|
||||
compiler.units system.private ;
|
||||
IN: inference.known-words
|
||||
|
||||
! Shuffle words
|
||||
|
|
@ -135,7 +135,7 @@ M: object infer-call
|
|||
! Variadic tuple constructor
|
||||
\ <tuple-boa> [
|
||||
\ <tuple-boa>
|
||||
peek-d value-literal { tuple } <effect>
|
||||
peek-d value-literal layout-size { tuple } <effect>
|
||||
make-call-node
|
||||
] "infer" set-word-prop
|
||||
|
||||
|
|
@ -565,14 +565,11 @@ set-primitive-effect
|
|||
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
|
||||
\ quotation-xt make-flushable
|
||||
|
||||
\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
|
||||
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
|
||||
\ <tuple> make-flushable
|
||||
|
||||
\ (>tuple) { array } { tuple } <effect> set-primitive-effect
|
||||
\ (>tuple) make-flushable
|
||||
|
||||
\ tuple>array { tuple } { array } <effect> set-primitive-effect
|
||||
\ tuple>array make-flushable
|
||||
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
|
||||
\ <tuple-layout> make-foldable
|
||||
|
||||
\ datastack { } { array } <effect> set-primitive-effect
|
||||
\ datastack make-flushable
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: inference.transforms.tests
|
||||
USING: sequences inference.transforms tools.test math kernel
|
||||
quotations inference ;
|
||||
quotations inference accessors combinators words arrays ;
|
||||
|
||||
: compose-n-quot <repetition> >quotation ;
|
||||
: compose-n compose-n-quot call ;
|
||||
|
|
@ -32,3 +32,27 @@ TUPLE: a-tuple x y z ;
|
|||
{ set-a-tuple-x set-a-tuple-x } set-slots ;
|
||||
|
||||
[ [ set-slots-test-2 ] infer ] must-fail
|
||||
|
||||
TUPLE: color r g b ;
|
||||
|
||||
C: <color> color
|
||||
|
||||
: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ;
|
||||
|
||||
{ 1 3 } [ cleave-test ] must-infer-as
|
||||
|
||||
[ 1 2 3 ] [ 1 2 3 <color> cleave-test ] unit-test
|
||||
|
||||
[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test word-def call ] unit-test
|
||||
|
||||
: 2cleave-test { [ 2array ] [ + ] [ - ] } 2cleave ;
|
||||
|
||||
[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
|
||||
|
||||
[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
|
||||
|
||||
: spread-test { [ sq ] [ neg ] [ recip ] } spread ;
|
||||
|
||||
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
|
||||
|
||||
[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel words sequences generic math namespaces
|
||||
quotations assocs combinators math.bitfields inference.backend
|
||||
inference.dataflow inference.state tuples.private effects
|
||||
inference.dataflow inference.state classes.tuple.private effects
|
||||
inspector hashtables ;
|
||||
IN: inference.transforms
|
||||
|
||||
|
|
@ -39,6 +39,12 @@ IN: inference.transforms
|
|||
] if
|
||||
] 1 define-transform
|
||||
|
||||
\ cleave [ cleave>quot ] 1 define-transform
|
||||
|
||||
\ 2cleave [ 2cleave>quot ] 1 define-transform
|
||||
|
||||
\ spread [ spread>quot ] 1 define-transform
|
||||
|
||||
! Bitfields
|
||||
GENERIC: (bitfield-quot) ( spec -- quot )
|
||||
|
||||
|
|
@ -50,7 +56,7 @@ M: pair (bitfield-quot) ( spec -- quot )
|
|||
[ shift bitor ] append 2curry ;
|
||||
|
||||
: bitfield-quot ( spec -- quot )
|
||||
[ (bitfield-quot) ] map [ 0 ] add* concat ;
|
||||
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
|
||||
|
||||
\ bitfield [ bitfield-quot ] 1 define-transform
|
||||
|
||||
|
|
@ -76,7 +82,7 @@ M: duplicated-slots-error summary
|
|||
|
||||
\ construct-boa [
|
||||
dup +inlined+ depends-on
|
||||
dup tuple-size [ <tuple-boa> ] 2curry
|
||||
tuple-layout [ <tuple-boa> ] curry
|
||||
] 1 define-transform
|
||||
|
||||
\ construct-empty [
|
||||
|
|
@ -84,7 +90,7 @@ M: duplicated-slots-error summary
|
|||
peek-d value? [
|
||||
pop-literal
|
||||
dup +inlined+ depends-on
|
||||
dup tuple-size [ <tuple> ] 2curry
|
||||
tuple-layout [ <tuple> ] curry
|
||||
swap infer-quot
|
||||
] [
|
||||
\ construct-empty 1 1 <effect> make-call-node
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: init kernel system namespaces io io.encodings io.encodings.utf8 ;
|
||||
USING: init kernel system namespaces io io.encodings
|
||||
io.encodings.utf8 init assocs ;
|
||||
IN: io.backend
|
||||
|
||||
SYMBOL: io-backend
|
||||
|
|
@ -17,14 +18,13 @@ HOOK: io-multiplex io-backend ( ms -- )
|
|||
|
||||
HOOK: normalize-directory io-backend ( str -- newstr )
|
||||
|
||||
M: object normalize-directory ;
|
||||
|
||||
HOOK: normalize-pathname io-backend ( str -- newstr )
|
||||
|
||||
M: object normalize-pathname ;
|
||||
M: object normalize-directory normalize-pathname ;
|
||||
|
||||
: set-io-backend ( io-backend -- )
|
||||
io-backend set-global init-io init-stdio ;
|
||||
io-backend set-global init-io init-stdio
|
||||
"io.files" init-hooks get at call ;
|
||||
|
||||
[ init-io embedded? [ init-stdio ] unless ]
|
||||
"io.backend" add-init-hook
|
||||
|
|
|
|||
|
|
@ -2,4 +2,7 @@ USING: help.syntax help.markup ;
|
|||
IN: io.encodings.binary
|
||||
|
||||
HELP: binary
|
||||
{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ;
|
||||
{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
ABOUT: binary
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: io.encodings
|
||||
|
||||
ABOUT: "encodings"
|
||||
ABOUT: "io.encodings"
|
||||
|
||||
ARTICLE: "io.encodings" "I/O encodings"
|
||||
"Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream."
|
||||
"Bytes can't be understood in isolation as text. They must be interpreted under a certain encoding. Factor provides utilities for dealing with encoded text by declaring that a stream has a particular encoding, and utilities to encode and decode strings."
|
||||
{ $subsection "encodings-constructors" }
|
||||
{ $subsection "encodings-descriptors" }
|
||||
{ $subsection "encodings-protocol" } ;
|
||||
|
||||
ARTICLE: "encodings-constructors" "Constructing an encoded stream"
|
||||
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
|
||||
"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
|
||||
{ $subsection <encoder> }
|
||||
{ $subsection <decoder> }
|
||||
{ $subsection <encoder-duplex> } ;
|
||||
|
|
@ -18,48 +19,56 @@ HELP: <encoder>
|
|||
{ $values { "stream" "an output stream" }
|
||||
{ "encoding" "an encoding descriptor" }
|
||||
{ "newstream" "an encoded output stream" } }
|
||||
{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
|
||||
{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: <decoder>
|
||||
{ $values { "stream" "an input stream" }
|
||||
{ "encoding" "an encoding descriptor" }
|
||||
{ "newstream" "an encoded output stream" } }
|
||||
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
|
||||
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: <encoder-duplex>
|
||||
{ $values { "stream-in" "an input stream" }
|
||||
{ "stream-out" "an output stream" }
|
||||
{ "encoding" "an encoding descriptor" }
|
||||
{ "duplex" "an encoded duplex stream" } }
|
||||
{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ;
|
||||
{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." }
|
||||
$low-level-note ;
|
||||
|
||||
{ <encoder> <decoder> <encoder-duplex> } related-words
|
||||
|
||||
ARTICLE: "encodings-descriptors" "Encoding descriptors"
|
||||
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
|
||||
{ $vocab-subsection "io.encodings.utf8" }
|
||||
{ $vocab-subsection "io.encodings.ascii" }
|
||||
{ $vocab-subsection "io.encodings.8-bit" }
|
||||
{ $vocab-subsection "io.encodings.binary" }
|
||||
{ $vocab-subsection "io.encodings.utf16" } ;
|
||||
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
|
||||
{ $vocab-subsection "Binary" "io.encodings.binary" }
|
||||
{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
|
||||
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
|
||||
{ $vocab-subsection "UTF-8" "io.encodings.utf8" }
|
||||
{ $vocab-subsection "UTF-16" "io.encodings.utf16" }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
ARTICLE: "encodings-protocol" "Encoding protocol"
|
||||
"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
|
||||
"There are two parts to implementing a new encoding. First, methods for creating an encoded or decoded stream must be provided. These have defaults, however, which wrap a stream in an encoder or decoder wrapper with the given encoding descriptor."
|
||||
{ $subsection <encoder> }
|
||||
{ $subsection <decoder> }
|
||||
"If an encoding might be contained in the code slot of an encoder or decoder tuple, then the following methods must be implemented to read or write one code point from a stream:"
|
||||
{ $subsection decode-char }
|
||||
{ $subsection encode-char }
|
||||
"The following methods are optional:"
|
||||
{ $subsection <encoder> }
|
||||
{ $subsection <decoder> } ;
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
HELP: decode-char
|
||||
{ $values { "stream" "an underlying input stream" }
|
||||
{ "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
|
||||
{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
|
||||
{ $contract "Reads a single code point from the underlying stream, interpreting it by the encoding." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: encode-char
|
||||
{ $values { "char" "a character" }
|
||||
{ "stream" "an underlying output stream" }
|
||||
{ "encoding" "an encoding descriptor" } }
|
||||
{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
|
||||
{ $contract "Writes the code point in the encoding to the underlying stream given." }
|
||||
$low-level-note ;
|
||||
|
||||
{ encode-char decode-char } related-words
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: io.streams.encodings.tests
|
|||
resource-path ascii <file-reader> ;
|
||||
|
||||
[ { } ]
|
||||
[ "/core/io/test/empty-file.txt" <resource-reader> lines ]
|
||||
[ "core/io/test/empty-file.txt" <resource-reader> lines ]
|
||||
unit-test
|
||||
|
||||
: lines-test ( stream -- line1 line2 )
|
||||
|
|
@ -16,21 +16,21 @@ unit-test
|
|||
"This is a line."
|
||||
"This is another line."
|
||||
] [
|
||||
"/core/io/test/windows-eol.txt" <resource-reader> lines-test
|
||||
"core/io/test/windows-eol.txt" <resource-reader> lines-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"This is a line."
|
||||
"This is another line."
|
||||
] [
|
||||
"/core/io/test/mac-os-eol.txt" <resource-reader> lines-test
|
||||
"core/io/test/mac-os-eol.txt" <resource-reader> lines-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"This is a line."
|
||||
"This is another line."
|
||||
] [
|
||||
"/core/io/test/unix-eol.txt" <resource-reader> lines-test
|
||||
"core/io/test/unix-eol.txt" <resource-reader> lines-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors namespaces
|
||||
growable strings io classes continuations combinators
|
||||
io.styles io.streams.plain splitting
|
||||
io.streams.duplex byte-arrays sequences.private ;
|
||||
USING: math kernel sequences sbufs vectors namespaces growable
|
||||
strings io classes continuations combinators io.styles
|
||||
io.streams.plain splitting io.streams.duplex byte-arrays
|
||||
sequences.private accessors ;
|
||||
IN: io.encodings
|
||||
|
||||
! The encoding descriptor protocol
|
||||
|
|
@ -34,7 +34,7 @@ M: tuple-class <decoder> construct-empty <decoder> ;
|
|||
M: tuple <decoder> f decoder construct-boa ;
|
||||
|
||||
: >decoder< ( decoder -- stream encoding )
|
||||
{ decoder-stream decoder-code } get-slots ;
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
|
||||
: cr+ t swap set-decoder-cr ; inline
|
||||
|
||||
|
|
@ -59,7 +59,7 @@ M: tuple <decoder> f decoder construct-boa ;
|
|||
over decoder-cr [
|
||||
over cr-
|
||||
"\n" ?head [
|
||||
over stream-read1 [ add ] when*
|
||||
over stream-read1 [ suffix ] when*
|
||||
] when
|
||||
] when nip ;
|
||||
|
||||
|
|
@ -108,7 +108,7 @@ M: tuple-class <encoder> construct-empty <encoder> ;
|
|||
M: tuple <encoder> encoder construct-boa ;
|
||||
|
||||
: >encoder< ( encoder -- stream encoding )
|
||||
{ encoder-stream encoder-code } get-slots ;
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
|
||||
M: encoder stream-write1
|
||||
>encoder< encode-char ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,8 @@
|
|||
USING: help.markup help.syntax io.encodings strings io.files ;
|
||||
USING: help.markup help.syntax ;
|
||||
IN: io.encodings.utf8
|
||||
|
||||
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
|
||||
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences. The encoding descriptor for UTF-8:"
|
||||
{ $subsection utf8 } ;
|
||||
|
||||
HELP: utf8
|
||||
{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. This conforms to the " { $link "encodings-protocol" } "." } ;
|
||||
{ $class-description "This is the encoding descriptor for a UTF-8 encoding. UTF-8 is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
ABOUT: "io.encodings.utf8"
|
||||
ABOUT: utf8
|
||||
|
|
|
|||
|
|
@ -20,9 +20,6 @@ ARTICLE: "pathnames" "Pathname manipulation"
|
|||
{ $subsection file-name }
|
||||
{ $subsection last-path-separator }
|
||||
{ $subsection append-path }
|
||||
"Pathnames relative to Factor's install directory:"
|
||||
{ $subsection resource-path }
|
||||
{ $subsection ?resource-path }
|
||||
"Pathnames relative to Factor's temporary files directory:"
|
||||
{ $subsection temp-directory }
|
||||
{ $subsection temp-file }
|
||||
|
|
@ -248,12 +245,6 @@ HELP: resource-path
|
|||
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
|
||||
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
|
||||
|
||||
HELP: ?resource-path
|
||||
{ $values { "path" "a pathname string" } { "newpath" "a string" } }
|
||||
{ $description "If the path is prefixed with " { $snippet "\"resource:\"" } ", prepends the resource path." } ;
|
||||
|
||||
{ resource-path ?resource-path } related-words
|
||||
|
||||
HELP: pathname
|
||||
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,66 @@
|
|||
IN: io.files.tests
|
||||
USING: tools.test io.files io threads kernel continuations io.encodings.ascii
|
||||
io.files.unique sequences strings accessors ;
|
||||
USING: tools.test io.files io threads kernel continuations
|
||||
io.encodings.ascii io.files.unique sequences strings accessors
|
||||
io.encodings.utf8 ;
|
||||
|
||||
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
|
||||
[ ] [ "blahblah" temp-file make-directory ] unit-test
|
||||
[ t ] [ "blahblah" temp-file directory? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ temp-directory "loldir" append-path delete-directory ] ignore-errors
|
||||
temp-directory [
|
||||
"loldir" make-directory
|
||||
] with-directory
|
||||
temp-directory "loldir" append-path exists?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ temp-directory "loldir" append-path delete-directory ] ignore-errors
|
||||
temp-directory [
|
||||
"loldir" make-directory
|
||||
"loldir" delete-directory
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
[ "file1 contents" ] [
|
||||
[ temp-directory "loldir" append-path delete-directory ] ignore-errors
|
||||
temp-directory [
|
||||
"file1 contents" "file1" utf8 set-file-contents
|
||||
"file1" "file2" copy-file
|
||||
"file2" utf8 file-contents
|
||||
] with-directory
|
||||
"file1" temp-file delete-file
|
||||
"file2" temp-file delete-file
|
||||
] unit-test
|
||||
|
||||
[ "file3 contents" ] [
|
||||
temp-directory [
|
||||
"file3 contents" "file3" utf8 set-file-contents
|
||||
"file3" "file4" move-file
|
||||
"file4" utf8 file-contents
|
||||
] with-directory
|
||||
"file4" temp-file delete-file
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
temp-directory [
|
||||
"file5" touch-file
|
||||
"file5" delete-file
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
temp-directory [
|
||||
"file6" touch-file
|
||||
"file6" link-info drop
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
|
||||
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
|
||||
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
|
||||
[ "" ] [ "" file-name ] unit-test
|
||||
|
||||
[ ] [
|
||||
{ "Hello world." }
|
||||
|
|
@ -65,7 +117,7 @@ io.files.unique sequences strings accessors ;
|
|||
|
||||
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
|
||||
[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] bi@ move-file ] unit-test
|
||||
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
|
||||
|
|
@ -81,6 +133,18 @@ io.files.unique sequences strings accessors ;
|
|||
"delete-tree-test" temp-file delete-tree
|
||||
] unit-test
|
||||
|
||||
[ { { "kernel" t } } ] [
|
||||
"core" resource-path [
|
||||
"." directory [ first "kernel" = ] subset
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
[ { { "kernel" t } } ] [
|
||||
"resource:core" [
|
||||
"." directory [ first "kernel" = ] subset
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test/a/b/c" temp-file make-directories
|
||||
] unit-test
|
||||
|
|
@ -129,6 +193,15 @@ io.files.unique sequences strings accessors ;
|
|||
|
||||
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
|
||||
|
||||
[ t ] [
|
||||
temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
|
||||
temp-directory "test41" append-path utf8 file-contents "hi41" =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
temp-directory [ "test41" file-info size>> ] with-directory 4 =
|
||||
] unit-test
|
||||
|
||||
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
|
||||
|
||||
[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
|
||||
|
|
@ -144,3 +217,51 @@ io.files.unique sequences strings accessors ;
|
|||
] keep file-info size>>
|
||||
] with-unique-file
|
||||
] unit-test
|
||||
|
||||
[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
|
||||
[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
|
||||
[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
|
||||
[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
|
||||
[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
|
||||
[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
|
||||
[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
|
||||
[ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test
|
||||
|
||||
[ "" ] [ "" "." append-path ] unit-test
|
||||
[ "" ".." append-path ] must-fail
|
||||
|
||||
[ "/" ] [ "/" "./." append-path ] unit-test
|
||||
[ "/" ] [ "/" "././" append-path ] unit-test
|
||||
[ "/a/b/lib" ] [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test
|
||||
[ "/a/b/lib/" ] [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test
|
||||
|
||||
[ "" "../lib/" append-path ] must-fail
|
||||
[ "lib" ] [ "" "lib" append-path ] unit-test
|
||||
[ "lib" ] [ "" "./lib" append-path ] unit-test
|
||||
|
||||
[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
|
||||
[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
|
||||
|
||||
[ "foo/bar/." parent-directory ] must-fail
|
||||
[ "foo/bar/./" parent-directory ] must-fail
|
||||
[ "foo/bar/baz/.." parent-directory ] must-fail
|
||||
[ "foo/bar/baz/../" parent-directory ] must-fail
|
||||
|
||||
[ "." parent-directory ] must-fail
|
||||
[ "./" parent-directory ] must-fail
|
||||
[ ".." parent-directory ] must-fail
|
||||
[ "../" parent-directory ] must-fail
|
||||
[ "../../" parent-directory ] must-fail
|
||||
[ "foo/.." parent-directory ] must-fail
|
||||
[ "foo/../" parent-directory ] must-fail
|
||||
[ "" parent-directory ] must-fail
|
||||
[ "." ] [ "boot.x86.64.image" parent-directory ] unit-test
|
||||
|
||||
[ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test
|
||||
[ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test
|
||||
[ "bar/foo" ] [ "bar/baz" "./..//foo" append-path ] unit-test
|
||||
[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
|
||||
|
||||
[ t ] [ "resource:core" absolute-path? ] unit-test
|
||||
[ t ] [ "/foo" absolute-path? ] unit-test
|
||||
[ f ] [ "" absolute-path? ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: io.backend io.files.private io hashtables kernel math
|
||||
memory namespaces sequences strings assocs arrays definitions
|
||||
system combinators splitting sbufs continuations io.encodings
|
||||
io.encodings.binary ;
|
||||
io.encodings.binary init accessors ;
|
||||
IN: io.files
|
||||
|
||||
HOOK: (file-reader) io-backend ( path -- stream )
|
||||
|
|
@ -13,66 +13,149 @@ HOOK: (file-writer) io-backend ( path -- stream )
|
|||
HOOK: (file-appender) io-backend ( path -- stream )
|
||||
|
||||
: <file-reader> ( path encoding -- stream )
|
||||
swap (file-reader) swap <decoder> ;
|
||||
swap normalize-pathname (file-reader) swap <decoder> ;
|
||||
|
||||
: <file-writer> ( path encoding -- stream )
|
||||
swap (file-writer) swap <encoder> ;
|
||||
swap normalize-pathname (file-writer) swap <encoder> ;
|
||||
|
||||
: <file-appender> ( path encoding -- stream )
|
||||
swap (file-appender) swap <encoder> ;
|
||||
swap normalize-pathname (file-appender) swap <encoder> ;
|
||||
|
||||
HOOK: rename-file io-backend ( from to -- )
|
||||
: file-lines ( path encoding -- seq )
|
||||
<file-reader> lines ;
|
||||
|
||||
: with-file-reader ( path encoding quot -- )
|
||||
>r <file-reader> r> with-stream ; inline
|
||||
|
||||
: file-contents ( path encoding -- str )
|
||||
<file-reader> contents ;
|
||||
|
||||
: with-file-writer ( path encoding quot -- )
|
||||
>r <file-writer> r> with-stream ; inline
|
||||
|
||||
: set-file-lines ( seq path encoding -- )
|
||||
[ [ print ] each ] with-file-writer ;
|
||||
|
||||
: set-file-contents ( str path encoding -- )
|
||||
[ write ] with-file-writer ;
|
||||
|
||||
: with-file-appender ( path encoding quot -- )
|
||||
>r <file-appender> r> with-stream ; inline
|
||||
|
||||
! Pathnames
|
||||
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
|
||||
|
||||
: path-separator ( -- string ) windows? "\\" "/" ? ;
|
||||
|
||||
: right-trim-separators ( str -- newstr )
|
||||
[ path-separator? ] right-trim ;
|
||||
|
||||
: left-trim-separators ( str -- newstr )
|
||||
[ path-separator? ] left-trim ;
|
||||
|
||||
: append-path ( str1 str2 -- str )
|
||||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append ;
|
||||
|
||||
: prepend-path ( str1 str2 -- str )
|
||||
swap append-path ; inline
|
||||
|
||||
: last-path-separator ( path -- n ? )
|
||||
[ length 1- ] keep [ path-separator? ] find-last* ;
|
||||
|
||||
HOOK: root-directory? io-backend ( path -- ? )
|
||||
|
||||
M: object root-directory? ( path -- ? ) path-separator? ;
|
||||
|
||||
: special-directory? ( name -- ? ) { "." ".." } member? ;
|
||||
M: object root-directory? ( path -- ? )
|
||||
dup empty? [ drop f ] [ [ path-separator? ] all? ] if ;
|
||||
|
||||
ERROR: no-parent-directory path ;
|
||||
|
||||
: parent-directory ( path -- parent )
|
||||
right-trim-separators {
|
||||
{ [ dup empty? ] [ drop "/" ] }
|
||||
{ [ dup root-directory? ] [ ] }
|
||||
{ [ dup [ path-separator? ] contains? not ] [ drop "." ] }
|
||||
dup root-directory? [
|
||||
right-trim-separators
|
||||
dup last-path-separator [
|
||||
1+ cut
|
||||
] [
|
||||
drop "." swap
|
||||
] if
|
||||
{ "" "." ".." } member? [
|
||||
no-parent-directory
|
||||
] when
|
||||
] unless ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: head-path-separator? ( path1 ? -- ?' )
|
||||
[
|
||||
dup empty? [ drop t ] [ first path-separator? ] if
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: head.? ( path -- ? ) "." ?head head-path-separator? ;
|
||||
|
||||
: head..? ( path -- ? ) ".." ?head head-path-separator? ;
|
||||
|
||||
: append-path-empty ( path1 path2 -- path' )
|
||||
{
|
||||
{ [ dup head.? ] [
|
||||
1 tail left-trim-separators append-path-empty
|
||||
] }
|
||||
{ [ dup head..? ] [ drop no-parent-directory ] }
|
||||
{ [ t ] [ nip ] }
|
||||
} cond ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: windows-absolute-path? ( path -- path ? )
|
||||
{
|
||||
{ [ dup length 2 < ] [ f ] }
|
||||
{ [ dup second CHAR: : = ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond ;
|
||||
|
||||
: absolute-path? ( path -- ? )
|
||||
{
|
||||
{ [ dup empty? ] [ f ] }
|
||||
{ [ dup "resource:" head? ] [ t ] }
|
||||
{ [ dup first path-separator? ] [ t ] }
|
||||
{ [ windows? ] [ windows-absolute-path? ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
||||
: append-path ( str1 str2 -- str )
|
||||
{
|
||||
{ [ over empty? ] [ append-path-empty ] }
|
||||
{ [ dup empty? ] [ drop ] }
|
||||
{ [ dup absolute-path? ] [ nip ] }
|
||||
{ [ dup head.? ] [ 1 tail left-trim-separators append-path ] }
|
||||
{ [ dup head..? ] [
|
||||
2 tail left-trim-separators
|
||||
>r parent-directory r> append-path
|
||||
] }
|
||||
{ [ t ] [
|
||||
dup last-path-separator drop 1+ cut
|
||||
special-directory? [ no-parent-directory ] when
|
||||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
: file-name ( path -- string )
|
||||
right-trim-separators {
|
||||
{ [ dup empty? ] [ drop "/" ] }
|
||||
{ [ dup last-path-separator ] [ 1+ tail ] }
|
||||
{ [ t ] [ drop ] }
|
||||
} cond ;
|
||||
: prepend-path ( str1 str2 -- str )
|
||||
swap append-path ; inline
|
||||
|
||||
: file-name ( path -- string )
|
||||
dup root-directory? [
|
||||
right-trim-separators
|
||||
dup last-path-separator [ 1+ tail ] [ drop ] if
|
||||
] unless ;
|
||||
|
||||
! File info
|
||||
TUPLE: file-info type size permissions modified ;
|
||||
|
||||
HOOK: file-info io-backend ( path -- info )
|
||||
|
||||
! Symlinks
|
||||
HOOK: link-info io-backend ( path -- info )
|
||||
|
||||
HOOK: make-link io-backend ( path1 path2 -- )
|
||||
|
||||
HOOK: read-link io-backend ( path -- info )
|
||||
|
||||
: copy-link ( path1 path2 -- )
|
||||
>r read-link r> make-link ;
|
||||
|
||||
SYMBOL: +regular-file+
|
||||
SYMBOL: +directory+
|
||||
SYMBOL: +character-device+
|
||||
|
|
@ -94,8 +177,18 @@ HOOK: cd io-backend ( path -- )
|
|||
|
||||
HOOK: cwd io-backend ( -- path )
|
||||
|
||||
SYMBOL: current-directory
|
||||
|
||||
M: object cwd ( -- path ) "." ;
|
||||
|
||||
[ cwd current-directory set-global ] "io.files" add-init-hook
|
||||
|
||||
: with-directory ( path quot -- )
|
||||
cwd [ cd ] curry rot cd [ ] cleanup ; inline
|
||||
>r normalize-pathname r>
|
||||
current-directory swap with-variable ; inline
|
||||
|
||||
: set-current-directory ( path -- )
|
||||
normalize-pathname current-directory set ;
|
||||
|
||||
! Creating directories
|
||||
HOOK: make-directory io-backend ( path -- )
|
||||
|
|
@ -118,7 +211,7 @@ HOOK: make-directory io-backend ( path -- )
|
|||
dup string?
|
||||
[ tuck append-path directory? 2array ] [ nip ] if
|
||||
] with map
|
||||
[ first special-directory? not ] subset ;
|
||||
[ first { "." ".." } member? not ] subset ;
|
||||
|
||||
: directory ( path -- seq )
|
||||
normalize-directory dup (directory) fixup-directory ;
|
||||
|
|
@ -134,14 +227,14 @@ HOOK: delete-file io-backend ( path -- )
|
|||
|
||||
HOOK: delete-directory io-backend ( path -- )
|
||||
|
||||
: (delete-tree) ( path dir? -- )
|
||||
[
|
||||
dup directory* [ (delete-tree) ] assoc-each
|
||||
delete-directory
|
||||
] [ delete-file ] if ;
|
||||
|
||||
: delete-tree ( path -- )
|
||||
dup directory? (delete-tree) ;
|
||||
dup link-info type>> +directory+ = [
|
||||
dup directory over [
|
||||
[ first delete-tree ] each
|
||||
] with-directory delete-directory
|
||||
] [
|
||||
delete-file
|
||||
] if ;
|
||||
|
||||
: to-directory over file-name append-path ;
|
||||
|
||||
|
|
@ -174,13 +267,17 @@ M: object copy-file
|
|||
DEFER: copy-tree-into
|
||||
|
||||
: copy-tree ( from to -- )
|
||||
over directory? [
|
||||
>r dup directory swap r> [
|
||||
>r swap first append-path r> copy-tree-into
|
||||
] 2curry each
|
||||
] [
|
||||
copy-file
|
||||
] if ;
|
||||
normalize-pathname
|
||||
over link-info type>>
|
||||
{
|
||||
{ +symbolic-link+ [ copy-link ] }
|
||||
{ +directory+ [
|
||||
>r dup directory r> rot [
|
||||
[ >r first r> copy-tree-into ] curry each
|
||||
] with-directory
|
||||
] }
|
||||
[ drop copy-file ]
|
||||
} case ;
|
||||
|
||||
: copy-tree-into ( from to -- )
|
||||
to-directory copy-tree ;
|
||||
|
|
@ -193,11 +290,19 @@ DEFER: copy-tree-into
|
|||
"resource-path" get [ image parent-directory ] unless*
|
||||
prepend-path ;
|
||||
|
||||
: ?resource-path ( path -- newpath )
|
||||
"resource:" ?head [ resource-path ] when ;
|
||||
: temp-directory ( -- path )
|
||||
"temp" resource-path dup make-directories ;
|
||||
|
||||
: resource-exists? ( path -- ? )
|
||||
?resource-path exists? ;
|
||||
: temp-file ( name -- path )
|
||||
temp-directory prepend-path ;
|
||||
|
||||
M: object normalize-pathname ( path -- path' )
|
||||
"resource:" ?head [
|
||||
left-trim-separators resource-path
|
||||
normalize-pathname
|
||||
] [
|
||||
current-directory get prepend-path
|
||||
] if ;
|
||||
|
||||
! Pathname presentations
|
||||
TUPLE: pathname string ;
|
||||
|
|
@ -206,35 +311,6 @@ C: <pathname> pathname
|
|||
|
||||
M: pathname <=> [ pathname-string ] compare ;
|
||||
|
||||
: file-lines ( path encoding -- seq )
|
||||
<file-reader> lines ;
|
||||
|
||||
: with-file-reader ( path encoding quot -- )
|
||||
>r <file-reader> r> with-stream ; inline
|
||||
|
||||
: file-contents ( path encoding -- str )
|
||||
<file-reader> contents ;
|
||||
|
||||
: with-file-writer ( path encoding quot -- )
|
||||
>r <file-writer> r> with-stream ; inline
|
||||
|
||||
: set-file-lines ( seq path encoding -- )
|
||||
[ [ print ] each ] with-file-writer ;
|
||||
|
||||
: set-file-contents ( str path encoding -- )
|
||||
[ write ] with-file-writer ;
|
||||
|
||||
: with-file-appender ( path encoding quot -- )
|
||||
>r <file-appender> r> with-stream ; inline
|
||||
|
||||
: temp-directory ( -- path )
|
||||
"temp" resource-path
|
||||
dup exists? not
|
||||
[ dup make-directory ]
|
||||
when ;
|
||||
|
||||
: temp-file ( name -- path ) temp-directory prepend-path ;
|
||||
|
||||
! Home directory
|
||||
: home ( -- dir )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -4,24 +4,24 @@ io.encodings.binary ;
|
|||
IN: io.tests
|
||||
|
||||
[ f ] [
|
||||
"resource:/core/io/test/no-trailing-eol.factor" run-file
|
||||
"resource:core/io/test/no-trailing-eol.factor" run-file
|
||||
"foo" "io.tests" lookup
|
||||
] unit-test
|
||||
|
||||
: <resource-reader> ( resource -- stream )
|
||||
resource-path iso-8859-1 <file-reader> ;
|
||||
resource-path latin1 <file-reader> ;
|
||||
|
||||
[
|
||||
"This is a line.\rThis is another line.\r"
|
||||
] [
|
||||
"/core/io/test/mac-os-eol.txt" <resource-reader>
|
||||
"core/io/test/mac-os-eol.txt" <resource-reader>
|
||||
[ 500 read ] with-stream
|
||||
] unit-test
|
||||
|
||||
[
|
||||
255
|
||||
] [
|
||||
"/core/io/test/binary.txt" <resource-reader>
|
||||
"core/io/test/binary.txt" <resource-reader>
|
||||
[ read1 ] with-stream >fixnum
|
||||
] unit-test
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ IN: io.tests
|
|||
}
|
||||
] [
|
||||
[
|
||||
"/core/io/test/separator-test.txt" <resource-reader> [
|
||||
"core/io/test/separator-test.txt" <resource-reader> [
|
||||
"J" read-until 2array ,
|
||||
"i" read-until 2array ,
|
||||
"X" read-until 2array ,
|
||||
|
|
|
|||
|
|
@ -7,6 +7,8 @@ IN: kernel
|
|||
ARTICLE: "shuffle-words" "Shuffle words"
|
||||
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
|
||||
$nl
|
||||
"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
|
||||
$nl
|
||||
"Removing stack elements:"
|
||||
{ $subsection drop }
|
||||
{ $subsection 2drop }
|
||||
|
|
@ -39,33 +41,137 @@ $nl
|
|||
{ $code
|
||||
": foo ( m ? n -- m+n/n )"
|
||||
" >r [ r> + ] [ drop r> ] if ; ! This is OK"
|
||||
}
|
||||
"An alternative to using " { $link >r } " and " { $link r> } " is the following:"
|
||||
{ $subsection dip } ;
|
||||
} ;
|
||||
|
||||
ARTICLE: "basic-combinators" "Basic combinators"
|
||||
"The following pair of words invoke words and quotations reflectively:"
|
||||
{ $subsection call }
|
||||
{ $subsection execute }
|
||||
"These words are used to implement " { $emphasis "combinators" } ", which are words that take code from the stack. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
|
||||
{ $code
|
||||
": keep ( x quot -- x )"
|
||||
" over >r call r> ; inline"
|
||||
}
|
||||
"Word inlining is documented in " { $link "declarations" } "."
|
||||
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
|
||||
"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
|
||||
$nl
|
||||
"There are some words that combine shuffle words with " { $link call } ". They are useful for implementing higher-level combinators."
|
||||
"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
|
||||
{ $code
|
||||
": keep [ ] bi ;"
|
||||
": 2keep [ ] 2bi ;"
|
||||
": 3keep [ ] 3bi ;"
|
||||
""
|
||||
": dup [ ] [ ] bi ;"
|
||||
": 2dup [ ] [ ] 2bi ;"
|
||||
": 3dup [ ] [ ] 3bi ;"
|
||||
""
|
||||
": tuck [ nip ] [ ] 2bi ;"
|
||||
": swap [ nip ] [ drop ] 2bi ;"
|
||||
""
|
||||
": over [ ] [ drop ] 2bi ;"
|
||||
": pick [ ] [ 2drop ] 3bi ;"
|
||||
": 2over [ ] [ drop ] 3bi ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "cleave-combinators" "Cleave combinators"
|
||||
"The cleave combinators apply multiple quotations to a single value."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi }
|
||||
{ $subsection 2bi }
|
||||
{ $subsection 3bi }
|
||||
"Three quotations:"
|
||||
{ $subsection tri }
|
||||
{ $subsection 2tri }
|
||||
{ $subsection 3tri }
|
||||
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
|
||||
{ $code
|
||||
"! First alternative; uses keep"
|
||||
"[ 1 + ] keep"
|
||||
"[ 1 - ] keep"
|
||||
"2 *"
|
||||
"! Second alternative: uses tri"
|
||||
"[ 1 + ]"
|
||||
"[ 1 - ]"
|
||||
"[ 2 * ] tri"
|
||||
}
|
||||
"The latter is more aesthetically pleasing than the former."
|
||||
$nl
|
||||
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
|
||||
{ $subsection "cleave-shuffle-equivalence" } ;
|
||||
|
||||
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
|
||||
"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
|
||||
$nl
|
||||
"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
|
||||
{ $code
|
||||
": dip [ ] bi* ;"
|
||||
""
|
||||
": slip [ call ] [ ] bi* ;"
|
||||
": 2slip [ call ] [ ] [ ] tri* ;"
|
||||
""
|
||||
": nip [ drop ] [ ] bi* ;"
|
||||
": 2nip [ drop ] [ drop ] [ ] tri* ;"
|
||||
""
|
||||
": rot"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
""
|
||||
": -rot"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
""
|
||||
": spin"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "spread-combinators" "Spread combinators"
|
||||
"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi* }
|
||||
{ $subsection 2bi* }
|
||||
"Three quotations:"
|
||||
{ $subsection tri* }
|
||||
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
|
||||
{ $code
|
||||
"! First alternative; uses retain stack explicitly"
|
||||
">r >r 1 +"
|
||||
"r> 1 -"
|
||||
"r> 2 *"
|
||||
"! Second alternative: uses tri*"
|
||||
"[ 1 + ]"
|
||||
"[ 1 - ]"
|
||||
"[ 2 * ] tri*"
|
||||
}
|
||||
|
||||
$nl
|
||||
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
|
||||
{ $subsection "spread-shuffle-equivalence" } ;
|
||||
|
||||
ARTICLE: "apply-combinators" "Apply combinators"
|
||||
"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi@ }
|
||||
{ $subsection 2bi@ }
|
||||
"Three quotations:"
|
||||
{ $subsection tri@ }
|
||||
"A pair of utility words built from " { $link bi@ } ":"
|
||||
{ $subsection both? }
|
||||
{ $subsection either? } ;
|
||||
|
||||
ARTICLE: "slip-keep-combinators" "The slip and keep combinators"
|
||||
"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
|
||||
{ $subsection slip }
|
||||
{ $subsection 2slip }
|
||||
{ $subsection 3slip }
|
||||
"The dip combinator invokes the quotation at the top of the stack, hiding the value underneath:"
|
||||
{ $subsection dip }
|
||||
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
|
||||
{ $subsection keep }
|
||||
{ $subsection 2keep }
|
||||
{ $subsection 3keep }
|
||||
{ $subsection 2apply }
|
||||
"A pair of utility words built from " { $link 2apply } ":"
|
||||
{ $subsection both? }
|
||||
{ $subsection either? }
|
||||
"A looping combinator:"
|
||||
{ $subsection while }
|
||||
{ $subsection 3keep } ;
|
||||
|
||||
ARTICLE: "compositional-combinators" "Compositional combinators"
|
||||
"Quotations can be composed using efficient quotation-specific operations:"
|
||||
{ $subsection curry }
|
||||
{ $subsection 2curry }
|
||||
|
|
@ -73,8 +179,21 @@ $nl
|
|||
{ $subsection with }
|
||||
{ $subsection compose }
|
||||
{ $subsection 3compose }
|
||||
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "."
|
||||
{ $see-also "combinators" } ;
|
||||
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
|
||||
|
||||
ARTICLE: "implementing-combinators" "Implementing combinators"
|
||||
"The following pair of words invoke words and quotations reflectively:"
|
||||
{ $subsection call }
|
||||
{ $subsection execute }
|
||||
"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
|
||||
{ $code
|
||||
": keep ( x quot -- x )"
|
||||
" over >r call r> ; inline"
|
||||
}
|
||||
"Word inlining is documented in " { $link "declarations" } "."
|
||||
$nl
|
||||
"A looping combinator:"
|
||||
{ $subsection while } ;
|
||||
|
||||
ARTICLE: "booleans" "Booleans"
|
||||
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
|
||||
|
|
@ -115,15 +234,13 @@ ARTICLE: "conditionals" "Conditionals and logic"
|
|||
{ $subsection ?if }
|
||||
"Sometimes instead of branching, you just need to pick one of two values:"
|
||||
{ $subsection ? }
|
||||
"Forms which abstract away common patterns involving multiple nested branches:"
|
||||
{ $subsection cond }
|
||||
{ $subsection case }
|
||||
"There are some logical operations on booleans:"
|
||||
{ $subsection >boolean }
|
||||
{ $subsection not }
|
||||
{ $subsection and }
|
||||
{ $subsection or }
|
||||
{ $subsection xor }
|
||||
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
|
||||
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
|
||||
|
||||
ARTICLE: "equality" "Equality and comparison testing"
|
||||
|
|
@ -146,7 +263,23 @@ $nl
|
|||
"An object can be cloned; the clone has distinct identity but equal value:"
|
||||
{ $subsection clone } ;
|
||||
|
||||
! Defined in handbook.factor
|
||||
ARTICLE: "dataflow" "Data and control flow"
|
||||
{ $subsection "evaluator" }
|
||||
{ $subsection "words" }
|
||||
{ $subsection "effects" }
|
||||
{ $subsection "booleans" }
|
||||
{ $subsection "shuffle-words" }
|
||||
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
|
||||
{ $subsection "cleave-combinators" }
|
||||
{ $subsection "spread-combinators" }
|
||||
{ $subsection "apply-combinators" }
|
||||
{ $subsection "slip-keep-combinators" }
|
||||
{ $subsection "conditionals" }
|
||||
{ $subsection "combinators" }
|
||||
"Advanced topics:"
|
||||
{ $subsection "implementing-combinators" }
|
||||
{ $subsection "continuations" } ;
|
||||
|
||||
ABOUT: "dataflow"
|
||||
|
||||
HELP: eq? ( obj1 obj2 -- ? )
|
||||
|
|
@ -211,12 +344,12 @@ HELP: hashcode*
|
|||
{ $values { "depth" integer } { "obj" object } { "code" fixnum } }
|
||||
{ $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:"
|
||||
{ $list
|
||||
{ "if two objects are equal under " { $link = } ", they must have equal hashcodes" }
|
||||
{ "if the hashcode of an object depends on the values of its slots, the hashcode of the slots must be computed recursively by calling " { $link hashcode* } " with a " { $snippet "level" } " parameter decremented by one. This avoids excessive work while still computing well-distributed hashcodes. The " { $link recursive-hashcode } " combinator can help with implementing this logic" }
|
||||
{ "the hashcode should be a " { $link fixnum } ", however returning a " { $link bignum } " will not cause any problems other than potential performance degradation."
|
||||
"the hashcode is only permitted to change between two invocations if the object was mutated in some way" }
|
||||
{ "If two objects are equal under " { $link = } ", they must have equal hashcodes." }
|
||||
{ "If the hashcode of an object depends on the values of its slots, the hashcode of the slots must be computed recursively by calling " { $link hashcode* } " with a " { $snippet "level" } " parameter decremented by one. This avoids excessive work while still computing well-distributed hashcodes. The " { $link recursive-hashcode } " combinator can help with implementing this logic," }
|
||||
{ "The hashcode should be a " { $link fixnum } ", however returning a " { $link bignum } " will not cause any problems other than potential performance degradation." }
|
||||
{ "The hashcode is only permitted to change between two invocations if the object or one of its slot values was mutated." }
|
||||
}
|
||||
"If mutable objects are used as hashtable keys, they must not be mutated in such a way that their hashcode changes. Doing so will violate bucket sorting invariants and result in undefined behavior." } ;
|
||||
"If mutable objects are used as hashtable keys, they must not be mutated in such a way that their hashcode changes. Doing so will violate bucket sorting invariants and result in undefined behavior. See " { $link "hashtables.keys" } " for details." } ;
|
||||
|
||||
HELP: hashcode
|
||||
{ $values { "obj" object } { "code" fixnum } }
|
||||
|
|
@ -242,6 +375,8 @@ HELP: equal?
|
|||
{ { $snippet "a = b" } " implies " { $snippet "b = a" } }
|
||||
{ { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } }
|
||||
}
|
||||
$nl
|
||||
"If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
|
||||
}
|
||||
{ $examples
|
||||
"To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
|
||||
|
|
@ -376,9 +511,189 @@ HELP: 3keep
|
|||
{ $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
|
||||
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
|
||||
|
||||
HELP: 2apply
|
||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } { "x" object } { "y" object } }
|
||||
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ;
|
||||
HELP: bi
|
||||
{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } "." }
|
||||
{ $examples
|
||||
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] bi"
|
||||
"dup p q"
|
||||
}
|
||||
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- y )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] bi"
|
||||
"dup p swap q"
|
||||
}
|
||||
"In general, the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] bi"
|
||||
"[ p ] keep q"
|
||||
}
|
||||
|
||||
} ;
|
||||
|
||||
HELP: 2bi
|
||||
{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
|
||||
{ $examples
|
||||
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 2bi"
|
||||
"2dup p q"
|
||||
}
|
||||
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 2bi"
|
||||
"2dup p -rot q"
|
||||
}
|
||||
"In general, the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 2bi"
|
||||
"[ p ] 2keep q"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: 3bi
|
||||
{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
|
||||
{ $examples
|
||||
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 3bi"
|
||||
"3dup p q"
|
||||
}
|
||||
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 3bi"
|
||||
"3dup p -roll q"
|
||||
}
|
||||
"In general, the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 3bi"
|
||||
"[ p ] 3keep q"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: tri
|
||||
{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." }
|
||||
{ $examples
|
||||
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] tri"
|
||||
"dup p dup q r"
|
||||
}
|
||||
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x -- y )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] tri"
|
||||
"dup p over q rot r"
|
||||
}
|
||||
"In general, the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] tri"
|
||||
"[ p ] keep [ q ] keep r"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: 2tri
|
||||
{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values, and finally applies " { $snippet "r" } " to the two input values." }
|
||||
{ $examples
|
||||
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] 2tri"
|
||||
"2dup p 2dup q r"
|
||||
}
|
||||
"In general, the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] 2tri"
|
||||
"[ p ] 2keep [ q ] 2keep r"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: 3tri
|
||||
{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." }
|
||||
{ $examples
|
||||
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] 3tri"
|
||||
"3dup p 3dup q r"
|
||||
}
|
||||
"In general, the following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] 3tri"
|
||||
"[ p ] 3keep [ q ] 3keep r"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
||||
HELP: bi*
|
||||
{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } "." }
|
||||
{ $examples
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] bi*"
|
||||
">r p r> q"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: 2bi*
|
||||
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( w x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y z -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to " { $snippet "w" } " and " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } " and " { $snippet "z" } "." }
|
||||
{ $examples
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 2bi*"
|
||||
">r >r q r> r> q"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: tri*
|
||||
{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( z -- ... )" } } }
|
||||
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." }
|
||||
{ $examples
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] tri*"
|
||||
">r >r q r> q r> r"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: bi@
|
||||
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
|
||||
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." }
|
||||
{ $examples
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] bi@"
|
||||
">r p r> p"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: 2bi@
|
||||
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- )" } } }
|
||||
{ $description "Applies the quotation to " { $snippet "w" } " and " { $snippet "x" } ", then to " { $snippet "y" } " and " { $snippet "z" } "." }
|
||||
{ $examples
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] 2bi@"
|
||||
">r >r p r> r> p"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: tri@
|
||||
{ $values { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
|
||||
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } ", and finally to " { $snippet "z" } "." }
|
||||
{ $examples
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] tri@"
|
||||
">r >r p r> p r> p"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: if ( cond true false -- )
|
||||
{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel.private ;
|
||||
IN: kernel
|
||||
|
|
@ -27,24 +27,28 @@ DEFER: if
|
|||
|
||||
: if ( ? true false -- ) ? call ;
|
||||
|
||||
: if* ( cond true false -- )
|
||||
pick [ drop call ] [ 2nip call ] if ; inline
|
||||
|
||||
: ?if ( default cond true false -- )
|
||||
pick [ roll 2drop call ] [ 2nip call ] if ; inline
|
||||
|
||||
! Single branch
|
||||
: unless ( cond false -- )
|
||||
swap [ drop ] [ call ] if ; inline
|
||||
|
||||
: unless* ( cond false -- )
|
||||
over [ drop ] [ nip call ] if ; inline
|
||||
|
||||
: when ( cond true -- )
|
||||
swap [ call ] [ drop ] if ; inline
|
||||
|
||||
! Anaphoric
|
||||
: if* ( cond true false -- )
|
||||
pick [ drop call ] [ 2nip call ] if ; inline
|
||||
|
||||
: when* ( cond true -- )
|
||||
over [ call ] [ 2drop ] if ; inline
|
||||
|
||||
: unless* ( cond false -- )
|
||||
over [ drop ] [ nip call ] if ; inline
|
||||
|
||||
! Default
|
||||
: ?if ( default cond true false -- )
|
||||
pick [ roll 2drop call ] [ 2nip call ] if ; inline
|
||||
|
||||
! Slippers
|
||||
: slip ( quot x -- x ) >r call r> ; inline
|
||||
|
||||
: 2slip ( quot x y -- x y ) >r >r call r> r> ; inline
|
||||
|
|
@ -53,6 +57,7 @@ DEFER: if
|
|||
|
||||
: dip ( obj quot -- obj ) swap slip ; inline
|
||||
|
||||
! Keepers
|
||||
: keep ( x quot -- x ) over slip ; inline
|
||||
|
||||
: 2keep ( x y quot -- x y ) 2over 2slip ; inline
|
||||
|
|
@ -60,36 +65,55 @@ DEFER: if
|
|||
: 3keep ( x y z quot -- x y z )
|
||||
>r 3dup r> -roll 3slip ; inline
|
||||
|
||||
: 2apply ( x y quot -- ) tuck 2slip call ; inline
|
||||
! Cleavers
|
||||
: bi ( x p q -- )
|
||||
>r keep r> call ; inline
|
||||
|
||||
: tri ( x p q r -- )
|
||||
>r pick >r bi r> r> call ; inline
|
||||
|
||||
! Double cleavers
|
||||
: 2bi ( x y p q -- )
|
||||
>r 2keep r> call ; inline
|
||||
|
||||
: 2tri ( x y p q r -- )
|
||||
>r >r 2keep r> 2keep r> call ; inline
|
||||
|
||||
! Triple cleavers
|
||||
: 3bi ( x y z p q -- )
|
||||
>r 3keep r> call ; inline
|
||||
|
||||
: 3tri ( x y z p q r -- )
|
||||
>r >r 3keep r> 3keep r> call ; inline
|
||||
|
||||
! Spreaders
|
||||
: bi* ( x y p q -- )
|
||||
>r swap slip r> call ; inline
|
||||
|
||||
: tri* ( x y z p q r -- )
|
||||
>r rot >r bi* r> r> call ; inline
|
||||
|
||||
! Double spreaders
|
||||
: 2bi* ( w x y z p q -- )
|
||||
>r -rot 2slip r> call ; inline
|
||||
|
||||
! Appliers
|
||||
: bi@ ( x y quot -- )
|
||||
tuck 2slip call ; inline
|
||||
|
||||
: tri@ ( x y z quot -- )
|
||||
tuck >r bi@ r> call ; inline
|
||||
|
||||
! Double appliers
|
||||
: 2bi@ ( w x y z quot -- )
|
||||
dup -roll 3slip call ; inline
|
||||
|
||||
: while ( pred body tail -- )
|
||||
>r >r dup slip r> r> roll
|
||||
[ >r tuck 2slip r> while ]
|
||||
[ 2nip call ] if ; inline
|
||||
|
||||
! Quotation building
|
||||
USE: tuples.private
|
||||
|
||||
: curry ( obj quot -- curry )
|
||||
\ curry 4 <tuple-boa> ;
|
||||
|
||||
: 2curry ( obj1 obj2 quot -- curry )
|
||||
curry curry ; inline
|
||||
|
||||
: 3curry ( obj1 obj2 obj3 quot -- curry )
|
||||
curry curry curry ; inline
|
||||
|
||||
: with ( param obj quot -- obj curry )
|
||||
swapd [ swapd call ] 2curry ; inline
|
||||
|
||||
: compose ( quot1 quot2 -- curry )
|
||||
\ compose 4 <tuple-boa> ;
|
||||
|
||||
: 3compose ( quot1 quot2 quot3 -- curry )
|
||||
compose compose ; inline
|
||||
|
||||
! Object protocol
|
||||
|
||||
GENERIC: delegate ( obj -- delegate )
|
||||
|
||||
M: object delegate drop f ;
|
||||
|
|
@ -118,7 +142,6 @@ M: object clone ;
|
|||
M: callstack clone (clone) ;
|
||||
|
||||
! Tuple construction
|
||||
|
||||
GENERIC# get-slots 1 ( tuple slots -- ... )
|
||||
|
||||
GENERIC# set-slots 1 ( ... tuple slots -- )
|
||||
|
|
@ -132,8 +155,20 @@ GENERIC: construct-boa ( ... class -- tuple )
|
|||
: construct-delegate ( delegate class -- tuple )
|
||||
>r { set-delegate } r> construct ; inline
|
||||
|
||||
! Booleans
|
||||
! Quotation building
|
||||
: 2curry ( obj1 obj2 quot -- curry )
|
||||
curry curry ; inline
|
||||
|
||||
: 3curry ( obj1 obj2 obj3 quot -- curry )
|
||||
curry curry curry ; inline
|
||||
|
||||
: with ( param obj quot -- obj curry )
|
||||
swapd [ swapd call ] 2curry ; inline
|
||||
|
||||
: 3compose ( quot1 quot2 quot3 -- curry )
|
||||
compose compose ; inline
|
||||
|
||||
! Booleans
|
||||
: not ( obj -- ? ) f eq? ; inline
|
||||
|
||||
: >boolean ( obj -- ? ) t f ? ; inline
|
||||
|
|
@ -144,11 +179,11 @@ GENERIC: construct-boa ( ... class -- tuple )
|
|||
|
||||
: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline
|
||||
|
||||
: both? ( x y quot -- ? ) 2apply and ; inline
|
||||
: both? ( x y quot -- ? ) bi@ and ; inline
|
||||
|
||||
: either? ( x y quot -- ? ) 2apply or ; inline
|
||||
: either? ( x y quot -- ? ) bi@ or ; inline
|
||||
|
||||
: compare ( obj1 obj2 quot -- n ) 2apply <=> ; inline
|
||||
: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
|
||||
|
||||
: most ( x y quot -- z )
|
||||
>r 2dup r> call [ drop ] [ nip ] if ; inline
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays hashtables io kernel math math.parser memory
|
||||
namespaces parser sequences strings io.styles
|
||||
io.streams.duplex vectors words generic system combinators
|
||||
tuples continuations debugger definitions compiler.units ;
|
||||
continuations debugger definitions compiler.units ;
|
||||
IN: listener
|
||||
|
||||
SYMBOL: quit-flag
|
||||
|
|
|
|||
|
|
@ -169,7 +169,7 @@ IN: math.intervals.tests
|
|||
|
||||
: random-interval ( -- interval )
|
||||
1000 random dup 2 1000 random + +
|
||||
1 random zero? [ [ neg ] 2apply swap ] when
|
||||
1 random zero? [ [ neg ] bi@ swap ] when
|
||||
4 random {
|
||||
{ 0 [ [a,b] ] }
|
||||
{ 1 [ [a,b) ] }
|
||||
|
|
@ -188,7 +188,7 @@ IN: math.intervals.tests
|
|||
{ max interval-max }
|
||||
}
|
||||
"math.ratios.private" vocab [
|
||||
{ / interval/ } add
|
||||
{ / interval/ } suffix
|
||||
] when
|
||||
random ;
|
||||
|
||||
|
|
@ -197,7 +197,7 @@ IN: math.intervals.tests
|
|||
0 pick interval-contains? over first { / /i } member? and [
|
||||
3drop t
|
||||
] [
|
||||
[ >r [ random-element ] 2apply ! 2dup . .
|
||||
[ >r [ random-element ] bi@ ! 2dup . .
|
||||
r> first execute ] 3keep
|
||||
second execute interval-contains?
|
||||
] if ;
|
||||
|
|
@ -214,7 +214,7 @@ IN: math.intervals.tests
|
|||
|
||||
: comparison-test
|
||||
random-interval random-interval random-comparison
|
||||
[ >r [ random-element ] 2apply r> first execute ] 3keep
|
||||
[ >r [ random-element ] bi@ r> first execute ] 3keep
|
||||
second execute dup incomparable eq? [
|
||||
2drop t
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ C: <interval> interval
|
|||
|
||||
: (interval-op) ( p1 p2 quot -- p3 )
|
||||
2over >r >r
|
||||
>r [ first ] 2apply r> call
|
||||
>r [ first ] bi@ r> call
|
||||
r> r> [ second ] both? 2array ; inline
|
||||
|
||||
: interval-op ( i1 i2 quot -- i3 )
|
||||
|
|
@ -108,7 +108,7 @@ C: <interval> interval
|
|||
|
||||
: interval-intersect ( i1 i2 -- i3 )
|
||||
2dup and [
|
||||
[ interval>points ] 2apply swapd
|
||||
[ interval>points ] bi@ swapd
|
||||
[ swap endpoint> ] most
|
||||
>r [ swap endpoint< ] most r>
|
||||
make-interval
|
||||
|
|
@ -118,7 +118,7 @@ C: <interval> interval
|
|||
|
||||
: interval-union ( i1 i2 -- i3 )
|
||||
2dup and [
|
||||
[ interval>points 2array ] 2apply append points>interval
|
||||
[ interval>points 2array ] bi@ append points>interval
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
|
@ -131,17 +131,17 @@ C: <interval> interval
|
|||
|
||||
: interval-singleton? ( int -- ? )
|
||||
interval>points
|
||||
2dup [ second ] 2apply and
|
||||
[ [ first ] 2apply = ]
|
||||
2dup [ second ] bi@ and
|
||||
[ [ first ] bi@ = ]
|
||||
[ 2drop f ] if ;
|
||||
|
||||
: interval-length ( int -- n )
|
||||
dup
|
||||
[ interval>points [ first ] 2apply swap - ]
|
||||
[ interval>points [ first ] bi@ swap - ]
|
||||
[ drop 0 ] if ;
|
||||
|
||||
: interval-closure ( i1 -- i2 )
|
||||
dup [ interval>points [ first ] 2apply [a,b] ] when ;
|
||||
dup [ interval>points [ first ] bi@ [a,b] ] when ;
|
||||
|
||||
: interval-shift ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
|
|
@ -163,7 +163,7 @@ C: <interval> interval
|
|||
[ min ] interval-op interval-closure ;
|
||||
|
||||
: interval-interior ( i1 -- i2 )
|
||||
interval>points [ first ] 2apply (a,b) ;
|
||||
interval>points [ first ] bi@ (a,b) ;
|
||||
|
||||
: interval-division-op ( i1 i2 quot -- i3 )
|
||||
>r 0 over interval-closure interval-contains?
|
||||
|
|
@ -186,13 +186,13 @@ SYMBOL: incomparable
|
|||
: left-endpoint-< ( i1 i2 -- ? )
|
||||
[ swap interval-subset? ] 2keep
|
||||
[ nip interval-singleton? ] 2keep
|
||||
[ interval-from ] 2apply =
|
||||
[ interval-from ] bi@ =
|
||||
and and ;
|
||||
|
||||
: right-endpoint-< ( i1 i2 -- ? )
|
||||
[ interval-subset? ] 2keep
|
||||
[ drop interval-singleton? ] 2keep
|
||||
[ interval-to ] 2apply =
|
||||
[ interval-to ] bi@ =
|
||||
and and ;
|
||||
|
||||
: (interval<) over interval-from over interval-from endpoint< ;
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ HELP: <mirror>
|
|||
"TUPLE: circle center radius ;"
|
||||
"C: <circle> circle"
|
||||
"{ 100 50 } 15 <circle> <mirror> >alist ."
|
||||
"{ { \"center\" { 100 50 } } { \"radius\" 15 } }"
|
||||
"{ { \"delegate\" f } { \"center\" { 100 50 } } { \"radius\" 15 } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ TUPLE: foo bar baz ;
|
|||
|
||||
C: <foo> foo
|
||||
|
||||
[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
|
||||
[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
|
||||
|
||||
[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,17 +1,15 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs hashtables kernel sequences generic words
|
||||
arrays classes slots slots.private tuples math vectors
|
||||
arrays classes slots slots.private classes.tuple math vectors
|
||||
quotations sorting prettyprint ;
|
||||
IN: mirrors
|
||||
|
||||
GENERIC: object-slots ( obj -- seq )
|
||||
: all-slots ( class -- slots )
|
||||
superclasses [ "slots" word-prop ] map concat ;
|
||||
|
||||
M: object object-slots class "slots" word-prop ;
|
||||
|
||||
M: tuple object-slots
|
||||
dup class "slots" word-prop
|
||||
swap delegate [ 1 tail-slice ] unless ;
|
||||
: object-slots ( obj -- seq )
|
||||
class all-slots ;
|
||||
|
||||
TUPLE: mirror object slots ;
|
||||
|
||||
|
|
|
|||
|
|
@ -99,7 +99,7 @@ namespaces assocs kernel sequences math tools.test words ;
|
|||
] unit-test
|
||||
|
||||
: regression-2 ( x y -- x.y )
|
||||
[ p1 ] 2apply [
|
||||
[ p1 ] bi@ [
|
||||
[
|
||||
rot
|
||||
[ 2swap [ swapd * -rot p2 +@ ] 2keep ]
|
||||
|
|
|
|||
|
|
@ -6,17 +6,16 @@ inference.class kernel assocs math math.private kernel.private
|
|||
sequences words parser vectors strings sbufs io namespaces
|
||||
assocs quotations sequences.private io.binary io.crc32
|
||||
io.streams.string layouts splitting math.intervals
|
||||
math.floats.private tuples tuples.private classes
|
||||
math.floats.private classes.tuple classes.tuple.private classes
|
||||
classes.algebra optimizer.def-use optimizer.backend
|
||||
optimizer.pattern-match optimizer.inlining float-arrays
|
||||
sequences.private combinators ;
|
||||
|
||||
! the output of <tuple> and <tuple-boa> has the class which is
|
||||
! its second-to-last input
|
||||
{ <tuple> <tuple-boa> } [
|
||||
[
|
||||
dup node-in-d dup length 2 - swap nth node-literal
|
||||
dup class? [ drop tuple ] unless 1array f
|
||||
dup node-in-d peek node-literal
|
||||
dup tuple-layout? [ layout-class ] [ drop tuple ] if
|
||||
1array f
|
||||
] "output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
|
|
@ -61,7 +60,7 @@ sequences.private combinators ;
|
|||
[ value-literal sequence? ] [ drop f ] if ;
|
||||
|
||||
: member-quot ( seq -- newquot )
|
||||
[ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
|
||||
[ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
|
||||
|
||||
: expand-member ( #call -- )
|
||||
dup node-in-d peek value-literal member-quot f splice-quot ;
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ generic.standard system ;
|
|||
: post-process ( class interval node -- classes intervals )
|
||||
dupd won't-overflow?
|
||||
[ >r dup { f integer } member? [ drop fixnum ] when r> ] when
|
||||
[ dup [ 1array ] when ] 2apply ;
|
||||
[ dup [ 1array ] when ] bi@ ;
|
||||
|
||||
: math-output-interval-1 ( node word -- interval )
|
||||
dup [
|
||||
|
|
@ -147,7 +147,7 @@ generic.standard system ;
|
|||
] each
|
||||
|
||||
: intervals ( node -- i1 i2 )
|
||||
node-in-d first2 [ value-interval* ] 2apply ;
|
||||
node-in-d first2 [ value-interval* ] bi@ ;
|
||||
|
||||
: math-output-interval-2 ( node word -- interval )
|
||||
dup [
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: arrays compiler.units generic hashtables inference kernel
|
|||
kernel.private math optimizer prettyprint sequences sbufs
|
||||
strings tools.test vectors words sequences.private quotations
|
||||
optimizer.backend classes classes.algebra inference.dataflow
|
||||
tuples.private continuations growable optimizer.inlining
|
||||
classes.tuple.private continuations growable optimizer.inlining
|
||||
namespaces hints ;
|
||||
IN: optimizer.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ IN: optimizer.specializers
|
|||
|
||||
: method-declaration ( method -- quot )
|
||||
dup "method-generic" word-prop dispatch# object <array>
|
||||
swap "method-class" word-prop add* ;
|
||||
swap "method-class" word-prop prefix ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration [ declare ] curry prepend ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue