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

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

db4
Aaron Schaefer 2008-02-29 14:43:55 -05:00
parent 24f5c9e40d ad2d06806b
commit 5c62133688
594 changed files with 10205 additions and 422216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@ -15,3 +15,7 @@ factor
.gdb_history
*.*.marks
.*.swp
temp
logs
work
misc/wordsize

11
Makefile
View File

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

4
README.txt Normal file → Executable file
View File

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

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

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

13
core/alien/alien.factor
View File

@ -53,18 +53,11 @@ TUPLE: library path abi dll ;
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library ) f \ library construct-boa ;
: <library> ( path abi -- library )
over dup [ dlopen ] when \ library construct-boa ;
: load-library ( name -- dll )
library dup [
dup library-dll [ ] [
dup library-path dup [
dlopen dup rot set-library-dll
] [
2drop f
] if
] ?if
] when ;
library library-dll ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;

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

@ -315,7 +315,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
data-gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] string-out
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
: callback-5

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

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator generator.registers generator.fixup
hashtables kernel math namespaces sequences words
@ -213,30 +213,37 @@ TUPLE: no-such-library name ;
M: no-such-library summary
drop "Library not found" ;
M: no-such-library compiler-error-type
drop +linkage+ ;
: no-such-library ( name -- )
\ no-such-library +linkage+ (inference-error) ;
\ no-such-library construct-boa
compiling-word get compiler-error ;
: (alien-invoke-dlsym) ( node -- symbol dll )
dup alien-invoke-function
swap alien-invoke-library [
load-library
] [
2drop no-such-library
] recover ;
TUPLE: no-such-symbol ;
TUPLE: no-such-symbol name ;
M: no-such-symbol summary
drop "Symbol not found" ;
: no-such-symbol ( -- )
\ no-such-symbol +linkage+ (inference-error) ;
M: no-such-symbol compiler-error-type
drop +linkage+ ;
: alien-invoke-dlsym ( node -- symbol dll )
dup (alien-invoke-dlsym) 2dup dlsym [
>r over stdcall-mangle r> 2dup dlsym
[ no-such-symbol ] unless
] unless rot drop ;
: no-such-symbol ( name -- )
\ no-such-symbol construct-boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd [ dlsym ] curry contains?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
] if ;
: alien-invoke-dlsym ( node -- symbols dll )
dup alien-invoke-function dup pick stdcall-mangle 2array
swap alien-invoke-library library dup [ library-dll ] when
2dup check-dlsym ;
\ alien-invoke [
! Four literals
@ -247,8 +254,6 @@ M: no-such-symbol summary
pop-literal nip over set-alien-invoke-function
pop-literal nip over set-alien-invoke-library
pop-literal nip over set-alien-invoke-return
! If symbol doesn't resolve, no stack effect, no compile
dup alien-invoke-dlsym 2drop
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! Add node to IR
@ -326,7 +331,7 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry
alien-callback-xt [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
\ alien-callback [
@ -362,7 +367,7 @@ TUPLE: callback-context ;
] if ;
: do-callback ( quot token -- )
init-error-handler
init-catchstack
dup 2 setenv
slip
wait-to-return ; inline
@ -398,7 +403,7 @@ TUPLE: callback-context ;
callback-unwind %unwind ;
: generate-callback ( node -- )
dup alien-callback-xt dup rot [
dup alien-callback-xt dup [
init-templates
%save-word-xt
%prologue-later
@ -407,7 +412,7 @@ TUPLE: callback-context ;
dup wrap-callback-quot %alien-callback
%callback-return
] with-stack-frame
] generate-1 ;
] with-generator ;
M: alien-callback generate-node
end-basic-block generate-callback iterate-next ;

0
core/alien/remote-control/remote-control.factor Normal file → Executable file
View File

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

@ -9,18 +9,20 @@ C-STRUCT: bar
[ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
C-STRUCT: align-test
{ "int" "x" }
{ "double" "y" } ;
! This was actually only correct on Windows/x86:
[ 16 ] [ "align-test" heap-size ] unit-test
cell 4 = [
C-STRUCT: one
{ "long" "a" } { "double" "b" } { "int" "c" } ;
[ 24 ] [ "one" heap-size ] unit-test
] when
! C-STRUCT: align-test
! { "int" "x" }
! { "double" "y" } ;
!
! [ 16 ] [ "align-test" heap-size ] unit-test
!
! cell 4 = [
! C-STRUCT: one
! { "long" "a" } { "double" "b" } { "int" "c" } ;
!
! [ 24 ] [ "one" heap-size ] unit-test
! ] when
: MAX_FOOS 30 ;

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

@ -59,6 +59,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
{ $subsection diff }
{ $subsection remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
{ $see-also key? } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
@ -266,12 +267,16 @@ HELP: remove-all
{ $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." }
{ $side-effects "assoc" } ;
HELP: substitute
{ $values { "assoc" assoc } { "seq" "a mutable sequence" } }
{ $description "Replaces elements of " { $snippet "seq" } " which appear in as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
HELP: substitute-here
{ $values { "seq" "a mutable sequence" } { "assoc" assoc } }
{ $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
{ $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." }
{ $side-effects "seq" } ;
HELP: substitute
{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
HELP: cache
{ $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }

10
core/assocs/assocs.factor
View File

@ -124,8 +124,14 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry subset ;
: substitute ( assoc seq -- )
swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
: (substitute)
[ dupd at* [ nip ] [ drop ] if ] curry ; inline
: substitute-here ( seq assoc -- )
(substitute) change-each ;
: substitute ( seq assoc -- newseq )
(substitute) map ;
: cache ( key assoc quot -- value )
2over at [

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

@ -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,6 +82,4 @@ nl
malloc free memcpy
} compile
[ compiled-usages recompile ] recompile-hook set-global
" done" print flush

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

@ -36,7 +36,7 @@ IN: bootstrap.image
: data-base 1024 ; inline
: userenv-size 40 ; inline
: userenv-size 64 ; inline
: header-size 10 ; inline
@ -416,7 +416,7 @@ M: curry '
"Writing image to " write
architecture get boot-image-name resource-path
dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ;
[ (write-image) ] with-file-writer ;
PRIVATE>

8
core/bootstrap/primitives.factor
View File

@ -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
@ -98,7 +101,7 @@ H{ } clone update-map set
[
over "type" word-prop dup
\ tag-mask get < \ tag \ type ? , , \ eq? ,
] [ ] make define-predicate ;
] [ ] make define-predicate* ;
: register-builtin ( class -- )
dup "type" word-prop builtins get set-nth ;
@ -646,6 +649,7 @@ builtins get num-tags get tail f union-class define-class
{ "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
}
dup length [ >r first2 r> make-primitive ] 2each

14
core/bootstrap/stage1.factor
View File

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

107
core/bootstrap/stage2.factor
View File

@ -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,65 +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 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
] [
print-error :c 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

38
core/boxes/boxes-docs.factor Executable file
View File

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

24
core/boxes/boxes-tests.factor Executable file
View File

@ -0,0 +1,24 @@
IN: temporary
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

21
core/boxes/boxes.factor Executable file
View File

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

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

@ -119,7 +119,7 @@ HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
HELP: define-predicate
HELP: define-predicate*
{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
{ $description
"Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
@ -132,6 +132,13 @@ HELP: define-predicate
}
$low-level-note ;
HELP: define-predicate
{ $values { "class" class } { "quot" "a quotation" } }
{ $description
"Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
}
$low-level-note ;
HELP: superclass
{ $values { "class" class } { "super" class } }
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }

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

@ -63,7 +63,7 @@ UNION: bah fixnum alien ;
! Test generic see and parsing
[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] string-out ] unit-test
[ [ \ bah see ] with-string-writer ] unit-test
! Test redefinition of classes
UNION: union-1 fixnum float ;

12
core/classes/classes.factor
View File

@ -31,13 +31,16 @@ PREDICATE: class tuple-class
PREDICATE: word predicate "predicating" word-prop >boolean ;
: define-predicate ( class predicate quot -- )
: define-predicate* ( class predicate quot -- )
over [
dupd predicate-effect define-declared
2dup 1quotation "predicate" set-word-prop
swap "predicating" set-word-prop
] [
3drop
] [ 3drop ] if ;
: define-predicate ( class quot -- )
over "forgotten" word-prop [ 2drop ] [
>r dup predicate-word r> define-predicate*
] if ;
: superclass ( class -- super )
@ -252,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 ;

2
core/classes/predicate/predicate.factor Normal file → Executable file
View File

@ -16,7 +16,7 @@ PREDICATE: class predicate-class
: define-predicate-class ( superclass class definition -- )
>r dup f roll predicate-class define-class r>
dupd "predicate-definition" set-word-prop
dup predicate-word over predicate-quot define-predicate ;
dup predicate-quot define-predicate ;
M: predicate-class reset-class
{

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

@ -31,9 +31,7 @@ PREDICATE: class union-class
] if ;
: define-union-predicate ( class -- )
dup predicate-word
over members union-predicate-quot
define-predicate ;
dup members union-predicate-quot define-predicate ;
M: union-class update-predicate define-union-predicate ;

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

@ -7,11 +7,7 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
{ $subsection cond>quot }
{ $subsection case>quot }
{ $subsection alist>quot }
"A powerful tool used to optimize code in several places is open-coded hashtable dispatch:"
{ $subsection hash-case>quot }
{ $subsection distribute-buckets }
{ $subsection hash-dispatch-quot } ;
{ $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators"
"The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":"
@ -104,19 +100,17 @@ HELP: case>quot
{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl
"The quotation actually tests each possible case in order;" { $link hash-case>quot } " produces more efficient code." } ;
"This word uses three strategies:"
{ $list
"If the assoc only has a few keys, a linear search is generated."
{ "If the assoc has a large number of keys which form a contiguous range of integers, a direct dispatch is generated using the " { $link dispatch } " word together with a bounds check." }
"Otherwise, an open-coded hashtable dispatch is generated."
} } ;
HELP: distribute-buckets
{ $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } }
{ $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
{ $notes "This word is used in the implemention of " { $link hash-case>quot } " and " { $link standard-combination } "." } ;
HELP: hash-case>quot
{ $values { "default" quotation } { "assoc" "an association list mapping quotations to quotations" } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl
"The quotation uses an efficient hash-based search to avoid testing the object against all possible keys." }
{ $notes "This word is used behind the scenes to compile " { $link case } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
HELP: dispatch ( n array -- )
{ $values { "n" "a fixnum" } { "array" "an array of quotations" } }

7
core/combinators/combinators-tests.factor Normal file → Executable file
View File

@ -69,3 +69,10 @@ namespaces combinators words ;
! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test

55
core/combinators/combinators.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors ;
kernel kernel.private math assocs quotations vectors
hashtables sorting ;
TUPLE: no-cond ;
@ -31,16 +32,24 @@ TUPLE: no-case ;
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two depend on combinators
M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
: alist>quot ( default assoc -- quot )
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
reverse [ no-cond ] swap alist>quot ;
: case>quot ( default assoc -- quot )
: linear-case-quot ( default assoc -- quot )
[ >r [ dupd = ] curry r> \ drop add* ] assoc-map
alist>quot ;
@ -63,20 +72,50 @@ M: sequence hashcode*
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
[ case>quot ] with map ;
[ linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
[ dispatch ] curry append ;
: hash-case>quot ( default assoc -- quot )
: hash-case-quot ( default assoc -- quot )
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append ;
: contiguous-range? ( keys -- from to ? )
dup [ fixnum? ] all? [
dup all-unique? [
dup infimum over supremum
[ - swap prune length + 1 = ] 2keep rot
] [
drop f f f
] if
] [
drop f f f
] if ;
: dispatch-case ( value from to default array -- )
>r >r 3dup between? [
drop - >fixnum r> drop r> dispatch
] [
2drop r> call r> drop
] if ; inline
: dispatch-case-quot ( default assoc from to -- quot )
-roll -roll sort-keys values [ >quotation ] map
[ dispatch-case ] 2curry 2curry ;
: case>quot ( default assoc -- quot )
dup empty? [
drop
] [
dup length 4 <= [
case>quot
linear-case-quot
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
dup keys contiguous-range? [
dispatch-case-quot
] [
2drop hash-case-quot
] if
] if
] if ;

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

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

33
core/compiler/compiler.factor
View File

@ -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 ;
@ -24,13 +19,12 @@ IN: compiler
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
f pick compiler-error
over compiled-unxref
over crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[
dup word-dataflow >r swap dup r> optimize generate
[ word-dataflow optimize ] keep dup generate
] computing-dependencies ;
: compile-failed ( word error -- )
@ -38,6 +32,7 @@ IN: compiler
swap compiler-error ;
: (compile) ( word -- )
f over compiler-error
[ dup compile-succeeded finish-compile ]
[ dupd compile-failed f save-effect ]
recover ;
@ -49,25 +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 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 ;
compiled get >alist
] with-scope ;
: recompile-all ( -- )
[ all-words recompile ] with-compiler-errors ;
: decompile ( word -- )
f 2array 1array modify-code-heap ;
forget-errors all-words compile ;

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

@ -1,5 +1,5 @@
USING: tools.test compiler quotations math kernel sequences
assocs namespaces ;
USING: tools.test quotations math kernel sequences
assocs namespaces compiler.units ;
IN: temporary
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test

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

@ -1,5 +1,5 @@
IN: temporary
USING: compiler kernel kernel.private memory math
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

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

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

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

@ -1,4 +1,4 @@
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
@ -227,3 +227,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
[ 3 ] [ t single-combination-test-2 ] unit-test
[ 3 ] [ 3 single-combination-test-2 ] unit-test
[ f ] [ f single-combination-test-2 ] unit-test
! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test

6
core/compiler/tests/stack-trace.factor
View File

@ -1,7 +1,7 @@
IN: temporary
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting ;
words splitting sorting ;
: symbolic-stack-trace ( -- newseq )
error-continuation get continuation-call callstack>array
@ -31,9 +31,9 @@ words splitting ;
\ > stack-trace-contains?
] unit-test
: quux [ t [ "hi" throw ] when ] times ;
: quux { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
\ (each-integer) stack-trace-contains?
\ sort stack-trace-contains?
] unit-test

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

@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
[
[ ] [ init-templates ] unit-test
[ ] [ init-generator ] unit-test
H{ } clone compiled set
[ ] [ gensym gensym begin-compiling ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test

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

@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
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 ;
words definitions compiler.units io combinators ;
IN: temporary
! Oops!
@ -191,3 +191,18 @@ TUPLE: my-tuple ;
2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-call
] unit-test
! Regression
: a-dummy drop "hi" print ;
[ ] [
1 [
dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
drop - >fixnum {
[ a-dummy ]
[ a-dummy ]
[ a-dummy ]
} dispatch
] [ 2drop no-case ] if
] compile-call
] unit-test

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

@ -1,5 +1,5 @@
IN: temporary
USING: kernel tools.test compiler ;
USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ;

8
core/compiler/units/units-docs.factor
View File

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

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

@ -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,20 +64,46 @@ 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
: compile-call ( quot -- )
[ define-temp ] with-compilation-unit execute ;
: default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ;
recompile-hook global
[ [ [ f ] { } map>assoc modify-code-heap ] or ]
[ [ default-recompile-hook ] or ]
change-at

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

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

55
core/continuations/continuations.factor
View File

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

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

@ -128,7 +128,7 @@ HOOK: %prepare-var-args compiler-backend ( -- )
M: object %prepare-var-args ;
HOOK: %alien-invoke compiler-backend ( library function -- )
HOOK: %alien-invoke compiler-backend ( function library -- )
HOOK: %cleanup compiler-backend ( alien-node -- )

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

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

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

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

4
core/debugger/debugger-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: debugger kernel continuations tools.test ;
[ ] [ [ drop ] [ error. ] recover ] unit-test

77
core/debugger/debugger.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
generic.standard ;
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 ;
@ -254,3 +250,52 @@ M: no-compilation-unit error.
"Attempting to define " write
no-compilation-unit-definition pprint
" outside of a compilation unit" print ;
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

2
core/definitions/definitions.factor
View File

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

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

@ -111,7 +111,8 @@ SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ;
: string>symbol ( str -- alien )
wince? [ string>u16-alien ] [ string>char-alien ] if ;
[ wince? [ string>u16-alien ] [ string>char-alien ] if ]
over string? [ call ] [ map ] if ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
@ -140,17 +141,19 @@ SYMBOL: literal-table
V{ } clone relocation-table set
V{ } clone label-table set ;
: generate-labels ( -- labels )
label-table get [
: resolve-labels ( labels -- labels' )
[
first3 label-offset
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( code -- relocation-table label-table code )
: fixup ( code -- literals relocation labels code )
[
init-fixup
dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >array
generate-labels
label-table get resolve-labels
] { } make ;

17
core/generator/generator-docs.factor
View File

@ -22,34 +22,35 @@ HELP: compiled
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiling-label
{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiled-stack-traces?
{ $values { "?" "a boolean" } }
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
HELP: literal-table
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
HELP: init-generator
HELP: begin-compiling
{ $values { "word" word } { "label" word } }
{ $description "Prepares to generate machine code for a word." } ;
HELP: generate-1
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
HELP: with-generator
{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
HELP: generate-node
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate-nodes
{ $values { "node" "a dataflow node" } }
{ $description "Recursively generate machine code for a dataflow graph." }
{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }

123
core/generator/generator.factor
View File

@ -11,12 +11,6 @@ IN: generator
SYMBOL: compile-queue
SYMBOL: compiled
: begin-compiling ( word -- )
f swap compiled get set-at ;
: finish-compiling ( word literals relocation labels code -- )
4array swap compiled get set-at ;
: queue-compile ( word -- )
{
{ [ dup compiled get key? ] [ drop ] }
@ -32,24 +26,31 @@ SYMBOL: compiling-word
SYMBOL: compiling-label
SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
: init-generator ( -- )
: begin-compiling ( word label -- )
H{ } clone compiling-loops set
compiling-label set
compiling-word set
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set ;
compiling-word get f ?
1vector literal-table set
f compiling-word get compiled get set-at ;
: generate-1 ( word label node quot -- )
pick begin-compiling [
roll compiling-word set
pick compiling-label set
init-generator
call
literal-table get >array
] { } make fixup finish-compiling ;
: finish-compiling ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( node word label quot -- )
[
>r begin-compiling r>
{ } make fixup
finish-compiling
] with-scope ; inline
GENERIC: generate-node ( node -- next )
@ -62,12 +63,12 @@ GENERIC: generate-node ( node -- next )
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
: generate ( word label node -- )
: generate ( node word label -- )
[
init-generate-nodes
[ generate-nodes ] with-node-iterator
] generate-1 ;
] with-generator ;
: word-dataflow ( word -- effect dataflow )
[
@ -82,25 +83,6 @@ GENERIC: generate-node ( node -- next )
: if-intrinsics ( #call -- quot )
node-param "if-intrinsics" word-prop ;
DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
PREDICATE: #values #terminal-values node-successor #terminal? ;
PREDICATE: #call #terminal-call
dup node-successor #if?
over node-successor node-successor #terminal? and
swap if-intrinsics and ;
UNION: #terminal
POSTPONE: f #return #terminal-values #terminal-merge ;
: tail-call? ( -- ? )
node-stack get [
dup #terminal-call? swap node-successor #terminal? or
] all? ;
! node
M: node generate-node drop iterate-next ;
@ -112,20 +94,34 @@ M: node generate-node drop iterate-next ;
: generate-call ( label -- next )
dup maybe-compile
end-basic-block
tail-call? [
%jump f
dup compiling-loops get at [
%jump-label f
] [
0 frame-required
%call
iterate-next
] if ;
tail-call? [
%jump f
] [
0 frame-required
%call
iterate-next
] if
] ?if ;
! #label
M: #label generate-node
dup node-param generate-call >r
dup #label-word over node-param rot node-child generate
dup node-child over #label-word rot node-param generate
r> ;
! #loop
: compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ;
M: #loop generate-node
end-basic-block
dup node-param compiling-loop
node-child generate-nodes
iterate-next ;
! #if
: end-false-branch ( label -- )
tail-call? [ %return drop ] [ %jump-label ] if ;
@ -150,25 +146,18 @@ M: #if generate-node
! #dispatch
: dispatch-branch ( node word -- label )
gensym [
rot [
[
copy-templates
%save-dispatch-xt
%prologue-later
[ generate-nodes ] with-node-iterator
] generate-1
] with-generator
] keep ;
: tail-dispatch? ( node -- ? )
#! Is the dispatch a jump to a tail call to a word?
dup #call? swap node-successor #return? and ;
: dispatch-branches ( node -- )
node-children [
dup tail-dispatch? [
node-param
] [
compiling-word get dispatch-branch
] if %dispatch-label
compiling-word get dispatch-branch
%dispatch-label
] each ;
: generate-dispatch ( node -- )
@ -182,10 +171,10 @@ M: #dispatch generate-node
generate-dispatch iterate-next
] [
compiling-word get gensym [
rot [
[
init-generate-nodes
generate-dispatch
] generate-1
] with-generator
] keep generate-call
] if ;
@ -224,10 +213,11 @@ M: #dispatch generate-node
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: do-if-intrinsic ( #call pair -- next )
<label> [ swap do-template ] keep
>r node-successor r> generate-if
node-successor ;
: do-if-intrinsic ( pair -- next )
<label> [
swap do-template
node> node-successor dup >node
] keep generate-if ;
: find-intrinsic ( #call -- pair/f )
intrinsics find-template ;
@ -249,7 +239,7 @@ M: #call generate-node
] [
node-param generate-call
] ?if
] if* ;
] ?if ;
! #call-label
M: #call-label generate-node node-param generate-call ;
@ -274,4 +264,7 @@ M: #r> generate-node
iterate-next ;
! #return
M: #return generate-node drop end-basic-block %return f ;
M: #return generate-node
end-basic-block
node-param compiling-loops get key?
[ %return ] unless f ;

2
core/generator/registers/registers.factor Normal file → Executable file
View File

@ -504,7 +504,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
[ swap substitute ] curry each-phantom ;
[ substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ;

38
core/generic/generic.factor
View File

@ -30,6 +30,7 @@ M: generic definer drop f f ;
M: generic definition drop f ;
: make-generic ( word -- )
dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ;
TUPLE: method word def specializer generic loc ;
@ -81,10 +82,19 @@ M: method-body stack-effect
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ;
: redefine-method ( quot class generic -- )
[ method set-method-def ] 3keep
[ make-method-def ] 2keep
method method-word swap define ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
[ <method> ] 2keep
[ set-at ] with-methods ;
2dup method [
redefine-method
] [
[ <method> ] 2keep
[ set-at ] with-methods
] if ;
: define-default-method ( generic combination -- )
dupd make-default-method object bootstrap-word pick <method>
@ -92,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 ;
@ -104,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 [

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

@ -58,16 +58,15 @@ TUPLE: no-math-method left right generic ;
2drop object-method
] if ;
: math-vtable* ( picker max quot -- quot )
: math-vtable ( picker quot -- quot )
[
rot , \ tag ,
[ >r [ bootstrap-type>class ] map r> map % ] { } make ,
>r
, \ tag ,
num-tags get [ bootstrap-type>class ]
r> compose map ,
\ dispatch ,
] [ ] make ; inline
: math-vtable ( picker quot -- quot )
num-tags get swap math-vtable* ; inline
TUPLE: math-combination ;
M: math-combination make-default-method

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

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
@ -77,7 +77,6 @@ TUPLE: no-method object generic ;
class-predicates alist>quot ;
: small-generic ( methods -- def )
[ 1quotation ] assoc-map
object method-alist>quot ;
: hash-methods ( methods -- buckets )
@ -110,7 +109,7 @@ TUPLE: no-method object generic ;
: build-type-vtable ( alist-seq -- alist-seq )
dup length [
vtable-class
swap [ word-def ] assoc-map simplify-alist
swap simplify-alist
class-predicates alist>quot
] 2map ;
@ -145,7 +144,8 @@ TUPLE: no-method object generic ;
] if ;
: standard-methods ( word -- alist )
dup methods swap default-method add* ;
dup methods swap default-method add*
[ 1quotation ] assoc-map ;
M: standard-combination make-default-method
standard-combination-# (dispatch#)
@ -161,9 +161,6 @@ TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
M: hook-combination method-prologue
2drop [ drop ] ;
: with-hook ( combination quot -- quot' )
0 (dispatch#) [
swap slip
@ -175,7 +172,11 @@ M: hook-combination make-default-method
[ error-method ] with-hook ;
M: hook-combination perform-combination
[ standard-methods single-combination ] with-hook ;
[
standard-methods
[ [ drop ] swap append ] assoc-map
single-combination
] with-hook ;
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;

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

@ -157,8 +157,12 @@ H{ } "x" set
] unit-test
[ { "one" "two" 3 } ] [
H{ { 1 "one" } { 2 "two" } }
{ 1 2 3 } clone [ substitute ] keep
{ 1 2 3 } clone dup
H{ { 1 "one" } { 2 "two" } } substitute-here
] unit-test
[ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test

20
core/hashtables/hashtables.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
math.private sequences sequences.private vectors
combinators ;
math.private sequences sequences.private vectors ;
IN: hashtables
<PRIVATE
@ -17,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@)
] [
@ -41,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
] [
@ -161,17 +158,10 @@ M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;
M: hashtable equal?
{
{ [ over hashtable? not ] [ 2drop f ] }
{ [ 2dup [ assoc-size ] 2apply number= not ] [ 2drop f ] }
{ [ t ] [ assoc= ] }
} cond ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
over hashtable? [
2dup [ assoc-size ] 2apply number=
[ assoc= ] [ 2drop f ] if
] [ 2drop f ] if ;
! Default method
M: assoc new-assoc drop <hashtable> ;

71
core/heaps/heaps-docs.factor Normal file → Executable file
View File

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

77
core/heaps/heaps-tests.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
! 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 ;
heaps heaps.private math.parser random assocs sequences sorting ;
IN: temporary
[ <min-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

189
core/heaps/heaps.factor Normal file → Executable file
View File

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

12
core/inference/class/class-tests.factor
View File

@ -283,3 +283,15 @@ cell-bits 32 = [
[ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
\ number= inlined?
] unit-test
[ t ] [
[ HEX: ff bitand 0 HEX: ff between? ]
\ >= inlined?
] unit-test
[ t ] [
[ HEX: ff swap HEX: ff bitand >= ]
\ >= inlined?
] unit-test

3
core/inference/dataflow/dataflow-docs.factor
View File

@ -1,4 +1,5 @@
USING: inference.dataflow help.syntax help.markup ;
USING: help.syntax help.markup ;
IN: inference.dataflow
HELP: #return
{ $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }

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

@ -97,11 +97,13 @@ M: object flatten-curry , ;
: node-child node-children first ;
TUPLE: #label word ;
TUPLE: #label word loop? ;
: #label ( word label -- node )
\ #label param-node [ set-#label-word ] keep ;
PREDICATE: #label #loop #label-loop? ;
TUPLE: #entry ;
: #entry ( -- node ) \ #entry all-out-node ;
@ -304,3 +306,19 @@ SYMBOL: node-stack
node-children
[ last-node ] map
[ #terminate? not ] subset ;
DEFER: #tail?
PREDICATE: #merge #tail-merge node-successor #tail? ;
PREDICATE: #values #tail-values node-successor #tail? ;
UNION: #tail
POSTPONE: f #return #tail-values #tail-merge #terminate ;
: tail-call? ( -- ? )
#! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
node-successor dup #tail? swap #terminate? not and
] all? ;

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

@ -5,7 +5,7 @@ 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 ;
io.thread sequences.private ;
IN: temporary
{ 0 2 } [ 2 "Hello" ] 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

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

@ -10,7 +10,7 @@ namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private tuples tuples.private vectors vectors.private
words words.private assocs inspector ;
words words.private assocs inspector compiler.units ;
IN: inference.known-words
! Shuffle words
@ -345,7 +345,7 @@ M: object infer-call
\ <word> { object object } { word } <effect> set-primitive-effect
\ <word> make-flushable
\ word-xt { word } { integer } <effect> set-primitive-effect
\ word-xt { word } { integer integer } <effect> set-primitive-effect
\ word-xt make-flushable
\ getenv { fixnum } { object } <effect> set-primitive-effect
@ -596,3 +596,7 @@ set-primitive-effect
\ (os-envs) { } { array } <effect> set-primitive-effect
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect
\ modify-code-heap { array object } { } <effect> set-primitive-effect

2
core/inference/state/state-tests.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: tools.test inference.state ;
USING: tools.test inference.state words ;
SYMBOL: a
SYMBOL: b

5
core/inference/state/state.factor
View File

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

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

@ -35,7 +35,7 @@ IN: inference.transforms
dup peek swap 1 head*
] [
[ no-case ] swap
] if hash-case>quot
] if case>quot
] if
] 1 define-transform

7
core/init/init-tests.factor Normal file
View File

@ -0,0 +1,7 @@
IN: temporary
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

2
core/init/init.factor Normal file → Executable file
View File

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

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

@ -8,4 +8,4 @@ f describe
H{ } describe
H{ } describe
[ "fixnum instance\n" ] [ [ 3 describe ] string-out ] unit-test
[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test

11
core/inspector/inspector.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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

6
core/io/backend/backend.factor
View File

@ -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
core/io/encodings/authors.txt
View File

@ -1 +1,2 @@
Daniel Ehrenberg
Slava Pestov

0
core/io/utf16/authors.txt → core/io/encodings/binary/authors.txt
View File

5
core/io/encodings/binary/binary-docs.factor Normal file
View File

@ -0,0 +1,5 @@
USING: help.syntax help.markup ;
IN: io.encodings.binary
HELP: binary
{ $class-description "This is the encoding descriptor for binary I/O." } ;

3
core/io/encodings/binary/binary.factor Normal file
View File

@ -0,0 +1,3 @@
USING: kernel io.encodings ;
TUPLE: binary ;

1
core/io/encodings/binary/summary.txt Normal file
View File

@ -0,0 +1 @@
Dummy encoding for binary I/O

1
core/io/encodings/binary/tags.txt Normal file
View File

@ -0,0 +1 @@
text

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

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors
namespaces unicode.syntax ;
USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
namespaces unicode growable strings io classes io.streams.c
continuations ;
IN: io.encodings
TUPLE: encode-error ;
@ -18,11 +19,77 @@ SYMBOL: begin
over push 0 begin ;
: push-replacement ( buf -- buf ch state )
UNICHAR: replacement-character decoded ;
CHAR: replacement-character decoded ;
: finish-decoding ( buf ch state -- str )
begin eq? [ decode-error ] unless drop "" like ;
: decode ( seq quot -- str )
>r [ length <sbuf> 0 begin ] keep r> each
: start-decoding ( seq length -- buf ch state seq )
<sbuf> 0 begin roll ;
GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
: decode ( seq quot -- string )
>r dup length start-decoding r>
[ -rot ] swap compose each
finish-decoding ; inline
: space ( resizable -- room-left )
dup underlying swap [ length ] 2apply - ;
: full? ( resizable -- ? ) space zero? ;
: end-read-loop ( buf ch state stream quot -- string/f )
2drop 2drop >string f like ;
: decode-read-loop ( buf ch state stream encoding -- string/f )
>r >r pick r> r> rot full? [ end-read-loop ] [
over stream-read1 [
-rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop
] [ end-read-loop ] if*
] if ;
: decode-read ( length stream encoding -- string )
>r swap start-decoding r>
decode-read-loop ;
: <decoding> ( stream decoding-class -- decoded-stream )
construct-delegate <line-reader> ;
: <encoding> ( stream encoding-class -- encoded-stream )
construct-delegate <plain-writer> ;
GENERIC: encode-string ( string encoding -- byte-array )
M: tuple-class encode-string construct-empty encode-string ;
MIXIN: encoding-stream
M: encoding-stream stream-read1 1 swap stream-read ;
M: encoding-stream stream-read
[ delegate ] keep decode-read ;
M: encoding-stream stream-read-partial stream-read ;
M: encoding-stream stream-read-until
! Copied from { c-reader stream-read-until }!!!
[ swap read-until-loop ] "" make
swap over empty? over not and [ 2drop f f ] when ;
M: encoding-stream stream-write1
>r 1string r> stream-write ;
M: encoding-stream stream-write
[ encode-string ] keep delegate stream-write ;
M: encoding-stream dispose delegate dispose ;
GENERIC: underlying-stream ( encoded-stream -- delegate )
M: encoding-stream underlying-stream delegate ;
GENERIC: set-underlying-stream ( new-underlying stream -- )
M: encoding-stream set-underlying-stream set-delegate ;
: set-encoding ( encoding stream -- ) ! This doesn't work now
[ underlying-stream swap construct-delegate ] keep
set-underlying-stream ;

0
core/io/utf8/authors.txt → core/io/encodings/latin1/authors.txt
View File

5
core/io/encodings/latin1/latin1-docs.factor Normal file
View File

@ -0,0 +1,5 @@
USING: help.syntax help.markup ;
IN: io.encodings.latin1
HELP: latin1
{ $class-description "This class is used for Latin 1 (ISO 8859-1) encoding and decoding" } ;

10
core/io/encodings/latin1/latin1.factor Executable file
View File

@ -0,0 +1,10 @@
USING: io io.encodings strings kernel ;
IN: io.encodings.latin1
TUPLE: latin1 ;
M: latin1 stream-read delegate stream-read >string ;
M: latin1 stream-read-until delegate stream-read-until >string ;
M: latin1 stream-read-partial delegate stream-read-partial >string ;

1
core/io/encodings/latin1/summary.txt Normal file
View File

@ -0,0 +1 @@
ISO 8859-1 encoding/decoding

1
core/io/encodings/latin1/tags.txt Normal file
View File

@ -0,0 +1 @@
text

1
core/io/encodings/tags.txt Normal file
View File

@ -0,0 +1 @@
text

BIN
core/io/encodings/utf16/.utf16.factor.swo Normal file
View File

Binary file not shown.

1
core/io/encodings/utf16/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

0
core/io/utf16/summary.txt → core/io/encodings/utf16/summary.txt
View File

1
core/io/encodings/utf16/tags.txt Normal file
View File

@ -0,0 +1 @@
text

2
core/io/utf16/utf16-docs.factor → core/io/encodings/utf16/utf16-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io.encodings strings ;
IN: io.utf16
IN: io.encodings.utf16
ARTICLE: "io.utf16" "Working with UTF16-encoded data"
"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences."

28
core/io/encodings/utf16/utf16-tests.factor Executable file
View File

@ -0,0 +1,28 @@
USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings
io unicode ;
: decode-w/stream ( array encoding -- newarray )
>r >sbuf dup reverse-here r> <decoding> contents >array ;
: encode-w/stream ( array encoding -- newarray )
>r SBUF" " clone tuck r> <encoding> stream-write >array ;
[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode-w/stream ] unit-test
[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode-w/stream ] unit-test
[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode-w/stream ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode-w/stream ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode-w/stream ] unit-test
[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode-w/stream ] unit-test
[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode-w/stream ] unit-test
[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode-w/stream ] unit-test

56
core/io/utf16/utf16.factor → core/io/encodings/utf16/utf16.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting ;
IN: io.utf16
io.encodings combinators splitting io byte-arrays ;
IN: io.encodings.utf16
SYMBOL: double
SYMBOL: quad1
@ -30,7 +30,7 @@ SYMBOL: ignore
>r 2 shift r> BIN: 11 bitand bitor quad3
] [ 2drop do-ignore ] if ;
: (decode-utf16be) ( buf byte ch state -- buf ch state )
: decode-utf16be-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf16be ] }
{ double [ end-multibyte ] }
@ -41,7 +41,7 @@ SYMBOL: ignore
} case ;
: decode-utf16be ( seq -- str )
[ -rot (decode-utf16be) ] decode ;
[ decode-utf16be-step ] decode ;
: handle-double ( buf byte ch -- buf ch state )
swap dup -3 shift BIN: 11011 = [
@ -55,7 +55,7 @@ SYMBOL: ignore
BIN: 11 bitand append-nums HEX: 10000 + decoded
] [ 2drop push-replacement ] if ;
: (decode-utf16le) ( buf byte ch state -- buf ch state )
: decode-utf16le-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop double ] }
{ double [ handle-double ] }
@ -65,7 +65,7 @@ SYMBOL: ignore
} case ;
: decode-utf16le ( seq -- str )
[ -rot (decode-utf16le) ] decode ;
[ decode-utf16le-step ] decode ;
: encode-first
-10 shift
@ -104,13 +104,49 @@ SYMBOL: ignore
: encode-utf16 ( str -- seq )
encode-utf16le bom-le swap append ;
: utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
: utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
: decode-utf16 ( seq -- str )
{
{ [ utf16le? ] [ decode-utf16le ] }
{ [ utf16be? ] [ decode-utf16be ] }
{ [ start-utf16le? ] [ decode-utf16le ] }
{ [ start-utf16be? ] [ decode-utf16be ] }
{ [ t ] [ decode-error ] }
} cond ;
TUPLE: utf16le ;
INSTANCE: utf16le encoding-stream
M: utf16le encode-string drop encode-utf16le ;
M: utf16le decode-step drop decode-utf16le-step ;
TUPLE: utf16be ;
INSTANCE: utf16be encoding-stream
M: utf16be encode-string drop encode-utf16be ;
M: utf16be decode-step drop decode-utf16be-step ;
TUPLE: utf16 encoding ;
INSTANCE: utf16 encoding-stream
M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary?
M: utf16 set-underlying-stream delegate set-delegate ; ! necessary?
M: utf16 encode-string
>r encode-utf16le r>
dup utf16-encoding [ drop ]
[ t swap set-utf16-encoding bom-le swap append ] if ;
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf16le ] [
bom-be sequence= [ utf16be ] [ decode-error ] if
] if ;
: read-bom ( utf16 -- encoding )
2 over delegate stream-read bom>le/be construct-empty
[ swap set-utf16-encoding ] keep ;
M: utf16 decode-step
! inefficient: checks if bom is done many times
! This should transform itself into utf16be or utf16le after reading BOM
dup utf16-encoding [ ] [ read-bom ] ?if decode-step ;

1
core/io/encodings/utf8/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

0
core/io/utf8/summary.txt → core/io/encodings/utf8/summary.txt
View File

1
core/io/encodings/utf8/tags.txt Normal file
View File

@ -0,0 +1 @@
text

6
core/io/utf8/utf8-docs.factor → core/io/encodings/utf8/utf8-docs.factor Normal file → Executable file
View File

@ -1,12 +1,12 @@
USING: help.markup help.syntax io.encodings strings ;
IN: io.utf8
IN: io.encodings.utf8
ARTICLE: "io.utf8" "Working with UTF8-encoded data"
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
{ $subsection encode-utf8 }
{ $subsection decode-utf8 } ;
ABOUT: "io.utf8"
ABOUT: "io.encodings.utf8"
HELP: decode-utf8
{ $values { "seq" "a sequence of bytes" } { "str" string } }

23
core/io/encodings/utf8/utf8-tests.factor Normal file
View File

@ -0,0 +1,23 @@
USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings
sequences strings arrays unicode ;
: decode-utf8-w/stream ( array -- newarray )
>sbuf dup reverse-here utf8 <decoding> contents ;
: encode-utf8-w/stream ( array -- newarray )
SBUF" " clone tuck utf8 <encoding> stream-write >array ;
[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
[ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
[ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8-w/stream ] unit-test

23
core/io/utf8/utf8.factor → core/io/encodings/utf8/utf8.factor
View File

@ -1,8 +1,10 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors
namespaces io.encodings combinators ;
IN: io.utf8
USING: math kernel sequences sbufs vectors growable io continuations
namespaces io.encodings combinators strings io.streams.c ;
IN: io.encodings.utf8
! Decoding UTF-8
SYMBOL: double
SYMBOL: triple
@ -31,7 +33,7 @@ SYMBOL: quad3
: end-multibyte ( buf byte ch -- buf ch state )
f append-nums [ decoded ] unless* ;
: (decode-utf8) ( buf byte ch state -- buf ch state )
: decode-utf8-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf8 ] }
{ double [ end-multibyte ] }
@ -43,7 +45,9 @@ SYMBOL: quad3
} case ;
: decode-utf8 ( seq -- str )
[ -rot (decode-utf8) ] decode ;
[ decode-utf8-step ] decode ;
! Encoding UTF-8
: encoded ( char -- )
BIN: 111111 bitand BIN: 10000000 bitor , ;
@ -70,3 +74,12 @@ SYMBOL: quad3
: encode-utf8 ( str -- seq )
[ [ char>utf8 ] each ] B{ } make ;
! Interface for streams
TUPLE: utf8 ;
INSTANCE: utf8 encoding-stream
M: utf8 encode-string drop encode-utf8 ;
M: utf8 decode-step drop decode-utf8-step ;
! In the future, this should detect and ignore a BOM at the beginning

206
core/io/files/files-docs.factor
View File

@ -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" } "-to" } " 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-to" } " 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-to }
{ $subsection move-files-to }
"Copying files:"
{ $subsection copy-file }
{ $subsection copy-file-to }
{ $subsection copy-files-to }
"Copying directory trees recursively:"
{ $subsection copy-tree }
{ $subsection copy-tree-to }
{ $subsection copy-trees-to }
"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" } }
@ -52,12 +128,12 @@ HELP: <file-appender>
{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-in
HELP: with-file-reader
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: with-file-out
HELP: with-file-writer
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
@ -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-to
{ $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-to
{ $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-to
{ $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-to
{ $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-to
{ $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-to
{ $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." } ;

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

@ -6,63 +6,118 @@ USING: tools.test io.files io threads kernel continuations ;
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ ] [
"test-foo.txt" resource-path <file-writer> [
"test-foo.txt" temp-file [
"Hello world." print
] with-stream
] 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 <file-writer> [ [ yield "Hi" write ] in-thread ] with-stream ] 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 <file-writer> [ [ yield "Hi" write ] in-thread ] with-stream ] 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-to
] 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-to
] 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

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