diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 74c94c8edf..72feca27cd 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.tests USING: alien alien.accessors byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math system prettyprint ; diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 719068e031..843b0a826b 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc ; diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 876310cc5d..7e2e23726b 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.compiler.tests USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences inference words arrays parser quotations continuations inference.backend effects diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor index b934cd56a3..a33a86d4b5 100644 --- a/core/alien/structs/structs-tests.factor +++ b/core/alien/structs/structs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.structs.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc words vocabs namespaces ; diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor index e07f192197..a7801c7d74 100755 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel sequences sequences.private growable tools.test vectors layouts system math vectors.private ; -IN: temporary +IN: arrays.tests [ -2 { "a" "b" "c" } nth ] must-fail [ 10 { "a" "b" "c" } nth ] must-fail diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 8fabee06ef..a0a60e875a 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: assocs.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 5f89b90608..5774b86e45 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -1,6 +1,6 @@ USING: sequences arrays bit-arrays kernel tools.test math random ; -IN: temporary +IN: bit-arrays.tests [ 100 ] [ 100 length ] unit-test diff --git a/core/bit-vectors/bit-vectors-tests.factor b/core/bit-vectors/bit-vectors-tests.factor index 5838c1eb8d..dff9a8db37 100755 --- a/core/bit-vectors/bit-vectors-tests.factor +++ b/core/bit-vectors/bit-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: bit-vectors.tests USING: tools.test bit-vectors vectors sequences kernel math ; [ 0 ] [ 123 length ] unit-test diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index 8c618a8f30..ae5c66a45c 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test ; \ ' must-infer diff --git a/core/boxes/boxes-tests.factor b/core/boxes/boxes-tests.factor index 66ee5247ec..76a6cfd8b1 100755 --- a/core/boxes/boxes-tests.factor +++ b/core/boxes/boxes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: boxes.tests USING: boxes namespaces tools.test ; [ ] [ "b" set ] unit-test diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index 8197e57969..a989e091bb 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -19,3 +19,6 @@ TUPLE: box value full? ; : ?box ( box -- value/f ? ) dup box-full? [ box> t ] [ drop f f ] if ; + +: if-box? ( box quot -- ) + >r ?box r> [ drop ] if ; inline diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index b5b01c201b..07b82f6111 100755 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: byte-arrays.tests USING: tools.test byte-arrays ; [ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor index 2d9ca1f205..d457d6805e 100755 --- a/core/byte-vectors/byte-vectors-tests.factor +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: byte-vectors.tests USING: tools.test byte-vectors vectors sequences kernel ; [ 0 ] [ 123 length ] unit-test diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 103c4eed09..38ca796384 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes io.streams.string classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units ; -IN: temporary +IN: classes.tests H{ } "s" set @@ -62,7 +62,7 @@ UNION: bah fixnum alien ; [ bah ] [ \ bah? "predicating" word-prop ] unit-test ! Test generic see and parsing -[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ] +[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] [ [ \ bah see ] with-string-writer ] unit-test ! Test redefinition of classes @@ -78,7 +78,7 @@ M: union-1 generic-update-test drop "union-1" ; [ union-1 ] [ fixnum float class-or ] unit-test -"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval +"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval [ t ] [ bignum union-1 class< ] unit-test [ f ] [ union-1 number class< ] unit-test @@ -86,7 +86,7 @@ M: union-1 generic-update-test drop "union-1" ; [ object ] [ fixnum float class-or ] unit-test -"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval +"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test @@ -126,7 +126,7 @@ INSTANCE: integer mx1 [ t ] [ mx1 integer class< ] unit-test [ t ] [ mx1 number class< ] unit-test -"IN: temporary USE: arrays INSTANCE: array mx1" eval +"IN: classes.tests USE: arrays INSTANCE: array mx1" eval [ t ] [ array mx1 class< ] unit-test [ f ] [ mx1 number class< ] unit-test @@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ t ] [ quotation redefine-bug-2 class< ] unit-test [ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test -[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test +[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test [ t ] [ bignum redefine-bug-1 class< ] unit-test [ f ] [ fixnum redefine-bug-2 class< ] unit-test @@ -185,7 +185,7 @@ DEFER: mixin-forget-test-g [ ] [ { "USING: sequences ;" - "IN: temporary" + "IN: classes.tests" "MIXIN: mixin-forget-test" "INSTANCE: sequence mixin-forget-test" "GENERIC: mixin-forget-test-g ( x -- y )" @@ -200,7 +200,7 @@ DEFER: mixin-forget-test-g [ ] [ { "USING: hashtables ;" - "IN: temporary" + "IN: classes.tests" "MIXIN: mixin-forget-test" "INSTANCE: hashtable mixin-forget-test" "GENERIC: mixin-forget-test-g ( x -- y )" diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index ce8e180867..8abc53e43f 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: combinators.tests USING: alien strings kernel math tools.test io prettyprint namespaces combinators words ; diff --git a/core/command-line/command-line-tests.factor b/core/command-line/command-line-tests.factor index c4221b0d06..226765bafe 100644 --- a/core/command-line/command-line-tests.factor +++ b/core/command-line/command-line-tests.factor @@ -1,5 +1,5 @@ USING: namespaces tools.test kernel command-line ; -IN: temporary +IN: command-line.tests [ [ f ] [ "-no-user-init" cli-arg ] unit-test diff --git a/core/compiler/tests/curry.factor b/core/compiler/tests/curry.factor index 982b3cfb75..d2e7115f8f 100755 --- a/core/compiler/tests/curry.factor +++ b/core/compiler/tests/curry.factor @@ -1,6 +1,6 @@ USING: tools.test quotations math kernel sequences 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 diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor index 11470f7102..0d457a8310 100755 --- a/core/compiler/tests/float.factor +++ b/core/compiler/tests/float.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: compiler.units kernel kernel.private memory math math.private tools.test math.floats.private ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index d1e6f7abf4..dd9a453cfc 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: arrays compiler.units kernel kernel.private math math.constants math.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 7f23e28bec..13b7de6987 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,7 +1,7 @@ USING: compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory ; -IN: temporary +IN: compiler.tests ! Test empty word [ ] [ [ ] compile-call ] unit-test diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 137d86b489..f54ac62204 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private words splitting sorting ; diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index 13d834a489..bdbc985078 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -1,5 +1,5 @@ ! Testing templates machinery without compiling anything -IN: temporary +IN: compiler.tests USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences words kernel math effects definitions compiler.units ; diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 4be700f221..1c19730ec0 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -4,7 +4,7 @@ hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators ; -IN: temporary +IN: compiler.tests ! Oops! [ 5000 ] [ [ 5000 ] compile-call ] unit-test diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index 7acd599cb8..5843575eeb 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: kernel tools.test compiler.units ; TUPLE: color red green blue ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index b7d580afe5..d5ede60086 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -1,7 +1,7 @@ USING: kernel math namespaces io tools.test sequences vectors continuations debugger parser memory arrays words kernel.private ; -IN: temporary +IN: continuations.tests : (callcc1-test) swap 1- tuck swap ?push diff --git a/core/cpu/arm/assembler/assembler-tests.factor b/core/cpu/arm/assembler/assembler-tests.factor index 219015fae9..a30ab9f797 100644 --- a/core/cpu/arm/assembler/assembler-tests.factor +++ b/core/cpu/arm/assembler/assembler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: cpu.arm.assembler.tests USING: assembler-arm math test namespaces sequences kernel quotations ; diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor index 256bc57578..caa00bd618 100644 --- a/core/cpu/x86/assembler/assembler-tests.factor +++ b/core/cpu/x86/assembler/assembler-tests.factor @@ -1,5 +1,5 @@ USING: cpu.x86.assembler kernel tools.test namespaces ; -IN: temporary +IN: cpu.x86.assembler.tests [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test [ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test diff --git a/core/debugger/debugger-tests.factor b/core/debugger/debugger-tests.factor index 31c3e8a762..afa4aa1c28 100755 --- a/core/debugger/debugger-tests.factor +++ b/core/debugger/debugger-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index f0b0888052..4e8fb255dd 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 203c975bb2..cd651bff2f 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -1,7 +1,7 @@ USING: dlists dlists.private kernel tools.test random assocs hashtables sequences namespaces sorting debugger io prettyprint math ; -IN: temporary +IN: dlists.tests [ t ] [ dlist-empty? ] unit-test diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 46037ba0d4..234f567f25 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: effects.tests USING: effects tools.test ; [ t ] [ 1 1 2 2 effect<= ] unit-test diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor index 0e0ab3feb6..0918eecd84 100755 --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: float-arrays.tests USING: float-arrays tools.test ; [ F{ 1.0 1.0 1.0 } ] [ 3 1.0 ] unit-test diff --git a/core/float-vectors/float-vectors-tests.factor b/core/float-vectors/float-vectors-tests.factor index 68b8195eb7..383dd4bcf2 100755 --- a/core/float-vectors/float-vectors-tests.factor +++ b/core/float-vectors/float-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: float-vectors.tests USING: tools.test float-vectors vectors sequences kernel ; [ 0 ] [ 123 length ] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e3fdbc7b46..2dc699f87b 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -3,7 +3,7 @@ generic.math assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes continuations layouts classes.union sorting compiler.units ; -IN: temporary +IN: generic.tests GENERIC: foobar ( x -- y ) M: object foobar drop "Hello world" ; @@ -87,11 +87,11 @@ M: number union-containment drop 2 ; [ 2 ] [ 1.0 union-containment ] unit-test ! Testing recovery from bad method definitions -"IN: temporary GENERIC: unhappy ( x -- x )" eval +"IN: generic.tests GENERIC: unhappy ( x -- x )" eval [ - "IN: temporary M: dictionary unhappy ;" eval + "IN: generic.tests M: dictionary unhappy ;" eval ] must-fail -[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test +[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) M: string complex-combination drop ; @@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic TUPLE: redefinition-test-tuple ; -"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval +"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval [ t ] [ [ redefinition-test-generic , - "IN: temporary TUPLE: redefinition-test-tuple ;" eval + "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval redefinition-test-generic , ] { } make all-equal? ] unit-test diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor index a220ccc45e..7ba67fe97b 100755 --- a/core/growable/growable-tests.factor +++ b/core/growable/growable-tests.factor @@ -1,6 +1,6 @@ USING: math sequences classes growable tools.test kernel layouts ; -IN: temporary +IN: growable.tests ! erg found this one [ fixnum ] [ diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 31486372f2..a62b306378 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: hashtables.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index f199ba8837..61e09d894e 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -3,7 +3,7 @@ USING: arrays kernel math namespaces tools.test heaps heaps.private math.parser random assocs sequences sorting ; -IN: temporary +IN: heaps.tests [ heap-pop ] must-fail [ heap-pop ] must-fail diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 10eae1eb99..df90ac2291 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: inference.class.tests USING: arrays math.private kernel math compiler inference inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 1fe4b7ae1e..3c12e388c4 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -6,7 +6,7 @@ continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate debugger threads.private io.streams.string io.timeouts io.thread sequences.private ; -IN: temporary +IN: inference.tests { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor index 02a3c4fde0..84d72bdd9b 100644 --- a/core/inference/state/state-tests.factor +++ b/core/inference/state/state-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: inference.state.tests USING: tools.test inference.state words ; SYMBOL: a diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 0e5c3e231e..88aac780c1 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel quotations inference ; diff --git a/core/init/init-tests.factor b/core/init/init-tests.factor index aa7cd0ea58..ce68a1d7ab 100644 --- a/core/init/init-tests.factor +++ b/core/init/init-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: init.tests USING: init namespaces sequences math tools.test kernel ; [ t ] [ diff --git a/core/inspector/inspector-tests.factor b/core/inspector/inspector-tests.factor index fce0cc0c86..72c1a9a6bf 100644 --- a/core/inspector/inspector-tests.factor +++ b/core/inspector/inspector-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test math namespaces prettyprint sequences inspector io.streams.string ; -IN: temporary +IN: inspector.tests [ 1 2 3 ] describe f describe diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor index e295cc34dc..04f34068eb 100644 --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.backend.tests USING: tools.test io.backend kernel ; [ ] [ "a" normalize-pathname drop ] unit-test diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor index 69e733b55a..f6d103b0d1 100755 --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,5 +1,5 @@ USING: io.binary tools.test ; -IN: temporary +IN: io.binary.tests [ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test [ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index c918641912..9dc178ee57 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -57,8 +57,8 @@ ARTICLE: "delete-move-copy" "Deleting, moving, copying 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." } + { "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." } + { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." } } "Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file." $nl @@ -68,16 +68,16 @@ $nl { $subsection delete-tree } "Moving files:" { $subsection move-file } -{ $subsection move-file-to } -{ $subsection move-files-to } +{ $subsection move-file-into } +{ $subsection move-files-into } "Copying files:" { $subsection copy-file } -{ $subsection copy-file-to } -{ $subsection copy-files-to } +{ $subsection copy-file-into } +{ $subsection copy-files-into } "Copying directory trees recursively:" { $subsection copy-tree } -{ $subsection copy-tree-to } -{ $subsection copy-trees-to } +{ $subsection copy-tree-into } +{ $subsection copy-trees-into } "On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ; ARTICLE: "io.files" "Basic file operations" @@ -87,6 +87,7 @@ ARTICLE: "io.files" "Basic file operations" { $subsection "fs-meta" } { $subsection "directories" } { $subsection "delete-move-copy" } +{ $subsection "unique" } { $see-also "os" } ; ABOUT: "io.files" @@ -266,12 +267,12 @@ HELP: move-file { $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 +HELP: move-file-into { $values { "from" "a pathname string" } { "to" "a directory pathname string" } } { $description "Moves a file to another directory without renaming it." } { $errors "Throws an error if the file does not exist or if the move operation fails." } ; -HELP: move-files-to +HELP: move-files-into { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $description "Moves a set of files to another directory." } { $errors "Throws an error if the file does not exist or if the move operation fails." } ; @@ -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." } { $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" } } { $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 +HELP: copy-files-into { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $description "Copies a set of files to another directory." } { $errors "Throws an error if the file does not exist or if the copy operation fails." } ; @@ -298,12 +299,12 @@ HELP: copy-tree { $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 +HELP: copy-tree-into { $values { "from" "a pathname string" } { "to" "a directory pathname string" } } { $description "Copies a directory tree to another directory, recursively." } { $errors "Throws an error if the copy operation fails." } ; -HELP: copy-trees-to +HELP: copy-trees-into { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $description "Copies a set of directory trees to another directory, recursively." } { $errors "Throws an error if the copy operation fails." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 92e148a854..6943163c5d 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.files.tests USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test @@ -101,7 +101,7 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "copy-tree-test" temp-file - "copy-destination" temp-file copy-tree-to + "copy-destination" temp-file copy-tree-into ] unit-test [ "Foobar" ] [ @@ -109,7 +109,7 @@ USING: tools.test io.files io threads kernel continuations ; ] 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 [ "Foobar" ] [ @@ -121,3 +121,5 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "copy-destination" temp-file delete-tree ] unit-test [ ] [ "copy-tree-test" temp-file delete-tree ] unit-test + +[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 85f0621443..b51d767069 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs continuations ; +IN: io.files + ! Pathnames : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; @@ -50,6 +51,19 @@ TUPLE: no-parent-directory path ; { [ t ] [ drop ] } } 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 : stat ( path -- directory? permissions length modified ) normalize-pathname (stat) ; @@ -70,7 +84,7 @@ HOOK: cd io-backend ( path -- ) HOOK: cwd io-backend ( -- path ) : with-directory ( path quot -- ) - swap cd cwd [ cd ] curry [ ] cleanup ; inline + cwd [ cd ] curry rot cd [ ] cleanup ; inline ! Creating directories HOOK: make-directory io-backend ( path -- ) @@ -123,37 +137,37 @@ HOOK: delete-directory io-backend ( path -- ) ! Moving and renaming files HOOK: move-file io-backend ( from to -- ) -: move-file-to ( from to -- ) +: move-file-into ( from to -- ) to-directory move-file ; -: move-files-to ( files to -- ) - [ move-file-to ] curry each ; +: move-files-into ( files to -- ) + [ move-file-into ] curry each ; ! Copying files HOOK: copy-file io-backend ( from to -- ) -: copy-file-to ( from to -- ) +: copy-file-into ( from to -- ) to-directory copy-file ; -: copy-files-to ( files to -- ) - [ copy-file-to ] curry each ; +: copy-files-into ( files to -- ) + [ copy-file-into ] curry each ; -DEFER: copy-tree-to +DEFER: copy-tree-into : copy-tree ( from to -- ) over directory? [ >r dup directory swap r> [ - >r swap first path+ r> copy-tree-to + >r swap first path+ r> copy-tree-into ] 2curry each ] [ copy-file ] if ; -: copy-tree-to ( from to -- ) +: copy-tree-into ( from to -- ) to-directory copy-tree ; -: copy-trees-to ( files to -- ) - [ copy-tree-to ] curry each ; +: copy-trees-into ( files to -- ) + [ copy-tree-into ] curry each ; ! Special paths : resource-path ( path -- newpath ) @@ -209,4 +223,4 @@ HOOK: io-backend ( path -- stream ) { [ winnt? ] [ "USERPROFILE" os-env ] } { [ wince? ] [ "" resource-path ] } { [ unix? ] [ "HOME" os-env ] } - } cond ; \ No newline at end of file + } cond ; diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 23686abab5..e3c249ec5d 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,10 +1,10 @@ USING: arrays io io.files kernel math parser strings system tools.test words namespaces ; -IN: temporary +IN: io.tests [ f ] [ "resource:/core/io/test/no-trailing-eol.factor" run-file - "foo" "temporary" lookup + "foo" "io.tests" lookup ] unit-test : ( resource -- stream ) diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 16b78c2192..3da9f27646 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.files io io.streams.c ; -IN: temporary +IN: io.streams.c.tests [ "hello world" ] [ "test.txt" temp-file [ diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor index 44542e05ce..65bad3de41 100755 --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -1,5 +1,5 @@ USING: io.streams.duplex io kernel continuations tools.test ; -IN: temporary +IN: io.streams.duplex.tests ! Test duplex stream close behavior TUPLE: closing-stream closed? ; diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/streams/lines/lines-tests.factor index 64dc7bff3b..e8ecc65526 100755 --- a/core/io/streams/lines/lines-tests.factor +++ b/core/io/streams/lines/lines-tests.factor @@ -1,6 +1,6 @@ USING: io.streams.lines io.files io.streams.string io tools.test kernel ; -IN: temporary +IN: io.streams.lines.tests : ( resource -- stream ) resource-path ; diff --git a/core/io/streams/nested/nested-tests.factor b/core/io/streams/nested/nested-tests.factor index 7b26beb9c6..402cb19c3b 100644 --- a/core/io/streams/nested/nested-tests.factor +++ b/core/io/streams/nested/nested-tests.factor @@ -1,3 +1,3 @@ USING: io io.streams.string io.streams.nested kernel math namespaces io.styles tools.test ; -IN: temporary +IN: io.streams.nested.tests diff --git a/core/io/streams/string/string-tests.factor b/core/io/streams/string/string-tests.factor index 4bd31fe7d8..ca117534da 100644 --- a/core/io/streams/string/string-tests.factor +++ b/core/io/streams/string/string-tests.factor @@ -1,5 +1,5 @@ USING: io.streams.string io kernel arrays namespaces tools.test ; -IN: temporary +IN: io.streams.string.tests [ "line 1" CHAR: l ] [ diff --git a/core/io/test/no-trailing-eol.factor b/core/io/test/no-trailing-eol.factor index aa4d8b82d1..959f145bf5 100644 --- a/core/io/test/no-trailing-eol.factor +++ b/core/io/test/no-trailing-eol.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.tests USE: math : foo 2 2 + ; FORGET: foo \ No newline at end of file diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 2972cb2d5d..3c40984d7a 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs ; -IN: temporary +IN: kernel.tests [ 0 ] [ f size ] unit-test [ t ] [ [ \ = \ = ] all-equal? ] unit-test diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 4570b1162a..d694c62c67 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -1,7 +1,7 @@ USING: io io.streams.string io.streams.duplex listener tools.test parser math namespaces continuations vocabs kernel compiler.units ; -IN: temporary +IN: listener.tests : hello "Hi" print ; parsing @@ -9,7 +9,7 @@ IN: temporary stream-read-quot ; [ [ ] ] [ - "USE: temporary hello" parse-interactive + "USE: listener.tests hello" parse-interactive ] unit-test [ @@ -45,6 +45,6 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary : hello\n\"world\" ;" parse-interactive + "IN: listener.tests : hello\n\"world\" ;" parse-interactive drop ] unit-test diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index a10c0566f8..6dfc51f440 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,5 +1,5 @@ USING: math math.bitfields tools.test kernel words ; -IN: temporary +IN: math.bitfields.tests [ 0 ] [ { } bitfield ] unit-test [ 256 ] [ 1 { 8 } bitfield ] unit-test diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 54a90ef233..095392ed81 100755 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.constants tools.test sequences ; -IN: temporary +IN: math.floats.tests [ t ] [ 0.0 float? ] unit-test [ t ] [ 3.1415 number? ] unit-test diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 194edb8f7e..eebc45511a 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -1,6 +1,6 @@ USING: kernel math namespaces prettyprint math.private continuations tools.test sequences ; -IN: temporary +IN: math.integers.tests [ "-8" ] [ -8 unparse ] unit-test diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 2c6ac2ecb0..8e2f47f72b 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -1,6 +1,6 @@ USING: math.intervals kernel sequences words math arrays prettyprint tools.test random vocabs ; -IN: temporary +IN: math.intervals.tests [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index c650f7384c..fcd3b929ea 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -1,5 +1,5 @@ USING: kernel math namespaces tools.test ; -IN: temporary +IN: math.tests [ ] [ 5 [ ] times ] unit-test [ ] [ 0 [ ] times ] unit-test diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 226e47090a..baa6634a9f 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.parser sequences tools.test ; -IN: temporary +IN: math.parser.tests [ f ] [ f string>number ] diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index d0dfd2c0be..8808b30c59 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,6 +1,6 @@ USING: generic kernel kernel.private math memory prettyprint sequences tools.test words namespaces layouts classes ; -IN: temporary +IN: memory.tests TUPLE: testing x y z ; diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 994bb8ef84..863c4baa42 100644 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -1,5 +1,5 @@ USING: mirrors tools.test assocs kernel arrays ; -IN: temporary +IN: mirrors.tests TUPLE: foo bar baz ; diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor index 07e9d80c9e..8dc065c04a 100644 --- a/core/namespaces/namespaces-tests.factor +++ b/core/namespaces/namespaces-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: namespaces.tests USING: kernel namespaces tools.test words ; H{ } clone "test-namespace" set diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index b5b52e0e0e..d7638fa66d 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: optimizer.control.tests USING: tools.test optimizer.control combinators kernel sequences inference.dataflow math inference classes strings optimizer ; diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index 815c564109..d5e8e2d75d 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: optimizer.def-use.tests USING: inference inference.dataflow optimizer optimizer.def-use namespaces assocs kernel sequences math tools.test words ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index c63787ad52..5116d66715 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -3,7 +3,7 @@ kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private continuations growable optimizer.inlining namespaces hints ; -IN: temporary +IN: optimizer.tests [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index d95e8258be..89783d1b3c 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words io.streams.string namespaces classes effects source-files assocs sequences strings io.files definitions continuations sorting tuples compiler.units debugger ; -IN: temporary +IN: parser.tests [ [ 1 [ 2 [ 3 ] 4 ] 5 ] @@ -23,8 +23,8 @@ IN: temporary [ "hello world" ] [ - "IN: temporary : hello \"hello world\" ;" - eval "USE: temporary hello" eval + "IN: parser.tests : hello \"hello world\" ;" + eval "USE: parser.tests hello" eval ] unit-test [ ] @@ -51,7 +51,7 @@ IN: temporary : effect-parsing-test ( a b -- c ) + ; [ t ] [ - "effect-parsing-test" "temporary" lookup + "effect-parsing-test" "parser.tests" lookup \ effect-parsing-test eq? ] unit-test @@ -64,24 +64,24 @@ IN: temporary [ \ baz "declared-effect" word-prop effect-terminated? ] 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 ] [ - "effect-parsing-test" "temporary" lookup + "effect-parsing-test" "parser.tests" lookup \ effect-parsing-test eq? ] unit-test [ T{ effect f { "a" "b" } { "d" } f } ] [ \ 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 ! 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 [ "HEX: zzz" eval ] must-fail @@ -102,71 +102,71 @@ IN: temporary ] unit-test 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 ] [ - "USE: temporary \\ foo" eval - "foo" "temporary" lookup eq? + "USE: parser.tests \\ foo" eval + "foo" "parser.tests" lookup eq? ] unit-test ! Test smudging [ 1 ] [ - "IN: temporary : smudge-me ;" "foo" + "IN: parser.tests : smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test - [ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test + [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ ] [ - "IN: temporary : smudge-me-more ;" "foo" + "IN: parser.tests : smudge-me-more ;" "foo" parse-stream drop ] unit-test - [ t ] [ "smudge-me-more" "temporary" lookup >boolean ] unit-test - [ f ] [ "smudge-me" "temporary" lookup >boolean ] unit-test + [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test + [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ 3 ] [ - "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test [ 1 ] [ - "IN: temporary USING: arrays ; M: array smudge-me ;" "bar" + "IN: parser.tests USING: arrays ; M: array smudge-me ;" "bar" parse-stream drop "bar" source-file source-file-definitions first assoc-size ] unit-test [ 2 ] [ - "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test [ t ] [ - array "smudge-me" "temporary" lookup order memq? + array "smudge-me" "parser.tests" lookup order memq? ] unit-test [ t ] [ - integer "smudge-me" "temporary" lookup order memq? + integer "smudge-me" "parser.tests" lookup order memq? ] unit-test [ f ] [ - string "smudge-me" "temporary" lookup order memq? + string "smudge-me" "parser.tests" lookup order memq? ] unit-test [ ] [ - "IN: temporary USE: math 2 2 +" "a" + "IN: parser.tests USE: math 2 2 +" "a" parse-stream drop ] unit-test @@ -175,7 +175,7 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary USE: math 2 2 -" "a" + "IN: parser.tests USE: math 2 2 -" "a" parse-stream drop ] unit-test @@ -186,7 +186,7 @@ IN: temporary [ ] [ "a" source-files get delete-at 2 [ - "IN: temporary DEFER: x : y x ; : x y ;" + "IN: parser.tests DEFER: x : y x ; : x y ;" "a" parse-stream drop ] times ] unit-test @@ -194,19 +194,19 @@ IN: temporary "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" "a" parse-stream ] [ parse-error? ] must-fail-with [ t ] [ - "y" "temporary" lookup >boolean + "y" "parser.tests" lookup >boolean ] unit-test [ f ] [ - "IN: temporary : x ;" + "IN: parser.tests : x ;" "a" parse-stream drop - "y" "temporary" lookup + "y" "parser.tests" lookup ] unit-test ! Test new forward definition logic @@ -269,81 +269,81 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary : ; : bogus ;" + "IN: parser.tests : ; : bogus ;" "bogus-error" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: bogus-error ; C: bogus-error : bogus ;" + "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ;" "bogus-error" parse-stream drop ] unit-test ! Problems with class predicates -vs- ordinary words [ ] [ - "IN: temporary TUPLE: killer ;" + "IN: parser.tests TUPLE: killer ;" "removing-the-predicate" parse-stream drop ] unit-test [ ] [ - "IN: temporary GENERIC: killer? ( a -- b )" + "IN: parser.tests GENERIC: killer? ( a -- b )" "removing-the-predicate" parse-stream drop ] unit-test [ t ] [ - "killer?" "temporary" lookup >boolean + "killer?" "parser.tests" lookup >boolean ] unit-test [ - "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "removing-the-predicate" parse-stream ] [ [ 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 ;" "redefining-a-class-1" parse-stream ] [ [ 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" "redefining-a-class-2" parse-stream drop ] 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 ;" "redefining-a-class-3" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-fwd-test ;" + "IN: parser.tests TUPLE: class-fwd-test ;" "redefining-a-class-3" parse-stream drop ] unit-test [ - "IN: temporary \\ class-fwd-test" + "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] [ [ 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" "redefining-a-class-3" parse-stream drop ] unit-test [ - "IN: temporary \\ class-fwd-test" + "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] [ [ no-word? ] is? ] must-fail-with [ - "IN: temporary : foo ; TUPLE: foo ;" + "IN: parser.tests : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop ] [ [ 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 [ - "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 ] with-file-vocabs @@ -354,7 +354,7 @@ IN: temporary DEFER: ~b - "IN: temporary : ~b ~a ;" + "IN: parser.tests : ~b ~a ;" "smudgy" parse-stream drop : ~c ; @@ -389,43 +389,43 @@ IN: temporary ] 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 [ t ] [ - "foo?" "temporary" lookup word eq? + "foo?" "parser.tests" lookup word eq? ] unit-test [ ] [ - "IN: temporary TUPLE: foo ; GENERIC: foo" + "IN: parser.tests TUPLE: foo ; GENERIC: foo" "redefining-a-class-5" parse-stream drop ] unit-test [ ] [ - "IN: temporary M: f foo ;" + "IN: parser.tests M: f foo ;" "redefining-a-class-6" parse-stream drop ] 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" "redefining-a-class-5" parse-stream drop ] 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" "redefining-a-class-7" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: foo ;" + "IN: parser.tests TUPLE: foo ;" "redefining-a-class-7" parse-stream drop ] 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 ] [ relative-overflow-stack { 1 2 3 } sequence= ] diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 32629724bd..20130d7f7e 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private continuations generic compiler.units tools.walker ; -IN: temporary +IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test @@ -73,12 +73,12 @@ unit-test : 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 : 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 : blah @@ -115,28 +115,28 @@ unit-test [ [ parse-fresh drop ] with-compilation-unit [ - "temporary" lookup see + "prettyprint.tests" lookup see ] with-string-writer "\n" split 1 head* ] keep = ] with-scope ; : method-test { - "IN: temporary" + "IN: prettyprint.tests" "GENERIC: method-layout" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: complex method-layout" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " ;" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: fixnum method-layout ;" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: integer method-layout ;" "" - "USING: kernel temporary ;" + "USING: kernel prettyprint.tests ;" "M: object method-layout ;" } ; @@ -147,7 +147,7 @@ unit-test : retain-stack-test { "USING: io kernel sequences words ;" - "IN: temporary" + "IN: prettyprint.tests" ": retain-stack-layout ( x -- )" " dup stream-readln stream-readln" " >r [ define ] map r>" @@ -161,7 +161,7 @@ unit-test : soft-break-test { "USING: kernel math sequences strings ;" - "IN: temporary" + "IN: prettyprint.tests" ": soft-break-layout ( x y -- ? )" " over string? [" " over hashcode over hashcode number=" @@ -176,7 +176,7 @@ unit-test : another-retain-layout-test { "USING: kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": another-retain-layout ( seq1 seq2 quot -- newseq )" " -rot 2dup dupd min-length [ each drop roll ] map" " >r 3drop r> ; inline" @@ -189,7 +189,7 @@ unit-test : another-soft-break-test { "USING: namespaces parser sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" " [ \"hello world foo\" add ] [ ] make ;" @@ -203,7 +203,7 @@ unit-test : string-layout { "USING: io kernel parser ;" - "IN: temporary" + "IN: prettyprint.tests" ": string-layout-test ( error -- )" " \"Expected \" write dup unexpected-want expected>string write" " \" but got \" write unexpected-got expected>string print ;" @@ -224,7 +224,7 @@ unit-test : final-soft-break-test { "USING: kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": final-soft-break-layout ( class dim -- view )" " >r \"alloc\" send 0 0 r>" " first2 " @@ -240,7 +240,7 @@ unit-test : narrow-test { "USING: arrays combinators continuations kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": narrow-layout ( obj -- )" " {" " { [ dup continuation? ] [ append ] }" @@ -255,7 +255,7 @@ unit-test : another-narrow-test { - "IN: temporary" + "IN: prettyprint.tests" ": another-narrow-layout ( -- obj )" " H{" " { 1 2 }" @@ -274,13 +274,13 @@ unit-test : class-see-test { - "IN: temporary" + "IN: prettyprint.tests" "TUPLE: class-see-layout ;" "" - "IN: temporary" + "IN: prettyprint.tests" "GENERIC: class-see-layout ( x -- y )" "" - "USING: temporary ;" + "USING: prettyprint.tests ;" "M: class-see-layout class-see-layout ;" } ; @@ -292,9 +292,9 @@ unit-test ! Regression [ t ] [ - "IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n" + "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" dup eval - "generic-decl-test" "temporary" lookup + "generic-decl-test" "prettyprint.tests" lookup [ see ] with-string-writer = ] unit-test diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index 90ba150a41..a4c9a619b5 100755 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -1,5 +1,5 @@ USING: math kernel quotations tools.test sequences ; -IN: temporary +IN: quotations.tests [ [ 3 ] ] [ 3 [ ] curry ] unit-test [ [ \ + ] ] [ \ + [ ] curry ] unit-test diff --git a/core/sbufs/sbufs-tests.factor b/core/sbufs/sbufs-tests.factor index b8d5b3e3fc..b30812b06f 100644 --- a/core/sbufs/sbufs-tests.factor +++ b/core/sbufs/sbufs-tests.factor @@ -1,6 +1,6 @@ USING: kernel math namespaces sequences sbufs strings tools.test classes ; -IN: temporary +IN: sbufs.tests [ 5 ] [ "Hello" >sbuf length ] unit-test diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 40b2fef85e..c545a9baee 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel math namespaces sequences kernel.private sequences.private strings sbufs tools.test vectors bit-arrays generic ; -IN: temporary +IN: sequences.tests [ V{ 1 2 3 4 } ] [ 1 5 dup >vector ] unit-test [ 3 ] [ 1 4 dup length ] unit-test diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index d9227b2d95..732aeb045d 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -1,6 +1,6 @@ USING: sorting sequences kernel math random tools.test vectors ; -IN: temporary +IN: sorting.tests [ [ ] ] [ [ ] natural-sort ] unit-test diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index dd5313383e..98c39ae390 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -68,7 +68,10 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ swap ?resource-path dup exists? - [ file-lines swap record-checksum ] [ 2drop ] if + [ + over record-modified + file-lines swap record-checksum + ] [ 2drop ] if ] assoc-each ; M: pathname where pathname-string 1 2array ; diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index 2b6107e08b..d60403362c 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,5 +1,5 @@ USING: splitting tools.test ; -IN: temporary +IN: splitting.tests [ { 1 2 3 } 0 group ] must-fail diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 1df4e1c477..c971287ef6 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -1,6 +1,6 @@ USING: continuations kernel math namespaces strings sbufs tools.test sequences vectors arrays ; -IN: temporary +IN: strings.tests [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index c542e68981..296f542418 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -1,5 +1,5 @@ USING: math tools.test system prettyprint ; -IN: temporary +IN: system.tests [ t ] [ cell integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 00306da062..c2e627e7bf 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -1,5 +1,5 @@ USING: namespaces io tools.test threads kernel ; -IN: temporary +IN: threads.tests 3 "x" set namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 8680a3ce61..63bb233654 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects tuples tuples.private arrays vectors strings compiler.units ; -IN: temporary +IN: tuples.tests [ t ] [ \ tuple-class \ class class< ] unit-test [ f ] [ \ class \ tuple-class class< ] unit-test @@ -45,19 +45,19 @@ C: point 100 200 "p" set ! 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 [ 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 [ 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 ; @@ -113,7 +113,7 @@ GENERIC: TUPLE: yo-momma ; -"IN: temporary C: yo-momma" eval +"IN: tuples.tests C: yo-momma" eval [ f ] [ \ generic? ] unit-test @@ -202,12 +202,12 @@ M: vector silly "z" ; SYMBOL: not-a-tuple-class [ - "IN: temporary C: not-a-tuple-class" + "IN: tuples.tests C: not-a-tuple-class" eval ] must-fail [ t ] [ - "not-a-tuple-class" "temporary" lookup symbol? + "not-a-tuple-class" "tuples.tests" lookup symbol? ] unit-test ! Missing check @@ -226,7 +226,7 @@ C: erg's-reshape-problem { set-erg's-reshape-problem-a } \ 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 @@ -235,7 +235,7 @@ C: erg's-reshape-problem [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test [ - "IN: temporary SYMBOL: not-a-class C: not-a-class" eval + "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval ] [ [ check-tuple? ] is? ] must-fail-with ! Hardcore unit tests diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index b56cee1b34..d990f5f31c 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel kernel.private math namespaces sequences sequences.private strings tools.test vectors continuations random growable classes ; -IN: temporary +IN: vectors.tests [ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 3a8fc37583..f99bf94aa4 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -1,5 +1,5 @@ ! Unit tests for vocabs.loader vocabulary -IN: temporary +IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs tuples definitions @@ -31,7 +31,7 @@ IN: vocabs.loader.test.2 MAIN: hello -IN: temporary +IN: vocabs.loader.tests [ { 3 3 3 } ] [ "vocabs.loader.test.2" run diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 8bdd9b902f..acc6c783a5 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -4,7 +4,7 @@ USING: namespaces sequences io.files kernel assocs words vocabs definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint source-files arrays combinators strings system math.parser compiler.errors -splitting ; +splitting init ; IN: vocabs.loader SYMBOL: vocab-roots @@ -175,7 +175,12 @@ SYMBOL: failures : 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 ) diff --git a/core/vocabs/vocabs-tests.factor b/core/vocabs/vocabs-tests.factor index 9b05660d9d..21c3668148 100644 --- a/core/vocabs/vocabs-tests.factor +++ b/core/vocabs/vocabs-tests.factor @@ -1,5 +1,5 @@ ! Unit tests for vocabs vocabulary USING: vocabs tools.test ; -IN: temporary +IN: vocabs.tests [ f ] [ "kernel" vocab-main ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 63e30178f5..97ce86d38a 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,13 +1,13 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations vocabs continuations tuples compiler.units io.streams.string ; -IN: temporary +IN: words.tests [ 4 ] [ [ - "poo" "temporary" create [ 2 2 + ] define + "poo" "words.tests" create [ 2 2 + ] define ] with-compilation-unit - "poo" "temporary" lookup execute + "poo" "words.tests" lookup execute ] 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 ! word props. GENERIC: testing -"IN: temporary : testing ;" eval +"IN: words.tests : testing ;" eval [ f ] [ \ testing generic? ] unit-test @@ -112,13 +112,13 @@ M: array freakish ; DEFER: x [ x ] [ undefined? ] must-fail-with -[ ] [ "no-loc" "temporary" create drop ] unit-test -[ f ] [ "no-loc" "temporary" lookup where ] unit-test +[ ] [ "no-loc" "words.tests" create drop ] unit-test +[ f ] [ "no-loc" "words.tests" lookup where ] unit-test -[ ] [ "IN: temporary : no-loc-2 ;" eval ] unit-test -[ f ] [ "no-loc-2" "temporary" lookup where ] unit-test +[ ] [ "IN: words.tests : no-loc-2 ;" eval ] 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 ! regression @@ -141,40 +141,40 @@ SYMBOL: quot-uses-b [ { + } ] [ \ 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 [ ] [ - "IN: temporary GENERIC: symbol-generic" eval + "IN: words.tests GENERIC: symbol-generic" eval ] unit-test [ ] [ - "IN: temporary SYMBOL: symbol-generic" eval + "IN: words.tests SYMBOL: symbol-generic" eval ] unit-test -[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test -[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test +[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test [ ] [ - "IN: temporary GENERIC: symbol-generic" + "IN: words.tests GENERIC: symbol-generic" "symbol-generic-test" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: symbol-generic ;" + "IN: words.tests TUPLE: symbol-generic ;" "symbol-generic-test" parse-stream drop ] unit-test -[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test -[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test +[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test ! Regressions -[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test -[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test -[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ; foldable" eval ] unit-test +[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test -[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test -[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ; flushable" eval ] unit-test +[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test diff --git a/extra/alarms/alarms-tests.factor b/extra/alarms/alarms-tests.factor new file mode 100755 index 0000000000..1af851c9c6 --- /dev/null +++ b/extra/alarms/alarms-tests.factor @@ -0,0 +1,17 @@ +IN: alarms.tests +USING: alarms kernel calendar sequences tools.test threads +concurrency.count-downs ; + +[ ] [ + 1 + { 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 diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index a50e1817e1..1ccfdcbd30 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -37,8 +37,8 @@ SYMBOL: alarm-thread register-alarm ; : call-alarm ( alarm -- ) - dup alarm-quot try dup alarm-entry box> drop + dup alarm-quot try dup alarm-interval [ reschedule-alarm ] [ drop ] if ; : (trigger-alarms) ( alarms now -- ) @@ -46,8 +46,7 @@ SYMBOL: alarm-thread 2drop ] [ over heap-peek drop over alarm-expired? [ - over heap-pop drop call-alarm - (trigger-alarms) + over heap-pop drop call-alarm (trigger-alarms) ] [ 2drop ] if @@ -87,5 +86,4 @@ PRIVATE> from-now f add-alarm ; : cancel-alarm ( alarm -- ) - alarm-entry ?box - [ alarms get-global heap-delete ] [ drop ] if ; + alarm-entry [ alarms get-global heap-delete ] if-box? ; diff --git a/extra/ascii/ascii-tests.factor b/extra/ascii/ascii-tests.factor index ec76d89d7c..b2b13b1d78 100644 --- a/extra/ascii/ascii-tests.factor +++ b/extra/ascii/ascii-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ascii.tests USING: ascii tools.test sequences kernel math ; [ t ] [ CHAR: a letter? ] unit-test diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor new file mode 100755 index 0000000000..cc42028df6 --- /dev/null +++ b/extra/benchmark/fib6/fib6.factor @@ -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 diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor index c8da5f2c9f..c8d4714802 100755 --- a/extra/benchmark/reverse-complement/reverse-complement-tests.factor +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: benchmark.reverse-complement.tests USING: tools.test benchmark.reverse-complement crypto.md5 io.files kernel ; diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 6b1908afb1..c739bb787c 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,32 +1,54 @@ -USING: io.sockets io.server io kernel math threads -debugger tools.time prettyprint concurrency.combinators ; +USING: io.sockets io kernel math threads +debugger tools.time prettyprint concurrency.count-downs +namespaces arrays continuations ; IN: benchmark.sockets +SYMBOL: counter + +: number-of-requests 1 ; + +: server-addr "127.0.0.1" 7777 ; + +: server-loop ( server -- ) + dup accept [ + [ + read1 CHAR: x = [ + "server" get dispose + ] [ + number-of-requests + [ read1 write1 flush ] times + counter get count-down + ] if + ] with-stream + ] curry "Client handler" spawn drop server-loop ; + : simple-server ( -- ) - 7777 local-server "benchmark.sockets" [ - read1 CHAR: x = [ - stop-server - ] [ - 20 [ read1 write1 flush ] times - ] if - ] with-server ; + [ + server-addr dup "server" set [ + server-loop + ] with-disposal + ] ignore-errors ; : simple-client ( -- ) - "localhost" 7777 [ + server-addr [ 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 ; : stop-server ( -- ) - "localhost" 7777 [ + server-addr [ CHAR: x write1 ] with-stream ; : clients ( n -- ) dup pprint " clients: " write [ - [ simple-server ] in-thread + dup 2 * counter set + [ simple-server ] "Simple server" spawn drop yield yield - [ drop simple-client ] parallel-each + [ [ simple-client ] "Simple client" spawn drop ] times + counter get await stop-server yield yield ] time ; diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 1fa8ee4f41..084f30a103 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -4,7 +4,12 @@ IN: bootstrap.image.upload USING: http.client crypto.md5 splitting assocs kernel io.files 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 ; @@ -23,6 +28,8 @@ bootstrap.image sequences io namespaces io.launcher math ; ] { } make try-process ; : new-images ( -- ) - make-images compute-checksums upload-images ; + "" resource-path + [ make-images compute-checksums upload-images ] + with-directory ; MAIN: new-images diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 2b51f8603e..92cd5f5241 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -39,29 +39,25 @@ IN: builder : 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" target } to-strings >>arguments - "../compile-log" >>stdout - +stdout+ >>stderr + { "make" } >>arguments + "../compile-log" >>stdout + +stdout+ >>stderr >desc ; +: do-make-vm ( -- ) + make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : copy-image ( -- ) - "../../factor/" my-boot-image-name append - "../" my-boot-image-name append - copy-file - - "../../factor/" my-boot-image-name append - my-boot-image-name - copy-file ; + builds "factor" path+ my-boot-image-name path+ ".." copy-file-into + builds "factor" path+ my-boot-image-name path+ "." copy-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -77,6 +73,9 @@ IN: builder 20 minutes >>timeout >desc ; +: do-bootstrap ( -- ) + bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; + : builder-test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } to-strings ; @@ -89,6 +88,9 @@ IN: builder 45 minutes >>timeout >desc ; +: do-builder-test ( -- ) + builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: build-status @@ -101,52 +103,48 @@ SYMBOL: build-status enter-build-dir - "report" [ + "report" + [ + "Build machine: " write host-name print + "CPU: " write cpu print + "OS: " write os print + "Build directory: " write cwd print - "Build machine: " write host-name print - "CPU: " write cpu print - "OS: " write os print - "Build directory: " write cwd print nl + git-clone [ "git clone failed" print ] run-or-bail - git-clone [ "git clone failed" print ] run-or-bail + "factor" + [ + record-git-id + do-make-clean + do-make-vm + copy-image + do-bootstrap + do-builder-test + ] + with-directory - "factor" cd + "test-log" delete-file - record-git-id + "git id: " write "git-id" eval-file print nl - make-clean run-process drop + "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 - make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail + "Did not pass load-everything: " print "load-everything-vocabs" cat + "Did not pass test-all: " print "test-all-vocabs" cat - copy-image + "Benchmarks: " print "benchmarks" eval-file benchmarks. - bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail + nl - builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail + show-benchmark-deltas - "../test-log" delete-file + "benchmarks" ".." copy-file-into - "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 - - "Did not pass load-everything: " print "../load-everything-vocabs" cat - "Did not pass test-all: " print "../test-all-vocabs" cat - - "Benchmarks: " print - "../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks. - - nl - - show-benchmark-deltas - - "../benchmarks" "../../benchmarks" copy-file - - ".." cd - - maybe-release - - ] with-file-writer + maybe-release + ] + with-file-writer build-status on ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index c65241d922..849d1a54a3 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -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 ; 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -57,70 +60,46 @@ USING: system sequences splitting ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: move-file ( source destination -- ) - 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 +: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ; +: macosx-archive-cmd ( -- cmd ) { "hdiutil" "create" "-srcfolder" "factor" "-fs" "HFS+" "-volname" "factor" - archive-name } - to-strings run-process drop + archive-name } ; - archive-name releases move-file ; +: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: archive-cmd ( -- cmd ) + { + { [ windows? ] [ windows-archive-cmd ] } + { [ macosx? ] [ macosx-archive-cmd ] } + { [ unix? ] [ unix-archive-cmd ] } + } + 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 ( -- ) - os - { - { "linux" [ linux-release ] } - { "winnt" [ windows-release ] } - { "macosx" [ macosx-release ] } - } - case ; + "factor" + [ + remove-factor-app + remove-common-files + ] + with-directory + make-archive + archive-name releases move-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 1081d3256d..9682fc1346 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations io io.files io.launcher io.sockets math math.parser 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 ; IN: builder.util @@ -108,4 +108,4 @@ USE: prettyprint ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: failsafe ( quot -- ) [ drop ] recover ; \ No newline at end of file +: failsafe ( quot -- ) [ drop ] recover ; diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index 1f23d4f841..eb32ce5b43 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: calendar.format.tests USING: calendar.format tools.test io.streams.string ; [ 0 ] [ diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor index 4e1833af06..30e22c487b 100644 --- a/extra/calendar/unix/unix.factor +++ b/extra/calendar/unix/unix.factor @@ -1,5 +1,7 @@ + USING: alien alien.c-types arrays calendar.backend -kernel structs math unix namespaces ; + kernel structs math unix.time namespaces ; + IN: calendar.unix TUPLE: unix-calendar ; diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index 1f2436cf5d..df72572c67 100755 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -3,7 +3,7 @@ ! USING: kernel tools.test math channels channels.private sequences threads sorting ; -IN: temporary +IN: channels.tests { V{ 10 } } [ V{ } clone diff --git a/extra/channels/remote/remote-tests.factor b/extra/channels/remote/remote-tests.factor index 58a70fbf62..03967c954e 100644 --- a/extra/channels/remote/remote-tests.factor +++ b/extra/channels/remote/remote-tests.factor @@ -3,7 +3,7 @@ ! USING: kernel tools.test math assocs channels channels.remote channels.remote.private ; -IN: temporary +IN: channels.remote.tests { t } [ remote-channels assoc? diff --git a/extra/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor index 44f0b50996..20b7e2a02d 100644 --- a/extra/cocoa/cocoa-tests.factor +++ b/extra/cocoa/cocoa-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: cocoa.tests USING: cocoa cocoa.messages cocoa.subclassing cocoa.types compiler kernel namespaces cocoa.classes tools.test memory compiler.units ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 32fca44eaf..0a08948346 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,6 +1,6 @@ USING: combinators.lib kernel math random sequences tools.test continuations arrays vectors ; -IN: temporary +IN: combinators.lib.tests [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 019f4fe376..f65b94dc11 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -170,4 +170,4 @@ MACRO: construct-slots ( assoc tuple-class -- tuple ) >r keep r> rot [ call ] [ 2drop f ] if ; inline : retry ( quot n -- ) - swap [ drop ] swap compose attempt-all ; + [ drop ] rot compose attempt-all ; inline diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index e06b97489b..0f18fcf431 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math concurrency.mailboxes threads sequences ; diff --git a/extra/concurrency/count-downs/count-downs-tests.factor b/extra/concurrency/count-downs/count-downs-tests.factor index f6bd64234f..649802cd95 100755 --- a/extra/concurrency/count-downs/count-downs-tests.factor +++ b/extra/concurrency/count-downs/count-downs-tests.factor @@ -1,5 +1,5 @@ USING: concurrency.count-downs threads kernel tools.test ; -IN: temporary` +IN: concurrency.count-downs.tests` [ ] [ 0 await ] unit-test diff --git a/extra/concurrency/exchangers/exchangers-tests.factor b/extra/concurrency/exchangers/exchangers-tests.factor index 91338389d1..569b1a72c2 100755 --- a/extra/concurrency/exchangers/exchangers-tests.factor +++ b/extra/concurrency/exchangers/exchangers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.exchangers.tests USING: sequences tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; diff --git a/extra/concurrency/flags/flags-tests.factor b/extra/concurrency/flags/flags-tests.factor new file mode 100755 index 0000000000..f23ea95167 --- /dev/null +++ b/extra/concurrency/flags/flags-tests.factor @@ -0,0 +1,46 @@ +IN: concurrency.flags.tests +USING: tools.test concurrency.flags kernel threads locals ; + +:: flag-test-1 ( -- ) + [let | f [ ] | + [ f raise-flag ] "Flag test" spawn drop + f lower-flag + f flag-value? + ] ; + +[ f ] [ flag-test-1 ] unit-test + +:: flag-test-2 ( -- ) + [let | f [ ] | + [ 1000 sleep f raise-flag ] "Flag test" spawn drop + f lower-flag + f flag-value? + ] ; + +[ f ] [ flag-test-2 ] unit-test + +:: flag-test-3 ( -- ) + [let | f [ ] | + f raise-flag + f flag-value? + ] ; + +[ t ] [ flag-test-3 ] unit-test + +:: flag-test-4 ( -- ) + [let | f [ ] | + [ f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f flag-value? + ] ; + +[ t ] [ flag-test-4 ] unit-test + +:: flag-test-5 ( -- ) + [let | f [ ] | + [ 1000 sleep f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f flag-value? + ] ; + +[ t ] [ flag-test-5 ] unit-test diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor old mode 100644 new mode 100755 index 888b617b85..d598bf0b59 --- a/extra/concurrency/flags/flags.factor +++ b/extra/concurrency/flags/flags.factor @@ -9,8 +9,8 @@ TUPLE: flag value? thread ; : raise-flag ( flag -- ) dup flag-value? [ - dup flag-thread ?box - [ resume ] [ drop t over set-flag-value? ] if + t over set-flag-value? + dup flag-thread [ resume ] if-box? ] unless drop ; : wait-for-flag ( flag -- ) @@ -19,8 +19,4 @@ TUPLE: flag value? thread ; ] if ; : lower-flag ( flag -- ) - dup flag-value? [ - f swap set-flag-value? - ] [ - wait-for-flag - ] if ; + dup wait-for-flag f swap set-flag-value? ; diff --git a/extra/concurrency/futures/futures-tests.factor b/extra/concurrency/futures/futures-tests.factor index 39299f9cf7..208a72f820 100755 --- a/extra/concurrency/futures/futures-tests.factor +++ b/extra/concurrency/futures/futures-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.futures.tests USING: concurrency.futures kernel tools.test threads ; [ 50 ] [ diff --git a/extra/concurrency/locks/locks-docs.factor b/extra/concurrency/locks/locks-docs.factor index 86db5914c9..3a89af5ba0 100755 --- a/extra/concurrency/locks/locks-docs.factor +++ b/extra/concurrency/locks/locks-docs.factor @@ -46,7 +46,7 @@ $nl $nl "Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks." $nl -"Read/write locks are reentrant. A thread holding a read lock may acquire a write lock recursively, and a thread holding a write lock may acquire a write lock or a read lock recursively, however a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held." +"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held." { $subsection rw-lock } { $subsection } { $subsection with-read-lock } diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 92f1a9f103..659bd2714e 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.locks.tests USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel threads sequences calendar ; @@ -176,3 +176,38 @@ threads sequences calendar ; [ lock-timeout-test ] [ linked-error-thread thread-name "Lock timeout-er" = ] must-fail-with + +:: read/write-test ( -- ) + [let | l [ ] | + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop + + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop + + receive + ] ; + +[ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock +] must-fail + +[ + dup [ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock + ] with-write-lock +] must-fail + +[ ] [ + dup [ + dup [ + 1 seconds [ ] with-read-lock-timeout + ] with-read-lock + ] with-write-lock +] unit-test diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index ea442612b1..43f22c00da 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -55,17 +55,23 @@ TUPLE: rw-lock readers writers reader# writer ; r rw-lock-readers r> "read lock" wait ] when drop - dup rw-lock-reader# 1+ swap set-rw-lock-reader# ; + add-reader ; : notify-writer ( lock -- ) rw-lock-writers notify-1 ; +: remove-reader ( lock -- ) + dup rw-lock-reader# 1- swap set-rw-lock-reader# ; + : release-read-lock ( lock -- ) - dup rw-lock-reader# 1- dup pick set-rw-lock-reader# - zero? [ notify-writer ] [ drop ] if ; + dup remove-reader + dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ; : acquire-write-lock ( lock timeout -- ) over rw-lock-writer pick rw-lock-reader# 0 > or @@ -77,23 +83,34 @@ TUPLE: rw-lock readers writers reader# writer ; dup rw-lock-readers dlist-empty? [ notify-writer ] [ rw-lock-readers notify-all ] if ; -: do-reentrant-rw-lock ( lock timeout quot quot' -- ) - >r pick rw-lock-writer self eq? [ 2nip call ] r> if ; inline +: reentrant-read-lock-ok? ( lock -- ? ) + #! If we already have a write lock, then we can grab a read + #! lock too. + rw-lock-writer self eq? ; + +: reentrant-write-lock-ok? ( lock -- ? ) + #! The only case where we have a writer and > 1 reader is + #! write -> read re-entrancy, and in this case we prohibit + #! a further write -> read -> write re-entrancy. + dup rw-lock-writer self eq? + swap rw-lock-reader# zero? and ; PRIVATE> : with-read-lock-timeout ( lock timeout quot -- ) - [ + pick reentrant-read-lock-ok? [ + [ drop add-reader ] [ remove-reader ] do-lock + ] [ [ acquire-read-lock ] [ release-read-lock ] do-lock - ] do-reentrant-rw-lock ; inline + ] if ; inline : with-read-lock ( lock quot -- ) f swap with-read-lock-timeout ; inline : with-write-lock-timeout ( lock timeout quot -- ) - [ + pick reentrant-write-lock-ok? [ 2nip call ] [ [ acquire-write-lock ] [ release-write-lock ] do-lock - ] do-reentrant-rw-lock ; inline + ] if ; inline : with-write-lock ( lock quot -- ) f swap with-write-lock-timeout ; inline diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 4541d06a5a..24d83b2961 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.mailboxes.tests USING: concurrency.mailboxes vectors sequences threads tools.test math kernel strings ; diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 3f6e4e3ed8..6de381b166 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -4,7 +4,7 @@ USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words match quotations concurrency.messaging concurrency.mailboxes ; -IN: temporary +IN: concurrency.messaging.tests [ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test diff --git a/extra/concurrency/promises/promises-tests.factor b/extra/concurrency/promises/promises-tests.factor index fa749438d2..36fe4ef907 100755 --- a/extra/concurrency/promises/promises-tests.factor +++ b/extra/concurrency/promises/promises-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.promises.tests USING: vectors concurrency.promises kernel threads sequences tools.test ; diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor index 52b1123265..6710452b22 100644 --- a/extra/coroutines/coroutines-tests.factor +++ b/extra/coroutines/coroutines-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither. ! See http://factorcode.org/license.txt for BSD license. -IN: temporary +IN: coroutines.tests USING: coroutines kernel sequences prettyprint tools.test math ; : test1 ( -- co ) diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index 64efb96f90..35c99258db 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -1,5 +1,5 @@ USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ; -IN: temporary +IN: crypto.hmac.tests [ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test [ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test diff --git a/extra/crypto/timing/timing-tests.factor b/extra/crypto/timing/timing-tests.factor index 1337ccca8a..9afb913724 100644 --- a/extra/crypto/timing/timing-tests.factor +++ b/extra/crypto/timing/timing-tests.factor @@ -1,4 +1,4 @@ USING: crypto.timing kernel tools.test system math ; -IN: temporary +IN: crypto.timing.tests [ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test diff --git a/extra/crypto/xor/xor-tests.factor b/extra/crypto/xor/xor-tests.factor index 2a6fd525e0..ef781b9f25 100644 --- a/extra/crypto/xor/xor-tests.factor +++ b/extra/crypto/xor/xor-tests.factor @@ -1,5 +1,5 @@ USING: continuations crypto.xor kernel strings tools.test ; -IN: temporary +IN: crypto.xor.tests ! No key [ "" dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with diff --git a/extra/db/db.factor b/extra/db/db.factor index a577ff5fc5..e834144d0c 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math namespaces sequences sequences.lib tuples words strings -tools.walker ; +tools.walker new-slots accessors ; IN: db TUPLE: db @@ -25,10 +25,10 @@ HOOK: db-close db ( handle -- ) : dispose-db ( db -- ) dup db [ - dup db-insert-statements dispose-statements - dup db-update-statements dispose-statements - dup db-delete-statements dispose-statements - db-handle db-close + dup insert-statements>> dispose-statements + dup update-statements>> dispose-statements + dup delete-statements>> dispose-statements + handle>> db-close ] with-variable ; TUPLE: statement handle sql in-params out-params bind-params bound? ; @@ -36,11 +36,7 @@ TUPLE: simple-statement ; TUPLE: prepared-statement ; TUPLE: result-set sql params handle n max ; : ( sql in out -- statement ) - { - set-statement-sql - set-statement-in-params - set-statement-out-params - } statement construct ; + { (>>sql) (>>in-params) (>>out-params) } statement construct ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -62,21 +58,18 @@ GENERIC: more-rows? ( result-set -- ? ) ] if ; : bind-statement ( obj statement -- ) - [ set-statement-bind-params ] keep + swap >>bind-params [ bind-statement* ] keep - t swap set-statement-bound? ; + t >>bound? drop ; : init-result-set ( result-set -- ) - dup #rows over set-result-set-max - 0 swap set-result-set-n ; + dup #rows >>max + 0 >>n drop ; : ( query handle tuple -- result-set ) - >r >r { statement-sql statement-in-params } get-slots r> - { - set-result-set-sql - set-result-set-params - set-result-set-handle - } result-set construct r> construct-delegate ; + >r >r { sql>> in-params>> } get-slots r> + { (>>sql) (>>params) (>>handle) } result-set + construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 7ea2bb629a..250f98f73e 100755 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -4,12 +4,10 @@ USING: kernel db.postgresql alien continuations io classes prettyprint sequences namespaces tools.test db db.tuples db.types unicode.case ; -IN: temporary +IN: db.postgresql.tests -IN: scratchpad : test-db ( -- postgresql-db ) { "localhost" "postgres" "" "factor-test" } postgresql-db ; -IN: temporary [ ] [ test-db [ ] with-db ] unit-test diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 6c4b65ff9f..974fdb8782 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,7 +1,7 @@ USING: io io.files io.launcher kernel namespaces prettyprint tools.test db.sqlite db sequences continuations db.types db.tuples unicode.case ; -IN: temporary +IN: db.sqlite.tests : test.db "extra/db/sqlite/test.db" resource-path ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 1d927494b3..432d58adb6 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,7 @@ hashtables io.files io.files.tmp kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators tools.walker -combinators.cleave ; +combinators.cleave io ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -61,7 +61,8 @@ M: sqlite-result-set dispose ( result-set -- ) M: sqlite-statement bind-statement* ( statement -- ) dup statement-bound? [ dup reset-statement ] when - [ statement-bind-params ] [ statement-handle ] bi sqlite-bind ; + [ statement-bind-params ] [ statement-handle ] bi + sqlite-bind ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ @@ -72,7 +73,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) [ sql-spec-type ] tri 3array ] with map ] keep - [ set-statement-bind-params ] keep bind-statement* ; + bind-statement ; : last-insert-id ( -- id ) db get db-handle sqlite3_last_insert_rowid @@ -180,10 +181,14 @@ M: sqlite-db ( tuple class -- statement ) " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset - " where " 0% - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ";" 0% + dup empty? [ + drop + ] [ + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ";" 0% + ] if ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index c9e6d302e0..517f8bcc36 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math prettyprint tools.walker db.sqlite ; -IN: temporary +IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real ; : ( name age real -- person ) @@ -41,73 +41,73 @@ SYMBOL: the-person2 T{ person f 2 "johnny" 10 3.14 } } ] [ T{ person f f f f 3.14 } select-tuples ] unit-test + [ + { + T{ person f 1 "billy" 200 3.14 } + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f } select-tuples ] unit-test + [ ] [ the-person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test [ ] [ person drop-table ] unit-test ; -: test-sqlite ( -- ) - "tuples-test.db" resource-path sqlite-db [ - test-tuples - ] with-db ; +: make-native-person-table ( -- ) + [ person drop-table ] [ drop ] recover + person create-table + T{ person f f "billy" 200 3.14 } insert-tuple + T{ person f f "johnny" 10 3.14 } insert-tuple + ; -: test-postgresql ( -- ) - { "localhost" "postgres" "" "factor-test" } postgresql-db [ - test-tuples - ] with-db ; +: native-person-schema ( -- ) + person "PERSON" + { + { "the-id" "ID" +native-id+ } + { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + { "the-number" "AGE" INTEGER { +default+ 0 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + } define-persistent + "billy" 10 3.14 the-person1 set + "johnny" 10 3.14 the-person2 set ; -person "PERSON" -{ - { "the-id" "ID" +native-id+ } - { "the-name" "NAME" { VARCHAR 256 } +not-null+ } - { "the-number" "AGE" INTEGER { +default+ 0 } } - { "the-real" "REAL" DOUBLE { +default+ 0.3 } } -} define-persistent +: assigned-person-schema ( -- ) + person "PERSON" + { + { "the-id" "ID" INTEGER +assigned-id+ } + { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + { "the-number" "AGE" INTEGER { +default+ 0 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + } define-persistent + 1 "billy" 10 3.14 the-person1 set + 2 "johnny" 10 3.14 the-person2 set ; -"billy" 10 3.14 the-person1 set -"johnny" 10 3.14 the-person2 set - -test-sqlite -! test-postgresql - -person "PERSON" -{ - { "the-id" "ID" INTEGER +assigned-id+ } - { "the-name" "NAME" { VARCHAR 256 } +not-null+ } - { "the-number" "AGE" INTEGER { +default+ 0 } } - { "the-real" "REAL" DOUBLE { +default+ 0.3 } } -} define-persistent - -1 "billy" 10 3.14 the-person1 set -2 "johnny" 10 3.14 the-person2 set - -test-sqlite -! test-postgresql TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; -paste "PASTE" -{ - { "n" "ID" +native-id+ } - { "summary" "SUMMARY" TEXT } - { "author" "AUTHOR" TEXT } - { "channel" "CHANNEL" TEXT } - { "mode" "MODE" TEXT } - { "contents" "CONTENTS" TEXT } - { "date" "DATE" TIMESTAMP } - { "annotations" { +has-many+ annotation } } -} define-persistent +: native-paste-schema ( -- ) + paste "PASTE" + { + { "n" "ID" +native-id+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "channel" "CHANNEL" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + { "date" "DATE" TIMESTAMP } + { "annotations" { +has-many+ annotation } } + } define-persistent -annotation "ANNOTATION" -{ - { "n" "ID" +native-id+ } - { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } - { "summary" "SUMMARY" TEXT } - { "author" "AUTHOR" TEXT } - { "mode" "MODE" TEXT } - { "contents" "CONTENTS" TEXT } -} define-persistent + annotation "ANNOTATION" + { + { "n" "ID" +native-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; ! { "localhost" "postgres" "" "factor-test" } postgresql-db [ ! [ paste drop-table ] [ drop ] recover @@ -117,3 +117,15 @@ annotation "ANNOTATION" ! [ ] [ paste create-table ] unit-test ! [ ] [ annotation create-table ] unit-test ! ] with-db + + +: test-sqlite ( quot -- ) + >r "tuples-test.db" resource-path sqlite-db r> with-db ; + +: test-postgresql ( -- ) + >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; + +[ native-person-schema test-tuples ] test-sqlite +[ assigned-person-schema test-tuples ] test-sqlite + +! [ make-native-person-table ] test-sqlite diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index dd9a77aa21..d66357daa5 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,5 +1,5 @@ USING: delegate kernel arrays tools.test ; -IN: temporary +IN: delegate.tests TUPLE: hello this that ; C: hello diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index db4f023dad..09b4ccc357 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -1,5 +1,5 @@ USING: destructors kernel tools.test continuations ; -IN: temporary +IN: destructors.tests TUPLE: dummy-obj destroyed? ; diff --git a/extra/documents/documents-tests.factor b/extra/documents/documents-tests.factor index dfa24c6cea..e09afebfc2 100644 --- a/extra/documents/documents-tests.factor +++ b/extra/documents/documents-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: documents.tests USING: documents namespaces tools.test ; ! Tests diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor old mode 100644 new mode 100755 index db11833cf1..2e0d9832b0 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -1,42 +1,44 @@ USING: farkup kernel tools.test ; -IN: temporary +IN: farkup.tests -[ "
  • foo
" ] [ "-foo" parse-farkup ] unit-test -[ "
  • foo
\n" ] [ "-foo\n" parse-farkup ] unit-test -[ "
  • foo
  • bar
" ] [ "-foo\n-bar" parse-farkup ] unit-test -[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" parse-farkup ] unit-test +[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test +[ "
  • foo
\n" ] [ "-foo\n" convert-farkup ] unit-test +[ "
  • foo
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test +[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test -[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" parse-farkup ] unit-test -[ "

*foo\nbar\n

" ] [ "*foo\nbar\n" parse-farkup ] unit-test -[ "

Wow!

" ] [ "*Wow!*" parse-farkup ] unit-test -[ "

Wow.

" ] [ "_Wow._" parse-farkup ] unit-test +[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test +[ "

*foo\nbar\n

" ] [ "*foo\nbar\n" convert-farkup ] unit-test +[ "

Wow!

" ] [ "*Wow!*" convert-farkup ] unit-test +[ "

Wow.

" ] [ "_Wow._" convert-farkup ] unit-test -[ "

*

" ] [ "*" parse-farkup ] unit-test -[ "

*

" ] [ "\\*" parse-farkup ] unit-test -[ "

**

" ] [ "\\**" parse-farkup ] unit-test +[ "

*

" ] [ "*" convert-farkup ] unit-test +[ "

*

" ] [ "\\*" convert-farkup ] unit-test +[ "

**

" ] [ "\\**" convert-farkup ] unit-test -[ "" ] [ "\n\n" parse-farkup ] unit-test -[ "\n" ] [ "\n\n\n" parse-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\n\nbar" parse-farkup ] unit-test +[ "" ] [ "\n\n" convert-farkup ] unit-test +[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test -[ "\n

bar\n

" ] [ "\nbar\n" parse-farkup ] unit-test +[ "\n

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test -[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" parse-farkup ] unit-test +[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test -[ "" ] [ "" parse-farkup ] unit-test +[ "" ] [ "" convert-farkup ] unit-test [ "

|a

" ] -[ "|a" parse-farkup ] unit-test +[ "|a" convert-farkup ] unit-test [ "

|a|

" ] -[ "|a|" parse-farkup ] unit-test +[ "|a|" convert-farkup ] unit-test [ "
ab
" ] -[ "a|b" parse-farkup ] unit-test +[ "a|b" convert-farkup ] unit-test [ "
ab
\n
cd
" ] -[ "a|b\nc|d" parse-farkup ] unit-test +[ "a|b\nc|d" convert-farkup ] unit-test [ "
ab
\n
cd
\n" ] -[ "a|b\nc|d\n" parse-farkup ] unit-test +[ "a|b\nc|d\n" convert-farkup ] unit-test +[ "

foo\n

aheading

\n

adfasd

" ] +[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor old mode 100644 new mode 100755 index 718b8b3e28..dac4359d90 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -1,24 +1,20 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io kernel memoize namespaces peg -peg.ebnf sequences strings html.elements xml.entities -xmode.code2html splitting io.streams.string html -html.elements sequences.deep ascii ; -! unicode.categories ; -USE: tools.walker +USING: arrays io kernel memoize namespaces peg sequences strings +html.elements xml.entities xmode.code2html splitting +io.streams.string html peg.parsers html.elements sequences.deep +unicode.categories ; IN: farkup -MEMO: any-char ( -- parser ) [ drop t ] satisfy ; - : delimiters ( -- string ) - "*_^~%=[-|\\\n" ; inline + "*_^~%[-=|\\\n" ; inline MEMO: text ( -- parser ) [ delimiters member? not ] satisfy repeat1 [ >string escape-string ] action ; MEMO: delimiter ( -- parser ) - [ dup delimiters member? swap CHAR: \n = not and ] satisfy + [ dup delimiters member? swap "\n=" member? not and ] satisfy [ 1string ] action ; : surround-with-foo ( string tag -- seq ) @@ -39,12 +35,12 @@ MEMO: emphasis ( -- parser ) "_" "em" delimited ; MEMO: superscript ( -- parser ) "^" "sup" delimited ; MEMO: subscript ( -- parser ) "~" "sub" delimited ; MEMO: inline-code ( -- parser ) "%" "code" delimited ; +MEMO: nl ( -- parser ) "\n" token ; +MEMO: 2nl ( -- parser ) "\n\n" token hide ; MEMO: h1 ( -- parser ) "=" "h1" delimited ; MEMO: h2 ( -- parser ) "==" "h2" delimited ; MEMO: h3 ( -- parser ) "===" "h3" delimited ; MEMO: h4 ( -- parser ) "====" "h4" delimited ; -MEMO: nl ( -- parser ) "\n" token ; -MEMO: 2nl ( -- parser ) "\n\n" token hide ; : render-code ( string mode -- string' ) >r string-lines r> @@ -87,7 +83,7 @@ MEMO: table-column ( -- parser ) MEMO: table-row ( -- parser ) [ - table-column "|" token hide list-of* , + table-column "|" token hide list-of-many , ] seq* [ "tr" surround-with-foo ] action ; MEMO: table ( -- parser ) @@ -121,28 +117,13 @@ MEMO: paragraph ( -- parser ) [ "

" swap "

" 3array ] unless ] action ; -MEMO: farkup ( -- parser ) +PEG: parse-farkup ( -- parser ) [ list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , ] choice* repeat0 "\n" token optional 2seq ; -: farkup. ( parse-result -- ) - parse-result-ast +: write-farkup ( parse-result -- ) [ dup string? [ write ] [ drop ] if ] deep-each ; -: parse-farkup ( string -- string' ) - farkup parse [ farkup. ] with-string-writer ; - -! MEMO: table-column ( -- parser ) - ! text [ "td" surround-with-foo ] action ; -! -! MEMO: table-row ( -- parser ) - ! [ - ! "|" token hide , - ! table-column "|" token hide list-of , - ! "|" token "\n" token 2array choice hide , - ! ] seq* [ "tr" surround-with-foo ] action ; -! -! MEMO: table ( -- parser ) - ! table-row repeat1 - ! [ "table" surround-with-foo ] action ; +: convert-farkup ( string -- string' ) + parse-farkup [ write-farkup ] with-string-writer ; diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor index ccb004581a..ce968128be 100755 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test peg fjsc ; -IN: temporary +IN: fjsc.tests { T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ "55 2abc1 100" 'expression' parse parse-result-ast diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 5b5900f0bc..3811949c1d 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg strings promises sequences math math.parser namespaces words quotations arrays hashtables io - io.streams.string assocs memoize ascii ; + io.streams.string assocs memoize ascii peg.parsers ; IN: fjsc TUPLE: ast-number value ; diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor index fd21a4a4cd..4d2c9fe1c8 100755 --- a/extra/fry/fry-tests.factor +++ b/extra/fry/fry-tests.factor @@ -1,42 +1,46 @@ -IN: temporary -USING: fry tools.test math prettyprint kernel io arrays -sequences ; - -[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test - -[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test - -[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test - -[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test - -[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test - -[ [ "a" write "b" print ] ] -[ "a" "b" '[ , write , print ] ] unit-test - -[ [ 1 2 + 3 4 - ] ] -[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test - -[ 1/2 ] [ - 1 '[ , _ / ] 2 swap call -] unit-test - -[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ - 1 '[ , _ _ 3array ] - { "a" "b" "c" } { "A" "B" "C" } rot 2map -] unit-test - -[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ - '[ 1 _ 2array ] - { "a" "b" "c" } swap map -] unit-test - -[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ - 1 2 '[ , _ , 3array ] - { "a" "b" "c" } swap map -] unit-test - -: funny-dip '[ @ _ ] call ; inline - -[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test +IN: fry.tests +USING: fry tools.test math prettyprint kernel io arrays +sequences ; + +[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test + +[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test + +[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test + +[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test + +[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test + +[ [ "a" write "b" print ] ] +[ "a" "b" '[ , write , print ] ] unit-test + +[ [ 1 2 + 3 4 - ] ] +[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test + +[ 1/2 ] [ + 1 '[ , _ / ] 2 swap call +] unit-test + +[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ + 1 '[ , _ _ 3array ] + { "a" "b" "c" } { "A" "B" "C" } rot 2map +] unit-test + +[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ + '[ 1 _ 2array ] + { "a" "b" "c" } swap map +] unit-test + +[ 1 2 ] [ + 1 2 '[ _ , ] call +] unit-test + +[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ + 1 2 '[ , _ , 3array ] + { "a" "b" "c" } swap map +] unit-test + +: funny-dip '[ @ _ ] call ; inline + +[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index 0b0b91f0d0..f8d49af163 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -1,39 +1,44 @@ -! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences combinators parser splitting -quotations ; -IN: fry - -: , "Only valid inside a fry" throw ; -: @ "Only valid inside a fry" throw ; -: _ "Only valid inside a fry" throw ; - -DEFER: (fry) - -: ((fry)) ( accum quot adder -- result ) - >r [ ] swap (fry) r> - append swap dup empty? [ drop ] [ - [ swap compose ] curry append - ] if ; inline - -: (fry) ( accum quot -- result ) - dup empty? [ - drop 1quotation - ] [ - unclip { - { , [ [ curry ] ((fry)) ] } - { @ [ [ compose ] ((fry)) ] } - [ swap >r add r> (fry) ] - } case - ] if ; - -: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; - -: fry ( quot -- quot' ) - { _ } last-split1 [ - >r fry [ [ dip ] curry ] r> trivial-fry [ compose ] compose 3compose - ] [ - trivial-fry - ] if* ; - -: '[ \ ] parse-until fry over push-all ; parsing +! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences combinators parser splitting +quotations arrays namespaces ; +IN: fry + +: , "Only valid inside a fry" throw ; +: @ "Only valid inside a fry" throw ; +: _ "Only valid inside a fry" throw ; + +DEFER: (fry) + +: ((fry)) ( accum quot adder -- result ) + >r [ ] swap (fry) r> + append swap dup empty? [ drop ] [ + [ swap compose ] curry append + ] if ; inline + +: (fry) ( accum quot -- result ) + dup empty? [ + drop 1quotation + ] [ + unclip { + { , [ [ curry ] ((fry)) ] } + { @ [ [ compose ] ((fry)) ] } + [ swap >r add r> (fry) ] + } case + ] if ; + +: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; + +: fry ( quot -- quot' ) + { _ } last-split1 [ + [ + trivial-fry % + [ >r ] % + fry % + [ [ dip ] curry r> compose ] % + ] [ ] make + ] [ + trivial-fry + ] if* ; + +: '[ \ ] parse-until fry over push-all ; parsing diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor old mode 100644 new mode 100755 index 4afbd653bd..d8124d1f2b --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -1,5 +1,5 @@ USING: kernel sequences namespaces math tools.test furnace furnace.validator ; -IN: temporary +IN: furnace.tests TUPLE: test-tuple m n ; @@ -39,7 +39,7 @@ TUPLE: test-tuple m n ; ] unit-test [ - "/responder/temporary/foo?foo=3" + "/responder/furnace.tests/foo?foo=3" ] [ [ [ "3" foo ] quot-link diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor index 06d8ac815d..e84e57be6a 100644 --- a/extra/furnace/validator/validator-tests.factor +++ b/extra/furnace/validator/validator-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: furnace.validator.tests USING: kernel sequences tools.test furnace.validator furnace ; [ diff --git a/extra/globs/globs-tests.factor b/extra/globs/globs-tests.factor index 8021128810..446f1ee0a9 100644 --- a/extra/globs/globs-tests.factor +++ b/extra/globs/globs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: globs.tests USING: tools.test globs ; [ f ] [ "abd" "fdf" glob-matches? ] unit-test diff --git a/extra/help/crossref/crossref-tests.factor b/extra/help/crossref/crossref-tests.factor index eb30965f6a..1d569d8a8f 100755 --- a/extra/help/crossref/crossref-tests.factor +++ b/extra/help/crossref/crossref-tests.factor @@ -1,10 +1,10 @@ -IN: temporary +IN: help.crossref.tests USING: help.crossref help.topics help.markup tools.test words definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units ; [ ] [ - "IN: temporary USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval ] unit-test [ $subsection ] [ @@ -13,17 +13,17 @@ io.streams.string continuations debugger compiler.units ; [ t ] [ "foo" article-children - "foo" "temporary" lookup 1array sequence= + "foo" "help.crossref.tests" lookup 1array sequence= ] unit-test -[ "foo" ] [ "foo" "temporary" lookup article-parent ] unit-test +[ "foo" ] [ "foo" "help.crossref.tests" lookup article-parent ] unit-test [ ] [ - [ "foo" "temporary" lookup forget ] with-compilation-unit + [ "foo" "help.crossref.tests" lookup forget ] with-compilation-unit ] unit-test [ ] [ - "IN: temporary USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval ] unit-test [ ] [ diff --git a/extra/help/definitions/definitions-tests.factor b/extra/help/definitions/definitions-tests.factor index 836f82a306..7134c6b0b0 100755 --- a/extra/help/definitions/definitions-tests.factor +++ b/extra/help/definitions/definitions-tests.factor @@ -1,13 +1,13 @@ USING: math definitions help.topics help tools.test prettyprint parser io.streams.string kernel source-files assocs namespaces words io sequences ; -IN: temporary +IN: help.definitions.tests [ ] [ \ + >link see ] unit-test [ [ 4 ] [ - "IN: temporary USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" + "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size @@ -16,11 +16,11 @@ IN: temporary [ t ] [ "hello" articles get key? ] unit-test [ t ] [ "hello2" articles get key? ] unit-test [ t ] [ - "hello" "temporary" lookup "help" word-prop >boolean + "hello" "help.definitions.tests" lookup "help" word-prop >boolean ] unit-test [ 2 ] [ - "IN: temporary USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" + "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size @@ -29,12 +29,12 @@ IN: temporary [ t ] [ "hello" articles get key? ] unit-test [ f ] [ "hello2" articles get key? ] unit-test [ f ] [ - "hello" "temporary" lookup "help" word-prop + "hello" "help.definitions.tests" lookup "help" word-prop ] unit-test - [ ] [ "IN: temporary USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test + [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test - [ ] [ "xxx" "temporary" lookup help ] unit-test + [ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test - [ ] [ "xxx" "temporary" lookup >link synopsis print ] unit-test + [ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test ] with-file-vocabs diff --git a/extra/help/help.factor b/extra/help/help.factor index 490374a384..9332e6aff8 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -132,13 +132,13 @@ M: word set-article-parent swap "help-parent" set-word-prop ; 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 + ":s - data stack at error time" print + ":r - retain stack at error time" print + ":c - call stack at error time" print ":edit - jump to source location (parse errors only)" print - ":get ( var -- value ) accesses variables at time of the error" print ; + ":get ( var -- value ) accesses variables at time of the error" print + ":vars - list all variables at error time"; : :help ( -- ) error get delegates [ error-help ] map [ ] subset diff --git a/extra/help/markup/markup-tests.factor b/extra/help/markup/markup-tests.factor index 71a9b54760..0b4b69bf59 100644 --- a/extra/help/markup/markup-tests.factor +++ b/extra/help/markup/markup-tests.factor @@ -1,6 +1,6 @@ USING: definitions help help.markup kernel sequences tools.test words parser namespaces assocs generic io.streams.string ; -IN: temporary +IN: help.markup.tests TUPLE: blahblah quux ; diff --git a/extra/help/syntax/syntax-tests.factor b/extra/help/syntax/syntax-tests.factor index 136313c2ef..bcf92b77c7 100755 --- a/extra/help/syntax/syntax-tests.factor +++ b/extra/help/syntax/syntax-tests.factor @@ -1,21 +1,21 @@ -IN: temporary +IN: help.syntax.tests USING: tools.test parser vocabs help.syntax namespaces ; [ [ "foobar" ] [ - "IN: temporary USE: help.syntax ABOUT: \"foobar\"" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval + "help.syntax.tests" vocab vocab-help ] unit-test [ { "foobar" } ] [ - "IN: temporary USE: help.syntax ABOUT: { \"foobar\" }" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval + "help.syntax.tests" vocab vocab-help ] unit-test SYMBOL: xyz [ xyz ] [ - "IN: temporary USE: help.syntax ABOUT: xyz" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: xyz" eval + "help.syntax.tests" vocab vocab-help ] unit-test ] with-file-vocabs diff --git a/extra/help/topics/topics-tests.factor b/extra/help/topics/topics-tests.factor index c4c22b551f..1099f747bc 100644 --- a/extra/help/topics/topics-tests.factor +++ b/extra/help/topics/topics-tests.factor @@ -1,7 +1,7 @@ USING: definitions help help.topics help.crossref help.markup help.syntax kernel sequences tools.test words parser namespaces assocs source-files ; -IN: temporary +IN: help.topics.tests ! Test help cross-referencing diff --git a/extra/hexdump/hexdump-tests.factor b/extra/hexdump/hexdump-tests.factor index 3ddfe721a6..7fb26e10c5 100644 --- a/extra/hexdump/hexdump-tests.factor +++ b/extra/hexdump/hexdump-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: hexdump.tests USING: hexdump kernel sequences tools.test ; [ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor index aab00e0ca3..aa6a017540 100644 --- a/extra/html/elements/elements-tests.factor +++ b/extra/html/elements/elements-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: html.elements.tests USING: tools.test html html.elements io.streams.string ; : make-html-string diff --git a/extra/html/html-tests.factor b/extra/html/html-tests.factor index 4e3344855f..2994e2d792 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/html-tests.factor @@ -1,6 +1,6 @@ USING: html http io io.streams.string io.styles kernel namespaces tools.test xml.writer sbufs sequences html.private ; -IN: temporary +IN: html.tests : make-html-string [ with-html-stream ] with-string-writer ; diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index c490b737d9..0e98c1b998 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -1,5 +1,5 @@ USING: html.parser kernel tools.test ; -IN: temporary +IN: html.parser.tests [ V{ T{ tag f "html" H{ } f f f } } diff --git a/extra/html/parser/utils/utils-tests.factor b/extra/html/parser/utils/utils-tests.factor index fcac31a6aa..4b25db16fd 100644 --- a/extra/html/parser/utils/utils-tests.factor +++ b/extra/html/parser/utils/utils-tests.factor @@ -3,7 +3,7 @@ hashtables.private io kernel math namespaces prettyprint quotations sequences splitting state-parser strings tools.test ; USING: html.parser.utils ; -IN: temporary +IN: html.parser.utils.tests [ "'Rome'" ] [ "Rome" single-quote ] unit-test [ "\"Roma\"" ] [ "Roma" double-quote ] unit-test diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 5146502644..0a4941aaa0 100644 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,5 @@ USING: http tools.test ; -IN: temporary +IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 18edd94f12..627d7d889d 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,7 +1,7 @@ USING: webapps.file http.server.responders http http.server namespaces io tools.test strings io.server logging ; -IN: temporary +IN: http.server.tests [ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/templating-tests.factor index d889cd848a..ceb2ed95be 100644 --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/templating-tests.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.string http.server.templating kernel tools.test sequences ; -IN: temporary +IN: http.server.templating.tests : test-template ( path -- ? ) "extra/http/server/templating/test/" swap append diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 3b0dcb8e5e..4c451f7f6e 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -82,10 +82,10 @@ DEFER: <% delimiter templating-vocab use+ ! so that reload works properly dup source-file file set - dup ?resource-path file-contents + ?resource-path file-contents [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] assert-depth drop ; + ] curry assert-depth ; : run-relative-template-file ( filename -- ) file get source-file-path parent-directory diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index c9203d9ef8..2260bf5882 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.buffers.tests USING: alien alien.c-types io.buffers kernel kernel.private libc sequences tools.test namespaces ; diff --git a/extra/io/files/temporary/backend/backend.factor b/extra/io/files/temporary/backend/backend.factor deleted file mode 100644 index 0fe4068621..0000000000 --- a/extra/io/files/temporary/backend/backend.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: io.backend ; -IN: io.files.temporary.backend - -HOOK: (temporary-file) io-backend ( path prefix suffix -- stream path ) -HOOK: temporary-path io-backend ( -- path ) diff --git a/extra/io/files/temporary/temporary.factor b/extra/io/files/temporary/temporary.factor deleted file mode 100644 index d46ddff8c6..0000000000 --- a/extra/io/files/temporary/temporary.factor +++ /dev/null @@ -1,36 +0,0 @@ -USING: kernel math math.bitfields combinators.lib math.parser -random sequences sequences.lib continuations namespaces -io.files io.backend io.nonblocking io arrays -io.files.temporary.backend system combinators vocabs.loader ; -USE: tools.walker -IN: io.files.temporary - -: random-letter ( -- ch ) - 26 random { CHAR: a CHAR: A } random + ; - -: random-ch ( -- ch ) - { t f } random - [ 10 random CHAR: 0 + ] [ random-letter ] if ; - -: random-name ( n -- string ) - [ drop random-ch ] "" map-as ; - -: ( prefix suffix -- path duplex-stream ) - temporary-path -rot - [ 10 random-name swap 3append path+ dup (temporary-file) ] 3curry - 10 retry ; - -: with-temporary-file ( quot -- path ) - >r f f r> with-stream ; - -: temporary-directory ( -- path ) - [ temporary-path 10 random-name path+ dup make-directory ] 10 retry ; - -: with-temporary-directory ( quot -- ) - >r temporary-directory r> - [ with-directory ] 2keep drop delete-tree ; - -{ - { [ unix? ] [ "io.unix.files.temporary" ] } - { [ windows? ] [ "io.windows.files.temporary" ] } -} cond require diff --git a/extra/io/files/unique/backend/backend.factor b/extra/io/files/unique/backend/backend.factor new file mode 100644 index 0000000000..b26557688b --- /dev/null +++ b/extra/io/files/unique/backend/backend.factor @@ -0,0 +1,5 @@ +USING: io.backend ; +IN: io.files.unique.backend + +HOOK: (make-unique-file) io-backend ( path -- stream ) +HOOK: temporary-path io-backend ( -- path ) diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor new file mode 100644 index 0000000000..61f960d9f7 --- /dev/null +++ b/extra/io/files/unique/unique-docs.factor @@ -0,0 +1,50 @@ +USING: help.markup help.syntax io io.nonblocking kernel math +io.files.unique.private math.parser io.files ; +IN: io.files.unique + +ARTICLE: "unique" "Making and using unique files" +"Files:" +{ $subsection make-unique-file } +{ $subsection with-unique-file } +{ $subsection with-temporary-file } +"Directories:" +{ $subsection make-unique-directory } +{ $subsection with-unique-directory } +{ $subsection with-temporary-directory } ; + +ABOUT: "unique" + +HELP: make-unique-file ( prefix suffix -- path stream ) +{ $values { "prefix" "a string" } { "suffix" "a string" } +{ "path" "a pathname string" } { "stream" "an output stream" } } +{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname and a " { $link } " stream." } +{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." } +{ $see-also with-unique-file } ; + +HELP: make-unique-directory ( -- path ) +{ $values { "path" "a pathname string" } } +{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." } +{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." } +{ $see-also with-unique-directory } ; + +HELP: with-unique-file ( quot -- path ) +{ $values { "quot" "a quotation" } { "path" "a pathname string" } } +{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. Returns the full pathname after the stream has been closed." } +{ $notes "The unique file will remain after calling this word." } +{ $see-also with-temporary-file } ; + +HELP: with-unique-directory ( quot -- path ) +{ $values { "quot" "a quotation" } { "path" "a pathname string" } } +{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. Returns the full pathname after the quotation has been called." } +{ $notes "The directory will remain after calling this word." } +{ $see-also with-temporary-directory } ; + +HELP: with-temporary-file ( quot -- ) +{ $values { "quot" "a quotation" } } +{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. The file is deleted after the quotation returns." } +{ $see-also with-unique-file } ; + +HELP: with-temporary-directory ( quot -- ) +{ $values { "quot" "a quotation" } } +{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. The directory is deleted after the quotation returns." } +{ $see-also with-unique-directory } ; diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor new file mode 100644 index 0000000000..1e77cd6814 --- /dev/null +++ b/extra/io/files/unique/unique.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.bitfields combinators.lib math.parser +random sequences sequences.lib continuations namespaces +io.files io.backend io.nonblocking io arrays +io.files.unique.backend system combinators vocabs.loader ; +IN: io.files.unique + + + +: make-unique-file ( prefix suffix -- path stream ) + temporary-path -rot + [ + unique-length random-name swap 3append path+ + dup (make-unique-file) + ] 3curry unique-retries retry ; + +: with-unique-file ( quot -- path ) + >r f f make-unique-file r> rot [ with-stream ] dip ; inline + +: with-temporary-file ( quot -- ) + with-unique-file delete-file ; inline + +: make-unique-directory ( -- path ) + [ + temporary-path unique-length random-name path+ + dup make-directory + ] unique-retries retry ; + +: with-unique-directory ( quot -- path ) + >r make-unique-directory r> + [ with-directory ] curry keep ; inline + +: with-temporary-directory ( quot -- ) + with-unique-directory delete-tree ; inline + +{ + { [ unix? ] [ "io.unix.files.unique" ] } + { [ windows? ] [ "io.windows.files.unique" ] } +} cond require diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor index 6705caa33c..bacb8eb5a9 100755 --- a/extra/io/launcher/launcher-tests.factor +++ b/extra/io/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.launcher.tests USING: tools.test io.launcher ; \ must-infer diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index 25caae036d..832b88b248 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,5 +1,5 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ; -IN: temporary +IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-file-writer ] unit-test diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 34065203f8..1678c2de41 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -49,7 +49,7 @@ M: simple-monitor set-timeout set-simple-monitor-timeout ; >r r> construct-delegate ; inline : notify-callback ( simple-monitor -- ) - simple-monitor-callback ?box [ resume ] [ drop ] if ; + simple-monitor-callback [ resume ] if-box? ; M: simple-monitor timed-out notify-callback ; diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index 24b4c231d1..8e56169bb3 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.server.tests USING: tools.test io.server io.server.private ; { 1 0 } [ [ ] server-loop ] must-infer-as diff --git a/extra/io/sockets/impl/impl-tests.factor b/extra/io/sockets/impl/impl-tests.factor index 51305db45c..6b930a994e 100644 --- a/extra/io/sockets/impl/impl-tests.factor +++ b/extra/io/sockets/impl/impl-tests.factor @@ -1,5 +1,5 @@ USING: io.sockets.impl io.sockets kernel tools.test ; -IN: temporary +IN: io.sockets.impl.tests [ B{ 1 2 3 4 } ] [ "1.2.3.4" T{ inet4 } inet-pton ] unit-test diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index 103c2789c6..f5366d32ae 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.files ; -IN: temporary +IN: io.unix.files.tests [ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test [ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 7b1c97abbe..db3cf674c7 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io -unix unix.stat kernel math continuations math.bitfields byte-arrays -alien ; + unix unix.stat unix.time kernel math continuations math.bitfields + byte-arrays alien combinators combinators.cleave calendar ; IN: io.unix.files @@ -68,3 +68,24 @@ M: unix-io delete-directory ( path -- ) M: unix-io copy-file ( from to -- ) >r dup file-permissions over r> (copy-file) chmod io-error ; + +: stat>type ( stat -- type ) + stat-st_mode { + { [ dup S_ISREG ] [ +regular-file+ ] } + { [ dup S_ISDIR ] [ +directory+ ] } + { [ dup S_ISCHR ] [ +character-device+ ] } + { [ dup S_ISBLK ] [ +block-device+ ] } + { [ dup S_ISFIFO ] [ +fifo+ ] } + { [ dup S_ISLNK ] [ +symbolic-link+ ] } + { [ dup S_ISSOCK ] [ +socket+ ] } + { [ t ] [ +unknown+ ] } + } cond nip ; + +M: unix-io file-info ( path -- info ) + stat* { + [ stat>type ] + [ stat-st_size ] + [ stat-st_mode ] + [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] + } cleave + \ file-info construct-boa ; diff --git a/extra/io/unix/files/temporary/temporary.factor b/extra/io/unix/files/temporary/temporary.factor deleted file mode 100644 index 0ac6d7605e..0000000000 --- a/extra/io/unix/files/temporary/temporary.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: kernel io.nonblocking io.unix.backend math.bitfields -unix io.files.temporary.backend ; -IN: io.unix.files.temporary - -: open-temporary-flags ( -- flags ) - { O_RDWR O_CREAT O_EXCL } flags ; - -M: unix-io (temporary-file) ( path -- duplex-stream ) - open-temporary-flags file-mode open dup io-error - ; - -M: unix-io temporary-path ( -- path ) "/tmp" ; diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor new file mode 100644 index 0000000000..185d9cd405 --- /dev/null +++ b/extra/io/unix/files/unique/unique.factor @@ -0,0 +1,12 @@ +USING: kernel io.nonblocking io.unix.backend math.bitfields +unix io.files.unique.backend ; +IN: io.unix.files.unique + +: open-unique-flags ( -- flags ) + { O_RDWR O_CREAT O_EXCL } flags ; + +M: unix-io (make-unique-file) ( path -- duplex-stream ) + open-unique-flags file-mode open dup io-error + ; + +M: unix-io temporary-path ( -- path ) "/tmp" ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 7b67a9d468..60e3754ec6 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel io.nonblocking io.unix.backend -sequences assocs unix unix.kqueue unix.process math namespaces +sequences assocs unix unix.time unix.kqueue unix.process math namespaces combinators threads vectors io.launcher io.unix.launcher ; IN: io.unix.kqueue diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor deleted file mode 100755 index eb3038e1b5..0000000000 --- a/extra/io/unix/launcher/launcher-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -IN: temporary -USING: io.unix.launcher tools.test ; - -[ "" tokenize-command ] must-fail -[ " " tokenize-command ] must-fail -[ { "a" } ] [ "a" tokenize-command ] unit-test -[ { "abc" } ] [ "abc" tokenize-command ] unit-test -[ { "abc" } ] [ "abc " tokenize-command ] unit-test -[ { "abc" } ] [ " abc" tokenize-command ] unit-test -[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test -[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test -[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test -[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test -[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test -[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test -[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] must-fail -[ "'abc def" tokenize-command ] must-fail -[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test - -[ - { - "Hello world.app/Contents/MacOS/hello-ui" - "-i=boot.macosx-ppc.image" - "-include= math compiler ui" - "-deploy-vocab=hello-ui" - "-output-image=Hello world.app/Contents/Resources/hello-ui.image" - "-no-stack-traces" - "-no-user-init" - } -] [ - "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command -] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0393b13c7f..444a662c32 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -2,41 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend io.launcher io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system - alien.c-types debugger continuations arrays assocs -combinators unix.process parser-combinators memoize -promises strings threads unix ; +alien.c-types debugger continuations arrays assocs combinators +unix.process strings threads unix ; IN: io.unix.launcher ! Search unix first USE: unix -! Our command line parser. Supported syntax: -! foo bar baz -- simple tokens -! foo\ bar -- escaping the space -! 'foo bar' -- quotation -! "foo bar" -- quotation -LAZY: 'escaped-char' "\\" token any-char-parser &> ; - -LAZY: 'quoted-char' ( delimiter -- parser' ) - 'escaped-char' - swap [ member? not ] curry satisfy - <|> ; inline - -LAZY: 'quoted' ( delimiter -- parser ) - dup 'quoted-char' swap dup surrounded-by ; - -LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' ; - -LAZY: 'argument' ( -- parser ) - "\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|> - [ >string ] <@ ; - -MEMO: 'arguments' ( -- parser ) - 'argument' " " token nonempty-list-of ; - -: tokenize-command ( command -- arguments ) - 'arguments' just parse-1 ; - : get-arguments ( -- seq ) +command+ get [ tokenize-command ] [ +arguments+ get ] if* ; diff --git a/extra/io/unix/launcher/parser/parser-tests.factor b/extra/io/unix/launcher/parser/parser-tests.factor new file mode 100755 index 0000000000..63aadcabbe --- /dev/null +++ b/extra/io/unix/launcher/parser/parser-tests.factor @@ -0,0 +1,33 @@ +IN: io.unix.launcher.parser.tests +USING: io.unix.launcher.parser tools.test ; + +[ "" tokenize-command ] must-fail +[ " " tokenize-command ] must-fail +[ V{ "a" } ] [ "a" tokenize-command ] unit-test +[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test +[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test +[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test +[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test +[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test +[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test +[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test +[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test +[ "'abc def' \"hey" tokenize-command ] must-fail +[ "'abc def" tokenize-command ] must-fail +[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test + +[ + V{ + "Hello world.app/Contents/MacOS/hello-ui" + "-i=boot.macosx-ppc.image" + "-include= math compiler ui" + "-deploy-vocab=hello-ui" + "-output-image=Hello world.app/Contents/Resources/hello-ui.image" + "-no-stack-traces" + "-no-user-init" + } +] [ + "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command +] unit-test diff --git a/extra/io/unix/launcher/parser/parser.factor b/extra/io/unix/launcher/parser/parser.factor new file mode 100755 index 0000000000..21ce131abd --- /dev/null +++ b/extra/io/unix/launcher/parser/parser.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: peg peg.parsers kernel sequences strings words +memoize ; +IN: io.unix.launcher.parser + +! Our command line parser. Supported syntax: +! foo bar baz -- simple tokens +! foo\ bar -- escaping the space +! 'foo bar' -- quotation +! "foo bar" -- quotation +MEMO: 'escaped-char' + "\\" token [ drop t ] satisfy 2seq [ second ] action ; + +MEMO: 'quoted-char' ( delimiter -- parser' ) + 'escaped-char' + swap [ member? not ] curry satisfy + 2choice ; inline + +MEMO: 'quoted' ( delimiter -- parser ) + dup 'quoted-char' repeat0 swap dup surrounded-by ; + +MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; + +MEMO: 'argument' ( -- parser ) + "\"" 'quoted' + "'" 'quoted' + 'unquoted' 3choice + [ >string ] action ; + +PEG: tokenize-command ( command -- ast/f ) + 'argument' " " token repeat1 list-of + " " token repeat0 swap over pack + just ; diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index af7417854e..680cb0b3e5 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,7 +1,7 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences prettyprint system ; -IN: temporary +IN: io.unix.tests ! Unix domain stream sockets : socket-server "unix-domain-socket-test" temp-file ; diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index e740561cf9..64e2cc3c3d 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,6 +1,6 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend combinators namespaces -system vocabs.loader sequences ; +io.unix.launcher io.unix.mmap io.backend +combinators namespaces system vocabs.loader sequences ; "io.unix." os append require diff --git a/extra/io/windows/files/temporary/temporary.factor b/extra/io/windows/files/temporary/temporary.factor deleted file mode 100644 index d96ff49e15..0000000000 --- a/extra/io/windows/files/temporary/temporary.factor +++ /dev/null @@ -1,8 +0,0 @@ -USING: kernel system ; -IN: io.windows.files.temporary - -M: windows-io (temporary-file) ( path -- stream ) - GENERIC_WRITE CREATE_NEW 0 open-file 0 ; - -M: windows-io temporary-path ( -- path ) - "TEMP" os-env ; diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor new file mode 100644 index 0000000000..0823c3f0f3 --- /dev/null +++ b/extra/io/windows/files/unique/unique.factor @@ -0,0 +1,9 @@ +USING: kernel system io.files.unique.backend +windows.kernel32 io.windows io.nonblocking ; +IN: io.windows.files.unique + +M: windows-io (make-unique-file) ( path -- stream ) + GENERIC_WRITE CREATE_NEW 0 open-file 0 ; + +M: windows-io temporary-path ( -- path ) + "TEMP" os-env ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index e4ebe3dd37..c4ac99fe4a 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,6 +1,6 @@ USING: io.files kernel tools.test io.backend io.windows.nt.files splitting ; -IN: temporary +IN: io.windows.nt.tests [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test [ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 9f2f2db0a5..38b7d4829c 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.nonblocking io.sockets io.binary -io.sockets.impl windows.errors strings io.streams.duplex kernel -math namespaces sequences windows windows.kernel32 +io.sockets.impl windows.errors strings io.streams.duplex +kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting continuations math.bitfields ; IN: io.windows diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 649a6bada7..8031678896 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; -IN: temporary +IN: jamshred.tunnel.tests [ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 } T{ segment T{ oint f { 1 1 1 } } 1 } diff --git a/extra/koszul/koszul-tests.factor b/extra/koszul/koszul-tests.factor index d72314fc4d..13dc341350 100644 --- a/extra/koszul/koszul-tests.factor +++ b/extra/koszul/koszul-tests.factor @@ -1,5 +1,5 @@ USING: koszul tools.test kernel sequences assocs namespaces ; -IN: temporary +IN: koszul.tests [ { V{ { } } V{ { 1 } } V{ { 2 3 } { 7 8 } } V{ { 4 5 6 } } } diff --git a/extra/lazy-lists/examples/examples-tests.factor b/extra/lazy-lists/examples/examples-tests.factor index 14798de18a..d4e3ed79b8 100644 --- a/extra/lazy-lists/examples/examples-tests.factor +++ b/extra/lazy-lists/examples/examples-tests.factor @@ -1,5 +1,5 @@ USING: lazy-lists.examples lazy-lists tools.test ; -IN: temporary +IN: lazy-lists.examples.tests [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test [ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lazy-lists/lazy-lists-tests.factor index 9b7f0effd2..0424a5d069 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/extra/lazy-lists/lazy-lists-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: lazy-lists tools.test kernel math io sequences ; -IN: temporary +IN: lazy-lists.tests [ { 1 2 3 4 } ] [ { 1 2 3 4 } >list list>array diff --git a/extra/levenshtein/levenshtein-tests.factor b/extra/levenshtein/levenshtein-tests.factor index 40e055686a..722ccb86ca 100644 --- a/extra/levenshtein/levenshtein-tests.factor +++ b/extra/levenshtein/levenshtein-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: temporary +IN: levenshtein.tests USING: tools.test levenshtein ; [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test diff --git a/extra/lint/lint-tests.factor b/extra/lint/lint-tests.factor index 707d34b274..9a39980c9f 100644 --- a/extra/lint/lint-tests.factor +++ b/extra/lint/lint-tests.factor @@ -1,5 +1,5 @@ USING: io lint kernel math tools.test ; -IN: temporary +IN: lint.tests ! Don't write code like this : lint1 diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index b290c25159..e48f9f4061 100644 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,6 +1,6 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint ; -IN: temporary +IN: locals.tests :: foo ( a b -- a a ) a a ; diff --git a/extra/macros/macros-tests.factor b/extra/macros/macros-tests.factor index d41003797c..59a53afb70 100644 --- a/extra/macros/macros-tests.factor +++ b/extra/macros/macros-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: macros.tests USING: tools.test macros math kernel arrays vectors ; diff --git a/extra/match/match-tests.factor b/extra/match/match-tests.factor index d9162ae286..044b80fe9d 100755 --- a/extra/match/match-tests.factor +++ b/extra/match/match-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test match namespaces arrays ; -IN: temporary +IN: match.tests MATCH-VARS: ?a ?b ; diff --git a/extra/math/analysis/analysis-tests.factor b/extra/math/analysis/analysis-tests.factor index 0ed66a569c..5b537c2621 100644 --- a/extra/math/analysis/analysis-tests.factor +++ b/extra/math/analysis/analysis-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.functions tools.test math.analysis math.constants ; -IN: temporary +IN: math.analysis.tests : eps .00000001 ; diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/extra/math/combinatorics/combinatorics-tests.factor index 440630e38f..e6a2824433 100644 --- a/extra/math/combinatorics/combinatorics-tests.factor +++ b/extra/math/combinatorics/combinatorics-tests.factor @@ -1,5 +1,5 @@ USING: math.combinatorics math.combinatorics.private tools.test ; -IN: temporary +IN: math.combinatorics.tests [ { } ] [ 0 factoradic ] unit-test [ { 1 0 } ] [ 1 factoradic ] unit-test diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index e8535d0637..9174ac9988 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.constants math.functions tools.test prettyprint ; -IN: temporary +IN: math.complex.tests [ 1 C{ 0 1 } rect> ] must-fail [ C{ 0 1 } 1 rect> ] must-fail diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor index 6e961b979c..9244fa62e2 100644 --- a/extra/math/erato/erato-tests.factor +++ b/extra/math/erato/erato-tests.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists math.erato tools.test ; -IN: temporary +IN: math.erato.tests [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 6f4dc42593..6773678dab 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.constants math.functions math.private math.libm tools.test ; -IN: temporary +IN: math.functions.tests [ t ] [ 4 4 .00000001 ~ ] unit-test [ t ] [ 4.0000001 4.0000001 .000001 ~ ] unit-test diff --git a/extra/math/matrices/elimination/elimination-tests.factor b/extra/math/matrices/elimination/elimination-tests.factor index d6fb2957e1..7c833391d8 100644 --- a/extra/math/matrices/elimination/elimination-tests.factor +++ b/extra/math/matrices/elimination/elimination-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.matrices.elimination.tests USING: kernel math.matrices math.matrices.elimination tools.test sequences ; diff --git a/extra/math/matrices/matrices-tests.factor b/extra/math/matrices/matrices-tests.factor index 9670ab80b8..ee2516e9a6 100644 --- a/extra/math/matrices/matrices-tests.factor +++ b/extra/math/matrices/matrices-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.matrices.tests USING: math.matrices math.vectors tools.test math ; [ diff --git a/extra/math/miller-rabin/miller-rabin-tests.factor b/extra/math/miller-rabin/miller-rabin-tests.factor index f8bc9d4970..9ca85ea72c 100644 --- a/extra/math/miller-rabin/miller-rabin-tests.factor +++ b/extra/math/miller-rabin/miller-rabin-tests.factor @@ -1,5 +1,5 @@ USING: math.miller-rabin tools.test ; -IN: temporary +IN: math.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test diff --git a/extra/math/numerical-integration/numerical-integration-tests.factor b/extra/math/numerical-integration/numerical-integration-tests.factor index 33b6e78571..c5b92c73de 100644 --- a/extra/math/numerical-integration/numerical-integration-tests.factor +++ b/extra/math/numerical-integration/numerical-integration-tests.factor @@ -1,6 +1,6 @@ USING: kernel math.numerical-integration tools.test math math.constants math.functions ; -IN: temporary +IN: math.numerical-integration.tests [ 50 ] [ 0 10 [ ] integrate-simpson ] unit-test [ 1000/3 ] [ 0 10 [ sq ] integrate-simpson ] unit-test diff --git a/extra/math/polynomials/polynomials-tests.factor b/extra/math/polynomials/polynomials-tests.factor index 4d0cdf8c8b..73215f9167 100644 --- a/extra/math/polynomials/polynomials-tests.factor +++ b/extra/math/polynomials/polynomials-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.polynomials.tests USING: kernel math math.polynomials tools.test ; ! Tests diff --git a/extra/math/quaternions/quaternions-tests.factor b/extra/math/quaternions/quaternions-tests.factor index 4f59798df0..b30a1bc271 100644 --- a/extra/math/quaternions/quaternions-tests.factor +++ b/extra/math/quaternions/quaternions-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.quaternions.tests USING: tools.test math.quaternions kernel math.vectors math.constants ; diff --git a/extra/math/ranges/ranges-tests.factor b/extra/math/ranges/ranges-tests.factor index 09416814bd..825c68d1b9 100644 --- a/extra/math/ranges/ranges-tests.factor +++ b/extra/math/ranges/ranges-tests.factor @@ -1,5 +1,5 @@ USING: math.ranges sequences tools.test arrays ; -IN: temporary +IN: math.ranges.tests [ { } ] [ 1 1 (a,b) >array ] unit-test [ { } ] [ 1 1 (a,b] >array ] unit-test diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 4dba49b908..75572d8415 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser math.ratios math.functions tools.test ; -IN: temporary +IN: math.ratios.tests [ 1 2 ] [ 1/2 >fraction ] unit-test diff --git a/extra/math/statistics/statistics-tests.factor b/extra/math/statistics/statistics-tests.factor index 4d3b21bbbe..0884e1aed2 100644 --- a/extra/math/statistics/statistics-tests.factor +++ b/extra/math/statistics/statistics-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.functions math.statistics tools.test ; -IN: temporary +IN: math.statistics.tests [ 1 ] [ { 1 } mean ] unit-test [ 3/2 ] [ { 1 2 } mean ] unit-test diff --git a/extra/math/text/english/english-tests.factor b/extra/math/text/english/english-tests.factor index 00fccde1d3..8f8932c97d 100644 --- a/extra/math/text/english/english-tests.factor +++ b/extra/math/text/english/english-tests.factor @@ -1,5 +1,5 @@ USING: math.functions math.text.english tools.test ; -IN: temporary +IN: math.text.english.tests [ "Zero" ] [ 0 number>text ] unit-test [ "Twenty-One" ] [ 21 number>text ] unit-test diff --git a/extra/math/vectors/vectors-tests.factor b/extra/math/vectors/vectors-tests.factor index 924dc16c44..5c71e2374f 100644 --- a/extra/math/vectors/vectors-tests.factor +++ b/extra/math/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.vectors.tests USING: math.vectors tools.test ; [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index ea615d2f9a..bd02c2f708 100755 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: models.tests USING: arrays generic kernel math models namespaces sequences assocs tools.test ; diff --git a/extra/money/money-tests.factor b/extra/money/money-tests.factor index 19d6b6c2aa..b2ccdf93b7 100644 --- a/extra/money/money-tests.factor +++ b/extra/money/money-tests.factor @@ -1,5 +1,5 @@ USING: money parser tools.test ; -IN: temporary +IN: money.tests [ -1/10 ] [ DECIMAL: -.1 ] unit-test [ -1/10 ] [ DECIMAL: -0.1 ] unit-test diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index 1c68cbe540..8910e64092 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: multi-methods.tests USING: multi-methods tools.test kernel math arrays sequences prettyprint strings classes hashtables assocs namespaces debugger continuations ; diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 6f921497b2..2dd3fd911c 100755 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel lazy-lists tools.test strings math sequences parser-combinators arrays math.parser unicode.categories ; -IN: temporary +IN: parser-combinators.tests ! Testing <&> { { T{ parse-result f { "a" "b" } T{ slice f 2 4 "abcd" } } } } [ diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index cdf89e1f37..bf06708e09 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists promises kernel sequences strings math arrays splitting quotations combinators namespaces -unicode.case unicode.categories ; +unicode.case unicode.categories sequences.deep ; IN: parser-combinators ! Parser combinator protocol @@ -329,11 +329,6 @@ LAZY: <(+)> ( parser -- parser ) LAZY: surrounded-by ( parser start end -- parser' ) [ token ] 2apply swapd pack ; -: flatten* ( obj -- ) - dup array? [ [ flatten* ] each ] [ , ] if ; - -: flatten [ flatten* ] { } make ; - : exactly-n ( parser n -- parser' ) swap [ flatten ] <@ ; diff --git a/extra/partial-continuations/partial-continuations-tests.factor b/extra/partial-continuations/partial-continuations-tests.factor index 56dc6bcd87..7e876b0934 100644 --- a/extra/partial-continuations/partial-continuations-tests.factor +++ b/extra/partial-continuations/partial-continuations-tests.factor @@ -1,6 +1,6 @@ USING: namespaces math partial-continuations tools.test kernel sequences ; -IN: temporary +IN: partial-continuations.tests SYMBOL: sum diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index a308b9af52..452da8df05 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test peg peg.ebnf ; -IN: temporary +IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ "abc" 'non-terminal' parse parse-result-ast diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index d134f3316f..5d7d7297ef 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - unicode.categories ; + peg.parsers unicode.categories ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -182,4 +182,4 @@ DEFER: 'choice' f ] if* ; -: " parse-tokens " " join ebnf>quot call ; parsing \ No newline at end of file +: " parse-tokens " " join ebnf>quot call ; parsing diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor new file mode 100755 index 0000000000..437edc1007 --- /dev/null +++ b/extra/peg/parsers/parsers-docs.factor @@ -0,0 +1,149 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax peg peg.parsers.private +unicode.categories ; +IN: peg.parsers + +HELP: (list-of) +{ $values + { "items" "a sequence" } + { "separator" "a parser" } + { "repeat1?" "a boolean" } + { "parser" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Does not hide the separators." +} { $see-also list-of list-of-many } ; + +HELP: list-of +{ $values + { "items" "a sequence" } + { "separator" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of one or more items." +} { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." } +{ $examples + { $example "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" } + { $example "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also list-of-many } ; + +HELP: list-of-many +{ $values + { "items" "a sequence" } + { "separator" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of two or more items." +} { $notes "Use " { $link list-of } " to return a list of only one item." +} { $examples + { $example "\"a\" \"a\" token \",\" token list-of-many parse ." "f" } + { $example "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also list-of } ; + +HELP: epsilon +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches the empty sequence." +} ; + +HELP: any-char +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches the any single character." +} ; + +HELP: exactly-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches an exact repetition of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 4 exactly-n parse ." "f" } + { $example "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also at-least-n at-most-n from-m-to-n } ; + +HELP: at-least-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches n or more repetitions of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 4 at-least-n parse ." "f" } + { $example "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-most-n from-m-to-n } ; + +HELP: at-most-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches n or fewer repetitions of the input parser." +} { $examples + { $example "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-least-n from-m-to-n } ; + +HELP: from-m-to-n +{ $values + { "parser" "a parser" } + { "m" "an integer" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches between and including m to n repetitions of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" } + { $example "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-most-n at-least-n } ; + +HELP: pack +{ $values + { "begin" "a parser" } + { "body" "a parser" } + { "end" "a parser" } + { "parser'" "a parser" } +} { $description + "Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." +} { $examples + { $example "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" } +} { $see-also surrounded-by } ; + +HELP: surrounded-by +{ $values + { "parser" "a parser" } + { "begin" "a string" } + { "end" "a string" } + { "parser'" "a parser" } +} { $description + "Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." +} { $examples + { $example "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" } +} { $see-also pack } ; + +HELP: 'digit' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches a single digit as defined by the " { $link digit? } " word." +} { $see-also 'integer' } ; + +HELP: 'integer' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches an integer composed of digits, as defined by the " { $link 'digit' } " word." +} { $see-also 'digit' 'string' } ; + +HELP: 'string' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches an string composed of a \", anything that is not \", and another \"." +} { $see-also 'integer' } ; diff --git a/extra/peg/parsers/parsers-tests.factor b/extra/peg/parsers/parsers-tests.factor new file mode 100644 index 0000000000..08bde98419 --- /dev/null +++ b/extra/peg/parsers/parsers-tests.factor @@ -0,0 +1,50 @@ +USING: kernel peg peg.parsers tools.test ; +IN: peg.parsers.tests + +[ V{ "a" } ] +[ "a" "a" token "," token list-of parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "a,a,a,a" "a" token "," token list-of parse parse-result-ast ] unit-test + +[ f ] +[ "a" "a" token "," token list-of-many parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "a,a,a,a" "a" token "," token list-of-many parse parse-result-ast ] unit-test + +[ f ] +[ "aaa" "a" token 4 exactly-n parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 exactly-n parse parse-result-ast ] unit-test + +[ f ] +[ "aaa" "a" token 4 at-least-n parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" } ] +[ "aaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ 97 ] +[ "a" any-char parse parse-result-ast ] unit-test + +[ V{ } ] +[ "" epsilon parse parse-result-ast ] unit-test diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor new file mode 100755 index 0000000000..5e82756853 --- /dev/null +++ b/extra/peg/parsers/parsers.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences strings namespaces math assocs shuffle + vectors arrays combinators.lib memoize math.parser match + unicode.categories sequences.deep peg peg.private ; +IN: peg.parsers + +TUPLE: just-parser p1 ; + +: just-pattern + [ + dup [ + dup parse-result-remaining empty? [ drop f ] unless + ] when + ] ; + + +M: just-parser compile ( parser -- quot ) + just-parser-p1 compile just-pattern append ; + +MEMO: just ( parser -- parser ) + just-parser construct-boa init-parser ; + +r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq + [ unclip 1vector swap first append ] action ; +PRIVATE> + +MEMO: list-of ( items separator -- parser ) + hide f (list-of) ; + +MEMO: list-of-many ( items separator -- parser ) + hide t (list-of) ; + +MEMO: epsilon ( -- parser ) V{ } token ; + +MEMO: any-char ( -- parser ) [ drop t ] satisfy ; + + + +MEMO: exactly-n ( parser n -- parser' ) + swap seq ; + +MEMO: at-most-n ( parser n -- parser' ) + dup zero? [ + 2drop epsilon + ] [ + 2dup exactly-n + -rot 1- at-most-n 2choice + ] if ; + +MEMO: at-least-n ( parser n -- parser' ) + dupd exactly-n swap repeat0 2seq + [ flatten-vectors ] action ; + +MEMO: from-m-to-n ( parser m n -- parser' ) + >r [ exactly-n ] 2keep r> swap - at-most-n 2seq + [ flatten-vectors ] action ; + +MEMO: pack ( begin body end -- parser ) + >r >r hide r> r> hide 3seq [ first ] action ; + +MEMO: surrounded-by ( parser begin end -- parser' ) + [ token ] 2apply swapd pack ; + +MEMO: 'digit' ( -- parser ) + [ digit? ] satisfy [ digit> ] action ; + +MEMO: 'integer' ( -- parser ) + 'digit' repeat1 [ 10 digits>integer ] action ; + +MEMO: 'string' ( -- parser ) + [ + [ CHAR: " = ] satisfy hide , + [ CHAR: " = not ] satisfy repeat0 , + [ CHAR: " = ] satisfy hide , + ] { } make seq [ first >string ] action ; diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 6a8d7429f3..7a1ce99883 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test strings namespaces arrays sequences peg peg.private ; -IN: temporary +IN: peg.tests { 0 1 2 } [ 0 next-id set-global get-next-id get-next-id get-next-id diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ed7012da45..01decc2c81 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib memoize math.parser match - unicode.categories ; + unicode.categories sequences.lib compiler.units parser + words ; IN: peg TUPLE: parse-result remaining ast ; @@ -312,6 +313,9 @@ MEMO: range ( min max -- parser ) : 3seq ( parser1 parser2 parser3 -- parser ) 3array seq ; +: 4seq ( parser1 parser2 parser3 parser4 -- parser ) + 4array seq ; + : seq* ( quot -- paser ) { } make seq ; inline @@ -324,6 +328,9 @@ MEMO: range ( min max -- parser ) : 3choice ( parser1 parser2 parser3 -- parser ) 3array choice ; +: 4choice ( parser1 parser2 parser3 parser4 -- parser ) + 4array choice ; + : choice* ( quot -- paser ) { } make choice ; inline @@ -354,25 +361,11 @@ MEMO: hide ( parser -- parser ) MEMO: delay ( parser -- parser ) delay-parser construct-boa init-parser ; -MEMO: (list-of) ( items separator repeat1? -- parser ) - >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq - [ unclip 1vector swap first append ] action ; - -MEMO: list-of ( items separator -- parser ) - hide f (list-of) ; - -MEMO: list-of* ( items separator -- parser ) - hide t (list-of) ; - -MEMO: 'digit' ( -- parser ) - [ digit? ] satisfy [ digit> ] action ; - -MEMO: 'integer' ( -- parser ) - 'digit' repeat1 [ 10 digits>integer ] action ; - -MEMO: 'string' ( -- parser ) - [ - [ CHAR: " = ] satisfy hide , - [ CHAR: " = not ] satisfy repeat0 , - [ CHAR: " = ] satisfy hide , - ] { } make seq [ first >string ] action ; +: PEG: + (:) [ + [ + call compile + [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ] + append define + ] with-compilation-unit + ] 2curry over push-all ; parsing diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index cec7b24cd0..fa8ac89f57 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test peg peg.pl0 ; -IN: temporary +IN: peg.pl0.tests { "abc" } [ "abc" ident parse parse-result-ast diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index b6b030f56c..6844eb44dc 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays strings math.parser sequences peg peg.ebnf memoize ; +USING: kernel arrays strings math.parser sequences +peg peg.ebnf peg.parsers memoize ; IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 diff --git a/extra/peg/search/search-tests.factor b/extra/peg/search/search-tests.factor index b33161dfff..c65001be09 100755 --- a/extra/peg/search/search-tests.factor +++ b/extra/peg/search/search-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel math math.parser arrays tools.test peg peg.search ; -IN: temporary +IN: peg.search.tests { V{ 123 456 } } [ "abc 123 def 456" 'integer' search diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor index d3e031fdc6..7294ac0e8f 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: porter-stemmer.tests USING: arrays io kernel porter-stemmer sequences tools.test io.files ; diff --git a/extra/random/random-tests.factor b/extra/random/random-tests.factor index 7d506b85f3..d431e57d01 100644 --- a/extra/random/random-tests.factor +++ b/extra/random/random-tests.factor @@ -1,5 +1,5 @@ USING: kernel math random namespaces sequences tools.test ; -IN: temporary +IN: random.tests : check-random ( max -- ? ) dup >r random 0 r> between? ; diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index d4af66b72f..b19c2f39c9 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel sequences sequences.lib math math.functions math.ranges tools.test strings ; -IN: temporary +IN: sequences.lib.tests [ 50 ] [ 100 [1,b] [ even? ] count ] unit-test [ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 6c80c8de7d..766103e4b0 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -4,7 +4,7 @@ USING: tools.test kernel serialize io io.streams.string math alien arrays byte-arrays sequences math prettyprint parser classes math.constants ; -IN: temporary +IN: serialize.tests TUPLE: serialize-test a b ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 784f446b7e..c1afeced3d 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,6 +1,6 @@ USING: smtp tools.test io.streams.string threads smtp.server kernel sequences namespaces logging ; -IN: temporary +IN: smtp.tests { 0 0 } [ [ ] with-smtp-connection ] must-infer-as diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor index 4091156558..6aeb5aa098 100644 --- a/extra/taxes/taxes-tests.factor +++ b/extra/taxes/taxes-tests.factor @@ -1,5 +1,5 @@ USING: kernel money taxes tools.test ; -IN: temporary +IN: taxes.tests [ 426 23 diff --git a/extra/tools/annotations/annotations-tests.factor b/extra/tools/annotations/annotations-tests.factor index 90d9d26f51..ec8f48a161 100755 --- a/extra/tools/annotations/annotations-tests.factor +++ b/extra/tools/annotations/annotations-tests.factor @@ -1,5 +1,5 @@ USING: tools.test tools.annotations math parser ; -IN: temporary +IN: tools.annotations.tests : foo ; \ foo watch @@ -17,7 +17,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: temporary USE: math M: integer some-generic 1- ;" eval ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test [ 2 ] [ 3 some-generic ] unit-test diff --git a/extra/tools/browser/browser-tests.factor b/extra/tools/browser/browser-tests.factor index fc7960e475..38d9ae65e2 100755 --- a/extra/tools/browser/browser-tests.factor +++ b/extra/tools/browser/browser-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.browser.tests USING: tools.browser tools.test help.markup ; [ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor index b616766597..a277a68ed7 100755 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -1,12 +1,12 @@ USING: math kernel sequences io.files tools.crossref tools.test parser namespaces source-files generic definitions ; -IN: temporary +IN: tools.crossref.tests GENERIC: foo M: integer foo + ; -"resource:extra/tools/test/foo.factor" run-file +"resource:extra/tools/crossref/test/foo.factor" run-file [ t ] [ integer \ foo method method-word \ + usage member? ] unit-test [ t ] [ \ foo usage [ pathname? ] contains? ] unit-test diff --git a/extra/tools/test/foo.factor b/extra/tools/crossref/test/foo.factor old mode 100644 new mode 100755 similarity index 50% rename from extra/tools/test/foo.factor rename to extra/tools/crossref/test/foo.factor index 944a25cf5e..f7bc321912 --- a/extra/tools/test/foo.factor +++ b/extra/tools/crossref/test/foo.factor @@ -1,4 +1,4 @@ -USE: temporary +USE: tools.crossref.tests USE: kernel 1 2 foo drop diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 2f79669497..d473d8f640 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math ; diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index fb9e0f815a..6a2ce448af 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -10,12 +10,12 @@ IN: tools.deploy.windows vm over copy-file ; : copy-fonts ( bundle-name -- ) - "fonts/" resource-path swap copy-tree-to ; + "fonts/" resource-path swap copy-tree-into ; : copy-dlls ( bundle-name -- ) { "freetype6.dll" "zlib1.dll" "factor.dll" } [ resource-path ] map - swap copy-files-to ; + swap copy-files-into ; : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dlls diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor index 36bcc73b74..9efbf63f7f 100644 --- a/extra/tools/memory/memory-tests.factor +++ b/extra/tools/memory/memory-tests.factor @@ -1,4 +1,4 @@ USING: tools.test tools.memory ; -IN: temporary +IN: tools.memory.tests [ ] [ heap-stats. ] unit-test diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor index c346d9763c..e33201e22c 100755 --- a/extra/tools/profiler/profiler-tests.factor +++ b/extra/tools/profiler/profiler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.profiler.tests USING: tools.profiler tools.test kernel memory math threads alien tools.profiler.private sequences ; diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index a8c7239922..743822e7f9 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -43,7 +43,7 @@ $nl } "The latter is used for vocabularies with more extensive test suites." $nl -"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run." +"If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested." { $subsection "tools.test.write" } { $subsection "tools.test.run" } { $subsection "tools.test.failure" } ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 0ab68f502e..259b91c3af 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -50,13 +50,8 @@ SYMBOL: this-test : (run-test) ( vocab -- ) dup vocab-source-loaded? [ - vocab-tests - [ - "temporary" forget-vocab - dup [ forget-source ] each - ] with-compilation-unit - dup [ run-file ] each - ] when drop ; + vocab-tests [ run-file ] each + ] [ drop ] if ; : run-test ( vocab -- failures ) V{ } clone [ diff --git a/extra/tools/test/tools.factor b/extra/tools/test/tools.factor index 7699d61062..bf74c1ae98 100644 --- a/extra/tools/test/tools.factor +++ b/extra/tools/test/tools.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.test.tests USING: completion words sequences test ; [ ] [ "swp" apropos ] unit-test diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor index 1302ebe3d8..2d4a6c3396 100755 --- a/extra/tools/walker/walker-tests.factor +++ b/extra/tools/walker/walker-tests.factor @@ -1,7 +1,7 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test continuations math.parser threads arrays tools.walker.debug ; -IN: temporary +IN: tools.walker.tests [ { } ] [ [ ] test-walker diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index 0964ea7e56..570125cb45 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test trees trees.avl math random sequences assocs ; -IN: temporary +IN: trees.avl.tests [ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor index 5075163802..29ea2eee2d 100644 --- a/extra/trees/splay/splay-tests.factor +++ b/extra/trees/splay/splay-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test trees.splay math namespaces assocs sequences random ; -IN: temporary +IN: trees.splay.tests : randomize-numeric-splay-tree ( splay-tree -- ) 100 [ drop 100 random swap at drop ] with each ; diff --git a/extra/trees/trees-tests.factor b/extra/trees/trees-tests.factor index 2795b0d5da..fd26b37c70 100644 --- a/extra/trees/trees-tests.factor +++ b/extra/trees/trees-tests.factor @@ -1,5 +1,5 @@ USING: trees assocs tools.test kernel sequences ; -IN: temporary +IN: trees.tests : test-tree ( -- tree ) TREE{ diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor index 0a9711c446..2eb9d8bb12 100755 --- a/extra/tuple-syntax/tuple-syntax-tests.factor +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -1,5 +1,5 @@ USING: tools.test tuple-syntax ; -IN: temporary +IN: tuple-syntax.tests TUPLE: foo bar baz ; diff --git a/extra/tuples/lib/lib-tests.factor b/extra/tuples/lib/lib-tests.factor index 88c09d81c4..5d90f25bd7 100644 --- a/extra/tuples/lib/lib-tests.factor +++ b/extra/tuples/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test tuples.lib ; -IN: temporary +IN: tuples.lib.tests TUPLE: foo a b* c d* e f* ; diff --git a/extra/ui/cocoa/tools/tools.factor b/extra/ui/cocoa/tools/tools.factor old mode 100644 new mode 100755 diff --git a/extra/ui/commands/commands-tests.factor b/extra/ui/commands/commands-tests.factor index de9534ab74..8001ff9761 100644 --- a/extra/ui/commands/commands-tests.factor +++ b/extra/ui/commands/commands-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.commands.tests USING: ui.commands ui.gestures tools.test help.markup io io.streams.string ; diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor index 9e1b0aa985..dab9ef5acf 100755 --- a/extra/ui/gadgets/books/books-tests.factor +++ b/extra/ui/gadgets/books/books-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.books.tests USING: tools.test ui.gadgets.books ; \ must-infer diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 224ef9e1ce..6c5d757dd4 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.buttons.tests USING: ui.commands ui.gadgets.buttons ui.gadgets.labels ui.gadgets tools.test namespaces sequences kernel models ; diff --git a/extra/ui/gadgets/frames/frames-tests.factor b/extra/ui/gadgets/frames/frames-tests.factor index 80cf70b960..e38e97c76c 100644 --- a/extra/ui/gadgets/frames/frames-tests.factor +++ b/extra/ui/gadgets/frames/frames-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.frames.tests USING: ui.gadgets.frames ui.gadgets tools.test ; [ ] [ layout ] unit-test diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index 54bae31f79..0a44e5e267 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel dlists math math.parser ui sequences hashtables assocs io arrays diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/extra/ui/gadgets/grids/grids-tests.factor index 6f08009da3..0792d55135 100644 --- a/extra/ui/gadgets/grids/grids-tests.factor +++ b/extra/ui/gadgets/grids/grids-tests.factor @@ -1,6 +1,6 @@ USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays namespaces ; -IN: temporary +IN: ui.gadgets.grids.tests [ { 0 0 } ] [ { } pref-dim ] unit-test diff --git a/extra/ui/gadgets/labelled/labelled-tests.factor b/extra/ui/gadgets/labelled/labelled-tests.factor index 87b2a45678..377f3ab787 100644 --- a/extra/ui/gadgets/labelled/labelled-tests.factor +++ b/extra/ui/gadgets/labelled/labelled-tests.factor @@ -1,7 +1,7 @@ USING: ui.gadgets ui.gadgets.labels ui.gadgets.labelled ui.gadgets.packs ui.gadgets.frames ui.gadgets.grids namespaces kernel tools.test ui.gadgets.buttons sequences ; -IN: temporary +IN: ui.gadgets.labelled.tests TUPLE: testing ; diff --git a/extra/ui/gadgets/lists/lists-tests.factor b/extra/ui/gadgets/lists/lists-tests.factor index 44a89a7e60..bf2ad72d0e 100644 --- a/extra/ui/gadgets/lists/lists-tests.factor +++ b/extra/ui/gadgets/lists/lists-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.lists.tests USING: ui.gadgets.lists models prettyprint math tools.test kernel ; diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/extra/ui/gadgets/packs/packs-tests.factor index ce6df74769..28a656e2ad 100644 --- a/extra/ui/gadgets/packs/packs-tests.factor +++ b/extra/ui/gadgets/packs/packs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.packs.tests USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render kernel namespaces tools.test math.parser sequences ; diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor index 848f7919d3..e3f6e36050 100755 --- a/extra/ui/gadgets/panes/panes-tests.factor +++ b/extra/ui/gadgets/panes/panes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.panes.tests USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.streams.string tools.test prettyprint definitions help help.syntax help.markup splitting diff --git a/extra/ui/gadgets/presentations/presentations-tests.factor b/extra/ui/gadgets/presentations/presentations-tests.factor index c4f693c939..46f274d53a 100644 --- a/extra/ui/gadgets/presentations/presentations-tests.factor +++ b/extra/ui/gadgets/presentations/presentations-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.presentations.tests USING: math ui.gadgets.presentations ui.gadgets tools.test prettyprint ui.gadgets.buttons io io.streams.string kernel tuples ; diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index dd667fdfec..5ccd6c7cd8 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.scrollers.tests USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames diff --git a/extra/ui/gadgets/slots/slots-tests.factor b/extra/ui/gadgets/slots/slots-tests.factor index 5388794624..b955a2604d 100644 --- a/extra/ui/gadgets/slots/slots-tests.factor +++ b/extra/ui/gadgets/slots/slots-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.slots.tests USING: assocs ui.gadgets.slots tools.test refs ; [ t ] [ { 1 2 3 } 2 slot-editor? ] unit-test diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/extra/ui/gadgets/tracks/tracks-tests.factor index 77c69bc8a8..e2db914089 100644 --- a/extra/ui/gadgets/tracks/tracks-tests.factor +++ b/extra/ui/gadgets/tracks/tracks-tests.factor @@ -1,5 +1,5 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test ; -IN: temporary +IN: ui.gadgets.tracks.tests [ { 100 100 } ] [ [ diff --git a/extra/ui/gadgets/worlds/worlds-tests.factor b/extra/ui/gadgets/worlds/worlds-tests.factor index 949ad49460..2e186d875d 100644 --- a/extra/ui/gadgets/worlds/worlds-tests.factor +++ b/extra/ui/gadgets/worlds/worlds-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.worlds.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel ; diff --git a/extra/ui/operations/operations-tests.factor b/extra/ui/operations/operations-tests.factor index b7b2224cfa..1e3d08f164 100755 --- a/extra/ui/operations/operations-tests.factor +++ b/extra/ui/operations/operations-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.operations.tests USING: ui.operations ui.commands prettyprint kernel namespaces tools.test ui.gadgets ui.gadgets.editors parser io io.streams.string math help help.markup ; diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor index 7262c72756..f56f5bcc4e 100755 --- a/extra/ui/tools/browser/browser-tests.factor +++ b/extra/ui/tools/browser/browser-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.tools.browser.tests USING: tools.test tools.test.ui ui.tools.browser ; \ must-infer diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index 0422c4170a..fe0a654217 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.tools.interactor.tests USING: ui.tools.interactor tools.test ; \ must-infer diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index 0024fa725f..13ce834df3 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -3,7 +3,7 @@ ui.tools.listener hashtables kernel namespaces parser sequences tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words tools.test.ui slots.private threads ; -IN: temporary +IN: ui.tools.listener.tests [ f ] [ "word" source-editor command-map empty? ] unit-test diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index c4c366bb7d..75401b3861 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -45,21 +45,20 @@ M: listener-gadget tool-scroller listener-gadget-input interactor-flag wait-for-flag ; : workspace-busy? ( workspace -- ? ) - workspace-listener - dup wait-for-listener - listener-gadget-input interactor-busy? ; - -: get-listener ( -- listener ) - [ workspace-busy? not ] get-workspace* workspace-listener ; + workspace-listener listener-gadget-input interactor-busy? ; : listener-input ( string -- ) - get-listener listener-gadget-input set-editor-string ; + get-workspace + workspace-listener + listener-gadget-input set-editor-string ; : (call-listener) ( quot listener -- ) listener-gadget-input interactor-call ; : call-listener ( quot -- ) - get-listener (call-listener) ; + [ workspace-busy? not ] get-workspace* workspace-listener + [ dup wait-for-listener (call-listener) ] 2curry + "Listener call" spawn drop ; M: listener-command invoke-command ( target command -- ) command-quot call-listener ; @@ -68,7 +67,8 @@ M: listener-operation invoke-command ( target command -- ) [ operation-hook call ] keep operation-quot call-listener ; : eval-listener ( string -- ) - get-listener + get-workspace + workspace-listener listener-gadget-input [ set-editor-string ] keep evaluate-input ; @@ -96,7 +96,9 @@ M: listener-operation invoke-command ( target command -- ) [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; : insert-word ( word -- ) - get-listener [ word-completion-string ] keep + get-workspace + workspace-listener + [ word-completion-string ] keep listener-gadget-input user-input ; : quot-action ( interactor -- lines ) diff --git a/extra/ui/tools/search/search-tests.factor b/extra/ui/tools/search/search-tests.factor index 49bd1a3837..4a75ebfc96 100755 --- a/extra/ui/tools/search/search-tests.factor +++ b/extra/ui/tools/search/search-tests.factor @@ -2,7 +2,7 @@ USING: assocs ui.tools.search help.topics io.files io.styles kernel namespaces sequences source-files threads tools.test ui.gadgets ui.gestures vocabs vocabs.loader words tools.test.ui debugger ; -IN: temporary +IN: ui.tools.search.tests [ f ] [ "no such word with this name exists, certainly" diff --git a/extra/ui/tools/tools-docs.factor b/extra/ui/tools/tools-docs.factor index 0d68be1730..57ad16bf70 100755 --- a/extra/ui/tools/tools-docs.factor +++ b/extra/ui/tools/tools-docs.factor @@ -111,7 +111,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts" { $command-map workspace "scrolling" } { $command-map workspace "workflow" } { $heading "Implementation" } -"Workspaces are instances of " { $link workspace-window } "." ; +"Workspaces are instances of " { $link workspace } "." ; ARTICLE: "ui-tools" "UI development tools" "The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.." diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index ff2444e43b..279737466f 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -3,7 +3,7 @@ ui.tools.search ui.tools.workspace kernel models namespaces sequences tools.test ui.gadgets ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.presentations ui.gadgets.scrollers vocabs tools.test.ui ui ; -IN: temporary +IN: ui.tools.tests [ [ f ] [ diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index b3b24cf749..062bcf9416 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -82,7 +82,7 @@ workspace "workflow" f { } define-command-map [ - "Factor workspace" open-status-window + dup "Factor workspace" open-status-window ] workspace-window-hook set-global : inspect-continuation ( traceback -- ) diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index 36b2abb7dd..fefb188239 100755 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -1,4 +1,4 @@ USING: ui.tools.walker tools.test ; -IN: temporary +IN: ui.tools.walker.tests \ must-infer diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/extra/ui/tools/workspace/workspace-tests.factor index 5e3695fed3..49b14cda77 100755 --- a/extra/ui/tools/workspace/workspace-tests.factor +++ b/extra/ui/tools/workspace/workspace-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.tools.workspace.tests USING: tools.test ui.tools ; \ must-infer diff --git a/extra/ui/tools/workspace/workspace.factor b/extra/ui/tools/workspace/workspace.factor index de21bf3187..d79fa92f54 100755 --- a/extra/ui/tools/workspace/workspace.factor +++ b/extra/ui/tools/workspace/workspace.factor @@ -14,9 +14,12 @@ TUPLE: workspace book listener popup ; SYMBOL: workspace-window-hook -: workspace-window ( -- workspace ) +: workspace-window* ( -- workspace ) workspace-window-hook get call ; +: workspace-window ( -- ) + workspace-window* drop ; + GENERIC: call-tool* ( arg tool -- ) GENERIC: tool-scroller ( tool -- scroller ) @@ -33,9 +36,9 @@ M: gadget tool-scroller drop f ; : select-tool ( workspace class -- ) swap show-tool drop ; : get-workspace* ( quot -- workspace ) - [ dup workspace? [ over call ] [ drop f ] if ] find-window - [ nip dup raise-window gadget-child ] - [ workspace-window get-workspace* ] if* ; inline + [ >r dup workspace? r> [ drop f ] if ] curry find-window + [ dup raise-window gadget-child ] + [ workspace-window* ] if* ; inline : get-workspace ( -- workspace ) [ drop t ] get-workspace* ; diff --git a/extra/ui/traverse/traverse-tests.factor b/extra/ui/traverse/traverse-tests.factor index 37b3f25321..5e6ac4125b 100755 --- a/extra/ui/traverse/traverse-tests.factor +++ b/extra/ui/traverse/traverse-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.traverse.tests USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel math arrays tools.test io ui.gadgets.panes ui.traverse definitions compiler.units ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index b5ab63c4c8..6cba5cfdf8 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -235,6 +235,35 @@ M: windows-ui-backend (close-window) : handle-wm-kill-focus ( hWnd uMsg wParam lParam -- ) 3drop window [ unfocus-world ] when* ; +: message>button ( uMsg -- button down? ) + { + { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] } + { [ dup WM_LBUTTONUP = ] [ drop 1 f ] } + { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] } + { [ dup WM_MBUTTONUP = ] [ drop 2 f ] } + { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] } + { [ dup WM_RBUTTONUP = ] [ drop 3 f ] } + + { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] } + { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] } + { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] } + { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] } + { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] } + { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] } + } cond ; + +! If the user clicks in the window border ("non-client area") +! Windows sends us an NC[LMR]BUTTONDOWN message; but if the +! mouse is subsequently released outside the NC area, we receive +! a [LMR]BUTTONUP message and Factor can get confused. So we +! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN. +SYMBOL: nc-buttons + +: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- ) + 2drop nip + message>button nc-buttons get + swap [ push ] [ delete ] if ; + : >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ; : mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ; @@ -244,16 +273,8 @@ M: windows-ui-backend (close-window) get-RECT-top-left 2array v- ; : mouse-event>gesture ( uMsg -- button ) - key-modifiers swap - { - { [ dup WM_LBUTTONDOWN = ] [ drop 1 ] } - { [ dup WM_LBUTTONUP = ] [ drop 1 ] } - { [ dup WM_MBUTTONDOWN = ] [ drop 2 ] } - { [ dup WM_MBUTTONUP = ] [ drop 2 ] } - { [ dup WM_RBUTTONDOWN = ] [ drop 3 ] } - { [ dup WM_RBUTTONUP = ] [ drop 3 ] } - { [ t ] [ "bad button" throw ] } - } cond ; + key-modifiers swap message>button + [ ] [ ] if ; : mouse-buttons ( -- seq ) WM_LBUTTONDOWN WM_RBUTTONDOWN 2array ; @@ -276,12 +297,16 @@ M: windows-ui-backend (close-window) mouse-captured off ; : handle-wm-buttondown ( hWnd uMsg wParam lParam -- ) - >r over capture-mouse? [ pick set-capture ] when r> + >r >r dup capture-mouse? [ over set-capture ] when r> r> prepare-mouse send-button-down ; : handle-wm-buttonup ( hWnd uMsg wParam lParam -- ) mouse-captured get [ release-capture ] when - prepare-mouse send-button-up ; + pick message>button drop dup nc-buttons get member? [ + nc-buttons get delete 4drop + ] [ + drop prepare-mouse send-button-up + ] if ; : make-TRACKMOUSEEVENT ( hWnd -- alien ) "TRACKMOUSEEVENT" [ set-TRACKMOUSEEVENT-hwndTrack ] keep @@ -307,44 +332,58 @@ M: windows-ui-backend (close-window) #! message sent if mouse leaves main application 4drop forget-rollover ; +SYMBOL: wm-handlers + +H{ } clone wm-handlers set-global + +: add-wm-handler ( quot wm -- ) + dup array? + [ [ execute add-wm-handler ] with each ] + [ wm-handlers get-global set-at ] if ; + +[ handle-wm-close 0 ] WM_CLOSE add-wm-handler +[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler + +[ handle-wm-size 0 ] WM_SIZE add-wm-handler +[ handle-wm-move 0 ] WM_MOVE add-wm-handler + +[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler +[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler +[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler + +[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler +[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler +[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler + +[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler +[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler +[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler +[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler +[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler +[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler + +[ 4dup handle-wm-ncbutton DefWindowProc ] +{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN +WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP } +add-wm-handler + +[ nc-buttons get-global delete-all DefWindowProc ] +{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler + +[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler +[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler +[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler +[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler + +SYMBOL: trace-messages? + ! return 0 if you handle the message, else just let DefWindowProc return its val : ui-wndproc ( -- object ) "uint" { "void*" "uint" "long" "long" } "stdcall" [ [ - pick ! global [ dup windows-message-name . ] bind - { - { [ dup WM_CLOSE = ] [ drop handle-wm-close 0 ] } - { [ dup WM_PAINT = ] - [ drop 4dup handle-wm-paint DefWindowProc ] } - { [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] } - { [ dup WM_MOVE = ] [ drop handle-wm-move 0 ] } - - ! Keyboard events - { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ] - [ drop 4dup handle-wm-keydown DefWindowProc ] } - { [ dup WM_CHAR = over WM_SYSCHAR = or ] - [ drop 4dup handle-wm-char DefWindowProc ] } - { [ dup WM_KEYUP = over WM_SYSKEYUP = or ] - [ drop 4dup handle-wm-keyup DefWindowProc ] } - - { [ dup WM_SYSCOMMAND = ] [ drop handle-wm-syscommand ] } - { [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] } - { [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] } - - ! Mouse events - { [ dup WM_LBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } - { [ dup WM_MBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } - { [ dup WM_RBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } - { [ dup WM_LBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } - { [ dup WM_MBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } - { [ dup WM_RBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } - { [ dup WM_MOUSEMOVE = ] [ drop handle-wm-mousemove 0 ] } - { [ dup WM_MOUSEWHEEL = ] [ drop handle-wm-mousewheel 0 ] } - { [ dup WM_CANCELMODE = ] [ drop handle-wm-cancelmode 0 ] } - { [ dup WM_MOUSELEAVE = ] [ drop handle-wm-mouseleave 0 ] } - - { [ t ] [ drop DefWindowProc ] } - } cond + pick + trace-messages? get-global [ dup windows-message-name . ] when + wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if ] ui-try ] alien-callback ; @@ -358,7 +397,6 @@ M: windows-ui-backend (close-window) { [ t ] [ dup TranslateMessage drop dup DispatchMessage drop - yield event-loop ] } } cond ; @@ -410,7 +448,8 @@ M: windows-ui-backend (close-window) SetFocus drop ; : init-win32-ui ( -- ) - "MSG" msg-obj set + V{ } clone nc-buttons set-global + "MSG" msg-obj set-global "Factor-window" malloc-u16-string class-name-ptr set-global register-wndclassex drop GetDoubleClickTime double-click-timeout set-global ; @@ -455,11 +494,11 @@ M: windows-ui-backend raise-window* ( world -- ) ] when* ; M: windows-ui-backend set-title ( string world -- ) - world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep + world-handle dup win-title [ free ] when* - >r malloc-u16-string dup r> - set-win-title alien-address - SendMessage drop ; + >r malloc-u16-string r> + 2dup set-win-title + win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ; M: windows-ui-backend ui [ diff --git a/extra/units/imperial/imperial-tests.factor b/extra/units/imperial/imperial-tests.factor index def13bd784..793fe5679d 100644 --- a/extra/units/imperial/imperial-tests.factor +++ b/extra/units/imperial/imperial-tests.factor @@ -1,5 +1,5 @@ USING: kernel math tools.test units.imperial inverse ; -IN: temporary +IN: units.imperial.tests [ 1 ] [ 12 inches [ feet ] undo ] unit-test [ 12 ] [ 1 feet [ inches ] undo ] unit-test diff --git a/extra/units/si/si-tests.factor b/extra/units/si/si-tests.factor index 85d2bd3317..9fb702f050 100644 --- a/extra/units/si/si-tests.factor +++ b/extra/units/si/si-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test units.si inverse math.constants math.functions units.imperial ; -IN: temporary +IN: units.si.tests [ t ] [ 1 m 100 cm = ] unit-test diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor index 28ab9ab7c4..81f3163a77 100644 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel math sequences tools.test units.si units.imperial units inverse math.functions ; -IN: temporary +IN: units.tests [ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test [ T{ dimensioned f 3 { m } { s } } ] [ 3 m/s ] unit-test diff --git a/extra/unix/stat/macosx/macosx.factor b/extra/unix/stat/macosx/macosx.factor index 1cb3994708..3741a22413 100644 --- a/extra/unix/stat/macosx/macosx.factor +++ b/extra/unix/stat/macosx/macosx.factor @@ -27,3 +27,7 @@ C-STRUCT: stat FUNCTION: int stat ( char* pathname, stat* buf ) ; FUNCTION: int lstat ( char* pathname, stat* buf ) ; + +: stat-st_atim stat-st_atimespec ; +: stat-st_mtim stat-st_mtimespec ; +: stat-st_ctim stat-st_ctimespec ; \ No newline at end of file diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index ca0736b6d4..204321f30c 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -1,5 +1,6 @@ -USING: kernel system combinators alien.syntax math vocabs.loader ; +USING: kernel system combinators alien.syntax alien.c-types + math io.unix.backend vocabs.loader ; IN: unix.stat @@ -55,11 +56,21 @@ FUNCTION: int fchmod ( int fd, mode_t mode ) ; FUNCTION: int mkdir ( char* path, mode_t mode ) ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +<< + os + { + { "linux" [ "unix.stat.linux" require ] } + { "macosx" [ "unix.stat.macosx" require ] } + [ drop ] + } + case +>> ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -{ - { [ linux? ] [ "unix.stat.linux" require ] } - { [ t ] [ ] } -} -cond +: check-status ( n -- ) io-error ; +: stat* ( pathname -- stat ) + "stat" dup >r + stat check-status + r> ; diff --git a/extra/unix/time/time.factor b/extra/unix/time/time.factor new file mode 100644 index 0000000000..460631d9ea --- /dev/null +++ b/extra/unix/time/time.factor @@ -0,0 +1,32 @@ + +USING: kernel alien.syntax alien.c-types math ; + +IN: unix.time + +TYPEDEF: uint time_t + +C-STRUCT: tm + { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) + { "int" "min" } ! Minutes: 0-59 + { "int" "hour" } ! Hours since midnight: 0-23 + { "int" "mday" } ! Day of the month: 1-31 + { "int" "mon" } ! Months *since* january: 0-11 + { "int" "year" } ! Years since 1900 + { "int" "wday" } ! Days since Sunday (0-6) + { "int" "yday" } ! Days since Jan. 1: 0-365 + { "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST, + { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?) + { "char*" "zone" } ; + +C-STRUCT: timespec + { "time_t" "sec" } + { "long" "nsec" } ; + +: make-timespec ( ms -- timespec ) + 1000 /mod 1000000 * + "timespec" + [ set-timespec-nsec ] keep + [ set-timespec-sec ] keep ; + +FUNCTION: time_t time ( time_t* t ) ; +FUNCTION: tm* localtime ( time_t* clock ) ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index f83120a96f..9cc8552f98 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -8,32 +8,8 @@ IN: unix TYPEDEF: uint in_addr_t TYPEDEF: uint socklen_t -TYPEDEF: uint time_t TYPEDEF: ulong size_t -C-STRUCT: tm - { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) - { "int" "min" } ! Minutes: 0-59 - { "int" "hour" } ! Hours since midnight: 0-23 - { "int" "mday" } ! Day of the month: 1-31 - { "int" "mon" } ! Months *since* january: 0-11 - { "int" "year" } ! Years since 1900 - { "int" "wday" } ! Days since Sunday (0-6) - { "int" "yday" } ! Days since Jan. 1: 0-365 - { "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST, - { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?) - { "char*" "zone" } ; - -C-STRUCT: timespec - { "time_t" "sec" } - { "long" "nsec" } ; - -: make-timespec ( ms -- timespec ) - 1000 /mod 1000000 * - "timespec" - [ set-timespec-nsec ] keep - [ set-timespec-sec ] keep ; - : PROT_NONE 0 ; inline : PROT_READ 1 ; inline : PROT_WRITE 2 ; inline @@ -89,7 +65,6 @@ FUNCTION: ushort htons ( ushort n ) ; FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ; FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ; FUNCTION: int listen ( int s, int backlog ) ; -FUNCTION: tm* localtime ( time_t* clock ) ; FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ; FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ; FUNCTION: int munmap ( void* addr, size_t len ) ; @@ -117,7 +92,6 @@ FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; FUNCTION: char* strerror ( int errno ) ; FUNCTION: int system ( char* command ) ; -FUNCTION: time_t time ( time_t* t ) ; FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor index 32a104687e..78e2339764 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/vocabs/monitor/monitor.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel -tools.browser namespaces continuations ; +tools.browser namespaces continuations vocabs.loader ; IN: vocabs.monitor ! Use file system change monitoring to flush the tags/authors @@ -9,7 +9,9 @@ IN: vocabs.monitor SYMBOL: vocab-monitor : monitor-thread ( -- ) - vocab-monitor get-global next-change 2drop reset-cache ; + vocab-monitor get-global + next-change 2drop + t sources-changed? set-global reset-cache ; : start-monitor-thread #! Silently ignore errors during monitor creation since diff --git a/extra/xml/tests/arithmetic.factor b/extra/xml/tests/arithmetic.factor index 371bf2d605..577ef5718c 100644 --- a/extra/xml/tests/arithmetic.factor +++ b/extra/xml/tests/arithmetic.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -IN: xml-arith +IN: xml.tests USING: xml io kernel math sequences strings xml.utilities tools.test math.parser ; PROCESS: calculate ( tag -- n ) diff --git a/extra/xml/tests/soap.factor b/extra/xml/tests/soap.factor index 8b7d17553b..775930025f 100755 --- a/extra/xml/tests/soap.factor +++ b/extra/xml/tests/soap.factor @@ -1,5 +1,5 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ; -IN: temporary +IN: xml.tests : assemble-data ( tag -- 3array ) { "URL" "snippet" "title" } diff --git a/extra/xml/tests/templating.factor b/extra/xml/tests/templating.factor index 2dd69ca99b..6db98ec848 100644 --- a/extra/xml/tests/templating.factor +++ b/extra/xml/tests/templating.factor @@ -1,5 +1,6 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces xml.data xml.utilities xml.writer generic sequences.deep ; +IN: xml.tests : sub-tag T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" } ; diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor index 871425559b..02c7aecb13 100644 --- a/extra/xml/tests/test.factor +++ b/extra/xml/tests/test.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -IN: temporary +IN: xml.tests USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities parser strings xml.data io.files xml.writer xml.utilities state-parser continuations assocs sequences.deep ; diff --git a/extra/xmode/catalog/catalog-tests.factor b/extra/xmode/catalog/catalog-tests.factor index d5420ed2e3..75e377bc97 100644 --- a/extra/xmode/catalog/catalog-tests.factor +++ b/extra/xmode/catalog/catalog-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: xmode.catalog.tests USING: xmode.catalog tools.test hashtables assocs kernel sequences io ; diff --git a/extra/xmode/keyword-map/keyword-map-tests.factor b/extra/xmode/keyword-map/keyword-map-tests.factor index 9fbe9110e8..b14bbd0f70 100644 --- a/extra/xmode/keyword-map/keyword-map-tests.factor +++ b/extra/xmode/keyword-map/keyword-map-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: xmode.keyword-map.tests USING: xmode.keyword-map xmode.tokens tools.test namespaces assocs kernel strings ; diff --git a/extra/xmode/marker/marker-tests.factor b/extra/xmode/marker/marker-tests.factor index 6bcba91c84..1d059852e2 100755 --- a/extra/xmode/marker/marker-tests.factor +++ b/extra/xmode/marker/marker-tests.factor @@ -1,6 +1,6 @@ USING: xmode.tokens xmode.catalog xmode.marker tools.test kernel ; -IN: temporary +IN: xmode.marker.tests [ { diff --git a/extra/xmode/rules/rules-tests.factor b/extra/xmode/rules/rules-tests.factor index 404dbb89fb..5fc62f39e9 100644 --- a/extra/xmode/rules/rules-tests.factor +++ b/extra/xmode/rules/rules-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: xmode.rules.tests USING: xmode.rules tools.test ; [ { 1 2 3 } ] [ f { 1 2 3 } ?push-all ] unit-test diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor index 713700bf7a..bbb19a7555 100755 --- a/extra/xmode/utilities/utilities-tests.factor +++ b/extra/xmode/utilities/utilities-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: xmode.utilities.tests USING: xmode.utilities tools.test xml xml.data kernel strings vectors sequences io.files prettyprint assocs unicode.case ;