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

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

Conflicts:

	extra/semantic-db/semantic-db-tests.factor
db4
Alex Chapman 2008-04-01 12:09:33 +11:00
parent 5dd354333f 8e2c2e1838
commit 4d2cb451f3
317 changed files with 3116 additions and 1847 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Makefile
View File

@ -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*.*

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

@ -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() {
@ -125,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() {
@ -156,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
@ -182,7 +183,7 @@ find_os() {
}
find_architecture() {
echo "Finding ARCH..."
$ECHO "Finding ARCH..."
uname_m=`uname -m`
check_ret uname
case $uname_m in
@ -201,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
@ -219,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
@ -437,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>"
}
@ -452,5 +453,6 @@ case "$1" in
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

13
build-support/grovel.c
View File

@ -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();

38
build-support/target
View File

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

8
build-support/wordsize.c
View File

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

5
core/alien/alien.factor
View File

@ -1,8 +1,7 @@
! 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
@ -40,7 +39,7 @@ M: alien equal?
2dup [ expired? ] either? [
[ expired? ] both?
] [
[ alien-address ] 2apply =
[ alien-address ] bi@ =
] if
] [
2drop f

2
core/assocs/assocs.factor
View File

@ -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 )

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

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

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

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

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

@ -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 tuples.private 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 ;
@ -295,29 +303,28 @@ M: bit-array ' bit-array emit-dummy-array ;
M: float-array ' float-array emit-dummy-array ;
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ]
[ class transfer-word tuple-layout ] bi add* [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
[
[
dup class transfer-word tuple-layout ' ,
tuple>array 1 tail-slice [ ' ] map %
] { } make
tuple type-number dup [ emit-seq ] emit-object
]
! Hack
over class word-name "tombstone" =
[ objects get swap cache ] [ call ] if ;
dup class word-name "tombstone" =
[ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
M: tuple ' emit-tuple ;
M: tuple-layout '
objects get [
[
dup layout-hashcode ' ,
dup layout-class ' ,
dup layout-size ' ,
dup layout-superclasses ' ,
layout-echelon ' ,
] { } make
{
[ 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 ;
@ -328,14 +335,9 @@ M: tombstone '
word-def first objects get [ emit-tuple ] cache ;
! Arrays
: emit-array ( list type tag -- pointer )
>r >r [ ' ] map r> r> [
dup length emit-fixnum
emit-seq
] emit-object ;
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
@ -350,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 ( -- )
@ -436,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
core/bootstrap/layouts/layouts.factor
View File

@ -2,7 +2,7 @@
! 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 tuples.private ;
float-arrays quotations assocs layouts classes.tuple.private ;
BIN: 111 tag-mask set
8 num-tags set

85
core/bootstrap/primitives.factor
View File

@ -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
tuples.private 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
@ -60,6 +61,8 @@ num-types get f <array> builtins set
"byte-arrays"
"byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
"compiler.units"
"continuations.private"
"float-arrays"
@ -91,8 +94,6 @@ num-types get f <array> builtins set
"system.private"
"threads.private"
"tools.profiler.private"
"tuples"
"tuples.private"
"words"
"words.private"
"vectors"
@ -102,33 +103,36 @@ num-types get f <array> builtins set
! 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
@ -291,35 +295,35 @@ define-builtin
"callstack" "kernel" create { } define-builtin
"tuple-layout" "tuples.private" create {
"tuple-layout" "classes.tuple.private" create {
{
{ "fixnum" "math" }
"hashcode"
{ "layout-hashcode" "tuples.private" }
{ "layout-hashcode" "classes.tuple.private" }
f
}
{
{ "word" "words" }
"class"
{ "layout-class" "tuples.private" }
{ "layout-class" "classes.tuple.private" }
f
}
{
{ "fixnum" "math" }
"size"
{ "layout-size" "tuples.private" }
{ "layout-size" "classes.tuple.private" }
f
}
{
{ "array" "arrays" }
"superclasses"
{ "layout-superclasses" "tuples.private" }
{ "layout-superclasses" "classes.tuple.private" }
f
}
{
{ "fixnum" "math" }
"echelon"
{ "layout-echelon" "tuples.private" }
{ "layout-echelon" "classes.tuple.private" }
f
}
} define-builtin
@ -335,13 +339,16 @@ define-builtin
{ "set-delegate" "kernel" }
}
}
define-tuple-slots
[ 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
@ -353,15 +360,15 @@ 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
@ -495,8 +502,9 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"curry" "kernel" lookup
dup f "inline" set-word-prop
dup tuple-layout [ <tuple-boa> ] curry define
[ f "inline" set-word-prop ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define
"compose" "kernel" create
"tuple" "kernel" lookup
@ -515,8 +523,9 @@ dup tuple-layout [ <tuple-boa> ] curry define
} define-tuple-class
"compose" "kernel" lookup
dup f "inline" set-word-prop
dup tuple-layout [ <tuple-boa> ] curry define
[ f "inline" set-word-prop ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define
! Primitive words
: make-primitive ( word vocab n -- )
@ -694,13 +703,13 @@ dup tuple-layout [ <tuple-boa> ] curry define
{ "<string>" "strings" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "tuples.private" }
{ "<tuple-layout>" "tuples.private" }
{ "<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" }

2
core/bootstrap/stage2.factor
View File

@ -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 ;

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

@ -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 )
{

36
core/classes/classes.factor
View File

@ -83,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 -- )
@ -100,23 +99,30 @@ 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

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

@ -1,7 +1,7 @@
! 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: mixin-class < union-class "mixin" word-prop ;
@ -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 }

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

@ -14,8 +14,8 @@ PREDICATE: predicate-class < class
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
>r >r dup f r> predicate-class define-class r>
dupd "predicate-definition" set-word-prop
>r dupd f predicate-class define-class
r> dupd "predicate-definition" set-word-prop
dup predicate-quot define-predicate ;
M: predicate-class reset-class

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

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

22
core/tuples/tuples-docs.factor → core/classes/tuple/tuple-docs.factor
View File

@ -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,26 +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." } ;
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." } ;
{ $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: 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

199
core/tuples/tuples-tests.factor → core/classes/tuple/tuple-tests.factor
View File

@ -1,10 +1,10 @@
USING: definitions generic kernel kernel.private math
math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations
generic.standard effects tuples tuples.private arrays vectors
strings compiler.units accessors classes.algebra calendar
prettyprint io.streams.string splitting ;
IN: tuples.tests
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 ;
@ -44,7 +44,7 @@ C: <redefinition-test> redefinition-test
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
"IN: tuples.tests TUPLE: redefinition-test ;" eval
"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
@ -56,7 +56,7 @@ C: <point> point
[ ] [ 100 200 <point> "p" set ] unit-test
! Use eval to sequence parsing explicitly
[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test
[ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get y>> ] unit-test
@ -68,7 +68,7 @@ C: <point> point
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
"IN: tuples.tests TUPLE: point z y ;" eval
"IN: classes.tuple.tests TUPLE: point z y ;" eval
[ 3 ] [ "p" get tuple-size ] unit-test
@ -124,7 +124,7 @@ GENERIC: <yo-momma>
TUPLE: yo-momma ;
"IN: tuples.tests C: <yo-momma> yo-momma" eval
"IN: classes.tuple.tests C: <yo-momma> yo-momma" eval
[ f ] [ \ <yo-momma> generic? ] unit-test
@ -213,12 +213,12 @@ M: vector silly "z" ;
SYMBOL: not-a-tuple-class
[
"IN: tuples.tests C: <not-a-tuple-class> 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" "tuples.tests" lookup symbol?
"not-a-tuple-class" "classes.tuple.tests" lookup symbol?
] unit-test
! Missing check
@ -234,14 +234,14 @@ C: <erg's-reshape-problem> erg's-reshape-problem
: cons-test-1 \ erg's-reshape-problem construct-empty ;
: cons-test-2 \ erg's-reshape-problem construct-boa ;
"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ ] [ 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: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ no-tuple-class? ] is? ] must-fail-with
! Inheritance
@ -265,9 +265,13 @@ C: <laptop> laptop
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] 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 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
@ -294,9 +298,13 @@ C: <server> server
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
[ "1U" ] [ "server" get rackmount>> ] 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
@ -313,13 +321,162 @@ C: <server> server
] unit-test
[
"IN: tuples.tests TUPLE: bad-superclass < word ;" eval
"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" word-prop "slot-names" set
\ thread slot-names "slot-names" set
[ ] [
[
@ -337,7 +494,7 @@ USE: threads
USE: vocabs
\ vocab "slot-names" word-prop "slot-names" set
\ vocab slot-names "slot-names" set
[ ] [
[

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

@ -0,0 +1,252 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ;
IN: classes.tuple
M: tuple 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 add* ;
: 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 add* ;
: 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
core/classes/union/union.factor
View File

@ -33,10 +33,10 @@ PREDICATE: union-class < 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 ;

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

@ -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." }

20
core/combinators/combinators.factor
View File

@ -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 -- )

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

@ -10,7 +10,7 @@ IN: compiler.tests
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry >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

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

@ -72,13 +72,13 @@ 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
[ 1 ] [

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

@ -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 ]

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

@ -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 } ;

15
core/continuations/continuations.factor
View File

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

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

@ -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 ;

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

@ -5,8 +5,8 @@ cpu.arm.architecture cpu.arm.allot kernel kernel.private math
math.private namespaces sequences words
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

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

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

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

@ -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
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -6,9 +6,9 @@ kernel.private math math.private namespaces sequences words
generic quotations byte-arrays hashtables hashtables.private
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

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

@ -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 ;

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

@ -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 ;
@ -162,10 +162,10 @@ 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 ;

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

@ -6,8 +6,8 @@ kernel.private math math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private
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

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

@ -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." }

4
core/debugger/debugger.factor
View File

@ -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 ;

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

@ -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 ;

4
core/effects/effects.factor
View File

@ -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 ;

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

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

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

@ -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"

31
core/hashtables/hashtables.factor
View File

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

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

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

4
core/heaps/heaps.factor
View File

@ -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< ;

4
core/inference/class/class.factor
View File

@ -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 ;

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

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

6
core/inference/known-words/known-words.factor
View File

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

26
core/inference/transforms/transforms-tests.factor
View File

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

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

@ -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 )

12
core/io/encodings/encodings.factor
View File

@ -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
@ -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 ;

52
core/io/files/files-tests.factor
View File

@ -7,6 +7,56 @@ io.encodings.utf8 ;
[ ] [ "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
@ -67,7 +117,7 @@ io.encodings.utf8 ;
[ ] [ "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

45
core/io/files/files.factor
View File

@ -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 init ;
io.encodings.binary init accessors ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -45,6 +45,8 @@ HOOK: (file-appender) io-backend ( path -- stream )
! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
: path-separator ( -- string ) windows? "\\" "/" ? ;
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
@ -143,8 +145,17 @@ PRIVATE>
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+
@ -216,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 ;
@ -256,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 ;

385
core/kernel/kernel-docs.factor
View File

@ -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 } }

76
core/kernel/kernel.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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,7 +65,48 @@ 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
@ -110,8 +156,6 @@ GENERIC: construct-boa ( ... class -- tuple )
>r { set-delegate } r> construct ; inline
! Quotation building
USE: tuples.private
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
@ -135,11 +179,11 @@ USE: tuples.private
: 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

2
core/listener/listener.factor
View File

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

6
core/math/intervals/intervals-tests.factor
View File

@ -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) ] }
@ -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
] [

20
core/math/intervals/intervals.factor
View File

@ -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< ;

2
core/mirrors/mirrors-docs.factor
View File

@ -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 } }"
}
} ;

2
core/mirrors/mirrors.factor
View File

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

2
core/optimizer/def-use/def-use-tests.factor
View File

@ -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 ]

2
core/optimizer/known-words/known-words.factor
View File

@ -6,7 +6,7 @@ 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 ;

4
core/optimizer/math/math.factor
View File

@ -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
core/optimizer/optimizer-tests.factor
View File

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

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

@ -333,12 +333,14 @@ HELP: CREATE
{ $errors "Throws an error if the end of the line is reached." }
$parsing-note ;
HELP: no-word
{ $values { "name" string } { "newword" word } }
{ $description "Throws a " { $link no-word } " error." }
HELP: no-word-error
{ $error-description "Thrown if the parser encounters a token which does not name a word in the current vocabulary search path. If any words with this name exist in vocabularies not part of the search path, a number of restarts will offer to add those vocabularies to the search path and use the chosen word." }
{ $notes "Apart from a missing " { $link POSTPONE: USE: } ", this error can also indicate an ordering issue. In Factor, words must be defined before they can be called. Mutual recursion can be implemented via " { $link POSTPONE: DEFER: } "." } ;
HELP: no-word
{ $values { "name" string } { "newword" word } }
{ $description "Throws a " { $link no-word-error } "." } ;
HELP: search
{ $values { "str" string } { "word/f" "a word or " { $link f } } }
{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." }

7
core/parser/parser-tests.factor
View File

@ -1,7 +1,8 @@
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting tuples compiler.units debugger vocabs vocabs.loader ;
sorting classes.tuple compiler.units debugger vocabs
vocabs.loader ;
IN: parser.tests
[
@ -321,7 +322,7 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word? ] is? ] must-fail-with
] [ [ no-word-error? ] is? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
@ -331,7 +332,7 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word? ] is? ] must-fail-with
] [ [ no-word-error? ] is? ] must-fail-with
[
"IN: parser.tests : foo ; TUPLE: foo ;"

27
core/parser/parser.factor
View File

@ -5,16 +5,18 @@ namespaces prettyprint sequences strings vectors words
quotations inspector io.styles io combinators sorting
splitting math.parser effects continuations debugger
io.files io.streams.string vocabs io.encodings.utf8
source-files classes hashtables compiler.errors compiler.units ;
source-files classes hashtables compiler.errors compiler.units
accessors ;
IN: parser
TUPLE: lexer text line line-text line-length column ;
: next-line ( lexer -- )
0 over set-lexer-column
dup lexer-line over lexer-text ?nth over set-lexer-line-text
dup lexer-line-text length over set-lexer-line-length
dup lexer-line 1+ swap set-lexer-line ;
dup [ line>> ] [ text>> ] bi ?nth >>line-text
dup line-text>> length >>line-length
[ 1+ ] change-line
0 >>column
drop ;
: <lexer> ( text -- lexer )
0 { set-lexer-text set-lexer-line } lexer construct
@ -159,8 +161,7 @@ TUPLE: parse-error file line col text ;
: <parse-error> ( msg -- error )
file get
lexer get
{ lexer-line lexer-column lexer-line-text } get-slots
lexer get [ line>> ] [ column>> ] [ line-text>> ] tri
parse-error construct-boa
[ set-delegate ] keep ;
@ -251,13 +252,13 @@ PREDICATE: unexpected-eof < unexpected
[ "Use the word " swap summary append ] keep
] { } map>assoc ;
TUPLE: no-word name ;
TUPLE: no-word-error name ;
M: no-word summary
M: no-word-error summary
drop "Word not found in current vocabulary search path" ;
: no-word ( name -- newword )
dup \ no-word construct-boa
dup no-word-error construct-boa
swap words-named [ forward-reference? not ] subset
word-restarts throw-restarts
dup word-vocabulary (use+) ;
@ -366,6 +367,10 @@ ERROR: bad-number ;
: (M:) CREATE-METHOD parse-definition ;
: scan-object ( -- object )
scan-word dup parsing?
[ V{ } clone swap execute first ] when ;
GENERIC: expected>string ( obj -- str )
M: f expected>string drop "end of input" ;
@ -470,7 +475,7 @@ SYMBOL: interactive-vocabs
: removed-definitions ( -- definitions )
new-definitions old-definitions
[ get first2 union ] 2apply diff ;
[ get first2 union ] bi@ diff ;
: smudged-usage ( -- usages referenced removed )
removed-definitions filter-moved keys [

3
core/prettyprint/backend/backend.factor
View File

@ -4,7 +4,8 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
generic hashtables io assocs kernel math namespaces sequences
strings sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
tuples tuples.private classes float-arrays float-vectors ;
classes.tuple classes.tuple.private classes float-arrays
float-vectors ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )

8
core/prettyprint/prettyprint.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint
USING: alien arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects tuples io.files classes continuations
definitions effects classes.tuple io.files classes continuations
hashtables classes.mixin classes.union classes.predicate
combinators quotations ;
@ -114,7 +114,7 @@ SYMBOL: ->
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
1+ cut [ (remove-breakpoints) ] 2apply
1+ cut [ (remove-breakpoints) ] bi@
[ -> ] swap 3append
] [
drop
@ -260,7 +260,7 @@ M: tuple-class see-class*
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
"slot-names" word-prop [ text ] each
slot-names [ text ] each
pprint-; block> ;
M: word see-class* drop ;

2
core/quotations/quotations.factor
View File

@ -12,7 +12,7 @@ M: curry call dup 3 slot swap 4 slot call ;
M: compose call dup 3 slot swap 4 slot slip call ;
M: wrapper equal?
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ;
UNION: callable quotation curry compose ;

6
core/refs/refs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov
! Copyright (C) 2007, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: tuples kernel assocs ;
USING: classes.tuple kernel assocs accessors ;
IN: refs
TUPLE: ref assoc key ;
@ -8,7 +8,7 @@ TUPLE: ref assoc key ;
: <ref> ( assoc key class -- tuple )
>r ref construct-boa r> construct-delegate ; inline
: >ref< ( ref -- key assoc ) dup ref-key swap ref-assoc ;
: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ;
: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )

6
core/sequences/sequences-tests.factor
View File

@ -169,13 +169,13 @@ unit-test
[ f ] [ { "a" "b" "c" } { "a" "b" "c" } mismatch ] unit-test
[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] 2apply ] unit-test
[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] bi@ ] unit-test
[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test
[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] bi@ ] unit-test
[ -1 1 "abc" <slice> ] must-fail
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
[ -1 ] [ "ab" "abc" <=> ] unit-test
[ 1 ] [ "abc" "ab" <=> ] unit-test

12
core/sequences/sequences.factor
View File

@ -300,9 +300,9 @@ M: immutable-sequence clone-like like ;
: change-nth ( i seq quot -- )
[ >r nth r> call ] 3keep drop set-nth ; inline
: min-length ( seq1 seq2 -- n ) [ length ] 2apply min ; inline
: min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
: max-length ( seq1 seq2 -- n ) [ length ] 2apply max ; inline
: max-length ( seq1 seq2 -- n ) [ length ] bi@ max ; inline
<PRIVATE
@ -369,7 +369,7 @@ PRIVATE>
(2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- )
>r [ <reversed> ] 2apply r> 2each ; inline
>r [ <reversed> ] bi@ r> 2each ; inline
: 2reduce ( seq1 seq2 identity quot -- result )
>r -rot r> 2each ; inline
@ -460,7 +460,7 @@ M: sequence <=>
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
: sequence= ( seq1 seq2 -- ? )
2dup [ length ] 2apply number=
2dup [ length ] bi@ number=
[ mismatch not ] [ 2drop f ] if ; inline
: move ( to from seq -- )
@ -620,12 +620,12 @@ M: sequence <=>
[ drop nip ]
[ 2drop first ]
[ >r drop first2 r> call ]
[ >r drop first3 r> 2apply ]
[ >r drop first3 r> bi@ ]
} dispatch
] [
drop
>r >r halves r> r>
[ [ binary-reduce ] 2curry 2apply ] keep
[ [ binary-reduce ] 2curry bi@ ] keep
call
] if ; inline

2
core/slots/slots-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
effects generic.standard tuples slots.private classes
effects generic.standard classes.tuple slots.private classes
strings math ;
IN: slots

6
core/slots/slots.factor
View File

@ -23,9 +23,6 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
@ -82,3 +79,6 @@ C: <slot-spec> slot-spec
dup slot-spec-offset swap slot-spec-name
define-slot-methods
] with each ;
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;

2
core/sorting/sorting.factor
View File

@ -32,7 +32,7 @@ DEFER: sort
] if ; inline
: merge ( sorted1 sorted2 quot -- result )
>r [ [ <iterator> ] 2apply ] 2keep r>
>r [ [ <iterator> ] bi@ ] 2keep r>
rot length rot length + <vector>
[ (merge) ] keep underlying ; inline

2
core/splitting/splitting.factor
View File

@ -56,7 +56,7 @@ INSTANCE: groups sequence
] if ;
: last-split1 ( seq subseq -- before after )
[ <reversed> ] 2apply split1 [ reverse ] 2apply
[ <reversed> ] bi@ split1 [ reverse ] bi@
dup [ swap ] when ;
: (split) ( separators n seq -- )

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

@ -1,6 +1,6 @@
USING: generic help.syntax help.markup kernel math parser words
effects classes generic.standard tuples generic.math arrays
io.files vocabs.loader io sequences assocs ;
effects classes generic.standard classes.tuple generic.math
arrays io.files vocabs.loader io sequences assocs ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"

6
core/syntax/syntax.factor
View File

@ -3,7 +3,7 @@
USING: alien arrays bit-arrays bit-vectors byte-arrays
byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting tuples generic.standard
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
combinators debugger ;
@ -171,9 +171,7 @@ IN: bootstrap.syntax
] define-syntax
"FORGET:" [
scan-word
dup parsing? [ V{ } clone swap execute first ] when
forget
scan-object forget
] define-syntax
"(" [

209
core/tuples/tuples.factor
View File

@ -1,209 +0,0 @@
! 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 ;
IN: tuples
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 ;
: tuple-size tuple-layout layout-size ; inline
PRIVATE>
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
dup tuple-layout
[ layout-size swap [ array-nth ] curry map ] keep
layout-class add* ;
: >tuple ( seq -- tuple )
dup first tuple-layout <tuple> [
>r 1 tail-slice dup length r>
[ tuple-size min ] keep
[ set-array-nth ] curry
2each
] keep ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
over tuple-layout over tuple-layout eq? [
dup tuple-size -rot
[ >r over r> array-nth >r array-nth r> = ] 2curry
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" word-prop length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs slot-names )
over superclass-size 2 + simple-slots
dup [ slot-spec-name ] map ;
: define-tuple-slots ( class slots -- )
dupd generate-tuple-slots
>r dupd "slots" set-word-prop
r> dupd "slot-names" set-word-prop
dup "slots" word-prop 2dup define-slots define-accessors ;
: make-tuple-layout ( class -- layout )
dup superclass-size over "slot-names" word-prop length +
over superclasses dup length 1- <tuple-layout> ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
: removed-slots ( class newslots -- seq )
swap "slot-names" word-prop seq-diff ;
: forget-slots ( class newslots -- )
dupd removed-slots [
2dup
reader-word forget-method
writer-word forget-method
] with each ;
: permutation ( seq1 seq2 -- permutation )
swap [ index ] curry map ;
: reshape-tuple ( oldtuple permutation -- newtuple )
>r tuple>array 2 cut r>
[ [ swap ?nth ] [ drop f ] if* ] with map
append >tuple ;
: reshape-tuples ( class newslots -- )
>r dup "slot-names" word-prop r> permutation
[
>r [ swap class eq? ] curry instances dup r>
[ reshape-tuple ] curry map
become
] 2curry after-compilation ;
: tuple-class-unchanged ( class superclass slots -- ) 3drop ;
: prepare-tuple-class ( class slots -- )
dupd define-tuple-slots
dup define-tuple-layout
define-tuple-predicate ;
: change-superclass "not supported" throw ;
: redefine-tuple-class ( class superclass slots -- )
>r 2dup swap superclass eq?
[ drop ] [ dupd change-superclass ] if r>
2dup forget-slots
2dup reshape-tuples
over changed-word
over redefined
prepare-tuple-class ;
: define-new-tuple-class ( class superclass slots -- )
>r dupd f swap tuple-class define-class r>
prepare-tuple-class ;
PRIVATE>
: define-tuple-class ( class superclass slots -- )
{
{ [ pick tuple-class? not ] [ define-new-tuple-class ] }
{ [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] }
{ [ t ] [ redefine-tuple-class ] }
} cond ;
: define-error-class ( class superclass slots -- )
pick >r define-tuple-class r>
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 ;
: delegates ( obj -- seq )
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
M: tuple hashcode*
[
dup tuple-size -rot 0 -rot [
swapd array-nth hashcode* bitxor
] 2curry reduce
] recursive-hashcode ;
: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
! Definition protocol
M: tuple-class reset-class
{
"metaclass" "superclass" "slot-names" "slots" "layout"
} reset-props ;
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
M: object construct-empty ( class -- tuple )
tuple-layout <tuple> ;
M: object construct ( ... slots class -- tuple )
construct-empty [ swap set-slots ] keep ;
M: object construct-boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;

2
core/vectors/vectors-tests.factor
View File

@ -77,7 +77,7 @@ IN: vectors.tests
[ f ] [
V{ 1 2 3 4 } dup clone
[ underlying ] 2apply eq?
[ underlying ] bi@ eq?
] unit-test
[ 0 ] [

4
core/vocabs/loader/loader-tests.factor
View File

@ -2,7 +2,7 @@
IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs tuples definitions
parser source-files words assocs classes.tuple definitions
debugger compiler.units tools.vocabs ;
! This vocab should not exist, but just in case...
@ -68,7 +68,7 @@ IN: vocabs.loader.tests
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
] [ [ no-word? ] is? ] must-fail-with
] [ [ no-word-error? ] is? ] must-fail-with
0 "count-me" set-global

2
core/vocabs/vocabs.factor
View File

@ -94,7 +94,7 @@ TUPLE: vocab-link name ;
M: vocab-link equal?
over vocab-link?
[ [ vocab-link-name ] 2apply = ] [ 2drop f ] if ;
[ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
M: vocab-link hashcode*
vocab-link-name hashcode* ;

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

@ -1,6 +1,7 @@
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations tuples compiler.units io.streams.string ;
vocabs continuations classes.tuple compiler.units
io.streams.string ;
IN: words.tests
[ 4 ] [

2
extra/bake/bake.factor
View File

@ -1,6 +1,6 @@
USING: kernel parser namespaces quotations arrays vectors strings
sequences assocs tuples math combinators ;
sequences assocs classes.tuple math combinators ;
IN: bake

2
extra/benchmark/benchmark.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger combinators.cleave ;
continuations debugger ;
IN: benchmark
: run-benchmark ( vocab -- result )

4
extra/benchmark/raytracer/raytracer.factor
View File

@ -133,7 +133,7 @@ DEFER: create ( level c r -- scene )
pick 1 = [ <sphere> nip ] [ create-group ] if ;
: ss-point ( dx dy -- point )
[ oversampling /f ] 2apply 0.0 3float-array ;
[ oversampling /f ] bi@ 0.0 3float-array ;
: ss-grid ( -- ss-grid )
oversampling [ oversampling [ ss-point ] with map ] map ;
@ -150,7 +150,7 @@ DEFER: create ( level c r -- scene )
: pixel-grid ( -- grid )
size reverse [
size [
[ size 0.5 * - ] 2apply swap size
[ size 0.5 * - ] bi@ swap size
3float-array
] with map
] map ;

2
extra/benchmark/reverse-complement/reverse-complement-tests.factor
View File

@ -5,7 +5,7 @@ io.files kernel ;
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
[ resource-path ] 2apply
[ resource-path ] bi@
reverse-complement
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"

2
extra/benchmark/spectral-norm/spectral-norm.factor
View File

@ -7,7 +7,7 @@ IN: benchmark.spectral-norm
: fast-truncate >fixnum >float ; inline
: eval-A ( i j -- n )
[ >float ] 2apply
[ >float ] bi@
dupd + dup 1+ * 2 /f fast-truncate + 1+
recip ; inline

2
extra/benchmark/typecheck2/typecheck2.factor
View File

@ -3,7 +3,7 @@ IN: benchmark.typecheck2
TUPLE: hello n ;
: hello-n* dup tuple? [ 4 slot ] [ 3 throw ] if ;
: hello-n* dup tuple? [ 3 slot ] [ 3 throw ] if ;
: foo 0 100000000 [ over hello-n* + ] times ;

2
extra/benchmark/typecheck3/typecheck3.factor
View File

@ -3,7 +3,7 @@ IN: benchmark.typecheck3
TUPLE: hello n ;
: hello-n* dup tag 2 eq? [ 4 slot ] [ 3 throw ] if ;
: hello-n* dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
: foo 0 100000000 [ over hello-n* + ] times ;

2
extra/benchmark/typecheck4/typecheck4.factor
View File

@ -3,7 +3,7 @@ IN: benchmark.typecheck4
TUPLE: hello n ;
: hello-n* 4 slot ;
: hello-n* 3 slot ;
: foo 0 100000000 [ over hello-n* + ] times ;

2
extra/bitfields/bitfields.factor
View File

@ -63,7 +63,7 @@ M: check< summary drop "Number exceeds upper bound" ;
[ range>accessor ] map ;
: clear-range ( range -- num )
first2 dupd + [ 2^ 1- ] 2apply bitnot bitor ;
first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ;
: range>setter ( range -- quot )
[

3
extra/boids/boids.factor
View File

@ -6,7 +6,6 @@ USING: kernel namespaces
math.vectors
math.trig
combinators arrays sequences random vars
combinators.cleave
combinators.lib ;
IN: boids
@ -81,7 +80,7 @@ VAR: separation-radius
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-position ( self other -- v ) swap [ boid-pos ] 2apply v- ;
: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ;
: relative-angle ( self other -- angle )
over boid-vel -rot relative-position angle-between ;

1
extra/boids/ui/ui.factor
View File

@ -19,7 +19,6 @@ USING: kernel namespaces
ui.gadgets.packs
ui.gadgets.grids
ui.gestures
combinators.cleave
assocs.lib vars rewrite-closures boids ;
IN: boids.ui

3
extra/bootstrap/random/random.factor
View File

@ -1,6 +1,6 @@
USING: vocabs.loader sequences system
random random.mersenne-twister combinators init
namespaces ;
namespaces random ;
"random.mersenne-twister" require
@ -9,5 +9,6 @@ namespaces ;
{ [ unix? ] [ "random.unix" require ] }
} cond
! [ [ 32 random-bits ] with-secure-random <mersenne-twister> random-generator set-global ]
[ millis <mersenne-twister> random-generator set-global ]
"generator.random" add-init-hook

4
extra/builder/benchmark/benchmark.factor
View File

@ -19,11 +19,11 @@ IN: builder.benchmark
2array ;
: compare-tables ( old new -- table )
[ passing-benchmarks ] 2apply
[ passing-benchmarks ] bi@
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
"../benchmarks" "benchmarks" [ eval-file ] 2apply
"../benchmarks" "benchmarks" [ eval-file ] bi@
compare-tables
sort-values ;

30
extra/builder/builder.factor
View File

@ -13,6 +13,12 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : cd ( path -- ) current-directory set ;
: cd ( path -- ) set-current-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
builds make-directory
builds cd
@ -42,15 +48,31 @@ IN: builder
: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
: do-make-clean ( -- ) { "make" "clean" } try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gnu-make ( -- string )
os { "freebsd" "openbsd" "netbsd" } member?
[ "gmake" ]
[ "make" ]
if ;
! : do-make-clean ( -- ) { "make" "clean" } try-process ;
: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : make-vm ( -- desc )
! <process>
! { "make" } >>command
! "../compile-log" >>stdout
! +stdout+ >>stderr ;
: make-vm ( -- desc )
<process>
{ "make" } >>command
"../compile-log" >>stdout
+stdout+ >>stderr ;
{ gnu-make } to-strings >>command
"../compile-log" >>stdout
+stdout+ >>stderr ;
: do-make-vm ( -- )
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;

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