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

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

db4
Alex Chapman 2008-03-04 09:58:57 +11:00
parent 7af882a5fb 47a96775d8
commit 62e330319d
288 changed files with 1643 additions and 1055 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,4 @@
IN: temporary IN: alien.tests
USING: alien alien.accessors byte-arrays arrays kernel USING: alien alien.accessors byte-arrays arrays kernel
kernel.private namespaces tools.test sequences libc math system kernel.private namespaces tools.test sequences libc math system
prettyprint ; prettyprint ;

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

@ -1,4 +1,4 @@
IN: temporary IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ; sequences system libc ;

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

@ -1,4 +1,4 @@
IN: temporary IN: alien.compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects arrays parser quotations continuations inference.backend effects

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

@ -1,4 +1,4 @@
IN: temporary IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces ; sequences system libc words vocabs namespaces ;

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

@ -1,6 +1,6 @@
USING: arrays kernel sequences sequences.private growable USING: arrays kernel sequences sequences.private growable
tools.test vectors layouts system math vectors.private ; tools.test vectors layouts system math vectors.private ;
IN: temporary IN: arrays.tests
[ -2 { "a" "b" "c" } nth ] must-fail [ -2 { "a" "b" "c" } nth ] must-fail
[ 10 { "a" "b" "c" } nth ] must-fail [ 10 { "a" "b" "c" } nth ] must-fail

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

@ -1,4 +1,4 @@
IN: temporary IN: assocs.tests
USING: kernel math namespaces tools.test vectors sequences USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs sequences.private hashtables io prettyprint assocs
continuations ; continuations ;

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

@ -1,6 +1,6 @@
USING: sequences arrays bit-arrays kernel tools.test math USING: sequences arrays bit-arrays kernel tools.test math
random ; random ;
IN: temporary IN: bit-arrays.tests
[ 100 ] [ 100 <bit-array> length ] unit-test [ 100 ] [ 100 <bit-array> length ] unit-test

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

@ -1,4 +1,4 @@
IN: temporary IN: bit-vectors.tests
USING: tools.test bit-vectors vectors sequences kernel math ; USING: tools.test bit-vectors vectors sequences kernel math ;
[ 0 ] [ 123 <bit-vector> length ] unit-test [ 0 ] [ 123 <bit-vector> length ] unit-test

2
core/bootstrap/image/image-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test ; USING: bootstrap.image bootstrap.image.private tools.test ;
\ ' must-infer \ ' must-infer

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

@ -1,4 +1,4 @@
IN: temporary IN: boxes.tests
USING: boxes namespaces tools.test ; USING: boxes namespaces tools.test ;
[ ] [ <box> "b" set ] unit-test [ ] [ <box> "b" set ] unit-test

3
core/boxes/boxes.factor
View File

@ -19,3 +19,6 @@ TUPLE: box value full? ;
: ?box ( box -- value/f ? ) : ?box ( box -- value/f ? )
dup box-full? [ box> t ] [ drop f f ] if ; dup box-full? [ box> t ] [ drop f f ] if ;
: if-box? ( box quot -- )
>r ?box r> [ drop ] if ; inline

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

@ -1,4 +1,4 @@
IN: temporary IN: byte-arrays.tests
USING: tools.test byte-arrays ; USING: tools.test byte-arrays ;
[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test [ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test

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

@ -1,4 +1,4 @@
IN: temporary IN: byte-vectors.tests
USING: tools.test byte-vectors vectors sequences kernel ; USING: tools.test byte-vectors vectors sequences kernel ;
[ 0 ] [ 123 <byte-vector> length ] unit-test [ 0 ] [ 123 <byte-vector> length ] unit-test

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

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes io.streams.string tools.test vectors words quotations classes io.streams.string
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units ; vectors definitions source-files compiler.units ;
IN: temporary IN: classes.tests
H{ } "s" set H{ } "s" set
@ -62,7 +62,7 @@ UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test [ bah ] [ \ bah? "predicating" word-prop ] unit-test
! Test generic see and parsing ! Test generic see and parsing
[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ] [ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test [ [ \ bah see ] with-string-writer ] unit-test
! Test redefinition of classes ! Test redefinition of classes
@ -78,7 +78,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ union-1 ] [ fixnum float class-or ] unit-test [ union-1 ] [ fixnum float class-or ] unit-test
"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval "IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test [ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test [ f ] [ union-1 number class< ] unit-test
@ -86,7 +86,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ object ] [ fixnum float class-or ] unit-test [ object ] [ fixnum float class-or ] unit-test
"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval "IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
[ f ] [ union-1 union-class? ] unit-test [ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test
@ -126,7 +126,7 @@ INSTANCE: integer mx1
[ t ] [ mx1 integer class< ] unit-test [ t ] [ mx1 integer class< ] unit-test
[ t ] [ mx1 number class< ] unit-test [ t ] [ mx1 number class< ] unit-test
"IN: temporary USE: arrays INSTANCE: array mx1" eval "IN: classes.tests USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class< ] unit-test [ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test [ f ] [ mx1 number class< ] unit-test
@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ quotation redefine-bug-2 class< ] unit-test [ t ] [ quotation redefine-bug-2 class< ] unit-test
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test [ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test [ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test [ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test [ f ] [ fixnum redefine-bug-2 class< ] unit-test
@ -185,7 +185,7 @@ DEFER: mixin-forget-test-g
[ ] [ [ ] [
{ {
"USING: sequences ;" "USING: sequences ;"
"IN: temporary" "IN: classes.tests"
"MIXIN: mixin-forget-test" "MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test" "INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )" "GENERIC: mixin-forget-test-g ( x -- y )"
@ -200,7 +200,7 @@ DEFER: mixin-forget-test-g
[ ] [ [ ] [
{ {
"USING: hashtables ;" "USING: hashtables ;"
"IN: temporary" "IN: classes.tests"
"MIXIN: mixin-forget-test" "MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test" "INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )" "GENERIC: mixin-forget-test-g ( x -- y )"

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

@ -1,4 +1,4 @@
IN: temporary IN: combinators.tests
USING: alien strings kernel math tools.test io prettyprint USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words ; namespaces combinators words ;

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

@ -1,5 +1,5 @@
USING: namespaces tools.test kernel command-line ; USING: namespaces tools.test kernel command-line ;
IN: temporary IN: command-line.tests
[ [
[ f ] [ "-no-user-init" cli-arg ] unit-test [ f ] [ "-no-user-init" cli-arg ] unit-test

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

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

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

@ -1,4 +1,4 @@
IN: temporary IN: compiler.tests
USING: compiler.units kernel kernel.private memory math USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;

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

@ -1,4 +1,4 @@
IN: temporary IN: compiler.tests
USING: arrays compiler.units kernel kernel.private math USING: arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays continuations sequences.private hashtables.private byte-arrays

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

@ -1,7 +1,7 @@
USING: compiler.units tools.test kernel kernel.private USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings sequences.private math.private math combinators strings
alien arrays memory ; alien arrays memory ;
IN: temporary IN: compiler.tests
! Test empty word ! Test empty word
[ ] [ [ ] compile-call ] unit-test [ ] [ [ ] compile-call ] unit-test

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

@ -1,4 +1,4 @@
IN: temporary IN: compiler.tests
USING: compiler tools.test namespaces sequences USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private kernel.private kernel math continuations continuations.private
words splitting sorting ; words splitting sorting ;

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

@ -1,5 +1,5 @@
! Testing templates machinery without compiling anything ! Testing templates machinery without compiling anything
IN: temporary IN: compiler.tests
USING: compiler generator generator.registers USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units ; words kernel math effects definitions compiler.units ;

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

@ -4,7 +4,7 @@ hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators ; words definitions compiler.units io combinators ;
IN: temporary IN: compiler.tests
! Oops! ! Oops!
[ 5000 ] [ [ 5000 ] compile-call ] unit-test [ 5000 ] [ [ 5000 ] compile-call ] unit-test

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

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

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

@ -1,7 +1,7 @@
USING: kernel math namespaces io tools.test sequences vectors USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words continuations debugger parser memory arrays words
kernel.private ; kernel.private ;
IN: temporary IN: continuations.tests
: (callcc1-test) : (callcc1-test)
swap 1- tuck swap ?push swap 1- tuck swap ?push

2
core/cpu/arm/assembler/assembler-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary IN: cpu.arm.assembler.tests
USING: assembler-arm math test namespaces sequences kernel USING: assembler-arm math test namespaces sequences kernel
quotations ; quotations ;

2
core/cpu/x86/assembler/assembler-tests.factor
View File

@ -1,5 +1,5 @@
USING: cpu.x86.assembler kernel tools.test namespaces ; USING: cpu.x86.assembler kernel tools.test namespaces ;
IN: temporary IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test [ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test

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

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

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

@ -1,4 +1,4 @@
IN: temporary IN: definitions.tests
USING: tools.test generic kernel definitions sequences USING: tools.test generic kernel definitions sequences
compiler.units ; compiler.units ;

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

@ -1,7 +1,7 @@
USING: dlists dlists.private kernel tools.test random assocs USING: dlists dlists.private kernel tools.test random assocs
hashtables sequences namespaces sorting debugger io prettyprint hashtables sequences namespaces sorting debugger io prettyprint
math ; math ;
IN: temporary IN: dlists.tests
[ t ] [ <dlist> dlist-empty? ] unit-test [ t ] [ <dlist> dlist-empty? ] unit-test

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

@ -1,4 +1,4 @@
IN: temporary IN: effects.tests
USING: effects tools.test ; USING: effects tools.test ;
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test [ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test

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

@ -1,4 +1,4 @@
IN: temporary IN: float-arrays.tests
USING: float-arrays tools.test ; USING: float-arrays tools.test ;
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test [ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test

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

@ -1,4 +1,4 @@
IN: temporary IN: float-vectors.tests
USING: tools.test float-vectors vectors sequences kernel ; USING: tools.test float-vectors vectors sequences kernel ;
[ 0 ] [ 123 <float-vector> length ] unit-test [ 0 ] [ 123 <float-vector> length ] unit-test

12
core/generic/generic-tests.factor
View File

@ -3,7 +3,7 @@ generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words prettyprint sequences strings tools.test vectors words
quotations classes continuations layouts classes.union sorting quotations classes continuations layouts classes.union sorting
compiler.units ; compiler.units ;
IN: temporary IN: generic.tests
GENERIC: foobar ( x -- y ) GENERIC: foobar ( x -- y )
M: object foobar drop "Hello world" ; M: object foobar drop "Hello world" ;
@ -87,11 +87,11 @@ M: number union-containment drop 2 ;
[ 2 ] [ 1.0 union-containment ] unit-test [ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions ! Testing recovery from bad method definitions
"IN: temporary GENERIC: unhappy ( x -- x )" eval "IN: generic.tests GENERIC: unhappy ( x -- x )" eval
[ [
"IN: temporary M: dictionary unhappy ;" eval "IN: generic.tests M: dictionary unhappy ;" eval
] must-fail ] must-fail
[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test [ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
GENERIC# complex-combination 1 ( a b -- c ) GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ; M: string complex-combination drop ;
@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic
TUPLE: redefinition-test-tuple ; TUPLE: redefinition-test-tuple ;
"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval "IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
[ t ] [ [ t ] [
[ [
redefinition-test-generic , redefinition-test-generic ,
"IN: temporary TUPLE: redefinition-test-tuple ;" eval "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
redefinition-test-generic , redefinition-test-generic ,
] { } make all-equal? ] { } make all-equal?
] unit-test ] unit-test

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

@ -1,6 +1,6 @@
USING: math sequences classes growable tools.test kernel USING: math sequences classes growable tools.test kernel
layouts ; layouts ;
IN: temporary IN: growable.tests
! erg found this one ! erg found this one
[ fixnum ] [ [ fixnum ] [

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

@ -1,4 +1,4 @@
IN: temporary IN: hashtables.tests
USING: kernel math namespaces tools.test vectors sequences USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs sequences.private hashtables io prettyprint assocs
continuations ; continuations ;

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

@ -3,7 +3,7 @@
USING: arrays kernel math namespaces tools.test USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting ; heaps heaps.private math.parser random assocs sequences sorting ;
IN: temporary IN: heaps.tests
[ <min-heap> heap-pop ] must-fail [ <min-heap> heap-pop ] must-fail
[ <max-heap> heap-pop ] must-fail [ <max-heap> heap-pop ] must-fail

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

@ -1,4 +1,4 @@
IN: temporary IN: inference.class.tests
USING: arrays math.private kernel math compiler inference USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien sequences words inference.class quotations alien

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

@ -6,7 +6,7 @@ continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string io.timeouts debugger threads.private io.streams.string io.timeouts
io.thread sequences.private ; io.thread sequences.private ;
IN: temporary IN: inference.tests
{ 0 2 } [ 2 "Hello" ] must-infer-as { 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as { 1 2 } [ dup ] must-infer-as

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

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

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

@ -1,4 +1,4 @@
IN: temporary IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel USING: sequences inference.transforms tools.test math kernel
quotations inference ; quotations inference ;

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

@ -1,4 +1,4 @@
IN: temporary IN: init.tests
USING: init namespaces sequences math tools.test kernel ; USING: init namespaces sequences math tools.test kernel ;
[ t ] [ [ t ] [

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

@ -1,6 +1,6 @@
USING: kernel tools.test math namespaces prettyprint USING: kernel tools.test math namespaces prettyprint
sequences inspector io.streams.string ; sequences inspector io.streams.string ;
IN: temporary IN: inspector.tests
[ 1 2 3 ] describe [ 1 2 3 ] describe
f describe f describe

2
core/io/backend/backend-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary IN: io.backend.tests
USING: tools.test io.backend kernel ; USING: tools.test io.backend kernel ;
[ ] [ "a" normalize-pathname drop ] unit-test [ ] [ "a" normalize-pathname drop ] unit-test

2
core/io/binary/binary-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.binary tools.test ; USING: io.binary tools.test ;
IN: temporary IN: io.binary.tests
[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test [ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test [ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test

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

@ -57,8 +57,8 @@ ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
"The operations for moving and copying files come in three flavors:" "The operations for moving and copying files come in three flavors:"
{ $list { $list
{ "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." } { "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" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
{ "A word named " { $snippet { $emphasis "operation" } "s-to" } " which takes a sequence of source paths and destination directory." } { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." }
} }
"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file." "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 $nl
@ -68,16 +68,16 @@ $nl
{ $subsection delete-tree } { $subsection delete-tree }
"Moving files:" "Moving files:"
{ $subsection move-file } { $subsection move-file }
{ $subsection move-file-to } { $subsection move-file-into }
{ $subsection move-files-to } { $subsection move-files-into }
"Copying files:" "Copying files:"
{ $subsection copy-file } { $subsection copy-file }
{ $subsection copy-file-to } { $subsection copy-file-into }
{ $subsection copy-files-to } { $subsection copy-files-into }
"Copying directory trees recursively:" "Copying directory trees recursively:"
{ $subsection copy-tree } { $subsection copy-tree }
{ $subsection copy-tree-to } { $subsection copy-tree-into }
{ $subsection copy-trees-to } { $subsection copy-trees-into }
"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ; "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" ARTICLE: "io.files" "Basic file operations"
@ -87,6 +87,7 @@ ARTICLE: "io.files" "Basic file operations"
{ $subsection "fs-meta" } { $subsection "fs-meta" }
{ $subsection "directories" } { $subsection "directories" }
{ $subsection "delete-move-copy" } { $subsection "delete-move-copy" }
{ $subsection "unique" }
{ $see-also "os" } ; { $see-also "os" } ;
ABOUT: "io.files" ABOUT: "io.files"
@ -266,12 +267,12 @@ HELP: move-file
{ $description "Moves or renames a file." } { $description "Moves or renames a file." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; { $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: move-file-to HELP: move-file-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } { $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Moves a file to another directory without renaming it." } { $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." } ; { $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: move-files-to HELP: move-files-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Moves a set of files to another directory." } { $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." } ; { $errors "Throws an error if the file does not exist or if the move operation fails." } ;
@ -282,12 +283,12 @@ HELP: copy-file
{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." } { $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." } ; { $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-file-to HELP: copy-file-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } { $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a file to another directory." } { $description "Copies a file to another directory." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; { $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-files-to HELP: copy-files-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of files to another directory." } { $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." } ; { $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
@ -298,12 +299,12 @@ HELP: copy-tree
{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." } { $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." } ; { $errors "Throws an error if the copy operation fails." } ;
HELP: copy-tree-to HELP: copy-tree-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } { $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a directory tree to another directory, recursively." } { $description "Copies a directory tree to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ; { $errors "Throws an error if the copy operation fails." } ;
HELP: copy-trees-to HELP: copy-trees-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of directory trees to another directory, recursively." } { $description "Copies a set of directory trees to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ; { $errors "Throws an error if the copy operation fails." } ;

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

@ -1,4 +1,4 @@
IN: temporary IN: io.files.tests
USING: tools.test io.files io threads kernel continuations ; USING: tools.test io.files io threads kernel continuations ;
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "passwd" ] [ "/etc/passwd" file-name ] unit-test
@ -101,7 +101,7 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [ [ ] [
"copy-tree-test" temp-file "copy-tree-test" temp-file
"copy-destination" temp-file copy-tree-to "copy-destination" temp-file copy-tree-into
] unit-test ] unit-test
[ "Foobar" ] [ [ "Foobar" ] [
@ -109,7 +109,7 @@ USING: tools.test io.files io threads kernel continuations ;
] unit-test ] unit-test
[ ] [ [ ] [
"copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-to "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into
] unit-test ] unit-test
[ "Foobar" ] [ [ "Foobar" ] [
@ -121,3 +121,5 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [ "copy-destination" temp-file delete-tree ] unit-test [ ] [ "copy-destination" temp-file delete-tree ] unit-test
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test [ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test

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

@ -1,10 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: io.files
USING: io.backend io.files.private io hashtables kernel math USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations ; system combinators splitting sbufs continuations ;
IN: io.files
! Pathnames ! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
@ -50,6 +51,19 @@ TUPLE: no-parent-directory path ;
{ [ t ] [ drop ] } { [ t ] [ drop ] }
} cond ; } cond ;
TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info )
SYMBOL: +regular-file+
SYMBOL: +directory+
SYMBOL: +character-device+
SYMBOL: +block-device+
SYMBOL: +fifo+
SYMBOL: +symbolic-link+
SYMBOL: +socket+
SYMBOL: +unknown+
! File metadata ! File metadata
: stat ( path -- directory? permissions length modified ) : stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ; normalize-pathname (stat) ;
@ -70,7 +84,7 @@ HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path ) HOOK: cwd io-backend ( -- path )
: with-directory ( path quot -- ) : with-directory ( path quot -- )
swap cd cwd [ cd ] curry [ ] cleanup ; inline cwd [ cd ] curry rot cd [ ] cleanup ; inline
! Creating directories ! Creating directories
HOOK: make-directory io-backend ( path -- ) HOOK: make-directory io-backend ( path -- )
@ -123,37 +137,37 @@ HOOK: delete-directory io-backend ( path -- )
! Moving and renaming files ! Moving and renaming files
HOOK: move-file io-backend ( from to -- ) HOOK: move-file io-backend ( from to -- )
: move-file-to ( from to -- ) : move-file-into ( from to -- )
to-directory move-file ; to-directory move-file ;
: move-files-to ( files to -- ) : move-files-into ( files to -- )
[ move-file-to ] curry each ; [ move-file-into ] curry each ;
! Copying files ! Copying files
HOOK: copy-file io-backend ( from to -- ) HOOK: copy-file io-backend ( from to -- )
: copy-file-to ( from to -- ) : copy-file-into ( from to -- )
to-directory copy-file ; to-directory copy-file ;
: copy-files-to ( files to -- ) : copy-files-into ( files to -- )
[ copy-file-to ] curry each ; [ copy-file-into ] curry each ;
DEFER: copy-tree-to DEFER: copy-tree-into
: copy-tree ( from to -- ) : copy-tree ( from to -- )
over directory? [ over directory? [
>r dup directory swap r> [ >r dup directory swap r> [
>r swap first path+ r> copy-tree-to >r swap first path+ r> copy-tree-into
] 2curry each ] 2curry each
] [ ] [
copy-file copy-file
] if ; ] if ;
: copy-tree-to ( from to -- ) : copy-tree-into ( from to -- )
to-directory copy-tree ; to-directory copy-tree ;
: copy-trees-to ( files to -- ) : copy-trees-into ( files to -- )
[ copy-tree-to ] curry each ; [ copy-tree-into ] curry each ;
! Special paths ! Special paths
: resource-path ( path -- newpath ) : resource-path ( path -- newpath )

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

@ -1,10 +1,10 @@
USING: arrays io io.files kernel math parser strings system USING: arrays io io.files kernel math parser strings system
tools.test words namespaces ; tools.test words namespaces ;
IN: temporary IN: io.tests
[ f ] [ [ f ] [
"resource:/core/io/test/no-trailing-eol.factor" run-file "resource:/core/io/test/no-trailing-eol.factor" run-file
"foo" "temporary" lookup "foo" "io.tests" lookup
] unit-test ] unit-test
: <resource-reader> ( resource -- stream ) : <resource-reader> ( resource -- stream )

2
core/io/streams/c/c-tests.factor
View File

@ -1,5 +1,5 @@
USING: tools.test io.files io io.streams.c ; USING: tools.test io.files io io.streams.c ;
IN: temporary IN: io.streams.c.tests
[ "hello world" ] [ [ "hello world" ] [
"test.txt" temp-file [ "test.txt" temp-file [

2
core/io/streams/duplex/duplex-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.streams.duplex io kernel continuations tools.test ; USING: io.streams.duplex io kernel continuations tools.test ;
IN: temporary IN: io.streams.duplex.tests
! Test duplex stream close behavior ! Test duplex stream close behavior
TUPLE: closing-stream closed? ; TUPLE: closing-stream closed? ;

2
core/io/streams/lines/lines-tests.factor
View File

@ -1,6 +1,6 @@
USING: io.streams.lines io.files io.streams.string io USING: io.streams.lines io.files io.streams.string io
tools.test kernel ; tools.test kernel ;
IN: temporary IN: io.streams.lines.tests
: <resource-reader> ( resource -- stream ) : <resource-reader> ( resource -- stream )
resource-path <file-reader> ; resource-path <file-reader> ;

2
core/io/streams/nested/nested-tests.factor
View File

@ -1,3 +1,3 @@
USING: io io.streams.string io.streams.nested kernel math USING: io io.streams.string io.streams.nested kernel math
namespaces io.styles tools.test ; namespaces io.styles tools.test ;
IN: temporary IN: io.streams.nested.tests

2
core/io/streams/string/string-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.streams.string io kernel arrays namespaces tools.test ; USING: io.streams.string io kernel arrays namespaces tools.test ;
IN: temporary IN: io.streams.string.tests
[ "line 1" CHAR: l ] [ "line 1" CHAR: l ]
[ [

2
core/io/test/no-trailing-eol.factor
View File

@ -1,4 +1,4 @@
IN: temporary IN: io.tests
USE: math USE: math
: foo 2 2 + ; : foo 2 2 + ;
FORGET: foo FORGET: foo

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

@ -1,7 +1,7 @@
USING: arrays byte-arrays kernel kernel.private math memory USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs ; continuations prettyprint io.streams.string debugger assocs ;
IN: temporary IN: kernel.tests
[ 0 ] [ f size ] unit-test [ 0 ] [ f size ] unit-test
[ t ] [ [ \ = \ = ] all-equal? ] unit-test [ t ] [ [ \ = \ = ] all-equal? ] unit-test

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

@ -1,7 +1,7 @@
USING: io io.streams.string io.streams.duplex listener USING: io io.streams.string io.streams.duplex listener
tools.test parser math namespaces continuations vocabs kernel tools.test parser math namespaces continuations vocabs kernel
compiler.units ; compiler.units ;
IN: temporary IN: listener.tests
: hello "Hi" print ; parsing : hello "Hi" print ; parsing
@ -9,7 +9,7 @@ IN: temporary
<string-reader> stream-read-quot ; <string-reader> stream-read-quot ;
[ [ ] ] [ [ [ ] ] [
"USE: temporary hello" parse-interactive "USE: listener.tests hello" parse-interactive
] unit-test ] unit-test
[ [
@ -45,6 +45,6 @@ IN: temporary
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary : hello\n\"world\" ;" parse-interactive "IN: listener.tests : hello\n\"world\" ;" parse-interactive
drop drop
] unit-test ] unit-test

2
core/math/bitfields/bitfields-tests.factor
View File

@ -1,5 +1,5 @@
USING: math math.bitfields tools.test kernel words ; USING: math math.bitfields tools.test kernel words ;
IN: temporary IN: math.bitfields.tests
[ 0 ] [ { } bitfield ] unit-test [ 0 ] [ { } bitfield ] unit-test
[ 256 ] [ 1 { 8 } bitfield ] unit-test [ 256 ] [ 1 { 8 } bitfield ] unit-test

2
core/math/floats/floats-tests.factor
View File

@ -1,5 +1,5 @@
USING: kernel math math.constants tools.test sequences ; USING: kernel math math.constants tools.test sequences ;
IN: temporary IN: math.floats.tests
[ t ] [ 0.0 float? ] unit-test [ t ] [ 0.0 float? ] unit-test
[ t ] [ 3.1415 number? ] unit-test [ t ] [ 3.1415 number? ] unit-test

2
core/math/integers/integers-tests.factor
View File

@ -1,6 +1,6 @@
USING: kernel math namespaces prettyprint USING: kernel math namespaces prettyprint
math.private continuations tools.test sequences ; math.private continuations tools.test sequences ;
IN: temporary IN: math.integers.tests
[ "-8" ] [ -8 unparse ] unit-test [ "-8" ] [ -8 unparse ] unit-test

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

@ -1,6 +1,6 @@
USING: math.intervals kernel sequences words math arrays USING: math.intervals kernel sequences words math arrays
prettyprint tools.test random vocabs ; prettyprint tools.test random vocabs ;
IN: temporary IN: math.intervals.tests
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test

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

@ -1,5 +1,5 @@
USING: kernel math namespaces tools.test ; USING: kernel math namespaces tools.test ;
IN: temporary IN: math.tests
[ ] [ 5 [ ] times ] unit-test [ ] [ 5 [ ] times ] unit-test
[ ] [ 0 [ ] times ] unit-test [ ] [ 0 [ ] times ] unit-test

2
core/math/parser/parser-tests.factor
View File

@ -1,5 +1,5 @@
USING: kernel math math.parser sequences tools.test ; USING: kernel math math.parser sequences tools.test ;
IN: temporary IN: math.parser.tests
[ f ] [ f ]
[ f string>number ] [ f string>number ]

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

@ -1,6 +1,6 @@
USING: generic kernel kernel.private math memory prettyprint USING: generic kernel kernel.private math memory prettyprint
sequences tools.test words namespaces layouts classes ; sequences tools.test words namespaces layouts classes ;
IN: temporary IN: memory.tests
TUPLE: testing x y z ; TUPLE: testing x y z ;

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

@ -1,5 +1,5 @@
USING: mirrors tools.test assocs kernel arrays ; USING: mirrors tools.test assocs kernel arrays ;
IN: temporary IN: mirrors.tests
TUPLE: foo bar baz ; TUPLE: foo bar baz ;

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

@ -1,4 +1,4 @@
IN: temporary IN: namespaces.tests
USING: kernel namespaces tools.test words ; USING: kernel namespaces tools.test words ;
H{ } clone "test-namespace" set H{ } clone "test-namespace" set

2
core/optimizer/control/control-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary IN: optimizer.control.tests
USING: tools.test optimizer.control combinators kernel USING: tools.test optimizer.control combinators kernel
sequences inference.dataflow math inference classes strings sequences inference.dataflow math inference classes strings
optimizer ; optimizer ;

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

@ -1,4 +1,4 @@
IN: temporary IN: optimizer.def-use.tests
USING: inference inference.dataflow optimizer optimizer.def-use USING: inference inference.dataflow optimizer optimizer.def-use
namespaces assocs kernel sequences math tools.test words ; namespaces assocs kernel sequences math tools.test words ;

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

@ -3,7 +3,7 @@ kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private optimizer.backend classes inference.dataflow tuples.private
continuations growable optimizer.inlining namespaces hints ; continuations growable optimizer.inlining namespaces hints ;
IN: temporary IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*

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

@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations assocs sequences strings io.files definitions continuations
sorting tuples compiler.units debugger ; sorting tuples compiler.units debugger ;
IN: temporary IN: parser.tests
[ [
[ 1 [ 2 [ 3 ] 4 ] 5 ] [ 1 [ 2 [ 3 ] 4 ] 5 ]
@ -23,8 +23,8 @@ IN: temporary
[ "hello world" ] [ "hello world" ]
[ [
"IN: temporary : hello \"hello world\" ;" "IN: parser.tests : hello \"hello world\" ;"
eval "USE: temporary hello" eval eval "USE: parser.tests hello" eval
] unit-test ] unit-test
[ ] [ ]
@ -51,7 +51,7 @@ IN: temporary
: effect-parsing-test ( a b -- c ) + ; : effect-parsing-test ( a b -- c ) + ;
[ t ] [ [ t ] [
"effect-parsing-test" "temporary" lookup "effect-parsing-test" "parser.tests" lookup
\ effect-parsing-test eq? \ effect-parsing-test eq?
] unit-test ] unit-test
@ -64,24 +64,24 @@ IN: temporary
[ \ baz "declared-effect" word-prop effect-terminated? ] [ \ baz "declared-effect" word-prop effect-terminated? ]
unit-test unit-test
[ ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
[ t ] [ [ t ] [
"effect-parsing-test" "temporary" lookup "effect-parsing-test" "parser.tests" lookup
\ effect-parsing-test eq? \ effect-parsing-test eq?
] unit-test ] unit-test
[ T{ effect f { "a" "b" } { "d" } f } ] [ T{ effect f { "a" "b" } { "d" } f } ]
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
[ ] [ "IN: temporary : effect-parsing-test ;" eval ] unit-test [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test
[ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test [ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
! Funny bug ! Funny bug
[ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test
[ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
! These should throw errors ! These should throw errors
[ "HEX: zzz" eval ] must-fail [ "HEX: zzz" eval ] must-fail
@ -102,71 +102,71 @@ IN: temporary
] unit-test ] unit-test
DEFER: foo DEFER: foo
"IN: temporary USING: math prettyprint ; : foo 2 2 + . ; parsing" eval "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval
[ ] [ "USE: temporary foo" eval ] unit-test [ ] [ "USE: parser.tests foo" eval ] unit-test
"IN: temporary USING: math prettyprint ; : foo 2 2 + . ;" eval "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval
[ t ] [ [ t ] [
"USE: temporary \\ foo" eval "USE: parser.tests \\ foo" eval
"foo" "temporary" lookup eq? "foo" "parser.tests" lookup eq?
] unit-test ] unit-test
! Test smudging ! Test smudging
[ 1 ] [ [ 1 ] [
"IN: temporary : smudge-me ;" <string-reader> "foo" "IN: parser.tests : smudge-me ;" <string-reader> "foo"
parse-stream drop parse-stream drop
"foo" source-file source-file-definitions first assoc-size "foo" source-file source-file-definitions first assoc-size
] unit-test ] unit-test
[ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
[ ] [ [ ] [
"IN: temporary : smudge-me-more ;" <string-reader> "foo" "IN: parser.tests : smudge-me-more ;" <string-reader> "foo"
parse-stream drop parse-stream drop
] unit-test ] unit-test
[ t ] [ "smudge-me-more" "temporary" lookup >boolean ] unit-test [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test
[ f ] [ "smudge-me" "temporary" lookup >boolean ] unit-test [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
[ 3 ] [ [ 3 ] [
"IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo" "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
parse-stream drop parse-stream drop
"foo" source-file source-file-definitions first assoc-size "foo" source-file source-file-definitions first assoc-size
] unit-test ] unit-test
[ 1 ] [ [ 1 ] [
"IN: temporary USING: arrays ; M: array smudge-me ;" <string-reader> "bar" "IN: parser.tests USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
parse-stream drop parse-stream drop
"bar" source-file source-file-definitions first assoc-size "bar" source-file source-file-definitions first assoc-size
] unit-test ] unit-test
[ 2 ] [ [ 2 ] [
"IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo" "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
parse-stream drop parse-stream drop
"foo" source-file source-file-definitions first assoc-size "foo" source-file source-file-definitions first assoc-size
] unit-test ] unit-test
[ t ] [ [ t ] [
array "smudge-me" "temporary" lookup order memq? array "smudge-me" "parser.tests" lookup order memq?
] unit-test ] unit-test
[ t ] [ [ t ] [
integer "smudge-me" "temporary" lookup order memq? integer "smudge-me" "parser.tests" lookup order memq?
] unit-test ] unit-test
[ f ] [ [ f ] [
string "smudge-me" "temporary" lookup order memq? string "smudge-me" "parser.tests" lookup order memq?
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary USE: math 2 2 +" <string-reader> "a" "IN: parser.tests USE: math 2 2 +" <string-reader> "a"
parse-stream drop parse-stream drop
] unit-test ] unit-test
@ -175,7 +175,7 @@ IN: temporary
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary USE: math 2 2 -" <string-reader> "a" "IN: parser.tests USE: math 2 2 -" <string-reader> "a"
parse-stream drop parse-stream drop
] unit-test ] unit-test
@ -186,7 +186,7 @@ IN: temporary
[ ] [ [ ] [
"a" source-files get delete-at "a" source-files get delete-at
2 [ 2 [
"IN: temporary DEFER: x : y x ; : x y ;" "IN: parser.tests DEFER: x : y x ; : x y ;"
<string-reader> "a" parse-stream drop <string-reader> "a" parse-stream drop
] times ] times
] unit-test ] unit-test
@ -194,19 +194,19 @@ IN: temporary
"a" source-files get delete-at "a" source-files get delete-at
[ [
"IN: temporary : x ; : y 3 throw ; this is an error" "IN: parser.tests : x ; : y 3 throw ; this is an error"
<string-reader> "a" parse-stream <string-reader> "a" parse-stream
] [ parse-error? ] must-fail-with ] [ parse-error? ] must-fail-with
[ t ] [ [ t ] [
"y" "temporary" lookup >boolean "y" "parser.tests" lookup >boolean
] unit-test ] unit-test
[ f ] [ [ f ] [
"IN: temporary : x ;" "IN: parser.tests : x ;"
<string-reader> "a" parse-stream drop <string-reader> "a" parse-stream drop
"y" "temporary" lookup "y" "parser.tests" lookup
] unit-test ] unit-test
! Test new forward definition logic ! Test new forward definition logic
@ -269,81 +269,81 @@ IN: temporary
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary : <bogus-error> ; : bogus <bogus-error> ;" "IN: parser.tests : <bogus-error> ; : bogus <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop <string-reader> "bogus-error" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus <bogus-error> ;" "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop <string-reader> "bogus-error" parse-stream drop
] unit-test ] unit-test
! Problems with class predicates -vs- ordinary words ! Problems with class predicates -vs- ordinary words
[ ] [ [ ] [
"IN: temporary TUPLE: killer ;" "IN: parser.tests TUPLE: killer ;"
<string-reader> "removing-the-predicate" parse-stream drop <string-reader> "removing-the-predicate" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary GENERIC: killer? ( a -- b )" "IN: parser.tests GENERIC: killer? ( a -- b )"
<string-reader> "removing-the-predicate" parse-stream drop <string-reader> "removing-the-predicate" parse-stream drop
] unit-test ] unit-test
[ t ] [ [ t ] [
"killer?" "temporary" lookup >boolean "killer?" "parser.tests" lookup >boolean
] unit-test ] unit-test
[ [
"IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream <string-reader> "removing-the-predicate" parse-stream
] [ [ redefine-error? ] is? ] must-fail-with ] [ [ redefine-error? ] is? ] must-fail-with
[ [
"IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream <string-reader> "redefining-a-class-1" parse-stream
] [ [ redefine-error? ] is? ] must-fail-with ] [ [ redefine-error? ] is? ] must-fail-with
[ ] [ [ ] [
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
<string-reader> "redefining-a-class-2" parse-stream drop <string-reader> "redefining-a-class-2" parse-stream drop
] unit-test ] unit-test
[ [
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop <string-reader> "redefining-a-class-3" parse-stream drop
] [ [ redefine-error? ] is? ] must-fail-with ] [ [ redefine-error? ] is? ] must-fail-with
[ ] [ [ ] [
"IN: temporary TUPLE: class-fwd-test ;" "IN: parser.tests TUPLE: class-fwd-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop <string-reader> "redefining-a-class-3" parse-stream drop
] unit-test ] unit-test
[ [
"IN: temporary \\ class-fwd-test" "IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop <string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word? ] is? ] must-fail-with ] [ [ no-word? ] is? ] must-fail-with
[ ] [ [ ] [
"IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop <string-reader> "redefining-a-class-3" parse-stream drop
] unit-test ] unit-test
[ [
"IN: temporary \\ class-fwd-test" "IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop <string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word? ] is? ] must-fail-with ] [ [ no-word? ] is? ] must-fail-with
[ [
"IN: temporary : foo ; TUPLE: foo ;" "IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop <string-reader> "redefining-a-class-4" parse-stream drop
] [ [ redefine-error? ] is? ] must-fail-with ] [ [ redefine-error? ] is? ] must-fail-with
[ ] [ [ ] [
"IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
] unit-test ] unit-test
[ [
"IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
] must-fail ] must-fail
] with-file-vocabs ] with-file-vocabs
@ -354,7 +354,7 @@ IN: temporary
DEFER: ~b DEFER: ~b
"IN: temporary : ~b ~a ;" <string-reader> "IN: parser.tests : ~b ~a ;" <string-reader>
"smudgy" parse-stream drop "smudgy" parse-stream drop
: ~c ; : ~c ;
@ -389,43 +389,43 @@ IN: temporary
] with-scope ] with-scope
[ ] [ [ ] [
"IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval "IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
] unit-test ] unit-test
[ t ] [ [ t ] [
"foo?" "temporary" lookup word eq? "foo?" "parser.tests" lookup word eq?
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo" "IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop <string-reader> "redefining-a-class-5" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary M: f foo ;" "IN: parser.tests M: f foo ;"
<string-reader> "redefining-a-class-6" parse-stream drop <string-reader> "redefining-a-class-6" parse-stream drop
] unit-test ] unit-test
[ f ] [ f "foo" "temporary" lookup execute ] unit-test [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [ [ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo" "IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop <string-reader> "redefining-a-class-5" parse-stream drop
] unit-test ] unit-test
[ f ] [ f "foo" "temporary" lookup execute ] unit-test [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [ [ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo" "IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-7" parse-stream drop <string-reader> "redefining-a-class-7" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary TUPLE: foo ;" "IN: parser.tests TUPLE: foo ;"
<string-reader> "redefining-a-class-7" parse-stream drop <string-reader> "redefining-a-class-7" parse-stream drop
] unit-test ] unit-test
[ t ] [ "foo" "temporary" lookup symbol? ] unit-test [ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
[ "resource:core/parser/test/assert-depth.factor" run-file ] [ "resource:core/parser/test/assert-depth.factor" run-file ]
[ relative-overflow-stack { 1 2 3 } sequence= ] [ relative-overflow-stack { 1 2 3 } sequence= ]

44
core/prettyprint/prettyprint-tests.factor
View File

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker ; continuations generic compiler.units tools.walker ;
IN: temporary IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test [ "4" ] [ 4 unparse ] unit-test
[ "1.0" ] [ 1.0 unparse ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test
@ -73,12 +73,12 @@ unit-test
: foo ( a -- b ) dup * ; inline : foo ( a -- b ) dup * ; inline
[ "USING: kernel math ;\nIN: temporary\n: foo ( a -- b ) dup * ; inline\n" ] [ "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" ]
[ [ \ foo see ] with-string-writer ] unit-test [ [ \ foo see ] with-string-writer ] unit-test
: bar ( x -- y ) 2 + ; : bar ( x -- y ) 2 + ;
[ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ] [ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ]
[ [ \ bar see ] with-string-writer ] unit-test [ [ \ bar see ] with-string-writer ] unit-test
: blah : blah
@ -115,28 +115,28 @@ unit-test
[ [
[ parse-fresh drop ] with-compilation-unit [ parse-fresh drop ] with-compilation-unit
[ [
"temporary" lookup see "prettyprint.tests" lookup see
] with-string-writer "\n" split 1 head* ] with-string-writer "\n" split 1 head*
] keep = ] keep =
] with-scope ; ] with-scope ;
: method-test : method-test
{ {
"IN: temporary" "IN: prettyprint.tests"
"GENERIC: method-layout" "GENERIC: method-layout"
"" ""
"USING: math temporary ;" "USING: math prettyprint.tests ;"
"M: complex method-layout" "M: complex method-layout"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;" " ;"
"" ""
"USING: math temporary ;" "USING: math prettyprint.tests ;"
"M: fixnum method-layout ;" "M: fixnum method-layout ;"
"" ""
"USING: math temporary ;" "USING: math prettyprint.tests ;"
"M: integer method-layout ;" "M: integer method-layout ;"
"" ""
"USING: kernel temporary ;" "USING: kernel prettyprint.tests ;"
"M: object method-layout ;" "M: object method-layout ;"
} ; } ;
@ -147,7 +147,7 @@ unit-test
: retain-stack-test : retain-stack-test
{ {
"USING: io kernel sequences words ;" "USING: io kernel sequences words ;"
"IN: temporary" "IN: prettyprint.tests"
": retain-stack-layout ( x -- )" ": retain-stack-layout ( x -- )"
" dup stream-readln stream-readln" " dup stream-readln stream-readln"
" >r [ define ] map r>" " >r [ define ] map r>"
@ -161,7 +161,7 @@ unit-test
: soft-break-test : soft-break-test
{ {
"USING: kernel math sequences strings ;" "USING: kernel math sequences strings ;"
"IN: temporary" "IN: prettyprint.tests"
": soft-break-layout ( x y -- ? )" ": soft-break-layout ( x y -- ? )"
" over string? [" " over string? ["
" over hashcode over hashcode number=" " over hashcode over hashcode number="
@ -176,7 +176,7 @@ unit-test
: another-retain-layout-test : another-retain-layout-test
{ {
"USING: kernel sequences ;" "USING: kernel sequences ;"
"IN: temporary" "IN: prettyprint.tests"
": another-retain-layout ( seq1 seq2 quot -- newseq )" ": another-retain-layout ( seq1 seq2 quot -- newseq )"
" -rot 2dup dupd min-length [ each drop roll ] map" " -rot 2dup dupd min-length [ each drop roll ] map"
" >r 3drop r> ; inline" " >r 3drop r> ; inline"
@ -189,7 +189,7 @@ unit-test
: another-soft-break-test : another-soft-break-test
{ {
"USING: namespaces parser sequences ;" "USING: namespaces parser sequences ;"
"IN: temporary" "IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )" ": another-soft-break-layout ( node -- quot )"
" parse-error-file" " parse-error-file"
" [ <reversed> \"hello world foo\" add ] [ ] make ;" " [ <reversed> \"hello world foo\" add ] [ ] make ;"
@ -203,7 +203,7 @@ unit-test
: string-layout : string-layout
{ {
"USING: io kernel parser ;" "USING: io kernel parser ;"
"IN: temporary" "IN: prettyprint.tests"
": string-layout-test ( error -- )" ": string-layout-test ( error -- )"
" \"Expected \" write dup unexpected-want expected>string write" " \"Expected \" write dup unexpected-want expected>string write"
" \" but got \" write unexpected-got expected>string print ;" " \" but got \" write unexpected-got expected>string print ;"
@ -224,7 +224,7 @@ unit-test
: final-soft-break-test : final-soft-break-test
{ {
"USING: kernel sequences ;" "USING: kernel sequences ;"
"IN: temporary" "IN: prettyprint.tests"
": final-soft-break-layout ( class dim -- view )" ": final-soft-break-layout ( class dim -- view )"
" >r \"alloc\" send 0 0 r>" " >r \"alloc\" send 0 0 r>"
" first2 <NSRect>" " first2 <NSRect>"
@ -240,7 +240,7 @@ unit-test
: narrow-test : narrow-test
{ {
"USING: arrays combinators continuations kernel sequences ;" "USING: arrays combinators continuations kernel sequences ;"
"IN: temporary" "IN: prettyprint.tests"
": narrow-layout ( obj -- )" ": narrow-layout ( obj -- )"
" {" " {"
" { [ dup continuation? ] [ append ] }" " { [ dup continuation? ] [ append ] }"
@ -255,7 +255,7 @@ unit-test
: another-narrow-test : another-narrow-test
{ {
"IN: temporary" "IN: prettyprint.tests"
": another-narrow-layout ( -- obj )" ": another-narrow-layout ( -- obj )"
" H{" " H{"
" { 1 2 }" " { 1 2 }"
@ -274,13 +274,13 @@ unit-test
: class-see-test : class-see-test
{ {
"IN: temporary" "IN: prettyprint.tests"
"TUPLE: class-see-layout ;" "TUPLE: class-see-layout ;"
"" ""
"IN: temporary" "IN: prettyprint.tests"
"GENERIC: class-see-layout ( x -- y )" "GENERIC: class-see-layout ( x -- y )"
"" ""
"USING: temporary ;" "USING: prettyprint.tests ;"
"M: class-see-layout class-see-layout ;" "M: class-see-layout class-see-layout ;"
} ; } ;
@ -292,9 +292,9 @@ unit-test
! Regression ! Regression
[ t ] [ [ t ] [
"IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n" "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup eval dup eval
"generic-decl-test" "temporary" lookup "generic-decl-test" "prettyprint.tests" lookup
[ see ] with-string-writer = [ see ] with-string-writer =
] unit-test ] unit-test

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

@ -1,5 +1,5 @@
USING: math kernel quotations tools.test sequences ; USING: math kernel quotations tools.test sequences ;
IN: temporary IN: quotations.tests
[ [ 3 ] ] [ 3 [ ] curry ] unit-test [ [ 3 ] ] [ 3 [ ] curry ] unit-test
[ [ \ + ] ] [ \ + [ ] curry ] unit-test [ [ \ + ] ] [ \ + [ ] curry ] unit-test

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

@ -1,6 +1,6 @@
USING: kernel math namespaces sequences sbufs strings USING: kernel math namespaces sequences sbufs strings
tools.test classes ; tools.test classes ;
IN: temporary IN: sbufs.tests
[ 5 ] [ "Hello" >sbuf length ] unit-test [ 5 ] [ "Hello" >sbuf length ] unit-test

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

@ -1,7 +1,7 @@
USING: arrays kernel math namespaces sequences kernel.private USING: arrays kernel math namespaces sequences kernel.private
sequences.private strings sbufs tools.test vectors bit-arrays sequences.private strings sbufs tools.test vectors bit-arrays
generic ; generic ;
IN: temporary IN: sequences.tests
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test [ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
[ 3 ] [ 1 4 dup <slice> length ] unit-test [ 3 ] [ 1 4 dup <slice> length ] unit-test

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

@ -1,6 +1,6 @@
USING: sorting sequences kernel math random tools.test USING: sorting sequences kernel math random tools.test
vectors ; vectors ;
IN: temporary IN: sorting.tests
[ [ ] ] [ [ ] natural-sort ] unit-test [ [ ] ] [ [ ] natural-sort ] unit-test

5
core/source-files/source-files.factor
View File

@ -68,7 +68,10 @@ uses definitions ;
: reset-checksums ( -- ) : reset-checksums ( -- )
source-files get [ source-files get [
swap ?resource-path dup exists? swap ?resource-path dup exists?
[ file-lines swap record-checksum ] [ 2drop ] if [
over record-modified
file-lines swap record-checksum
] [ 2drop ] if
] assoc-each ; ] assoc-each ;
M: pathname where pathname-string 1 2array ; M: pathname where pathname-string 1 2array ;

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

@ -1,5 +1,5 @@
USING: splitting tools.test ; USING: splitting tools.test ;
IN: temporary IN: splitting.tests
[ { 1 2 3 } 0 group ] must-fail [ { 1 2 3 } 0 group ] must-fail

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

@ -1,6 +1,6 @@
USING: continuations kernel math namespaces strings sbufs USING: continuations kernel math namespaces strings sbufs
tools.test sequences vectors arrays ; tools.test sequences vectors arrays ;
IN: temporary IN: strings.tests
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test

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

@ -1,5 +1,5 @@
USING: math tools.test system prettyprint ; USING: math tools.test system prettyprint ;
IN: temporary IN: system.tests
[ t ] [ cell integer? ] unit-test [ t ] [ cell integer? ] unit-test
[ t ] [ bootstrap-cell integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test

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

@ -1,5 +1,5 @@
USING: namespaces io tools.test threads kernel ; USING: namespaces io tools.test threads kernel ;
IN: temporary IN: threads.tests
3 "x" set 3 "x" set
namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop

22
core/tuples/tuples-tests.factor
View File

@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations namespaces quotations sequences.private classes continuations
generic.standard effects tuples tuples.private arrays vectors generic.standard effects tuples tuples.private arrays vectors
strings compiler.units ; strings compiler.units ;
IN: temporary IN: tuples.tests
[ t ] [ \ tuple-class \ class class< ] unit-test [ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test [ f ] [ \ class \ tuple-class class< ] unit-test
@ -45,19 +45,19 @@ C: <point> point
100 200 <point> "p" set 100 200 <point> "p" set
! Use eval to sequence parsing explicitly ! Use eval to sequence parsing explicitly
"IN: temporary TUPLE: point x y z ;" eval "IN: tuples.tests TUPLE: point x y z ;" eval
[ 100 ] [ "p" get point-x ] unit-test [ 100 ] [ "p" get point-x ] unit-test
[ 200 ] [ "p" get point-y ] unit-test [ 200 ] [ "p" get point-y ] unit-test
[ f ] [ "p" get "point-z" "temporary" lookup execute ] unit-test [ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
300 "p" get "set-point-z" "temporary" lookup execute 300 "p" get "set-point-z" "tuples.tests" lookup execute
"IN: temporary TUPLE: point z y ;" eval "IN: tuples.tests TUPLE: point z y ;" eval
[ "p" get point-x ] must-fail [ "p" get point-x ] must-fail
[ 200 ] [ "p" get point-y ] unit-test [ 200 ] [ "p" get point-y ] unit-test
[ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test [ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
TUPLE: predicate-test ; TUPLE: predicate-test ;
@ -113,7 +113,7 @@ GENERIC: <yo-momma>
TUPLE: yo-momma ; TUPLE: yo-momma ;
"IN: temporary C: <yo-momma> yo-momma" eval "IN: tuples.tests C: <yo-momma> yo-momma" eval
[ f ] [ \ <yo-momma> generic? ] unit-test [ f ] [ \ <yo-momma> generic? ] unit-test
@ -202,12 +202,12 @@ M: vector silly "z" ;
SYMBOL: not-a-tuple-class SYMBOL: not-a-tuple-class
[ [
"IN: temporary C: <not-a-tuple-class> not-a-tuple-class" "IN: tuples.tests C: <not-a-tuple-class> not-a-tuple-class"
eval eval
] must-fail ] must-fail
[ t ] [ [ t ] [
"not-a-tuple-class" "temporary" lookup symbol? "not-a-tuple-class" "tuples.tests" lookup symbol?
] unit-test ] unit-test
! Missing check ! Missing check
@ -226,7 +226,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
{ set-erg's-reshape-problem-a } { set-erg's-reshape-problem-a }
\ erg's-reshape-problem construct ; \ erg's-reshape-problem construct ;
"IN: temporary TUPLE: erg's-reshape-problem a b c d e f ;" eval "IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
@ -235,7 +235,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test
[ [
"IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ check-tuple? ] is? ] must-fail-with ] [ [ check-tuple? ] is? ] must-fail-with
! Hardcore unit tests ! Hardcore unit tests

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

@ -1,7 +1,7 @@
USING: arrays kernel kernel.private math namespaces USING: arrays kernel kernel.private math namespaces
sequences sequences.private strings tools.test vectors sequences sequences.private strings tools.test vectors
continuations random growable classes ; continuations random growable classes ;
IN: temporary IN: vectors.tests
[ ] [ 10 [ [ -1000000 <vector> ] ignore-errors ] times ] unit-test [ ] [ 10 [ [ -1000000 <vector> ] ignore-errors ] times ] unit-test

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

@ -1,5 +1,5 @@
! Unit tests for vocabs.loader vocabulary ! Unit tests for vocabs.loader vocabulary
IN: temporary IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string kernel arrays sequences namespaces io.streams.string
parser source-files words assocs tuples definitions parser source-files words assocs tuples definitions
@ -31,7 +31,7 @@ IN: vocabs.loader.test.2
MAIN: hello MAIN: hello
IN: temporary IN: vocabs.loader.tests
[ { 3 3 3 } ] [ [ { 3 3 3 } ] [
"vocabs.loader.test.2" run "vocabs.loader.test.2" run

9
core/vocabs/loader/loader.factor
View File

@ -4,7 +4,7 @@ USING: namespaces sequences io.files kernel assocs words vocabs
definitions parser continuations inspector debugger io io.styles definitions parser continuations inspector debugger io io.styles
io.streams.lines hashtables sorting prettyprint source-files io.streams.lines hashtables sorting prettyprint source-files
arrays combinators strings system math.parser compiler.errors arrays combinators strings system math.parser compiler.errors
splitting ; splitting init ;
IN: vocabs.loader IN: vocabs.loader
SYMBOL: vocab-roots SYMBOL: vocab-roots
@ -175,7 +175,12 @@ SYMBOL: failures
: refresh ( prefix -- ) to-refresh do-refresh ; : refresh ( prefix -- ) to-refresh do-refresh ;
: refresh-all ( -- ) "" refresh ; SYMBOL: sources-changed?
[ t sources-changed? set-global ] "vocabs.loader" add-init-hook
: refresh-all ( -- )
"" refresh f sources-changed? set-global ;
GENERIC: (load-vocab) ( name -- vocab ) GENERIC: (load-vocab) ( name -- vocab )

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

@ -1,5 +1,5 @@
! Unit tests for vocabs vocabulary ! Unit tests for vocabs vocabulary
USING: vocabs tools.test ; USING: vocabs tools.test ;
IN: temporary IN: vocabs.tests
[ f ] [ "kernel" vocab-main ] unit-test [ f ] [ "kernel" vocab-main ] unit-test

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

@ -1,13 +1,13 @@
USING: arrays generic assocs kernel math namespaces USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations sequences tools.test words definitions parser quotations
vocabs continuations tuples compiler.units io.streams.string ; vocabs continuations tuples compiler.units io.streams.string ;
IN: temporary IN: words.tests
[ 4 ] [ [ 4 ] [
[ [
"poo" "temporary" create [ 2 2 + ] define "poo" "words.tests" create [ 2 2 + ] define
] with-compilation-unit ] with-compilation-unit
"poo" "temporary" lookup execute "poo" "words.tests" lookup execute
] unit-test ] unit-test
[ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test [ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test
@ -50,7 +50,7 @@ SYMBOL: a-symbol
! See if redefining a generic as a colon def clears some ! See if redefining a generic as a colon def clears some
! word props. ! word props.
GENERIC: testing GENERIC: testing
"IN: temporary : testing ;" eval "IN: words.tests : testing ;" eval
[ f ] [ \ testing generic? ] unit-test [ f ] [ \ testing generic? ] unit-test
@ -112,13 +112,13 @@ M: array freakish ;
DEFER: x DEFER: x
[ x ] [ undefined? ] must-fail-with [ x ] [ undefined? ] must-fail-with
[ ] [ "no-loc" "temporary" create drop ] unit-test [ ] [ "no-loc" "words.tests" create drop ] unit-test
[ f ] [ "no-loc" "temporary" lookup where ] unit-test [ f ] [ "no-loc" "words.tests" lookup where ] unit-test
[ ] [ "IN: temporary : no-loc-2 ;" eval ] unit-test [ ] [ "IN: words.tests : no-loc-2 ;" eval ] unit-test
[ f ] [ "no-loc-2" "temporary" lookup where ] unit-test [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test
[ ] [ "IN: temporary : test-last ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test
[ "test-last" ] [ word word-name ] unit-test [ "test-last" ] [ word word-name ] unit-test
! regression ! regression
@ -141,40 +141,40 @@ SYMBOL: quot-uses-b
[ { + } ] [ \ quot-uses-b uses ] unit-test [ { + } ] [ \ quot-uses-b uses ] unit-test
[ "IN: temporary : undef-test ; << undef-test >>" eval ] [ "IN: words.tests : undef-test ; << undef-test >>" eval ]
[ [ undefined? ] is? ] must-fail-with [ [ undefined? ] is? ] must-fail-with
[ ] [ [ ] [
"IN: temporary GENERIC: symbol-generic" eval "IN: words.tests GENERIC: symbol-generic" eval
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary SYMBOL: symbol-generic" eval "IN: words.tests SYMBOL: symbol-generic" eval
] unit-test ] unit-test
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test [ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
[ ] [ [ ] [
"IN: temporary GENERIC: symbol-generic" <string-reader> "IN: words.tests GENERIC: symbol-generic" <string-reader>
"symbol-generic-test" parse-stream drop "symbol-generic-test" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary TUPLE: symbol-generic ;" <string-reader> "IN: words.tests TUPLE: symbol-generic ;" <string-reader>
"symbol-generic-test" parse-stream drop "symbol-generic-test" parse-stream drop
] unit-test ] unit-test
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test [ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
! Regressions ! Regressions
[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ; foldable" eval ] unit-test
[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test
[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ; flushable" eval ] unit-test
[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test
[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test

17
extra/alarms/alarms-tests.factor Executable file
View File

@ -0,0 +1,17 @@
IN: alarms.tests
USING: alarms kernel calendar sequences tools.test threads
concurrency.count-downs ;
[ ] [
1 <count-down>
{ f } clone 2dup
[ first cancel-alarm count-down ] 2curry 1 seconds later
swap set-first
await
] unit-test
[ ] [
[
[ resume ] curry instant later drop
] "test" suspend drop
] unit-test

8
extra/alarms/alarms.factor
View File

@ -37,8 +37,8 @@ SYMBOL: alarm-thread
register-alarm ; register-alarm ;
: call-alarm ( alarm -- ) : call-alarm ( alarm -- )
dup alarm-quot try
dup alarm-entry box> drop dup alarm-entry box> drop
dup alarm-quot try
dup alarm-interval [ reschedule-alarm ] [ drop ] if ; dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
: (trigger-alarms) ( alarms now -- ) : (trigger-alarms) ( alarms now -- )
@ -46,8 +46,7 @@ SYMBOL: alarm-thread
2drop 2drop
] [ ] [
over heap-peek drop over alarm-expired? [ over heap-peek drop over alarm-expired? [
over heap-pop drop call-alarm over heap-pop drop call-alarm (trigger-alarms)
(trigger-alarms)
] [ ] [
2drop 2drop
] if ] if
@ -87,5 +86,4 @@ PRIVATE>
from-now f add-alarm ; from-now f add-alarm ;
: cancel-alarm ( alarm -- ) : cancel-alarm ( alarm -- )
alarm-entry ?box alarm-entry [ alarms get-global heap-delete ] if-box? ;
[ alarms get-global heap-delete ] [ drop ] if ;

2
extra/ascii/ascii-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary IN: ascii.tests
USING: ascii tools.test sequences kernel math ; USING: ascii tools.test sequences kernel math ;
[ t ] [ CHAR: a letter? ] unit-test [ t ] [ CHAR: a letter? ] unit-test

14
extra/benchmark/fib6/fib6.factor Executable file
View File

@ -0,0 +1,14 @@
IN: benchmark.fib6
USING: math kernel alien ;
: fib
"int" { "int" } "cdecl" [
dup 1 <= [ drop 1 ] [
1- dup fib swap 1- fib +
] if
] alien-callback
"int" { "int" } "cdecl" alien-indirect ;
: fib-main 25 fib drop ;
MAIN: fib-main

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

@ -1,4 +1,4 @@
IN: temporary IN: benchmark.reverse-complement.tests
USING: tools.test benchmark.reverse-complement crypto.md5 USING: tools.test benchmark.reverse-complement crypto.md5
io.files kernel ; io.files kernel ;

46
extra/benchmark/sockets/sockets.factor
View File

@ -1,32 +1,54 @@
USING: io.sockets io.server io kernel math threads USING: io.sockets io kernel math threads
debugger tools.time prettyprint concurrency.combinators ; debugger tools.time prettyprint concurrency.count-downs
namespaces arrays continuations ;
IN: benchmark.sockets IN: benchmark.sockets
: simple-server ( -- ) SYMBOL: counter
7777 local-server "benchmark.sockets" [
: number-of-requests 1 ;
: server-addr "127.0.0.1" 7777 <inet4> ;
: server-loop ( server -- )
dup accept [
[
read1 CHAR: x = [ read1 CHAR: x = [
stop-server "server" get dispose
] [ ] [
20 [ read1 write1 flush ] times number-of-requests
[ read1 write1 flush ] times
counter get count-down
] if ] if
] with-server ; ] with-stream
] curry "Client handler" spawn drop server-loop ;
: simple-server ( -- )
[
server-addr <server> dup "server" set [
server-loop
] with-disposal
] ignore-errors ;
: simple-client ( -- ) : simple-client ( -- )
"localhost" 7777 <inet> <client> [ server-addr <client> [
CHAR: b write1 flush CHAR: b write1 flush
20 [ CHAR: a dup write1 flush read1 assert= ] times number-of-requests
[ CHAR: a dup write1 flush read1 assert= ] times
counter get count-down
] with-stream ; ] with-stream ;
: stop-server ( -- ) : stop-server ( -- )
"localhost" 7777 <inet> <client> [ server-addr <client> [
CHAR: x write1 CHAR: x write1
] with-stream ; ] with-stream ;
: clients ( n -- ) : clients ( n -- )
dup pprint " clients: " write [ dup pprint " clients: " write [
[ simple-server ] in-thread dup 2 * <count-down> counter set
[ simple-server ] "Simple server" spawn drop
yield yield yield yield
[ drop simple-client ] parallel-each [ [ simple-client ] "Simple client" spawn drop ] times
counter get await
stop-server stop-server
yield yield yield yield
] time ; ] time ;

11
extra/bootstrap/image/upload/upload.factor
View File

@ -4,7 +4,12 @@ IN: bootstrap.image.upload
USING: http.client crypto.md5 splitting assocs kernel io.files USING: http.client crypto.md5 splitting assocs kernel io.files
bootstrap.image sequences io namespaces io.launcher math ; bootstrap.image sequences io namespaces io.launcher math ;
: destination "slava@factorcode.org:www/images/latest/" ; SYMBOL: upload-images-destination
: destination ( -- dest )
upload-images-destination get
"slava@/var/www/factorcode.org/newsite/images/latest/"
or ;
: checksums "checksums.txt" temp-file ; : checksums "checksums.txt" temp-file ;
@ -23,6 +28,8 @@ bootstrap.image sequences io namespaces io.launcher math ;
] { } make try-process ; ] { } make try-process ;
: new-images ( -- ) : new-images ( -- )
make-images compute-checksums upload-images ; "" resource-path
[ make-images compute-checksums upload-images ]
with-directory ;
MAIN: new-images MAIN: new-images

72
extra/builder/builder.factor
View File

@ -39,29 +39,25 @@ IN: builder
: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ; : record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ;
: make-clean ( -- desc ) { "make" "clean" } ; : do-make-clean ( -- desc ) { "make" "clean" } try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
: make-vm ( -- desc ) : make-vm ( -- desc )
<process*> <process*>
{ "make" target } to-strings >>arguments { "make" } >>arguments
"../compile-log" >>stdout "../compile-log" >>stdout
+stdout+ >>stderr +stdout+ >>stderr
>desc ; >desc ;
: do-make-vm ( -- )
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: copy-image ( -- ) : copy-image ( -- )
"../../factor/" my-boot-image-name append builds "factor" path+ my-boot-image-name path+ ".." copy-file-into
"../" my-boot-image-name append builds "factor" path+ my-boot-image-name path+ "." copy-file-into ;
copy-file
"../../factor/" my-boot-image-name append
my-boot-image-name
copy-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -77,6 +73,9 @@ IN: builder
20 minutes >>timeout 20 minutes >>timeout
>desc ; >desc ;
: do-bootstrap ( -- )
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
: builder-test-cmd ( -- cmd ) : builder-test-cmd ( -- cmd )
{ "./factor" "-run=builder.test" } to-strings ; { "./factor" "-run=builder.test" } to-strings ;
@ -89,6 +88,9 @@ IN: builder
45 minutes >>timeout 45 minutes >>timeout
>desc ; >desc ;
: do-builder-test ( -- )
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status SYMBOL: build-status
@ -101,52 +103,48 @@ SYMBOL: build-status
enter-build-dir enter-build-dir
"report" [ "report"
[
"Build machine: " write host-name print "Build machine: " write host-name print
"CPU: " write cpu print "CPU: " write cpu print
"OS: " write os print "OS: " write os print
"Build directory: " write cwd print nl "Build directory: " write cwd print
git-clone [ "git clone failed" print ] run-or-bail git-clone [ "git clone failed" print ] run-or-bail
"factor" cd "factor"
[
record-git-id record-git-id
do-make-clean
make-clean run-process drop do-make-vm
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
copy-image copy-image
do-bootstrap
do-builder-test
]
with-directory
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail "test-log" delete-file
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail "git id: " write "git-id" eval-file print nl
"../test-log" delete-file "Boot time: " write "boot-time" eval-file milli-seconds>time print
"Load time: " write "load-time" eval-file milli-seconds>time print
"Test time: " write "test-time" eval-file milli-seconds>time print nl
"Boot time: " write "../boot-time" eval-file milli-seconds>time print "Did not pass load-everything: " print "load-everything-vocabs" cat
"Load time: " write "../load-time" eval-file milli-seconds>time print "Did not pass test-all: " print "test-all-vocabs" cat
"Test time: " write "../test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "../load-everything-vocabs" cat "Benchmarks: " print "benchmarks" eval-file benchmarks.
"Did not pass test-all: " print "../test-all-vocabs" cat
"Benchmarks: " print
"../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks.
nl nl
show-benchmark-deltas show-benchmark-deltas
"../benchmarks" "../../benchmarks" copy-file "benchmarks" ".." copy-file-into
".." cd
maybe-release maybe-release
]
] with-file-writer with-file-writer
build-status on ; build-status on ;

93
extra/builder/release/release.factor
View File

@ -1,12 +1,17 @@
USING: kernel namespaces sequences combinators io.files io.launcher USING: kernel system namespaces sequences splitting combinators
io.files io.launcher
bake combinators.cleave builder.common builder.util ; bake combinators.cleave builder.common builder.util ;
IN: builder.release IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path ) builds "/releases" append dup make-directory ; : releases ( -- path )
builds "releases" path+
dup exists? not
[ dup make-directory ]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -34,8 +39,6 @@ IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: system sequences splitting ;
: cpu- ( -- cpu ) cpu "." split "-" join ; : cpu- ( -- cpu ) cpu "." split "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -57,70 +60,46 @@ USING: system sequences splitting ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: move-file ( source destination -- ) : windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
swap { "mv" , , } bake run-process drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: linux-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
{ "tar" "-cvzf" archive-name "factor" } to-strings run-process drop
archive-name releases move-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: windows-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
{ "zip" "-r" archive-name "factor" } to-strings run-process drop
archive-name releases move-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: macosx-release ( -- )
"factor" cd
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
: macosx-archive-cmd ( -- cmd )
{ "hdiutil" "create" { "hdiutil" "create"
"-srcfolder" "factor" "-srcfolder" "factor"
"-fs" "HFS+" "-fs" "HFS+"
"-volname" "factor" "-volname" "factor"
archive-name } archive-name } ;
to-strings run-process drop
archive-name releases move-file ; : unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: release ( -- ) : archive-cmd ( -- cmd )
os
{ {
{ "linux" [ linux-release ] } { [ windows? ] [ windows-archive-cmd ] }
{ "winnt" [ windows-release ] } { [ macosx? ] [ macosx-archive-cmd ] }
{ "macosx" [ macosx-release ] } { [ unix? ] [ unix-archive-cmd ] }
} }
case ; cond ;
: make-archive ( -- ) archive-cmd to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remove-common-files ( -- )
{ "rm" "-rf" common-files } to-strings try-process ;
: remove-factor-app ( -- )
macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
: release ( -- )
"factor"
[
remove-factor-app
remove-common-files
]
with-directory
make-archive
archive-name releases move-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/builder/util/util.factor
View File

@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets io io.files io.launcher io.sockets
math math.parser math math.parser
combinators sequences splitting quotations arrays strings tools.time combinators sequences splitting quotations arrays strings tools.time
parser-combinators new-slots accessors assocs.lib sequences.deep new-slots accessors assocs.lib
combinators.cleave bake calendar calendar.format ; combinators.cleave bake calendar calendar.format ;
IN: builder.util IN: builder.util

2
extra/calendar/format/format-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary IN: calendar.format.tests
USING: calendar.format tools.test io.streams.string ; USING: calendar.format tools.test io.streams.string ;
[ 0 ] [ [ 0 ] [

4
extra/calendar/unix/unix.factor
View File

@ -1,5 +1,7 @@
USING: alien alien.c-types arrays calendar.backend USING: alien alien.c-types arrays calendar.backend
kernel structs math unix namespaces ; kernel structs math unix.time namespaces ;
IN: calendar.unix IN: calendar.unix
TUPLE: unix-calendar ; TUPLE: unix-calendar ;

2
extra/channels/channels-tests.factor
View File

@ -3,7 +3,7 @@
! !
USING: kernel tools.test math channels channels.private USING: kernel tools.test math channels channels.private
sequences threads sorting ; sequences threads sorting ;
IN: temporary IN: channels.tests
{ V{ 10 } } [ { V{ 10 } } [
V{ } clone <channel> V{ } clone <channel>

2
extra/channels/remote/remote-tests.factor
View File

@ -3,7 +3,7 @@
! !
USING: kernel tools.test math assocs channels channels.remote USING: kernel tools.test math assocs channels channels.remote
channels.remote.private ; channels.remote.private ;
IN: temporary IN: channels.remote.tests
{ t } [ { t } [
remote-channels assoc? remote-channels assoc?

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