Merge branch 'master' of http://factorcode.org/git/factor into experimental
Alex Chapman
commit
97ff9b8443
|
|
@ -15,5 +15,7 @@ factor
|
|||
.gdb_history
|
||||
*.*.marks
|
||||
.*.swp
|
||||
reverse-complement-in.txt
|
||||
reverse-complement-out.txt
|
||||
temp
|
||||
logs
|
||||
work
|
||||
misc/wordsize
|
||||
11
Makefile
11
Makefile
|
|
@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
|
||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||
|
||||
default:
|
||||
default: misc/wordsize
|
||||
make `./misc/target`
|
||||
|
||||
help:
|
||||
@echo "Run 'make' with one of the following parameters:"
|
||||
@echo ""
|
||||
@echo "freebsd-x86-32"
|
||||
|
|
@ -142,7 +145,8 @@ wince-arm:
|
|||
|
||||
macosx.app: factor
|
||||
mkdir -p $(BUNDLE)/Contents/MacOS
|
||||
cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
|
||||
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
|
||||
ln -s Factor.app/Contents/MacOS/factor ./factor
|
||||
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
|
||||
|
||||
install_name_tool \
|
||||
|
|
@ -158,6 +162,9 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
|
|||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
misc/wordsize: misc/wordsize.c
|
||||
gcc misc/wordsize.c -o misc/wordsize
|
||||
|
||||
clean:
|
||||
rm -f vm/*.o
|
||||
rm -f factor*.dll libfactor*.*
|
||||
|
|
|
|||
|
|
@ -52,7 +52,9 @@ The Factor runtime is written in GNU C99, and is built with GNU make and
|
|||
gcc.
|
||||
|
||||
Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
|
||||
3.3 or earlier.
|
||||
3.3 or earlier. If you are using gcc 4.3, you might get an unusable
|
||||
Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
|
||||
command-line arguments for make.
|
||||
|
||||
Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
|
||||
targets and build options. Then run 'make' with the appropriate target
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ $nl
|
|||
HELP: alien-invoke-error
|
||||
{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||
{ $list
|
||||
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
|
||||
{ "The return type or parameter list references an unknown C type." }
|
||||
{ "The symbol or library could not be found." }
|
||||
{ "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
|
||||
|
|
@ -103,7 +103,7 @@ HELP: alien-invoke
|
|||
HELP: alien-indirect-error
|
||||
{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||
{ $list
|
||||
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
|
||||
{ "The return type or parameter list references an unknown C type." }
|
||||
{ "One of the three inputs to " { $link alien-indirect } " is not a literal value." }
|
||||
}
|
||||
|
|
@ -120,7 +120,7 @@ HELP: alien-indirect
|
|||
HELP: alien-callback-error
|
||||
{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||
{ $list
|
||||
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
|
||||
{ "The return type or parameter list references an unknown C type." }
|
||||
{ "One of the four inputs to " { $link alien-callback } " is not a literal value." }
|
||||
}
|
||||
|
|
@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor"
|
|||
{ $subsection alien-invoke }
|
||||
"Sometimes it is necessary to invoke a C function pointer, rather than a named C function:"
|
||||
{ $subsection alien-indirect }
|
||||
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
|
||||
$nl
|
||||
"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ;
|
||||
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ;
|
||||
|
||||
ARTICLE: "alien-callback-gc" "Callbacks and code GC"
|
||||
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: alien.tests
|
||||
USING: alien alien.accessors byte-arrays arrays kernel
|
||||
kernel.private namespaces tools.test sequences libc math system
|
||||
prettyprint ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: alien.c-types.tests
|
||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: alien.compiler.tests
|
||||
USING: alien alien.c-types alien.syntax compiler kernel
|
||||
namespaces namespaces tools.test sequences inference words
|
||||
arrays parser quotations continuations inference.backend effects
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generator generator.registers generator.fixup
|
||||
hashtables kernel math namespaces sequences words
|
||||
|
|
@ -367,7 +367,7 @@ TUPLE: callback-context ;
|
|||
] if ;
|
||||
|
||||
: do-callback ( quot token -- )
|
||||
init-error-handler
|
||||
init-catchstack
|
||||
dup 2 setenv
|
||||
slip
|
||||
wait-to-return ; inline
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: alien.structs.tests
|
||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc words vocabs namespaces ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays kernel sequences sequences.private growable
|
||||
tools.test vectors layouts system math vectors.private ;
|
||||
IN: temporary
|
||||
IN: arrays.tests
|
||||
|
||||
[ -2 { "a" "b" "c" } nth ] must-fail
|
||||
[ 10 { "a" "b" "c" } nth ] must-fail
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: assocs.tests
|
||||
USING: kernel math namespaces tools.test vectors sequences
|
||||
sequences.private hashtables io prettyprint assocs
|
||||
continuations ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: sequences arrays bit-arrays kernel tools.test math
|
||||
random ;
|
||||
IN: temporary
|
||||
IN: bit-arrays.tests
|
||||
|
||||
[ 100 ] [ 100 <bit-array> length ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: bit-vectors.tests
|
||||
USING: tools.test bit-vectors vectors sequences kernel math ;
|
||||
|
||||
[ 0 ] [ 123 <bit-vector> length ] unit-test
|
||||
|
|
|
|||
|
|
@ -16,6 +16,14 @@ IN: bootstrap.compiler
|
|||
|
||||
"cpu." cpu append require
|
||||
|
||||
: enable-compiler ( -- )
|
||||
[ optimized-recompile-hook ] recompile-hook set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
[ default-recompile-hook ] recompile-hook set-global ;
|
||||
|
||||
enable-compiler
|
||||
|
||||
nl
|
||||
"Compiling some words to speed up bootstrap..." write flush
|
||||
|
||||
|
|
@ -74,12 +82,4 @@ nl
|
|||
malloc free memcpy
|
||||
} compile
|
||||
|
||||
: enable-compiler ( -- )
|
||||
[ compiled-usages recompile ] recompile-hook set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
[ default-recompile-hook ] recompile-hook set-global ;
|
||||
|
||||
enable-compiler
|
||||
|
||||
" done" print flush
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: bootstrap.image.tests
|
||||
USING: bootstrap.image bootstrap.image.private tools.test ;
|
||||
|
||||
\ ' must-infer
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ IN: bootstrap.image
|
|||
|
||||
: data-base 1024 ; inline
|
||||
|
||||
: userenv-size 40 ; inline
|
||||
: userenv-size 64 ; inline
|
||||
|
||||
: header-size 10 ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -30,7 +30,10 @@ crossref off
|
|||
"syntax" vocab vocab-words bootstrap-syntax set
|
||||
H{ } clone dictionary set
|
||||
H{ } clone changed-words set
|
||||
[ drop ] recompile-hook set
|
||||
|
||||
! Trivial recompile hook. We don't want to touch the code heap
|
||||
! during stage1 bootstrap, it would just waste time.
|
||||
[ drop { } ] recompile-hook set
|
||||
|
||||
call
|
||||
call
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: bootstrap.stage1
|
||||
USING: arrays debugger generic hashtables io assocs
|
||||
kernel.private kernel math memory namespaces parser
|
||||
prettyprint sequences vectors words system splitting
|
||||
init io.files bootstrap.image bootstrap.image.private vocabs
|
||||
vocabs.loader system ;
|
||||
vocabs.loader system debugger continuations ;
|
||||
|
||||
{ "resource:core" } vocab-roots set
|
||||
|
||||
|
|
@ -31,6 +31,7 @@ vocabs.loader system ;
|
|||
"libc" require
|
||||
|
||||
"io.streams.c" require
|
||||
"io.thread" require
|
||||
"vocabs.loader" require
|
||||
|
||||
"syntax" require
|
||||
|
|
@ -39,7 +40,14 @@ vocabs.loader system ;
|
|||
[
|
||||
"resource:core/bootstrap/stage2.factor"
|
||||
dup resource-exists? [
|
||||
run-file
|
||||
[ run-file ]
|
||||
[
|
||||
:c
|
||||
dup print-error flush
|
||||
"listener" vocab
|
||||
[ restarts. vocab-main execute ]
|
||||
[ die ] if*
|
||||
] recover
|
||||
] [
|
||||
"Cannot find " write write "." print
|
||||
"Please move " write image write " to the same directory as the Factor sources," print
|
||||
|
|
|
|||
|
|
@ -29,9 +29,7 @@ SYMBOL: bootstrap-time
|
|||
|
||||
: compile-remaining ( -- )
|
||||
"Compiling remaining words..." print flush
|
||||
vocabs [
|
||||
words "compile" "compiler" lookup execute
|
||||
] each ;
|
||||
vocabs [ words [ compiled? not ] subset compile ] each ;
|
||||
|
||||
: count-words ( pred -- )
|
||||
all-words swap subset length number>string write ;
|
||||
|
|
@ -53,66 +51,60 @@ SYMBOL: bootstrap-time
|
|||
! Wrap everything in a catch which starts a listener so
|
||||
! you can see what went wrong, instead of dealing with a
|
||||
! fep
|
||||
[
|
||||
! We time bootstrap
|
||||
millis >r
|
||||
|
||||
default-image-name "output-image" set-global
|
||||
! We time bootstrap
|
||||
millis >r
|
||||
|
||||
"math help handbook compiler tools ui ui.tools io" "include" set-global
|
||||
"" "exclude" set-global
|
||||
default-image-name "output-image" set-global
|
||||
|
||||
parse-command-line
|
||||
"math help handbook compiler tools ui ui.tools io" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
"-no-crossref" cli-args member? [ do-crossref ] unless
|
||||
parse-command-line
|
||||
|
||||
! Set dll paths
|
||||
wince? [ "windows.ce" require ] when
|
||||
winnt? [ "windows.nt" require ] when
|
||||
"-no-crossref" cli-args member? [ do-crossref ] unless
|
||||
|
||||
"deploy-vocab" get [
|
||||
"stage2: deployment mode" print
|
||||
] [
|
||||
"listener" require
|
||||
"none" require
|
||||
] if
|
||||
! Set dll paths
|
||||
wince? [ "windows.ce" require ] when
|
||||
winnt? [ "windows.nt" require ] when
|
||||
|
||||
[
|
||||
load-components
|
||||
|
||||
run-bootstrap-init
|
||||
|
||||
"bootstrap.compiler" vocab [
|
||||
compile-remaining
|
||||
] when
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
|
||||
f error set-global
|
||||
f error-continuation set-global
|
||||
|
||||
"deploy-vocab" get [
|
||||
"tools.deploy.shaker" run
|
||||
] [
|
||||
[
|
||||
boot
|
||||
do-init-hooks
|
||||
[
|
||||
parse-command-line
|
||||
run-user-init
|
||||
"run" get run
|
||||
stdio get [ stream-flush ] when*
|
||||
] [ print-error 1 exit ] recover
|
||||
] set-boot-quot
|
||||
|
||||
millis r> - dup bootstrap-time set-global
|
||||
print-report
|
||||
|
||||
"output-image" get resource-path save-image-and-exit
|
||||
] if
|
||||
"deploy-vocab" get [
|
||||
"stage2: deployment mode" print
|
||||
] [
|
||||
:c
|
||||
print-error restarts.
|
||||
"listener" vocab-main execute
|
||||
1 exit
|
||||
] recover
|
||||
"listener" require
|
||||
"none" require
|
||||
] if
|
||||
|
||||
[
|
||||
load-components
|
||||
|
||||
run-bootstrap-init
|
||||
|
||||
"bootstrap.compiler" vocab [
|
||||
compile-remaining
|
||||
] when
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
|
||||
f error set-global
|
||||
f error-continuation set-global
|
||||
|
||||
"deploy-vocab" get [
|
||||
"tools.deploy.shaker" run
|
||||
] [
|
||||
[
|
||||
boot
|
||||
do-init-hooks
|
||||
[
|
||||
parse-command-line
|
||||
run-user-init
|
||||
"run" get run
|
||||
stdio get [ stream-flush ] when*
|
||||
] [ print-error 1 exit ] recover
|
||||
] set-boot-quot
|
||||
|
||||
millis r> - dup bootstrap-time set-global
|
||||
print-report
|
||||
|
||||
"output-image" get resource-path save-image-and-exit
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -0,0 +1,38 @@
|
|||
USING: help.markup help.syntax kernel ;
|
||||
IN: boxes
|
||||
|
||||
HELP: box
|
||||
{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ;
|
||||
|
||||
HELP: <box>
|
||||
{ $values { "box" box } }
|
||||
{ $description "Creates a new empty box." } ;
|
||||
|
||||
HELP: >box
|
||||
{ $values { "value" object } { "box" box } }
|
||||
{ $description "Stores a value into a box." }
|
||||
{ $errors "Throws an error if the box is full." } ;
|
||||
|
||||
HELP: box>
|
||||
{ $values { "box" box } { "value" "the value of the box" } }
|
||||
{ $description "Removes a value from a box." }
|
||||
{ $errors "Throws an error if the box is empty." } ;
|
||||
|
||||
HELP: ?box
|
||||
{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } }
|
||||
{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;
|
||||
|
||||
ARTICLE: "boxes" "Boxes"
|
||||
"A " { $emphasis "box" } " is a container which can either be empty or hold a single value."
|
||||
{ $subsection box }
|
||||
"Creating an empty box:"
|
||||
{ $subsection <box> }
|
||||
"Testing if a box is full:"
|
||||
{ $subsection box-full? }
|
||||
"Storing a value and removing a value from a box:"
|
||||
{ $subsection >box }
|
||||
{ $subsection box> }
|
||||
"Safely removing a value:"
|
||||
{ $subsection ?box } ;
|
||||
|
||||
ABOUT: "boxes"
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
IN: boxes.tests
|
||||
USING: boxes namespaces tools.test ;
|
||||
|
||||
[ ] [ <box> "b" set ] unit-test
|
||||
|
||||
[ ] [ 3 "b" get >box ] unit-test
|
||||
|
||||
[ t ] [ "b" get box-full? ] unit-test
|
||||
|
||||
[ 4 "b" >box ] must-fail
|
||||
|
||||
[ 3 ] [ "b" get box> ] unit-test
|
||||
|
||||
[ f ] [ "b" get box-full? ] unit-test
|
||||
|
||||
[ "b" get box> ] must-fail
|
||||
|
||||
[ f f ] [ "b" get ?box ] unit-test
|
||||
|
||||
[ ] [ 12 "b" get >box ] unit-test
|
||||
|
||||
[ 12 t ] [ "b" get ?box ] unit-test
|
||||
|
||||
[ f ] [ "b" get box-full? ] unit-test
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel ;
|
||||
IN: boxes
|
||||
|
||||
TUPLE: box value full? ;
|
||||
|
||||
: <box> ( -- box ) box construct-empty ;
|
||||
|
||||
: >box ( value box -- )
|
||||
dup box-full? [ "Box already has a value" throw ] when
|
||||
t over set-box-full?
|
||||
set-box-value ;
|
||||
|
||||
: box> ( box -- value )
|
||||
dup box-full? [ "Box empty" throw ] unless
|
||||
dup box-value f pick set-box-value
|
||||
f rot set-box-full? ;
|
||||
|
||||
: ?box ( box -- value/f ? )
|
||||
dup box-full? [ box> t ] [ drop f f ] if ;
|
||||
|
||||
: if-box? ( box quot -- )
|
||||
>r ?box r> [ drop ] if ; inline
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: byte-arrays.tests
|
||||
USING: tools.test byte-arrays ;
|
||||
|
||||
[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: byte-vectors.tests
|
||||
USING: tools.test byte-vectors vectors sequences kernel ;
|
||||
|
||||
[ 0 ] [ 123 <byte-vector> length ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
|
|||
tools.test vectors words quotations classes io.streams.string
|
||||
classes.private classes.union classes.mixin classes.predicate
|
||||
vectors definitions source-files compiler.units ;
|
||||
IN: temporary
|
||||
IN: classes.tests
|
||||
|
||||
H{ } "s" set
|
||||
|
||||
|
|
@ -62,7 +62,7 @@ UNION: bah fixnum alien ;
|
|||
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
||||
|
||||
! Test generic see and parsing
|
||||
[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ]
|
||||
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] with-string-writer ] unit-test
|
||||
|
||||
! Test redefinition of classes
|
||||
|
|
@ -78,7 +78,7 @@ M: union-1 generic-update-test drop "union-1" ;
|
|||
|
||||
[ union-1 ] [ fixnum float class-or ] unit-test
|
||||
|
||||
"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval
|
||||
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
|
||||
|
||||
[ t ] [ bignum union-1 class< ] unit-test
|
||||
[ f ] [ union-1 number class< ] unit-test
|
||||
|
|
@ -86,7 +86,7 @@ M: union-1 generic-update-test drop "union-1" ;
|
|||
|
||||
[ object ] [ fixnum float class-or ] unit-test
|
||||
|
||||
"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval
|
||||
"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
|
||||
|
||||
[ f ] [ union-1 union-class? ] unit-test
|
||||
[ t ] [ union-1 predicate-class? ] unit-test
|
||||
|
|
@ -126,7 +126,7 @@ INSTANCE: integer mx1
|
|||
[ t ] [ mx1 integer class< ] unit-test
|
||||
[ t ] [ mx1 number class< ] unit-test
|
||||
|
||||
"IN: temporary USE: arrays INSTANCE: array mx1" eval
|
||||
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
|
||||
|
||||
[ t ] [ array mx1 class< ] unit-test
|
||||
[ f ] [ mx1 number class< ] unit-test
|
||||
|
|
@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
|
|||
[ t ] [ quotation redefine-bug-2 class< ] unit-test
|
||||
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
|
||||
|
||||
[ t ] [ bignum redefine-bug-1 class< ] unit-test
|
||||
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
|
||||
|
|
@ -185,7 +185,7 @@ DEFER: mixin-forget-test-g
|
|||
[ ] [
|
||||
{
|
||||
"USING: sequences ;"
|
||||
"IN: temporary"
|
||||
"IN: classes.tests"
|
||||
"MIXIN: mixin-forget-test"
|
||||
"INSTANCE: sequence mixin-forget-test"
|
||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||
|
|
@ -200,7 +200,7 @@ DEFER: mixin-forget-test-g
|
|||
[ ] [
|
||||
{
|
||||
"USING: hashtables ;"
|
||||
"IN: temporary"
|
||||
"IN: classes.tests"
|
||||
"MIXIN: mixin-forget-test"
|
||||
"INSTANCE: hashtable mixin-forget-test"
|
||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||
|
|
|
|||
|
|
@ -255,8 +255,7 @@ PRIVATE>
|
|||
|
||||
: (define-class) ( word props -- )
|
||||
over reset-class
|
||||
over reset-generic
|
||||
over define-symbol
|
||||
over deferred? [ over define-symbol ] when
|
||||
>r dup word-props r> union over set-word-props
|
||||
t "class" set-word-prop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: combinators.tests
|
||||
USING: alien strings kernel math tools.test io prettyprint
|
||||
namespaces combinators words ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: namespaces tools.test kernel command-line ;
|
||||
IN: temporary
|
||||
IN: command-line.tests
|
||||
|
||||
[
|
||||
[ f ] [ "-no-user-init" cli-arg ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,18 +1,14 @@
|
|||
USING: generator help.markup help.syntax words io parser
|
||||
assocs words.private sequences ;
|
||||
assocs words.private sequences compiler.units ;
|
||||
IN: compiler
|
||||
|
||||
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
||||
"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
|
||||
$nl
|
||||
"The main entry points to the optimizing compiler:"
|
||||
{ $subsection compile }
|
||||
{ $subsection recompile }
|
||||
{ $subsection recompile-all }
|
||||
"The main entry point to the optimizing compiler:"
|
||||
{ $subsection optimized-recompile-hook }
|
||||
"Removing a word's optimized definition:"
|
||||
{ $subsection decompile }
|
||||
"The optimizing compiler can also compile and call a single quotation:"
|
||||
{ $subsection compile-call } ;
|
||||
{ $subsection decompile } ;
|
||||
|
||||
ARTICLE: "compiler" "Optimizing compiler"
|
||||
"Factor is a fully compiled language implementation with two distinct compilers:"
|
||||
|
|
@ -26,22 +22,6 @@ ARTICLE: "compiler" "Optimizing compiler"
|
|||
|
||||
ABOUT: "compiler"
|
||||
|
||||
HELP: compile
|
||||
{ $values { "seq" "a sequence of words" } }
|
||||
{ $description "Compiles a set of words. Ignores words which are already compiled." } ;
|
||||
|
||||
HELP: recompile
|
||||
{ $values { "seq" "a sequence of words" } }
|
||||
{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ;
|
||||
|
||||
HELP: compile-call
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Compiles and runs a quotation." }
|
||||
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
|
||||
|
||||
HELP: recompile-all
|
||||
{ $description "Recompiles all words." } ;
|
||||
|
||||
HELP: decompile
|
||||
{ $values { "word" word } }
|
||||
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
|
||||
|
|
@ -50,3 +30,8 @@ HELP: (compile)
|
|||
{ $values { "word" word } }
|
||||
{ $description "Compile a single word." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
||||
HELP: optimized-recompile-hook
|
||||
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
|
||||
{ $description "Compile a set of words." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
|
|
|||
|
|
@ -4,14 +4,9 @@ USING: kernel namespaces arrays sequences io inference.backend
|
|||
inference.state generator debugger math.parser prettyprint words
|
||||
compiler.units continuations vocabs assocs alien.compiler dlists
|
||||
optimizer definitions math compiler.errors threads graphs
|
||||
generic ;
|
||||
generic inference ;
|
||||
IN: compiler
|
||||
|
||||
: compiled-usages ( words -- seq )
|
||||
[ [ dup ] H{ } map>assoc dup ] keep [
|
||||
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
|
||||
] with each keys ;
|
||||
|
||||
: ripple-up ( word -- )
|
||||
compiled-usage [ drop queue-compile ] assoc-each ;
|
||||
|
||||
|
|
@ -49,27 +44,17 @@ IN: compiler
|
|||
compile-loop
|
||||
] if ;
|
||||
|
||||
: recompile ( words -- )
|
||||
: decompile ( word -- )
|
||||
f 2array 1array t modify-code-heap ;
|
||||
|
||||
: optimized-recompile-hook ( words -- alist )
|
||||
[
|
||||
H{ } clone compile-queue set
|
||||
H{ } clone compiled set
|
||||
[ queue-compile ] each
|
||||
compile-queue get compile-loop
|
||||
compiled get >alist
|
||||
dup [ drop crossref? ] assoc-contains?
|
||||
modify-code-heap
|
||||
] with-scope ; inline
|
||||
|
||||
: compile ( words -- )
|
||||
[ compiled? not ] subset recompile ;
|
||||
|
||||
: compile-call ( quot -- )
|
||||
H{ } clone changed-words
|
||||
[ define-temp dup 1array compile ] with-variable
|
||||
execute ;
|
||||
] with-scope ;
|
||||
|
||||
: recompile-all ( -- )
|
||||
[ all-words recompile ] with-compiler-errors ;
|
||||
|
||||
: decompile ( word -- )
|
||||
f 2array 1array t modify-code-heap ;
|
||||
forget-errors all-words compile ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: tools.test compiler quotations math kernel sequences
|
||||
assocs namespaces ;
|
||||
IN: temporary
|
||||
USING: tools.test quotations math kernel sequences
|
||||
assocs namespaces compiler.units ;
|
||||
IN: compiler.tests
|
||||
|
||||
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
|
||||
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: compiler kernel kernel.private memory math
|
||||
IN: compiler.tests
|
||||
USING: compiler.units kernel kernel.private memory math
|
||||
math.private tools.test math.floats.private ;
|
||||
|
||||
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
IN: temporary
|
||||
USING: arrays compiler kernel kernel.private math math.constants
|
||||
math.private sequences strings tools.test words continuations
|
||||
sequences.private hashtables.private byte-arrays strings.private
|
||||
system random layouts vectors.private sbufs.private
|
||||
strings.private slots.private alien alien.accessors
|
||||
alien.c-types alien.syntax namespaces libc sequences.private ;
|
||||
IN: compiler.tests
|
||||
USING: arrays compiler.units kernel kernel.private math
|
||||
math.constants math.private sequences strings tools.test words
|
||||
continuations sequences.private hashtables.private byte-arrays
|
||||
strings.private system random layouts vectors.private
|
||||
sbufs.private strings.private slots.private alien
|
||||
alien.accessors alien.c-types alien.syntax namespaces libc
|
||||
sequences.private ;
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
[ ] [ 1 [ drop ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: compiler tools.test kernel kernel.private
|
||||
USING: compiler.units tools.test kernel kernel.private
|
||||
sequences.private math.private math combinators strings
|
||||
alien arrays memory ;
|
||||
IN: temporary
|
||||
IN: compiler.tests
|
||||
|
||||
! Test empty word
|
||||
[ ] [ [ ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: compiler.tests
|
||||
USING: compiler tools.test namespaces sequences
|
||||
kernel.private kernel math continuations continuations.private
|
||||
words splitting sorting ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! Testing templates machinery without compiling anything
|
||||
IN: temporary
|
||||
IN: compiler.tests
|
||||
USING: compiler generator generator.registers
|
||||
generator.registers.private tools.test namespaces sequences
|
||||
words kernel math effects definitions compiler.units ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ hashtables.private math.private namespaces sequences
|
|||
sequences.private tools.test namespaces.private slots.private
|
||||
sequences.private byte-arrays alien alien.accessors layouts
|
||||
words definitions compiler.units io combinators ;
|
||||
IN: temporary
|
||||
IN: compiler.tests
|
||||
|
||||
! Oops!
|
||||
[ 5000 ] [ [ 5000 ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: kernel tools.test compiler ;
|
||||
IN: compiler.tests
|
||||
USING: kernel tools.test compiler.units ;
|
||||
|
||||
TUPLE: color red green blue ;
|
||||
|
||||
|
|
|
|||
|
|
@ -61,3 +61,11 @@ HELP: modify-code-heap ( alist -- )
|
|||
{ { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
|
||||
} }
|
||||
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;
|
||||
|
||||
HELP: compile
|
||||
{ $values { "seq" "a sequence of words" } }
|
||||
{ $description "Compiles a set of words." } ;
|
||||
|
||||
HELP: compile-call
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Compiles and runs a quotation." } ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel continuations assocs namespaces sequences words
|
||||
vocabs definitions hashtables ;
|
||||
vocabs definitions hashtables init ;
|
||||
IN: compiler.units
|
||||
|
||||
SYMBOL: old-definitions
|
||||
|
|
@ -37,10 +37,11 @@ SYMBOL: recompile-hook
|
|||
|
||||
SYMBOL: definition-observers
|
||||
|
||||
definition-observers global [ V{ } like ] change-at
|
||||
|
||||
GENERIC: definitions-changed ( assoc obj -- )
|
||||
|
||||
[ V{ } clone definition-observers set-global ]
|
||||
"compiler.units" add-init-hook
|
||||
|
||||
: add-definition-observer ( obj -- )
|
||||
definition-observers get push ;
|
||||
|
||||
|
|
@ -63,24 +64,45 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
dup changed-words get update
|
||||
dup dup changed-vocabs update ;
|
||||
|
||||
: compile ( words -- )
|
||||
recompile-hook get call
|
||||
dup [ drop crossref? ] assoc-contains?
|
||||
modify-code-heap ;
|
||||
|
||||
SYMBOL: post-compile-tasks
|
||||
|
||||
: after-compilation ( quot -- )
|
||||
post-compile-tasks get push ;
|
||||
|
||||
: call-recompile-hook ( -- )
|
||||
changed-words get keys
|
||||
compiled-usages recompile-hook get call ;
|
||||
|
||||
: call-post-compile-tasks ( -- )
|
||||
post-compile-tasks get [ call ] each ;
|
||||
|
||||
: finish-compilation-unit ( -- )
|
||||
changed-words get keys recompile-hook get call
|
||||
call-recompile-hook
|
||||
call-post-compile-tasks
|
||||
dup [ drop crossref? ] assoc-contains? modify-code-heap
|
||||
changed-definitions notify-definition-observers ;
|
||||
|
||||
: with-compilation-unit ( quot -- )
|
||||
[
|
||||
H{ } clone changed-words set
|
||||
H{ } clone forgotten-definitions set
|
||||
V{ } clone post-compile-tasks set
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[ finish-compilation-unit ]
|
||||
[ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: default-recompile-hook
|
||||
[ f ] { } map>assoc
|
||||
dup [ drop crossref? ] assoc-contains?
|
||||
modify-code-heap ;
|
||||
: compile-call ( quot -- )
|
||||
[ define-temp ] with-compilation-unit execute ;
|
||||
|
||||
: default-recompile-hook ( words -- alist )
|
||||
[ f ] { } map>assoc ;
|
||||
|
||||
recompile-hook global
|
||||
[ [ default-recompile-hook ] or ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax kernel kernel.private
|
||||
continuations.private parser vectors arrays namespaces
|
||||
threads assocs words quotations ;
|
||||
assocs words quotations ;
|
||||
IN: continuations
|
||||
|
||||
ARTICLE: "errors-restartable" "Restartable errors"
|
||||
|
|
@ -23,9 +23,10 @@ $nl
|
|||
"Two words raise an error in the innermost error handler for the current dynamic extent:"
|
||||
{ $subsection throw }
|
||||
{ $subsection rethrow }
|
||||
"Two words for establishing an error handler:"
|
||||
"Words for establishing an error handler:"
|
||||
{ $subsection cleanup }
|
||||
{ $subsection recover }
|
||||
{ $subsection ignore-errors }
|
||||
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
|
||||
{ $subsection "errors-restartable" }
|
||||
{ $subsection "errors-post-mortem" } ;
|
||||
|
|
@ -44,11 +45,7 @@ ARTICLE: "continuations.private" "Continuation implementation details"
|
|||
{ $subsection namestack }
|
||||
{ $subsection set-namestack }
|
||||
{ $subsection catchstack }
|
||||
{ $subsection set-catchstack }
|
||||
"The continuations implementation has hooks for single-steppers:"
|
||||
{ $subsection walker-hook }
|
||||
{ $subsection set-walker-hook }
|
||||
{ $subsection (continue-with) } ;
|
||||
{ $subsection set-catchstack } ;
|
||||
|
||||
ARTICLE: "continuations" "Continuations"
|
||||
"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
|
||||
|
|
@ -110,10 +107,6 @@ HELP: callcc1
|
|||
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
|
||||
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
|
||||
|
||||
HELP: (continue-with)
|
||||
{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
|
||||
{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ;
|
||||
|
||||
HELP: continue
|
||||
{ $values { "continuation" continuation } }
|
||||
{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;
|
||||
|
|
@ -156,6 +149,10 @@ HELP: recover
|
|||
{ $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } }
|
||||
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
|
||||
|
||||
HELP: ignore-errors
|
||||
{ $values { "try" quotation } }
|
||||
{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
|
||||
|
||||
HELP: rethrow
|
||||
{ $values { "error" object } }
|
||||
{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
|
||||
|
|
@ -196,9 +193,3 @@ HELP: save-error
|
|||
{ $values { "error" "an error" } }
|
||||
{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: init-error-handler
|
||||
{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;
|
||||
|
||||
HELP: break
|
||||
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: kernel math namespaces io tools.test sequences vectors
|
||||
continuations debugger parser memory arrays words
|
||||
kernel.private ;
|
||||
IN: temporary
|
||||
IN: continuations.tests
|
||||
|
||||
: (callcc1-test)
|
||||
swap 1- tuck swap ?push
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ IN: continuations
|
|||
|
||||
SYMBOL: error
|
||||
SYMBOL: error-continuation
|
||||
SYMBOL: error-thread
|
||||
SYMBOL: restarts
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -24,6 +25,8 @@ SYMBOL: restarts
|
|||
#! with a declaration.
|
||||
f { object } declare ;
|
||||
|
||||
: init-catchstack V{ } clone 1 setenv ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: catchstack ( -- catchstack ) catchstack* clone ; inline
|
||||
|
|
@ -91,14 +94,8 @@ C: <continuation> continuation
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: set-walker-hook ( quot -- ) 3 setenv ; inline
|
||||
|
||||
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
|
||||
|
||||
: continue-with ( obj continuation -- )
|
||||
[
|
||||
walker-hook [ >r 2array r> ] when* (continue-with)
|
||||
] 2 (throw) ;
|
||||
[ (continue-with) ] 2 (throw) ;
|
||||
|
||||
: continue ( continuation -- )
|
||||
f swap continue-with ;
|
||||
|
|
@ -113,13 +110,22 @@ GENERIC: compute-restarts ( error -- seq )
|
|||
|
||||
PRIVATE>
|
||||
|
||||
SYMBOL: thread-error-hook
|
||||
|
||||
: rethrow ( error -- * )
|
||||
catchstack* empty? [ die ] when
|
||||
dup save-error c> continue-with ;
|
||||
dup save-error
|
||||
catchstack* empty? [
|
||||
thread-error-hook get-global
|
||||
[ 1 (throw) ] [ die ] if*
|
||||
] when
|
||||
c> continue-with ;
|
||||
|
||||
: recover ( try recovery -- )
|
||||
>r [ swap >c call c> drop ] curry r> ifcc ; inline
|
||||
|
||||
: ignore-errors ( quot -- )
|
||||
[ drop ] recover ; inline
|
||||
|
||||
: cleanup ( try cleanup-always cleanup-error -- )
|
||||
over >r compose [ dip rethrow ] curry
|
||||
recover r> call ; inline
|
||||
|
|
@ -166,34 +172,3 @@ M: condition compute-restarts
|
|||
condition-continuation
|
||||
[ <restart> ] curry { } assoc>map
|
||||
append ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: init-error-handler ( -- )
|
||||
V{ } clone set-catchstack
|
||||
! VM calls on error
|
||||
[
|
||||
continuation error-continuation set-global rethrow
|
||||
] 5 setenv
|
||||
! VM adds this to kernel errors, so that user-space
|
||||
! can identify them
|
||||
"kernel-error" 6 setenv ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Debugging support
|
||||
: with-walker-hook ( continuation -- )
|
||||
[ swap set-walker-hook (continue) ] curry callcc1 ;
|
||||
|
||||
SYMBOL: break-hook
|
||||
|
||||
: break ( -- )
|
||||
continuation callstack
|
||||
over set-continuation-call
|
||||
walker-hook [ (continue-with) ] [ break-hook get call ] if* ;
|
||||
|
||||
GENERIC: (step-into) ( obj -- )
|
||||
|
||||
M: wrapper (step-into) wrapped break ;
|
||||
M: object (step-into) break ;
|
||||
M: callable (step-into) \ break add* break ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: cpu.arm.assembler.tests
|
||||
USING: assembler-arm math test namespaces sequences kernel
|
||||
quotations ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types arrays cpu.x86.assembler
|
||||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
|
||||
cpu.architecture kernel kernel.private math namespaces sequences
|
||||
generator.registers generator.fixup generator system
|
||||
alien.compiler combinators command-line
|
||||
compiler io vocabs.loader ;
|
||||
compiler compiler.units io vocabs.loader ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
PREDICATE: x86-backend x86-32-backend
|
||||
|
|
@ -281,7 +281,10 @@ T{ x86-backend f 4 } compiler-backend set-global
|
|||
|
||||
"-no-sse2" cli-args member? [
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
[ sse2? ] compile-call [
|
||||
[ optimized-recompile-hook ] recompile-hook [
|
||||
[ sse2? ] compile-call
|
||||
] with-variable
|
||||
[
|
||||
" - yes" print
|
||||
"cpu.x86.sse2" require
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: cpu.x86.assembler kernel tools.test namespaces ;
|
||||
IN: temporary
|
||||
IN: cpu.x86.assembler.tests
|
||||
|
||||
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
|
||||
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien arrays generic generic.math help.markup help.syntax
|
||||
kernel math memory strings sbufs vectors io io.files classes
|
||||
help generic.standard continuations system ;
|
||||
help generic.standard continuations system debugger.private ;
|
||||
IN: debugger
|
||||
|
||||
ARTICLE: "errors-assert" "Assertions"
|
||||
|
|
@ -80,9 +80,6 @@ HELP: print-error
|
|||
HELP: restarts.
|
||||
{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
|
||||
|
||||
HELP: debug-help
|
||||
{ $description "Print a synopsis of useful debugger words." } ;
|
||||
|
||||
HELP: error-hook
|
||||
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
|
||||
{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
|
||||
|
|
@ -169,3 +166,6 @@ HELP: depth
|
|||
HELP: assert-depth
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;
|
||||
|
||||
HELP: init-debugger
|
||||
{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: debugger.tests
|
||||
USING: debugger kernel continuations tools.test ;
|
||||
|
||||
[ ] [ [ drop ] [ error. ] recover ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private
|
|||
strings io.styles vectors words system splitting math.parser
|
||||
tuples continuations continuations.private combinators
|
||||
generic.math io.streams.duplex classes compiler.units
|
||||
generic.standard vocabs ;
|
||||
generic.standard vocabs threads threads.private init
|
||||
kernel.private libc ;
|
||||
IN: debugger
|
||||
|
||||
GENERIC: error. ( error -- )
|
||||
|
|
@ -31,6 +32,9 @@ M: string error. print ;
|
|||
: :get ( variable -- value )
|
||||
error-continuation get continuation-name assoc-stack ;
|
||||
|
||||
: :vars ( -- )
|
||||
error-continuation get continuation-name namestack. ;
|
||||
|
||||
: :res ( n -- )
|
||||
1- restarts get-global nth f restarts set-global restart ;
|
||||
|
||||
|
|
@ -54,19 +58,6 @@ M: string error. print ;
|
|||
dup length [ restart. ] 2each
|
||||
] if ;
|
||||
|
||||
: debug-help ( -- )
|
||||
nl
|
||||
"Debugger commands:" print
|
||||
nl
|
||||
":help - documentation for this error" print
|
||||
":s - data stack at exception time" print
|
||||
":r - retain stack at exception time" print
|
||||
":c - call stack at exception time" print
|
||||
":edit - jump to source location (parse errors only)" print
|
||||
|
||||
":get ( var -- value ) accesses variables at time of the error" print
|
||||
flush ;
|
||||
|
||||
: print-error ( error -- )
|
||||
[ error. flush ] curry
|
||||
[ global [ "Error in print-error!" print drop ] bind ]
|
||||
|
|
@ -74,7 +65,12 @@ M: string error. print ;
|
|||
|
||||
SYMBOL: error-hook
|
||||
|
||||
[ print-error restarts. debug-help ] error-hook set-global
|
||||
[
|
||||
print-error
|
||||
restarts.
|
||||
nl
|
||||
"Type :help for debugging help." print flush
|
||||
] error-hook set-global
|
||||
|
||||
: try ( quot -- )
|
||||
[ error-hook get call ] recover ;
|
||||
|
|
@ -257,3 +253,49 @@ M: no-compilation-unit error.
|
|||
|
||||
M: no-vocab summary
|
||||
drop "Vocabulary does not exist" ;
|
||||
|
||||
M: check-ptr summary
|
||||
drop "Memory allocation failed" ;
|
||||
|
||||
M: double-free summary
|
||||
drop "Free failed since memory is not allocated" ;
|
||||
|
||||
M: realloc-error summary
|
||||
drop "Memory reallocation failed" ;
|
||||
|
||||
: error-in-thread. ( -- )
|
||||
error-thread get-global
|
||||
"Error in thread " write
|
||||
[
|
||||
dup thread-id #
|
||||
" (" % dup thread-name %
|
||||
", " % dup thread-quot unparse-short % ")" %
|
||||
] "" make swap write-object ":" print nl ;
|
||||
|
||||
! Hooks
|
||||
M: thread error-in-thread ( error thread -- )
|
||||
initial-thread get-global eq? [
|
||||
die drop
|
||||
] [
|
||||
global [
|
||||
error-in-thread. print-error flush
|
||||
] bind
|
||||
] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: init-debugger ( -- )
|
||||
V{ } clone set-catchstack
|
||||
! VM calls on error
|
||||
[
|
||||
self error-thread set-global
|
||||
continuation error-continuation set-global
|
||||
rethrow
|
||||
] 5 setenv
|
||||
! VM adds this to kernel errors, so that user-space
|
||||
! can identify them
|
||||
"kernel-error" 6 setenv ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
[ init-debugger ] "debugger" add-init-hook
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: definitions.tests
|
||||
USING: tools.test generic kernel definitions sequences
|
||||
compiler.units ;
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ M: object uses drop f ;
|
|||
|
||||
: xref ( defspec -- ) dup uses crossref get add-vertex ;
|
||||
|
||||
: usage ( defspec -- seq ) crossref get at keys ;
|
||||
: usage ( defspec -- seq ) \ f or crossref get at keys ;
|
||||
|
||||
GENERIC: redefined* ( defspec -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: dlists dlists.private kernel tools.test random assocs
|
||||
hashtables sequences namespaces sorting debugger io prettyprint
|
||||
math ;
|
||||
IN: temporary
|
||||
IN: dlists.tests
|
||||
|
||||
[ t ] [ <dlist> dlist-empty? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: effects.tests
|
||||
USING: effects tools.test ;
|
||||
|
||||
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: float-arrays.tests
|
||||
USING: float-arrays tools.test ;
|
||||
|
||||
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: float-vectors.tests
|
||||
USING: tools.test float-vectors vectors sequences kernel ;
|
||||
|
||||
[ 0 ] [ 123 <float-vector> length ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ generic.math assocs hashtables io kernel math namespaces parser
|
|||
prettyprint sequences strings tools.test vectors words
|
||||
quotations classes continuations layouts classes.union sorting
|
||||
compiler.units ;
|
||||
IN: temporary
|
||||
IN: generic.tests
|
||||
|
||||
GENERIC: foobar ( x -- y )
|
||||
M: object foobar drop "Hello world" ;
|
||||
|
|
@ -87,11 +87,11 @@ M: number union-containment drop 2 ;
|
|||
[ 2 ] [ 1.0 union-containment ] unit-test
|
||||
|
||||
! Testing recovery from bad method definitions
|
||||
"IN: temporary GENERIC: unhappy ( x -- x )" eval
|
||||
"IN: generic.tests GENERIC: unhappy ( x -- x )" eval
|
||||
[
|
||||
"IN: temporary M: dictionary unhappy ;" eval
|
||||
"IN: generic.tests M: dictionary unhappy ;" eval
|
||||
] must-fail
|
||||
[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
|
||||
[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
|
||||
|
||||
GENERIC# complex-combination 1 ( a b -- c )
|
||||
M: string complex-combination drop ;
|
||||
|
|
@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic
|
|||
|
||||
TUPLE: redefinition-test-tuple ;
|
||||
|
||||
"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval
|
||||
"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
redefinition-test-generic ,
|
||||
"IN: temporary TUPLE: redefinition-test-tuple ;" eval
|
||||
"IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
|
||||
redefinition-test-generic ,
|
||||
] { } make all-equal?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -102,11 +102,13 @@ M: method-body stack-effect
|
|||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
dup first2 method [ method-loc ] [ second where ] ?if ;
|
||||
dup first2 method [ method-word ] [ second ] ?if where ;
|
||||
|
||||
M: method-spec set-where first2 method set-method-loc ;
|
||||
M: method-spec set-where
|
||||
first2 method method-word set-where ;
|
||||
|
||||
M: method-spec definer drop \ M: \ ; ;
|
||||
M: method-spec definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-spec definition
|
||||
first2 method dup [ method-def ] when ;
|
||||
|
|
@ -114,9 +116,21 @@ M: method-spec definition
|
|||
: forget-method ( class generic -- )
|
||||
check-method
|
||||
[ delete-at* ] with-methods
|
||||
[ method-word forget ] [ drop ] if ;
|
||||
[ method-word forget-word ] [ drop ] if ;
|
||||
|
||||
M: method-spec forget* first2 forget-method ;
|
||||
M: method-spec forget*
|
||||
first2 forget-method ;
|
||||
|
||||
M: method-body definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-body definition
|
||||
"method" word-prop method-def ;
|
||||
|
||||
M: method-body forget*
|
||||
"method" word-prop
|
||||
{ method-specializer method-generic } get-slots
|
||||
forget-method ;
|
||||
|
||||
: implementors* ( classes -- words )
|
||||
all-words [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: math sequences classes growable tools.test kernel
|
||||
layouts ;
|
||||
IN: temporary
|
||||
IN: growable.tests
|
||||
|
||||
! erg found this one
|
||||
[ fixnum ] [
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: hashtables.tests
|
||||
USING: kernel math namespaces tools.test vectors sequences
|
||||
sequences.private hashtables io prettyprint assocs
|
||||
continuations ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@ IN: hashtables
|
|||
2 fixnum+fast over wrap ; inline
|
||||
|
||||
: (key@) ( key keys i -- array n ? )
|
||||
#! cond form expanded by hand for better interpreter speed
|
||||
3dup swap array-nth dup ((tombstone)) eq? [
|
||||
2drop probe (key@)
|
||||
] [
|
||||
|
|
@ -40,7 +39,6 @@ IN: hashtables
|
|||
swap <hash-array> over set-hash-array init-hash ;
|
||||
|
||||
: (new-key@) ( key keys i -- keys n empty? )
|
||||
#! cond form expanded by hand for better interpreter speed
|
||||
3dup swap array-nth dup ((empty)) eq? [
|
||||
2drop rot drop t
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -11,69 +11,72 @@ $nl
|
|||
{ $subsection min-heap? }
|
||||
{ $subsection <min-heap> }
|
||||
"Max-heaps sort their elements so that the maximum element is first:"
|
||||
{ $subsection min-heap }
|
||||
{ $subsection min-heap? }
|
||||
{ $subsection <min-heap> }
|
||||
{ $subsection max-heap }
|
||||
{ $subsection max-heap? }
|
||||
{ $subsection <max-heap> }
|
||||
"Both obey a protocol."
|
||||
$nl
|
||||
"Queries:"
|
||||
{ $subsection heap-empty? }
|
||||
{ $subsection heap-length }
|
||||
{ $subsection heap-size }
|
||||
{ $subsection heap-peek }
|
||||
"Insertion:"
|
||||
{ $subsection heap-push }
|
||||
{ $subsection heap-push* }
|
||||
{ $subsection heap-push-all }
|
||||
"Removal:"
|
||||
{ $subsection heap-pop* }
|
||||
{ $subsection heap-pop } ;
|
||||
{ $subsection heap-pop }
|
||||
{ $subsection heap-delete } ;
|
||||
|
||||
ABOUT: "heaps"
|
||||
|
||||
HELP: <min-heap>
|
||||
{ $values { "min-heap" min-heap } }
|
||||
{ $description "Create a new " { $link min-heap } "." }
|
||||
{ $see-also <max-heap> } ;
|
||||
{ $description "Create a new " { $link min-heap } "." } ;
|
||||
|
||||
HELP: <max-heap>
|
||||
{ $values { "max-heap" max-heap } }
|
||||
{ $description "Create a new " { $link max-heap } "." }
|
||||
{ $see-also <min-heap> } ;
|
||||
{ $description "Create a new " { $link max-heap } "." } ;
|
||||
|
||||
HELP: heap-push
|
||||
{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
|
||||
{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
|
||||
{ $side-effects "heap" }
|
||||
{ $see-also heap-push-all heap-pop } ;
|
||||
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
|
||||
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-push*
|
||||
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
|
||||
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-push-all
|
||||
{ $values { "assoc" assoc } { "heap" heap } }
|
||||
{ $values { "assoc" assoc } { "heap" "a heap" } }
|
||||
{ $description "Push every key/value pair of an assoc onto a heap." }
|
||||
{ $side-effects "heap" }
|
||||
{ $see-also heap-push heap-pop } ;
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-peek
|
||||
{ $values { "heap" heap } { "key" object } { "value" object } }
|
||||
{ $description "Outputs the first element in the heap, leaving it in the heap." }
|
||||
{ $see-also heap-pop heap-pop* } ;
|
||||
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
|
||||
{ $description "Output the first element in the heap, leaving it in the heap." } ;
|
||||
|
||||
HELP: heap-pop*
|
||||
{ $values { "heap" heap } }
|
||||
{ $description "Removes the first element from the heap." }
|
||||
{ $side-effects "heap" }
|
||||
{ $see-also heap-pop heap-push heap-peek } ;
|
||||
{ $values { "heap" "a heap" } }
|
||||
{ $description "Remove the first element from the heap." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-pop
|
||||
{ $values { "heap" heap } { "key" object } { "value" object } }
|
||||
{ $description "Outputs the first element in the heap and removes it from the heap." }
|
||||
{ $side-effects "heap" }
|
||||
{ $see-also heap-pop* heap-push heap-peek } ;
|
||||
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
|
||||
{ $description "Output and remove the first element in the heap." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-empty?
|
||||
{ $values { "heap" heap } { "?" "a boolean" } }
|
||||
{ $description "Tests if a " { $link heap } " has no nodes." }
|
||||
{ $see-also heap-length heap-peek } ;
|
||||
{ $values { "heap" "a heap" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a heap has no nodes." } ;
|
||||
|
||||
HELP: heap-length
|
||||
{ $values { "heap" heap } { "n" integer } }
|
||||
{ $description "Returns the number of key/value pairs in the heap." }
|
||||
{ $see-also heap-empty? } ;
|
||||
HELP: heap-size
|
||||
{ $values { "heap" "a heap" } { "n" integer } }
|
||||
{ $description "Returns the number of key/value pairs in the heap." } ;
|
||||
|
||||
HELP: heap-delete
|
||||
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
|
||||
{ $description "Output and remove the first element in the heap." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright 2007 Ryan Murphy
|
||||
! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: arrays kernel math namespaces tools.test
|
||||
heaps heaps.private ;
|
||||
IN: temporary
|
||||
heaps heaps.private math.parser random assocs sequences sorting ;
|
||||
IN: heaps.tests
|
||||
|
||||
[ <min-heap> heap-pop ] must-fail
|
||||
[ <max-heap> heap-pop ] must-fail
|
||||
|
|
@ -15,16 +15,8 @@ IN: temporary
|
|||
|
||||
! Binary Min Heap
|
||||
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
|
||||
{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
|
||||
[ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
|
||||
<min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all
|
||||
3 [ dup heap-pop* ] times
|
||||
] unit-test
|
||||
{ t } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ t 5 f <entry> t 3 f <entry> T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
|
||||
|
||||
|
|
@ -32,18 +24,51 @@ IN: temporary
|
|||
|
||||
[ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
|
||||
|
||||
[ 0 ] [ <max-heap> heap-length ] unit-test
|
||||
[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
|
||||
[ 0 ] [ <max-heap> heap-size ] unit-test
|
||||
[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
|
||||
|
||||
[ { { 1 2 } { 3 4 } { 5 6 } } ] [
|
||||
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
|
||||
[ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
|
||||
] unit-test
|
||||
[ { { 1 2 } } ] [
|
||||
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
|
||||
[ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make
|
||||
] unit-test
|
||||
[ { } ] [
|
||||
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
|
||||
[ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make
|
||||
] unit-test
|
||||
: heap-sort ( alist -- keys )
|
||||
<min-heap> [ heap-push-all ] keep heap-pop-all ;
|
||||
|
||||
: random-alist ( n -- alist )
|
||||
[
|
||||
[
|
||||
(random) dup number>string swap set
|
||||
] times
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: test-heap-sort ( n -- ? )
|
||||
random-alist dup >alist sort-keys swap heap-sort = ;
|
||||
|
||||
14 [
|
||||
[ t ] swap [ 2^ test-heap-sort ] curry unit-test
|
||||
] each
|
||||
|
||||
: test-entry-indices ( n -- ? )
|
||||
random-alist
|
||||
<min-heap> [ heap-push-all ] keep
|
||||
heap-data dup length swap [ entry-index ] map sequence= ;
|
||||
|
||||
14 [
|
||||
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
|
||||
] each
|
||||
|
||||
: delete-random ( seq -- elt )
|
||||
dup length random dup pick nth >r swap delete-nth r> ;
|
||||
|
||||
: sort-entries ( entries -- entries' )
|
||||
[ [ entry-key ] compare ] sort ;
|
||||
|
||||
: delete-test ( n -- ? )
|
||||
[
|
||||
random-alist
|
||||
<min-heap> [ heap-push-all ] keep
|
||||
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 ;
|
||||
|
||||
11 [
|
||||
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -1,26 +1,31 @@
|
|||
! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
|
||||
! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
|
||||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences arrays assocs ;
|
||||
USING: kernel math sequences arrays assocs sequences.private
|
||||
growable ;
|
||||
IN: heaps
|
||||
|
||||
MIXIN: priority-queue
|
||||
|
||||
GENERIC: heap-push ( value key heap -- )
|
||||
GENERIC: heap-push* ( value key heap -- entry )
|
||||
GENERIC: heap-peek ( heap -- value key )
|
||||
GENERIC: heap-pop* ( heap -- )
|
||||
GENERIC: heap-pop ( heap -- value key )
|
||||
GENERIC: heap-delete ( key heap -- )
|
||||
GENERIC: heap-delete* ( key heap -- old ? )
|
||||
GENERIC: heap-delete ( entry heap -- )
|
||||
GENERIC: heap-empty? ( heap -- ? )
|
||||
GENERIC: heap-length ( heap -- n )
|
||||
GENERIC# heap-pop-while 2 ( heap pred quot -- )
|
||||
GENERIC: heap-size ( heap -- n )
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: heap data ;
|
||||
|
||||
: heap-data delegate ; inline
|
||||
|
||||
: <heap> ( class -- heap )
|
||||
>r V{ } clone heap construct-boa r>
|
||||
construct-delegate ; inline
|
||||
>r V{ } clone r> construct-delegate ; inline
|
||||
|
||||
TUPLE: entry value key heap index ;
|
||||
|
||||
: <entry> ( value key heap -- entry ) f entry construct-boa ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: min-heap ;
|
||||
|
|
@ -34,23 +39,67 @@ TUPLE: max-heap ;
|
|||
INSTANCE: min-heap priority-queue
|
||||
INSTANCE: max-heap priority-queue
|
||||
|
||||
M: priority-queue heap-empty? ( heap -- ? )
|
||||
heap-data empty? ;
|
||||
|
||||
M: priority-queue heap-size ( heap -- n )
|
||||
heap-data length ;
|
||||
|
||||
<PRIVATE
|
||||
: left ( n -- m ) 2 * 1+ ; inline
|
||||
: right ( n -- m ) 2 * 2 + ; inline
|
||||
: up ( n -- m ) 1- 2 /i ; inline
|
||||
: left-value ( n heap -- obj ) >r left r> nth ; inline
|
||||
: right-value ( n heap -- obj ) >r right r> nth ; inline
|
||||
: up-value ( n vec -- obj ) >r up r> nth ; inline
|
||||
: swap-up ( n vec -- ) >r dup up r> exchange ; inline
|
||||
: last-index ( vec -- n ) length 1- ; inline
|
||||
|
||||
: left ( n -- m ) 1 shift 1 + ; inline
|
||||
|
||||
: right ( n -- m ) 1 shift 2 + ; inline
|
||||
|
||||
: up ( n -- m ) 1- 2/ ; inline
|
||||
|
||||
: data-nth ( n heap -- entry )
|
||||
heap-data nth-unsafe ; inline
|
||||
|
||||
: up-value ( n heap -- entry )
|
||||
>r up r> data-nth ; inline
|
||||
|
||||
: left-value ( n heap -- entry )
|
||||
>r left r> data-nth ; inline
|
||||
|
||||
: right-value ( n heap -- entry )
|
||||
>r right r> data-nth ; inline
|
||||
|
||||
: data-set-nth ( entry n heap -- )
|
||||
>r [ swap set-entry-index ] 2keep r>
|
||||
heap-data set-nth-unsafe ;
|
||||
|
||||
: data-push ( entry heap -- n )
|
||||
dup heap-size [
|
||||
swap 2dup heap-data ensure 2drop data-set-nth
|
||||
] keep ; inline
|
||||
|
||||
: data-pop ( heap -- entry )
|
||||
heap-data pop ; inline
|
||||
|
||||
: data-pop* ( heap -- )
|
||||
heap-data pop* ; inline
|
||||
|
||||
: data-peek ( heap -- entry )
|
||||
heap-data peek ; inline
|
||||
|
||||
: data-first ( heap -- entry )
|
||||
heap-data first ; inline
|
||||
|
||||
: data-exchange ( m n heap -- )
|
||||
[ tuck data-nth >r data-nth r> ] 3keep
|
||||
tuck >r >r data-set-nth r> r> data-set-nth ; inline
|
||||
|
||||
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
|
||||
: (heap-compare) drop [ first ] compare 0 ; inline
|
||||
|
||||
: (heap-compare) drop [ entry-key ] compare 0 ; inline
|
||||
|
||||
M: min-heap heap-compare (heap-compare) > ;
|
||||
|
||||
M: max-heap heap-compare (heap-compare) < ;
|
||||
|
||||
: heap-bounds-check? ( m heap -- ? )
|
||||
heap-data length >= ; inline
|
||||
heap-size >= ; inline
|
||||
|
||||
: left-bounds-check? ( m heap -- ? )
|
||||
>r left r> heap-bounds-check? ; inline
|
||||
|
|
@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ;
|
|||
: right-bounds-check? ( m heap -- ? )
|
||||
>r right r> heap-bounds-check? ; inline
|
||||
|
||||
: up-heap-continue? ( vec heap -- ? )
|
||||
>r [ last-index ] keep [ up-value ] keep peek r>
|
||||
: continue? ( m up[m] heap -- ? )
|
||||
[ data-nth swap ] keep [ data-nth ] keep
|
||||
heap-compare ; inline
|
||||
|
||||
: up-heap ( vec heap -- )
|
||||
2dup up-heap-continue? [
|
||||
>r dup last-index [ over swap-up ] keep
|
||||
up 1+ head-slice r> up-heap
|
||||
DEFER: up-heap
|
||||
|
||||
: (up-heap) ( n heap -- )
|
||||
>r dup up r>
|
||||
3dup continue? [
|
||||
[ data-exchange ] 2keep up-heap
|
||||
] [
|
||||
2drop
|
||||
3drop
|
||||
] if ;
|
||||
|
||||
: up-heap ( n heap -- )
|
||||
over 0 > [ (up-heap) ] [ 2drop ] if ;
|
||||
|
||||
: (child) ( m heap -- n )
|
||||
dupd
|
||||
[ heap-data left-value ] 2keep
|
||||
[ heap-data right-value ] keep heap-compare
|
||||
2dup right-value
|
||||
>r 2dup left-value r>
|
||||
rot heap-compare
|
||||
[ right ] [ left ] if ;
|
||||
|
||||
: child ( m heap -- n )
|
||||
2dup right-bounds-check? [ drop left ] [ (child) ] if ;
|
||||
2dup right-bounds-check?
|
||||
[ drop left ] [ (child) ] if ;
|
||||
|
||||
: swap-down ( m heap -- )
|
||||
[ child ] 2keep heap-data exchange ;
|
||||
[ child ] 2keep data-exchange ;
|
||||
|
||||
DEFER: down-heap
|
||||
|
||||
: down-heap-continue? ( heap m heap -- m heap ? )
|
||||
[ heap-data nth ] 2keep child pick
|
||||
dupd [ heap-data nth swapd ] keep heap-compare ;
|
||||
|
||||
: (down-heap) ( m heap -- )
|
||||
2dup down-heap-continue? [
|
||||
-rot [ swap-down ] keep down-heap
|
||||
] [
|
||||
[ child ] 2keep swapd
|
||||
3dup continue? [
|
||||
3drop
|
||||
] [
|
||||
[ data-exchange ] 2keep down-heap
|
||||
] if ;
|
||||
|
||||
: down-heap ( m heap -- )
|
||||
|
|
@ -100,40 +152,43 @@ DEFER: down-heap
|
|||
|
||||
PRIVATE>
|
||||
|
||||
M: priority-queue heap-push ( value key heap -- )
|
||||
>r swap 2array r>
|
||||
[ heap-data push ] keep
|
||||
[ heap-data ] keep
|
||||
up-heap ;
|
||||
M: priority-queue heap-push* ( value key heap -- entry )
|
||||
[ <entry> dup ] keep [ data-push ] keep up-heap ;
|
||||
|
||||
: heap-push ( value key heap -- ) heap-push* drop ;
|
||||
|
||||
: heap-push-all ( assoc heap -- )
|
||||
[ swapd heap-push ] curry assoc-each ;
|
||||
|
||||
: >entry< ( entry -- key value )
|
||||
{ entry-value entry-key } get-slots ;
|
||||
|
||||
M: priority-queue heap-peek ( heap -- value key )
|
||||
heap-data first first2 swap ;
|
||||
data-first >entry< ;
|
||||
|
||||
: entry>index ( entry heap -- n )
|
||||
over entry-heap eq? [
|
||||
"Invalid entry passed to heap-delete" throw
|
||||
] unless
|
||||
entry-index ;
|
||||
|
||||
M: priority-queue heap-delete ( entry heap -- )
|
||||
[ entry>index ] keep
|
||||
2dup heap-size 1- = [
|
||||
nip data-pop*
|
||||
] [
|
||||
[ nip data-pop ] 2keep
|
||||
[ data-set-nth ] 2keep
|
||||
down-heap
|
||||
] if ;
|
||||
|
||||
M: priority-queue heap-pop* ( heap -- )
|
||||
dup heap-data length 1 > [
|
||||
[ heap-data pop ] keep
|
||||
[ heap-data set-first ] keep
|
||||
0 swap down-heap
|
||||
] [
|
||||
heap-data pop*
|
||||
] if ;
|
||||
dup data-first swap heap-delete ;
|
||||
|
||||
M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
|
||||
M: priority-queue heap-pop ( heap -- value key )
|
||||
dup data-first [ swap heap-delete ] keep >entry< ;
|
||||
|
||||
M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
|
||||
|
||||
M: priority-queue heap-length ( heap -- n ) heap-data length ;
|
||||
|
||||
: (heap-pop-while) ( heap pred quot -- )
|
||||
pick heap-empty? [
|
||||
3drop
|
||||
] [
|
||||
[ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep
|
||||
roll [ (heap-pop-while) ] [ 3drop ] if
|
||||
] if ;
|
||||
|
||||
M: priority-queue heap-pop-while ( heap pred quot -- )
|
||||
[ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;
|
||||
: heap-pop-all ( heap -- alist )
|
||||
[ dup heap-empty? not ]
|
||||
[ dup heap-pop swap 2array ]
|
||||
[ ] unfold nip ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: inference.class.tests
|
||||
USING: arrays math.private kernel math compiler inference
|
||||
inference.dataflow optimizer tools.test kernel.private generic
|
||||
sequences words inference.class quotations alien
|
||||
|
|
@ -288,3 +288,10 @@ cell-bits 32 = [
|
|||
[ HEX: ff bitand 0 HEX: ff between? ]
|
||||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ HEX: ff swap HEX: ff bitand >= ]
|
||||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -5,8 +5,8 @@ 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
|
||||
sequences.private ;
|
||||
IN: temporary
|
||||
io.thread sequences.private ;
|
||||
IN: inference.tests
|
||||
|
||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||
{ 1 2 } [ dup ] must-infer-as
|
||||
|
|
@ -440,7 +440,7 @@ DEFER: bar
|
|||
\ error. must-infer
|
||||
|
||||
! Test odds and ends
|
||||
\ idle-thread must-infer
|
||||
\ io-thread must-infer
|
||||
|
||||
! Incorrect stack declarations on inline recursive words should
|
||||
! be caught
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: tools.test inference.state ;
|
||||
IN: inference.state.tests
|
||||
USING: tools.test inference.state words ;
|
||||
|
||||
SYMBOL: a
|
||||
SYMBOL: b
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces sequences kernel ;
|
||||
USING: assocs namespaces sequences kernel words ;
|
||||
IN: inference.state
|
||||
|
||||
! Nesting state to solve recursion
|
||||
|
|
@ -31,9 +31,6 @@ SYMBOL: current-node
|
|||
! Words that the current dataflow IR depends on
|
||||
SYMBOL: dependencies
|
||||
|
||||
SYMBOL: +inlined+
|
||||
SYMBOL: +called+
|
||||
|
||||
: depends-on ( word how -- )
|
||||
swap dependencies get dup [
|
||||
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: inference.transforms.tests
|
||||
USING: sequences inference.transforms tools.test math kernel
|
||||
quotations inference ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
IN: init.tests
|
||||
USING: init namespaces sequences math tools.test kernel ;
|
||||
|
||||
[ t ] [
|
||||
init-hooks get [ first "libc" = ] find drop
|
||||
init-hooks get [ first "io.backend" = ] find drop <
|
||||
] unit-test
|
||||
|
|
@ -15,7 +15,7 @@ init-hooks global [ drop V{ } clone ] cache drop
|
|||
dup init-hooks get at [ over call ] unless
|
||||
init-hooks get set-at ;
|
||||
|
||||
: boot ( -- ) init-namespaces init-error-handler ;
|
||||
: boot ( -- ) init-namespaces init-catchstack ;
|
||||
|
||||
: boot-quot ( -- quot ) 20 getenv ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel tools.test math namespaces prettyprint
|
||||
sequences inspector io.streams.string ;
|
||||
IN: temporary
|
||||
IN: inspector.tests
|
||||
|
||||
[ 1 2 3 ] describe
|
||||
f describe
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic hashtables io kernel assocs math
|
||||
namespaces prettyprint sequences strings io.styles vectors words
|
||||
|
|
@ -93,6 +93,15 @@ SYMBOL: +editable+
|
|||
|
||||
: describe ( obj -- ) H{ } describe* ;
|
||||
|
||||
: namestack. ( seq -- )
|
||||
[
|
||||
[ global eq? not ] subset
|
||||
[ keys ] map concat prune
|
||||
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
|
||||
|
||||
: .vars ( -- )
|
||||
namestack namestack. ;
|
||||
|
||||
SYMBOL: inspector-hook
|
||||
|
||||
[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: io.backend.tests
|
||||
USING: tools.test io.backend kernel ;
|
||||
|
||||
[ ] [ "a" normalize-pathname drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -19,8 +19,8 @@ HOOK: normalize-pathname io-backend ( str -- newstr )
|
|||
|
||||
M: object normalize-pathname ;
|
||||
|
||||
[ init-io embedded? [ init-stdio ] unless ]
|
||||
"io.backend" add-init-hook
|
||||
|
||||
: set-io-backend ( backend -- )
|
||||
io-backend set-global init-io init-stdio ;
|
||||
|
||||
[ init-io embedded? [ init-stdio ] unless ]
|
||||
"io.backend" add-init-hook
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: io.binary tools.test ;
|
||||
IN: temporary
|
||||
IN: io.binary.tests
|
||||
|
||||
[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
|
||||
[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Daniel Ehrenberg
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
text
|
||||
|
|
@ -1,41 +1,117 @@
|
|||
USING: help.markup help.syntax io io.styles strings
|
||||
io.backend io.files.private ;
|
||||
io.backend io.files.private quotations ;
|
||||
IN: io.files
|
||||
|
||||
ARTICLE: "file-streams" "Reading and writing files"
|
||||
"File streams:"
|
||||
{ $subsection <file-reader> }
|
||||
{ $subsection <file-writer> }
|
||||
{ $subsection <file-appender> }
|
||||
"Utility combinators:"
|
||||
{ $subsection with-file-reader }
|
||||
{ $subsection with-file-writer }
|
||||
{ $subsection with-file-appender } ;
|
||||
|
||||
ARTICLE: "pathnames" "Pathname manipulation"
|
||||
"Pathname manipulation:"
|
||||
{ $subsection parent-directory }
|
||||
{ $subsection file-name }
|
||||
{ $subsection last-path-separator }
|
||||
{ $subsection path+ }
|
||||
"File system meta-data:"
|
||||
"Pathnames relative to Factor's install directory:"
|
||||
{ $subsection resource-path }
|
||||
{ $subsection ?resource-path }
|
||||
"Pathnames relative to Factor's temporary files directory:"
|
||||
{ $subsection temp-directory }
|
||||
{ $subsection temp-file }
|
||||
"Pathname presentations:"
|
||||
{ $subsection pathname }
|
||||
{ $subsection <pathname> } ;
|
||||
|
||||
ARTICLE: "directories" "Directories"
|
||||
"Current and home directories:"
|
||||
{ $subsection cwd }
|
||||
{ $subsection cd }
|
||||
{ $subsection with-directory }
|
||||
{ $subsection home }
|
||||
"Directory listing:"
|
||||
{ $subsection directory }
|
||||
{ $subsection directory* }
|
||||
"Creating directories:"
|
||||
{ $subsection make-directory }
|
||||
{ $subsection make-directories } ;
|
||||
|
||||
ARTICLE: "fs-meta" "File meta-data"
|
||||
{ $subsection exists? }
|
||||
{ $subsection directory? }
|
||||
{ $subsection file-length }
|
||||
{ $subsection file-modified }
|
||||
{ $subsection stat }
|
||||
"Directory listing:"
|
||||
{ $subsection directory }
|
||||
"File management:"
|
||||
{ $subsection stat } ;
|
||||
|
||||
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
|
||||
"Operations for deleting and copying files come in two forms:"
|
||||
{ $list
|
||||
{ "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." }
|
||||
{ "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." }
|
||||
}
|
||||
"The operations for moving and copying files come in three flavors:"
|
||||
{ $list
|
||||
{ "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." }
|
||||
{ "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
|
||||
{ "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." }
|
||||
}
|
||||
"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file."
|
||||
$nl
|
||||
"Deleting files:"
|
||||
{ $subsection delete-file }
|
||||
{ $subsection make-directory }
|
||||
{ $subsection delete-directory }
|
||||
"Current and home directories:"
|
||||
{ $subsection home }
|
||||
{ $subsection cwd }
|
||||
{ $subsection cd }
|
||||
"Pathnames relative to the Factor install directory:"
|
||||
{ $subsection resource-path }
|
||||
{ $subsection ?resource-path }
|
||||
"Pathname presentations:"
|
||||
{ $subsection pathname }
|
||||
{ $subsection <pathname> }
|
||||
{ $subsection delete-tree }
|
||||
"Moving files:"
|
||||
{ $subsection move-file }
|
||||
{ $subsection move-file-into }
|
||||
{ $subsection move-files-into }
|
||||
"Copying files:"
|
||||
{ $subsection copy-file }
|
||||
{ $subsection copy-file-into }
|
||||
{ $subsection copy-files-into }
|
||||
"Copying directory trees recursively:"
|
||||
{ $subsection copy-tree }
|
||||
{ $subsection copy-tree-into }
|
||||
{ $subsection copy-trees-into }
|
||||
"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ;
|
||||
|
||||
ARTICLE: "io.files" "Basic file operations"
|
||||
"The " { $vocab-link "io.files" } " vocabulary provides basic support for working with files."
|
||||
{ $subsection "pathnames" }
|
||||
{ $subsection "file-streams" }
|
||||
{ $subsection "fs-meta" }
|
||||
{ $subsection "directories" }
|
||||
{ $subsection "delete-move-copy" }
|
||||
{ $subsection "unique" }
|
||||
{ $see-also "os" } ;
|
||||
|
||||
ABOUT: "file-streams"
|
||||
ABOUT: "io.files"
|
||||
|
||||
HELP: path-separator?
|
||||
{ $values { "ch" "a code point" } { "?" "a boolean" } }
|
||||
{ $description "Tests if the code point is a platform-specific path separator." }
|
||||
{ $examples
|
||||
"On Unix:"
|
||||
{ $example "USING: io.files prettyprint ;" "CHAR: / path-separator? ." "t" }
|
||||
} ;
|
||||
|
||||
HELP: parent-directory
|
||||
{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
|
||||
{ $description "Strips the last component off a pathname." }
|
||||
{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
|
||||
|
||||
HELP: file-name
|
||||
{ $values { "path" "a pathname string" } { "string" string } }
|
||||
{ $description "Outputs the last component of a pathname string." }
|
||||
{ $examples
|
||||
{ "\"/usr/bin/gcc\" file-name ." "\"gcc\"" }
|
||||
{ "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
|
||||
} ;
|
||||
|
||||
HELP: <file-reader>
|
||||
{ $values { "path" "a pathname string" } { "stream" "an input stream" } }
|
||||
|
|
@ -77,7 +153,12 @@ HELP: cd
|
|||
{ $description "Changes the current working directory of the Factor process." }
|
||||
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
|
||||
|
||||
{ cd cwd } related-words
|
||||
{ cd cwd with-directory } related-words
|
||||
|
||||
HELP: with-directory
|
||||
{ $values { "path" "a pathname string" } { "quot" quotation } }
|
||||
{ $description "Changes the current working directory for the duration of a quotation's execution." }
|
||||
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
|
||||
|
||||
HELP: stat ( path -- directory? permissions length modified )
|
||||
{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } }
|
||||
|
|
@ -108,6 +189,11 @@ HELP: directory
|
|||
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }
|
||||
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
|
||||
|
||||
HELP: directory*
|
||||
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ path dir? }" } " pairs" } }
|
||||
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
|
||||
{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
|
||||
|
||||
HELP: file-length
|
||||
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
|
||||
{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
|
||||
|
|
@ -116,19 +202,6 @@ HELP: file-modified
|
|||
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
|
||||
{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
|
||||
|
||||
HELP: parent-directory
|
||||
{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
|
||||
{ $description "Strips the last component off a pathname." }
|
||||
{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
|
||||
|
||||
HELP: file-name
|
||||
{ $values { "path" "a pathname string" } { "string" string } }
|
||||
{ $description "Outputs the last component of a pathname string." }
|
||||
{ $examples
|
||||
{ "\"/usr/bin/gcc\" file-name ." "\"gcc\"" }
|
||||
{ "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
|
||||
} ;
|
||||
|
||||
HELP: resource-path
|
||||
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
|
||||
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
|
||||
|
|
@ -168,7 +241,72 @@ HELP: make-directory
|
|||
{ $description "Creates a directory." }
|
||||
{ $errors "Throws an error if the directory could not be created." } ;
|
||||
|
||||
HELP: make-directories
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Creates a directory and any parent directories which do not yet exist." }
|
||||
{ $errors "Throws an error if the directories could not be created." } ;
|
||||
|
||||
HELP: delete-directory
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Deletes a directory. The directory must be empty." }
|
||||
{ $errors "Throws an error if the directory could not be deleted." } ;
|
||||
|
||||
HELP: touch-file
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Updates the modification time of a file or directory. If the file does not exist, creates a new, empty file." }
|
||||
{ $errors "Throws an error if the file could not be touched." } ;
|
||||
|
||||
HELP: delete-tree
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Deletes a file or directory, recursing into subdirectories." }
|
||||
{ $errors "Throws an error if the deletion fails." }
|
||||
{ $warning "Misuse of this word can lead to catastrophic data loss." } ;
|
||||
|
||||
HELP: move-file
|
||||
{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
|
||||
{ $description "Moves or renames a file." }
|
||||
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
|
||||
|
||||
HELP: move-file-into
|
||||
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
|
||||
{ $description "Moves a file to another directory without renaming it." }
|
||||
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
|
||||
|
||||
HELP: move-files-into
|
||||
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
|
||||
{ $description "Moves a set of files to another directory." }
|
||||
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
|
||||
|
||||
HELP: copy-file
|
||||
{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
|
||||
{ $description "Copies a file." }
|
||||
{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." }
|
||||
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
|
||||
|
||||
HELP: copy-file-into
|
||||
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
|
||||
{ $description "Copies a file to another directory." }
|
||||
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
|
||||
|
||||
HELP: copy-files-into
|
||||
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
|
||||
{ $description "Copies a set of files to another directory." }
|
||||
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
|
||||
|
||||
HELP: copy-tree
|
||||
{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
|
||||
{ $description "Copies a directory tree recursively." }
|
||||
{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." }
|
||||
{ $errors "Throws an error if the copy operation fails." } ;
|
||||
|
||||
HELP: copy-tree-into
|
||||
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
|
||||
{ $description "Copies a directory tree to another directory, recursively." }
|
||||
{ $errors "Throws an error if the copy operation fails." } ;
|
||||
|
||||
HELP: copy-trees-into
|
||||
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
|
||||
{ $description "Copies a set of directory trees to another directory, recursively." }
|
||||
{ $errors "Throws an error if the copy operation fails." } ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: io.files.tests
|
||||
USING: tools.test io.files io threads kernel continuations ;
|
||||
|
||||
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
|
||||
|
|
@ -6,63 +6,120 @@ USING: tools.test io.files io threads kernel continuations ;
|
|||
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-foo.txt" resource-path [
|
||||
"test-foo.txt" temp-file [
|
||||
"Hello world." print
|
||||
] with-file-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-foo.txt" resource-path <file-appender> [
|
||||
"test-foo.txt" temp-file <file-appender> [
|
||||
"Hello appender." print
|
||||
] with-stream
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-bar.txt" resource-path <file-appender> [
|
||||
"test-bar.txt" temp-file <file-appender> [
|
||||
"Hello appender." print
|
||||
] with-stream
|
||||
] unit-test
|
||||
|
||||
[ "Hello world.\nHello appender.\n" ] [
|
||||
"test-foo.txt" resource-path file-contents
|
||||
"test-foo.txt" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ "Hello appender.\n" ] [
|
||||
"test-bar.txt" resource-path file-contents
|
||||
"test-bar.txt" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [ "test-foo.txt" resource-path delete-file ] unit-test
|
||||
[ ] [ "test-foo.txt" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "test-bar.txt" resource-path delete-file ] unit-test
|
||||
[ ] [ "test-bar.txt" temp-file delete-file ] unit-test
|
||||
|
||||
[ f ] [ "test-foo.txt" resource-path exists? ] unit-test
|
||||
[ f ] [ "test-foo.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ f ] [ "test-bar.txt" resource-path exists? ] unit-test
|
||||
[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "test-blah" resource-path make-directory ] unit-test
|
||||
[ ] [ "test-blah" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-blah/fooz" resource-path <file-writer> dispose
|
||||
"test-blah/fooz" temp-file <file-writer> dispose
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"test-blah/fooz" resource-path exists?
|
||||
"test-blah/fooz" temp-file exists?
|
||||
] unit-test
|
||||
|
||||
[ ] [ "test-blah/fooz" resource-path delete-file ] unit-test
|
||||
[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "test-blah" resource-path delete-directory ] unit-test
|
||||
[ ] [ "test-blah" temp-file delete-directory ] unit-test
|
||||
|
||||
[ f ] [ "test-blah" resource-path exists? ] unit-test
|
||||
[ f ] [ "test-blah" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test
|
||||
[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path delete-file ] unit-test
|
||||
[ ] [ "test-quux.txt" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test
|
||||
[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test
|
||||
[ t ] [ "quux-test.txt" resource-path exists? ] unit-test
|
||||
[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
|
||||
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "quux-test.txt" resource-path delete-file ] unit-test
|
||||
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [
|
||||
"delete-tree-test/a/b/c/d" temp-file
|
||||
[ "Hi" print ] with-file-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"delete-tree-test" temp-file delete-tree
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test/a/b/c" temp-file make-directories
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test/a/b/c/d" temp-file
|
||||
[ "Foobar" write ] with-file-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test" temp-file
|
||||
"copy-destination" temp-file copy-tree
|
||||
] unit-test
|
||||
|
||||
[ "Foobar" ] [
|
||||
"copy-destination/a/b/c/d" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-destination" temp-file delete-tree
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test" temp-file
|
||||
"copy-destination" temp-file copy-tree-into
|
||||
] unit-test
|
||||
|
||||
[ "Foobar" ] [
|
||||
"copy-destination/copy-tree-test/a/b/c/d" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into
|
||||
] unit-test
|
||||
|
||||
[ "Foobar" ] [
|
||||
"d" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [ "d" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "copy-destination" temp-file delete-tree ] unit-test
|
||||
|
||||
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
|
||||
|
||||
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,34 +1,14 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.files
|
||||
USING: io.backend io.files.private io hashtables kernel math
|
||||
memory namespaces sequences strings assocs arrays definitions
|
||||
system combinators splitting sbufs continuations ;
|
||||
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
||||
HOOK: cwd io-backend ( -- path )
|
||||
|
||||
HOOK: <file-reader> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-writer> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-appender> io-backend ( path -- stream )
|
||||
|
||||
HOOK: delete-file io-backend ( path -- )
|
||||
|
||||
HOOK: rename-file io-backend ( from to -- )
|
||||
|
||||
HOOK: make-directory io-backend ( path -- )
|
||||
|
||||
HOOK: delete-directory io-backend ( path -- )
|
||||
IN: io.files
|
||||
|
||||
! Pathnames
|
||||
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
|
||||
|
||||
HOOK: root-directory? io-backend ( path -- ? )
|
||||
|
||||
M: object root-directory? ( path -- ? ) path-separator? ;
|
||||
|
||||
: right-trim-separators ( str -- newstr )
|
||||
[ path-separator? ] right-trim ;
|
||||
|
||||
|
|
@ -39,33 +19,15 @@ M: object root-directory? ( path -- ? ) path-separator? ;
|
|||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append ;
|
||||
|
||||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
|
||||
: file-length ( path -- n ) stat 4array third ;
|
||||
|
||||
: file-modified ( path -- n ) stat >r 3drop r> ; inline
|
||||
|
||||
: exists? ( path -- ? ) file-modified >boolean ;
|
||||
|
||||
: directory? ( path -- ? ) stat 3drop ;
|
||||
|
||||
: special-directory? ( name -- ? )
|
||||
{ "." ".." } member? ;
|
||||
|
||||
: fixup-directory ( path seq -- newseq )
|
||||
[
|
||||
dup string?
|
||||
[ tuck path+ directory? 2array ] [ nip ] if
|
||||
] with map
|
||||
[ first special-directory? not ] subset ;
|
||||
|
||||
: directory ( path -- seq )
|
||||
normalize-directory dup (directory) fixup-directory ;
|
||||
|
||||
: last-path-separator ( path -- n ? )
|
||||
[ length 1- ] keep [ path-separator? ] find-last* ;
|
||||
|
||||
HOOK: root-directory? io-backend ( path -- ? )
|
||||
|
||||
M: object root-directory? ( path -- ? ) path-separator? ;
|
||||
|
||||
: special-directory? ( name -- ? ) { "." ".." } member? ;
|
||||
|
||||
TUPLE: no-parent-directory path ;
|
||||
|
||||
: no-parent-directory ( path -- * )
|
||||
|
|
@ -89,15 +51,43 @@ TUPLE: no-parent-directory path ;
|
|||
{ [ t ] [ drop ] }
|
||||
} cond ;
|
||||
|
||||
: resource-path ( path -- newpath )
|
||||
\ resource-path get [ image parent-directory ] unless*
|
||||
swap path+ ;
|
||||
TUPLE: file-info type size permissions modified ;
|
||||
|
||||
: ?resource-path ( path -- newpath )
|
||||
"resource:" ?head [ resource-path ] when ;
|
||||
HOOK: file-info io-backend ( path -- info )
|
||||
|
||||
: resource-exists? ( path -- ? )
|
||||
?resource-path exists? ;
|
||||
SYMBOL: +regular-file+
|
||||
SYMBOL: +directory+
|
||||
SYMBOL: +character-device+
|
||||
SYMBOL: +block-device+
|
||||
SYMBOL: +fifo+
|
||||
SYMBOL: +symbolic-link+
|
||||
SYMBOL: +socket+
|
||||
SYMBOL: +unknown+
|
||||
|
||||
! File metadata
|
||||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
|
||||
: file-length ( path -- n ) stat drop 2nip ;
|
||||
|
||||
: file-modified ( path -- n ) stat >r 3drop r> ;
|
||||
|
||||
: file-permissions ( path -- perm ) stat 2drop nip ;
|
||||
|
||||
: exists? ( path -- ? ) file-modified >boolean ;
|
||||
|
||||
: directory? ( path -- ? ) stat 3drop ;
|
||||
|
||||
! Current working directory
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
||||
HOOK: cwd io-backend ( -- path )
|
||||
|
||||
: with-directory ( path quot -- )
|
||||
cwd [ cd ] curry rot cd [ ] cleanup ; inline
|
||||
|
||||
! Creating directories
|
||||
HOOK: make-directory io-backend ( path -- )
|
||||
|
||||
: make-directories ( path -- )
|
||||
normalize-pathname right-trim-separators {
|
||||
|
|
@ -111,35 +101,107 @@ TUPLE: no-parent-directory path ;
|
|||
] }
|
||||
} cond drop ;
|
||||
|
||||
! Directory listings
|
||||
: fixup-directory ( path seq -- newseq )
|
||||
[
|
||||
dup string?
|
||||
[ tuck path+ directory? 2array ] [ nip ] if
|
||||
] with map
|
||||
[ first special-directory? not ] subset ;
|
||||
|
||||
: directory ( path -- seq )
|
||||
normalize-directory dup (directory) fixup-directory ;
|
||||
|
||||
: directory* ( path -- seq )
|
||||
dup directory [ first2 >r path+ r> 2array ] with map ;
|
||||
|
||||
! Touching files
|
||||
HOOK: touch-file io-backend ( path -- )
|
||||
|
||||
! Deleting files
|
||||
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) ;
|
||||
|
||||
: to-directory over file-name path+ ;
|
||||
|
||||
! Moving and renaming files
|
||||
HOOK: move-file io-backend ( from to -- )
|
||||
|
||||
: move-file-into ( from to -- )
|
||||
to-directory move-file ;
|
||||
|
||||
: move-files-into ( files to -- )
|
||||
[ move-file-into ] curry each ;
|
||||
|
||||
! Copying files
|
||||
HOOK: copy-file io-backend ( from to -- )
|
||||
|
||||
M: object copy-file
|
||||
dup parent-directory make-directories
|
||||
<file-writer> [
|
||||
swap <file-reader> [
|
||||
swap stream-copy
|
||||
] with-disposal
|
||||
] with-disposal ;
|
||||
: copy-file-into ( from to -- )
|
||||
to-directory copy-file ;
|
||||
|
||||
: copy-directory ( from to -- )
|
||||
dup make-directories
|
||||
>r dup directory swap r> [
|
||||
>r >r first r> over path+ r> rot path+ copy-file
|
||||
] 2curry each ;
|
||||
: copy-files-into ( files to -- )
|
||||
[ copy-file-into ] curry each ;
|
||||
|
||||
: home ( -- dir )
|
||||
{
|
||||
{ [ winnt? ] [ "USERPROFILE" os-env ] }
|
||||
{ [ wince? ] [ "" resource-path ] }
|
||||
{ [ unix? ] [ "HOME" os-env ] }
|
||||
} cond ;
|
||||
DEFER: copy-tree-into
|
||||
|
||||
: copy-tree ( from to -- )
|
||||
over directory? [
|
||||
>r dup directory swap r> [
|
||||
>r swap first path+ r> copy-tree-into
|
||||
] 2curry each
|
||||
] [
|
||||
copy-file
|
||||
] if ;
|
||||
|
||||
: copy-tree-into ( from to -- )
|
||||
to-directory copy-tree ;
|
||||
|
||||
: copy-trees-into ( files to -- )
|
||||
[ copy-tree-into ] curry each ;
|
||||
|
||||
! Special paths
|
||||
: resource-path ( path -- newpath )
|
||||
\ resource-path get [ image parent-directory ] unless*
|
||||
swap path+ ;
|
||||
|
||||
: ?resource-path ( path -- newpath )
|
||||
"resource:" ?head [ resource-path ] when ;
|
||||
|
||||
: resource-exists? ( path -- ? )
|
||||
?resource-path exists? ;
|
||||
|
||||
: temp-directory ( -- path )
|
||||
"temp" resource-path
|
||||
dup exists? not
|
||||
[ dup make-directory ]
|
||||
when ;
|
||||
|
||||
: temp-file ( name -- path ) temp-directory swap path+ ;
|
||||
|
||||
! Pathname presentations
|
||||
TUPLE: pathname string ;
|
||||
|
||||
C: <pathname> pathname
|
||||
|
||||
M: pathname <=> [ pathname-string ] compare ;
|
||||
|
||||
! Streams
|
||||
HOOK: <file-reader> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-writer> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-appender> io-backend ( path -- stream )
|
||||
|
||||
: file-lines ( path -- seq ) <file-reader> lines ;
|
||||
|
||||
: file-contents ( path -- str )
|
||||
|
|
@ -154,3 +216,11 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
|
||||
: with-file-appender ( path quot -- )
|
||||
>r <file-appender> r> with-stream ; inline
|
||||
|
||||
! Home directory
|
||||
: home ( -- dir )
|
||||
{
|
||||
{ [ winnt? ] [ "USERPROFILE" os-env ] }
|
||||
{ [ wince? ] [ "" resource-path ] }
|
||||
{ [ unix? ] [ "HOME" os-env ] }
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ IN: io
|
|||
ARTICLE: "stream-protocol" "Stream protocol"
|
||||
"The stream protocol consists of a large number of generic words, many of which are optional."
|
||||
$nl
|
||||
"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in a " { $link with-stream } ". This leads more simpler, more reusable and more robust code."
|
||||
$nl
|
||||
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
|
||||
$nl
|
||||
"Three words are required for input streams:"
|
||||
|
|
@ -25,7 +27,35 @@ $nl
|
|||
{ $see-also "io.timeouts" } ;
|
||||
|
||||
ARTICLE: "stdio" "The default stream"
|
||||
"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
|
||||
"Most I/O code only operates on one stream at a time. The " { $emphasis "default stream" } " is an implicit parameter used by many I/O words designed for this particular use-case. Using this idiom improves code in three ways:"
|
||||
{ $list
|
||||
{ "Code becomes simpler because there is no need to keep a stream around on the stack." }
|
||||
{ "Code becomes more robust because " { $link with-stream } " automatically closes the stream if there is an error." }
|
||||
{ "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-stream } " to specify the source or destination for I/O operations." }
|
||||
}
|
||||
"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" <file-reader>"
|
||||
"dup stream-readln number>string over stream-read 16 group"
|
||||
"swap dispose"
|
||||
}
|
||||
"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" <file-reader> ["
|
||||
" dup stream-readln number>string over stream-read"
|
||||
" 16 group"
|
||||
"] with-disposal"
|
||||
}
|
||||
"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" <file-reader> ["
|
||||
" readln number>string read 16 group"
|
||||
"] with-stream"
|
||||
}
|
||||
"The default stream is stored in a dynamically-scoped variable:"
|
||||
{ $subsection stdio }
|
||||
"Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user."
|
||||
{ $subsection read1 }
|
||||
|
|
@ -65,6 +95,8 @@ $nl
|
|||
|
||||
ARTICLE: "streams" "Streams"
|
||||
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium."
|
||||
$nl
|
||||
"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "."
|
||||
{ $subsection "stream-protocol" }
|
||||
{ $subsection "stdio" }
|
||||
{ $subsection "stream-utils" }
|
||||
|
|
@ -75,42 +107,50 @@ ABOUT: "streams"
|
|||
HELP: stream-readln
|
||||
{ $values { "stream" "an input stream" } { "str" string } }
|
||||
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-read1
|
||||
{ $values { "stream" "an input stream" } { "ch/f" "a character or " { $link f } } }
|
||||
{ $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-read
|
||||
{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
|
||||
{ $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-read-until
|
||||
{ $values { "seps" string } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } }
|
||||
{ $contract "Reads characters from the stream, until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-write1
|
||||
{ $values { "ch" "a character" } { "stream" "an output stream" } }
|
||||
{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link write1 } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-write
|
||||
{ $values { "str" string } { "stream" "an output stream" } }
|
||||
{ $contract "Writes a string of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link write } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-flush
|
||||
{ $values { "stream" "an output stream" } }
|
||||
{ $contract "Waits for any pending output to complete." }
|
||||
{ $notes "With many output streams, written output is buffered and not sent to the underlying resource until either the buffer is full, or this word is called." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link flush } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-nl
|
||||
{ $values { "stream" "an output stream" } }
|
||||
{ $contract "Writes a line terminator. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-format
|
||||
|
|
@ -118,6 +158,7 @@ HELP: stream-format
|
|||
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
|
||||
$nl
|
||||
"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: make-block-stream
|
||||
|
|
@ -127,7 +168,7 @@ $nl
|
|||
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
|
||||
$nl
|
||||
"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
|
||||
{ $notes "Instead of calling this word directly, use " { $link with-nesting } "." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-write-table
|
||||
|
|
@ -135,13 +176,13 @@ HELP: stream-write-table
|
|||
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
|
||||
$nl
|
||||
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
|
||||
{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: make-cell-stream
|
||||
{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
|
||||
{ $contract "Creates an output stream which writes to a table cell object." }
|
||||
{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: make-span-stream
|
||||
|
|
@ -149,12 +190,13 @@ HELP: make-span-stream
|
|||
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
|
||||
$nl
|
||||
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
|
||||
{ $notes "Instead of calling this word directly, use " { $link with-style } "." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-print
|
||||
{ $values { "str" string } { "stream" "an output stream" } }
|
||||
{ $description "Writes a newline-terminated string." }
|
||||
{ $notes "Most code only works on one stream at a time and should instead use " { $link print } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-copy
|
||||
|
|
@ -167,17 +209,17 @@ HELP: stdio
|
|||
|
||||
HELP: readln
|
||||
{ $values { "str/f" "a string or " { $link f } } }
|
||||
{ $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
{ $description "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
$io-error ;
|
||||
|
||||
HELP: read1
|
||||
{ $values { "ch/f" "a character or " { $link f } } }
|
||||
{ $contract "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
{ $description "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
$io-error ;
|
||||
|
||||
HELP: read
|
||||
{ $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } }
|
||||
{ $contract "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
|
||||
{ $description "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
|
||||
$io-error ;
|
||||
|
||||
HELP: read-until
|
||||
|
|
@ -192,26 +234,26 @@ $io-error ;
|
|||
|
||||
HELP: write
|
||||
{ $values { "str" string } }
|
||||
{ $contract "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
||||
{ $description "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
||||
$io-error ;
|
||||
|
||||
HELP: flush
|
||||
{ $contract "Waits for any pending output to the " { $link stdio } " stream to complete." }
|
||||
{ $description "Waits for any pending output to the " { $link stdio } " stream to complete." }
|
||||
$io-error ;
|
||||
|
||||
HELP: nl
|
||||
{ $contract "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
||||
{ $description "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
||||
$io-error ;
|
||||
|
||||
HELP: format
|
||||
{ $values { "str" string } { "style" "a hashtable" } }
|
||||
{ $contract "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
||||
{ $description "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
||||
{ $notes "Details are in the documentation for " { $link stream-format } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: with-nesting
|
||||
{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
|
||||
{ $contract "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
|
||||
{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
|
||||
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
|
||||
$io-error ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: arrays io io.files kernel math parser strings system
|
||||
tools.test words namespaces ;
|
||||
IN: temporary
|
||||
IN: io.tests
|
||||
|
||||
[ f ] [
|
||||
"resource:/core/io/test/no-trailing-eol.factor" run-file
|
||||
"foo" "temporary" lookup
|
||||
"foo" "io.tests" lookup
|
||||
] unit-test
|
||||
|
||||
: <resource-reader> ( resource -- stream )
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: tools.test io.files io io.streams.c ;
|
||||
IN: temporary
|
||||
IN: io.streams.c.tests
|
||||
|
||||
[ "hello world" ] [
|
||||
"test.txt" resource-path [
|
||||
"test.txt" temp-file [
|
||||
"hello world" write
|
||||
] with-file-writer
|
||||
|
||||
"test.txt" resource-path "rb" fopen <c-reader> contents
|
||||
"test.txt" temp-file "rb" fopen <c-reader> contents
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ M: object init-stdio
|
|||
stdin-handle stdout-handle <duplex-c-stream> stdio set-global
|
||||
stderr-handle <c-writer> <plain-writer> stderr set-global ;
|
||||
|
||||
M: object io-multiplex (sleep) ;
|
||||
M: object io-multiplex 60 60 * 1000 * or (sleep) ;
|
||||
|
||||
M: object <file-reader>
|
||||
"rb" fopen <c-reader> <line-reader> ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: io.streams.duplex io kernel continuations tools.test ;
|
||||
IN: temporary
|
||||
IN: io.streams.duplex.tests
|
||||
|
||||
! Test duplex stream close behavior
|
||||
TUPLE: closing-stream closed? ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: io.streams.lines io.files io.streams.string io
|
||||
tools.test kernel ;
|
||||
IN: temporary
|
||||
IN: io.streams.lines.tests
|
||||
|
||||
: <resource-reader> ( resource -- stream )
|
||||
resource-path <file-reader> ;
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
USING: io io.streams.string io.streams.nested kernel math
|
||||
namespaces io.styles tools.test ;
|
||||
IN: temporary
|
||||
IN: io.streams.nested.tests
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: io.streams.string io kernel arrays namespaces tools.test ;
|
||||
IN: temporary
|
||||
IN: io.streams.string.tests
|
||||
|
||||
[ "line 1" CHAR: l ]
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: io.tests
|
||||
USE: math
|
||||
: foo 2 2 + ;
|
||||
FORGET: foo
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.thread
|
||||
USING: threads io.backend namespaces init math ;
|
||||
|
||||
: io-thread ( -- )
|
||||
sleep-time io-multiplex yield ;
|
||||
|
||||
: start-io-thread ( -- )
|
||||
[ io-thread t ]
|
||||
"I/O wait" spawn-server
|
||||
\ io-thread set-global ;
|
||||
|
||||
[ start-io-thread ] "io.thread" add-init-hook
|
||||
|
|
@ -139,10 +139,6 @@ ARTICLE: "equality" "Equality and comparison testing"
|
|||
! Defined in handbook.factor
|
||||
ABOUT: "dataflow"
|
||||
|
||||
HELP: version
|
||||
{ $values { "str" string } }
|
||||
{ $description "Outputs the version number of the current Factor instance." } ;
|
||||
|
||||
HELP: eq? ( obj1 obj2 -- ? )
|
||||
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
|
||||
{ $description "Tests if two references point at the same object." } ;
|
||||
|
|
@ -336,7 +332,7 @@ HELP: either?
|
|||
{ $example "5 7 [ even? ] either? ." "f" }
|
||||
} ;
|
||||
|
||||
HELP: call ( quot -- )
|
||||
HELP: call ( callable -- )
|
||||
{ $values { "quot" callable } }
|
||||
{ $description "Calls a quotation."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: arrays byte-arrays kernel kernel.private math memory
|
||||
namespaces sequences tools.test math.private quotations
|
||||
continuations prettyprint io.streams.string debugger assocs ;
|
||||
IN: temporary
|
||||
IN: kernel.tests
|
||||
|
||||
[ 0 ] [ f size ] unit-test
|
||||
[ t ] [ [ \ = \ = ] all-equal? ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,8 +3,6 @@
|
|||
USING: kernel.private ;
|
||||
IN: kernel
|
||||
|
||||
: version ( -- str ) "0.92" ; foldable
|
||||
|
||||
! Stack stuff
|
||||
: spin ( x y z -- z y x ) swap rot ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -32,3 +32,7 @@ SYMBOL: type-numbers
|
|||
|
||||
: most-negative-fixnum ( -- n )
|
||||
first-bignum neg ;
|
||||
|
||||
M: real >integer
|
||||
dup most-negative-fixnum most-positive-fixnum between?
|
||||
[ >fixnum ] [ >bignum ] if ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov
|
||||
! Copyright (C) 2007 Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien assocs continuations init inspector kernel namespaces ;
|
||||
USING: alien assocs continuations init kernel namespaces ;
|
||||
IN: libc
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -25,28 +25,22 @@ PRIVATE>
|
|||
|
||||
TUPLE: check-ptr ;
|
||||
|
||||
M: check-ptr summary drop "Memory allocation failed" ;
|
||||
|
||||
: check-ptr ( c-ptr -- c-ptr )
|
||||
[ \ check-ptr construct-boa throw ] unless* ;
|
||||
|
||||
TUPLE: double-free ;
|
||||
|
||||
M: double-free summary drop "Free failed since memory is not allocated" ;
|
||||
|
||||
: double-free ( -- * )
|
||||
\ double-free construct-empty throw ;
|
||||
|
||||
TUPLE: realloc-error ptr size ;
|
||||
|
||||
M: realloc-error summary drop "Memory reallocation failed" ;
|
||||
|
||||
: realloc-error ( alien size -- * )
|
||||
\ realloc-error construct-boa throw ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
[ H{ } clone mallocs set-global ] "mallocs" add-init-hook
|
||||
[ H{ } clone mallocs set-global ] "libc" add-init-hook
|
||||
|
||||
: add-malloc ( alien -- )
|
||||
dup mallocs get-global set-at ;
|
||||
|
|
|
|||
|
|
@ -38,9 +38,6 @@ HELP: listen
|
|||
{ $description "Prompts for an expression on the " { $link stdio } " stream and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
|
||||
{ $errors "If the expression input by the user throws an error, the error is printed to the " { $link stdio } " stream and the word returns normally." } ;
|
||||
|
||||
HELP: print-banner
|
||||
{ $description "Print Factor version, operating system, and CPU architecture." } ;
|
||||
|
||||
HELP: listener
|
||||
{ $description "Prompts for expressions on the " { $link stdio } " stream and evaluates them until end of file is reached." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: io io.streams.string io.streams.duplex listener
|
||||
tools.test parser math namespaces continuations vocabs kernel
|
||||
compiler.units ;
|
||||
IN: temporary
|
||||
IN: listener.tests
|
||||
|
||||
: hello "Hi" print ; parsing
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ IN: temporary
|
|||
<string-reader> stream-read-quot ;
|
||||
|
||||
[ [ ] ] [
|
||||
"USE: temporary hello" parse-interactive
|
||||
"USE: listener.tests hello" parse-interactive
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -45,6 +45,6 @@ IN: temporary
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: temporary : hello\n\"world\" ;" parse-interactive
|
||||
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
|
||||
drop
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays hashtables io kernel math memory namespaces
|
||||
parser sequences strings io.styles io.streams.lines
|
||||
USING: arrays hashtables io kernel math math.parser memory
|
||||
namespaces parser sequences strings io.styles io.streams.lines
|
||||
io.streams.duplex vectors words generic system combinators
|
||||
tuples continuations debugger definitions compiler.units ;
|
||||
IN: listener
|
||||
|
|
@ -62,11 +62,7 @@ M: duplex-stream stream-read-quot
|
|||
[ quit-flag off ]
|
||||
[ listen until-quit ] if ; inline
|
||||
|
||||
: print-banner ( -- )
|
||||
"Factor " write version write
|
||||
" on " write os write "/" write cpu print ;
|
||||
|
||||
: listener ( -- )
|
||||
print-banner [ until-quit ] with-interactive-vocabs ;
|
||||
[ until-quit ] with-interactive-vocabs ;
|
||||
|
||||
MAIN: listener
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: math math.bitfields tools.test kernel words ;
|
||||
IN: temporary
|
||||
IN: math.bitfields.tests
|
||||
|
||||
[ 0 ] [ { } bitfield ] unit-test
|
||||
[ 256 ] [ 1 { 8 } bitfield ] unit-test
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue