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/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 7d01fb2b00..a67c7f4fb9 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: bit-arrays byte-arrays float-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations -system compiler.units ; +system compiler.units io.files io.encodings.binary ; IN: alien.c-types DEFER: @@ -273,6 +273,9 @@ M: long-long-type box-return ( type -- ) r> add* ] when ; +: malloc-file-contents ( path -- alien ) + binary file-contents >byte-array malloc-byte-array ; + [ [ alien-cell ] [ set-alien-cell ] 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/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 35dae109cf..241511c00d 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts splitting growable classes tuples words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger float-arrays quotations.private -sequences.private combinators ; +sequences.private combinators io.encodings.binary ; IN: bootstrap.image : my-arch ( -- arch ) @@ -416,7 +416,7 @@ M: curry ' "Writing image to " write architecture get boot-image-name resource-path dup write "..." print flush - [ (write-image) ] with-file-writer ; + binary [ (write-image) ] with-stream ; PRIVATE> diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f3f233ea0b..ab0e1cebe0 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -623,6 +623,7 @@ builtins get num-tags get tail f union-class define-class { "fopen" "io.streams.c" } { "fgetc" "io.streams.c" } { "fread" "io.streams.c" } + { "fputc" "io.streams.c" } { "fwrite" "io.streams.c" } { "fflush" "io.streams.c" } { "fclose" "io.streams.c" } 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..640439312d 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 @@ -56,13 +56,13 @@ UNION: c a b ; [ t ] [ \ c \ tuple class< ] unit-test [ f ] [ \ tuple \ c class< ] unit-test -DEFER: bah -FORGET: bah +! DEFER: bah +! FORGET: bah 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-docs.factor b/core/generic/generic-docs.factor index 631aa7e62d..b2fba47d3a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -116,16 +116,18 @@ HELP: method-spec { $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." } { $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ; +HELP: method-body +{ $class-description "The class of method bodies, which are words with special word properties set." } ; + HELP: method -{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } } -{ $description "Looks up a method definition." } -{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ; +{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } +{ $description "Looks up a method definition." } ; { method define-method POSTPONE: M: } related-words HELP: { $values { "def" "a quotation" } { "method" "a new method definition" } } -{ $description "Creates a new "{ $link method } " instance." } ; +{ $description "Creates a new method." } ; HELP: methods { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } 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/generic/generic.factor b/core/generic/generic.factor index 35cc471033..f73579661d 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -25,16 +25,12 @@ GENERIC: make-default-method ( generic combination -- method ) PREDICATE: word generic "combination" word-prop >boolean ; -M: generic definer drop f f ; - M: generic definition drop f ; : make-generic ( word -- ) dup { "unannotated-def" } reset-props dup dup "combination" word-prop perform-combination define ; -TUPLE: method word def specializer generic loc ; - : method ( class generic -- method/f ) "methods" word-prop at ; @@ -47,7 +43,7 @@ PREDICATE: pair method-spec : methods ( word -- assoc ) "methods" word-prop [ keys sort-classes ] keep - [ dupd at method-word ] curry { } map>assoc ; + [ dupd at ] curry { } map>assoc ; TUPLE: check-method class generic ; @@ -63,29 +59,33 @@ TUPLE: check-method class generic ; : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; -: make-method-def ( quot word combination -- quot ) +: make-method-def ( quot class generic -- quot ) "combination" word-prop method-prologue swap append ; -PREDICATE: word method-body "method" word-prop >boolean ; +PREDICATE: word method-body "method-def" word-prop >boolean ; M: method-body stack-effect - "method" word-prop method-generic stack-effect ; + "method-generic" word-prop stack-effect ; -: ( quot class generic -- word ) - [ make-method-def ] 2keep - method-word-name f - dup rot define - dup xref ; +: method-word-props ( quot class generic -- assoc ) + [ + "method-generic" set + "method-class" set + "method-def" set + ] H{ } make-assoc ; -: ( quot class generic -- method ) +: ( quot class generic -- word ) check-method - [ ] 3keep f \ method construct-boa - dup method-word over "method" set-word-prop ; + [ make-method-def ] 3keep + [ method-word-props ] 2keep + method-word-name f + tuck set-word-props + dup rot define ; : redefine-method ( quot class generic -- ) - [ method set-method-def ] 3keep + [ method swap "method-def" set-word-prop ] 3keep [ make-method-def ] 2keep - method method-word swap define ; + method swap define ; : define-method ( quot class generic -- ) >r bootstrap-word r> @@ -102,21 +102,22 @@ M: method-body stack-effect ! Definition protocol M: method-spec where - dup first2 method [ method-word ] [ second ] ?if where ; + dup first2 method [ ] [ second ] ?if where ; M: method-spec set-where - first2 method method-word set-where ; + first2 method set-where ; M: method-spec definer drop \ M: \ ; ; M: method-spec definition - first2 method dup [ method-def ] when ; + first2 method dup + [ "method-def" word-prop ] when ; : forget-method ( class generic -- ) check-method [ delete-at* ] with-methods - [ method-word forget-word ] [ drop ] if ; + [ forget-word ] [ drop ] if ; M: method-spec forget* first2 forget-method ; @@ -125,11 +126,11 @@ M: method-body definer drop \ M: \ ; ; M: method-body definition - "method" word-prop method-def ; + "method-def" word-prop ; M: method-body forget* - "method" word-prop - { method-specializer method-generic } get-slots + dup "method-class" word-prop + swap "method-generic" word-prop forget-method ; : implementors* ( classes -- words ) @@ -168,8 +169,7 @@ M: word subwords drop f ; M: generic subwords dup "methods" word-prop values - swap "default-method" word-prop add - [ method-word ] map ; + swap "default-method" word-prop add ; M: generic forget-word dup subwords [ forget-word ] each (forget-word) ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 0b2b9fcca3..27b0ddb7a2 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ; : applicable-method ( generic class -- quot ) over method - [ method-word word-def ] + [ word-def ] [ default-math-method ] ?if ; : object-method ( generic -- quot ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 230ec446c7..313f487c99 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -69,7 +69,7 @@ TUPLE: no-method object generic ; ] if ; : default-method ( word -- pair ) - "default-method" word-prop method-word + "default-method" word-prop object bootstrap-word swap 2array ; : method-alist>quot ( alist base-class -- quot ) 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/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 359bedd041..7d8c6f0b5f 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private slots.private math assocs -math.private sequences sequences.private vectors ; + math.private sequences sequences.private vectors ; IN: hashtables heap-pop ] must-fail [ heap-pop ] must-fail diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cadf326692..2a2e6995eb 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -10,8 +10,7 @@ IN: inference.backend recursive-state get at ; : inline? ( word -- ? ) - dup "method" word-prop - [ method-generic inline? ] [ "inline" word-prop ] ?if ; + dup "method-generic" word-prop swap or "inline" word-prop ; : local-recursive-state ( -- assoc ) recursive-state get dup keys 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/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 8e8251ff62..5e150e66b7 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -538,6 +538,8 @@ set-primitive-effect \ fwrite { string alien } { } set-primitive-effect +\ fputc { object alien } { } set-primitive-effect + \ fread { integer string } { object } set-primitive-effect \ fflush { alien } { } set-primitive-effect 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/backend/backend.factor b/core/io/backend/backend.factor index c38b7355b1..1595ecd576 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,13 +1,17 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init kernel system namespaces ; +USING: init kernel system namespaces io io.encodings io.encodings.utf8 ; IN: io.backend SYMBOL: io-backend HOOK: init-io io-backend ( -- ) -HOOK: init-stdio io-backend ( -- ) +HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ) + +: init-stdio ( -- ) + (init-stdio) utf8 stderr set-global + utf8 stdio set-global ; HOOK: io-multiplex io-backend ( ms -- ) @@ -19,7 +23,7 @@ HOOK: normalize-pathname io-backend ( str -- newstr ) M: object normalize-pathname ; -: set-io-backend ( backend -- ) +: set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio ; [ init-io embedded? [ init-stdio ] unless ] 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/binary/binary.factor b/core/io/binary/binary.factor old mode 100644 new mode 100755 index c4d3abefce..9f6231b643 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -10,7 +10,7 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- str ) [ nth-byte ] with "" map-as ; +: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ; : >be ( x n -- str ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) diff --git a/core/io/encodings/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor index f8be5054df..823eea67be 100644 --- a/core/io/encodings/binary/binary-docs.factor +++ b/core/io/encodings/binary/binary-docs.factor @@ -2,4 +2,4 @@ USING: help.syntax help.markup ; IN: io.encodings.binary HELP: binary -{ $class-description "This is the encoding descriptor for binary I/O." } ; +{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ; diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor index c4c6237715..b8bcc0f87a 100644 --- a/core/io/encodings/binary/binary.factor +++ b/core/io/encodings/binary/binary.factor @@ -1,3 +1,3 @@ -USING: kernel io.encodings ; - -TUPLE: binary ; +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +IN: io.encodings.binary SYMBOL: binary diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor new file mode 100644 index 0000000000..e5e71b05f0 --- /dev/null +++ b/core/io/encodings/encodings-docs.factor @@ -0,0 +1,68 @@ +USING: help.markup help.syntax ; +IN: io.encodings + +ABOUT: "encodings" + +ARTICLE: "io.encodings" "I/O encodings" +"Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream." +{ $subsection "encodings-constructors" } +{ $subsection "encodings-descriptors" } +{ $subsection "encodings-protocol" } ; + +ARTICLE: "encodings-constructors" "Constructing an encoded stream" +{ $subsection } +{ $subsection } +{ $subsection } ; + +HELP: ( stream encoding -- newstream ) +{ $values { "stream" "an output stream" } + { "encoding" "an encoding descriptor" } + { "newstream" "an encoded output stream" } } +{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ; + +HELP: ( stream encoding -- newstream ) +{ $values { "stream" "an input stream" } + { "encoding" "an encoding descriptor" } + { "newstream" "an encoded output stream" } } +{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ; + +HELP: ( stream-in stream-out encoding -- duplex ) +{ $values { "stream-in" "an input stream" } + { "stream-out" "an output stream" } + { "encoding" "an encoding descriptor" } + { "duplex" "an encoded duplex stream" } } +{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ; + +{ } related-words + +ARTICLE: "encodings-descriptors" "Encoding descriptors" +"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" +$nl { $vocab-link "io.encodings.utf8" } +$nl { $vocab-link "io.encodings.ascii" } +$nl { $vocab-link "io.encodings.binary" } +$nl { $vocab-link "io.encodings.utf16" } ; + +ARTICLE: "encodings-protocol" "Encoding protocol" +"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again." +{ $subsection decode-step } +{ $subsection init-decoder } +{ $subsection stream-write-encoded } ; + +HELP: decode-step ( buf char encoding -- ) +{ $values { "buf" "A string buffer which characters can be pushed to" } + { "char" "An octet which is read from a stream" } + { "encoding" "An encoding descriptor tuple" } } +{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ; + +HELP: stream-write-encoded ( string stream encoding -- ) +{ $values { "string" "a string" } + { "stream" "an output stream" } + { "encoding" "an encoding descriptor" } } +{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ; + +HELP: init-decoder ( stream encoding -- encoding ) +{ $values { "stream" "an input stream" } + { "encoding" "an encoding descriptor" } } +{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ; + +{ init-decoder decode-step stream-write-encoded } related-words diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/encodings/encodings-tests.factor similarity index 86% rename from core/io/streams/lines/lines-tests.factor rename to core/io/encodings/encodings-tests.factor index 64dc7bff3b..73d2efa7d4 100755 --- a/core/io/streams/lines/lines-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -1,9 +1,9 @@ -USING: io.streams.lines io.files io.streams.string io -tools.test kernel ; -IN: temporary +USING: io.files io.streams.string io +tools.test kernel io.encodings.ascii ; +IN: io.streams.encodings.tests : ( resource -- stream ) - resource-path ; + resource-path ascii ; [ { } ] [ "/core/io/test/empty-file.txt" lines ] diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 2d94e3ea80..2f68334bde 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,13 +1,24 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain -namespaces unicode growable strings io classes io.streams.c -continuations ; +USING: math kernel sequences sbufs vectors namespaces +growable strings io classes continuations combinators +io.styles io.streams.plain io.encodings.binary splitting +io.streams.duplex byte-arrays ; IN: io.encodings -TUPLE: encode-error ; +! The encoding descriptor protocol -: encode-error ( -- * ) \ encode-error construct-empty throw ; +GENERIC: decode-step ( buf char encoding -- ) +M: object decode-step drop swap push ; + +GENERIC: init-decoder ( stream encoding -- encoding ) +M: tuple-class init-decoder construct-empty init-decoder ; +M: object init-decoder nip ; + +GENERIC: stream-write-encoded ( string stream encoding -- byte-array ) +M: object stream-write-encoded drop stream-write ; + +! Decoding TUPLE: decode-error ; @@ -15,24 +26,12 @@ TUPLE: decode-error ; SYMBOL: begin -: decoded ( buf ch -- buf ch state ) +: push-decoded ( buf ch -- buf ch state ) over push 0 begin ; : push-replacement ( buf -- buf ch state ) - CHAR: replacement-character decoded ; - -: finish-decoding ( buf ch state -- str ) - begin eq? [ decode-error ] unless drop "" like ; - -: start-decoding ( seq length -- buf ch state seq ) - 0 begin roll ; - -GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) - -: decode ( seq quot -- string ) - >r dup length start-decoding r> - [ -rot ] swap compose each - finish-decoding ; inline + ! This is the replacement character + HEX: fffd push-decoded ; : space ( resizable -- room-left ) dup underlying swap [ length ] 2apply - ; @@ -42,54 +41,113 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) : end-read-loop ( buf ch state stream quot -- string/f ) 2drop 2drop >string f like ; -: decode-read-loop ( buf ch state stream encoding -- string/f ) - >r >r pick r> r> rot full? [ end-read-loop ] [ +: decode-read-loop ( buf stream encoding -- string/f ) + pick full? [ 2drop >string ] [ over stream-read1 [ - -rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop - ] [ end-read-loop ] if* + -rot tuck >r >r >r dupd r> decode-step r> r> + decode-read-loop + ] [ 2drop >string f like ] if* ] if ; : decode-read ( length stream encoding -- string ) - >r swap start-decoding r> - decode-read-loop ; + rot -rot decode-read-loop ; -: ( stream decoding-class -- decoded-stream ) - construct-delegate ; +TUPLE: decoder code cr ; +: ( stream encoding -- newstream ) + dup binary eq? [ drop ] [ + dupd init-decoder { set-delegate set-decoder-code } + decoder construct + ] if ; -: ( stream encoding-class -- encoded-stream ) - construct-delegate ; +: cr+ t swap set-decoder-cr ; inline -GENERIC: encode-string ( string encoding -- byte-array ) -M: tuple-class encode-string construct-empty encode-string ; +: cr- f swap set-decoder-cr ; inline -MIXIN: encoding-stream +: line-ends/eof ( stream str -- str ) f like swap cr- ; inline -M: encoding-stream stream-read1 1 swap stream-read ; +: line-ends\r ( stream str -- str ) swap cr+ ; inline -M: encoding-stream stream-read - [ delegate ] keep decode-read ; +: line-ends\n ( stream str -- str ) + over decoder-cr over empty? and + [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline -M: encoding-stream stream-read-partial stream-read ; +: handle-readln ( stream str ch -- str ) + { + { f [ line-ends/eof ] } + { CHAR: \r [ line-ends\r ] } + { CHAR: \n [ line-ends\n ] } + } case ; -M: encoding-stream stream-read-until +: fix-read ( stream string -- string ) + over decoder-cr [ + over cr- + "\n" ?head [ + swap stream-read1 [ add ] when* + ] [ nip ] if + ] [ nip ] if ; + +M: decoder stream-read + tuck { delegate decoder-code } get-slots decode-read fix-read ; + +M: decoder stream-read-partial stream-read ; + +: decoder-read-until ( stream delim -- ch ) ! Copied from { c-reader stream-read-until }!!! - [ swap read-until-loop ] "" make + over stream-read1 dup [ + dup pick memq? [ 2nip ] [ , decoder-read-until ] if + ] [ + 2nip + ] if ; + +M: decoder stream-read-until + ! Copied from { c-reader stream-read-until }!!! + [ swap decoder-read-until ] "" make swap over empty? over not and [ 2drop f f ] when ; -M: encoding-stream stream-write1 +: fix-read1 ( stream char -- char ) + over decoder-cr [ + over cr- + dup CHAR: \n = [ + drop stream-read1 + ] [ nip ] if + ] [ nip ] if ; + +M: decoder stream-read1 + 1 swap stream-read f like [ first ] [ f ] if* ; + +M: decoder stream-readln ( stream -- str ) + "\r\n" over stream-read-until handle-readln ; + +! Encoding + +TUPLE: encode-error ; + +: encode-error ( -- * ) \ encode-error construct-empty throw ; + +TUPLE: encoder code ; +: ( stream encoding -- newstream ) + dup binary eq? [ drop ] [ + construct-empty { set-delegate set-encoder-code } + encoder construct + ] if ; + +M: encoder stream-write1 >r 1string r> stream-write ; -M: encoding-stream stream-write - [ encode-string ] keep delegate stream-write ; +M: encoder stream-write + { delegate encoder-code } get-slots stream-write-encoded ; -M: encoding-stream dispose delegate dispose ; +M: encoder dispose delegate dispose ; -GENERIC: underlying-stream ( encoded-stream -- delegate ) -M: encoding-stream underlying-stream delegate ; +INSTANCE: encoder plain-writer -GENERIC: set-underlying-stream ( new-underlying stream -- ) -M: encoding-stream set-underlying-stream set-delegate ; +! Rebinding duplex streams which have not read anything yet -: set-encoding ( encoding stream -- ) ! This doesn't work now - [ underlying-stream swap construct-delegate ] keep - set-underlying-stream ; +: reencode ( stream encoding -- newstream ) + over encoder? [ >r delegate r> ] when ; + +: redecode ( stream encoding -- newstream ) + over decoder? [ >r delegate r> ] when ; + +: ( stream-in stream-out encoding -- duplex ) + tuck reencode >r redecode r> ; diff --git a/core/io/encodings/latin1/latin1.factor b/core/io/encodings/latin1/latin1.factor deleted file mode 100755 index e6d6281eb6..0000000000 --- a/core/io/encodings/latin1/latin1.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: io io.encodings strings kernel ; -IN: io.encodings.latin1 - -TUPLE: latin1 ; - -M: latin1 stream-read delegate stream-read >string ; - -M: latin1 stream-read-until delegate stream-read-until >string ; - -M: latin1 stream-read-partial delegate stream-read-partial >string ; diff --git a/core/io/encodings/latin1/authors.txt b/core/io/encodings/string/authors.txt similarity index 100% rename from core/io/encodings/latin1/authors.txt rename to core/io/encodings/string/authors.txt diff --git a/core/io/encodings/string/string-docs.factor b/core/io/encodings/string/string-docs.factor new file mode 100644 index 0000000000..0a35eee272 --- /dev/null +++ b/core/io/encodings/string/string-docs.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax byte-arrays strings ; +IN: io.encodings.string + +ARTICLE: "io.encodings.string" "Encoding and decoding strings" +"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:" +{ $subsection encode } +{ $subsection decode } ; + +HELP: decode +{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" } + { "string" string } } +{ $description "Decodes the byte array using the given encoding, outputting a string" } ; + +HELP: encode +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } +{ $description "Encodes the given string into a byte array with the given encoding." } ; diff --git a/core/io/encodings/string/string-tests.factor b/core/io/encodings/string/string-tests.factor new file mode 100644 index 0000000000..ddae9c8734 --- /dev/null +++ b/core/io/encodings/string/string-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: strings io.encodings.utf8 io.encodings.utf16 +io.encodings.string tools.test ; +IN: io.encodings.string.tests + +[ "hello" ] [ "hello" utf8 decode ] unit-test +[ "he" ] [ "\0h\0e" utf16be decode ] unit-test + +[ "hello" ] [ "hello" utf8 encode >string ] unit-test +[ "\0h\0e" ] [ "he" utf16be encode >string ] unit-test diff --git a/core/io/encodings/string/string.factor b/core/io/encodings/string/string.factor new file mode 100644 index 0000000000..5e57a943a9 --- /dev/null +++ b/core/io/encodings/string/string.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.streams.byte-array ; +IN: io.encodings.string + +: decode ( byte-array encoding -- string ) + contents ; + +: encode ( string encoding -- byte-array ) + [ write ] with-byte-writer ; diff --git a/core/io/encodings/string/summary.txt b/core/io/encodings/string/summary.txt new file mode 100644 index 0000000000..59b8927dea --- /dev/null +++ b/core/io/encodings/string/summary.txt @@ -0,0 +1 @@ +Encoding and decoding strings diff --git a/core/io/encodings/latin1/tags.txt b/core/io/encodings/string/tags.factor similarity index 100% rename from core/io/encodings/latin1/tags.txt rename to core/io/encodings/string/tags.factor diff --git a/core/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor deleted file mode 100644 index c49c030ef3..0000000000 --- a/core/io/encodings/utf16/utf16-docs.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: help.markup help.syntax io.encodings strings ; -IN: io.encodings.utf16 - -ARTICLE: "io.utf16" "Working with UTF16-encoded data" -"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences." -{ $subsection encode-utf16le } -{ $subsection encode-utf16be } -{ $subsection decode-utf16le } -{ $subsection decode-utf16be } -"Support for UTF16 data with a byte order mark:" -{ $subsection encode-utf16 } -{ $subsection decode-utf16 } ; - -ABOUT: "io.utf16" - -HELP: decode-utf16 -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in UTF16 format. The bytes must begin with a UTF16 byte order mark, which determines if the input is in little or big endian. To decode data without a byte order mark, use " { $link decode-utf16le } " or " { $link decode-utf16be } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -HELP: decode-utf16be -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in big endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -HELP: decode-utf16le -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in little endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -{ decode-utf16 decode-utf16le decode-utf16be } related-words - -HELP: encode-utf16be -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in big endian UTF16 format." } ; - -HELP: encode-utf16le -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in little endian UTF16 format." } ; - -HELP: encode-utf16 -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in UTF16 format with a byte order mark." } ; - -{ encode-utf16 encode-utf16be encode-utf16le } related-words diff --git a/core/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor deleted file mode 100755 index 041c486915..0000000000 --- a/core/io/encodings/utf16/utf16-tests.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings -io unicode ; - -: decode-w/stream ( array encoding -- newarray ) - >r >sbuf dup reverse-here r> contents >array ; - -: encode-w/stream ( array encoding -- newarray ) - >r SBUF" " clone tuck r> stream-write >array ; - -[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode-w/stream ] unit-test - -[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode-w/stream ] unit-test - -[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode-w/stream ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode-w/stream ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test - -[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode-w/stream ] unit-test - -[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode-w/stream ] unit-test -[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode-w/stream ] unit-test - -[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode-w/stream ] unit-test diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor index 6e1923824f..dbbc193a02 100755 --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -1,18 +1,11 @@ -USING: help.markup help.syntax io.encodings strings ; +USING: help.markup help.syntax io.encodings strings io.files ; IN: io.encodings.utf8 ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data" -"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." -{ $subsection encode-utf8 } -{ $subsection decode-utf8 } ; +"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences. The encoding descriptor for UTF-8:" +{ $subsection utf8 } ; + +HELP: utf8 +{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. This conforms to the " { $link "encodings-protocol" } "." } ; ABOUT: "io.encodings.utf8" - -HELP: decode-utf8 -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in UTF8 format." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -HELP: encode-utf8 -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in UTF8 format." } ; diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index 44d0870385..8f1c998f3d 100644 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,21 +1,20 @@ -USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings -sequences strings arrays unicode ; +USING: io.encodings.utf8 tools.test io.encodings.string strings arrays ; : decode-utf8-w/stream ( array -- newarray ) - >sbuf dup reverse-here utf8 contents ; + utf8 decode >array ; : encode-utf8-w/stream ( array -- newarray ) - SBUF" " clone tuck utf8 stream-write >array ; + utf8 encode >array ; -[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test -[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test +[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream ] unit-test [ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test [ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream ] unit-test [ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 6a3a8b8ec7..5887a8375e 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -1,11 +1,13 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors growable io continuations -namespaces io.encodings combinators strings io.streams.c ; +namespaces io.encodings combinators strings ; IN: io.encodings.utf8 ! Decoding UTF-8 +TUPLE: utf8 ch state ; + SYMBOL: double SYMBOL: triple SYMBOL: triple2 @@ -23,7 +25,7 @@ SYMBOL: quad3 : begin-utf8 ( buf byte -- buf ch state ) { - { [ dup -7 shift zero? ] [ decoded ] } + { [ dup -7 shift zero? ] [ push-decoded ] } { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] } { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] } { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] } @@ -31,7 +33,7 @@ SYMBOL: quad3 } cond ; : end-multibyte ( buf byte ch -- buf ch state ) - f append-nums [ decoded ] unless* ; + f append-nums [ push-decoded ] unless* ; : decode-utf8-step ( buf byte ch state -- buf ch state ) { @@ -44,42 +46,42 @@ SYMBOL: quad3 { quad3 [ end-multibyte ] } } case ; -: decode-utf8 ( seq -- str ) - [ decode-utf8-step ] decode ; +: unpack-state ( encoding -- ch state ) + { utf8-ch utf8-state } get-slots ; + +: pack-state ( ch state encoding -- ) + { set-utf8-ch set-utf8-state } set-slots ; + +M: utf8 decode-step ( buf char encoding -- ) + [ unpack-state decode-utf8-step ] keep pack-state drop ; + +M: utf8 init-decoder nip begin over set-utf8-state ; ! Encoding UTF-8 : encoded ( char -- ) - BIN: 111111 bitand BIN: 10000000 bitor , ; + BIN: 111111 bitand BIN: 10000000 bitor write1 ; : char>utf8 ( char -- ) { - { [ dup -7 shift zero? ] [ , ] } + { [ dup -7 shift zero? ] [ write1 ] } { [ dup -11 shift zero? ] [ - dup -6 shift BIN: 11000000 bitor , + dup -6 shift BIN: 11000000 bitor write1 encoded ] } { [ dup -16 shift zero? ] [ - dup -12 shift BIN: 11100000 bitor , + dup -12 shift BIN: 11100000 bitor write1 dup -6 shift encoded encoded ] } { [ t ] [ - dup -18 shift BIN: 11110000 bitor , + dup -18 shift BIN: 11110000 bitor write1 dup -12 shift encoded dup -6 shift encoded encoded ] } } cond ; -: encode-utf8 ( str -- seq ) - [ [ char>utf8 ] each ] B{ } make ; - -! Interface for streams - -TUPLE: utf8 ; -INSTANCE: utf8 encoding-stream - -M: utf8 encode-string drop encode-utf8 ; -M: utf8 decode-step drop decode-utf8-step ; -! In the future, this should detect and ignore a BOM at the beginning +M: utf8 stream-write-encoded + ! For efficiency, this should be modified to avoid variable reads + drop [ [ char>utf8 ] each ] with-stream* ; diff --git a/core/io/files/authors.txt b/core/io/files/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/core/io/files/authors.txt +++ b/core/io/files/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index b8cf747106..9609cd123b 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -10,7 +10,9 @@ ARTICLE: "file-streams" "Reading and writing files" "Utility combinators:" { $subsection with-file-reader } { $subsection with-file-writer } -{ $subsection with-file-appender } ; +{ $subsection with-file-appender } +{ $subsection file-contents } +{ $subsection file-lines } ; ARTICLE: "pathnames" "Pathname manipulation" "Pathname manipulation:" @@ -57,8 +59,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 +70,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,7 +89,6 @@ ARTICLE: "io.files" "Basic file operations" { $subsection "fs-meta" } { $subsection "directories" } { $subsection "delete-move-copy" } -{ $subsection "unique" } { $see-also "os" } ; ABOUT: "io.files" @@ -114,33 +115,44 @@ HELP: file-name } ; HELP: -{ $values { "path" "a pathname string" } { "stream" "an input stream" } } -{ $description "Outputs an input stream for reading from the specified pathname." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptors" } + { "stream" "an input stream" } } +{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." } { $errors "Throws an error if the file is unreadable." } ; HELP: -{ $values { "path" "a pathname string" } { "stream" "an output stream" } } -{ $description "Outputs an output stream for writing to the specified pathname. The file's length is truncated to zero." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } +{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: -{ $values { "path" "a pathname string" } { "stream" "an output stream" } } -{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } +{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-reader -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } { $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } { $errors "Throws an error if the file is unreadable." } ; HELP: with-file-writer -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } -{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } +{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-stream } "." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-appender -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } -{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } +{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: file-lines +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } } +{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: file-contents +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } } +{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: cwd @@ -267,12 +279,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." } ; @@ -283,12 +295,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." } ; @@ -299,12 +311,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..e7f7f4f777 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,34 +1,34 @@ -IN: temporary -USING: tools.test io.files io threads kernel continuations ; +IN: io.files.tests +USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ - "test-foo.txt" temp-file [ + "test-foo.txt" temp-file ascii [ "Hello world." print ] with-file-writer ] unit-test [ ] [ - "test-foo.txt" temp-file [ + "test-foo.txt" temp-file ascii [ "Hello appender." print - ] with-stream + ] with-file-appender ] unit-test [ ] [ - "test-bar.txt" temp-file [ + "test-bar.txt" temp-file ascii [ "Hello appender." print - ] with-stream + ] with-file-appender ] unit-test [ "Hello world.\nHello appender.\n" ] [ - "test-foo.txt" temp-file file-contents + "test-foo.txt" temp-file ascii file-contents ] unit-test [ "Hello appender.\n" ] [ - "test-bar.txt" temp-file file-contents + "test-bar.txt" temp-file ascii file-contents ] unit-test [ ] [ "test-foo.txt" temp-file delete-file ] unit-test @@ -42,7 +42,7 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "test-blah" temp-file make-directory ] unit-test [ ] [ - "test-blah/fooz" temp-file dispose + "test-blah/fooz" temp-file ascii dispose ] unit-test [ t ] [ @@ -55,11 +55,11 @@ USING: tools.test io.files io threads kernel continuations ; [ f ] [ "test-blah" temp-file exists? ] unit-test -[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test [ ] [ "test-quux.txt" temp-file delete-file ] unit-test -[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test [ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test [ t ] [ "quux-test.txt" temp-file exists? ] unit-test @@ -70,7 +70,7 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "delete-tree-test/a/b/c/d" temp-file - [ "Hi" print ] with-file-writer + ascii [ "Hi" print ] with-file-writer ] unit-test [ ] [ @@ -83,7 +83,7 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "copy-tree-test/a/b/c/d" temp-file - [ "Foobar" write ] with-file-writer + ascii [ "Foobar" write ] with-file-writer ] unit-test [ ] [ @@ -92,7 +92,7 @@ USING: tools.test io.files io threads kernel continuations ; ] unit-test [ "Foobar" ] [ - "copy-destination/a/b/c/d" temp-file file-contents + "copy-destination/a/b/c/d" temp-file ascii file-contents ] unit-test [ ] [ @@ -101,19 +101,19 @@ 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" ] [ - "copy-destination/copy-tree-test/a/b/c/d" temp-file file-contents + "copy-destination/copy-tree-test/a/b/c/d" temp-file ascii file-contents ] 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" ] [ - "d" temp-file file-contents + "d" temp-file ascii file-contents ] unit-test [ ] [ "d" temp-file delete-file ] unit-test @@ -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 e20437fa85..f740d1dc21 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,11 +1,28 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions -system combinators splitting sbufs continuations ; - +system combinators splitting sbufs continuations io.encodings +io.encodings.binary ; IN: io.files +HOOK: (file-reader) io-backend ( path -- stream ) + +HOOK: (file-writer) io-backend ( path -- stream ) + +HOOK: (file-appender) io-backend ( path -- stream ) + +: ( path encoding -- stream ) + swap (file-reader) swap ; + +: ( path encoding -- stream ) + swap (file-writer) swap ; + +: ( path encoding -- stream ) + swap (file-appender) swap ; + +HOOK: rename-file io-backend ( from to -- ) + ! Pathnames : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; @@ -54,6 +71,7 @@ TUPLE: no-parent-directory path ; TUPLE: file-info type size permissions modified ; HOOK: file-info io-backend ( path -- info ) +HOOK: link-info io-backend ( path -- info ) SYMBOL: +regular-file+ SYMBOL: +directory+ @@ -84,7 +102,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 -- ) @@ -137,37 +155,45 @@ 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 -- ) +M: object copy-file + dup parent-directory make-directories + binary [ + swap binary [ + swap stream-copy + ] with-disposal + ] with-disposal ; + +: 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 ) @@ -180,6 +206,28 @@ DEFER: copy-tree-to : resource-exists? ( path -- ? ) ?resource-path exists? ; +! Pathname presentations +TUPLE: pathname string ; + +C: pathname + +M: pathname <=> [ pathname-string ] compare ; + +: file-lines ( path encoding -- seq ) lines ; + +: file-contents ( path encoding -- str ) + dupd swap file-length + [ stream-copy ] keep >string ; + +: with-file-reader ( path encoding quot -- ) + >r r> with-stream ; inline + +: with-file-writer ( path encoding quot -- ) + >r r> with-stream ; inline + +: with-file-appender ( path encoding quot -- ) + >r r> with-stream ; inline + : temp-directory ( -- path ) "temp" resource-path dup exists? not @@ -188,39 +236,10 @@ DEFER: copy-tree-to : temp-file ( name -- path ) temp-directory swap path+ ; -! Pathname presentations -TUPLE: pathname string ; - -C: pathname - -M: pathname <=> [ pathname-string ] compare ; - -! Streams -HOOK: io-backend ( path -- stream ) - -HOOK: io-backend ( path -- stream ) - -HOOK: io-backend ( path -- stream ) - -: file-lines ( path -- seq ) lines ; - -: file-contents ( path -- str ) - dup swap file-length - [ stream-copy ] keep >string ; - -: with-file-reader ( path quot -- ) - >r r> with-stream ; inline - -: with-file-writer ( path quot -- ) - >r r> with-stream ; inline - -: with-file-appender ( path quot -- ) - >r r> with-stream ; inline - ! Home directory : home ( -- dir ) { { [ 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-docs.factor b/core/io/io-docs.factor index 0986196e8d..fd40950e62 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -100,7 +100,7 @@ $nl { $subsection "stream-protocol" } { $subsection "stdio" } { $subsection "stream-utils" } -{ $see-also "io.streams.string" "io.streams.lines" "io.streams.plain" "io.streams.duplex" } ; +{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ; ABOUT: "streams" diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor old mode 100644 new mode 100755 index 23686abab5..22c942d2d9 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,14 +1,15 @@ USING: arrays io io.files kernel math parser strings system -tools.test words namespaces ; -IN: temporary +tools.test words namespaces io.encodings.latin1 +io.encodings.binary ; +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 ) - resource-path ; + resource-path latin1 ; [ "This is a line.\rThis is another line.\r" @@ -31,10 +32,10 @@ IN: temporary ! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test -[ "" ] [ +[ "/core/io/test/binary.txt" [ 0.2 read ] with-stream -] unit-test +] must-fail [ { @@ -53,7 +54,7 @@ IN: temporary ] unit-test [ ] [ - image [ + image binary [ 10 [ 65536 read drop ] times ] with-file-reader ] unit-test diff --git a/core/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor new file mode 100644 index 0000000000..8e0b97e06b --- /dev/null +++ b/core/io/streams/byte-array/byte-array-docs.factor @@ -0,0 +1,33 @@ +USING: help.syntax help.markup io byte-arrays quotations ; +IN: io.streams.byte-array + +ABOUT: "io.streams.byte-array" + +ARTICLE: "io.streams.byte-array" "Byte-array streams" +"Byte array streams:" +{ $subsection } +{ $subsection } +"Utility combinators:" +{ $subsection with-byte-reader } +{ $subsection with-byte-writer } ; + +HELP: +{ $values { "byte-array" byte-array } + { "encoding" "an encoding descriptor" } } +{ $description "Provides an input stream reading off the given byte array using the given encoding." } ; + +HELP: +{ $values { "encoding" "an encoding descriptor" } + { "stream" "an output stream" } } +{ $description "Provides an output stream, putting things in the given encoding, storing everything written to it in a byte-array." } ; + +HELP: with-byte-reader +{ $values { "encoding" "an encoding descriptor" } + { "quot" quotation } { "byte-array" byte-array } } +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading the byte array in the given encoding from beginning to end." } ; + +HELP: with-byte-writer +{ $values { "encoding" "an encoding descriptor" } + { "quot" quotation } + { "byte-array" byte-array } } +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new byte array writer, putting things in the given encoding. The accumulated byte array is output when the quotation returns." } ; diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index eb224650f3..d5ca8eac68 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -3,14 +3,14 @@ sequences io namespaces ; IN: io.streams.byte-array : ( encoding -- stream ) - 512 swap ; + 512 swap ; : with-byte-writer ( encoding quot -- byte-array ) >r r> [ stdio get ] compose with-stream* >byte-array ; inline : ( byte-array encoding -- stream ) - >r >byte-vector dup reverse-here r> ; + >r >byte-vector dup reverse-here r> ; : with-byte-reader ( byte-array encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor index de8a756f92..5d9c7b1a53 100644 --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -6,7 +6,6 @@ ARTICLE: "io.streams.c" "ANSI C streams" "C streams are found in the " { $vocab-link "io.streams.c" } " vocabulary; they are " { $link "stream-protocol" } " implementations which read and write C " { $snippet "FILE*" } " handles." { $subsection } { $subsection } -{ $subsection } "Underlying primitives used to implement the above:" { $subsection fopen } { $subsection fwrite } @@ -31,10 +30,6 @@ HELP: ( out -- stream ) { $description "Creates a stream which writes data by calling C standard library functions." } { $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ; -HELP: -{ $values { "in" "a C FILE* handle" } { "out" "a C FILE* handle" } { "stream" "a new stream" } } -{ $description "Creates a stream which reads and writes data by calling C standard library functions, wrapping the input portion in a " { $link line-reader } " and the output portion in a " { $link plain-writer } "." } ; - HELP: fopen ( path mode -- alien ) { $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } } { $description "Opens a file named by " { $snippet "path" } ". The " { $snippet "mode" } " parameter should be something like " { $snippet "\"r\"" } " or " { $snippet "\"rw\"" } "; consult the " { $snippet "fopen(3)" } " manual page for details." } diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 16b78c2192..321cad4d19 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,10 +1,12 @@ -USING: tools.test io.files io io.streams.c ; -IN: temporary +USING: tools.test io.files io io.streams.c +io.encodings.ascii strings ; +IN: io.streams.c.tests [ "hello world" ] [ - "test.txt" temp-file [ + "test.txt" temp-file ascii [ "hello world" write ] with-file-writer "test.txt" temp-file "rb" fopen contents + >string ] unit-test diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 48d6e6e430..372acbe0c1 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private namespaces io -strings sequences math generic threads.private classes -io.backend io.streams.lines io.streams.plain io.streams.duplex -io.files continuations ; +USING: kernel kernel.private namespaces io io.encodings +sequences math generic threads.private classes io.backend +io.streams.duplex io.files continuations byte-arrays ; IN: io.streams.c TUPLE: c-writer handle ; @@ -11,7 +10,7 @@ TUPLE: c-writer handle ; C: c-writer M: c-writer stream-write1 - >r 1string r> stream-write ; + c-writer-handle fputc ; M: c-writer stream-write c-writer-handle fwrite ; @@ -27,7 +26,7 @@ TUPLE: c-reader handle ; C: c-reader M: c-reader stream-read - >r >fixnum r> c-reader-handle fread ; + c-reader-handle fread ; M: c-reader stream-read-partial stream-read ; @@ -43,41 +42,39 @@ M: c-reader stream-read1 ] if ; M: c-reader stream-read-until - [ swap read-until-loop ] "" make swap + [ swap read-until-loop ] B{ } make swap over empty? over not and [ 2drop f f ] when ; M: c-reader dispose c-reader-handle fclose ; -: ( in out -- stream ) - >r r> - - ; - M: object init-io ; : stdin-handle 11 getenv ; : stdout-handle 12 getenv ; : stderr-handle 38 getenv ; -M: object init-stdio - stdin-handle stdout-handle stdio set-global - stderr-handle stderr set-global ; +M: object (init-stdio) + stdin-handle + stdout-handle + stderr-handle ; M: object io-multiplex 60 60 * 1000 * or (sleep) ; -M: object - "rb" fopen ; +M: object (file-reader) + "rb" fopen ; -M: object - "wb" fopen ; +M: object (file-writer) + "wb" fopen ; -M: object - "ab" fopen ; +M: object (file-appender) + "ab" fopen ; : show ( msg -- ) #! A word which directly calls primitives. It is used to #! print stuff from contexts where the I/O system would #! otherwise not work (tools.deploy.shaker, the I/O #! multiplexer thread). - "\r\n" append stdout-handle fwrite stdout-handle fflush ; + "\r\n" append >byte-array + stdout-handle fwrite + stdout-handle fflush ; 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/authors.txt b/core/io/streams/lines/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/core/io/streams/lines/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/core/io/streams/lines/lines-docs.factor b/core/io/streams/lines/lines-docs.factor deleted file mode 100644 index 789a060ed5..0000000000 --- a/core/io/streams/lines/lines-docs.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: help.markup help.syntax io strings ; -IN: io.streams.lines - -ARTICLE: "io.streams.lines" "Line reader streams" -"Line reader streams wrap an underlying stream and provide a default implementation of " { $link stream-readln } "." -{ $subsection line-reader } -{ $subsection } ; - -ABOUT: "io.streams.lines" - -HELP: line-reader -{ $class-description "An input stream which delegates to an underlying stream while providing an implementation of the " { $link stream-readln } " word in terms of the underlying stream's " { $link stream-read-until } ". Line readers are created by calling " { $link } "." } ; - -HELP: -{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } } -{ $description "Creates a new " { $link line-reader } "." } -{ $notes "Stream constructors should call this word to wrap streams that do not natively support reading lines. Unix (" { $snippet "\\n" } "), Windows (" { $snippet "\\r\\n" } ") and MacOS (" { $snippet "\\r" } ") line endings are supported." } ; diff --git a/core/io/streams/lines/lines.factor b/core/io/streams/lines/lines.factor deleted file mode 100755 index 391c602cc3..0000000000 --- a/core/io/streams/lines/lines.factor +++ /dev/null @@ -1,57 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: io.streams.lines -USING: arrays generic io kernel math namespaces sequences -vectors combinators splitting ; - -TUPLE: line-reader cr ; - -: ( stream -- new-stream ) - line-reader construct-delegate ; - -: cr+ t swap set-line-reader-cr ; inline - -: cr- f swap set-line-reader-cr ; inline - -: line-ends/eof ( stream str -- str ) f like swap cr- ; inline - -: line-ends\r ( stream str -- str ) swap cr+ ; inline - -: line-ends\n ( stream str -- str ) - over line-reader-cr over empty? and - [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline - -: handle-readln ( stream str ch -- str ) - { - { f [ line-ends/eof ] } - { CHAR: \r [ line-ends\r ] } - { CHAR: \n [ line-ends\n ] } - } case ; - -M: line-reader stream-readln ( stream -- str ) - "\r\n" over delegate stream-read-until handle-readln ; - -: fix-read ( stream string -- string ) - over line-reader-cr [ - over cr- - "\n" ?head [ - swap stream-read1 [ add ] when* - ] [ nip ] if - ] [ nip ] if ; - -M: line-reader stream-read - tuck delegate stream-read fix-read ; - -M: line-reader stream-read-partial - tuck delegate stream-read-partial fix-read ; - -: fix-read1 ( stream char -- char ) - over line-reader-cr [ - over cr- - dup CHAR: \n = [ - drop stream-read1 - ] [ nip ] if - ] [ nip ] if ; - -M: line-reader stream-read1 ( stream -- char ) - dup delegate stream-read1 fix-read1 ; diff --git a/core/io/streams/lines/summary.txt b/core/io/streams/lines/summary.txt deleted file mode 100644 index 8c0c096f0b..0000000000 --- a/core/io/streams/lines/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Read lines of text from a character-oriented stream 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/plain/plain-docs.factor b/core/io/streams/plain/plain-docs.factor index 4d7c5cc25e..a84e5be4f7 100644 --- a/core/io/streams/plain/plain-docs.factor +++ b/core/io/streams/plain/plain-docs.factor @@ -8,17 +8,10 @@ ARTICLE: "io.streams.plain" "Plain writer streams" { $link make-span-stream } ", " { $link make-block-stream } " and " { $link make-cell-stream } "." -{ $subsection plain-writer } -{ $subsection } ; +{ $subsection plain-writer } ; ABOUT: "io.streams.plain" HELP: plain-writer -{ $class-description "An output stream which delegates to an underlying stream while providing an implementation of the extended stream output protocol in a trivial way. Plain writers are created by calling " { $link } "." } -{ $see-also "stream-protocol" } ; - -HELP: -{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } } -{ $description "Creates a new " { $link plain-writer } "." } -{ $notes "Stream constructors should call this word to wrap streams that do not natively support the extended stream output protocol." } +{ $class-description "An output stream mixin providing an implementation of the extended stream output protocol in a trivial way." } { $see-also "stream-protocol" } ; diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index 70421eb1c2..4898a58fb1 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -1,13 +1,9 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel io io.streams.nested ; IN: io.streams.plain -USING: generic assocs kernel math namespaces sequences -io.styles io io.streams.nested ; -TUPLE: plain-writer ; - -: ( stream -- new-stream ) - plain-writer construct-delegate ; +MIXIN: plain-writer M: plain-writer stream-nl CHAR: \n swap stream-write1 ; diff --git a/core/io/streams/string/string-docs.factor b/core/io/streams/string/string-docs.factor index e948d2162a..91ac244608 100644 --- a/core/io/streams/string/string-docs.factor +++ b/core/io/streams/string/string-docs.factor @@ -26,4 +26,4 @@ HELP: HELP: with-string-reader { $values { "str" string } { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end. The accumulated string is output when the quotation returns." } ; +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ; 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/streams/string/string.factor b/core/io/streams/string/string.factor index a45c616b9a..7833e0aa47 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.string USING: io kernel math namespaces sequences sbufs strings -generic splitting io.streams.plain io.streams.lines growable -continuations ; +generic splitting growable continuations io.streams.plain +io.encodings ; M: growable dispose drop ; @@ -12,38 +12,19 @@ M: growable stream-write push-all ; M: growable stream-flush drop ; : ( -- stream ) - 512 ; + 512 ; : with-string-writer ( quot -- str ) swap [ stdio get ] compose with-stream* >string ; inline -: format-column ( seq ? -- seq ) - [ - [ 0 [ length max ] reduce ] keep - swap [ CHAR: \s pad-right ] curry map - ] unless ; - -: map-last ( seq quot -- seq ) - swap dup length - [ zero? rot [ call ] keep swap ] 2map nip ; inline - -: format-table ( table -- seq ) - flip [ format-column ] map-last - flip [ " " join ] map ; - -M: plain-writer stream-write-table - [ drop format-table [ print ] each ] with-stream* ; - -M: plain-writer make-cell-stream 2drop ; - M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ; : harden-as ( seq growble-exemplar -- newseq ) underlying like ; : growable-read-until ( growable n -- str ) - dupd tail-slice swap harden-as dup reverse-here ; + >fixnum dupd tail-slice swap harden-as dup reverse-here ; : find-last-sep swap [ memq? ] curry find-last drop ; @@ -69,7 +50,31 @@ M: growable stream-read-partial stream-read ; : ( str -- stream ) - >sbuf dup reverse-here ; + >sbuf dup reverse-here f ; : with-string-reader ( str quot -- ) >r r> with-stream ; inline + +INSTANCE: growable plain-writer + +: format-column ( seq ? -- seq ) + [ + [ 0 [ length max ] reduce ] keep + swap [ CHAR: \s pad-right ] curry map + ] unless ; + +: map-last ( seq quot -- seq ) + swap dup length + [ zero? rot [ call ] keep swap ] 2map nip ; inline + +: format-table ( table -- seq ) + flip [ format-column ] map-last + flip [ " " join ] map ; + +M: plain-writer stream-write-table + [ drop format-table [ print ] each ] with-stream* ; + +M: plain-writer make-cell-stream 2drop ; + +M: growable stream-readln ( stream -- str ) + "\r\n" over stream-read-until handle-readln ; 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/listener/listener.factor b/core/listener/listener.factor index fe1471716d..61d3f9836d 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math math.parser memory -namespaces parser sequences strings io.styles io.streams.lines +namespaces parser sequences strings io.styles io.streams.duplex vectors words generic system combinators tuples continuations debugger definitions compiler.units ; IN: listener @@ -32,7 +32,7 @@ GENERIC: stream-read-quot ( stream -- quot/f ) 3drop f ] if ; -M: line-reader stream-read-quot +M: object stream-read-quot V{ } clone read-quot-loop ; M: duplex-stream stream-read-quot 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/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index f3709780f9..04d7ab4ee5 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -1,208 +1,208 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs inference inference.class -inference.dataflow inference.backend inference.state io kernel -math namespaces sequences vectors words quotations hashtables -combinators classes generic.math continuations optimizer.def-use -optimizer.backend generic.standard optimizer.specializers -optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private ; -IN: optimizer.inlining - -: remember-inlining ( node history -- ) - [ swap set-node-history ] curry each-node ; - -: inlining-quot ( node quot -- node ) - over node-in-d dataflow-with - dup rot infer-classes/node ; - -: splice-quot ( #call quot history -- node ) - #! Must add history *before* splicing in, otherwise - #! the rest of the IR will also remember the history - pick node-history append - >r dupd inlining-quot dup r> remember-inlining - tuck splice-node ; - -! A heuristic to avoid excessive inlining -DEFER: (flat-length) - -: word-flat-length ( word -- n ) - { - ! heuristic: { ... } declare comes up in method bodies - ! and we don't care about it - { [ dup \ declare eq? ] [ drop -2 ] } - ! recursive - { [ dup get ] [ drop 1 ] } - ! not inline - { [ dup inline? not ] [ drop 1 ] } - ! inline - { [ t ] [ dup dup set word-def (flat-length) ] } - } cond ; - -: (flat-length) ( seq -- n ) - [ - { - { [ dup quotation? ] [ (flat-length) 1+ ] } - { [ dup array? ] [ (flat-length) ] } - { [ dup word? ] [ word-flat-length ] } - { [ t ] [ drop 1 ] } - } cond - ] map sum ; - -: flat-length ( seq -- n ) - [ word-def (flat-length) ] with-scope ; - -! Single dispatch method inlining optimization -: specific-method ( class word -- class ) order min-class ; - -: node-class# ( node n -- class ) - over node-in-d ?nth node-class ; - -: dispatching-class ( node word -- class ) - [ dispatch# node-class# ] keep specific-method ; - -: inline-standard-method ( node word -- node ) - 2dup dispatching-class dup [ - over +inlined+ depends-on - swap method method-word 1quotation f splice-quot - ] [ - 3drop t - ] if ; - -! Partial dispatch of math-generic words -: math-both-known? ( word left right -- ? ) - math-class-max swap specific-method ; - -: inline-math-method ( #call word -- node ) - over node-input-classes first2 3dup math-both-known? - [ math-method f splice-quot ] [ 2drop 2drop t ] if ; - -: inline-method ( #call -- node ) - dup node-param { - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ t ] [ 2drop t ] } - } cond ; - -! Resolve type checks at compile time where possible -: comparable? ( actual testing -- ? ) - #! If actual is a subset of testing or if the two classes - #! are disjoint, return t. - 2dup class< >r classes-intersect? not r> or ; - -: optimize-predicate? ( #call -- ? ) - dup node-param "predicating" word-prop dup [ - >r node-class-first r> comparable? - ] [ - 2drop f - ] if ; - -: literal-quot ( node literals -- quot ) - #! Outputs a quotation which drops the node's inputs, and - #! pushes some literals. - >r node-in-d length \ drop - r> [ literalize ] map append >quotation ; - -: inline-literals ( node literals -- node ) - #! Make #shuffle -> #push -> #return -> successor - dupd literal-quot f splice-quot ; - -: evaluate-predicate ( #call -- ? ) - dup node-param "predicating" word-prop >r - node-class-first r> class< ; - -: optimize-predicate ( #call -- node ) - #! If the predicate is followed by a branch we fold it - #! immediately - dup evaluate-predicate swap - dup node-successor #if? [ - dup drop-inputs >r - node-successor swap 0 1 ? fold-branch - r> [ set-node-successor ] keep - ] [ - swap 1array inline-literals - ] if ; - -: optimizer-hooks ( node -- conditions ) - node-param "optimizer-hooks" word-prop ; - -: optimizer-hook ( node -- pair/f ) - dup optimizer-hooks [ first call ] find 2nip ; - -: optimize-hook ( node -- ) - dup optimizer-hook second call ; - -: define-optimizers ( word optimizers -- ) - "optimizer-hooks" set-word-prop ; - -: flush-eval? ( #call -- ? ) - dup node-param "flushable" word-prop [ - node-out-d [ unused? ] all? - ] [ - drop f - ] if ; - -: flush-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup node-out-d length f inline-literals ; - -: partial-eval? ( #call -- ? ) - dup node-param "foldable" word-prop [ - dup node-in-d [ node-literal? ] with all? - ] [ - drop f - ] if ; - -: literal-in-d ( #call -- inputs ) - dup node-in-d [ node-literal ] with map ; - -: partial-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup literal-in-d over node-param 1quotation - [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; - -: define-identities ( words identities -- ) - [ "identities" set-word-prop ] curry each ; - -: find-identity ( node -- quot ) - [ node-param "identities" word-prop ] keep - [ swap first in-d-match? ] curry find - nip dup [ second ] when ; - -: apply-identities ( node -- node/f ) - dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; - -: optimistic-inline? ( #call -- ? ) - dup node-param "specializer" word-prop dup [ - >r node-input-classes r> specialized-length tail* - [ types length 1 = ] all? - ] [ - 2drop f - ] if ; - -: splice-word-def ( #call word -- node ) - dup +inlined+ depends-on - dup word-def swap 1array splice-quot ; - -: optimistic-inline ( #call -- node ) - dup node-param over node-history memq? [ - drop t - ] [ - dup node-param splice-word-def - ] if ; - -: method-body-inline? ( #call -- ? ) - node-param dup method-body? - [ flat-length 10 <= ] [ drop f ] if ; - -M: #call optimize-node* - { - { [ dup flush-eval? ] [ flush-eval ] } - { [ dup partial-eval? ] [ partial-eval ] } - { [ dup find-identity ] [ apply-identities ] } - { [ dup optimizer-hook ] [ optimize-hook ] } - { [ dup optimize-predicate? ] [ optimize-predicate ] } - { [ dup optimistic-inline? ] [ optimistic-inline ] } - { [ dup method-body-inline? ] [ optimistic-inline ] } - { [ t ] [ inline-method ] } - } cond dup not ; +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic assocs inference inference.class +inference.dataflow inference.backend inference.state io kernel +math namespaces sequences vectors words quotations hashtables +combinators classes generic.math continuations optimizer.def-use +optimizer.backend generic.standard optimizer.specializers +optimizer.def-use optimizer.pattern-match generic.standard +optimizer.control kernel.private ; +IN: optimizer.inlining + +: remember-inlining ( node history -- ) + [ swap set-node-history ] curry each-node ; + +: inlining-quot ( node quot -- node ) + over node-in-d dataflow-with + dup rot infer-classes/node ; + +: splice-quot ( #call quot history -- node ) + #! Must add history *before* splicing in, otherwise + #! the rest of the IR will also remember the history + pick node-history append + >r dupd inlining-quot dup r> remember-inlining + tuck splice-node ; + +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + { + ! heuristic: { ... } declare comes up in method bodies + ! and we don't care about it + { [ dup \ declare eq? ] [ drop -2 ] } + ! recursive + { [ dup get ] [ drop 1 ] } + ! not inline + { [ dup inline? not ] [ drop 1 ] } + ! inline + { [ t ] [ dup dup set word-def (flat-length) ] } + } cond ; + +: (flat-length) ( seq -- n ) + [ + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond + ] map sum ; + +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + +! Single dispatch method inlining optimization +: specific-method ( class word -- class ) order min-class ; + +: node-class# ( node n -- class ) + over node-in-d ?nth node-class ; + +: dispatching-class ( node word -- class ) + [ dispatch# node-class# ] keep specific-method ; + +: inline-standard-method ( node word -- node ) + 2dup dispatching-class dup [ + over +inlined+ depends-on + swap method 1quotation f splice-quot + ] [ + 3drop t + ] if ; + +! Partial dispatch of math-generic words +: math-both-known? ( word left right -- ? ) + math-class-max swap specific-method ; + +: inline-math-method ( #call word -- node ) + over node-input-classes first2 3dup math-both-known? + [ math-method f splice-quot ] [ 2drop 2drop t ] if ; + +: inline-method ( #call -- node ) + dup node-param { + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ t ] [ 2drop t ] } + } cond ; + +! Resolve type checks at compile time where possible +: comparable? ( actual testing -- ? ) + #! If actual is a subset of testing or if the two classes + #! are disjoint, return t. + 2dup class< >r classes-intersect? not r> or ; + +: optimize-predicate? ( #call -- ? ) + dup node-param "predicating" word-prop dup [ + >r node-class-first r> comparable? + ] [ + 2drop f + ] if ; + +: literal-quot ( node literals -- quot ) + #! Outputs a quotation which drops the node's inputs, and + #! pushes some literals. + >r node-in-d length \ drop + r> [ literalize ] map append >quotation ; + +: inline-literals ( node literals -- node ) + #! Make #shuffle -> #push -> #return -> successor + dupd literal-quot f splice-quot ; + +: evaluate-predicate ( #call -- ? ) + dup node-param "predicating" word-prop >r + node-class-first r> class< ; + +: optimize-predicate ( #call -- node ) + #! If the predicate is followed by a branch we fold it + #! immediately + dup evaluate-predicate swap + dup node-successor #if? [ + dup drop-inputs >r + node-successor swap 0 1 ? fold-branch + r> [ set-node-successor ] keep + ] [ + swap 1array inline-literals + ] if ; + +: optimizer-hooks ( node -- conditions ) + node-param "optimizer-hooks" word-prop ; + +: optimizer-hook ( node -- pair/f ) + dup optimizer-hooks [ first call ] find 2nip ; + +: optimize-hook ( node -- ) + dup optimizer-hook second call ; + +: define-optimizers ( word optimizers -- ) + "optimizer-hooks" set-word-prop ; + +: flush-eval? ( #call -- ? ) + dup node-param "flushable" word-prop [ + node-out-d [ unused? ] all? + ] [ + drop f + ] if ; + +: flush-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup node-out-d length f inline-literals ; + +: partial-eval? ( #call -- ? ) + dup node-param "foldable" word-prop [ + dup node-in-d [ node-literal? ] with all? + ] [ + drop f + ] if ; + +: literal-in-d ( #call -- inputs ) + dup node-in-d [ node-literal ] with map ; + +: partial-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup literal-in-d over node-param 1quotation + [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; + +: define-identities ( words identities -- ) + [ "identities" set-word-prop ] curry each ; + +: find-identity ( node -- quot ) + [ node-param "identities" word-prop ] keep + [ swap first in-d-match? ] curry find + nip dup [ second ] when ; + +: apply-identities ( node -- node/f ) + dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; + +: optimistic-inline? ( #call -- ? ) + dup node-param "specializer" word-prop dup [ + >r node-input-classes r> specialized-length tail* + [ types length 1 = ] all? + ] [ + 2drop f + ] if ; + +: splice-word-def ( #call word -- node ) + dup +inlined+ depends-on + dup word-def swap 1array splice-quot ; + +: optimistic-inline ( #call -- node ) + dup node-param over node-history memq? [ + drop t + ] [ + dup node-param splice-word-def + ] if ; + +: method-body-inline? ( #call -- ? ) + node-param dup method-body? + [ flat-length 10 <= ] [ drop f ] if ; + +M: #call optimize-node* + { + { [ dup flush-eval? ] [ flush-eval ] } + { [ dup partial-eval? ] [ partial-eval ] } + { [ dup find-identity ] [ apply-identities ] } + { [ dup optimizer-hook ] [ optimize-hook ] } + { [ dup optimize-predicate? ] [ optimize-predicate ] } + { [ dup optimistic-inline? ] [ optimistic-inline ] } + { [ dup method-body-inline? ] [ optimistic-inline ] } + { [ t ] [ inline-method ] } + } cond dup not ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index c63787ad52..3abccecc7f 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,378 +1,378 @@ -USING: arrays compiler.units generic hashtables inference kernel -kernel.private math optimizer prettyprint sequences sbufs -strings tools.test vectors words sequences.private quotations -optimizer.backend classes inference.dataflow tuples.private -continuations growable optimizer.inlining namespaces hints ; -IN: temporary - -[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* -] unit-test - -[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* -] unit-test - -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - -GENERIC: xyz ( obj -- obj ) -M: array xyz xyz ; - -[ t ] [ \ xyz compiled? ] unit-test - -! Test predicate inlining -: pred-test-1 - dup fixnum? [ - dup integer? [ "integer" ] [ "nope" ] if - ] [ - "not a fixnum" - ] if ; - -[ 1 "integer" ] [ 1 pred-test-1 ] unit-test - -TUPLE: pred-test ; - -: pred-test-2 - dup tuple? [ - dup pred-test? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test - -: pred-test-3 - dup pred-test? [ - dup tuple? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test - -: inline-test - "nom" = ; - -[ t ] [ "nom" inline-test ] unit-test -[ f ] [ "shayin" inline-test ] unit-test -[ f ] [ 3 inline-test ] unit-test - -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; - -[ ] [ 1000000 fixnum-declarations . ] unit-test - -! regression - -: literal-not-branch 0 not [ ] [ ] if ; - -[ ] [ literal-not-branch ] unit-test - -! regression - -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; - -[ 3 ] [ t bad-kill-2 ] unit-test - -! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- x y ) 2 dup (the-test) ; - -[ 2 0 ] [ the-test ] unit-test - -! regression -: (double-recursion) ( start end -- ) - < [ - 6 1 (double-recursion) - 3 2 (double-recursion) - ] when ; inline - -: double-recursion 0 2 (double-recursion) ; - -[ ] [ double-recursion ] unit-test - -! regression -: double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline - -: double-label-2 ( a -- b ) - dup array? [ ] [ ] if 0 t double-label-1 ; - -[ 0 ] [ 10 double-label-2 ] unit-test - -! regression -GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test -[ breakage ] must-fail - -! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - -: branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline - -: branch-fold-regression-1 ( -- m ) - 10 branch-fold-regression-0 ; - -[ 10 ] [ branch-fold-regression-1 ] unit-test - -! another regression -: constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test - -! another regression -: foo f ; -: bar foo 4 4 = and ; -[ f ] [ bar ] unit-test - -! ensure identities are working in some form -[ t ] [ - [ { number } declare 0 + ] dataflow optimize - [ #push? ] node-exists? not -] unit-test - -! compiling with a non-literal class failed -: -regression ; - -[ t ] [ \ -regression compiled? ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ reversed ] [ reversed \ foozul specific-method ] unit-test - -! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable - -[ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-call -] unit-test - -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable - -[ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-call -] unit-test - -[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test -[ 0 ] [ 5 [ dup - ] compile-call ] unit-test - -[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test - -[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test - -[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test - -[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test - -[ f ] [ 5 [ dup < ] compile-call ] unit-test -[ t ] [ 5 [ dup <= ] compile-call ] unit-test -[ f ] [ 5 [ dup > ] compile-call ] unit-test -[ t ] [ 5 [ dup >= ] compile-call ] unit-test - -[ t ] [ 5 [ dup eq? ] compile-call ] unit-test -[ t ] [ 5 [ dup = ] compile-call ] unit-test -[ t ] [ 5 [ dup number= ] compile-call ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test - -GENERIC: detect-number ( obj -- obj ) -M: number detect-number ; - -[ 10 f [ 0 + detect-number ] compile-call ] must-fail - -! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test - -! Regression -USE: sorting -USE: sorting.private - -: old-binsearch ( elt quot seq -- elt quot i ) - dup length 1 <= [ - slice-from - ] [ - [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if - ] if ; inline - -[ 10 ] [ - 10 20 >vector - [ [ - ] swap old-binsearch ] compile-call 2nip -] unit-test - -! Regression -TUPLE: silly-tuple a b ; - -[ 1 2 { silly-tuple-a silly-tuple-b } ] [ - T{ silly-tuple f 1 2 } - [ - { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-call -] unit-test - -! Regression -: empty-compound ; - -: node-successor-f-bug ( x -- * ) - [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; - -[ t ] [ \ node-successor-f-bug compiled? ] unit-test - -[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test - -[ ] [ [ ] dataflow optimize drop ] unit-test - -! Make sure we have sane heuristics -: should-inline? method method-word flat-length 10 <= ; - -[ t ] [ \ fixnum \ shift should-inline? ] unit-test -[ f ] [ \ array \ equal? should-inline? ] unit-test -[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test -[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test - -! Regression -: lift-throw-tail-regression - dup integer? [ "an integer" ] [ - dup string? [ "a string" ] [ - "error" throw - ] if - ] if ; - -[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test -[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test -[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test - -: lift-loop-tail-test-1 ( a quot -- ) - over even? [ - [ >r 3 - r> call ] keep lift-loop-tail-test-1 - ] [ - over 0 < [ - 2drop - ] [ - [ >r 2 - r> call ] keep lift-loop-tail-test-1 - ] if - ] if ; inline - -: lift-loop-tail-test-2 - 10 [ ] lift-loop-tail-test-1 1 2 3 ; - -[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test - -! Make sure we don't lose -GENERIC: generic-inline-test ( x -- y ) -M: integer generic-inline-test ; - -: generic-inline-test-1 - 1 - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test ; - -[ { t f } ] [ - \ generic-inline-test-1 word-def dataflow - [ optimize-1 , optimize-1 , drop ] { } make -] unit-test - -! Forgot a recursive inline check -: recursive-inline-hang ( a -- a ) - dup array? [ recursive-inline-hang ] when ; - -HINTS: recursive-inline-hang array ; - -: recursive-inline-hang-1 - { } recursive-inline-hang ; - -[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test - -DEFER: recursive-inline-hang-3 - -: recursive-inline-hang-2 ( a -- a ) - dup array? [ recursive-inline-hang-3 ] when ; - -HINTS: recursive-inline-hang-2 array ; - -: recursive-inline-hang-3 ( a -- a ) - dup array? [ recursive-inline-hang-2 ] when ; - -HINTS: recursive-inline-hang-3 array ; - - +USING: arrays compiler.units generic hashtables inference kernel +kernel.private math optimizer prettyprint sequences sbufs +strings tools.test vectors words sequences.private quotations +optimizer.backend classes inference.dataflow tuples.private +continuations growable optimizer.inlining namespaces hints ; +IN: optimizer.tests + +[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* +] unit-test + +[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +GENERIC: xyz ( obj -- obj ) +M: array xyz xyz ; + +[ t ] [ \ xyz compiled? ] unit-test + +! Test predicate inlining +: pred-test-1 + dup fixnum? [ + dup integer? [ "integer" ] [ "nope" ] if + ] [ + "not a fixnum" + ] if ; + +[ 1 "integer" ] [ 1 pred-test-1 ] unit-test + +TUPLE: pred-test ; + +: pred-test-2 + dup tuple? [ + dup pred-test? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test + +: pred-test-3 + dup pred-test? [ + dup tuple? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test + +: inline-test + "nom" = ; + +[ t ] [ "nom" inline-test ] unit-test +[ f ] [ "shayin" inline-test ] unit-test +[ f ] [ 3 inline-test ] unit-test + +: fixnum-declarations >fixnum 24 shift 1234 bitxor ; + +[ ] [ 1000000 fixnum-declarations . ] unit-test + +! regression + +: literal-not-branch 0 not [ ] [ ] if ; + +[ ] [ literal-not-branch ] unit-test + +! regression + +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-2 bad-kill-1 drop ; + +[ 3 ] [ t bad-kill-2 ] unit-test + +! regression +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; + +[ 2 0 ] [ the-test ] unit-test + +! regression +: (double-recursion) ( start end -- ) + < [ + 6 1 (double-recursion) + 3 2 (double-recursion) + ] when ; inline + +: double-recursion 0 2 (double-recursion) ; + +[ ] [ double-recursion ] unit-test + +! regression +: double-label-1 ( a b c -- d ) + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + +: double-label-2 ( a -- b ) + dup array? [ ] [ ] if 0 t double-label-1 ; + +[ 0 ] [ 10 double-label-2 ] unit-test + +! regression +GENERIC: void-generic ( obj -- * ) +: breakage "hi" void-generic ; +[ t ] [ \ breakage compiled? ] unit-test +[ breakage ] must-fail + +! regression +: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline +: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline +: test-2 ( -- ) 5 test-1 ; + +[ f ] [ f test-2 ] unit-test + +: branch-fold-regression-0 ( m -- n ) + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + +: branch-fold-regression-1 ( -- m ) + 10 branch-fold-regression-0 ; + +[ 10 ] [ branch-fold-regression-1 ] unit-test + +! another regression +: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! another regression +: foo f ; +: bar foo 4 4 = and ; +[ f ] [ bar ] unit-test + +! ensure identities are working in some form +[ t ] [ + [ { number } declare 0 + ] dataflow optimize + [ #push? ] node-exists? not +] unit-test + +! compiling with a non-literal class failed +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ reversed ] [ reversed \ foozul specific-method ] unit-test + +! regression +: constant-fold-2 f ; foldable +: constant-fold-3 4 ; foldable + +[ f t ] [ + [ constant-fold-2 constant-fold-3 4 = ] compile-call +] unit-test + +: constant-fold-4 f ; foldable +: constant-fold-5 f ; foldable + +[ f ] [ + [ constant-fold-4 constant-fold-5 or ] compile-call +] unit-test + +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test + +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test + +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test + +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test + +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test + +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test + +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test + +GENERIC: detect-number ( obj -- obj ) +M: number detect-number ; + +[ 10 f [ 0 + detect-number ] compile-call ] must-fail + +! Regression +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test + +! Regression +USE: sorting +USE: sorting.private + +: old-binsearch ( elt quot seq -- elt quot i ) + dup length 1 <= [ + slice-from + ] [ + [ midpoint swap call ] 3keep roll dup zero? + [ drop dup slice-from swap midpoint@ + ] + [ partition old-binsearch ] if + ] if ; inline + +[ 10 ] [ + 10 20 >vector + [ [ - ] swap old-binsearch ] compile-call 2nip +] unit-test + +! Regression +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-call +] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test + +[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +[ ] [ [ ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test + +! Regression +: lift-throw-tail-regression + dup integer? [ "an integer" ] [ + dup string? [ "a string" ] [ + "error" throw + ] if + ] if ; + +[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test +[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test +[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test + +: lift-loop-tail-test-1 ( a quot -- ) + over even? [ + [ >r 3 - r> call ] keep lift-loop-tail-test-1 + ] [ + over 0 < [ + 2drop + ] [ + [ >r 2 - r> call ] keep lift-loop-tail-test-1 + ] if + ] if ; inline + +: lift-loop-tail-test-2 + 10 [ ] lift-loop-tail-test-1 1 2 3 ; + +[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test + +! Make sure we don't lose +GENERIC: generic-inline-test ( x -- y ) +M: integer generic-inline-test ; + +: generic-inline-test-1 + 1 + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test ; + +[ { t f } ] [ + \ generic-inline-test-1 word-def dataflow + [ optimize-1 , optimize-1 , drop ] { } make +] unit-test + +! Forgot a recursive inline check +: recursive-inline-hang ( a -- a ) + dup array? [ recursive-inline-hang ] when ; + +HINTS: recursive-inline-hang array ; + +: recursive-inline-hang-1 + { } recursive-inline-hang ; + +[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test + +DEFER: recursive-inline-hang-3 + +: recursive-inline-hang-2 ( a -- a ) + dup array? [ recursive-inline-hang-3 ] when ; + +HINTS: recursive-inline-hang-2 array ; + +: recursive-inline-hang-3 ( a -- a ) + dup array? [ recursive-inline-hang-2 ] when ; + +HINTS: recursive-inline-hang-3 array ; + + 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/parser/parser.factor b/core/parser/parser.factor index 2f2d4a8c18..8e1927c043 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger -io.files io.streams.string io.streams.lines vocabs +io.files io.streams.string vocabs io.encodings.utf8 source-files classes hashtables compiler.errors compiler.units ; IN: parser @@ -500,7 +500,7 @@ SYMBOL: interactive-vocabs [ [ [ parsing-file ] keep - [ ?resource-path ] keep + [ ?resource-path utf8 ] keep parse-stream ] with-compiler-errors ] [ 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/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 2efc9b4e67..6cb03e4199 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -175,10 +175,10 @@ M: method-spec synopsis* dup definer. [ pprint-word ] each ; M: method-body synopsis* - dup definer. - "method" word-prop dup - method-specializer pprint* - method-generic pprint* ; + dup dup + definer. + "method-class" word-prop pprint* + "method-generic" word-prop pprint* ; M: mixin-instance synopsis* dup definer. @@ -269,7 +269,7 @@ M: builtin-class see-class* : see-implementors ( class -- seq ) dup implementors - [ method method-word ] with map + [ method ] with map natural-sort ; : see-class ( class -- ) @@ -280,9 +280,7 @@ M: builtin-class see-class* ] when drop ; : see-methods ( generic -- seq ) - "methods" word-prop - [ nip method-word ] { } assoc>map - natural-sort ; + "methods" word-prop values natural-sort ; M: word see dup see-class 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..55300a3c29 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -4,8 +4,8 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger -io.files io.crc32 io.streams.string io.streams.lines vocabs -hashtables graphs compiler.units ; +io.files io.crc32 io.streams.string vocabs +hashtables graphs compiler.units io.encodings.utf8 ; IN: source-files SYMBOL: source-files @@ -17,7 +17,7 @@ uses definitions ; : (source-modified?) ( path modified checksum -- ? ) pick file-modified rot [ 0 or ] 2apply > - [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ; + [ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ; : source-modified? ( path -- ? ) dup source-files get at [ @@ -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 + utf8 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..b21329de9c 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. 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 +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/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 720a1ef645..1a3fecc3fb 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ; M: f set-vocab-docs-loaded? 2drop ; +M: f vocab-help ; + : create-vocab ( name -- vocab ) dictionary get [ ] cache ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index f1cc678d17..4903f8933b 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -1,5 +1,5 @@ -USING: definitions help.markup help.syntax kernel -kernel.private parser words.private vocabs classes quotations +USING: definitions help.markup help.syntax kernel parser +kernel.private words.private vocabs classes quotations strings effects compiler.units ; IN: words diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 63e30178f5..4d9933147b 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,44 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ "IN: temporary : undef-test ; << undef-test >>" eval ] +"undef-test" "words.tests" lookup [ + [ forget ] with-compilation-unit +] when* + +[ "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/core/words/words.factor b/core/words/words.factor index e8b3fd9781..ce69c1ff2e 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method" word-prop ] [ t ] } + { [ dup "method-def" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; 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/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 182f04a367..88095759e6 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -16,13 +16,16 @@ IN: assocs.lib : at-default ( key assoc -- value/key ) dupd at [ nip ] when* ; +: replace-at ( assoc value key -- assoc ) + >r >r dup r> 1vector r> rot set-at ; + : insert-at ( value key assoc -- ) [ ?push ] change-at ; -: peek-at* ( key assoc -- obj ? ) - at* dup [ >r peek r> ] when ; +: peek-at* ( assoc key -- obj ? ) + swap at* dup [ >r peek r> ] when ; -: peek-at ( key assoc -- obj ) +: peek-at ( assoc key -- obj ) peek-at* drop ; : >multi-assoc ( assoc -- new-assoc ) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index bd13455357..231c6edf50 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -21,7 +21,7 @@ IN: benchmark ] with-row [ [ - swap [ ($vocab-link) ] with-cell + swap [ dup ($vocab-link) ] with-cell first2 pprint-cell pprint-cell ] with-row ] assoc-each diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 1740bcb28e..3c9c78d358 100644 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -1,6 +1,6 @@ ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2 USING: math kernel io io.files locals multiline assocs sequences -sequences.private benchmark.reverse-complement hints +sequences.private benchmark.reverse-complement hints io.encodings.ascii byte-arrays float-arrays ; IN: benchmark.fasta @@ -94,7 +94,7 @@ HINTS: random fixnum ; n [ ] seed [ initial-seed ] | - out [ + out ascii [ n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta initial-seed 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/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index b95e182bd1..e06b81f6de 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files splitting strings +USING: kernel io io.files splitting strings io.encodings.ascii hashtables sequences assocs math namespaces prettyprint math.parser combinators arrays sorting unicode.case ; @@ -57,7 +57,7 @@ IN: benchmark.knucleotide : knucleotide ( -- ) "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path - [ read-input ] with-file-reader + ascii [ read-input ] with-file-reader process-input ; MAIN: knucleotide diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 0da4785785..05eda2ad81 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,6 +1,6 @@ IN: benchmark.mandel USING: arrays io kernel math namespaces sequences strings sbufs -math.functions math.parser io.files colors.hsv ; +math.functions math.parser io.files colors.hsv io.encodings.binary ; : max-color 360 ; inline : zoom-fact 0.8 ; inline @@ -66,6 +66,6 @@ SYMBOL: cols : mandel-main ( -- ) "mandel.ppm" temp-file - [ mandel write ] with-file-writer ; + binary [ mandel write ] with-file-writer ; MAIN: mandel-main diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index ddfd0ed6dd..232842a51e 100644 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -3,7 +3,7 @@ USING: float-arrays compiler generic io io.files kernel math math.functions math.vectors math.parser namespaces sequences -sequences.private words ; +sequences.private words io.encodings.binary ; IN: benchmark.raytracer ! parameters @@ -171,6 +171,6 @@ DEFER: create ( level c r -- scene ) : raytracer-main "raytracer.pnm" temp-file - [ run write ] with-file-writer ; + binary [ run write ] with-file-writer ; MAIN: raytracer-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/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index cf4143d533..9c782e65e6 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.duplex kernel sequences sequences.private strings vectors words memoize splitting -hints unicode.case continuations ; +hints unicode.case continuations io.encodings.latin1 ; IN: benchmark.reverse-complement MEMO: trans-map ( -- str ) @@ -32,8 +32,8 @@ HINTS: do-line vector string ; readln [ do-line (reverse-complement) ] [ show-seq ] if* ; : reverse-complement ( infile outfile -- ) - [ - swap [ + latin1 [ + swap latin1 [ swap [ 500000 (reverse-complement) ] with-stream diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 6b1908afb1..25212c7264 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,43 +1,58 @@ -USING: io.sockets io.server io kernel math threads -debugger tools.time prettyprint concurrency.combinators ; -IN: benchmark.sockets - -: simple-server ( -- ) - 7777 local-server "benchmark.sockets" [ - read1 CHAR: x = [ - stop-server - ] [ - 20 [ read1 write1 flush ] times - ] if - ] with-server ; - -: simple-client ( -- ) - "localhost" 7777 [ - CHAR: b write1 flush - 20 [ CHAR: a dup write1 flush read1 assert= ] times - ] with-stream ; - -: stop-server ( -- ) - "localhost" 7777 [ - CHAR: x write1 - ] with-stream ; - -: clients ( n -- ) - dup pprint " clients: " write [ - [ simple-server ] in-thread - yield yield - [ drop simple-client ] parallel-each - stop-server - yield yield - ] time ; - -: socket-benchmarks - 10 clients - 20 clients - 40 clients ; - ! 80 clients - ! 160 clients - ! 320 clients - ! 640 clients ; - -MAIN: socket-benchmarks +USING: io.sockets io kernel math threads io.encodings.ascii +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 ( -- ) + [ + server-addr ascii dup "server" set [ + server-loop + ] with-disposal + ] ignore-errors ; + +: simple-client ( -- ) + server-addr ascii [ + CHAR: b write1 flush + number-of-requests + [ CHAR: a dup write1 flush read1 assert= ] times + counter get count-down + ] with-stream ; + +: stop-server ( -- ) + server-addr ascii [ + CHAR: x write1 + ] with-stream ; + +: clients ( n -- ) + dup pprint " clients: " write [ + dup 2 * counter set + [ simple-server ] "Simple server" spawn drop + yield yield + [ [ simple-client ] "Simple client" spawn drop ] times + counter get await + stop-server + yield yield + ] time ; + +: socket-benchmarks ; + +MAIN: socket-benchmarks diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index 1d52beebfc..bb7aebba62 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -1,12 +1,12 @@ USING: io io.files math math.parser kernel prettyprint -benchmark.random ; +benchmark.random io.encodings.ascii ; IN: benchmark.sum-file : sum-file-loop ( n -- n' ) readln [ string>number + sum-file-loop ] when* ; : sum-file ( file -- ) - [ 0 sum-file-loop ] with-file-reader . ; + ascii [ 0 sum-file-loop ] with-file-reader . ; : sum-file-main ( -- ) random-numbers-path sum-file ; diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 1fa8ee4f41..ab26a4ff13 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -2,16 +2,21 @@ ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.image.upload USING: http.client crypto.md5 splitting assocs kernel io.files -bootstrap.image sequences io namespaces io.launcher math ; +bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ; -: destination "slava@factorcode.org:www/images/latest/" ; +SYMBOL: upload-images-destination + +: destination ( -- dest ) + upload-images-destination get + "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" + or ; : checksums "checksums.txt" temp-file ; : boot-image-names images [ boot-image-name ] map ; : compute-checksums ( -- ) - checksums [ + checksums ascii [ boot-image-names [ dup write bl file>md5str print ] each ] with-file-writer ; @@ -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..41096e863c 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 ( -- ) { "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/bunny/model/model.factor b/extra/bunny/model/model.factor index 49a0f9254a..1d90209ed4 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices - math.parser io io.files kernel opengl opengl.gl opengl.glu + math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii opengl.capabilities shuffle http.client vectors splitting tools.time system combinators combinators.cleave float-arrays continuations namespaces sequences.lib ; @@ -35,7 +35,7 @@ IN: bunny.model : read-model ( stream -- model ) "Reading model" print flush [ - [ parse-model ] with-file-reader + ascii [ parse-model ] with-file-reader [ normals ] 2keep 3array ] time ; 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/format/format.factor b/extra/calendar/format/format.factor index 75ceea8ea2..89e09e0d0c 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -36,8 +36,12 @@ M: timestamp year. ( timestamp -- ) : pad-00 number>string 2 CHAR: 0 pad-left ; +: pad-0000 number>string 4 CHAR: 0 pad-left ; + : write-00 pad-00 write ; +: write-0000 pad-0000 write ; + : (timestamp>string) ( timestamp -- ) dup day-of-week day-abbreviations3 nth write ", " write dup day>> number>string write bl @@ -107,24 +111,68 @@ M: timestamp year. ( timestamp -- ) 60 / + * ] if ; +: read-ymd ( -- y m d ) + read-0000 "-" expect read-00 "-" expect read-00 ; + +: read-hms ( -- h m s ) + read-00 ":" expect read-00 ":" expect read-00 ; + : (rfc3339>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day + read-ymd "Tt" expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second + read-hms read-rfc3339-gmt-offset ! timezone ; : rfc3339>timestamp ( str -- timestamp ) [ (rfc3339>timestamp) ] with-string-reader ; +: (ymdhms>timestamp) ( -- timestamp ) + read-ymd " " expect read-hms 0 ; + +: ymdhms>timestamp ( str -- timestamp ) + [ (ymdhms>timestamp) ] with-string-reader ; + +: (hms>timestamp) ( -- timestamp ) + f f f read-hms f ; + +: hms>timestamp ( str -- timestamp ) + [ (hms>timestamp) ] with-string-reader ; + +: (ymd>timestamp) ( -- timestamp ) + read-ymd f f f f ; + +: ymd>timestamp ( str -- timestamp ) + [ (ymd>timestamp) ] with-string-reader ; + +: (timestamp>ymd) ( timestamp -- ) + dup timestamp-year write-0000 + "-" write + dup timestamp-month write-00 + "-" write + timestamp-day write-00 ; + +: timestamp>ymd ( timestamp -- str ) + [ (timestamp>ymd) ] with-string-writer ; + +: (timestamp>hms) + dup timestamp-hour write-00 + ":" write + dup timestamp-minute write-00 + ":" write + timestamp-second >integer write-00 ; + +: timestamp>hms ( timestamp -- str ) + [ (timestamp>hms) ] with-string-writer ; + +: timestamp>ymdhms ( timestamp -- str ) + >gmt + [ + dup (timestamp>ymd) + " " write + (timestamp>hms) + ] with-string-writer ; + : file-time-string ( timestamp -- string ) [ [ month>> month-abbreviations nth write ] keep bl 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 08336fd32e..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 ; inline + [ 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/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index 2c54a872f7..f09c441d26 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging threads io io.server qualified arrays -namespaces kernel ; +namespaces kernel io.encodings.binary ; QUALIFIED: io.sockets IN: concurrency.distributed @@ -15,7 +15,7 @@ SYMBOL: local-node ( -- addrspec ) [ local-node set-global "concurrency.distributed" - [ handle-node-client ] with-server + binary [ handle-node-client ] with-server ] 2curry f spawn drop ; : start-node ( port -- ) @@ -28,7 +28,7 @@ C: remote-process M: remote-process send ( message thread -- ) { remote-process-id remote-process-node } get-slots - io.sockets: [ 2array serialize ] with-stream ; + binary io.sockets: [ 2array serialize ] with-stream ; M: thread (serialize) ( obj -- ) thread-id local-node get-global 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/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 187297d0a0..24eceee744 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -3,7 +3,7 @@ ! USING: kernel math sequences words arrays io io.files namespaces math.parser assocs quotations parser parser-combinators -tools.time ; +tools.time io.encodings.binary ; IN: cpu.8080.emulator TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; @@ -439,7 +439,7 @@ M: cpu reset ( cpu -- ) : load-rom ( filename cpu -- ) #! Load the contents of the file into ROM. #! (address 0x0000-0x1FFF). - cpu-ram swap [ + cpu-ram swap binary [ 0 swap (load-rom) ] with-file-reader ; @@ -455,7 +455,7 @@ SYMBOL: rom-root #! file path shoul dbe relative to the '/roms' resource path. rom-dir [ cpu-ram [ - swap first2 rom-dir swap path+ [ + swap first2 rom-dir swap path+ binary [ swap (load-rom) ] with-file-reader ] curry each 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/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 7c358a8c09..56d39e71dc 100644 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -1,6 +1,6 @@ USING: arrays combinators crypto.common crypto.md5 crypto.sha1 crypto.md5.private io io.binary io.files io.streams.string -kernel math math.vectors memoize sequences ; +kernel math math.vectors memoize sequences io.encodings.binary ; IN: crypto.hmac : sha1-hmac ( Ko Ki -- hmac ) @@ -32,7 +32,7 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; [ init-hmac sha1-hmac ] with-stream ; : file>sha1-hmac ( K path -- hmac ) - stream>sha1-hmac ; + binary stream>sha1-hmac ; : string>sha1-hmac ( K string -- hmac ) stream>sha1-hmac ; @@ -42,7 +42,7 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; [ init-hmac md5-hmac ] with-stream ; : file>md5-hmac ( K path -- hmac ) - stream>md5-hmac ; + binary stream>md5-hmac ; : string>md5-hmac ( K string -- hmac ) stream>md5-hmac ; diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index 631a7a1020..debef26de4 100644 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -2,7 +2,8 @@ USING: kernel io io.binary io.files io.streams.string math math.functions math.parser namespaces splitting strings -sequences crypto.common byte-arrays locals sequences.private ; +sequences crypto.common byte-arrays locals sequences.private +io.encodings.binary ; IN: crypto.md5 : string>md5 ( string -- byte-array ) stream>md5 ; : string>md5str ( string -- md5-string ) string>md5 hex-string ; -: file>md5 ( path -- byte-array ) stream>md5 ; +: file>md5 ( path -- byte-array ) binary stream>md5 ; : file>md5str ( path -- md5-string ) file>md5 hex-string ; diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index f6dfbcd031..eaad6df622 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,6 +1,6 @@ -USING: arrays combinators crypto.common kernel io io.binary +USING: arrays combinators crypto.common kernel io io.encodings.binary io.files io.streams.string math.vectors strings sequences -namespaces math parser sequences vectors +namespaces math parser sequences vectors io.binary hashtables ; IN: crypto.sha1 @@ -123,7 +123,7 @@ SYMBOL: K : string>sha1 ( string -- sha1 ) stream>sha1 ; : string>sha1str ( string -- str ) string>sha1 hex-string ; : string>sha1-bignum ( string -- n ) string>sha1 be> ; -: file>sha1 ( file -- sha1 ) stream>sha1 ; +: file>sha1 ( file -- sha1 ) binary stream>sha1 ; : string>sha1-interleave ( string -- seq ) [ zero? ] left-trim 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..170d9a60f1 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,22 +25,18 @@ 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? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; -TUPLE: result-set sql params handle n max ; +TUPLE: result-set sql in-params out-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 ) @@ -51,6 +47,7 @@ GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) GENERIC: #columns ( result-set -- n ) GENERIC# row-column 1 ( result-set n -- obj ) +GENERIC# row-column-typed 1 ( result-set n -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) @@ -62,25 +59,25 @@ 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>> out-params>> } get-slots r> + { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set + construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; +: sql-row-typed ( result-set -- seq ) + dup #columns [ row-column-typed ] with map ; + : query-each ( statement quot -- ) over more-rows? [ [ call ] 2keep over advance-row query-each diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 7ea2bb629a..a6c2975c89 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 @@ -35,24 +33,6 @@ IN: temporary ] with-db ] unit-test -[ - { { "John" "America" } } -] [ - test-db [ - "select * from person where name = $1 and country = $2" - f f [ - { { "Jane" TEXT } { "New Zealand" TEXT } } - over do-bound-query - - { { "Jane" "New Zealand" } } = - [ "test fails" throw ] unless - - { { "John" TEXT } { "America" TEXT } } - swap do-bound-query - ] with-disposal - ] with-db -] unit-test - [ { { "John" "America" } @@ -113,244 +93,3 @@ IN: temporary : with-dummy-db ( quot -- ) >r T{ postgresql-db } db r> with-variable ; - -! TEST TUPLE DB - -TUPLE: puppy id name age ; -: ( name age -- puppy ) - { set-puppy-name set-puppy-age } puppy construct ; - -puppy "PUPPY" { - { "id" "ID" +native-id+ +not-null+ } - { "name" "NAME" { VARCHAR 256 } } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: kitty id name age ; -: ( name age -- kitty ) - { set-kitty-name set-kitty-age } kitty construct ; - -kitty "KITTY" { - { "id" "ID" INTEGER +assigned-id+ } - { "name" "NAME" TEXT } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: basket id puppies kitties ; -basket "BASKET" -{ - { "id" "ID" +native-id+ +not-null+ } - { "location" "LOCATION" TEXT } - { "puppies" { +has-many+ puppy } } - { "kitties" { +has-many+ kitty } } -} define-persistent - -! Create table -[ - "create table puppy(id serial primary key not null, name varchar 256, age integer);" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -[ - "create table kitty(id integer primary key, name text, age integer);" -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -[ - "create table basket(id serial primary key not null, location text);" -] [ - T{ postgresql-db } db [ - basket dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -! Create function -[ - "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table create-function-sql >lower - ] with-variable -] unit-test - -! Drop table - -[ - "drop table puppy;" -] [ - T{ postgresql-db } db [ - puppy db-table drop-table-sql >lower - ] with-variable -] unit-test - -[ - "drop table kitty;" -] [ - T{ postgresql-db } db [ - kitty db-table drop-table-sql >lower - ] with-variable -] unit-test - -[ - "drop table basket;" -] [ - T{ postgresql-db } db [ - basket db-table drop-table-sql >lower - ] with-variable -] unit-test - - -! Drop function -[ - "drop function add_puppy(varchar, integer);" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table drop-function-sql >lower - ] with-variable -] unit-test - -! Insert -[ -] [ - T{ postgresql-db } db [ - puppy - ] with-variable -] unit-test - -[ - "insert into kitty(id, name, age) values($1, $2, $3);" - { - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - T{ sql-spec f "name" "NAME" TEXT { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } - { } -] [ - T{ postgresql-db } db [ - kitty - ] with-variable -] unit-test - -! Update -[ - "update puppy set name = $1, age = $2 where id = $3" - { - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -[ - "update kitty set name = $1, age = $2 where id = $3" - { - T{ sql-spec f "name" "NAME" TEXT { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -! Delete -[ - "delete from puppy where id = $1" - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -[ - "delete from KITTY where ID = $1" - { - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table - ] with-variable -] unit-test - -! Select -[ - "select from PUPPY ID, NAME, AGE where NAME = $1;" - { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } } - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } -] [ - T{ postgresql-db } db [ - T{ puppy f f "Mr. Clunkers" } - - ] with-variable -] unit-test diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 8c957108e1..63bce0a8c3 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -112,7 +112,7 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 648d8493dc..f11f1e2ba6 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -2,7 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators -continuations db.types ; +continuations db.types calendar.format serialize +io.streams.string byte-arrays ; +USE: tools.walker IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -55,6 +57,10 @@ IN: db.sqlite.lib : sqlite-bind-null ( handle i -- ) sqlite3_bind_null sqlite-check-result ; +: sqlite-bind-blob ( handle i byte-array -- ) + dup length SQLITE_TRANSIENT + sqlite3_bind_blob sqlite-check-result ; + : sqlite-bind-text-by-name ( handle name text -- ) parameter-index sqlite-bind-text ; @@ -67,20 +73,32 @@ IN: db.sqlite.lib : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; +: sqlite-bind-blob-by-name ( handle name blob -- ) + parameter-index sqlite-bind-blob ; + : sqlite-bind-null-by-name ( handle name obj -- ) parameter-index drop sqlite-bind-null ; : sqlite-bind-type ( handle key value type -- ) + over [ drop NULL ] unless dup array? [ first ] when { { INTEGER [ sqlite-bind-int-by-name ] } - { BIG_INTEGER [ sqlite-bind-int64-by-name ] } + { BIG-INTEGER [ sqlite-bind-int64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { TIMESTAMP [ sqlite-bind-double-by-name ] } + { DATE [ sqlite-bind-text-by-name ] } + { TIME [ sqlite-bind-text-by-name ] } + { DATETIME [ sqlite-bind-text-by-name ] } + { TIMESTAMP [ sqlite-bind-text-by-name ] } + { BLOB [ sqlite-bind-blob-by-name ] } + { FACTOR-BLOB [ + [ serialize ] with-string-writer >byte-array + sqlite-bind-blob-by-name + ] } { +native-id+ [ sqlite-bind-int-by-name ] } - ! { NULL [ sqlite-bind-null-by-name ] } + { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -93,21 +111,38 @@ IN: db.sqlite.lib : sqlite-#columns ( query -- int ) sqlite3_column_count ; -! TODO : sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-blob ( handle index -- byte-array/f ) + [ sqlite3_column_bytes ] 2keep + pick zero? [ + 3drop f + ] [ + sqlite3_column_blob swap memory>byte-array + ] if ; + : sqlite-column-typed ( handle index type -- obj ) + dup array? [ first ] when { + { +native-id+ [ sqlite3_column_int64 ] } { INTEGER [ sqlite3_column_int ] } - { BIG_INTEGER [ sqlite3_column_int64 ] } + { BIG-INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } + { VARCHAR [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } - { TIMESTAMP [ sqlite3_column_double ] } + { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] } + { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] } + { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { BLOB [ sqlite-column-blob ] } + { FACTOR-BLOB [ + sqlite-column-blob [ deserialize ] with-string-reader + ] } + ! { NULL [ 2drop f ] } [ no-sql-type ] } case ; -! TODO : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 6c4b65ff9f..b30cb4ba80 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,51 +1,36 @@ 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 ; +: db-path "test.db" temp-file ; +: test.db db-path sqlite-db ; -[ ] [ [ test.db delete-file ] ignore-errors ] unit-test +[ ] [ [ db-path delete-file ] ignore-errors ] unit-test [ ] [ test.db [ "create table person (name varchar(30), country varchar(30))" sql-command "insert into person values('John', 'America')" sql-command "insert into person values('Jane', 'New Zealand')" sql-command - ] with-sqlite + ] with-db ] unit-test [ { { "John" "America" } { "Jane" "New Zealand" } } ] [ test.db [ "select * from person" sql-query - ] with-sqlite -] unit-test - -[ { { "John" "America" } } ] [ - test.db [ - "select * from person where name = :name and country = :country" - [ - { { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } } - over do-bound-query - - { { "Jane" "New Zealand" } } = - [ "test fails" throw ] unless - - { { ":name" "John" TEXT } { ":country" "America" TEXT } } - swap do-bound-query - ] with-disposal - ] with-sqlite + ] with-db ] unit-test [ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ] -[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test [ ] [ test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command - ] with-sqlite + ] with-db ] unit-test [ @@ -54,7 +39,7 @@ IN: temporary { "2" "Jane" "New Zealand" } { "3" "Jimmy" "Canada" } } -] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +] [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test [ test.db [ @@ -63,13 +48,13 @@ IN: temporary "insert into person(name, country) values('Jose', 'Mexico')" sql-command "oops" throw ] with-transaction - ] with-sqlite + ] with-db ] must-fail [ 3 ] [ test.db [ "select * from person" sql-query length - ] with-sqlite + ] with-db ] unit-test [ @@ -81,166 +66,11 @@ IN: temporary "insert into person(name, country) values('Jose', 'Mexico')" sql-command ] with-transaction - ] with-sqlite + ] with-db ] unit-test [ 5 ] [ test.db [ "select * from person" sql-query length - ] with-sqlite -] unit-test - -! TEST TUPLE DB - -TUPLE: puppy id name age ; -: ( name age -- puppy ) - { set-puppy-name set-puppy-age } puppy construct ; - -puppy "PUPPY" { - { "id" "ID" +native-id+ +not-null+ } - { "name" "NAME" { VARCHAR 256 } } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: kitty id name age ; -: ( name age -- kitty ) - { set-kitty-name set-kitty-age } kitty construct ; - -kitty "KITTY" { - { "id" "ID" INTEGER +assigned-id+ } - { "name" "NAME" TEXT } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: basket id puppies kitties ; -basket "BASKET" -{ - { "id" "ID" +native-id+ +not-null+ } - { "location" "LOCATION" TEXT } - { "puppies" { +has-many+ puppy } } - { "kitties" { +has-many+ kitty } } -} define-persistent - -! Create table -[ - "create table puppy(id integer primary key not null, name varchar, age integer);" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -[ - "create table kitty(id integer primary key, name text, age integer);" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -[ - "create table basket(id integer primary key not null, location text);" -] [ - T{ sqlite-db } db [ - basket dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -! Drop table -[ - "drop table puppy;" -] [ - T{ sqlite-db } db [ - puppy db-table drop-sql >lower - ] with-variable -] unit-test - -[ - "drop table kitty;" -] [ - T{ sqlite-db } db [ - kitty db-table drop-sql >lower - ] with-variable -] unit-test - -[ - "drop table basket;" -] [ - T{ sqlite-db } db [ - basket db-table drop-sql >lower - ] with-variable -] unit-test - -! Insert -[ - "insert into puppy(name, age) values(:name, :age);" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table insert-sql* >lower - ] with-variable -] unit-test - -[ - "insert into kitty(id, name, age) values(:id, :name, :age);" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table insert-sql* >lower - ] with-variable -] unit-test - -! Update -[ - "update puppy set name = :name, age = :age where id = :id" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table update-sql* >lower - ] with-variable -] unit-test - -[ - "update kitty set name = :name, age = :age where id = :id" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table update-sql* >lower - ] with-variable -] unit-test - -! Delete -[ - "delete from puppy where id = :id" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table delete-sql* >lower - ] with-variable -] unit-test - -[ - "delete from kitty where id = :id" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table delete-sql* >lower - ] with-variable -] unit-test - -! Select -[ - "select from puppy id, name, age where name = :name;" - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } -] [ - T{ sqlite-db } db [ - T{ puppy f f "Mr. Clunkers" } - select-sql >r >lower r> - ] with-variable + ] with-db ] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index b980e99718..643b42165d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,7 @@ hashtables io.files 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 ; @@ -53,7 +53,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 -- ) [ @@ -64,7 +65,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 @@ -79,8 +80,9 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set row-column ( result-set n -- obj ) >r result-set-handle r> sqlite-column ; -M: sqlite-result-set row-column-typed ( result-set n type -- obj ) - >r result-set-handle r> sqlite-column-typed ; +M: sqlite-result-set row-column-typed ( result-set n -- obj ) + dup pick result-set-out-params nth sql-spec-type + >r >r result-set-handle r> r> sqlite-column-typed ; M: sqlite-result-set advance-row ( result-set -- ) [ result-set-handle sqlite-next ] keep @@ -140,6 +142,10 @@ M: sqlite-db ( tuple -- statement ) " where " 0% find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; +: where-clause ( specs -- ) + " where " 0% + [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ; + M: sqlite-db ( class -- statement ) [ "update " 0% @@ -172,10 +178,7 @@ 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-clause ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) @@ -204,8 +207,13 @@ M: sqlite-db type-table ( -- assoc ) { INTEGER "integer" } { TEXT "text" } { VARCHAR "text" } + { DATE "date" } + { TIME "time" } + { DATETIME "datetime" } { TIMESTAMP "timestamp" } { DOUBLE "real" } + { BLOB "blob" } + { FACTOR-BLOB "blob" } } ; M: sqlite-db create-type-table diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index c9e6d302e0..5913f053da 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,113 +1,153 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples -db.types continuations namespaces db.postgresql math -prettyprint tools.walker db.sqlite ; -IN: temporary +db.types continuations namespaces math +prettyprint tools.walker db.sqlite calendar +math.intervals ; +IN: db.tuples.tests -TUPLE: person the-id the-name the-number the-real ; -: ( name age real -- person ) +TUPLE: person the-id the-name the-number the-real ts date time blob ; +: ( name age real ts date time blob -- person ) { set-person-the-name set-person-the-number set-person-the-real + set-person-ts + set-person-date + set-person-time + set-person-blob } person construct ; -: ( id name number the-real -- obj ) +: ( id name age real ts date time blob -- person ) [ set-person-the-id ] keep ; -SYMBOL: the-person1 -SYMBOL: the-person2 +SYMBOL: person1 +SYMBOL: person2 +SYMBOL: person3 +SYMBOL: person4 : test-tuples ( -- ) [ person drop-table ] [ drop ] recover [ ] [ person create-table ] unit-test [ person create-table ] must-fail - [ ] [ the-person1 get insert-tuple ] unit-test + [ ] [ person1 get insert-tuple ] unit-test - [ 1 ] [ the-person1 get person-the-id ] unit-test + [ 1 ] [ person1 get person-the-id ] unit-test - 200 the-person1 get set-person-the-number + 200 person1 get set-person-the-number - [ ] [ the-person1 get update-tuple ] unit-test + [ ] [ person1 get update-tuple ] unit-test [ T{ person f 1 "billy" 200 3.14 } ] [ T{ person f 1 } select-tuple ] unit-test - [ ] [ the-person2 get insert-tuple ] unit-test + [ ] [ person2 get insert-tuple ] unit-test [ { T{ person f 1 "billy" 200 3.14 } 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 + [ + { + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test + + + [ ] [ person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test + + [ ] [ person3 get insert-tuple ] unit-test + + [ + T{ + person + f + 3 + "teddy" + 10 + 3.14 + T{ timestamp f 2008 3 5 16 24 11 0 } + T{ timestamp f 2008 11 22 f f f f } + T{ timestamp f f f f 12 34 56 f } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } + } + ] [ T{ person f 3 } 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 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } + } define-persistent + "billy" 10 3.14 f f f f person1 set + "johnny" 10 3.14 f f f f person2 set + "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 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 - -"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 +: 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 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } + } define-persistent + 1 "billy" 10 3.14 f f f f person1 set + 2 "johnny" 10 3.14 f f f f person2 set + 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; 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 +157,55 @@ annotation "ANNOTATION" ! [ ] [ paste create-table ] unit-test ! [ ] [ annotation create-table ] unit-test ! ] with-db + +: test-sqlite ( quot -- ) + >r "tuples-test.db" temp-file 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 + +TUPLE: serialize-me id data ; + +: test-serialize ( -- ) + serialize-me "SERIALIZED" + { + { "id" "ID" +native-id+ } + { "data" "DATA" FACTOR-BLOB } + } define-persistent + [ serialize-me drop-table ] [ drop ] recover + [ ] [ serialize-me create-table ] unit-test + + [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test + [ + { T{ serialize-me f 1 H{ { 1 2 } } } } + ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; + +! [ test-serialize ] test-sqlite + +TUPLE: exam id name score ; + +: test-ranges ( -- ) + exam "EXAM" + { + { "id" "ID" +native-id+ } + { "name" "NAME" TEXT } + { "score" "SCORE" INTEGER } + } define-persistent + [ exam drop-table ] [ drop ] recover + [ ] [ exam create-table ] unit-test + + [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test + + [ + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test + ; + +! [ test-ranges ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index e7fe7e49c2..32055ccedc 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -37,27 +37,24 @@ HOOK: db ( class -- obj ) HOOK: db ( tuple -- tuple ) -HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: insert-tuple* db ( tuple statement -- ) : resulting-tuple ( row out-params -- tuple ) dup first sql-spec-class construct-empty [ [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named + >r sql-spec-slot-name r> set-slot-named ] curry 2each ] keep ; : query-tuples ( statement -- seq ) [ statement-out-params ] keep query-results [ - [ sql-row swap resulting-tuple ] with query-map + [ sql-row-typed swap resulting-tuple ] with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) - [ query-results [ sql-row ] with-disposal ] keep + [ query-results [ sql-row-typed ] with-disposal ] keep statement-out-params rot [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named + >r sql-spec-slot-name r> set-slot-named ] curry 2each ; : sql-props ( class -- columns table ) @@ -103,7 +100,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) db get db-delete-statements [ ] cache [ bind-tuple ] keep execute-statement ; -: select-tuples ( tuple -- tuple ) +: select-tuples ( tuple -- tuples ) dup dup class [ [ bind-tuple ] keep query-tuples ] with-disposal ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index c84b23c50f..023c72cd2d 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,7 +3,8 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes -mirrors tuples combinators ; +mirrors tuples combinators calendar.format serialize +io.streams.string ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -60,14 +61,19 @@ SYMBOL: +has-many+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; SYMBOL: INTEGER -SYMBOL: BIG_INTEGER +SYMBOL: BIG-INTEGER SYMBOL: DOUBLE SYMBOL: REAL SYMBOL: BOOLEAN SYMBOL: TEXT SYMBOL: VARCHAR -SYMBOL: TIMESTAMP SYMBOL: DATE +SYMBOL: TIME +SYMBOL: DATETIME +SYMBOL: TIMESTAMP +SYMBOL: BLOB +SYMBOL: FACTOR-BLOB +SYMBOL: NULL : spec>tuple ( class spec -- tuple ) [ ?first3 ] keep 3 ?tail* @@ -80,15 +86,6 @@ SYMBOL: DATE } sql-spec construct dup normalize-spec ; -: sql-type-hash ( -- assoc ) - H{ - { INTEGER "integer" } - { TEXT "text" } - { VARCHAR "varchar" } - { DOUBLE "real" } - { TIMESTAMP "timestamp" } - } ; - TUPLE: no-sql-type ; : no-sql-type ( -- * ) T{ no-sql-type } throw ; @@ -156,33 +153,6 @@ TUPLE: no-sql-modifier ; [ lookup-modifier ] map " " join dup empty? [ " " swap append ] unless ; -SYMBOL: building-seq -: get-building-seq ( n -- seq ) - building-seq get nth ; - -: n, get-building-seq push ; -: n% get-building-seq push-all ; -: n# >r number>string r> n% ; - -: 0, 0 n, ; -: 0% 0 n% ; -: 0# 0 n# ; -: 1, 1 n, ; -: 1% 1 n% ; -: 1# 1 n# ; -: 2, 2 n, ; -: 2% 2 n% ; -: 2# 2 n# ; - -: nmake ( quot exemplars -- seqs ) - dup length dup zero? [ 1+ ] when - [ - [ - [ drop 1024 swap new-resizable ] 2map - [ building-seq set call ] keep - ] 2keep >r [ like ] 2map r> firstn - ] with-scope ; - HOOK: bind% db ( spec -- ) TUPLE: no-slot-named ; @@ -210,15 +180,3 @@ TUPLE: no-slot-named ; >r dup sql-spec-type swap sql-spec-slot-name r> get-slot-named swap ] curry { } map>assoc ; - -: sql-type>factor-type ( obj type -- obj ) - dup array? [ first ] when - { - { +native-id+ [ string>number ] } - { INTEGER [ string>number ] } - { DOUBLE [ string>number ] } - { REAL [ string>number ] } - { TEXT [ ] } - { VARCHAR [ ] } - [ "no conversion from sql type to factor type" throw ] - } case ; 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/delegate/delegate.factor b/extra/delegate/delegate.factor index 667805dcc3..654d096b26 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,8 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ "method-def" word-prop spin define-method ] + [ 3drop ] if ] 2curry each ; : MIMIC: diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index 4c51e7ddfb..f96931c412 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax libc kernel ; +USING: help.markup help.syntax libc kernel continuations ; IN: destructors HELP: free-always @@ -23,7 +23,7 @@ HELP: close-later HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } { $notes "Destructors are not allowed to throw exceptions. No exceptions." } { $examples { $code "[ 10 malloc free-always ] with-destructors" } diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index db4f023dad..147e183688 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? ; @@ -9,7 +9,7 @@ TUPLE: dummy-destructor obj ; C: dummy-destructor -M: dummy-destructor destruct ( obj -- ) +M: dummy-destructor dispose ( obj -- ) dummy-destructor-obj t swap set-dummy-obj-destroyed? ; : destroy-always diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 0f8ec3af84..b2561c7439 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -4,18 +4,16 @@ USING: continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors -GENERIC: destruct ( obj -- ) - SYMBOL: error-destructors SYMBOL: always-destructors TUPLE: destructor object destroyed? ; -M: destructor destruct +M: destructor dispose dup destructor-destroyed? [ drop ] [ - dup destructor-object destruct + dup destructor-object dispose t swap set-destructor-destroyed? ] if ; @@ -29,10 +27,10 @@ M: destructor destruct always-destructors get push ; : do-always-destructors ( -- ) - always-destructors get [ destruct ] each ; + always-destructors get [ dispose ] each ; : do-error-destructors ( -- ) - error-destructors get [ destruct ] each ; + error-destructors get [ dispose ] each ; : with-destructors ( quot -- ) [ @@ -47,7 +45,7 @@ TUPLE: memory-destructor alien ; C: memory-destructor -M: memory-destructor destruct ( obj -- ) +M: memory-destructor dispose ( obj -- ) memory-destructor-alien free ; : free-always ( alien -- ) @@ -63,7 +61,7 @@ C: handle-destructor HOOK: destruct-handle io-backend ( obj -- ) -M: handle-destructor destruct ( obj -- ) +M: handle-destructor dispose ( obj -- ) handle-destructor-alien destruct-handle ; : close-always ( handle -- ) @@ -79,7 +77,7 @@ C: socket-destructor HOOK: destruct-socket io-backend ( obj -- ) -M: socket-destructor destruct ( obj -- ) +M: socket-destructor dispose ( obj -- ) socket-destructor-alien destruct-socket ; : close-socket-always ( handle -- ) 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/documents/documents.factor b/extra/documents/documents.factor index 34ecce5f8e..993e69ec14 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math models namespaces sequences strings -splitting io.streams.lines combinators unicode.categories ; +splitting combinators unicode.categories ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index fd5b6c1b06..ed579dde42 100644 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -3,11 +3,11 @@ USING: arrays definitions io kernel math namespaces parser prettyprint sequences strings words editors io.files io.sockets io.streams.string io.binary -math.parser ; +math.parser io.encodings.ascii ; IN: editors.jedit : jedit-server-info ( -- port auth ) - home "/.jedit/server" path+ [ + home "/.jedit/server" path+ ascii [ readln drop readln string>number readln string>number diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor old mode 100644 new mode 100755 index db11833cf1..f4b3025fcd --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -1,42 +1,48 @@ 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 + +[ "

=foo\n

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

foo

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

lol

foo

\n" ] [ "lol=foo=\n" 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/authors.txt b/extra/furnace/authors.txt deleted file mode 100644 index f372b574ae..0000000000 --- a/extra/furnace/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Doug Coleman diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor deleted file mode 100644 index 4afbd653bd..0000000000 --- a/extra/furnace/furnace-tests.factor +++ /dev/null @@ -1,47 +0,0 @@ -USING: kernel sequences namespaces math tools.test furnace furnace.validator ; -IN: temporary - -TUPLE: test-tuple m n ; - -[ H{ { "m" 3 } { "n" 2 } } ] -[ - [ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc -] unit-test - -[ - { 3 } -] [ - H{ { "n" "3" } } { { "n" v-number } } - [ action-param drop ] with map -] unit-test - -: foo ; - -\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action - -[ t ] [ [ 1 2 foo ] action-call? ] unit-test -[ f ] [ [ 2 + ] action-call? ] unit-test - -[ - { "2" "hello" } -] [ - [ - H{ - { "bar" "hello" } - } \ foo query>seq - ] with-scope -] unit-test - -[ - H{ { "foo" "1" } { "bar" "2" } } -] [ - { "1" "2" } \ foo quot>query -] unit-test - -[ - "/responder/temporary/foo?foo=3" -] [ - [ - [ "3" foo ] quot-link - ] with-scope -] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor deleted file mode 100755 index 590b3c82a7..0000000000 --- a/extra/furnace/furnace.factor +++ /dev/null @@ -1,206 +0,0 @@ -! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs calendar debugger furnace.sessions -furnace.validator hashtables heaps html.elements http -http.server.responders http.server.templating io.files kernel -math namespaces quotations sequences splitting words strings -vectors webapps.callback continuations tuples classes vocabs -html io ; -IN: furnace - -: code>quotation ( word/quot -- quot ) - dup word? [ 1quotation ] when ; - -SYMBOL: default-action -SYMBOL: template-path - -: render-template ( template -- ) - template-path get swap path+ - ".furnace" append resource-path - run-template-file ; - -: define-action ( word hash -- ) - over t "action" set-word-prop - "action-params" set-word-prop ; - -: define-form ( word1 word2 hash -- ) - dupd define-action - swap code>quotation "form-failed" set-word-prop ; - -: default-values ( word hash -- ) - "default-values" set-word-prop ; - -SYMBOL: request-params -SYMBOL: current-action -SYMBOL: validators-errored -SYMBOL: validation-errors - -: action-link ( query action -- url ) - [ - "/responder/" % - dup word-vocabulary "webapps." ?head drop % - "/" % - word-name % - ] "" make swap build-url ; - -: action-param ( hash paramsepc -- obj error/f ) - unclip rot at swap >quotation apply-validators ; - -: query>seq ( hash word -- seq ) - "action-params" word-prop [ - dup first -rot - action-param [ - t validators-errored >session - rot validation-errors session> set-at - ] [ - nip - ] if* - ] with map ; - -: lookup-session ( hash -- session ) - "furnace-session-id" over at get-session - [ ] [ new-session "furnace-session-id" roll set-at ] ?if ; - -: quot>query ( seq action -- hash ) - >r >array r> "action-params" word-prop - [ first swap 2array ] 2map >hashtable ; - -PREDICATE: word action "action" word-prop ; - -: action-call? ( quot -- ? ) - >vector dup pop action? >r [ word? not ] all? r> and ; - -: unclip* dup 1 head* swap peek ; - -: quot-link ( quot -- url ) - dup action-call? [ - unclip* [ quot>query ] keep action-link - ] [ - t register-html-callback - ] if ; - -: replace-variables ( quot -- quot ) - [ dup string? [ request-params session> at ] when ] map ; - -: furnace-session-id ( -- hash ) - "furnace-session-id" request-params session> at - "furnace-session-id" associate ; - -: redirect-to-action ( -- ) - current-action session> - "form-failed" word-prop replace-variables - quot-link furnace-session-id build-url permanent-redirect ; - -: if-form-page ( if then -- ) - current-action session> "form-failed" word-prop -rot if ; - -: do-action - current-action session> [ query>seq ] keep add >quotation call ; - -: process-form ( -- ) - H{ } clone validation-errors >session - request-params session> current-action session> query>seq - validators-errored session> [ - drop redirect-to-action - ] [ - current-action session> add >quotation call - ] if ; - -: page-submitted ( -- ) - [ process-form ] [ request-params session> do-action ] if-form-page ; - -: action-first-time ( -- ) - request-params session> current-action session> - [ "default-values" word-prop swap union request-params >session ] keep - request-params session> do-action ; - -: page-not-submitted ( -- ) - [ redirect-to-action ] [ action-first-time ] if-form-page ; - -: setup-call-action ( hash word -- ) - over lookup-session session set - current-action >session - request-params session> swap union - request-params >session - f validators-errored >session ; - -: call-action ( hash word -- ) - setup-call-action - "furnace-form-submitted" request-params session> at - [ page-submitted ] [ page-not-submitted ] if ; - -: responder-vocab ( str -- newstr ) - "webapps." swap append ; - -: lookup-action ( str webapp -- word ) - responder-vocab lookup dup [ - dup "action" word-prop [ drop f ] unless - ] when ; - -: truncate-url ( str -- newstr ) - CHAR: / over index [ head ] when* ; - -: parse-action ( str -- word/f ) - dup empty? [ drop default-action get ] when - truncate-url "responder" get lookup-action ; - -: service-request ( hash str -- ) - parse-action [ - [ call-action ] [
 print-error 
] recover - ] [ - "404 no such action: " "argument" get append httpd-error - ] if* ; - -: service-get - "query" get swap service-request ; - -: service-post - "response" get swap service-request ; - -: web-app ( name defaul path -- ) - [ - template-path set - default-action set - "responder" set - [ service-get ] "get" set - [ service-post ] "post" set - ] make-responder ; - -: explode-tuple ( tuple -- ) - dup tuple-slots swap class "slot-names" word-prop - [ set ] 2each ; - -SYMBOL: model - -: with-slots ( model quot -- ) - [ - >r [ dup model set explode-tuple ] when* r> call - ] with-scope ; - -: render-component ( model template -- ) - swap [ render-template ] with-slots ; - -: browse-webapp-source ( vocab -- ) - - "Browse source" write - ; - -: send-resource ( name -- ) - template-path get swap path+ resource-path - stdio get stream-copy ; - -: render-link ( quot name -- ) - write ; - -: session-var ( str -- newstr ) - request-params session> at ; - -: render ( str -- ) - request-params session> at [ write ] when* ; - -: render-error ( str error-str -- ) - swap validation-errors session> at validation-error? [ - write - ] [ - drop - ] if ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor deleted file mode 100755 index cf03fee6b1..0000000000 --- a/extra/furnace/sessions/sessions.factor +++ /dev/null @@ -1,50 +0,0 @@ -USING: assocs calendar init kernel math.parser -namespaces random boxes alarms combinators.lib ; -IN: furnace.sessions - -SYMBOL: sessions - -: timeout ( -- dt ) 20 minutes ; - -[ - H{ } clone sessions set-global -] "furnace.sessions" add-init-hook - -: new-session-id ( -- str ) - [ 4 big-random >hex ] - [ sessions get-global key? not ] generate ; - -TUPLE: session id namespace alarm user-agent ; - -: cancel-timeout ( session -- ) - session-alarm ?box [ cancel-alarm ] [ drop ] if ; - -: delete-session ( session -- ) - sessions get-global delete-at* - [ cancel-timeout ] [ drop ] if ; - -: touch-session ( session -- ) - dup cancel-timeout - dup [ session-id delete-session ] curry timeout later - swap session-alarm >box ; - -: ( id -- session ) - H{ } clone f session construct-boa ; - -: new-session ( -- session id ) - new-session-id [ - dup [ - [ sessions get-global set-at ] keep - touch-session - ] keep - ] keep ; - -: get-session ( id -- session/f ) - sessions get-global at* - [ dup touch-session ] when ; - -: session> ( str -- obj ) - session get session-namespace at ; - -: >session ( value key -- ) - session get session-namespace set-at ; diff --git a/extra/furnace/summary.txt b/extra/furnace/summary.txt deleted file mode 100755 index 5696506f79..0000000000 --- a/extra/furnace/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Action-based web framework diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt deleted file mode 100644 index 0aef4feca8..0000000000 --- a/extra/furnace/tags.txt +++ /dev/null @@ -1 +0,0 @@ -enterprise diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor deleted file mode 100644 index 06d8ac815d..0000000000 --- a/extra/furnace/validator/validator-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: temporary -USING: kernel sequences tools.test furnace.validator furnace ; - -[ - 123 f -] [ - H{ { "foo" "123" } } { "foo" v-number } action-param -] unit-test - -: validation-fails - [ action-param nip not ] append [ f ] swap unit-test ; - -[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails - -[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails - -[ "ABCD" f ] -[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ] -unit-test - -[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ] -validation-fails - -[ "AB" f ] -[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ] -unit-test - -[ "AB" f ] -[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ] -unit-test diff --git a/extra/furnace/validator/validator.factor b/extra/furnace/validator/validator.factor deleted file mode 100644 index 698c77fa9a..0000000000 --- a/extra/furnace/validator/validator.factor +++ /dev/null @@ -1,43 +0,0 @@ -! Copyright (C) 2006 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences math namespaces math.parser ; -IN: furnace.validator - -TUPLE: validation-error reason ; - -: apply-validators ( string quot -- obj error/f ) - [ - call f - ] [ - dup validation-error? [ >r 2drop f r> ] [ rethrow ] if - ] recover ; - -: validation-error ( msg -- * ) - \ validation-error construct-boa throw ; - -: v-default ( obj value -- obj ) - over empty? [ nip ] [ drop ] if ; - -: v-required ( str -- str ) - dup empty? [ "required" validation-error ] when ; - -: v-min-length ( str n -- str ) - over length over < [ - [ "must be at least " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-max-length ( str n -- str ) - over length over > [ - [ "must be no more than " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-number ( str -- n ) - string>number [ - "must be a number" validation-error - ] unless* ; 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/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 8e61766de1..ec4d6b79e1 100644 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -4,7 +4,7 @@ USING: alien arrays byte-arrays combinators graphics.viewer io io.binary io.files kernel libc math math.functions namespaces opengl opengl.gl prettyprint -sequences strings ui ui.gadgets.panes ; +sequences strings ui ui.gadgets.panes io.encodings.binary ; IN: graphics.bitmap ! Currently can only handle 24bit bitmaps. @@ -59,7 +59,7 @@ TUPLE: bitmap magic size reserved offset header-length width dup color-index-length read swap set-bitmap-color-index ; : load-bitmap ( path -- bitmap ) - [ + binary [ T{ bitmap } clone dup parse-file-header dup parse-bitmap-header @@ -69,7 +69,7 @@ TUPLE: bitmap magic size reserved offset header-length width raw-bitmap>string >byte-array over set-bitmap-array ; : save-bitmap ( bitmap path -- ) - [ + binary [ "BM" write dup bitmap-array length 14 + 40 + 4 >le write 0 4 >le write diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index ebdbdeb37e..72b300b585 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -191,11 +191,11 @@ ARTICLE: "cookbook-io" "Input and output cookbook" } "Print the lines of a file in sorted order:" { $code - "\"lines.txt\" file-lines natural-sort [ print ] each" + "utf8 \"lines.txt\" file-lines natural-sort [ print ] each" } "Read 1024 bytes from a file:" { $code - "\"data.bin\" [ 1024 read ] with-file-reader" + "\"data.bin\" binary [ 1024 read ] with-file-reader" } "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" { $code 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/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 178b7a5d35..84108a1db6 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -2,7 +2,7 @@ USING: help help.markup help.syntax help.definitions help.topics namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io generic math system strings sbufs vectors byte-arrays bit-arrays float-arrays -quotations ; +quotations io.streams.byte-array io.encodings.string ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -176,9 +176,9 @@ ARTICLE: "io" "Input and output" { $subsection "streams" } "Wrapper streams:" { $subsection "io.streams.duplex" } -{ $subsection "io.streams.lines" } { $subsection "io.streams.plain" } { $subsection "io.streams.string" } +{ $subsection "io.streams.byte-array" } "Utilities:" { $subsection "stream-binary" } { $subsection "styles" } @@ -186,6 +186,9 @@ ARTICLE: "io" "Input and output" { $subsection "io.files" } { $subsection "io.mmap" } { $subsection "io.monitors" } +{ $heading "Encodings" } +{ $subsection "io.encodings" } +{ $subsection "io.encodings.string" } { $heading "Other features" } { $subsection "network-streams" } { $subsection "io.launcher" } 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/markup/markup.factor b/extra/help/markup/markup.factor old mode 100644 new mode 100755 index 5f1b027823..32e29db7db --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -144,24 +144,36 @@ M: f print-element drop ; : $link ( element -- ) first ($link) ; -: ($subsection) ( object -- ) - [ article-title ] keep >link write-object ; +: ($long-link) ( object -- ) + dup article-title swap >link write-link ; -: $subsection ( element -- ) +: ($subsection) ( element quot -- ) [ subsection-style get [ bullet get write bl - first ($subsection) + call ] with-style - ] ($block) ; + ] ($block) ; inline -: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ; +: $subsection ( element -- ) + [ first ($long-link) ] ($subsection) ; -: $vocab-link ( element -- ) first ($vocab-link) ; +: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ; + +: $vocab-subsection ( element -- ) + [ + first2 dup vocab-help dup [ + 2nip ($long-link) + ] [ + drop ($vocab-link) + ] if + ] ($subsection) ; + +: $vocab-link ( element -- ) first dup ($vocab-link) ; : $vocabulary ( element -- ) first word-vocabulary [ - "Vocabulary" $heading nl ($vocab-link) + "Vocabulary" $heading nl dup ($vocab-link) ] when* ; : textual-list ( seq quot -- ) 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/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index fca15d9b07..45197b1a90 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,8 +1,43 @@ USING: assocs html.parser kernel math sequences strings ascii -arrays shuffle unicode.case namespaces splitting -http.server.responders ; +arrays shuffle unicode.case namespaces splitting http ; IN: html.parser.analyzer +: (find-relative) + [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; + +: find-relative ( seq quot n -- i elt ) + >r over [ find drop ] dip r> swap pick + (find-relative) ; + +: (find-all) ( n seq quot -- ) + 2dup >r >r find* [ + dupd 2array , 1+ r> r> (find-all) + ] [ + r> r> 3drop + ] if* ; + +: find-all ( seq quot -- alist ) + [ 0 -rot (find-all) ] { } make ; + +: (find-nth) ( offset seq quot n count -- obj ) + >r >r [ find* ] 2keep 4 npick [ + r> r> 1+ 2dup <= [ + 4drop + ] [ + >r >r >r >r drop 1+ r> r> r> r> + (find-nth) + ] if + ] [ + 2drop r> r> 2drop + ] if ; + +: find-nth ( seq quot n -- i elt ) + 0 -roll 0 (find-nth) ; + +: find-nth-relative ( seq quot n offest -- i elt ) + >r [ find-nth ] 3keep 2drop nip r> swap pick + (find-relative) ; + : remove-blank-text ( vector -- vector' ) [ dup tag-name text = [ @@ -52,29 +87,33 @@ IN: html.parser.analyzer >r >lower r> [ tag-attributes at over = ] with find rot drop ; -: find-between ( i/f tag/f vector -- vector ) +: find-between* ( i/f tag/f vector -- vector ) pick integer? [ - rot 1+ tail-slice + rot tail-slice >r tag-name r> - [ find-matching-close drop ] keep swap head + [ find-matching-close drop 1+ ] keep swap head ] [ 3drop V{ } clone ] if ; + +: find-between ( i/f tag/f vector -- vector ) + find-between* dup length 3 >= [ + [ 1 tail-slice 1 head-slice* ] keep like + ] when ; + +: find-between-first ( string vector -- vector' ) + [ find-first-name ] keep find-between ; + +: tag-link ( tag -- link/f ) + tag-attributes [ "href" swap at ] [ f ] if* ; : find-links ( vector -- vector ) [ tag-name "a" = ] subset - [ tag-attributes "href" swap at ] map - [ ] subset ; + [ tag-link ] subset ; -: (find-all) ( n seq quot -- ) - 2dup >r >r find* [ - dupd 2array , 1+ r> r> (find-all) - ] [ - r> r> 3drop - ] if* ; -: find-all ( seq quot -- alist ) - [ 0 -rot (find-all) ] { } make ; +: find-by-text ( seq quot -- tag ) + [ dup tag-name text = ] swap compose find drop ; : find-opening-tags-by-name ( name seq -- seq ) [ [ tag-name = ] keep tag-closing? not and ] with find-all ; @@ -82,8 +121,8 @@ IN: html.parser.analyzer : href-contains? ( str tag -- ? ) tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; -: query>hash* ( str -- hash ) - "?" split1 nip query>hash ; +: query>assoc* ( str -- hash ) + "?" split1 nip query>assoc ; ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map @@ -91,5 +130,5 @@ IN: html.parser.analyzer ! "a" over find-opening-tags-by-name ! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset ! first first 8 + over nth -! tag-attributes "href" swap at query>hash* +! tag-attributes "href" swap at query>assoc* ! "lat" over at "lon" rot at 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/basic-authentication/authors.txt b/extra/http/basic-authentication/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/http/basic-authentication/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/http/basic-authentication/basic-authentication-docs.factor b/extra/http/basic-authentication/basic-authentication-docs.factor deleted file mode 100644 index 68d6e6bf1d..0000000000 --- a/extra/http/basic-authentication/basic-authentication-docs.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax crypto.sha2 ; -IN: http.basic-authentication - -HELP: realms -{ $description - "A hashtable mapping a basic authentication realm (a string) " - "to either a quotation or a hashtable. The quotation has " - "stack effect ( username sha-256-string -- bool ). It " - "is expected to perform the user authentication when called." $nl - "If the realm maps to a hashtable then the hashtable should be a " - "mapping of usernames to sha-256 hashed passwords." $nl - "If the 'realms' variable does not exist in the current scope then " - "authentication will always fail." } -{ $see-also add-realm with-basic-authentication } ; - -HELP: add-realm -{ $values - { "data" "a quotation or a hashtable" } { "name" "a string" } } -{ $description - "Adds the authentication data to the " { $link realms } ". 'data' can be " - "a quotation with stack effect ( username sha-256-string -- bool ) or " - "a hashtable mapping username strings to sha-256-string passwords." } -{ $examples - { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" } - { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" } -} -{ $see-also with-basic-authentication realms } ; - -HELP: with-basic-authentication -{ $values - { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } } -{ $description - "Checks if the HTTP request has the correct authorisation headers " - "for basic authentication within the named realm. If the headers " - "are not present then a '401' HTTP response results from the " - "request, otherwise the quotation is called." } -{ $examples -{ $code "\"my-realm\" [\n serving-html \"Success!\" write\n] with-basic-authentication" } } -{ $see-also add-realm realms } - ; - -ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication" -"The Basic Authentication system provides a simple browser based " -"authentication method to web applications. When the browser requests " -"a resource protected with basic authentication the server responds with " -"a '401' response code which means the user is unauthorized." -$nl -"When the browser receives this it prompts the user for a username and " -"password. This is sent back to the server in a special HTTP header. The " -"server then checks this against its authentication information and either " -"accepts or rejects the users request." -$nl -"Authentication is split up into " { $link realms } ". Each realm can have " -"a different database of username and password information. A responder can " -"require basic authentication by using the " { $link with-basic-authentication } " word." -$nl -"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "." -$nl -"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word." -$nl -"Note that Basic Authentication itself is insecure in that it " -"sends the username and password as clear text (although it is " -"base64 encoded this is not much help). To prevent eavesdropping " -"it is best to use Basic Authentication with SSL." ; - -IN: http.basic-authentication -ABOUT: { "http-authentication" "basic-authentication" } diff --git a/extra/http/basic-authentication/basic-authentication-tests.factor b/extra/http/basic-authentication/basic-authentication-tests.factor deleted file mode 100644 index 318123b0b4..0000000000 --- a/extra/http/basic-authentication/basic-authentication-tests.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel crypto.sha2 http.basic-authentication tools.test - namespaces base64 sequences ; - -{ t } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ t } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - f realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test diff --git a/extra/http/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor deleted file mode 100644 index dfe04dc4b5..0000000000 --- a/extra/http/basic-authentication/basic-authentication.factor +++ /dev/null @@ -1,65 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel base64 http.server crypto.sha2 namespaces assocs - quotations hashtables combinators splitting sequences - http.server.responders io html.elements ; -IN: http.basic-authentication - -! 'realms' is a hashtable mapping a realm (a string) to -! either a quotation or a hashtable. The quotation -! has stack effect ( username sha-256-string -- bool ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'realms' maps to a hashtable then -! it is a mapping of usernames to sha-256 hashed passwords. -! -! 'realms' can be set on a per vhost basis in the vhosts -! table. -! -! If there are no realms then authentication fails. -SYMBOL: realms - -: add-realm ( data name -- ) - #! Add the named realm to the realms table. - #! 'data' should be a hashtable or a quotation. - realms get [ H{ } clone dup realms set ] unless* - set-at ; - -: user-authorized? ( username password realm -- bool ) - realms get dup [ - at { - { [ dup quotation? ] [ call ] } - { [ dup hashtable? ] [ swapd at = ] } - { [ t ] [ 3drop f ] } - } cond - ] [ - 3drop drop f - ] if ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split dup first "Basic" = [ - second base64> ":" split first2 string>sha-256-string rot - user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: authentication-error ( realm -- ) - "401 Unauthorized" response - "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header - - "Username or Password is invalid" write - ; - -: with-basic-authentication ( realm quot -- ) - #! Check if the user is authenticated in the given realm - #! to run the specified quotation. If not, use Basic - #! Authentication to ask for authorization details. - over "authorization" header-param authorization-ok? - [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http/basic-authentication/summary.txt b/extra/http/basic-authentication/summary.txt deleted file mode 100644 index 60cef7e630..0000000000 --- a/extra/http/basic-authentication/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP Basic Authentication implementation diff --git a/extra/http/basic-authentication/tags.txt b/extra/http/basic-authentication/tags.txt deleted file mode 100644 index c0772185a0..0000000000 --- a/extra/http/basic-authentication/tags.txt +++ /dev/null @@ -1 +0,0 @@ -web diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index d2fb719acd..4fca1697a5 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,14 +1,28 @@ -USING: http.client tools.test ; +USING: http.client http.client.private http tools.test +tuple-syntax namespaces ; [ "localhost" 80 ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test -[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test -[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test -[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test -[ 404 ] [ "404 File not found" parse-response ] unit-test -[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test -[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test +[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test +[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test [ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test + +[ + TUPLE{ request + method: "GET" + host: "www.apple.com" + path: "/index.html" + port: 80 + version: "1.1" + cookies: V{ } + } +] [ + [ + "http://www.apple.com/index.html" + + request-with-url + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 99ba045019..f7a160017a 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,64 +2,71 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib calendar ; +splitting calendar continuations accessors vectors io.encodings.binary ; IN: http.client -: parse-host ( url -- host port ) - #! Extract the host name and port number from an HTTP URL. - ":" split1 [ string>number ] [ 80 ] if* ; - -SYMBOL: domain - -: parse-url ( url -- host resource ) - dup "https://" head? [ - "ssl not yet supported: " swap append throw - ] when "http://" ?head drop +: parse-url ( url -- resource host port ) + "http://" ?head [ "Only http:// supported" throw ] unless "/" split1 [ "/" swap append ] [ "/" ] if* - >r dup empty? [ drop domain get ] [ dup domain set ] if r> ; + swap parse-host ; -: parse-response ( line -- code ) - "HTTP/" ?head [ " " split1 nip ] when - " " split1 drop string>number [ - "Premature end of stream" throw - ] unless* ; +r >>path r> dup [ query>assoc ] when >>query ; -: crlf "\r\n" write ; +! This is all pretty complex because it needs to handle +! HTTP redirects, which might be absolute or relative +: request-with-url ( url request -- request ) + clone dup "request" set + swap parse-url >r >r store-path r> >>host r> >>port ; -: http-request ( host resource method -- ) - write bl write " HTTP/1.0" write crlf - "Host: " write write crlf ; +DEFER: (http-request) -: get-request ( host resource -- ) - "GET" http-request crlf ; +: absolute-redirect ( url -- request ) + "request" get request-with-url ; -DEFER: http-get-stream +: relative-redirect ( path -- request ) + "request" get swap store-path ; -: do-redirect ( code headers stream -- code headers stream ) - #! Should this support Location: headers that are - #! relative URLs? - pick 100 /i 3 = [ - dispose "location" swap peek-at nip http-get-stream - ] when ; +: do-redirect ( response -- response stream ) + dup response-code 300 399 between? [ + header>> "location" swap at + dup "http://" head? [ + absolute-redirect + ] [ + relative-redirect + ] if "GET" >>method (http-request) + ] [ + stdio get + ] if ; -: default-timeout 1 minutes over set-timeout ; +: (http-request) ( request -- response stream ) + dup host>> over port>> stdio set + dup "r" set-global write-request flush read-response + do-redirect ; -: http-get-stream ( url -- code headers stream ) - #! Opens a stream for reading from an HTTP URL. - parse-url over parse-host [ - [ [ get-request read-response ] with-stream* ] keep - default-timeout - ] [ ] [ dispose ] cleanup do-redirect ; +PRIVATE> + +: http-request ( url request -- response stream ) + [ + request-with-url + [ + (http-request) + 1 minutes over set-timeout + ] [ ] [ stdio get dispose ] cleanup + ] with-scope ; + +: ( -- request ) + "GET" >>method ; + +: http-get-stream ( url -- response stream ) + http-request ; : success? ( code -- ? ) 200 = ; -: check-response ( code headers stream -- stream ) - nip swap success? +: check-response ( response stream -- stream ) + swap code>> success? [ dispose "HTTP download failed" throw ] unless ; : http-get ( url -- string ) @@ -70,23 +77,18 @@ DEFER: http-get-stream : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get-stream check-response - r> stream-copy ; + swap http-get-stream check-response + [ swap binary stream-copy ] with-disposal ; : download ( url -- ) dup download-name download-to ; -: post-request ( content-type content host resource -- ) - #! Note: It is up to the caller to url encode the content if - #! it is required according to the content-type. - "POST" http-request [ - "Content-Length: " write length number>string write crlf - "Content-Type: " write url-encode write crlf - crlf - ] keep write ; +: ( content-type content -- request ) + + "POST" >>method + swap >>post-data + swap >>post-data-type ; -: http-post ( content-type content url -- code headers string ) - #! Make a POST request. The content is URL encoded for you. - parse-url over parse-host [ - post-request flush read-response stdio get contents - ] with-stream ; +: http-post ( content-type content url -- response string ) + #! The content is URL encoded for you. + -rot url-encode http-request contents ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor old mode 100644 new mode 100755 index 5146502644..b706f34d13 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,6 @@ -USING: http tools.test ; -IN: temporary +USING: http tools.test multiline tuple-syntax +io.streams.string kernel arrays splitting sequences ; +IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -16,3 +17,113 @@ IN: temporary [ "%20%21%20" ] [ " ! " url-encode ] unit-test [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +[ "/" ] [ "http://foo.com" url>path ] unit-test +[ "/" ] [ "http://foo.com/" url>path ] unit-test +[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test +[ "/bar" ] [ "/bar" url>path ] unit-test + +STRING: read-request-test-1 +GET http://foo/bar HTTP/1.1 +Some-Header: 1 +Some-Header: 2 +Content-Length: 4 + +blah +; + +[ + TUPLE{ request + port: 80 + method: "GET" + path: "/bar" + query: H{ } + version: "1.1" + header: H{ { "some-header" "1; 2" } { "content-length" "4" } } + post-data: "blah" + cookies: V{ } + } +] [ + read-request-test-1 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-request-test-1' +GET /bar HTTP/1.1 +content-length: 4 +some-header: 1; 2 + +blah +; + +read-request-test-1' 1array [ + read-request-test-1 + [ read-request ] with-string-reader + [ write-request ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test + +STRING: read-request-test-2 +HEAD http://foo/bar HTTP/1.1 +Host: www.sex.com +; + +[ + TUPLE{ request + port: 80 + method: "HEAD" + path: "/bar" + query: H{ } + version: "1.1" + header: H{ { "host" "www.sex.com" } } + host: "www.sex.com" + cookies: V{ } + } +] [ + read-request-test-2 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-response-test-1 +HTTP/1.1 404 not found +Content-Type: text/html + +blah +; + +[ + TUPLE{ response + version: "1.1" + code: 404 + message: "not found" + header: H{ { "content-type" "text/html" } } + cookies: V{ } + } +] [ + read-response-test-1 + [ read-response ] with-string-reader +] unit-test + + +STRING: read-response-test-1' +HTTP/1.1 404 not found +content-type: text/html + + +; + +read-response-test-1' 1array [ + read-response-test-1 + [ read-response ] with-string-reader + [ write-response ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test + +[ t ] [ + "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT" + dup parse-cookies unparse-cookies = +] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 5c4dae94c7..849b9e2fc9 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,19 +1,13 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ascii io.encodings.utf8 assocs.lib -namespaces unicode.case ; +USING: hashtables io io.streams.string kernel math namespaces +math.parser assocs sequences strings splitting ascii +io.encodings.utf8 io.encodings.string namespaces +unicode.case combinators vectors sorting new-slots accessors +calendar calendar.format quotations arrays ; IN: http -: header-line ( line -- ) - ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; - -: (read-header) ( -- ) - readln dup - empty? [ drop ] [ header-line (read-header) ] if ; - -: read-header ( -- hash ) - [ (read-header) ] H{ } make-assoc ; +: http-port 80 ; inline : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -23,8 +17,8 @@ IN: http over digit? or swap "/_-." member? or ; foldable -: push-utf8 ( string -- ) - 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; +: push-utf8 ( ch -- ) + 1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) [ [ @@ -56,19 +50,377 @@ IN: http ] if ; : url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make decode-utf8 ; + [ 0 swap url-decode-iter ] "" make utf8 decode ; -: hash>query ( hash -- str ) +: crlf "\r\n" write ; + +: add-header ( value key assoc -- ) + [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ; + +: header-line ( line -- ) + dup first blank? [ + [ blank? ] left-trim + "last-header" get + "header" get + add-header + ] [ + ": " split1 dup [ + swap >lower dup "last-header" set + "header" get add-header + ] [ + 2drop + ] if + ] if ; + +: read-header-line ( -- ) + readln dup + empty? [ drop ] [ header-line read-header-line ] if ; + +: read-header ( -- assoc ) + H{ } clone [ + "header" [ read-header-line ] with-variable + ] keep ; + +: header-value>string ( value -- string ) + { + { [ dup number? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup string? ] [ ] } + { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + } cond ; + +: check-header-string ( str -- str ) + #! http://en.wikipedia.org/wiki/HTTP_Header_Injection + dup [ "\r\n" member? ] contains? + [ "Header injection attack" throw ] when ; + +: write-header ( assoc -- ) + >alist sort-keys [ + swap url-encode write ": " write + header-value>string check-header-string write crlf + ] assoc-each crlf ; + +: query>assoc ( query -- assoc ) + dup [ + "&" split [ + "=" split1 [ dup [ url-decode ] when ] 2apply + ] H{ } map>assoc + ] when ; + +: assoc>query ( hash -- str ) [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map "&" join ; -: build-url ( str query-params -- newstr ) +TUPLE: cookie name value path domain expires http-only ; + +: ( value name -- cookie ) + cookie construct-empty + swap >>name swap >>value ; + +: parse-cookies ( string -- seq ) [ - over % - dup assoc-empty? [ - 2drop - ] [ - CHAR: ? rot member? "&" "?" ? % - hash>query % - ] if - ] "" make ; + f swap + + ";" split [ + [ blank? ] trim "=" split1 swap >lower { + { "expires" [ >>expires ] } + { "domain" [ >>domain ] } + { "path" [ >>path ] } + { "httponly" [ drop t >>http-only ] } + { "" [ drop ] } + [ dup , nip ] + } case + ] each + + drop + ] { } make ; + +: (unparse-cookie) ( key value -- ) + { + { [ dup f eq? ] [ 2drop ] } + { [ dup t eq? ] [ drop , ] } + { [ t ] [ "=" swap 3append , ] } + } cond ; + +: unparse-cookie ( cookie -- strings ) + [ + dup name>> >lower over value>> (unparse-cookie) + "path" over path>> (unparse-cookie) + "domain" over domain>> (unparse-cookie) + "expires" over expires>> (unparse-cookie) + "httponly" over http-only>> (unparse-cookie) + drop + ] { } make ; + +: unparse-cookies ( cookies -- string ) + [ unparse-cookie ] map concat "; " join ; + +TUPLE: request +host +port +method +path +query +version +header +post-data +post-data-type +cookies ; + +: + request construct-empty + "1.1" >>version + http-port >>port + H{ } clone >>query + V{ } clone >>cookies ; + +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; + +: chop-hostname ( str -- str' ) + CHAR: / over index over length or tail + dup empty? [ drop "/" ] when ; + +: url>path ( url -- path ) + #! Technically, only proxies are meant to support hostnames + #! in HTTP requests, but IE sends these sometimes so we + #! just chop the hostname part. + url-decode "http://" ?head [ chop-hostname ] when ; + +: read-method ( request -- request ) + " " read-until [ "Bad request: method" throw ] unless + >>method ; + +: read-query ( request -- request ) + " " read-until + [ "Bad request: query params" throw ] unless + query>assoc >>query ; + +: read-url ( request -- request ) + " ?" read-until { + { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } + { CHAR: ? [ url>path >>path read-query ] } + [ "Bad request: URL" throw ] + } case ; + +: parse-version ( string -- version ) + "HTTP/" ?head [ "Bad version" throw ] unless + dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; + +: read-request-version ( request -- request ) + readln [ CHAR: \s = ] left-trim + parse-version + >>version ; + +: read-request-header ( request -- request ) + read-header >>header ; + +: header ( request/response key -- value ) + swap header>> at ; + +SYMBOL: max-post-request + +1024 256 * max-post-request set-global + +: content-length ( header -- n ) + "content-length" swap at string>number dup [ + dup max-post-request get > [ + "content-length > max-post-request" throw + ] when + ] when ; + +: read-post-data ( request -- request ) + dup header>> content-length [ read >>post-data ] when* ; + +: parse-host ( string -- host port ) + "." ?tail drop ":" split1 + [ string>number ] [ http-port ] if* ; + +: extract-host ( request -- request ) + dup "host" header parse-host >r >>host r> >>port ; + +: extract-post-data-type ( request -- request ) + dup "content-type" header >>post-data-type ; + +: extract-cookies ( request -- request ) + dup "cookie" header [ parse-cookies >>cookies ] when* ; + +: read-request ( -- request ) + + read-method + read-url + read-request-version + read-request-header + read-post-data + extract-host + extract-post-data-type + extract-cookies ; + +: write-method ( request -- request ) + dup method>> write bl ; + +: write-url ( request -- request ) + dup path>> url-encode write + dup query>> dup assoc-empty? [ drop ] [ + "?" write + assoc>query write + ] if ; + +: write-request-url ( request -- request ) + write-url bl ; + +: write-version ( request -- request ) + "HTTP/" write dup request-version write crlf ; + +: write-request-header ( request -- request ) + dup header>> >hashtable + over host>> [ "host" pick set-at ] when* + over post-data>> [ length "content-length" pick set-at ] when* + over post-data-type>> [ "content-type" pick set-at ] when* + over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* + write-header ; + +: write-post-data ( request -- request ) + dup post-data>> [ write ] when* ; + +: write-request ( request -- ) + write-method + write-request-url + write-version + write-request-header + write-post-data + flush + drop ; + +: request-url ( request -- url ) + [ + dup host>> [ + "http://" write + dup host>> url-encode write + ":" write + dup port>> number>string write + ] when + dup path>> "/" head? [ "/" write ] unless + write-url + drop + ] with-string-writer ; + +: set-header ( request/response value key -- request/response ) + pick header>> set-at ; + +GENERIC: write-response ( response -- ) + +GENERIC: write-full-response ( request response -- ) + +TUPLE: response +version +code +message +header +cookies +body ; + +: + response construct-empty + "1.1" >>version + H{ } clone >>header + "close" "connection" set-header + now timestamp>http-string "date" set-header + V{ } clone >>cookies ; + +: read-response-version + " \t" read-until + [ "Bad response: version" throw ] unless + parse-version + >>version ; + +: read-response-code + " \t" read-until [ "Bad response: code" throw ] unless + string>number [ "Bad response: code" throw ] unless* + >>code ; + +: read-response-message + readln >>message ; + +: read-response-header + read-header >>header + dup "set-cookie" header [ parse-cookies >>cookies ] when* ; + +: read-response ( -- response ) + + read-response-version + read-response-code + read-response-message + read-response-header ; + +: write-response-version ( response -- response ) + "HTTP/" write + dup version>> write bl ; + +: write-response-code ( response -- response ) + dup code>> number>string write bl ; + +: write-response-message ( response -- response ) + dup message>> write crlf ; + +: write-response-header ( response -- response ) + dup header>> clone + over cookies>> f like + [ unparse-cookies "set-cookie" pick set-at ] when* + write-header ; + +: write-response-body ( response -- response ) + dup body>> { + { [ dup not ] [ drop ] } + { [ dup string? ] [ write ] } + { [ dup callable? ] [ call ] } + { [ t ] [ stdio get stream-copy ] } + } cond ; + +M: response write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-header + flush + drop ; + +M: response write-full-response ( request response -- ) + dup write-response + swap method>> "HEAD" = [ write-response-body ] unless ; + +: set-content-type ( request/response content-type -- request/response ) + "content-type" set-header ; + +: get-cookie ( request/response name -- cookie/f ) + >r cookies>> r> [ swap name>> = ] curry find nip ; + +: delete-cookie ( request/response name -- ) + over cookies>> >r get-cookie r> delete ; + +: put-cookie ( request/response cookie -- request/response ) + [ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep + over cookies>> push ; + +TUPLE: raw-response +version +code +message +body ; + +: ( -- response ) + raw-response construct-empty + "1.1" >>version ; + +M: raw-response write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-body + drop ; + +M: raw-response write-full-response ( response -- ) + write-response nip ; diff --git a/extra/http/mime/mime.factor b/extra/http/mime/mime.factor old mode 100644 new mode 100755 index 3365127d87..f9097ecce3 --- a/extra/http/mime/mime.factor +++ b/extra/http/mime/mime.factor @@ -30,5 +30,6 @@ H{ { "pdf" "application/pdf" } { "factor" "text/plain" } + { "cgi" "application/x-cgi-script" } { "fhtml" "application/x-factor-server-page" } } "mime-types" set-global diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor new file mode 100644 index 0000000000..13089ae6e8 --- /dev/null +++ b/extra/http/server/actions/actions-tests.factor @@ -0,0 +1,39 @@ +IN: http.server.actions.tests +USING: http.server.actions tools.test math math.parser +multiline namespaces http io.streams.string http.server +sequences accessors ; + + + [ "a" get "b" get + ] >>get + { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params +"action-1" set + +STRING: action-request-test-1 +GET http://foo/bar?a=12&b=13 HTTP/1.1 + +blah +; + +[ 25 ] [ + action-request-test-1 [ read-request ] with-string-reader + "/blah" + "action-1" get call-responder +] unit-test + + + [ +path+ get "xxx" get "X" concat append ] >>post + { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params +"action-2" set + +STRING: action-request-test-2 +POST http://foo/bar/baz HTTP/1.1 +content-length: 5 + +xxx=4 +; + +[ "/blahXXXX" ] [ + action-request-test-2 [ read-request ] with-string-reader + "/blah" + "action-2" get call-responder +] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor new file mode 100755 index 0000000000..5e5b7a9563 --- /dev/null +++ b/extra/http/server/actions/actions.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots sequences kernel assocs combinators +http.server http.server.validators http hashtables namespaces ; +IN: http.server.actions + +SYMBOL: +path+ + +TUPLE: action get get-params post post-params revalidate ; + +: + action construct-empty + [ <400> ] >>get + [ <400> ] >>post + [ <400> ] >>revalidate ; + +: extract-params ( request path -- assoc ) + >r dup method>> { + { "GET" [ query>> ] } + { "POST" [ post-data>> query>assoc ] } + } case r> +path+ associate union ; + +: action-params ( request path param -- error? ) + -rot extract-params validate-params ; + +: get-action ( request path -- response ) + action get get-params>> action-params + [ <400> ] [ action get get>> call ] if ; + +: post-action ( request path -- response ) + action get post-params>> action-params + [ action get revalidate>> ] [ action get post>> ] if call ; + +M: action call-responder ( request path action -- response ) + action set + over request set + over method>> + { + { "GET" [ get-action ] } + { "POST" [ post-action ] } + } case ; diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor new file mode 100755 index 0000000000..2ea74febba --- /dev/null +++ b/extra/http/server/auth/basic/basic.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.auth.providers.null +http sequences ; +IN: http.server.auth.basic + +TUPLE: basic-auth responder realm provider ; + +C: basic-auth + +: authorization-ok? ( provider header -- ? ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 spin check-login + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +: logged-in? ( request responder -- ? ) + provider>> swap "authorization" header authorization-ok? ; + +M: basic-auth call-responder ( request path responder -- response ) + pick over logged-in? + [ responder>> call-responder ] [ 2nip realm>> <401> ] if ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor new file mode 100755 index 0000000000..e2f9a3608a --- /dev/null +++ b/extra/http/server/auth/login/login.factor @@ -0,0 +1,69 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.actions +http.server.sessions http.server.templating.fhtml http sequences +io.files namespaces ; +IN: http.server.auth.login + +TUPLE: login-auth responder provider ; + +C: (login-auth) login-auth + +SYMBOL: logged-in? +SYMBOL: provider +SYMBOL: post-login-url + +: login-page ( -- response ) + "text/html" [ + "extra/http/server/auth/login/login.fhtml" + resource-path run-template-file + ] >>body ; + +: + + [ login-page ] >>get + + { + { "name" [ ] } + { "password" [ ] } + } >>post-params + [ + "password" get + "name" get + provider sget check-login [ + t logged-in? sset + post-login-url sget + ] [ + login-page + ] if + ] >>post ; + +: + + [ + f logged-in? sset + request get "login" + ] >>post ; + +M: login-auth call-responder ( request path responder -- response ) + logged-in? sget + [ responder>> call-responder ] [ + pick method>> "GET" = [ + nip + provider>> provider sset + dup request-url post-login-url sset + "login" f session-link + ] [ + 3drop <400> + ] if + ] if ; + +: ( responder provider -- auth ) + (login-auth) + + swap >>default + "login" add-responder + "logout" add-responder + ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml new file mode 100755 index 0000000000..9bb1438588 --- /dev/null +++ b/extra/http/server/auth/login/login.fhtml @@ -0,0 +1,25 @@ + + +

Login required

+ +
+ + + + + + + + + + + + +
User name:
Password:
+ + + +
+ + + diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor new file mode 100755 index 0000000000..3270fe06e3 --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -0,0 +1,18 @@ +IN: http.server.auth.providers.assoc.tests +USING: http.server.auth.providers +http.server.auth.providers.assoc tools.test +namespaces ; + + "provider" set + +"slava" "provider" get new-user + +[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + +[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + +[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + +"fdasf" "slava" "provider" get set-password + +[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor new file mode 100755 index 0000000000..d57be622c7 --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.auth.providers.assoc +USING: new-slots accessors assocs kernel +http.server.auth.providers ; + +TUPLE: assoc-auth-provider assoc ; + +: ( -- provider ) + H{ } clone assoc-auth-provider construct-boa ; + +M: assoc-auth-provider check-login + assoc>> at = ; + +M: assoc-auth-provider new-user + assoc>> + 2dup key? [ drop user-exists ] when + t -rot set-at ; + +M: assoc-auth-provider set-password + assoc>> + 2dup key? [ drop no-such-user ] unless + set-at ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor new file mode 100755 index 0000000000..c4682c2051 --- /dev/null +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -0,0 +1,25 @@ +IN: http.server.auth.providers.db.tests +USING: http.server.auth.providers +http.server.auth.providers.db tools.test +namespaces db db.sqlite db.tuples continuations +io.files ; + +db-auth-provider "provider" set + +"auth-test.db" temp-file sqlite-db [ + + [ user drop-table ] ignore-errors + [ user create-table ] ignore-errors + + "slava" "provider" get new-user + + [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + + [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + + [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + + "fdasf" "slava" "provider" get set-password + + [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test +] with-db diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor new file mode 100755 index 0000000000..9583122875 --- /dev/null +++ b/extra/http/server/auth/providers/db/db.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db db.tuples db.types new-slots accessors +http.server.auth.providers kernel ; +IN: http.server.auth.providers.db + +TUPLE: user name password ; + +: user construct-empty ; + +user "USERS" +{ + { "name" "NAME" { VARCHAR 256 } +assigned-id+ } + { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } +} define-persistent + +: init-users-table ( -- ) + user create-table ; + +TUPLE: db-auth-provider ; + +: db-auth-provider T{ db-auth-provider } ; + +M: db-auth-provider check-login + drop + + swap >>name + swap >>password + select-tuple >boolean ; + +M: db-auth-provider new-user + drop + [ + + swap >>name + + dup select-tuple [ name>> user-exists ] when + + "unassigned" >>password + + insert-tuple + ] with-transaction ; + +M: db-auth-provider set-password + drop + [ + + swap >>name + + dup select-tuple [ ] [ no-such-user ] ?if + + swap >>password update-tuple + ] with-transaction ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor new file mode 100755 index 0000000000..702111972e --- /dev/null +++ b/extra/http/server/auth/providers/null/null.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.auth.providers kernel ; +IN: http.server.auth.providers.null + +TUPLE: null-auth-provider ; + +: null-auth-provider T{ null-auth-provider } ; + +M: null-auth-provider check-login 3drop f ; + +M: null-auth-provider new-user 3drop f ; + +M: null-auth-provider set-password 3drop f ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor new file mode 100755 index 0000000000..1e0fd33a67 --- /dev/null +++ b/extra/http/server/auth/providers/providers.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: http.server.auth.providers + +GENERIC: check-login ( password user provider -- ? ) + +GENERIC: new-user ( user provider -- ) + +GENERIC: set-password ( password user provider -- ) + +TUPLE: user-exists name ; + +: user-exists ( name -- * ) \ user-exists construct-boa throw ; + +TUPLE: no-such-user name ; + +: no-such-user ( name -- * ) \ no-such-user construct-boa throw ; diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor new file mode 100755 index 0000000000..b6dbed4b62 --- /dev/null +++ b/extra/http/server/authentication/basic/basic.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.authentication.basic +USING: accessors new-slots quotations assocs kernel splitting +base64 crypto.sha2 html.elements io combinators http.server +http sequences ; + +! 'users' is a quotation or an assoc. The quotation +! has stack effect ( sha-256-string username -- ? ). +! It should perform the user authentication. 'sha-256-string' +! is the plain text password provided by the user passed through +! 'string>sha-256-string'. If 'users' is an assoc then +! it is a mapping of usernames to sha-256 hashed passwords. +TUPLE: realm responder name users ; + +C: realm + +: user-authorized? ( password username realm -- ? ) + users>> { + { [ dup callable? ] [ call ] } + { [ dup assoc? ] [ at = ] } + } cond ; + +: authorization-ok? ( realm header -- bool ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 string>sha-256-string + spin user-authorized? + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot name>> "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +M: realm call-responder ( request path realm -- response ) + pick "authorization" header dupd authorization-ok? + [ responder>> call-responder ] [ 2nip <401> ] if ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor new file mode 100755 index 0000000000..fd2e8f8ad7 --- /dev/null +++ b/extra/http/server/callbacks/callbacks.factor @@ -0,0 +1,135 @@ +! Copyright (C) 2004 Chris Double. +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: html http http.server io kernel math namespaces +continuations calendar sequences assocs new-slots hashtables +accessors arrays alarms quotations combinators ; +IN: http.server.callbacks + +SYMBOL: responder + +TUPLE: callback-responder responder callbacks ; + +: ( responder -- responder' ) + #! A continuation responder is a special type of session + #! manager. However it works entirely differently from + #! the URL and cookie session managers. + H{ } clone callback-responder construct-boa ; + +TUPLE: callback cont quot expires alarm responder ; + +: timeout 20 minutes ; + +: timeout-callback ( callback -- ) + dup alarm>> cancel-alarm + dup responder>> callbacks>> delete-at ; + +: touch-callback ( callback -- ) + dup expires>> [ + dup alarm>> [ cancel-alarm ] when* + dup [ timeout-callback ] curry timeout later >>alarm + ] when drop ; + +: ( cont quot expires? -- callback ) + [ f responder get callback construct-boa ] keep + [ dup touch-callback ] when ; + +: invoke-callback ( request exit-cont callback -- response ) + [ quot>> 3array ] keep cont>> continue-with ; + +: register-callback ( cont quot expires? -- id ) + + responder get callbacks>> generate-key + [ responder get callbacks>> set-at ] keep ; + +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: forward-to-url ( url -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + request get swap exit-with ; + +: cont-id "factorcontid" ; + +: id>url ( id -- url ) + request get + swap cont-id associate >>query + request-url ; + +: forward-to-id ( id -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + id>url forward-to-url ; + +: restore-request ( pair -- ) + first3 >r exit-continuation set request set r> call ; + +: resume-page ( request page responder callback -- * ) + dup touch-callback + >r 2drop exit-continuation get + r> invoke-callback ; + +SYMBOL: post-refresh-get? + +: redirect-to-here ( -- ) + #! Force a redirect to the client browser so that the browser + #! goes to the current point in the code. This forces an URL + #! change on the browser so that refreshing that URL will + #! immediately run from this code point. This prevents the + #! "this request will issue a POST" warning from the browser + #! and prevents re-running the previous POST logic. This is + #! known as the 'post-refresh-get' pattern. + post-refresh-get? get [ + [ + [ ] t register-callback forward-to-id + ] callcc1 restore-request + ] [ + post-refresh-get? on + ] if ; + +SYMBOL: current-show + +: store-current-show ( -- ) + #! Store the current continuation in the variable 'current-show' + #! so it can be returned to later by 'quot-id'. Note that it + #! recalls itself when the continuation is called to ensure that + #! it resets its value back to the most recent show call. + [ current-show set f ] callcc1 + [ restore-request store-current-show ] when* ; + +: show-final ( quot -- * ) + >r redirect-to-here store-current-show + r> call exit-with ; inline + +M: callback-responder call-responder + [ + [ + exit-continuation set + dup responder set + pick request set + pick cont-id query-param over callbacks>> at [ + resume-page + ] [ + responder>> call-responder + "Continuation responder pages must use show-final" throw + ] if* + ] with-scope + ] callcc1 >r 3drop r> ; + +: show-page ( quot -- ) + >r redirect-to-here store-current-show r> + [ + [ ] register-callback + with-scope + exit-with + ] callcc1 restore-request ; inline + +: quot-id ( quot -- id ) + current-show get swap t register-callback ; + +: quot-url ( quot -- url ) + quot-id id>url ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor new file mode 100755 index 0000000000..9950a9a4a4 --- /dev/null +++ b/extra/http/server/cgi/cgi.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel assocs io.files combinators +arrays io.launcher io http.server.static http.server +http accessors sequences strings math.parser ; +IN: http.server.cgi + +: post? request get method>> "POST" = ; + +: cgi-variables ( script-path -- assoc ) + #! This needs some work. + [ + "CGI/1.0" "GATEWAY_INTERFACE" set + "HTTP/" request get version>> append "SERVER_PROTOCOL" set + "Factor" "SERVER_SOFTWARE" set + + dup "PATH_TRANSLATED" set + "SCRIPT_FILENAME" set + + request get path>> "SCRIPT_NAME" set + + request get host>> "SERVER_NAME" set + request get port>> number>string "SERVER_PORT" set + "" "PATH_INFO" set + "" "REMOTE_HOST" set + "" "REMOTE_ADDR" set + "" "AUTH_TYPE" set + "" "REMOTE_USER" set + "" "REMOTE_IDENT" set + + request get method>> "REQUEST_METHOD" set + request get query>> assoc>query "QUERY_STRING" set + request get "cookie" header "HTTP_COOKIE" set + + request get "user-agent" header "HTTP_USER_AGENT" set + request get "accept" header "HTTP_ACCEPT" set + + post? [ + request get post-data-type>> "CONTENT_TYPE" set + request get post-data>> length number>string "CONTENT_LENGTH" set + ] when + ] H{ } make-assoc ; + +: cgi-descriptor ( name -- desc ) + [ + dup 1array +arguments+ set + cgi-variables +environment+ set + ] H{ } make-assoc ; + +: serve-cgi ( name -- response ) + + 200 >>code + "CGI output follows" >>message + swap [ + stdio get swap cgi-descriptor [ + post? [ + request get post-data>> write flush + ] when + stdio get swap (stream-copy) + ] with-stream + ] curry >>body ; + +: enable-cgi ( responder -- responder ) + [ serve-cgi ] "application/x-cgi-script" + pick special>> set-at ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor new file mode 100644 index 0000000000..6fefb1b5dd --- /dev/null +++ b/extra/http/server/components/components.factor @@ -0,0 +1,129 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: new-slots html.elements http.server.validators +accessors namespaces kernel io farkup math.parser assocs +classes words tuples arrays sequences io.files +http.server.templating.fhtml splitting ; +IN: http.server.components + +SYMBOL: components + +TUPLE: component id ; + +: component ( name -- component ) + dup components get at + [ ] [ "No such component: " swap append throw ] ?if ; + +GENERIC: validate* ( string component -- result ) +GENERIC: render-view* ( value component -- ) +GENERIC: render-edit* ( value component -- ) +GENERIC: render-error* ( reason value component -- ) + +SYMBOL: values + +: value values get at ; + +: render-view ( component -- ) + dup id>> value swap render-view* ; + +: render-error ( error -- ) + write ; + +: render-edit ( component -- ) + dup id>> value dup validation-error? [ + dup reason>> swap value>> rot render-error* + ] [ + swap render-edit* + ] if ; + +: ( id string -- component ) + >r \ component construct-boa r> construct-delegate ; inline + +TUPLE: string min max ; + +: ( id -- component ) string ; + +M: string validate* + [ min>> v-min-length ] keep max>> v-max-length ; + +M: string render-view* + drop write ; + +: render-input + > dup =id =name =value input/> ; + +M: string render-edit* + render-input ; + +M: string render-error* + render-input render-error ; + +TUPLE: text ; + +: ( id -- component ) text construct-delegate ; + +: render-textarea + ; + +M: text render-edit* + render-textarea ; + +M: text render-error* + render-textarea render-error ; + +TUPLE: farkup ; + +: ( id -- component ) farkup construct-delegate ; + +M: farkup render-view* + drop string-lines "\n" join convert-farkup write ; + +TUPLE: number min max ; + +: ( id -- component ) number ; + +M: number validate* + >r v-number r> [ min>> v-min-value ] keep max>> v-max-value ; + +M: number render-view* + drop number>string write ; + +M: number render-edit* + >r number>string r> render-input ; + +M: number render-error* + render-input render-error ; + +: tuple>slots ( tuple -- alist ) + dup class "slot-names" word-prop swap tuple-slots + 2array flip ; + +: with-components ( tuple components quot -- ) + [ + >r components set + dup tuple>slots values set + tuple set + r> call + ] with-scope ; inline + +TUPLE: form view-template edit-template components ; + +:
( id view-template edit-template -- form ) + V{ } clone form construct-boa + swap \ component construct-boa + over set-delegate ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +M: form render-view* ( value form -- ) + dup components>> + swap view-template>> + [ resource-path run-template-file ] curry + with-components ; + +M: form render-edit* ( value form -- ) + dup components>> + swap edit-template>> + [ resource-path run-template-file ] curry + with-components ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor new file mode 100644 index 0000000000..099ded2f7f --- /dev/null +++ b/extra/http/server/crud/crud.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.crud +USING: kernel namespaces db.tuples math.parser +http.server.actions accessors ; + +: by-id ( class -- tuple ) + construct-empty "id" get >>id ; + +: ( class -- action ) + + { { "id" [ string>number ] } } >>post-params + swap [ by-id delete-tuple f ] curry >>post ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor new file mode 100755 index 0000000000..511921ce06 --- /dev/null +++ b/extra/http/server/db/db.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db http.server kernel new-slots accessors +continuations namespaces destructors ; +IN: http.server.db + +TUPLE: db-persistence responder db params ; + +C: db-persistence + +: connect-db ( db-persistence -- ) + dup db>> swap params>> make-db + dup db set + dup db-open + add-always-destructor ; + +M: db-persistence call-responder + dup connect-db responder>> call-responder ; diff --git a/extra/http/server/responders/authors.txt b/extra/http/server/responders/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/http/server/responders/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor deleted file mode 100755 index ac317e2605..0000000000 --- a/extra/http/server/responders/responders.factor +++ /dev/null @@ -1,225 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs hashtables html html.elements splitting -http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib logging ; - -IN: http.server.responders - -! Variables -SYMBOL: vhosts -SYMBOL: responders - -: >header ( value key -- multi-hash ) - H{ } clone [ insert-at ] keep ; - -: print-header ( alist -- ) - [ swap write ": " write print ] multi-assoc-each nl ; - -: response ( msg -- ) "HTTP/1.0 " write print ; - -: error-body ( error -- ) -

write

; - -: error-head ( error -- ) - response - H{ { "Content-Type" V{ "text/html" } } } print-header nl ; - -: httpd-error ( error -- ) - #! This must be run from handle-request - dup error-head - "head" "method" get = [ drop ] [ error-body ] if ; - -\ httpd-error ERROR add-error-logging - -: bad-request ( -- ) - [ - ! Make httpd-error print a body - "get" "method" set - "400 Bad request" httpd-error - ] with-scope ; - -: serving-content ( mime -- ) - "200 Document follows" response - "Content-Type" >header print-header ; - -: serving-html "text/html" serving-content ; - -: serve-html ( quot -- ) - serving-html with-html-stream ; - -: serving-text "text/plain" serving-content ; - -: redirect ( to response -- ) - response "Location" >header print-header ; - -: permanent-redirect ( to -- ) - "301 Moved Permanently" redirect ; - -: temporary-redirect ( to -- ) - "307 Temporary Redirect" redirect ; - -: directory-no/ ( -- ) - [ - "request" get % CHAR: / , - "raw-query" get [ CHAR: ? , % ] when* - ] "" make permanent-redirect ; - -: query>hash ( query -- hash ) - dup [ - "&" split [ - "=" split1 [ dup [ url-decode ] when ] 2apply 2array - ] map - ] when >hashtable ; - -SYMBOL: max-post-request - -1024 256 * max-post-request set-global - -: content-length ( header -- n ) - "content-length" swap peek-at string>number dup [ - dup max-post-request get > [ - "Content-Length > max-post-request" throw - ] when - ] when ; - -: read-post-request ( header -- str hash ) - content-length [ read dup query>hash ] [ f f ] if* ; - -LOG: log-headers DEBUG - -: interesting-headers ( assoc -- string ) - [ - [ - drop { - "user-agent" - "referer" - "x-forwarded-for" - "host" - } member? - ] assoc-subset [ - ": " swap 3append % "\n" % - ] multi-assoc-each - ] "" make ; - -: prepare-url ( url -- url ) - #! This is executed in the with-request namespace. - "?" split1 - dup "raw-query" set query>hash "query" set - dup "request" set ; - -: prepare-header ( -- ) - read-header - dup "header" set - dup interesting-headers log-headers - read-post-request "response" set "raw-response" set ; - -! Responders are called in a new namespace with these -! variables: - -! - method -- one of get, post, or head. -! - request -- the entire URL requested, including responder -! name -! - responder-url -- the component of the URL for the responder -! - raw-query -- raw query string -! - query -- a hashtable of query parameters, eg -! foo.bar?a=b&c=d becomes -! H{ { "a" "b" } { "c" "d" } } -! - header -- a hashtable of headers from the user's client -! - response -- a hashtable of the POST request response -! - raw-response -- raw POST request response - -: query-param ( key -- value ) "query" get at ; - -: header-param ( key -- value ) - "header" get peek-at ; - -: host ( -- string ) - #! The host the current responder was called from. - "host" header-param ":" split1 drop ; - -: add-responder ( responder -- ) - #! Add a responder object to the list. - "responder" over at responders get set-at ; - -: make-responder ( quot -- ) - #! quot has stack effect ( url -- ) - [ - [ - drop "GET method not implemented" httpd-error - ] "get" set - [ - drop "POST method not implemented" httpd-error - ] "post" set - [ - drop "HEAD method not implemented" httpd-error - ] "head" set - [ - drop bad-request - ] "bad" set - - call - ] H{ } make-assoc add-responder ; - -: add-simple-responder ( name quot -- ) - [ - [ drop ] swap append dup "get" set "post" set - "responder" set - ] make-responder ; - -: vhost ( name -- vhost ) - vhosts get at [ "default" vhost ] unless* ; - -: responder ( name -- responder ) - responders get at [ "404" responder ] unless* ; - -: set-default-responder ( name -- ) - responder "default" responders get set-at ; - -: call-responder ( method argument responder -- ) - over "argument" set [ swap get with-scope ] bind ; - -: serve-default-responder ( method url -- ) - "/" "responder-url" set - "default" responder call-responder ; - -: trim-/ ( url -- url ) - #! Trim a leading /, if there is one. - "/" ?head drop ; - -: serve-explicit-responder ( method url -- ) - "/" split1 - "/responder/" pick "/" 3append "responder-url" set - dup [ - swap responder call-responder - ] [ - ! Just a responder name by itself - drop "request" get "/" append permanent-redirect 2drop - ] if ; - -: serve-responder ( method path host -- ) - #! Responder paths come in two forms: - #! /foo/bar... - default responder used - #! /responder/foo/bar - responder foo, argument bar - vhost [ - trim-/ "responder/" ?head [ - serve-explicit-responder - ] [ - serve-default-responder - ] if - ] bind ; - -\ serve-responder DEBUG add-input-logging - -: no-such-responder ( -- ) - "404 No such responder" httpd-error ; - -! create a responders hash if it doesn't already exist -global [ - responders [ H{ } assoc-like ] change - - ! 404 error message pages are served by this guy - "404" [ no-such-responder ] add-simple-responder - - H{ } clone "default" associate vhosts set -] bind diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 18edd94f12..0635e1f895 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,39 +1,61 @@ -USING: webapps.file http.server.responders http -http.server namespaces io tools.test strings io.server -logging ; -IN: temporary +USING: http.server tools.test kernel namespaces accessors +new-slots io http math sequences assocs ; +IN: http.server.tests -[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test +TUPLE: mock-responder path ; -[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test +C: mock-responder -[ "index.html" ] -[ "http://www.jedit.org/index.html" url>path ] unit-test +M: mock-responder call-responder + 2nip + path>> on + "text/plain" ; -[ "foo/bar" ] -[ "http://www.jedit.org/foo/bar" url>path ] unit-test +: check-dispatch ( tag path -- ? ) + over off + swap default-host get call-responder + write-response get ; -[ "" ] -[ "http://www.jedit.org/" url>path ] unit-test +[ + + "foo" "foo" add-responder + "bar" "bar" add-responder + + "123" "123" add-responder + "default" >>default + "baz" add-responder + default-host set -[ "" ] -[ "http://www.jedit.org" url>path ] unit-test + [ "foo" ] [ + "foo" default-host get find-responder path>> nip + ] unit-test -[ "foobar" ] -[ "foobar" secure-path ] unit-test + [ "bar" ] [ + "bar" default-host get find-responder path>> nip + ] unit-test -[ f ] -[ "foobar/../baz" secure-path ] unit-test + [ t ] [ "foo" "foo" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test + [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test + [ t ] [ "123" "baz/123" check-dispatch ] unit-test + [ t ] [ "123" "baz///123" check-dispatch ] unit-test -[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test -[ ] [ f [ "POO" parse-request ] with-logging ] unit-test + [ t ] [ + + "baz" >>path + "baz" default-host get call-responder + dup code>> 300 399 between? >r + header>> "location" swap at "baz/" tail? r> and + ] unit-test +] with-scope -[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test +[ + + "default" >>default + default-host set -[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ] -[ "Foo=Bar&Baz=Quux" query>hash ] unit-test - -[ H{ { "Baz" " " } } ] -[ "Baz=%20" query>hash ] unit-test - -[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test + [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test +] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index a2f5c3474b..133783114d 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,65 +1,176 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting -threads http http.server.responders sequences prettyprint -io.server logging calendar ; - +threads http sequences prettyprint io.server logging calendar +new-slots html.elements accessors math.parser combinators.lib +vocabs.loader debugger html continuations random combinators +destructors io.encodings.latin1 ; IN: http.server -: (url>path) ( uri -- path ) - url-decode "http://" ?head [ - "/" split1 dup "" ? nip - ] when ; +GENERIC: call-responder ( request path responder -- response ) -: url>path ( uri -- path ) - "?" split1 dup [ - >r (url>path) "?" r> 3append - ] [ - drop (url>path) - ] if ; +TUPLE: trivial-responder response ; -: secure-path ( path -- path ) - ".." over subseq? [ drop f ] when ; +C: trivial-responder -: request-method ( cmd -- method ) - H{ - { "GET" "get" } - { "POST" "post" } - { "HEAD" "head" } - } at "bad" or ; +M: trivial-responder call-responder nip response>> call ; -: (handle-request) ( arg cmd -- method path host ) - request-method dup "method" set swap - prepare-url prepare-header host ; +: trivial-response-body ( code message -- ) + + +

swap number>string write bl write

+ + ; -: handle-request ( arg cmd -- ) - [ (handle-request) serve-responder ] with-scope ; +: ( code message -- response ) + + 2over [ trivial-response-body ] 2curry >>body + "text/html" set-content-type + swap >>message + swap >>code ; -: parse-request ( request -- ) - " " split1 dup [ - " HTTP" split1 drop url>path secure-path dup [ - swap handle-request +: <400> ( -- response ) + 400 "Bad request" ; + +: <404> ( -- response ) + 404 "Not Found" ; + +SYMBOL: 404-responder + +[ drop <404> ] 404-responder set-global + +: modify-for-redirect ( request to -- url ) + { + { [ dup "http://" head? ] [ nip ] } + { [ dup "/" head? ] [ >>path request-url ] } + { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] } + } cond ; + +: ( request to code message -- response ) + + -rot modify-for-redirect + "location" set-header ; + +\ DEBUG add-input-logging + +: ( request to -- response ) + 301 "Moved Permanently" ; + +: ( request to -- response ) + 307 "Temporary Redirect" ; + +: ( content-type -- response ) + + 200 >>code + swap set-content-type ; + +TUPLE: dispatcher default responders ; + +: ( -- dispatcher ) + 404-responder H{ } clone dispatcher construct-boa ; + +: set-main ( dispatcher name -- dispatcher ) + [ ] curry + >>default ; + +: split-path ( path -- rest first ) + [ CHAR: / = ] left-trim "/" split1 swap ; + +: find-responder ( path dispatcher -- path responder ) + over split-path pick responders>> at* + [ >r >r 2drop r> r> ] [ 2drop default>> ] if ; + +: redirect-with-/ ( request -- response ) + dup path>> "/" append ; + +M: dispatcher call-responder + over [ + 3dup find-responder call-responder [ + >r 3drop r> ] [ - 2drop bad-request - ] if + default>> [ + call-responder + ] [ + 3drop f + ] if* + ] if* ] [ - 2drop bad-request + 2drop redirect-with-/ ] if ; -\ parse-request NOTICE add-input-logging +: add-responder ( dispatcher responder path -- dispatcher ) + pick responders>> set-at ; + +: add-main-responder ( dispatcher responder path -- dispatcher ) + [ add-responder ] keep set-main ; + +: ( class -- dispatcher ) + swap construct-delegate ; inline + +SYMBOL: virtual-hosts +SYMBOL: default-host + +virtual-hosts global [ drop H{ } clone ] cache drop +default-host global [ drop 404-responder get-global ] cache drop + +: find-virtual-host ( host -- responder ) + virtual-hosts get at [ default-host get ] unless* ; + +SYMBOL: development-mode + +: <500> ( error -- response ) + 500 "Internal server error" + swap [ + "Internal server error" [ + development-mode get [ + [ print-error nl :c ] with-html-stream + ] [ + 500 "Internal server error" + trivial-response-body + ] if + ] simple-page + ] curry >>body ; + +: do-response ( request response -- ) + dup write-response + swap method>> "HEAD" = + [ drop ] [ write-response-body ] if ; + +: do-request ( request -- response ) + [ + dup dup path>> over host>> + find-virtual-host call-responder + [ <404> ] unless* + ] [ dup \ do-request log-error <500> ] recover ; + +: default-timeout 1 minutes stdio get set-timeout ; + +LOG: httpd-hit NOTICE + +: log-request ( request -- ) + { method>> host>> path>> } map-exec-with httpd-hit ; + +: ?refresh-all ( -- ) + development-mode get-global + [ global [ refresh-all ] bind ] when ; + +: handle-client ( -- ) + [ + default-timeout + ?refresh-all + read-request + dup log-request + do-request do-response + ] with-destructors ; : httpd ( port -- ) - internet-server "http.server" [ - 1 minutes stdio get set-timeout - readln [ parse-request ] when* - ] with-server ; + internet-server "http.server" + latin1 [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main -! Load default webapps -USE: webapps.file -USE: webapps.callback -USE: webapps.continuation -USE: webapps.cgi +: generate-key ( assoc -- str ) + 4 big-random >hex dup pick key? + [ drop generate-key ] [ nip ] if ; diff --git a/extra/furnace/sessions/authors.txt b/extra/http/server/sessions/authors.txt similarity index 100% rename from extra/furnace/sessions/authors.txt rename to extra/http/server/sessions/authors.txt diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor new file mode 100755 index 0000000000..d771737c73 --- /dev/null +++ b/extra/http/server/sessions/sessions-tests.factor @@ -0,0 +1,39 @@ +IN: http.server.sessions.tests +USING: tools.test http.server.sessions math namespaces +kernel accessors ; + +: with-session \ session swap with-variable ; inline + +TUPLE: foo ; + +C: foo + +M: foo init-session drop 0 "x" sset ; + +"1234" f [ + [ ] [ 3 "x" sset ] unit-test + + [ 9 ] [ "x" sget sq ] unit-test + + [ ] [ "x" [ 1- ] schange ] unit-test + + [ 4 ] [ "x" sget sq ] unit-test +] with-session + +[ t ] [ f url-sessions? ] unit-test +[ t ] [ f cookie-sessions? ] unit-test + +[ ] [ + + "manager" set +] unit-test + +[ { 5 0 } ] [ + [ + "manager" get new-session + dup "manager" get get-session [ 5 "a" sset ] with-session + dup "manager" get get-session [ "a" sget , ] with-session + dup "manager" get get-session [ "x" sget , ] with-session + "manager" get get-session delete-session + ] { } make +] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor new file mode 100755 index 0000000000..d7fed6bb64 --- /dev/null +++ b/extra/http/server/sessions/sessions.factor @@ -0,0 +1,114 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs calendar kernel math.parser namespaces random +boxes alarms new-slots accessors http http.server +quotations hashtables sequences ; +IN: http.server.sessions + +! ! ! ! ! ! +! WARNING: this session manager is vulnerable to XSRF attacks +! ! ! ! ! ! + +GENERIC: init-session ( responder -- ) + +M: dispatcher init-session drop ; + +TUPLE: session-manager responder sessions ; + +: ( responder class -- responder' ) + >r H{ } clone session-manager construct-boa r> + construct-delegate ; inline + +TUPLE: session id manager namespace alarm ; + +: ( id manager -- session ) + H{ } clone \ session construct-boa ; + +: timeout ( -- dt ) 20 minutes ; + +: cancel-timeout ( session -- ) + alarm>> [ cancel-alarm ] if-box? ; + +: delete-session ( session -- ) + dup cancel-timeout + dup manager>> sessions>> delete-at ; + +: touch-session ( session -- ) + dup cancel-timeout + dup [ delete-session ] curry timeout later + swap session-alarm >box ; + +: session ( -- assoc ) \ session get namespace>> ; + +: sget ( key -- value ) session at ; + +: sset ( value key -- ) session set-at ; + +: schange ( key quot -- ) session swap change-at ; inline + +: new-session ( responder -- id ) + [ sessions>> generate-key dup ] keep + [ dup touch-session ] keep + [ swap \ session [ responder>> init-session ] with-variable ] 2keep + >r over r> sessions>> set-at ; + +: get-session ( id responder -- session ) + sessions>> tuck at* [ + nip dup touch-session + ] [ + 2drop f + ] if ; + +: call-responder/session ( request path responder session -- response ) + \ session set responder>> call-responder ; + +: sessions ( -- manager/f ) + \ session get dup [ manager>> ] when ; + +GENERIC: session-link* ( url query sessions -- string ) + +M: object session-link* 2drop url-encode ; + +: session-link ( url query -- string ) sessions session-link* ; + +TUPLE: url-sessions ; + +: ( responder -- responder' ) + url-sessions ; + +: sess-id "factorsessid" ; + +M: url-sessions call-responder ( request path responder -- response ) + pick sess-id query-param over get-session [ + call-responder/session + ] [ + new-session nip sess-id set-query-param + dup request-url + ] if* ; + +M: url-sessions session-link* + drop + \ session get id>> sess-id associate union assoc>query + >r url-encode r> + dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; + +TUPLE: cookie-sessions ; + +: ( responder -- responder' ) + cookie-sessions ; + +: get-session-cookie ( request responder -- cookie ) + >r sess-id get-cookie dup + [ value>> r> get-session ] [ r> 2drop f ] if ; + +: ( id -- cookie ) + sess-id ; + +M: cookie-sessions call-responder ( request path responder -- response ) + 3dup nip get-session-cookie [ + call-responder/session + ] [ + dup new-session + [ over get-session call-responder/session ] keep + put-cookie + ] if* ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor new file mode 100755 index 0000000000..8d47d38eb1 --- /dev/null +++ b/extra/http/server/static/static.factor @@ -0,0 +1,101 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar html io io.files kernel math math.parser http +http.server namespaces parser sequences strings assocs +hashtables debugger http.mime sorting html.elements logging +calendar.format new-slots accessors ; +IN: http.server.static + +SYMBOL: responder + +! special maps mime types to quots with effect ( path -- ) +TUPLE: file-responder root hook special ; + +: unix-time>timestamp ( n -- timestamp ) + >r unix-1970 r> seconds time+ ; + +: file-http-date ( filename -- string ) + file-modified unix-time>timestamp timestamp>http-string ; + +: last-modified-matches? ( filename -- ? ) + file-http-date dup [ + request get "if-modified-since" header = + ] when ; + +: <304> ( -- response ) + 304 "Not modified" ; + +: ( root hook -- responder ) + H{ } clone file-responder construct-boa ; + +: ( root -- responder ) + [ + + over file-length "content-length" set-header + over file-http-date "last-modified" set-header + swap [ stdio get stream-copy ] curry >>body + ] ; + +: serve-static ( filename mime-type -- response ) + over last-modified-matches? + [ 2drop <304> ] [ responder get hook>> call ] if ; + +: serving-path ( filename -- filename ) + "" or responder get root>> swap path+ ; + +: serve-file ( filename -- response ) + dup mime-type + dup responder get special>> at + [ call ] [ serve-static ] ?if ; + +\ serve-file NOTICE add-input-logging + +: file. ( name dirp -- ) + [ "/" append ] when + dup write ; + +: directory. ( path -- ) + dup file-name [ +

dup file-name write

+
    + directory sort-keys + [
  • file.
  • ] assoc-each +
+ ] simple-html-document ; + +: list-directory ( directory -- response ) + "text/html" + swap [ directory. ] curry >>body ; + +: find-index ( filename -- path ) + { "index.html" "index.fhtml" } + [ dupd path+ exists? ] find nip + dup [ path+ ] [ nip ] if ; + +: serve-directory ( filename -- response ) + dup "/" tail? [ + dup find-index + [ serve-file ] [ list-directory ] ?if + ] [ + drop request get redirect-with-/ + ] if ; + +: serve-object ( filename -- response ) + serving-path dup exists? [ + dup directory? [ serve-directory ] [ serve-file ] if + ] [ + drop <404> + ] if ; + +M: file-responder call-responder ( request path responder -- response ) + over [ + ".." pick subseq? [ + 3drop <400> + ] [ + responder set + swap request set + serve-object + ] if + ] [ + 2drop redirect-with-/ + ] if ; diff --git a/extra/http/server/templating/authors.txt b/extra/http/server/templating/fhtml/authors.txt similarity index 100% rename from extra/http/server/templating/authors.txt rename to extra/http/server/templating/fhtml/authors.txt diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor old mode 100644 new mode 100755 similarity index 53% rename from extra/http/server/templating/templating-tests.factor rename to extra/http/server/templating/fhtml/fhtml-tests.factor index d889cd848a..40654734fa --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -1,14 +1,14 @@ -USING: io io.files io.streams.string http.server.templating kernel tools.test - sequences ; -IN: temporary +USING: io io.files io.streams.string io.encodings.utf8 +http.server.templating.fhtml kernel tools.test sequences ; +IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) - "extra/http/server/templating/test/" swap append + "extra/http/server/templating/fhtml/test/" swap append [ ".fhtml" append resource-path [ run-template-file ] with-string-writer ] keep - ".html" append resource-path file-contents = ; + ".html" append resource-path utf8 file-contents = ; [ t ] [ "example" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/fhtml/fhtml.factor similarity index 78% rename from extra/http/server/templating/templating.factor rename to extra/http/server/templating/fhtml/fhtml.factor index 3b0dcb8e5e..3dcd23b99f 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -2,13 +2,14 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel parser namespaces io -io.files io.streams.lines io.streams.string html html.elements +io.files io.streams.string html html.elements source-files debugger combinators math quotations generic -strings splitting ; +strings splitting accessors http.server.static http.server +assocs io.encodings.utf8 ; -IN: http.server.templating +IN: http.server.templating.fhtml -: templating-vocab ( -- vocab-name ) "http.server.templating" ; +: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; ! See apps/http-server/test/ or libs/furnace/ for template usage ! examples @@ -82,14 +83,24 @@ DEFER: <% delimiter templating-vocab use+ ! so that reload works properly dup source-file file set - dup ?resource-path file-contents + ?resource-path utf8 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 swap path+ run-template-file ; : template-convert ( infile outfile -- ) - [ run-template-file ] with-file-writer ; + utf8 [ run-template-file ] with-file-writer ; + +! file responder integration +: serve-fhtml ( filename -- response ) + "text/html" + swap [ run-template-file ] curry >>body ; + +: enable-fhtml ( responder -- responder ) + [ serve-fhtml ] + "application/x-factor-server-page" + pick special>> set-at ; diff --git a/extra/http/server/templating/test/bug.fhtml b/extra/http/server/templating/fhtml/test/bug.fhtml similarity index 100% rename from extra/http/server/templating/test/bug.fhtml rename to extra/http/server/templating/fhtml/test/bug.fhtml diff --git a/extra/http/server/templating/test/bug.html b/extra/http/server/templating/fhtml/test/bug.html similarity index 100% rename from extra/http/server/templating/test/bug.html rename to extra/http/server/templating/fhtml/test/bug.html diff --git a/extra/http/server/templating/test/example.fhtml b/extra/http/server/templating/fhtml/test/example.fhtml similarity index 100% rename from extra/http/server/templating/test/example.fhtml rename to extra/http/server/templating/fhtml/test/example.fhtml diff --git a/extra/http/server/templating/test/example.html b/extra/http/server/templating/fhtml/test/example.html similarity index 100% rename from extra/http/server/templating/test/example.html rename to extra/http/server/templating/fhtml/test/example.html diff --git a/extra/http/server/templating/test/stack.fhtml b/extra/http/server/templating/fhtml/test/stack.fhtml similarity index 100% rename from extra/http/server/templating/test/stack.fhtml rename to extra/http/server/templating/fhtml/test/stack.fhtml diff --git a/extra/http/server/templating/test/stack.html b/extra/http/server/templating/fhtml/test/stack.html similarity index 100% rename from extra/http/server/templating/test/stack.html rename to extra/http/server/templating/fhtml/test/stack.html diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor new file mode 100644 index 0000000000..ff68dcfc64 --- /dev/null +++ b/extra/http/server/validators/validators-tests.factor @@ -0,0 +1,4 @@ +IN: http.server.validators.tests +USING: kernel sequences tools.test http.server.validators ; + +[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor new file mode 100644 index 0000000000..03beb8c3ff --- /dev/null +++ b/extra/http/server/validators/validators.factor @@ -0,0 +1,64 @@ +! Copyright (C) 2006, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations sequences math namespaces +math.parser assocs new-slots ; +IN: http.server.validators + +TUPLE: validation-error value reason ; + +: validation-error ( value reason -- * ) + \ validation-error construct-boa throw ; + +: with-validator ( string quot -- result error? ) + [ f ] compose curry + [ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline + +: validate-param ( name validator assoc -- error? ) + swap pick + >r >r at r> with-validator swap r> set ; + +: validate-params ( validators assoc -- error? ) + [ validate-param ] curry { } assoc>map [ ] contains? ; + +: v-default ( str def -- str ) + over empty? spin ? ; + +: v-required ( str -- str ) + dup empty? [ "required" validation-error ] when ; + +: v-min-length ( str n -- str ) + over length over < [ + [ "must be at least " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-length ( str n -- str ) + over length over > [ + [ "must be no more than " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-number ( str -- n ) + dup string>number [ ] [ + "must be a number" validation-error + ] ?if ; + +: v-min-value ( str n -- str ) + 2dup < [ + [ "must be at least " % # ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-value ( str n -- str ) + 2dup > [ + [ "must be no more than " % # ] "" make + validation-error + ] [ + drop + ] if ; diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index ae0e058490..1740e8a523 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences kernel.private namespaces arrays io io.files splitting io.binary math.functions vectors quotations -combinators ; +combinators io.encodings.binary ; IN: icfp.2006 SYMBOL: regs @@ -134,7 +134,7 @@ SYMBOL: open-arrays [ run-op exec-loop ] unless ; : load-platters ( path -- ) - file-contents 4 group [ be> ] map + binary file-contents 4 group [ be> ] map 0 arrays get set-nth ; : init ( path -- ) diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor index def3e475f7..cf069f17aa 100644 --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -30,7 +30,7 @@ $nl ABOUT: "buffers" HELP: buffer -{ $class-description "The class of I/O buffers, which resemble FIFO queues, but are optimize for holding bytes, are have underlying storage allocated at a fixed address. Buffers must be de-allocated manually." +{ $class-description "The class of I/O buffers, which resemble FIFO queues, but are optimized for holding bytes, are have underlying storage allocated at a fixed address. Buffers must be de-allocated manually." $nl "Buffers have two internal pointers:" { $list 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/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor new file mode 100644 index 0000000000..fdefc35634 --- /dev/null +++ b/extra/io/encodings/ascii/ascii.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ; +IN: io.encodings.ascii + +: encode-check<= ( string stream max -- ) + [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ; + +TUPLE: ascii ; + +M: ascii stream-write-encoded ( string stream encoding -- ) + drop 127 encode-check<= ; + +M: ascii decode-step + drop dup 128 >= [ decode-error ] [ swap push ] if ; diff --git a/core/io/encodings/utf16/authors.txt b/extra/io/encodings/ascii/authors.txt similarity index 100% rename from core/io/encodings/utf16/authors.txt rename to extra/io/encodings/ascii/authors.txt diff --git a/extra/io/encodings/ascii/summary.txt b/extra/io/encodings/ascii/summary.txt new file mode 100644 index 0000000000..8c54de7680 --- /dev/null +++ b/extra/io/encodings/ascii/summary.txt @@ -0,0 +1 @@ +ASCII encoding for streams diff --git a/core/io/encodings/utf16/tags.txt b/extra/io/encodings/ascii/tags.txt similarity index 100% rename from core/io/encodings/utf16/tags.txt rename to extra/io/encodings/ascii/tags.txt diff --git a/extra/io/encodings/latin1/authors.txt b/extra/io/encodings/latin1/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/io/encodings/latin1/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/core/io/encodings/latin1/latin1-docs.factor b/extra/io/encodings/latin1/latin1-docs.factor similarity index 100% rename from core/io/encodings/latin1/latin1-docs.factor rename to extra/io/encodings/latin1/latin1-docs.factor diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor new file mode 100755 index 0000000000..989f45bc64 --- /dev/null +++ b/extra/io/encodings/latin1/latin1.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.encodings strings kernel io.encodings.ascii sequences math ; +IN: io.encodings.latin1 + +TUPLE: latin1 ; + +M: latin1 stream-write-encoded + drop 255 encode-check<= ; + +M: latin1 decode-step + drop dup 256 >= [ decode-error ] [ swap push ] if ; diff --git a/core/io/encodings/latin1/summary.txt b/extra/io/encodings/latin1/summary.txt similarity index 100% rename from core/io/encodings/latin1/summary.txt rename to extra/io/encodings/latin1/summary.txt diff --git a/extra/io/encodings/latin1/tags.txt b/extra/io/encodings/latin1/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/io/encodings/latin1/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/encodings/utf16/.utf16.factor.swo b/extra/io/encodings/utf16/.utf16.factor.swo similarity index 100% rename from core/io/encodings/utf16/.utf16.factor.swo rename to extra/io/encodings/utf16/.utf16.factor.swo diff --git a/extra/io/encodings/utf16/authors.txt b/extra/io/encodings/utf16/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/io/encodings/utf16/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/core/io/encodings/utf16/summary.txt b/extra/io/encodings/utf16/summary.txt similarity index 100% rename from core/io/encodings/utf16/summary.txt rename to extra/io/encodings/utf16/summary.txt diff --git a/extra/io/encodings/utf16/tags.txt b/extra/io/encodings/utf16/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/io/encodings/utf16/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor new file mode 100644 index 0000000000..018a15a534 --- /dev/null +++ b/extra/io/encodings/utf16/utf16-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax io.encodings strings ; +IN: io.encodings.utf16 + +ARTICLE: "utf16" "Working with UTF-16-encoded data" +"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:" +{ $subsection utf16le } +{ $subsection utf16be } +{ $subsection utf16 } +"All of these conform to the " { $link "encodings-protocol" } "." ; + +ABOUT: "utf16" + +HELP: utf16le +{ $class-description "The encoding protocol for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ; + +HELP: utf16be +{ $class-description "The encoding protocol for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ; + +HELP: utf16 +{ $class-description "The encoding protocol for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." } ; + +{ utf16 utf16le utf16be } related-words diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/extra/io/encodings/utf16/utf16-tests.factor new file mode 100755 index 0000000000..89b61a3e37 --- /dev/null +++ b/extra/io/encodings/utf16/utf16-tests.factor @@ -0,0 +1,22 @@ +USING: kernel tools.test io.encodings.utf16 arrays sbufs +sequences io.encodings io unicode io.encodings.string ; + +[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test +[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test + +[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test + +[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test + +[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test + +[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test + +[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test diff --git a/core/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor similarity index 55% rename from core/io/encodings/utf16/utf16.factor rename to extra/io/encodings/utf16/utf16.factor index 35b6282e21..a501fad0bd 100755 --- a/core/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -1,9 +1,13 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary io.encodings combinators splitting io byte-arrays ; IN: io.encodings.utf16 +! UTF-16BE decoding + +TUPLE: utf16be ch state ; + SYMBOL: double SYMBOL: quad1 SYMBOL: quad2 @@ -16,7 +20,7 @@ SYMBOL: ignore 8 shift bitor ; : end-multibyte ( buf byte ch -- buf ch state ) - append-nums decoded ; + append-nums push-decoded ; : begin-utf16be ( buf byte -- buf ch state ) dup -3 shift BIN: 11011 number= [ @@ -36,12 +40,24 @@ SYMBOL: ignore { double [ end-multibyte ] } { quad1 [ append-nums quad2 ] } { quad2 [ handle-quad2be ] } - { quad3 [ append-nums HEX: 10000 + decoded ] } + { quad3 [ append-nums HEX: 10000 + push-decoded ] } { ignore [ 2drop push-replacement ] } } case ; -: decode-utf16be ( seq -- str ) - [ decode-utf16be-step ] decode ; +: unpack-state-be ( encoding -- ch state ) + { utf16be-ch utf16be-state } get-slots ; + +: pack-state-be ( ch state encoding -- ) + { set-utf16be-ch set-utf16be-state } set-slots ; + +M: utf16be decode-step + [ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ; + +M: utf16be init-decoder nip begin over set-utf16be-state ; + +! UTF-16LE decoding + +TUPLE: utf16le ch state ; : handle-double ( buf byte ch -- buf ch state ) swap dup -3 shift BIN: 11011 = [ @@ -52,7 +68,7 @@ SYMBOL: ignore : handle-quad3le ( buf byte ch -- buf ch state ) swap dup -2 shift BIN: 110111 = [ - BIN: 11 bitand append-nums HEX: 10000 + decoded + BIN: 11 bitand append-nums HEX: 10000 + push-decoded ] [ 2drop push-replacement ] if ; : decode-utf16le-step ( buf byte ch state -- buf ch state ) @@ -64,8 +80,18 @@ SYMBOL: ignore { quad3 [ handle-quad3le ] } } case ; -: decode-utf16le ( seq -- str ) - [ decode-utf16le-step ] decode ; +: unpack-state-le ( encoding -- ch state ) + { utf16le-ch utf16le-state } get-slots ; + +: pack-state-le ( ch state encoding -- ) + { set-utf16le-ch set-utf16le-state } set-slots ; + +M: utf16le decode-step + [ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ; + +M: utf16le init-decoder nip begin over set-utf16le-state ; + +! UTF-16LE/BE encoding : encode-first -10 shift @@ -80,73 +106,50 @@ SYMBOL: ignore : char>utf16be ( char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first swap , , - encode-second swap , , - ] [ h>b/b , , ] if ; + dup encode-first swap write1 write1 + encode-second swap write1 write1 + ] [ h>b/b write1 write1 ] if ; -: encode-utf16be ( str -- seq ) - [ [ char>utf16be ] each ] B{ } make ; +: stream-write-utf16be ( string stream -- ) + [ [ char>utf16be ] each ] with-stream* ; + +M: utf16be stream-write-encoded ( string stream encoding -- ) + drop stream-write-utf16be ; : char>utf16le ( char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first , , - encode-second , , - ] [ h>b/b swap , , ] if ; + dup encode-first write1 write1 + encode-second write1 write1 + ] [ h>b/b swap write1 write1 ] if ; -: encode-utf16le ( str -- seq ) - [ [ char>utf16le ] each ] B{ } make ; +: stream-write-utf16le ( string stream -- ) + [ [ char>utf16le ] each ] with-stream* ; + +M: utf16le stream-write-encoded ( string stream encoding -- ) + drop stream-write-utf16le ; + +! UTF-16 : bom-le B{ HEX: ff HEX: fe } ; inline : bom-be B{ HEX: fe HEX: ff } ; inline -: encode-utf16 ( str -- seq ) - encode-utf16le bom-le swap append ; - : start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ; : start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ; -: decode-utf16 ( seq -- str ) - { - { [ start-utf16le? ] [ decode-utf16le ] } - { [ start-utf16be? ] [ decode-utf16be ] } - { [ t ] [ decode-error ] } - } cond ; +TUPLE: utf16 started? ; -TUPLE: utf16le ; -INSTANCE: utf16le encoding-stream - -M: utf16le encode-string drop encode-utf16le ; -M: utf16le decode-step drop decode-utf16le-step ; - -TUPLE: utf16be ; -INSTANCE: utf16be encoding-stream - -M: utf16be encode-string drop encode-utf16be ; -M: utf16be decode-step drop decode-utf16be-step ; - -TUPLE: utf16 encoding ; -INSTANCE: utf16 encoding-stream -M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary? -M: utf16 set-underlying-stream delegate set-delegate ; ! necessary? - -M: utf16 encode-string - >r encode-utf16le r> - dup utf16-encoding [ drop ] - [ t swap set-utf16-encoding bom-le swap append ] if ; +M: utf16 stream-write-encoded + dup utf16-started? [ drop ] + [ t swap set-utf16-started? bom-le over stream-write ] if + stream-write-utf16le ; : bom>le/be ( bom -- le/be ) dup bom-le sequence= [ drop utf16le ] [ bom-be sequence= [ utf16be ] [ decode-error ] if ] if ; -: read-bom ( utf16 -- encoding ) - 2 over delegate stream-read bom>le/be construct-empty - [ swap set-utf16-encoding ] keep ; - -M: utf16 decode-step - ! inefficient: checks if bom is done many times - ! This should transform itself into utf16be or utf16le after reading BOM - dup utf16-encoding [ ] [ read-bom ] ?if decode-step ; +M: utf16 init-decoder ( stream encoding -- newencoding ) + 2 rot stream-read bom>le/be construct-empty init-decoder ; diff --git a/extra/io/files/unique/backend/backend.factor b/extra/io/files/unique/backend/backend.factor index 228b6881f9..b26557688b 100644 --- a/extra/io/files/unique/backend/backend.factor +++ b/extra/io/files/unique/backend/backend.factor @@ -1,5 +1,5 @@ USING: io.backend ; IN: io.files.unique.backend -HOOK: (make-unique-file) io-backend ( prefix suffix -- stream path ) +HOOK: (make-unique-file) io-backend ( path -- stream ) HOOK: temporary-path io-backend ( -- path ) diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 3a1c3c46b8..1e77cd6814 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -29,7 +29,7 @@ PRIVATE> ] 3curry unique-retries retry ; : with-unique-file ( quot -- path ) - >r f f make-unique-file r> with-stream ; inline + >r f f make-unique-file r> rot [ with-stream ] dip ; inline : with-temporary-file ( quot -- ) with-unique-file delete-file ; inline @@ -46,3 +46,8 @@ PRIVATE> : 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-docs.factor b/extra/io/launcher/launcher-docs.factor index 96639dee87..0e50fd642a 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -35,33 +35,43 @@ HELP: +environment-mode+ HELP: +stdin+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard input is inherited" } + { { $link f } " - standard input is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - standard input is inherited from the current process" } { { $link +closed+ } " - standard input is closed" } { "a path name - standard input is read from the given file, which must exist" } + { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" } } } ; HELP: +stdout+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard output is inherited" } + { { $link f } " - standard output is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - standard output is inherited from the current process" } { { $link +closed+ } " - standard output is closed" } { "a path name - standard output is written to the given file, which is overwritten if it already exists" } + { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" } } } ; HELP: +stderr+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard error is inherited" } + { { $link f } " - standard error is inherited from the current process" } + { { $link +inherit+ } " - same as above" } + { { $link +stdout+ } " - standard error is merged with standard output" } { { $link +closed+ } " - standard error is closed" } { "a path name - standard error is written to the given file, which is overwritten if it already exists" } + { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" } } } ; HELP: +closed+ { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; +HELP: +inherit+ +{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; + HELP: +prepend-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." $nl @@ -149,8 +159,9 @@ HELP: process-stream HELP: { $values { "desc" "a launch descriptor" } + { "encoding" "an encoding descriptor" } { "stream" "a bidirectional stream" } } -{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." } +{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } { $notes "Closing the stream will block until the process exits." } ; HELP: with-process-stream 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/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 021ea487fc..ea5c58a3d3 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend io.timeouts system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader -init threads continuations math ; +init threads continuations math io.encodings io.streams.duplex +io.nonblocking ; IN: io.launcher ! Non-blocking process exit notification facility @@ -35,13 +36,16 @@ SYMBOL: +environment-mode+ SYMBOL: +stdin+ SYMBOL: +stdout+ SYMBOL: +stderr+ -SYMBOL: +closed+ + SYMBOL: +timeout+ SYMBOL: +prepend-environment+ SYMBOL: +replace-environment+ SYMBOL: +append-environment+ +SYMBOL: +closed+ +SYMBOL: +inherit+ + : default-descriptor H{ { +command+ f } @@ -121,13 +125,13 @@ M: process set-timeout set-process-timeout ; M: process timed-out kill-process ; -HOOK: process-stream* io-backend ( desc -- stream process ) +HOOK: (process-stream) io-backend ( desc -- in out process ) TUPLE: process-stream process ; -: ( desc -- stream ) - >descriptor - [ process-stream* ] keep +: ( desc encoding -- stream ) + swap >descriptor + [ (process-stream) >r rot r> ] keep +timeout+ swap at [ over set-timeout ] when* { set-delegate set-process-stream-process } process-stream construct ; @@ -141,3 +145,12 @@ TUPLE: process-stream process ; [ set-process-status ] keep [ processes get delete-at* drop [ resume ] each ] keep f swap set-process-handle ; + +GENERIC: underlying-handle ( stream -- handle ) + +M: port underlying-handle port-handle ; + +M: duplex-stream underlying-handle + dup duplex-stream-in underlying-handle + swap duplex-stream-out underlying-handle tuck = + [ "Invalid duplex stream" throw ] when ; diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index 25caae036d..81c3faec1e 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,9 +1,10 @@ -USING: io io.mmap io.files kernel tools.test continuations sequences ; -IN: temporary +USING: io io.mmap io.files kernel tools.test continuations +sequences io.encodings.ascii ; +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 +[ ] [ "mmap-test-file.txt" resource-path ascii [ "12345" write ] with-file-writer ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test -[ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test +[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors 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/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 6798f37887..6eee3739d9 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking USING: math kernel io sequences io.buffers io.timeouts generic -sbufs system io.streams.lines io.streams.plain io.streams.duplex +byte-vectors system io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces -splitting dlists assocs ; +splitting dlists assocs io.encodings.binary ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global @@ -38,16 +38,14 @@ GENERIC: close-handle ( handle -- ) : ( handle type -- port ) default-buffer-size get swap ; -: ( handle -- stream ) - input-port ; +: ( handle -- input-port ) + input-port ; -: ( handle -- stream ) - output-port ; +: ( handle -- output-port ) + output-port ; -: handle>duplex-stream ( in-handle out-handle -- stream ) - - [ >r r> ] [ ] [ dispose ] - cleanup ; +: ( read-handle write-handle -- input-port output-port ) + swap [ swap ] [ ] [ dispose drop ] cleanup ; : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; @@ -73,7 +71,7 @@ GENERIC: (wait-to-read) ( port -- ) M: input-port stream-read1 dup wait-to-read1 [ buffer-pop ] unless-eof ; -: read-step ( count port -- string/f ) +: read-step ( count port -- byte-array/f ) [ wait-to-read ] 2keep [ dupd buffer> ] unless-eof nip ; @@ -92,10 +90,10 @@ M: input-port stream-read >r 0 max >fixnum r> 2dup read-step dup [ pick over length > [ - pick + pick [ push-all ] keep [ read-loop ] keep - "" like + B{ } like ] [ 2nip ] if @@ -103,7 +101,7 @@ M: input-port stream-read 2nip ] if ; -: read-until-step ( separators port -- string/f separator/f ) +: read-until-step ( separators port -- byte-array/f separator/f ) dup wait-to-read1 dup port-eof? [ f swap set-port-eof? drop f f @@ -111,7 +109,7 @@ M: input-port stream-read buffer-until ] if ; -: read-until-loop ( seps port sbuf -- separator/f ) +: read-until-loop ( seps port byte-vector -- separator/f ) 2over read-until-step over [ >r over push-all r> dup [ >r 3drop r> @@ -122,18 +120,20 @@ M: input-port stream-read >r 2drop 2drop r> ] if ; -M: input-port stream-read-until ( seps port -- str/f sep/f ) +M: input-port stream-read-until ( seps port -- byte-array/f sep/f ) 2dup read-until-step dup [ >r 2nip r> ] [ over [ - drop >sbuf [ read-until-loop ] keep "" like swap + drop >byte-vector + [ read-until-loop ] keep + B{ } like swap ] [ >r 2nip r> ] if ] if ; -M: input-port stream-read-partial ( max stream -- string/f ) +M: input-port stream-read-partial ( max stream -- byte-array/f ) >r 0 max >fixnum r> read-step ; : can-write? ( len writer -- ? ) @@ -171,11 +171,11 @@ M: port dispose [ dup port-type >r closed over set-port-type r> close-port ] if ; -TUPLE: server-port addr client ; +TUPLE: server-port addr client client-addr encoding ; -: ( handle addr -- server ) - >r f server-port r> - { set-delegate set-server-port-addr } +: ( handle addr encoding -- server ) + rot f server-port + { set-server-port-addr set-server-port-encoding set-delegate } server-port construct ; : check-server-port ( port -- ) diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index 24b4c231d1..e1297a9839 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 +{ 2 0 } [ [ ] server-loop ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index a76ebcc450..4267f7d1e8 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -25,7 +25,7 @@ LOG: accepted-connection NOTICE >r accept r> [ with-client ] 2curry "Client" spawn drop ] 2keep accept-loop ; inline -: server-loop ( addrspec quot -- ) +: server-loop ( addrspec encoding quot -- ) >r dup servers get push r> [ accept-loop ] curry with-disposal ; inline @@ -39,12 +39,12 @@ PRIVATE> : internet-server ( port -- seq ) f swap t resolve-host ; -: with-server ( seq service quot -- ) +: with-server ( seq service encoding quot -- ) V{ } clone [ - servers [ - [ server-loop ] curry with-logging + swap servers [ + [ server-loop ] 2curry with-logging ] with-variable - ] 3curry parallel-each ; inline + ] 3curry curry parallel-each ; inline : stop-server ( -- ) servers get [ dispose ] each ; diff --git a/extra/io/sockets/authors.txt b/extra/io/sockets/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/extra/io/sockets/authors.txt +++ b/extra/io/sockets/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg 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/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 9136c3ca22..fa38ec90ee 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -92,20 +92,20 @@ HELP: inet6 } ; HELP: -{ $values { "addrspec" "an address specifier" } { "stream" "a bidirectional stream" } } -{ $description "Opens a network connection and outputs a bidirectional stream." } +{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } } +{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." } { $errors "Throws an error if the connection cannot be established." } { $examples - { $code "\"www.apple.com\" \"http\" " } + { $code "\"www.apple.com\" \"http\" utf8 " } } ; HELP: -{ $values { "addrspec" "an address specifier" } { "server" "a handle" } } +{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $description "Begins listening for network connections to a local address. Server objects responds to two words:" { $list { { $link dispose } " - stops listening on the port and frees all associated resources" } - { { $link accept } " - blocks until there is a connection" } + { { $link accept } " - blocks until there is a connection, and returns a stream of the encoding passed to the constructor" } } } { $notes @@ -119,7 +119,7 @@ HELP: HELP: accept { $values { "server" "a handle" } { "client" "a bidirectional stream" } } -{ $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established." +{ $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." $nl "The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." } { $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ; @@ -139,6 +139,7 @@ HELP: "To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" { $code "\"localhost\" 1234 t resolve-host" } "Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly." + "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding" } { $errors "Throws an error if the port is already in use, or if the OS forbids access." } ; diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1afffcc7b2..1dc7f4883d 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -IN: io.sockets USING: generic kernel io.backend namespaces continuations -sequences arrays ; +sequences arrays io.encodings io.nonblocking ; +IN: io.sockets TUPLE: local path ; @@ -26,17 +26,26 @@ TUPLE: client-stream addr ; { set-client-stream-addr set-delegate } client-stream construct ; -HOOK: (client) io-backend ( addrspec -- stream ) +HOOK: (client) io-backend ( addrspec -- client-in client-out ) -GENERIC: ( addrspec -- stream ) +GENERIC: client* ( addrspec -- client-in client-out ) +M: array client* [ (client) 2array ] attempt-all first2 ; +M: object client* (client) ; -M: array [ (client) ] attempt-all ; +: ( addrspec encoding -- stream ) + >r client* r> ; -M: object (client) ; +HOOK: (server) io-backend ( addrspec -- handle ) -HOOK: io-backend ( addrspec -- server ) +: ( addrspec encoding -- server ) + >r [ (server) ] keep r> ; -HOOK: accept io-backend ( server -- client ) +HOOK: (accept) io-backend ( server -- addrspec handle ) + +: accept ( server -- client ) + [ (accept) dup ] keep + server-port-encoding + ; HOOK: io-backend ( addrspec -- datagram ) @@ -48,7 +57,7 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq ) HOOK: host-name io-backend ( -- string ) -M: inet +M: inet client* dup inet-host swap inet-port f resolve-host dup empty? [ "Host name lookup failed" throw ] when - ; + client* ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index fe2f63e99a..93691c63e2 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math io.nonblocking sequences strings structs sbufs -threads unix vectors io.buffers io.backend +threads unix vectors io.buffers io.backend io.encodings io.streams.duplex math.parser continuations system libc -qualified namespaces io.timeouts ; +qualified namespaces io.timeouts io.encodings.utf8 ; QUALIFIED: io IN: io.unix.backend @@ -181,9 +181,10 @@ M: port port-flush ( port -- ) M: unix-io io-multiplex ( ms/f -- ) mx get-global wait-for-events ; -M: unix-io init-stdio ( -- ) - 0 1 handle>duplex-stream io:stdio set-global - 2 io:stderr set-global ; +M: unix-io (init-stdio) ( -- ) + 0 + 1 + 2 ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port mx ; 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 a5a4e64c03..1d472c19a3 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,8 +1,9 @@ ! 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 combinators combinators.cleave calendar ; +unix unix.stat unix.time kernel math continuations math.bitfields +byte-arrays alien combinators combinators.cleave calendar +io.encodings.binary ; IN: io.unix.files @@ -18,7 +19,7 @@ M: unix-io cd : open-read ( path -- fd ) O_RDONLY file-mode open dup io-error ; -M: unix-io ( path -- stream ) +M: unix-io (file-reader) ( path -- stream ) open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -26,7 +27,7 @@ M: unix-io ( path -- stream ) : open-write ( path -- fd ) write-flags file-mode open dup io-error ; -M: unix-io ( path -- stream ) +M: unix-io (file-writer) ( path -- stream ) open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -35,7 +36,7 @@ M: unix-io ( path -- stream ) append-flags file-mode open dup io-error [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; -M: unix-io ( path -- stream ) +M: unix-io (file-appender) ( path -- stream ) open-append ; : touch-mode @@ -60,8 +61,8 @@ M: unix-io delete-directory ( path -- ) : (copy-file) ( from to -- ) dup parent-directory make-directories - [ - swap [ + binary [ + swap binary [ swap stream-copy ] with-disposal ] with-disposal ; @@ -89,3 +90,12 @@ M: unix-io file-info ( path -- info ) [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] } cleave \ file-info construct-boa ; + +M: unix-io link-info ( path -- info ) + lstat* { + [ 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/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 7b67a9d468..c5dc964a7a 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 @@ -31,7 +31,8 @@ M: output-task io-task-filter drop EVFILT_WRITE ; swap io-task-filter over set-kevent-filter ; : register-kevent ( kevent mx -- ) - mx-fd swap 1 f 0 f kevent io-error ; + mx-fd swap 1 f 0 f kevent + 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; M: kqueue-mx register-io-task ( task mx -- ) over EV_ADD make-kevent over register-kevent diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor old mode 100755 new mode 100644 index eb3038e1b5..c24d5c7c9e --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,33 +1,80 @@ -IN: temporary -USING: io.unix.launcher tools.test ; +IN: io.unix.launcher.tests +USING: io.files tools.test io.launcher arrays io namespaces +continuations math io.encodings.ascii ; -[ "" 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 +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + "touch" + "launcher-test-1" temp-file + 2array + try-process +] unit-test + +[ t ] [ "launcher-test-1" temp-file exists? ] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + [ + "echo Hello" +command+ set + "launcher-test-1" temp-file +stdout+ set + ] { } make-assoc try-process +] unit-test + +[ "Hello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents +] unit-test + +[ "" ] [ + [ + "cat" + "launcher-test-1" temp-file + 2array +arguments+ set + +inherit+ +stdout+ set + ] { } make-assoc ascii contents +] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + [ + "cat" +command+ set + +closed+ +stdin+ set + "launcher-test-1" temp-file +stdout+ set + ] { } make-assoc try-process +] unit-test + +[ "" ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents +] unit-test + +[ ] [ + 2 [ + "launcher-test-1" temp-file ascii [ + [ + +stdout+ set + "echo Hello" +command+ set + ] { } make-assoc try-process + ] with-disposal + ] times +] unit-test + +[ "Hello\nHello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0393b13c7f..e79ca43e33 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,56 +1,45 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! 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 ; +USING: io io.backend io.launcher io.nonblocking io.unix.backend +io.unix.files io.nonblocking sequences kernel namespaces math +system alien.c-types debugger continuations arrays assocs +combinators unix.process strings threads unix +io.unix.launcher.parser io.encodings.latin1 ; 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* ; : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; -: (redirect) ( path mode fd -- ) - >r file-mode open dup io-error dup - r> dup2 io-error close ; +: redirect-fd ( oldfd fd -- ) + 2dup = [ 2drop ] [ dupd dup2 io-error close ] if ; + +: reset-fd ( fd -- ) F_SETFL 0 fcntl io-error ; + +: redirect-inherit ( obj mode fd -- ) + 2nip reset-fd ; + +: redirect-file ( obj mode fd -- ) + >r file-mode open dup io-error r> redirect-fd ; + +: redirect-closed ( obj mode fd -- ) + >r >r drop "/dev/null" r> r> redirect-file ; + +: redirect-stream ( obj mode fd -- ) + >r drop underlying-handle dup reset-fd r> redirect-fd ; : redirect ( obj mode fd -- ) { - { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] } - { [ pick string? ] [ (redirect) ] } + { [ pick not ] [ redirect-inherit ] } + { [ pick string? ] [ redirect-file ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick +inherit+ eq? ] [ redirect-closed ] } + { [ t ] [ redirect-stream ] } } cond ; : ?closed dup +closed+ eq? [ drop "/dev/null" ] when ; @@ -97,9 +86,9 @@ M: unix-io kill-process* ( pid -- ) -rot 2dup second close first close ] with-fork first swap second rot ; -M: unix-io process-stream* +M: unix-io (process-stream) [ - spawn-process-stream >r handle>duplex-stream r> + spawn-process-stream >r r> ] with-descriptor ; : find-process ( handle -- process ) 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..f3bb82343a --- /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' ( -- parser ) + "\\" 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/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 930240419a..bd7dfd9ce1 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. +! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. ! We need to fiddle with the exact search order here, since ! unix::accept shadows streams::accept. -IN: io.unix.sockets USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc combinators ; +IN: io.unix.sockets : pending-init-error ( port -- ) #! We close it here to avoid a resource leak; callers of @@ -42,16 +42,15 @@ M: connect-task do-io-task : wait-to-connect ( port -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io (client) ( addrspec -- stream ) +M: unix-io (client) ( addrspec -- client-in client-out ) dup make-sockaddr/size >r >r protocol-family SOCK_STREAM socket-fd dup r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket - dup handle>duplex-stream - dup duplex-stream-out + dup dup wait-to-connect - pending-init-error + dup pending-init-error ] [ dup close (io-error) ] if ; @@ -72,10 +71,10 @@ TUPLE: accept-task ; dup [ swap heap-size accept ] keep ; inline : do-accept ( port fd sockaddr -- ) - rot [ - server-port-addr parse-sockaddr - swap dup handle>duplex-stream - ] keep set-server-port-client ; + rot + [ server-port-addr parse-sockaddr ] keep + [ set-server-port-client-addr ] keep + set-server-port-client ; M: accept-task do-io-task io-task-port dup accept-sockaddr @@ -92,18 +91,17 @@ USE: io.sockets dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; -M: unix-io ( addrspec -- stream ) - [ - SOCK_STREAM server-fd - dup 10 listen zero? [ dup close (io-error) ] unless - ] keep ; +M: unix-io (server) ( addrspec -- handle ) + SOCK_STREAM server-fd + dup 10 listen zero? [ dup close (io-error) ] unless ; -M: unix-io accept ( server -- client ) +M: unix-io (accept) ( server -- addrspec handle ) #! Wait for a client connection. dup check-server-port dup wait-to-accept dup pending-error - server-port-client ; + dup server-port-client-addr + swap server-port-client ; ! Datagram sockets - UDP and Unix domain M: unix-io diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index af7417854e..c8ed4fc41c 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 +sequences prettyprint system io.encodings.binary io.encodings.ascii ; +IN: io.unix.tests ! Unix domain stream sockets : socket-server "unix-domain-socket-test" temp-file ; @@ -10,12 +10,12 @@ IN: temporary [ socket-server delete-file ] ignore-errors socket-server - [ - stdio get accept [ + ascii [ + accept [ "Hello world" print flush readln "XYZ" = "FOO" "BAR" ? print flush ] with-stream - ] with-stream + ] with-disposal socket-server delete-file ] "Test" spawn drop @@ -24,7 +24,7 @@ yield [ { "Hello world" "FOO" } ] [ [ - socket-server + socket-server ascii [ readln , "XYZ" print flush @@ -125,15 +125,15 @@ datagram-client delete-file ! Invalid parameter tests [ - image [ stdio get accept ] with-file-reader + image binary [ stdio get accept ] with-file-reader ] must-fail [ - image [ stdio get receive ] with-file-reader + image binary [ stdio get receive ] with-file-reader ] must-fail [ - image [ + image binary [ B{ 1 2 } datagram-server stdio get send ] with-file-reader diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 11cdc0aa3b..64e2cc3c3d 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend io.files.unique +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/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index d92b4db77c..f51521dfcc 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,7 +1,7 @@ USING: io.nonblocking io.windows threads.private kernel io.backend windows.winsock windows.kernel32 windows io.streams.duplex io namespaces alien.syntax system combinators -io.buffers ; +io.buffers io.encodings io.encodings.utf8 combinators.lib ; IN: io.windows.ce.backend : port-errored ( port -- ) @@ -33,15 +33,18 @@ LIBRARY: libc FUNCTION: void* _getstdfilex int fd ; FUNCTION: void* _fileno void* file ; -M: windows-ce-io init-stdio ( -- ) +M: windows-ce-io (init-stdio) ( -- ) #! We support Windows NT too, to make this I/O backend #! easier to debug. 512 default-buffer-size [ winnt? [ STD_INPUT_HANDLE GetStdHandle STD_OUTPUT_HANDLE GetStdHandle + STD_ERROR_HANDLE GetStdHandle ] [ 0 _getstdfilex _fileno 1 _getstdfilex _fileno - ] if - ] with-variable stdio set-global ; + 2 _getstdfilex _fileno + ] if [ f ] 3apply + rot -rot [ ] 2apply + ] with-variable ; diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index a5e0cb6b4a..878f5899f6 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -3,4 +3,5 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher namespaces io.windows.mmap ; IN: io.windows.ce +USE: io.windows.files T{ windows-ce-io } set-io-backend diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index e9ca6220af..9bc583a3d8 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -31,17 +31,15 @@ M: win32-socket wince-write ( port port-handle -- ) windows.winsock:WSAConnect windows.winsock:winsock-error!=0/f ; -M: windows-ce-io (client) ( addrspec -- duplex-stream ) - do-connect dup handle>duplex-stream ; +M: windows-ce-io (client) ( addrspec -- reader writer ) + do-connect dup ; -M: windows-ce-io ( addrspec -- duplex-stream ) - [ - windows.winsock:SOCK_STREAM server-fd - dup listen-on-socket - - ] keep ; +M: windows-ce-io (server) ( addrspec -- handle ) + windows.winsock:SOCK_STREAM server-fd + dup listen-on-socket + ; -M: windows-ce-io accept ( server -- client ) +M: windows-ce-io (accept) ( server -- client ) [ dup check-server-port [ @@ -54,7 +52,7 @@ M: windows-ce-io accept ( server -- client ) [ windows.winsock:winsock-error ] when ] keep ] keep server-port-addr parse-sockaddr swap - dup handle>duplex-stream + ] with-timeout ; M: windows-ce-io ( addrspec -- datagram ) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor new file mode 100644 index 0000000000..d107f80723 --- /dev/null +++ b/extra/io/windows/files/files.factor @@ -0,0 +1,110 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types io.files io.windows kernel +math windows windows.kernel32 combinators.cleave +windows.time calendar combinators math.functions +sequences combinators.lib namespaces words ; +IN: io.windows.files + +SYMBOL: +read-only+ +SYMBOL: +hidden+ +SYMBOL: +system+ +SYMBOL: +directory+ +SYMBOL: +archive+ +SYMBOL: +device+ +SYMBOL: +normal+ +SYMBOL: +temporary+ +SYMBOL: +sparse-file+ +SYMBOL: +reparse-point+ +SYMBOL: +compressed+ +SYMBOL: +offline+ +SYMBOL: +not-content-indexed+ +SYMBOL: +encrypted+ + +: expand-constants ( word/obj -- obj'/obj ) + dup word? [ execute ] when ; + +: get-flags ( n seq -- seq' ) + [ + [ + first2 expand-constants + [ swapd mask? [ , ] [ drop ] if ] 2curry + ] map call-with + ] { } make ; + +: win32-file-attributes ( n -- seq ) + { + { +read-only+ FILE_ATTRIBUTE_READONLY } + { +hidden+ FILE_ATTRIBUTE_HIDDEN } + { +system+ FILE_ATTRIBUTE_SYSTEM } + { +directory+ FILE_ATTRIBUTE_DIRECTORY } + { +archive+ FILE_ATTRIBUTE_ARCHIVE } + { +device+ FILE_ATTRIBUTE_DEVICE } + { +normal+ FILE_ATTRIBUTE_NORMAL } + { +temporary+ FILE_ATTRIBUTE_TEMPORARY } + { +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE } + { +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT } + { +compressed+ FILE_ATTRIBUTE_COMPRESSED } + { +offline+ FILE_ATTRIBUTE_OFFLINE } + { +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED } + { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED } + } get-flags ; + +: win32-file-type ( n -- symbol ) + FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; + +: WIN32_FIND_DATA>file-info + { + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] + [ + [ WIN32_FIND_DATA-nFileSizeLow ] + [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit + ] + [ WIN32_FIND_DATA-dwFileAttributes ] + ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ] + [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ] + ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ] + } cleave + \ file-info construct-boa ; + +: find-first-file-stat ( path -- WIN32_FIND_DATA ) + "WIN32_FIND_DATA" [ + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep + FindClose win32-error=0/f + ] keep ; + +: BY_HANDLE_FILE_INFORMATION>file-info + { + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ] + [ + [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] + [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit + ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] + ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] + [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] + ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ] + } cleave + \ file-info construct-boa ; + +: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) + [ + "BY_HANDLE_FILE_INFORMATION" + [ GetFileInformationByHandle win32-error=0/f ] keep + ] keep CloseHandle win32-error=0/f ; + +: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION ) + dup + GENERIC_READ FILE_SHARE_READ f + OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f + CreateFileW dup INVALID_HANDLE_VALUE = [ + drop find-first-file-stat WIN32_FIND_DATA>file-info + ] [ + nip + get-file-information BY_HANDLE_FILE_INFORMATION>file-info + ] if ; + +M: windows-nt-io file-info ( path -- info ) + get-file-information-stat ; + diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 01e654751e..0823c3f0f3 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,8 +1,9 @@ -USING: kernel system ; +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 ; + GENERIC_WRITE CREATE_NEW 0 open-file 0 ; M: windows-io temporary-path ( -- path ) "TEMP" os-env ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index cd9bb9baef..500a2b0d1f 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -1,18 +1,38 @@ -! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system strings io.windows.launcher io.windows.nt.pipes io.backend -combinators ; +combinators shuffle ; IN: io.windows.nt.launcher +: duplicate-handle ( handle -- handle' ) + GetCurrentProcess ! source process + swap ! handle + GetCurrentProcess ! target process + f [ ! target handle + DUPLICATE_SAME_ACCESS ! desired access + TRUE ! inherit handle + DUPLICATE_CLOSE_SOURCE ! options + DuplicateHandle win32-error=0/f + ] keep *void* ; + ! The below code is based on the example given in ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx -: (redirect) ( path access-mode create-mode -- handle ) - >r >r +: redirect-default ( default obj access-mode create-mode -- handle ) + 3drop ; + +: redirect-inherit ( default obj access-mode create-mode -- handle ) + 4drop f ; + +: redirect-closed ( default obj access-mode create-mode -- handle ) + drop 2nip null-pipe ; + +: redirect-file ( default path access-mode create-mode -- handle ) + >r >r >r drop r> normalize-pathname r> ! access-mode share-mode @@ -22,47 +42,59 @@ IN: io.windows.nt.launcher f ! template file CreateFile dup invalid-handle? dup close-later ; -: redirect ( obj access-mode create-mode -- handle ) - { - { [ pick not ] [ 3drop f ] } - { [ pick +closed+ eq? ] [ drop nip null-pipe ] } - { [ pick string? ] [ (redirect) ] } - } cond ; - -: ?closed or dup t eq? [ drop f ] when ; - -: inherited-stdout ( args -- handle ) - CreateProcess-args-stdout-pipe - [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdout ( args -- handle ) - +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stdout ?closed ; - -: inherited-stderr ( args -- handle ) - drop STD_ERROR_HANDLE GetStdHandle ; - -: redirect-stderr ( args -- handle ) - +stderr+ get - dup +stdout+ eq? [ - drop - CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput - ] [ - GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stderr ?closed - ] if ; - -: inherited-stdin ( args -- handle ) - CreateProcess-args-stdin-pipe - [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdin ( args -- handle ) - +stdin+ get GENERIC_READ OPEN_EXISTING redirect - swap inherited-stdin ?closed ; - : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; +: redirect-stream ( default stream access-mode create-mode -- handle ) + 2drop nip + underlying-handle win32-file-handle + duplicate-handle dup t set-inherit ; + +: redirect ( default obj access-mode create-mode -- handle ) + { + { [ pick not ] [ redirect-default ] } + { [ pick +inherit+ eq? ] [ redirect-inherit ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick string? ] [ redirect-file ] } + { [ t ] [ redirect-stream ] } + } cond ; + +: default-stdout ( args -- handle ) + CreateProcess-args-stdout-pipe dup [ pipe-out ] when ; + +: redirect-stdout ( args -- handle ) + default-stdout + +stdout+ get + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_OUTPUT_HANDLE GetStdHandle or ; + +: redirect-stderr ( args -- handle ) + +stderr+ get +stdout+ eq? [ + CreateProcess-args-lpStartupInfo + STARTUPINFO-hStdOutput + ] [ + drop + f + +stderr+ get + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_ERROR_HANDLE GetStdHandle or + ] if ; + +: default-stdin ( args -- handle ) + CreateProcess-args-stdin-pipe dup [ pipe-in ] when ; + +: redirect-stdin ( args -- handle ) + default-stdin + +stdin+ get + GENERIC_READ + OPEN_EXISTING + redirect + STD_INPUT_HANDLE GetStdHandle or ; + : add-pipe-dtors ( pipe -- ) dup pipe-in close-later @@ -87,7 +119,7 @@ M: windows-nt-io fill-redirection over redirect-stdin over set-STARTUPINFO-hStdInput drop ; -M: windows-nt-io process-stream* +M: windows-nt-io (process-stream) [ [ make-CreateProcess-args @@ -103,8 +135,10 @@ M: windows-nt-io process-stream* dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop dup CreateProcess-args-stdout-pipe pipe-in - over CreateProcess-args-stdin-pipe pipe-out + over CreateProcess-args-stdin-pipe pipe-out - swap CreateProcess-args-lpProcessInformation + [ f ] 2apply + + rot CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; 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/nt/nt.factor b/extra/io/windows/nt/nt.factor index be57a398a2..9bc587e00e 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -9,6 +9,7 @@ USE: io.windows.nt.launcher USE: io.windows.nt.monitors USE: io.windows.nt.sockets USE: io.windows.mmap +USE: io.windows.files USE: io.backend T{ windows-nt-io } set-io-backend diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index eef7476dd5..a63a533ba1 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -45,13 +45,12 @@ TUPLE: ConnectEx-args port "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: connect-continuation ( ConnectEx -- ) - dup ConnectEx-args-lpOverlapped* - swap ConnectEx-args-port duplex-stream-in - [ save-callback ] 2keep +: connect-continuation ( ConnectEx port -- ) + >r ConnectEx-args-lpOverlapped* r> + 2dup save-callback get-overlapped-result drop ; -M: windows-nt-io (client) ( addrspec -- duplex-stream ) +M: windows-nt-io (client) ( addrspec -- client-in client-out ) [ \ ConnectEx-args construct-empty over make-sockaddr/size pick init-connect @@ -61,13 +60,8 @@ M: windows-nt-io (client) ( addrspec -- duplex-stream ) dup ConnectEx-args-s* INADDR_ANY roll bind-socket dup (ConnectEx) - dup ConnectEx-args-s* dup handle>duplex-stream - over set-ConnectEx-args-port - - dup connect-continuation - ConnectEx-args-port - [ duplex-stream-in pending-error ] keep - [ duplex-stream-out pending-error ] keep + dup ConnectEx-args-s* dup + >r [ connect-continuation ] keep [ pending-error ] keep r> ] with-destructors ; TUPLE: AcceptEx-args port @@ -91,7 +85,7 @@ TUPLE: AcceptEx-args port f over set-AcceptEx-args-lpdwBytesReceived* (make-overlapped) swap set-AcceptEx-args-lpOverlapped* ; -: (accept) ( AcceptEx -- ) +: ((accept)) ( AcceptEx -- ) \ AcceptEx-args >tuple*< AcceptEx drop winsock-error-string [ throw ] when* ; @@ -117,38 +111,31 @@ TUPLE: AcceptEx-args port ] keep *void* ] keep AcceptEx-args-port server-port-addr parse-sockaddr ; -: accept-continuation ( AcceptEx -- client ) +: accept-continuation ( AcceptEx -- addrspec client ) [ make-accept-continuation ] keep [ check-accept-error ] keep [ extract-remote-host ] keep ! addrspec AcceptEx - [ - AcceptEx-args-sAcceptSocket* add-completion - ] keep - AcceptEx-args-sAcceptSocket* dup handle>duplex-stream - ; + [ AcceptEx-args-sAcceptSocket* add-completion ] keep + AcceptEx-args-sAcceptSocket* ; -M: windows-nt-io accept ( server -- client ) +M: windows-nt-io (accept) ( server -- addrspec handle ) [ [ dup check-server-port \ AcceptEx-args construct-empty [ init-accept ] keep - [ (accept) ] keep + [ ((accept)) ] keep [ accept-continuation ] keep AcceptEx-args-port pending-error - dup duplex-stream-in pending-error - dup duplex-stream-out pending-error ] with-timeout ] with-destructors ; -M: windows-nt-io ( addrspec -- server ) +M: windows-nt-io (server) ( addrspec -- handle ) [ - [ - SOCK_STREAM server-fd dup listen-on-socket - dup add-completion - - ] keep + SOCK_STREAM server-fd dup listen-on-socket + dup add-completion + ] with-destructors ; M: windows-nt-io ( addrspec -- datagram ) diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 06dbaf89f7..094a6ec0d6 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -2,10 +2,10 @@ ! 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 io.windows.files.unique windows.errors -strings io.streams.duplex kernel math namespaces sequences -windows windows.kernel32 windows.shell32 windows.types -windows.winsock splitting continuations math.bitfields ; +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 TUPLE: windows-nt-io ; @@ -20,9 +20,6 @@ TUPLE: win32-file handle ptr ; C: win32-file -: ( in out -- stream ) - >r f r> f handle>duplex-stream ; - HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) @@ -55,7 +52,7 @@ M: win32-file close-handle ( handle -- ) : open-file ( path access-mode create-mode flags -- handle ) [ >r >r >r normalize-pathname r> - share-mode f r> r> CreateFile-flags f CreateFile + share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile dup invalid-handle? dup close-later dup add-completion ] with-destructors ; @@ -112,13 +109,13 @@ C: FileArgs [ FileArgs-lpNumberOfBytesRet ] keep FileArgs-lpOverlapped ; -M: windows-io ( path -- stream ) +M: windows-io (file-reader) ( path -- stream ) open-read ; -M: windows-io ( path -- stream ) +M: windows-io (file-writer) ( path -- stream ) open-write ; -M: windows-io ( path -- stream ) +M: windows-io (file-appender) ( path -- stream ) open-append ; M: windows-io move-file ( from to -- ) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 44c682e671..8a39846fc4 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar io io.sockets kernel match namespaces -sequences splitting strings continuations threads ascii ; +sequences splitting strings continuations threads ascii +io.encodings.utf8 ; IN: irc ! "setup" objects @@ -97,7 +98,7 @@ SYMBOL: irc-client " hostname servername :irc.factor" irc-print ; : connect* ( server port -- ) - irc-client get set-irc-client-stream ; + utf8 irc-client get set-irc-client-stream ; : connect ( server -- ) 6667 connect* ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 2ea8a64bd9..3cc230126c 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,5 +1,5 @@ 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/ldap/ldap-tests.factor b/extra/ldap/ldap-tests.factor index e4338615ce..42e51c782a 100644 --- a/extra/ldap/ldap-tests.factor +++ b/extra/ldap/ldap-tests.factor @@ -5,10 +5,12 @@ tools.test ; get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 set-option -[ B{ 0 0 0 3 } ] [ +[ 3 ] [ get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" [ get-option ] keep + *int ] unit-test +[ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 @@ -52,3 +54,4 @@ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ get-ldp get-message next-message msgtype result-type ] with-bind +] drop diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor index 492aed1a54..ae613bd461 100755 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ; IN: ldap.libldap -"libldap" { +<< "libldap" { { [ win32? ] [ "libldap.dll" "stdcall" ] } { [ macosx? ] [ "libldap.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] } -} cond add-library +} cond add-library >> : LDAP_VERSION1 1 ; inline : LDAP_VERSION2 2 ; inline 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/locals/locals.factor b/extra/locals/locals.factor index 2e6fd6485d..5f58f1464a 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ; ! are unified : create-method ( class generic -- method ) 2dup method dup - [ 2nip method-word ] + [ 2nip ] [ drop 2dup [ ] -rot define-method create-method ] if ; : CREATE-METHOD ( -- class generic body ) @@ -367,16 +367,16 @@ M: lambda-method definer drop \ M:: \ ; ; M: lambda-method definition "lambda" word-prop lambda-body ; -: method-stack-effect +: method-stack-effect ( method -- effect ) dup "lambda" word-prop lambda-vars - swap "method" word-prop method-generic stack-effect dup [ effect-out ] when + swap "method-generic" word-prop stack-effect + dup [ effect-out ] when ; M: lambda-method synopsis* - dup definer. - dup "method" word-prop dup - method-specializer pprint* - method-generic pprint* + dup dup dup definer. + "method-specializer" word-prop pprint* + "method-generic" word-prop pprint* method-stack-effect effect>string comment. ; PRIVATE> diff --git a/extra/log-viewer/log-viewer.factor b/extra/log-viewer/log-viewer.factor index 0f139d184e..7bc63d3e34 100755 --- a/extra/log-viewer/log-viewer.factor +++ b/extra/log-viewer/log-viewer.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files io.monitors ; +USING: kernel io io.files io.monitors io.encodings.utf8 ; IN: log-viewer : read-lines ( stream -- ) @@ -9,6 +9,6 @@ IN: log-viewer dup next-change 2drop over read-lines tail-file-loop ; : tail-file ( file -- ) - dup dup read-lines + dup utf8 dup read-lines swap parent-directory f tail-file-loop ; diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor old mode 100644 new mode 100755 index 64ac3b4ff6..93485e4c7c --- a/extra/logging/insomniac/insomniac-docs.factor +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -27,7 +27,7 @@ HELP: schedule-insomniac { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } { $description "Starts a thread which e-mails log reports and rotates logs daily." } ; -ARTICLE: "logging.insomniac" "Automating log analysis and rotation" +ARTICLE: "logging.insomniac" "Automated log analysis" "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." $nl "Required configuration parameters:" diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index bb143879bf..0294085eda 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces raptor.cron assocs ; +kernel io.files io.streams.string namespaces raptor.cron assocs +io.encodings.utf8 ; IN: logging.insomniac SYMBOL: insomniac-smtp-host @@ -11,7 +12,7 @@ SYMBOL: insomniac-recipients : ?analyze-log ( service word-names -- string/f ) >r log-path 1 log# dup exists? [ - file-lines r> [ analyze-log ] with-string-writer + utf8 file-lines r> [ analyze-log ] with-string-writer ] [ r> 2drop f ] if ; diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor old mode 100644 new mode 100755 index 939388026d..715b1551b9 --- a/extra/logging/logging-docs.factor +++ b/extra/logging/logging-docs.factor @@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework" { $subsection "logging.levels" } { $subsection "logging.messages" } { $subsection "logging.rotation" } -{ $subsection "logging.parser" } -{ $subsection "logging.analysis" } -{ $subsection "logging.insomniac" } +{ $vocab-subsection "Log file parser" "logging.parser" } +{ $vocab-subsection "Log analysis" "logging.analysis" } +{ $vocab-subsection "Automated log analysis" "logging.insomniac" } { $subsection "logging.server" } ; ABOUT: "logging" diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 99f637f4a0..d181ab8a16 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -3,7 +3,8 @@ USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser words debugger math combinators concurrency.messaging -threads arrays init math.ranges strings calendar.format ; +threads arrays init math.ranges strings calendar.format +io.encodings.ascii ; IN: logging.server : log-root ( -- string ) @@ -20,7 +21,7 @@ SYMBOL: log-files : open-log-stream ( service -- stream ) log-path dup make-directories - 1 log# ; + 1 log# ascii ; : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; 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/functions/functions.factor b/extra/math/functions/functions.factor index 59ade44365..85e07fe73f 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -34,6 +34,10 @@ M: real sqrt : set-bit ( x n -- y ) 2^ bitor ; foldable : bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable : bit-set? ( x n -- ? ) bit-clear? not ; foldable +: unmask ( x n -- ? ) bitnot bitand ; foldable +: unmask? ( x n -- ? ) unmask 0 > ; foldable +: mask ( x n -- ? ) bitand ; foldable +: mask? ( x n -- ? ) mask 0 > ; foldable GENERIC: (^) ( x y -- z ) foldable 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/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 8a9ba9cf98..3004324511 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -1,4 +1,4 @@ -USING: io io.files sequences xml xml.utilities ; +USING: io io.files sequences xml xml.utilities io.encodings.utf8 ; IN: msxml-to-csv : print-csv ( table -- ) [ "," join print ] each ; @@ -13,6 +13,6 @@ IN: msxml-to-csv ] map ; : msxml>csv ( infile outfile -- ) - [ + utf8 [ file>xml (msxml>csv) print-csv ] with-file-writer ; 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/multiline/multiline.factor b/extra/multiline/multiline.factor index d32c11dd06..5baa205d15 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -38,3 +38,5 @@ IN: multiline : <" "\">" parse-multiline-string parsed ; parsing + +: /* "*/" parse-multiline-string drop ; parsing diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 528e770558..8e7af02597 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib ; + assocs.lib math.parser math sequences.lib ; IN: namespaces.lib @@ -17,3 +17,30 @@ IN: namespaces.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : set* ( val var -- ) namestack* set-assoc-stack ; + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, get-building-seq push ; +: n% get-building-seq push-all ; +: n# >r number>string r> n% ; + +: 0, 0 n, ; +: 0% 0 n% ; +: 0# 0 n# ; +: 1, 1 n, ; +: 1% 1 n% ; +: 1# 1 n# ; +: 2, 2 n, ; +: 2% 2 n% ; +: 2# 2 n# ; + +: nmake ( quot exemplars -- seqs ) + dup length dup zero? [ 1+ ] when + [ + [ + [ drop 1024 swap new-resizable ] 2map + [ building-seq set call ] keep + ] 2keep >r [ like ] 2map r> firstn + ] with-scope ; diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor index e24cee748e..2a685eccd1 100755 --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -14,7 +14,8 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays sequences libc shuffle alien.c-types system openal math namespaces threads shuffle opengl arrays ui.gadgets.worlds combinators math.parser ui.gadgets ui.render opengl.gl ui - continuations io.files hints combinators.lib sequences.lib debugger ; + continuations io.files hints combinators.lib sequences.lib + io.encodings.binary debugger ; IN: ogg.player @@ -611,7 +612,7 @@ M: theora-gadget draw-gadget* ( gadget -- ) play-ogg ; : play-vorbis-file ( filename -- ) - play-vorbis-stream ; + binary play-vorbis-stream ; : play-theora-stream ( stream -- ) @@ -619,5 +620,5 @@ M: theora-gadget draw-gadget* ( gadget -- ) play-ogg ; : play-theora-file ( filename -- ) - play-theora-stream ; + binary play-theora-stream ; diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 29016f6d57..8d1b3b5247 100644 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl -"libssl" { +<< "libssl" { { [ win32? ] [ "ssleay32.dll" "stdcall" ] } { [ macosx? ] [ "libssl.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] } -} cond add-library +} cond add-library >> : X509_FILETYPE_PEM 1 ; inline : X509_FILETYPE_ASN1 2 ; inline 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/pdf/libhpdf/libhpdf.factor b/extra/pdf/libhpdf/libhpdf.factor index 85ccc70c25..a40b7cddee 100644 --- a/extra/pdf/libhpdf/libhpdf.factor +++ b/extra/pdf/libhpdf/libhpdf.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators system ; IN: pdf.libhpdf -"libhpdf" { +<< "libhpdf" { { [ win32? ] [ "libhpdf.dll" "stdcall" ] } { [ macosx? ] [ "libhpdf.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] } -} cond add-library +} cond add-library >> ! compression mode : HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed diff --git a/extra/pdf/pdf-tests.factor b/extra/pdf/pdf-tests.factor index dc42874d2a..097f671d9a 100644 --- a/extra/pdf/pdf-tests.factor +++ b/extra/pdf/pdf-tests.factor @@ -92,6 +92,6 @@ SYMBOL: twidth ] with-text - "extra/pdf/test/font_test.pdf" resource-path save-to-file + "font_test.pdf" temp-file save-to-file ] with-pdf diff --git a/extra/pdf/test/font_test.pdf b/extra/pdf/test/font_test.pdf deleted file mode 100644 index 4360cf349f..0000000000 --- a/extra/pdf/test/font_test.pdf +++ /dev/null @@ -1,300 +0,0 @@ -%PDF-1.3 -%·¾­ª -1 0 obj -<< -/Type /Catalog -/Pages 2 0 R ->> -endobj -2 0 obj -<< -/Type /Pages -/Kids [ 4 0 R ] -/Count 1 ->> -endobj -3 0 obj -<< -/Producer (Haru\040Free\040PDF\040Library\0402.0.8) ->> -endobj -4 0 obj -<< -/Type /Page -/MediaBox [ 0 0 595 841 ] -/Contents 5 0 R -/Resources << -/ProcSet [ /PDF /Text /ImageB /ImageC /ImageI ] -/Font << -/F1 7 0 R -/F2 8 0 R -/F3 9 0 R -/F4 10 0 R -/F5 11 0 R -/F6 12 0 R -/F7 13 0 R -/F8 14 0 R -/F9 15 0 R -/F10 16 0 R -/F11 17 0 R -/F12 18 0 R -/F13 19 0 R -/F14 20 0 R ->> ->> -/Parent 2 0 R ->> -endobj -5 0 obj -<< -/Length 6 0 R ->> -stream -1 w -50 50 495 731 re -S -/F1 24 Tf -BT -238.148 791 Td -(Font\040Demo) Tj -ET -BT -/F1 16 Tf -60 761 Td -(\074Standard\040Type1\040font\040samples\076) Tj -ET -BT -60 736 Td -/F2 9 Tf -(Courier) Tj -0 -18 Td -/F2 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F3 9 Tf -(Courier-Bold) Tj -0 -18 Td -/F3 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F4 9 Tf -(Courier-Oblique) Tj -0 -18 Td -/F4 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F5 9 Tf -(Courier-BoldOblique) Tj -0 -18 Td -/F5 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F1 9 Tf -(Helvetica) Tj -0 -18 Td -/F1 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F6 9 Tf -(Helvetica-Bold) Tj -0 -18 Td -/F6 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F7 9 Tf -(Helvetica-Oblique) Tj -0 -18 Td -/F7 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F8 9 Tf -(Helvetica-BoldOblique) Tj -0 -18 Td -/F8 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F9 9 Tf -(Times-Roman) Tj -0 -18 Td -/F9 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F10 9 Tf -(Times-Bold) Tj -0 -18 Td -/F10 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F11 9 Tf -(Times-Italic) Tj -0 -18 Td -/F11 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F12 9 Tf -(Times-BoldItalic) Tj -0 -18 Td -/F12 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F13 9 Tf -(Symbol) Tj -0 -18 Td -/F13 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F14 9 Tf -(ZapfDingbats) Tj -0 -18 Td -/F14 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -ET - -endstream -endobj -6 0 obj -1517 -endobj -7 0 obj -<< -/Type /Font -/BaseFont /Helvetica -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -8 0 obj -<< -/Type /Font -/BaseFont /Courier -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -9 0 obj -<< -/Type /Font -/BaseFont /Courier-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -10 0 obj -<< -/Type /Font -/BaseFont /Courier-Oblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -11 0 obj -<< -/Type /Font -/BaseFont /Courier-BoldOblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -12 0 obj -<< -/Type /Font -/BaseFont /Helvetica-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -13 0 obj -<< -/Type /Font -/BaseFont /Helvetica-Oblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -14 0 obj -<< -/Type /Font -/BaseFont /Helvetica-BoldOblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -15 0 obj -<< -/Type /Font -/BaseFont /Times-Roman -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -16 0 obj -<< -/Type /Font -/BaseFont /Times-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -17 0 obj -<< -/Type /Font -/BaseFont /Times-Italic -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -18 0 obj -<< -/Type /Font -/BaseFont /Times-BoldItalic -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -19 0 obj -<< -/Type /Font -/BaseFont /Symbol -/Subtype /Type1 ->> -endobj -20 0 obj -<< -/Type /Font -/BaseFont /ZapfDingbats -/Subtype /Type1 ->> -endobj -xref -0 21 -0000000000 65535 f -0000000015 00000 n -0000000064 00000 n -0000000123 00000 n -0000000196 00000 n -0000000518 00000 n -0000002089 00000 n -0000002109 00000 n -0000002207 00000 n -0000002303 00000 n -0000002404 00000 n -0000002509 00000 n -0000002618 00000 n -0000002722 00000 n -0000002829 00000 n -0000002940 00000 n -0000003041 00000 n -0000003141 00000 n -0000003243 00000 n -0000003349 00000 n -0000003417 00000 n -trailer -<< -/Root 1 0 R -/Info 3 0 R -/Size 21 ->> -startxref -3491 -%%EOF 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-docs.factor b/extra/peg/peg-docs.factor index 6dff95c829..9ad375ea04 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -135,9 +135,10 @@ HELP: hide HELP: delay { $values + { "quot" "a quotation" } { "parser" "a parser" } } { $description "Delays the construction of a parser until it is actually required to parse. This " "allows for calling a parser that results in a recursive call to itself. The quotation " - "should return the constructed parser." } ; \ No newline at end of file + "should return the constructed parser." } ; 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..16cf40f884 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 @@ -351,28 +358,14 @@ MEMO: sp ( parser -- parser ) MEMO: hide ( parser -- parser ) [ drop ignore ] action ; -MEMO: delay ( parser -- parser ) +MEMO: delay ( quot -- 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..b22a5ef0d0 100755 --- a/extra/peg/search/search-tests.factor +++ b/extra/peg/search/search-tests.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel math math.parser arrays tools.test peg peg.search ; -IN: temporary +USING: kernel math math.parser arrays tools.test peg peg.parsers +peg.search ; +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..da0658f94d 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -1,6 +1,6 @@ -IN: temporary +IN: porter-stemmer.tests USING: arrays io kernel porter-stemmer sequences tools.test -io.files ; +io.files io.encodings.utf8 ; [ 0 ] [ "xa" consonant-seq ] unit-test [ 0 ] [ "xxaa" consonant-seq ] unit-test @@ -56,7 +56,7 @@ io.files ; [ "hell" ] [ "hell" step5 "" like ] unit-test [ "mate" ] [ "mate" step5 "" like ] unit-test -: resource-lines resource-path file-lines ; +: resource-lines resource-path utf8 file-lines ; [ { } ] [ "extra/porter-stemmer/test/voc.txt" resource-lines diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor index c66be27df7..a87722debc 100644 --- a/extra/project-euler/042/042.factor +++ b/extra/project-euler/042/042.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: ascii io.files kernel math math.functions namespaces - project-euler.common sequences sequences.lib splitting ; + project-euler.common sequences sequences.lib splitting io.encodings.ascii ; IN: project-euler.042 ! http://projecteuler.net/index.php?section=problems&id=42 @@ -31,7 +31,7 @@ IN: project-euler.042 : source-042 ( -- seq ) "extra/project-euler/042/words.txt" resource-path - file-contents [ quotable? ] subset "," split ; + ascii file-contents [ quotable? ] subset "," split ; : (triangle-upto) ( limit n -- ) 2dup nth-triangle > [ diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index f206f59472..436ccde776 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files math.parser namespaces project-euler.common sequences splitting ; +USING: io.files math.parser namespaces project-euler.common +io.encodings.ascii sequences splitting ; IN: project-euler.067 ! http://projecteuler.net/index.php?section=problems&id=67 @@ -38,7 +39,7 @@ IN: project-euler.067 : source-067 ( -- seq ) "extra/project-euler/067/triangle.txt" resource-path - file-lines [ " " split [ string>number ] map ] map ; + ascii file-lines [ " " split [ string>number ] map ] map ; PRIVATE> diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index f068db77ec..30c46de0a0 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs hashtables io.files kernel math math.parser namespaces sequences ; +USING: assocs hashtables io.files kernel math math.parser namespaces +io.encodings.ascii sequences ; IN: project-euler.079 ! http://projecteuler.net/index.php?section=problems&id=79 @@ -26,7 +27,7 @@ IN: project-euler.079 edges ( seq -- seq ) [ diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor index ab528786bb..f7eac4c32d 100755 --- a/extra/random-tester/safe-words/safe-words.factor +++ b/extra/random-tester/safe-words/safe-words.factor @@ -54,7 +54,6 @@ IN: random-tester.safe-words : method-words { - method-def forget-word } ; 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/raptor/raptor.factor b/extra/raptor/raptor.factor index 1ada2a30c6..1bf9b2d4c7 100755 --- a/extra/raptor/raptor.factor +++ b/extra/raptor/raptor.factor @@ -42,11 +42,11 @@ SYMBOL: networking-hook ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! USING: io io.files io.streams.lines io.streams.plain io.streams.duplex - listener ; + listener io.encodings.utf8 ; : tty-listener ( tty -- ) - dup [ - swap [ + dup utf8 [ + swap utf8 [ [ listener ] with-stream diff --git a/extra/regexp2/regexp2-tests.factor b/extra/regexp2/regexp2-tests.factor new file mode 100644 index 0000000000..1fb3f61f29 --- /dev/null +++ b/extra/regexp2/regexp2-tests.factor @@ -0,0 +1,5 @@ +USING: kernel peg regexp2 sequences tools.test ; +IN: regexp2.tests + +[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ] + [ "056" 'octal' parse ] unit-test diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor new file mode 100644 index 0000000000..e62eb76cb1 --- /dev/null +++ b/extra/regexp2/regexp2.factor @@ -0,0 +1,262 @@ +USING: assocs combinators.lib kernel math math.parser +namespaces peg unicode.case sequences unicode.categories +memoize peg.parsers ; +USE: io +USE: tools.walker +IN: regexp2 + +upper [ swap ch>upper = ] ] [ [ = ] ] if + curry ; + +: char-between?-quot ( ch1 ch2 -- quot ) + ignore-case? get + [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ] + [ [ between? ] ] + if 2curry ; + +: or-predicates ( quots -- quot ) + [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + +: literal-action [ nip ] curry action ; + +: delay-action [ curry ] curry action ; + +PRIVATE> + +: ascii? ( n -- ? ) + 0 HEX: 7f between? ; + +: octal-digit? ( n -- ? ) + CHAR: 0 CHAR: 7 between? ; + +: hex-digit? ( n -- ? ) + { + [ dup digit? ] + [ dup CHAR: a CHAR: f between? ] + [ dup CHAR: A CHAR: F between? ] + } || nip ; + +: control-char? ( n -- ? ) + { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ; + +: punct? ( n -- ? ) + "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; + +: c-identifier-char? ( ch -- ? ) + { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ; + +: java-blank? ( n -- ? ) + { + CHAR: \s + CHAR: \t CHAR: \n CHAR: \r + HEX: c HEX: 7 HEX: 1b + } member? ; + +: java-printable? ( n -- ? ) + { [ dup alpha? ] [ dup punct? ] } || nip ; + +MEMO: 'ordinary-char' ( -- parser ) + [ "\\^*+?|(){}[$" member? not ] satisfy + [ char=-quot ] action ; + +MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ; + +MEMO: 'octal' ( -- parser ) + "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq + [ first oct> ] action ; + +MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ; + +MEMO: 'hex' ( -- parser ) + "x" token hide 'hex-digit' 2 exactly-n 2seq + "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice + [ first hex> ] action ; + +: satisfy-tokens ( assoc -- parser ) + [ >r token r> literal-action ] { } assoc>map choice ; + +MEMO: 'simple-escape-char' ( -- parser ) + { + { "\\" CHAR: \\ } + { "t" CHAR: \t } + { "n" CHAR: \n } + { "r" CHAR: \r } + { "f" HEX: c } + { "a" HEX: 7 } + { "e" HEX: 1b } + } [ char=-quot ] assoc-map satisfy-tokens ; + +MEMO: 'predefined-char-class' ( -- parser ) + { + { "d" [ digit? ] } + { "D" [ digit? not ] } + { "s" [ java-blank? ] } + { "S" [ java-blank? not ] } + { "w" [ c-identifier-char? ] } + { "W" [ c-identifier-char? not ] } + } satisfy-tokens ; + +MEMO: 'posix-character-class' ( -- parser ) + { + { "Lower" [ letter? ] } + { "Upper" [ LETTER? ] } + { "ASCII" [ ascii? ] } + { "Alpha" [ Letter? ] } + { "Digit" [ digit? ] } + { "Alnum" [ alpha? ] } + { "Punct" [ punct? ] } + { "Graph" [ java-printable? ] } + { "Print" [ java-printable? ] } + { "Blank" [ " \t" member? ] } + { "Cntrl" [ control-char? ] } + { "XDigit" [ hex-digit? ] } + { "Space" [ java-blank? ] } + } satisfy-tokens "p{" "}" surrounded-by ; + +MEMO: 'simple-escape' ( -- parser ) + [ + 'octal' , + 'hex' , + "c" token hide [ LETTER? ] satisfy 2seq , + any-char , + ] choice* [ char=-quot ] action ; + +MEMO: 'escape' ( -- parser ) + "\\" token hide [ + 'simple-escape-char' , + 'predefined-char-class' , + 'posix-character-class' , + 'simple-escape' , + ] choice* 2seq ; + +MEMO: 'any-char' ( -- parser ) + "." token [ drop t ] literal-action ; + +MEMO: 'char' ( -- parser ) + 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ; + +DEFER: 'regexp' + +TUPLE: group-result str ; + +C: group-result + +MEMO: 'non-capturing-group' ( -- parser ) + "?:" token hide 'regexp' ; + +MEMO: 'positive-lookahead-group' ( -- parser ) + "?=" token hide 'regexp' [ ensure ] action ; + +MEMO: 'negative-lookahead-group' ( -- parser ) + "?!" token hide 'regexp' [ ensure-not ] action ; + +MEMO: 'simple-group' ( -- parser ) + 'regexp' [ [ ] action ] action ; + +MEMO: 'group' ( -- parser ) + [ + 'non-capturing-group' , + 'positive-lookahead-group' , + 'negative-lookahead-group' , + 'simple-group' , + ] choice* "(" ")" surrounded-by ; + +MEMO: 'range' ( -- parser ) + any-char "-" token hide any-char 3seq + [ first2 char-between?-quot ] action ; + +MEMO: 'character-class-term' ( -- parser ) + 'range' + 'escape' + [ "\\]" member? not ] satisfy [ char=-quot ] action + 3choice ; + +MEMO: 'positive-character-class' ( -- parser ) + ! todo + "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq + 'character-class-term' repeat1 2choice [ or-predicates ] action ; + +MEMO: 'negative-character-class' ( -- parser ) + "^" token hide 'positive-character-class' 2seq + [ [ not ] append ] action ; + +MEMO: 'character-class' ( -- parser ) + 'negative-character-class' 'positive-character-class' 2choice + "[" "]" surrounded-by [ satisfy ] action ; + +MEMO: 'escaped-seq' ( -- parser ) + any-char repeat1 + [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ; + +MEMO: 'break' ( quot -- parser ) + satisfy ensure + epsilon just 2choice ; + +MEMO: 'break-escape' ( -- parser ) + "$" token [ "\r\n" member? ] 'break' literal-action + "\\b" token [ blank? ] 'break' literal-action + "\\B" token [ blank? not ] 'break' literal-action + "\\z" token epsilon just literal-action 4choice ; + +MEMO: 'simple' ( -- parser ) + [ + 'escaped-seq' , + 'break-escape' , + 'group' , + 'character-class' , + 'char' , + ] choice* ; + +MEMO: 'exactly-n' ( -- parser ) + 'integer' [ exactly-n ] delay-action ; + +MEMO: 'at-least-n' ( -- parser ) + 'integer' "," token hide 2seq [ at-least-n ] delay-action ; + +MEMO: 'at-most-n' ( -- parser ) + "," token hide 'integer' 2seq [ at-most-n ] delay-action ; + +MEMO: 'from-m-to-n' ( -- parser ) + 'integer' "," token hide 'integer' 3seq + [ first2 from-m-to-n ] delay-action ; + +MEMO: 'greedy-interval' ( -- parser ) + 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ; + +MEMO: 'interval' ( -- parser ) + 'greedy-interval' + 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action + 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action + 3choice "{" "}" surrounded-by ; + +MEMO: 'repetition' ( -- parser ) + [ + ! Possessive + ! "*+" token [ ] literal-action , + ! "++" token [ ] literal-action , + ! "?+" token [ ] literal-action , + ! Reluctant + ! "*?" token [ <(*)> ] literal-action , + ! "+?" token [ <(+)> ] literal-action , + ! "??" token [ <(?)> ] literal-action , + ! Greedy + "*" token [ repeat0 ] literal-action , + "+" token [ repeat1 ] literal-action , + "?" token [ optional ] literal-action , + ] choice* ; + +MEMO: 'dummy' ( -- parser ) + epsilon [ ] literal-action ; + +! todo -- check the action +! MEMO: 'term' ( -- parser ) + ! 'simple' + ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action + ! [ ] action ; + diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 68a40704b3..1d493d3c14 100644 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -1,9 +1,9 @@ -USING: rss io kernel io.files tools.test ; +USING: rss io kernel io.files tools.test io.encodings.utf8 ; : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. - read-feed ; + utf8 read-feed ; [ T{ feed 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/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index c02932a020..050de0ae1c 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -140,13 +140,13 @@ PRIVATE> : strings ( alphabet length -- seqs ) >r dup length r> number-strings map-alphabet ; -: nths ( nths seq -- subseq ) - ! nths is a sequence of ones and zeroes +: switches ( seq1 seq -- subseq ) + ! seq1 is a sequence of ones and zeroes >r [ length ] keep [ nth 1 = ] curry subset r> [ nth ] curry { } map-as ; : power-set ( seq -- subsets ) - 2 over length exact-number-strings swap [ nths ] curry map ; + 2 over length exact-number-strings swap [ switches ] curry map ; : push-either ( elt quot accum1 accum2 -- ) >r >r keep swap r> r> ? push ; inline @@ -214,3 +214,9 @@ PRIVATE> : attempt-each ( seq quot -- result ) (each) iterate-prep (attempt-each-integer) ; inline + +: ?nth* ( n seq -- elt/f ? ) + 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable + +: nths ( indices seq -- seq' ) + [ swap nth ] with map ; 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/furnace/validator/authors.txt b/extra/singleton/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/furnace/validator/authors.txt rename to extra/singleton/authors.txt diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor new file mode 100644 index 0000000000..b87c557366 --- /dev/null +++ b/extra/singleton/singleton-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ; +IN: singleton + +HELP: SINGLETON: +{ $syntax "SINGLETON: class" +} { $values + { "class" "a new tuple class to define" } +} { $description + "Defines a new tuple class with membership predicate name? and a default empty constructor that is the class name itself." +} { $examples + { $example "SINGLETON: foo\nfoo ." "T{ foo f }" } +} { $see-also + POSTPONE: TUPLE: +} ; diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor new file mode 100644 index 0000000000..b745e8f902 --- /dev/null +++ b/extra/singleton/singleton.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel parser quotations prettyprint tuples words ; +IN: singleton + +: SINGLETON: + CREATE-CLASS + dup { } define-tuple-class + dup unparse create-in reset-generic + dup construct-empty 1quotation define ; parsing diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index c28ec7745a..92b605e91c 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -1,5 +1,8 @@ ! Copyright (C) 2007 Elie CHAFTARI ! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel prettyprint io io.timeouts io.server +sequences namespaces io.sockets continuations calendar io.encodings.ascii ; +IN: smtp.server ! Mock SMTP server for testing purposes. @@ -27,10 +30,6 @@ ! bye ! Connection closed by foreign host. -USING: combinators kernel prettyprint io io.timeouts io.server -sequences namespaces io.sockets continuations calendar ; -IN: smtp.server - SYMBOL: data-mode : process ( -- ) @@ -64,7 +63,7 @@ SYMBOL: data-mode : smtp-server ( port -- ) "Starting SMTP server on port " write dup . flush - "127.0.0.1" swap [ + "127.0.0.1" swap ascii [ accept [ 1 minutes stdio get set-timeout "220 hello\r\n" write flush diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 784f446b7e..32b2f3be14 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 @@ -84,6 +84,7 @@ IN: temporary [ ] [ [ + "localhost" smtp-host set 4321 smtp-port set "Hi guys\nBye guys" @@ -96,4 +97,4 @@ IN: temporary send-simple-message ] with-scope -] unit-test \ No newline at end of file +] unit-test diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index f3f90f68b9..bbec129ef6 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings -math.parser random system calendar calendar.format ; +math.parser random system calendar io.encodings.ascii calendar.format ; IN: smtp @@ -20,7 +20,7 @@ SYMBOL: esmtp t esmtp set-global : with-smtp-connection ( quot -- ) smtp-host get smtp-port get 2dup log-smtp-connection - [ + ascii [ smtp-domain [ host-name or ] change read-timeout get stdio get set-timeout call @@ -180,4 +180,4 @@ TUPLE: email from to subject body ; : send ( email -- ) { email-body email-subject email-to email-from } get-slots - send-simple-message ; \ No newline at end of file + send-simple-message ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 9d492e6467..06e9644370 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,7 @@ USING: combinators io io.files io.streams.duplex io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system -hexdump ; +hexdump io.encodings.binary ; IN: tar : zero-checksum 256 ; @@ -94,7 +94,7 @@ TUPLE: unimplemented-typeflag header ; ! Normal file : typeflag-0 - tar-header-name tar-path+ + tar-header-name tar-path+ binary [ read-data-blocks ] keep dispose ; ! Hard link @@ -236,7 +236,7 @@ TUPLE: unimplemented-typeflag header ; ] when* ; : parse-tar ( path -- obj ) - [ + binary [ "tar-test" resource-path base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind 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/browser/browser.factor b/extra/tools/browser/browser.factor index e9aaa190dc..24836c1201 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -2,15 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces splitting sequences io.files kernel assocs words vocabs vocabs.loader definitions parser continuations -inspector debugger io io.styles io.streams.lines hashtables +inspector debugger io io.styles hashtables sorting prettyprint source-files arrays combinators strings system math.parser help.markup help.topics help.syntax -help.stylesheet memoize ; +help.stylesheet memoize io.encodings.utf8 ; IN: tools.browser MEMO: (vocab-file-contents) ( path -- lines ) ?resource-path dup exists? - [ file-lines ] [ drop f ] if ; + [ utf8 file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-path+ dup [ (vocab-file-contents) ] when ; @@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ ?resource-path - [ [ print ] each ] with-file-writer + utf8 [ [ print ] each ] with-file-writer ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor index b616766597..0717763ed0 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 ] [ integer \ foo method \ + 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/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 2439ef8636..bcdc0f806f 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -6,7 +6,7 @@ continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend quotations io.launcher words.private tools.deploy.config -bootstrap.image ; +bootstrap.image io.encodings.utf8 ; IN: tools.deploy.backend : (copy-lines) ( stream -- ) @@ -20,7 +20,7 @@ IN: tools.deploy.backend [ +arguments+ set +stdout+ +stderr+ set - ] H{ } make-assoc + ] H{ } make-assoc utf8 dup duplex-stream-out dispose dup copy-lines process-stream-process wait-for-process zero? [ 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/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 61d7b9eaed..6cab5c98b9 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files kernel namespaces sequences system -tools.deploy.backend tools.deploy.config assocs hashtables -prettyprint cocoa cocoa.application cocoa.classes cocoa.plists ; +USING: io io.files kernel namespaces sequences +system tools.deploy.backend tools.deploy.config assocs +hashtables prettyprint io.unix.backend cocoa io.encodings.utf8 +cocoa.application cocoa.classes cocoa.plists qualified ; IN: tools.deploy.macosx : bundle-dir ( -- dir ) @@ -32,8 +33,8 @@ IN: tools.deploy.macosx ] H{ } make-assoc print-plist ; : create-app-plist ( vocab bundle-name -- ) - dup "Contents/Info.plist" path+ - [ print-app-plist ] with-stream ; + dup "Contents/Info.plist" path+ + utf8 [ print-app-plist ] with-file-writer ; : create-app-dir ( vocab bundle-name -- vm ) dup "Frameworks" copy-bundle-dir diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor index 2eddce6475..b37e42f323 100755 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -1,5 +1,6 @@ USING: cocoa cocoa.messages cocoa.application cocoa.nibs -assocs namespaces kernel words compiler sequences ui.cocoa ; +assocs namespaces kernel words compiler.units sequences +ui.cocoa ; "stop-after-last-window?" get global [ 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/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 8a0cd495cf..647b02baa5 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -system math generator.fixup ; +system math generator.fixup io.encodings.ascii ; IN: tools.disassembler : in-file "gdb-in.txt" temp-file ; @@ -15,7 +15,7 @@ M: word make-disassemble-cmd word-xt code-format - 2array make-disassemble-cmd ; M: pair make-disassemble-cmd - in-file [ + in-file ascii [ "attach " write current-process-handle number>string print "disassemble " write @@ -28,7 +28,7 @@ M: pair make-disassemble-cmd out-file +stdout+ set [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set ] { } make-assoc try-process - out-file file-lines ; + out-file ascii file-lines ; : tabs>spaces ( str -- str' ) { { CHAR: \t CHAR: \s } } substitute ; 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/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 784c9e8da6..467fcc14f4 100755 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -29,9 +29,8 @@ M: string (profile.) dup write-object ; M: method-body (profile.) - "method" word-prop - dup method-specializer over method-generic 2array synopsis - swap method-generic write-object ; + dup synopsis swap "method-generic" word-prop + write-object ; : counter. ( obj n -- ) [ 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/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index f71265e6f0..2936c39070 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -1,11 +1,11 @@ -USING: listener io.server ; +USING: listener io.server io.encodings.utf8 ; IN: tty-server : tty-server ( port -- ) local-server "tty-server" - [ listener ] with-server ; + utf8 [ listener ] with-server ; : default-tty-server 9999 tty-server ; -MAIN: default-tty-server \ No newline at end of file +MAIN: default-tty-server 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/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 2dade0f58e..8078ec4a33 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -73,7 +73,7 @@ M: freetype-renderer free-fonts ( world -- ) : open-face ( font style -- face ) ttf-name ttf-path - dup file-contents >byte-array malloc-byte-array + dup malloc-file-contents swap file-length (open-face) ; 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/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor index 5e5801dd02..167aa26084 100755 --- a/extra/ui/gadgets/labels/labels.factor +++ b/extra/ui/gadgets/labels/labels.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math namespaces -opengl sequences io.streams.lines strings splitting +opengl sequences strings splitting ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors models ; IN: ui.gadgets.labels 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/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 1fec668717..158a48a1c0 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim -x11.glx x11.clipboard x11.constants x11.windows +x11.glx x11.clipboard x11.constants x11.windows io.encodings.string io.encodings.utf8 combinators debugger system command-line ui.render math.vectors tuples opengl.gl threads ; IN: ui.x11 @@ -137,7 +137,7 @@ M: world selection-notify-event : encode-clipboard ( string type -- bytes ) XSelectionRequestEvent-target XA_UTF8_STRING = - [ encode-utf8 ] [ string>char-alien ] if ; + [ utf8 encode ] [ string>char-alien ] if ; : set-selection-prop ( evt -- ) dpy get swap @@ -212,7 +212,7 @@ M: x-clipboard paste-clipboard : set-title-new ( dpy window string -- ) >r XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace - r> encode-utf8 dup length XChangeProperty drop ; + r> utf8 encode dup length XChangeProperty drop ; M: x11-ui-backend set-title ( string world -- ) world-handle x11-handle-window swap dpy get -rot diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 1014d3ad7e..dfc7bf2264 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,7 +1,7 @@ USING: unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces combinators.lib assocs.lib math.ranges unicode.normalize -unicode.syntax unicode.data compiler.units alien.syntax ; +unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ; IN: unicode.breaks C-ENUM: Any L V T Extend Control CR LF graphemes ; @@ -30,7 +30,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; concat >set ; : other-extend-lines ( -- lines ) - "extra/unicode/PropList.txt" resource-path file-lines ; + "extra/unicode/PropList.txt" resource-path ascii file-lines ; VALUE: other-extend diff --git a/extra/unicode/categories/categories.factor b/extra/unicode/categories/categories.factor index e5f157463d..4ba96fb9c4 100644 --- a/extra/unicode/categories/categories.factor +++ b/extra/unicode/categories/categories.factor @@ -1,7 +1,7 @@ USING: unicode.syntax ; IN: unicode.categories -CATEGORY: blank Zs Zl Zp ; +CATEGORY: blank Zs Zl Zp \r\n ; CATEGORY: letter Ll ; CATEGORY: LETTER Lu ; CATEGORY: Letter Lu Ll Lt Lm Lo ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index c3998a6132..11be803893 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,6 +1,6 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting arrays math.parser combinators.lib hash2 -byte-arrays words namespaces words compiler.units parser ; +byte-arrays words namespaces words compiler.units parser io.encodings.ascii ; IN: unicode.data << @@ -21,7 +21,7 @@ IN: unicode.data ! Loading data from UnicodeData.txt : data ( filename -- data ) - file-lines [ ";" split ] map ; + ascii file-lines [ ";" split ] map ; : load-data ( -- data ) "extra/unicode/UnicodeData.txt" resource-path data ; 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/stat.factor b/extra/unix/stat/stat.factor index 204321f30c..6d60caf987 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -74,3 +74,8 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; "stat" dup >r stat check-status r> ; + +: lstat* ( pathname -- stat ) + "stat" dup >r + lstat 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..e1d49b8c6c 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 @@ -45,6 +21,7 @@ C-STRUCT: timespec : MAP_FAILED -1 ; inline +: ESRCH 3 ; inline : EEXIST 17 ; inline ! ! ! Unix functions @@ -89,7 +66,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 +93,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/webapps/callback/authors.txt b/extra/webapps/callback/authors.txt deleted file mode 100755 index a8fb961d36..0000000000 --- a/extra/webapps/callback/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Chris Double -Slava Pestov diff --git a/extra/webapps/callback/callback.factor b/extra/webapps/callback/callback.factor deleted file mode 100644 index 6bdc84bfa6..0000000000 --- a/extra/webapps/callback/callback.factor +++ /dev/null @@ -1,126 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! Copyright (C) 2006 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: html http http.server.responders io kernel math -namespaces prettyprint continuations random system sequences -assocs ; -IN: webapps.callback - -#! Name of the variable holding the continuation used to exit -#! back to the httpd responder. -SYMBOL: exit-continuation - -#! Tuple to hold global request data. This gets passed to -#! the continuation when resumed so it can restore things -#! like 'stdio' so it writes to the correct socket. -TUPLE: request stream exitcc method url raw-query query header response ; - -: ( -- request ) - stdio get - exit-continuation get - "method" get - "request" get - "raw-query" get - "query" get - "header" get - "response" get - request construct-boa ; - -: restore-request ( -- ) - request get - dup request-stream stdio set - dup request-method "method" set - dup request-raw-query "raw-query" set - dup request-query "query" set - dup request-header "header" set - dup request-response "response" set - request-exitcc exit-continuation set ; - -: update-request ( request new-request -- ) - [ request-stream over set-request-stream ] keep - [ request-method over set-request-method ] keep - [ request-url over set-request-url ] keep - [ request-raw-query over set-request-raw-query ] keep - [ request-query over set-request-query ] keep - [ request-header over set-request-header ] keep - [ request-response over set-request-response ] keep - request-exitcc swap set-request-exitcc ; - -: with-exit-continuation ( quot -- ) - #! Call the quotation with the variable exit-continuation bound - #! such that when the exit continuation is called, computation - #! will resume from the end of this 'with-exit-continuation' call. - [ - exit-continuation set call exit-continuation get continue - ] callcc0 drop ; - -: expiry-timeout ( -- ms ) 900 1000 * ; - -: get-random-id ( -- id ) - #! Generate a random id to use for continuation URL's - 4 big-random unparse ; - -: callback-table ( -- ) - #! Return the global table of continuations - \ callback-table get-global ; - -: reset-callback-table ( -- ) - #! Create the initial global table - H{ } clone \ callback-table set-global ; - -reset-callback-table - -#! Tuple for holding data related to a callback. -TUPLE: item quot expire? request id time-added ; - -: ( quot expire? request id -- item ) - millis item construct-boa ; - -: expired? ( item -- ? ) - #! Return true if the callback item is expirable - #! and has expired (ie. was added to the table more than - #! timeout milliseconds ago). - [ item-time-added expiry-timeout + millis < ] keep - item-expire? and ; - -: expire-callbacks ( -- ) - #! Expire all continuations in the continuation table - #! if they are 'timeout-seconds' old (ie. were added - #! more than 'timeout-seconds' ago. - callback-table clone [ - expired? [ callback-table delete-at ] [ drop ] if - ] assoc-each ; - -: id>url ( id -- string ) - #! Convert the continuation id to an URL suitable for - #! embedding in an HREF or other HTML. - "/responder/callback/?id=" swap url-encode append ; - -: register-callback ( quot expire? -- url ) - #! Store a continuation in the table and associate it with - #! a random id. That continuation will be expired after - #! a certain period of time if 'expire?' is true. - request get get-random-id [ ] keep - [ callback-table set-at ] keep - id>url ; - -: register-html-callback ( quot expire? -- url ) - >r [ serving-html ] swap append r> register-callback ; - -: callback-responder ( -- ) - expire-callbacks - "id" query-param callback-table at [ - [ - dup item-request [ - update-request - ] when* - item-quot call - exit-continuation get continue - ] with-exit-continuation drop - ] [ - "404 Callback not available" httpd-error - ] if* ; - -global [ - "callback" [ callback-responder ] add-simple-responder -] bind diff --git a/extra/webapps/cgi/authors.txt b/extra/webapps/cgi/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/cgi/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor deleted file mode 100755 index 5dba9dae00..0000000000 --- a/extra/webapps/cgi/cgi.factor +++ /dev/null @@ -1,75 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel assocs io.files combinators -arrays io.launcher io http.server.responders webapps.file -sequences strings math.parser unicode.case ; -IN: webapps.cgi - -SYMBOL: cgi-root - -: post? "method" get "post" = ; - -: cgi-variables ( script-path -- assoc ) - #! This needs some work. - [ - "CGI/1.0" "GATEWAY_INTERFACE" set - "HTTP/1.0" "SERVER_PROTOCOL" set - "Factor" "SERVER_SOFTWARE" set - - dup "PATH_TRANSLATED" set - "SCRIPT_FILENAME" set - - "request" get "SCRIPT_NAME" set - - host "SERVER_NAME" set - "" "SERVER_PORT" set - "" "PATH_INFO" set - "" "REMOTE_HOST" set - "" "REMOTE_ADDR" set - "" "AUTH_TYPE" set - "" "REMOTE_USER" set - "" "REMOTE_IDENT" set - - "method" get >upper "REQUEST_METHOD" set - "raw-query" get "QUERY_STRING" set - "cookie" header-param "HTTP_COOKIE" set - - "user-agent" header-param "HTTP_USER_AGENT" set - "accept" header-param "HTTP_ACCEPT" set - - post? [ - "content-type" header-param "CONTENT_TYPE" set - "raw-response" get length number>string "CONTENT_LENGTH" set - ] when - ] H{ } make-assoc ; - -: cgi-descriptor ( name -- desc ) - [ - cgi-root get swap path+ dup 1array +arguments+ set - cgi-variables +environment+ set - ] H{ } make-assoc ; - -: (do-cgi) ( name -- ) - "200 CGI output follows" response - stdio get swap cgi-descriptor [ - post? [ - "raw-response" get write flush - ] when - stdio get swap (stream-copy) - ] with-stream ; - -: serve-regular-file ( -- ) - cgi-root get doc-root [ file-responder ] with-variable ; - -: do-cgi ( name -- ) - { - { [ dup ".cgi" tail? not ] [ drop serve-regular-file ] } - { [ dup empty? ] [ "403 forbidden" httpd-error ] } - { [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] } - { [ ".." over subseq? ] [ "403 forbidden" httpd-error ] } - { [ t ] [ (do-cgi) ] } - } cond ; - -global [ - "cgi" [ "argument" get do-cgi ] add-simple-responder -] bind diff --git a/extra/webapps/continuation/authors.txt b/extra/webapps/continuation/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/webapps/continuation/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/webapps/continuation/continuation.factor b/extra/webapps/continuation/continuation.factor deleted file mode 100644 index 6b6838d89f..0000000000 --- a/extra/webapps/continuation/continuation.factor +++ /dev/null @@ -1,151 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! See http://factorcode.org/license.txt for BSD license. - -USING: http math namespaces io strings kernel html html.elements -hashtables continuations quotations parser generic sequences -webapps.callback http.server.responders ; -IN: webapps.continuation - -#! Used inside the session state of responders to indicate whether the -#! next request should use the post-refresh-get pattern. It is set to -#! true after each request. -SYMBOL: post-refresh-get? - -: >callable ( quot|interp|f -- interp ) - dup continuation? [ - [ continue ] curry - ] when ; - -: forward-to-url ( url -- ) - #! When executed inside a 'show' call, this will force a - #! HTTP 302 to occur to instruct the browser to forward to - #! the request URL. - [ - "HTTP/1.1 302 Document Moved\nLocation: " % % - "\nContent-Length: 0\nContent-Type: text/plain\n\n" % - ] "" make write exit-continuation get continue ; - -: forward-to-id ( id -- ) - #! When executed inside a 'show' call, this will force a - #! HTTP 302 to occur to instruct the browser to forward to - #! the request URL. - >r "request" get r> id>url append forward-to-url ; - -SYMBOL: current-show - -: store-current-show ( -- ) - #! Store the current continuation in the variable 'current-show' - #! so it can be returned to later by href callbacks. Note that it - #! recalls itself when the continuation is called to ensure that - #! it resets its value back to the most recent show call. - [ ( 0 -- ) - [ ( 0 1 -- ) - current-show set ( 0 -- ) - continue - ] callcc1 - nip - restore-request - call - store-current-show - ] callcc0 restore-request ; - -: redirect-to-here ( -- ) - #! Force a redirect to the client browser so that the browser - #! goes to the current point in the code. This forces an URL - #! change on the browser so that refreshing that URL will - #! immediately run from this code point. This prevents the - #! "this request will issue a POST" warning from the browser - #! and prevents re-running the previous POST logic. This is - #! known as the 'post-refresh-get' pattern. - post-refresh-get? get [ - [ - >callable t register-callback forward-to-url - ] callcc0 restore-request - ] [ - t post-refresh-get? set - ] if ; - -: (show) ( quot -- hashtable ) - #! See comments for show. The difference is the - #! quotation MUST set the content-type using 'serving-html' - #! or similar. - store-current-show redirect-to-here - [ - >callable t register-callback swap with-scope - exit-continuation get continue - ] callcc0 drop restore-request "response" get ; - -: show ( quot -- namespace ) - #! Call the quotation with the URL associated with the current - #! continuation. All output from the quotation goes to the client - #! browser. When the URL is later referenced then - #! computation will resume from this 'show' call with a hashtable on - #! the stack containing any query or post parameters. - #! 'quot' has stack effect ( url -- ) - #! NOTE: On return from 'show' the stack is exactly the same as - #! initial entry with 'quot' popped off and the hashtable pushed on. Even - #! if the quotation consumes items on the stack. - [ serving-html ] swap append (show) ; - -: (show-final) ( quot -- namespace ) - #! See comments for show-final. The difference is the - #! quotation MUST set the content-type using 'serving-html' - #! or similar. - store-current-show redirect-to-here - with-scope exit-continuation get continue ; - -: show-final ( quot -- namespace ) - #! Similar to 'show', except the quotation does not receive the URL - #! to resume computation following 'show-final'. No continuation is - #! stored for this resumption. As a result, 'show-final' is for use - #! when a page is to be displayed with no further action to occur. Its - #! use is an optimisation to save having to generate and save a continuation - #! in that special case. - #! 'quot' has stack effect ( -- ). - [ serving-html ] swap compose (show-final) ; - -#! Name of variable for holding initial continuation id that starts -#! the responder. -SYMBOL: root-callback - -: cont-get/post-responder ( id-or-f -- ) - #! httpd responder that handles the root continuation request. - #! The requests for actual continuation are processed by the - #! 'callback-responder'. - [ - [ f post-refresh-get? set request set root-callback get call ] with-scope - exit-continuation get continue - ] with-exit-continuation drop ; - -: quot-url ( quot -- url ) - current-show get [ continue-with ] 2curry t register-callback ; - -: quot-href ( text quot -- ) - #! Write to standard output an HTML HREF where the href, - #! when referenced, will call the quotation and then return - #! back to the most recent 'show' call (via the callback-cc). - #! The text of the link will be the 'text' argument on the - #! stack. - write ; - -: install-cont-responder ( name quot -- ) - #! Install a cont-responder with the given name - #! that will initially run the given quotation. - #! - #! Convert the quotation so it is run within a session namespace - #! and that namespace is initialized first. - [ - [ cont-get/post-responder ] "get" set - [ cont-get/post-responder ] "post" set - swap "responder" set - root-callback set - ] make-responder ; - -: show-message-page ( message -- ) - #! Display the message in an HTML page with an OK button. - [ - "Press OK to Continue" [ - swap paragraph - "OK" write - ] simple-page - ] show 2drop ; diff --git a/extra/webapps/continuation/examples/authors.txt b/extra/webapps/continuation/examples/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/webapps/continuation/examples/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/webapps/continuation/examples/examples.factor b/extra/webapps/continuation/examples/examples.factor deleted file mode 100644 index 2899562503..0000000000 --- a/extra/webapps/continuation/examples/examples.factor +++ /dev/null @@ -1,115 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! -! Simple test applications -USING: hashtables html kernel io html html.elements strings math -assocs quotations webapps.continuation namespaces prettyprint -sequences ; - -IN: webapps.continuation.examples - -: display-page ( title -- ) - #! Display a page with some text to test the cont-responder. - #! The page has a link to the 'next' continuation. - [ -

over write

- swap [ - "Next" write - ] simple-html-document - ] show 2drop ; - -: display-get-name-page ( -- name ) - #! Display a page prompting for input of a name and return that name. - [ - "Enter your name" [ -

swap write

- - "Name: " write - - - - ] simple-html-document - ] show "name" swap at ; - -: test-cont-responder ( -- ) - #! Test the cont-responder responder by displaying a few pages in a row. - "Page one" display-page - "Hello " display-get-name-page append display-page - "Page three" display-page ; - -: test-cont-responder2 ( -- ) - #! Test the cont-responder responder by displaying a few pages in a loop. - [ "one" "two" "three" "four" ] [ display-page ] each - "Done!" display-page ; - -: test-cont-responder3 ( -- ) - #! Test the quot-href word by displaying a menu of the current - #! test words. Note that we use show-final as we don't link to a 'next' page. - [ - "Menu" [ -

"Menu" write

-
    -
  1. "Test responder1" [ test-cont-responder ] quot-href
  2. -
  3. "Test responder2" [ test-cont-responder2 ] quot-href
  4. -
- ] simple-html-document - ] show-final ; - -: counter-example ( count -- ) - #! Display a counter which can be incremented or decremented - #! using anchors. - #! - #! Don't need the original alist - [ - #! And we don't need the 'url' argument - drop - "Counter: " over unparse append [ - dup

unparse write

- "++" over 1quotation [ f ] swap append [ 1 + counter-example ] append quot-href - "--" over 1quotation [ f ] swap append [ 1 - counter-example ] append quot-href - drop - ] simple-html-document - ] show drop ; - -: counter-example2 ( -- ) - #! Display a counter which can be incremented or decremented - #! using anchors. - #! - 0 "counter" set - [ - #! We don't need the 'url' argument - drop - "Counter: " "counter" get unparse append [ -

"counter" get unparse write

- "++" [ "counter" get 1 + "counter" set ] quot-href - "--" [ "counter" get 1 - "counter" set ] quot-href - ] simple-html-document - ] show - drop ; - -! Install the examples -"counter1" [ drop 0 counter-example ] install-cont-responder -"counter2" [ drop counter-example2 ] install-cont-responder -"test1" [ test-cont-responder ] install-cont-responder -"test2" [ drop test-cont-responder2 ] install-cont-responder -"test3" [ drop test-cont-responder3 ] install-cont-responder diff --git a/extra/webapps/file/authors.txt b/extra/webapps/file/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/file/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor deleted file mode 100755 index 411c70c76a..0000000000 --- a/extra/webapps/file/file.factor +++ /dev/null @@ -1,136 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: calendar html io io.files kernel math math.parser -http.server.responders http.server.templating namespaces parser -sequences strings assocs hashtables debugger http.mime sorting -html.elements logging calendar.format ; -IN: webapps.file - -SYMBOL: doc-root - -: serving-path ( filename -- filename ) - "" or doc-root get swap path+ ; - -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds time+ ; - -: file-http-date ( filename -- string ) - file-modified unix-time>timestamp timestamp>http-string ; - -: file-response ( filename mime-type -- ) - "200 OK" response - [ - "Content-Type" set - dup file-length number>string "Content-Length" set - file-http-date "Last-Modified" set - now timestamp>http-string "Date" set - ] H{ } make-assoc print-header ; - -: last-modified-matches? ( filename -- bool ) - file-http-date dup [ - "if-modified-since" header-param = - ] when ; - -: not-modified-response ( -- ) - "304 Not Modified" response - now timestamp>http-string "Date" associate print-header ; - -! You can override how files are served in a custom responder -SYMBOL: serve-file-hook - -[ - dupd - file-response - stdio get stream-copy -] serve-file-hook set-global - -: serve-static ( filename mime-type -- ) - over last-modified-matches? [ - 2drop not-modified-response - ] [ - "method" get "head" = [ - file-response - ] [ - serve-file-hook get call - ] if - ] if ; - -SYMBOL: page - -: run-page ( filename -- ) - dup - [ [ dup page set run-template-file ] with-scope ] try - drop ; - -\ run-page DEBUG add-input-logging - -: include-page ( filename -- ) - serving-path run-page ; - -: serve-fhtml ( filename -- ) - serving-html - "method" get "head" = [ drop ] [ run-page ] if ; - -: serve-file ( filename -- ) - dup mime-type dup "application/x-factor-server-page" = - [ drop serve-fhtml ] [ serve-static ] if ; - -\ serve-file NOTICE add-input-logging - -: file. ( name dirp -- ) - [ "/" append ] when - dup write ; - -: directory. ( path request -- ) - dup [ -

write

-
    - directory sort-keys - [
  • file.
  • ] assoc-each -
- ] simple-html-document ; - -: list-directory ( directory -- ) - serving-html - "method" get "head" = [ - drop - ] [ - "request" get directory. - ] if ; - -: find-index ( filename -- path ) - { "index.html" "index.fhtml" } - [ dupd path+ exists? ] find nip - dup [ path+ ] [ nip ] if ; - -: serve-directory ( filename -- ) - dup "/" tail? [ - dup find-index - [ serve-file ] [ list-directory ] ?if - ] [ - drop directory-no/ - ] if ; - -: serve-object ( filename -- ) - serving-path dup exists? [ - dup directory? [ serve-directory ] [ serve-file ] if - ] [ - drop "404 not found" httpd-error - ] if ; - -: file-responder ( -- ) - doc-root get [ - "argument" get serve-object - ] [ - "404 doc-root not set" httpd-error - ] if ; - -global [ - ! Serves files from a directory stored in the doc-root - ! variable. You can set the variable in the global - ! namespace, or inside the responder. - "file" [ file-responder ] add-simple-responder - - ! The root directory is served by... - "file" set-default-responder -] bind \ No newline at end of file diff --git a/extra/webapps/source/authors.txt b/extra/webapps/source/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/source/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/source/source.factor b/extra/webapps/source/source.factor deleted file mode 100755 index 98fb5b8873..0000000000 --- a/extra/webapps/source/source.factor +++ /dev/null @@ -1,35 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io.files namespaces webapps.file http.server.responders -xmode.code2html kernel html sequences ; -IN: webapps.source - -! This responder is a potential security problem. Make sure you -! don't have sensitive files stored under vm/, core/, extra/ -! or misc/. - -: check-source-path ( path -- ? ) - { "vm/" "core/" "extra/" "misc/" } - [ head? ] with contains? ; - -: source-responder ( path mime-type -- ) - drop - serving-html - [ - dup file-name swap htmlize-stream - ] with-html-stream ; - -global [ - ! Serve up our own source code - "source" [ - "argument" get check-source-path [ - [ - "" resource-path doc-root set - [ source-responder ] serve-file-hook set - file-responder - ] with-scope - ] [ - "403 forbidden" httpd-error - ] if - ] add-simple-responder -] bind diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 3574df36db..37b833cae1 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -445,6 +445,18 @@ C-STRUCT: WIN32_FIND_DATA { { "TCHAR" 260 } "cFileName" } { { "TCHAR" 14 } "cAlternateFileName" } ; +C-STRUCT: BY_HANDLE_FILE_INFORMATION + { "DWORD" "dwFileAttributes" } + { "FILETIME" "ftCreationTime" } + { "FILETIME" "ftLastAccessTime" } + { "FILETIME" "ftLastWriteTime" } + { "DWORD" "dwVolumeSerialNumber" } + { "DWORD" "nFileSizeHigh" } + { "DWORD" "nFileSizeLow" } + { "DWORD" "nNumberOfLinks" } + { "DWORD" "nFileIndexHigh" } + { "DWORD" "nFileIndexLow" } ; + TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA TYPEDEF: void* POVERLAPPED diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor index 62d2805f01..e910ca2888 100755 --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -1,39 +1,39 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types kernel math windows windows.kernel32 -namespaces calendar.backend ; -IN: windows.time - -: >64bit ( lo hi -- n ) - 32 shift bitor ; - -: windows-1601 ( -- timestamp ) - 1601 1 1 0 0 0 0 ; - -: FILETIME>windows-time ( FILETIME -- n ) - [ FILETIME-dwLowDateTime ] keep - FILETIME-dwHighDateTime >64bit ; - -: windows-time>timestamp ( n -- timestamp ) - 10000000 /i seconds windows-1601 swap time+ ; - -: windows-time ( -- n ) - "FILETIME" [ GetSystemTimeAsFileTime ] keep - FILETIME>windows-time ; - -: timestamp>windows-time ( timestamp -- n ) - #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) - >gmt windows-1601 (time-) 10000000 * >integer ; - -: windows-time>FILETIME ( n -- FILETIME ) - "FILETIME" - [ - [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep - >r -32 shift r> set-FILETIME-dwHighDateTime - ] keep ; - -: timestamp>FILETIME ( timestamp -- FILETIME/f ) - [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; - -: FILETIME>timestamp ( FILETIME -- timestamp/f ) - FILETIME>windows-time windows-time>timestamp ; +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types kernel math windows windows.kernel32 +namespaces calendar calendar.backend ; +IN: windows.time + +: >64bit ( lo hi -- n ) + 32 shift bitor ; + +: windows-1601 ( -- timestamp ) + 1601 1 1 0 0 0 0 ; + +: FILETIME>windows-time ( FILETIME -- n ) + [ FILETIME-dwLowDateTime ] keep + FILETIME-dwHighDateTime >64bit ; + +: windows-time>timestamp ( n -- timestamp ) + 10000000 /i seconds windows-1601 swap time+ ; + +: windows-time ( -- n ) + "FILETIME" [ GetSystemTimeAsFileTime ] keep + FILETIME>windows-time ; + +: timestamp>windows-time ( timestamp -- n ) + #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) + >gmt windows-1601 (time-) 10000000 * >integer ; + +: windows-time>FILETIME ( n -- FILETIME ) + "FILETIME" + [ + [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep + >r -32 shift r> set-FILETIME-dwHighDateTime + ] keep ; + +: timestamp>FILETIME ( timestamp -- FILETIME/f ) + [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; + +: FILETIME>timestamp ( FILETIME -- timestamp/f ) + FILETIME>windows-time windows-time>timestamp ; diff --git a/extra/x11/clipboard/clipboard.factor b/extra/x11/clipboard/clipboard.factor index eb4191ebb1..0313776a20 100755 --- a/extra/x11/clipboard/clipboard.factor +++ b/extra/x11/clipboard/clipboard.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax arrays kernel math -namespaces sequences io.encodings.utf8 x11.xlib x11.constants ; +namespaces sequences io.encodings.string io.encodings.utf8 x11.xlib +x11.constants ; IN: x11.clipboard ! This code was based on by McCLIM's Backends/CLX/port.lisp @@ -35,7 +36,7 @@ TUPLE: x-clipboard atom contents ; >r XSelectionEvent-property zero? [ r> drop f ] [ - r> selection-property 1 window-property decode-utf8 + r> selection-property 1 window-property utf8 decode ] if ; : own-selection ( prop win -- ) 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/xml/xml.factor b/extra/xml/xml.factor index ec3e24b99d..970ff39cf1 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -3,7 +3,7 @@ USING: io io.streams.string io.files kernel math namespaces prettyprint sequences arrays generic strings vectors xml.char-classes xml.data xml.errors xml.tokenize xml.writer -xml.utilities state-parser assocs ascii ; +xml.utilities state-parser assocs ascii io.encodings.utf8 ; IN: xml ! -- Overall parser with data tree @@ -167,7 +167,8 @@ TUPLE: pull-xml scope ; read-xml ; : file>xml ( filename -- xml ) - read-xml ; + ! Autodetect encoding! + utf8 read-xml ; : xml-reprint ( string -- ) string>xml print-xml ; 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/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index d6402603fa..6bff786fff 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -1,6 +1,6 @@ USING: xmode.loader xmode.utilities xmode.rules namespaces strings splitting assocs sequences kernel io.files xml memoize -words globs combinators ; +words globs combinators io.encodings.utf8 ; IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; @@ -25,7 +25,7 @@ TAGS> : load-catalog ( -- modes ) "extra/xmode/modes/catalog" resource-path - read-xml parse-modes-tag ; + file>xml parse-modes-tag ; : modes ( -- assoc ) \ modes get-global [ @@ -38,7 +38,7 @@ TAGS> MEMO: (load-mode) ( name -- rule-sets ) modes at mode-file "extra/xmode/modes/" swap append - resource-path parse-mode ; + resource-path utf8 parse-mode ; SYMBOL: rule-sets diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index 3db70cf2e9..47e619cc00 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -1,5 +1,5 @@ USING: xmode.tokens xmode.marker xmode.catalog kernel html html.elements io - io.files sequences words ; + io.files sequences words io.encodings.utf8 ; IN: xmode.code2html : htmlize-tokens ( tokens -- ) @@ -20,7 +20,7 @@ IN: xmode.code2html : default-stylesheet ( -- ) ; : htmlize-stream ( path stream -- ) @@ -40,5 +40,5 @@ IN: xmode.code2html ; : htmlize-file ( path -- ) - dup over ".html" append + dup utf8 over ".html" append utf8 [ htmlize-stream ] with-stream ; diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor new file mode 100755 index 0000000000..d14ffd93b3 --- /dev/null +++ b/extra/xmode/code2html/responder/responder.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files namespaces http.server http.server.static http +xmode.code2html kernel html sequences accessors ; +IN: xmode.code2html.responder + +: ( root -- responder ) + [ + drop + "text/html" + over file-http-date "last-modified" set-header + swap [ + dup file-name swap htmlize-stream + ] curry >>body + ] ; 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..eb30ad59f7 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 ; @@ -49,5 +49,5 @@ TAGS> } ] [ "extra/xmode/utilities/test.xml" - resource-path read-xml parse-company-tag + resource-path file>xml parse-company-tag ] unit-test diff --git a/extra/yahoo/yahoo-tests.factor b/extra/yahoo/yahoo-tests.factor index 22ea687a29..197fa4900b 100644 --- a/extra/yahoo/yahoo-tests.factor +++ b/extra/yahoo/yahoo-tests.factor @@ -6,6 +6,6 @@ USING: tools.test yahoo kernel io.files xml sequences ; "Official Foo Fighters" "http://www.foofighters.com/" "Official site with news, tour dates, discography, store, community, and more." -} ] [ "extra/yahoo/test-results.xml" resource-path read-xml parse-yahoo first ] unit-test +} ] [ "extra/yahoo/test-results.xml" resource-path file>xml parse-yahoo first ] unit-test [ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 query ] unit-test diff --git a/misc/factor.sh b/misc/factor.sh index 4f503f427b..3a6d2d64f9 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -15,246 +15,247 @@ GIT_PROTOCOL=${GIT_PROTOCOL:="git"} GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"} test_program_installed() { - if ! [[ -n `type -p $1` ]] ; then - return 0; - fi - return 1; + if ! [[ -n `type -p $1` ]] ; then + return 0; + fi + return 1; } ensure_program_installed() { - installed=0; - for i in $* ; - do - echo -n "Checking for $i..." - test_program_installed $i - if [[ $? -eq 0 ]]; then - echo -n "not " - else - installed=$(( $installed + 1 )) - fi - echo "found!" - done - if [[ $installed -eq 0 ]] ; then - echo -n "Install " - if [[ $# -eq 1 ]] ; then - echo -n $1 - else - echo -n "any of [ $* ]" - fi - echo " and try again." - exit 1 - fi + installed=0; + for i in $* ; + do + echo -n "Checking for $i..." + test_program_installed $i + if [[ $? -eq 0 ]]; then + echo -n "not " + else + installed=$(( $installed + 1 )) + fi + echo "found!" + done + if [[ $installed -eq 0 ]] ; then + echo -n "Install " + if [[ $# -eq 1 ]] ; then + echo -n $1 + else + echo -n "any of [ $* ]" + fi + echo " and try again." + exit 1 + fi } check_ret() { - RET=$? - if [[ $RET -ne 0 ]] ; then - echo $1 failed - exit 2 - fi + RET=$? + if [[ $RET -ne 0 ]] ; then + echo $1 failed + exit 2 + fi } check_gcc_version() { - echo -n "Checking gcc version..." - GCC_VERSION=`gcc --version` - check_ret gcc - if [[ $GCC_VERSION == *3.3.* ]] ; then - echo "bad!" - echo "You have a known buggy version of gcc (3.3)" - echo "Install gcc 3.4 or higher and try again." - exit 3 - fi - echo "ok." + echo -n "Checking gcc version..." + GCC_VERSION=`gcc --version` + check_ret gcc + if [[ $GCC_VERSION == *3.3.* ]] ; then + echo "bad!" + echo "You have a known buggy version of gcc (3.3)" + echo "Install gcc 3.4 or higher and try again." + exit 3 + fi + echo "ok." } set_downloader() { - test_program_installed wget - if [[ $? -ne 0 ]] ; then - DOWNLOAD=wget - else - DOWNLOAD="curl -O" - fi + test_program_installed wget + if [[ $? -ne 0 ]] ; then + DOWNLOAD=wget + else + DOWNLOAD="curl -O" + fi } set_md5sum() { - test_program_installed md5sum - if [[ $? -ne 0 ]] ; then - MD5SUM=md5sum - else - MD5SUM="md5 -r" - fi + test_program_installed md5sum + if [[ $? -ne 0 ]] ; then + MD5SUM=md5sum + else + MD5SUM="md5 -r" + fi } check_installed_programs() { - ensure_program_installed chmod - ensure_program_installed uname - ensure_program_installed git - ensure_program_installed wget curl - ensure_program_installed gcc - ensure_program_installed make - ensure_program_installed md5sum md5 - ensure_program_installed cut - case $OS in - netbsd) ensure_program_installed gmake;; - esac - check_gcc_version + ensure_program_installed chmod + ensure_program_installed uname + ensure_program_installed git + ensure_program_installed wget curl + ensure_program_installed gcc + ensure_program_installed make + ensure_program_installed md5sum md5 + ensure_program_installed cut + case $OS in + macosx) ensure_program_installed port;; + netbsd) ensure_program_installed gmake;; + esac + check_gcc_version } check_library_exists() { - GCC_TEST=factor-library-test.c - GCC_OUT=factor-library-test.out - echo -n "Checking for library $1..." - echo "int main(){return 0;}" > $GCC_TEST - gcc $GCC_TEST -o $GCC_OUT -l $1 - if [[ $? -ne 0 ]] ; then - echo "not found!" - echo "Warning: library $1 not found." - echo "***Factor will compile NO_UI=1" - NO_UI=1 - fi - rm -f $GCC_TEST - check_ret rm - rm -f $GCC_OUT - check_ret rm - echo "found." + GCC_TEST=factor-library-test.c + GCC_OUT=factor-library-test.out + echo -n "Checking for library $1..." + echo "int main(){return 0;}" > $GCC_TEST + gcc $GCC_TEST -o $GCC_OUT -l $1 + if [[ $? -ne 0 ]] ; then + echo "not found!" + echo "Warning: library $1 not found." + echo "***Factor will compile NO_UI=1" + NO_UI=1 + fi + rm -f $GCC_TEST + check_ret rm + rm -f $GCC_OUT + check_ret rm + echo "found." } check_X11_libraries() { - check_library_exists freetype - check_library_exists GLU - check_library_exists GL - check_library_exists X11 + check_library_exists freetype + check_library_exists GLU + check_library_exists GL + check_library_exists X11 } check_libraries() { - case $OS in - linux) check_X11_libraries;; - esac + case $OS in + linux) check_X11_libraries;; + esac } check_factor_exists() { - if [[ -d "factor" ]] ; then - echo "A directory called 'factor' already exists." - echo "Rename or delete it and try again." - exit 4 - fi + if [[ -d "factor" ]] ; then + echo "A directory called 'factor' already exists." + echo "Rename or delete it and try again." + exit 4 + fi } find_os() { - echo "Finding OS..." - uname_s=`uname -s` - check_ret uname - case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=winnt;; - *CYGWIN_NT*) OS=winnt;; - *CYGWIN*) OS=winnt;; - *darwin*) OS=macosx;; - *Darwin*) OS=macosx;; - *linux*) OS=linux;; - *Linux*) OS=linux;; - *NetBSD*) OS=netbsd;; - esac + echo "Finding OS..." + uname_s=`uname -s` + check_ret uname + case $uname_s in + CYGWIN_NT-5.2-WOW64) OS=winnt;; + *CYGWIN_NT*) OS=winnt;; + *CYGWIN*) OS=winnt;; + *darwin*) OS=macosx;; + *Darwin*) OS=macosx;; + *linux*) OS=linux;; + *Linux*) OS=linux;; + *NetBSD*) OS=netbsd;; + esac } find_architecture() { - echo "Finding ARCH..." - uname_m=`uname -m` - check_ret uname - case $uname_m in - i386) ARCH=x86;; - i686) ARCH=x86;; - *86) ARCH=x86;; - *86_64) ARCH=x86;; - "Power Macintosh") ARCH=ppc;; - esac + echo "Finding ARCH..." + uname_m=`uname -m` + check_ret uname + case $uname_m in + i386) ARCH=x86;; + i686) ARCH=x86;; + *86) ARCH=x86;; + *86_64) ARCH=x86;; + "Power Macintosh") ARCH=ppc;; + esac } write_test_program() { - echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "#include " > $C_WORD.c + echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } find_word_size() { - echo "Finding WORD..." - C_WORD=factor-word-size - write_test_program - gcc -o $C_WORD $C_WORD.c - WORD=$(./$C_WORD) - check_ret $C_WORD - rm -f $C_WORD* + echo "Finding WORD..." + C_WORD=factor-word-size + write_test_program + gcc -o $C_WORD $C_WORD.c + WORD=$(./$C_WORD) + check_ret $C_WORD + rm -f $C_WORD* } set_factor_binary() { - case $OS in - # winnt) FACTOR_BINARY=factor-nt;; - # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; - *) FACTOR_BINARY=factor;; - esac + case $OS in + # winnt) FACTOR_BINARY=factor-nt;; + # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; + *) FACTOR_BINARY=factor;; + esac } echo_build_info() { - echo OS=$OS - echo ARCH=$ARCH - echo WORD=$WORD - echo FACTOR_BINARY=$FACTOR_BINARY - echo MAKE_TARGET=$MAKE_TARGET - echo BOOT_IMAGE=$BOOT_IMAGE - echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET - echo GIT_PROTOCOL=$GIT_PROTOCOL - echo GIT_URL=$GIT_URL + echo OS=$OS + echo ARCH=$ARCH + echo WORD=$WORD + echo FACTOR_BINARY=$FACTOR_BINARY + echo MAKE_TARGET=$MAKE_TARGET + echo BOOT_IMAGE=$BOOT_IMAGE + echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET + echo GIT_PROTOCOL=$GIT_PROTOCOL + echo GIT_URL=$GIT_URL } set_build_info() { - if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then - echo "OS: $OS" - echo "ARCH: $ARCH" - echo "WORD: $WORD" - echo "OS, ARCH, or WORD is empty. Please report this" - exit 5 - fi + if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then + echo "OS: $OS" + echo "ARCH: $ARCH" + echo "WORD: $WORD" + echo "OS, ARCH, or WORD is empty. Please report this" + exit 5 + fi - MAKE_TARGET=$OS-$ARCH-$WORD - MAKE_IMAGE_TARGET=$ARCH.$WORD - BOOT_IMAGE=boot.$ARCH.$WORD.image - if [[ $OS == macosx && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.macosx-ppc.image - fi - if [[ $OS == linux && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.linux-ppc.image - fi + MAKE_TARGET=$OS-$ARCH-$WORD + MAKE_IMAGE_TARGET=$ARCH.$WORD + BOOT_IMAGE=boot.$ARCH.$WORD.image + if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.macosx-ppc.image + fi + if [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.linux-ppc.image + fi } find_build_info() { - find_os - find_architecture - find_word_size - set_factor_binary - set_build_info - echo_build_info + find_os + find_architecture + find_word_size + set_factor_binary + set_build_info + echo_build_info } invoke_git() { - git $* - check_ret git + git $* + check_ret git } git_clone() { - echo "Downloading the git repository from factorcode.org..." - invoke_git clone $GIT_URL + echo "Downloading the git repository from factorcode.org..." + invoke_git clone $GIT_URL } git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - invoke_git pull $GIT_URL master + echo "Updating the git repository from factorcode.org..." + invoke_git pull $GIT_URL master } cd_factor() { - cd factor - check_ret cd + cd factor + check_ret cd } invoke_make() { @@ -267,128 +268,134 @@ invoke_make() { } make_clean() { - invoke_make clean + invoke_make clean } make_factor() { - invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5 + invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5 } update_boot_images() { - echo "Deleting old images..." - rm checksums.txt* > /dev/null 2>&1 - rm $BOOT_IMAGE.* > /dev/null 2>&1 - rm staging.*.image > /dev/null 2>&1 - if [[ -f $BOOT_IMAGE ]] ; then - get_url http://factorcode.org/images/latest/checksums.txt - factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`; - set_md5sum - disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`; - echo "Factorcode md5: $factorcode_md5"; - echo "Disk md5: $disk_md5"; - if [[ "$factorcode_md5" == "$disk_md5" ]] ; then - echo "Your disk boot image matches the one on factorcode.org." - else - rm $BOOT_IMAGE > /dev/null 2>&1 - get_boot_image; - fi - else - get_boot_image - fi + echo "Deleting old images..." + rm checksums.txt* > /dev/null 2>&1 + rm $BOOT_IMAGE.* > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 + if [[ -f $BOOT_IMAGE ]] ; then + get_url http://factorcode.org/images/latest/checksums.txt + factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`; + set_md5sum + disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`; + echo "Factorcode md5: $factorcode_md5"; + echo "Disk md5: $disk_md5"; + if [[ "$factorcode_md5" == "$disk_md5" ]] ; then + echo "Your disk boot image matches the one on factorcode.org." + else + rm $BOOT_IMAGE > /dev/null 2>&1 + get_boot_image; + fi + else + get_boot_image + fi } get_boot_image() { - echo "Downloading boot image $BOOT_IMAGE." - get_url http://factorcode.org/images/latest/$BOOT_IMAGE + echo "Downloading boot image $BOOT_IMAGE." + get_url http://factorcode.org/images/latest/$BOOT_IMAGE } get_url() { - if [[ $DOWNLOAD -eq "" ]] ; then - set_downloader; - fi - echo $DOWNLOAD $1 ; - $DOWNLOAD $1 - check_ret $DOWNLOAD + if [[ $DOWNLOAD -eq "" ]] ; then + set_downloader; + fi + echo $DOWNLOAD $1 ; + $DOWNLOAD $1 + check_ret $DOWNLOAD } maybe_download_dlls() { - if [[ $OS == winnt ]] ; then - get_url http://factorcode.org/dlls/freetype6.dll - get_url http://factorcode.org/dlls/zlib1.dll - get_url http://factorcode.org/dlls/OpenAL32.dll - get_url http://factorcode.org/dlls/alut.dll - get_url http://factorcode.org/dlls/ogg.dll - get_url http://factorcode.org/dlls/theora.dll - get_url http://factorcode.org/dlls/vorbis.dll - get_url http://factorcode.org/dlls/sqlite3.dll - chmod 777 *.dll - check_ret chmod - fi + if [[ $OS == winnt ]] ; then + get_url http://factorcode.org/dlls/freetype6.dll + get_url http://factorcode.org/dlls/zlib1.dll + get_url http://factorcode.org/dlls/OpenAL32.dll + get_url http://factorcode.org/dlls/alut.dll + get_url http://factorcode.org/dlls/ogg.dll + get_url http://factorcode.org/dlls/theora.dll + get_url http://factorcode.org/dlls/vorbis.dll + get_url http://factorcode.org/dlls/sqlite3.dll + chmod 777 *.dll + check_ret chmod + fi } get_config_info() { - find_build_info - check_installed_programs - check_libraries + find_build_info + check_installed_programs + check_libraries } bootstrap() { - ./$FACTOR_BINARY -i=$BOOT_IMAGE + ./$FACTOR_BINARY -i=$BOOT_IMAGE } install() { - check_factor_exists - get_config_info - git_clone - cd_factor - make_factor - get_boot_image - maybe_download_dlls - bootstrap + check_factor_exists + get_config_info + git_clone + cd_factor + make_factor + get_boot_image + maybe_download_dlls + bootstrap } update() { - get_config_info - git_pull_factorcode - make_clean - make_factor + get_config_info + git_pull_factorcode + make_clean + make_factor } update_bootstrap() { - update_boot_images - bootstrap + update_boot_images + bootstrap } refresh_image() { - ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" + check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + check_ret factor } -install_libraries() { - yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make - check_ret sudo +install_libraries_apt() { + yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + check_ret sudo +} + +install_libraries_port() { + ensure_program_installed port + yes | sudo port install git-core } usage() { - echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|net-bootstrap" - echo "If you are behind a firewall, invoke as:" - echo "env GIT_PROTOCOL=http $0 " + echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap" + echo "If you are behind a firewall, invoke as:" + echo "env GIT_PROTOCOL=http $0 " } case "$1" in - install) install ;; - install-x11) install_libraries; install ;; - self-update) update; make_boot_image; bootstrap;; - quick-update) update; refresh_image ;; - update) update; update_bootstrap ;; - bootstrap) get_config_info; bootstrap ;; - net-bootstrap) get_config_info; update_boot_images; bootstrap ;; - *) usage ;; + install) install ;; + install-x11) install_libraries_apt; install ;; + install-macosx) install_libraries_port; install ;; + self-update) update; make_boot_image; bootstrap;; + quick-update) update; refresh_image ;; + update) update; update_bootstrap ;; + bootstrap) get_config_info; bootstrap ;; + net-bootstrap) get_config_info; update_boot_images; bootstrap ;; + *) usage ;; esac diff --git a/unmaintained/cryptlib/cryptlib-tests.factor b/unmaintained/cryptlib/cryptlib-tests.factor index c404114716..aeac468ba3 100644 --- a/unmaintained/cryptlib/cryptlib-tests.factor +++ b/unmaintained/cryptlib/cryptlib-tests.factor @@ -1,5 +1,6 @@ USING: cryptlib.libcl cryptlib prettyprint kernel alien sequences libc math -tools.test io io.files continuations alien.c-types splitting generic.math ; +tools.test io io.files continuations alien.c-types splitting generic.math +io.encodings.binary ; "=========================================================" print "Envelope/de-envelop test..." print @@ -152,7 +153,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; ! envelope CRYPT_FORMAT_CRYPTLIB [ "extra/cryptlib/test/large_data.txt" resource-path - file-contents set-pop-buffer + binary file-contents set-pop-buffer envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE get-pop-buffer alien>char-string length 10000 + set-attribute envelope-handle CRYPT_ENVINFO_DATASIZE @@ -192,7 +193,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; CRYPT_FORMAT_CRYPTLIB [ envelope-handle CRYPT_ENVINFO_PASSWORD "password" set-attribute-string "extra/cryptlib/test/large_data.txt" resource-path - file-contents set-pop-buffer + binary file-contents set-pop-buffer envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE get-pop-buffer alien>char-string length 10000 + set-attribute envelope-handle CRYPT_ENVINFO_DATASIZE diff --git a/unmaintained/id3/id3.factor b/unmaintained/id3/id3.factor index b894c574f3..7f39025c4c 100755 --- a/unmaintained/id3/id3.factor +++ b/unmaintained/id3/id3.factor @@ -3,7 +3,7 @@ USING: arrays combinators io io.binary io.files io.paths io.encodings.utf16 kernel math math.parser namespaces sequences -splitting strings assocs unicode.categories ; +splitting strings assocs unicode.categories io.encodings.binary ; IN: id3 @@ -107,20 +107,20 @@ C: extended-header read-header read-frames ; : supported-version? ( version -- ? ) - [ 3 4 ] member? ; + { 3 4 } member? ; : read-id3v2 ( -- tag/f ) read1 dup supported-version? [ (read-id3v2) ] [ drop f ] if ; : id3v2? ( -- ? ) - 3 read "ID3" = ; + 3 read "ID3" sequence= ; : read-tag ( stream -- tag/f ) id3v2? [ read-id3v2 ] [ f ] if ; : id3v2 ( filename -- tag/f ) - [ read-tag ] with-file-reader ; + binary [ read-tag ] with-file-reader ; : file? ( path -- ? ) stat 3drop not ; @@ -135,7 +135,7 @@ C: extended-header [ mp3? ] subset ; : id3? ( file -- ? ) - [ id3v2? ] with-file-reader ; + binary [ id3v2? ] with-file-reader ; : id3s ( files -- id3s ) [ id3? ] subset ; diff --git a/unmaintained/mad/api/api.factor b/unmaintained/mad/api/api.factor index d803fa64e0..fdc2903d46 100644 --- a/unmaintained/mad/api/api.factor +++ b/unmaintained/mad/api/api.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Adam Wendt. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad - namespaces prettyprint sbufs sequences tools.interpreter vars ; + namespaces prettyprint sbufs sequences tools.interpreter vars + io.encodings.binary ; IN: mad.api VARS: buffer-start buffer-length output-callback-var ; @@ -80,9 +81,6 @@ VARS: buffer-start buffer-length output-callback-var ; : make-decoder ( -- decoder ) "mad_decoder" malloc-object ; -: malloc-file-contents ( path -- alien ) - file-contents >byte-array malloc-byte-array ; - : mad-run ( -- int ) make-decoder [ mad-init ] keep MAD_DECODER_MODE_SYNC mad_decoder_run ; diff --git a/extra/channels/sniffer/backend/backend.factor b/unmaintained/sniffer/channels/backend/backend.factor similarity index 100% rename from extra/channels/sniffer/backend/backend.factor rename to unmaintained/sniffer/channels/backend/backend.factor diff --git a/extra/channels/sniffer/bsd/bsd.factor b/unmaintained/sniffer/channels/bsd/bsd.factor similarity index 100% rename from extra/channels/sniffer/bsd/bsd.factor rename to unmaintained/sniffer/channels/bsd/bsd.factor diff --git a/extra/channels/sniffer/sniffer.factor b/unmaintained/sniffer/channels/sniffer.factor similarity index 100% rename from extra/channels/sniffer/sniffer.factor rename to unmaintained/sniffer/channels/sniffer.factor diff --git a/extra/io/sniffer/authors.txt b/unmaintained/sniffer/io/authors.txt similarity index 100% rename from extra/io/sniffer/authors.txt rename to unmaintained/sniffer/io/authors.txt diff --git a/extra/io/sniffer/backend/authors.txt b/unmaintained/sniffer/io/backend/authors.txt similarity index 100% rename from extra/io/sniffer/backend/authors.txt rename to unmaintained/sniffer/io/backend/authors.txt diff --git a/extra/io/sniffer/backend/backend.factor b/unmaintained/sniffer/io/backend/backend.factor similarity index 100% rename from extra/io/sniffer/backend/backend.factor rename to unmaintained/sniffer/io/backend/backend.factor diff --git a/extra/io/sniffer/bsd/authors.txt b/unmaintained/sniffer/io/bsd/authors.txt similarity index 100% rename from extra/io/sniffer/bsd/authors.txt rename to unmaintained/sniffer/io/bsd/authors.txt diff --git a/extra/io/sniffer/bsd/bsd.factor b/unmaintained/sniffer/io/bsd/bsd.factor similarity index 95% rename from extra/io/sniffer/bsd/bsd.factor rename to unmaintained/sniffer/io/bsd/bsd.factor index 1c72a4780c..5f82b21069 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/unmaintained/sniffer/io/bsd/bsd.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2007 Elie Chaftari, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax destructors hexdump io -io.buffers io.nonblocking io.sockets io.streams.lines +io.buffers io.nonblocking io.sockets io.unix.backend io.unix.files kernel libc locals math qualified sequences io.sniffer.backend ; QUALIFIED: unix IN: io.sniffer.bsd -M: unix-io destruct-handle ( obj -- ) unix:close drop ; +M: unix-io destruct-handle ( obj -- ) unix:close ; C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ; C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ; diff --git a/extra/io/sniffer/filter/authors.txt b/unmaintained/sniffer/io/filter/authors.txt similarity index 100% rename from extra/io/sniffer/filter/authors.txt rename to unmaintained/sniffer/io/filter/authors.txt diff --git a/extra/io/sniffer/filter/backend/authors.txt b/unmaintained/sniffer/io/filter/backend/authors.txt similarity index 100% rename from extra/io/sniffer/filter/backend/authors.txt rename to unmaintained/sniffer/io/filter/backend/authors.txt diff --git a/extra/io/sniffer/filter/backend/backend.factor b/unmaintained/sniffer/io/filter/backend/backend.factor similarity index 100% rename from extra/io/sniffer/filter/backend/backend.factor rename to unmaintained/sniffer/io/filter/backend/backend.factor diff --git a/extra/io/sniffer/filter/bsd/authors.txt b/unmaintained/sniffer/io/filter/bsd/authors.txt similarity index 100% rename from extra/io/sniffer/filter/bsd/authors.txt rename to unmaintained/sniffer/io/filter/bsd/authors.txt diff --git a/extra/io/sniffer/filter/bsd/bsd.factor b/unmaintained/sniffer/io/filter/bsd/bsd.factor similarity index 100% rename from extra/io/sniffer/filter/bsd/bsd.factor rename to unmaintained/sniffer/io/filter/bsd/bsd.factor diff --git a/extra/io/sniffer/filter/filter.factor b/unmaintained/sniffer/io/filter/filter.factor similarity index 100% rename from extra/io/sniffer/filter/filter.factor rename to unmaintained/sniffer/io/filter/filter.factor diff --git a/extra/io/sniffer/sniffer.factor b/unmaintained/sniffer/io/sniffer.factor similarity index 100% rename from extra/io/sniffer/sniffer.factor rename to unmaintained/sniffer/io/sniffer.factor diff --git a/vm/io.c b/vm/io.c index d3a29abe72..faf681bbef 100755 --- a/vm/io.c +++ b/vm/io.c @@ -102,21 +102,46 @@ DEFINE_PRIMITIVE(fread) } else { - dpush(tag_object(memory_to_char_string( - (char *)(buf + 1),c))); + if(c != size) + { + REGISTER_UNTAGGED(buf); + F_BYTE_ARRAY *new_buf = allot_byte_array(c); + UNREGISTER_UNTAGGED(buf); + memcpy(new_buf + 1, buf + 1,c); + buf = new_buf; + } + dpush(tag_object(buf)); break; } } } +DEFINE_PRIMITIVE(fputc) +{ + FILE *file = unbox_alien(); + F_FIXNUM ch = to_fixnum(dpop()); + + for(;;) + { + if(fputc(ch,file) == EOF) + { + io_error(); + + /* Still here? EINTR */ + } + else + break; + } +} + DEFINE_PRIMITIVE(fwrite) { - FILE* file = unbox_alien(); - F_STRING* text = untag_string(dpop()); - F_FIXNUM length = untag_fixnum_fast(text->length); - char* string = to_char_string(text,false); + FILE *file = unbox_alien(); + F_BYTE_ARRAY *text = untag_byte_array(dpop()); + F_FIXNUM length = array_capacity(text); + char *string = (char *)(text + 1); - if(string_capacity(text) == 0) + if(length == 0) return; for(;;) diff --git a/vm/io.h b/vm/io.h index 39e7390c3e..a19da3887c 100755 --- a/vm/io.h +++ b/vm/io.h @@ -3,11 +3,12 @@ void io_error(void); int err_no(void); DECLARE_PRIMITIVE(fopen); +DECLARE_PRIMITIVE(fgetc); +DECLARE_PRIMITIVE(fread); +DECLARE_PRIMITIVE(fputc); DECLARE_PRIMITIVE(fwrite); DECLARE_PRIMITIVE(fflush); DECLARE_PRIMITIVE(fclose); -DECLARE_PRIMITIVE(fgetc); -DECLARE_PRIMITIVE(fread); /* Platform specific primitives */ DECLARE_PRIMITIVE(open_file); diff --git a/vm/primitives.c b/vm/primitives.c index a5cdb4f1ef..1b29dc65b7 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -162,6 +162,7 @@ void *primitives[] = { primitive_fopen, primitive_fgetc, primitive_fread, + primitive_fputc, primitive_fwrite, primitive_fflush, primitive_fclose,