diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index 3cd5afef33..8da030c7d1 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax -bit-arrays float-arrays debugger ; +bit-arrays float-arrays debugger destructors ; HELP: { $values { "type" hashtable } } @@ -222,6 +222,9 @@ $nl { $subsection realloc } "You must always free pointers returned by any of the above words when the block of memory is no longer in use:" { $subsection free } +"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":" +{ $subsection &free } +{ $subsection |free } "You can unsafely copy a range of bytes from one memory location to another:" { $subsection memcpy } "You can copy a range of bytes from memory into a byte array:" diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f67fc78259..44c0112c77 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -382,4 +382,6 @@ M: long-long-type box-return ( type -- ) "double" define-primitive-type os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef + + "ulong" "size_t" typedef ] with-compilation-unit diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 31ba4e4b6d..6fc8ca7685 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -5,8 +5,9 @@ hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes classes.builtin classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions -slots.deprecated classes.union compiler.units -bootstrap.image.private io.files accessors combinators ; +slots.deprecated classes.union classes.intersection +compiler.units bootstrap.image.private io.files accessors +combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -127,7 +128,7 @@ bootstrapping? on : register-builtin ( class -- ) [ dup lookup-type-number "type" set-word-prop ] [ dup "type" word-prop builtins get set-nth ] - [ f f builtin-class define-class ] + [ f f f builtin-class define-class ] tri ; : define-builtin-slots ( symbol slotspec -- ) @@ -160,7 +161,7 @@ bootstrapping? on ! Catch-all class for providing a default method. "object" "kernel" create -[ f builtins get [ ] filter union-class define-class ] +[ f f { } intersection-class define-class ] [ [ drop t ] "predicate" set-word-prop ] bi @@ -172,7 +173,7 @@ builtins get num-tags get tail define-union-class ! Empty class with no instances "null" "kernel" create -[ f { } union-class define-class ] +[ f { } f union-class define-class ] [ [ drop f ] "predicate" set-word-prop ] bi diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2e087ff5bd..f94cc0ed37 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -23,7 +23,7 @@ SYMBOL: bootstrap-time : load-components ( -- ) "include" "exclude" - [ get-global " " split [ empty? not ] filter ] bi@ + [ get-global " " split harvest ] bi@ diff [ "bootstrap." prepend require ] each ; diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 7d703d3093..d995cc3176 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -46,6 +46,7 @@ IN: bootstrap.syntax "TUPLE:" "T{" "UNION:" + "INTERSECTION:" "USE:" "USING:" "V{" diff --git a/core/boxes/boxes-docs.factor b/core/boxes/boxes-docs.factor index 3b8caaca1b..df1abe992b 100755 --- a/core/boxes/boxes-docs.factor +++ b/core/boxes/boxes-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax kernel ; IN: boxes HELP: box -{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ; +{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ; HELP: { $values { "box" box } } @@ -27,12 +27,11 @@ ARTICLE: "boxes" "Boxes" { $subsection box } "Creating an empty box:" { $subsection } -"Testing if a box is full:" -{ $subsection box-full? } "Storing a value and removing a value from a box:" { $subsection >box } { $subsection box> } "Safely removing a value:" -{ $subsection ?box } ; +{ $subsection ?box } +"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ; ABOUT: "boxes" diff --git a/core/boxes/boxes-tests.factor b/core/boxes/boxes-tests.factor index 76a6cfd8b1..71fc1c9a7b 100755 --- a/core/boxes/boxes-tests.factor +++ b/core/boxes/boxes-tests.factor @@ -1,17 +1,17 @@ IN: boxes.tests -USING: boxes namespaces tools.test ; +USING: boxes namespaces tools.test accessors ; [ ] [ "b" set ] unit-test [ ] [ 3 "b" get >box ] unit-test -[ t ] [ "b" get box-full? ] unit-test +[ t ] [ "b" get occupied>> ] unit-test [ 4 "b" >box ] must-fail [ 3 ] [ "b" get box> ] unit-test -[ f ] [ "b" get box-full? ] unit-test +[ f ] [ "b" get occupied>> ] unit-test [ "b" get box> ] must-fail @@ -21,4 +21,4 @@ USING: boxes namespaces tools.test ; [ 12 t ] [ "b" get ?box ] unit-test -[ f ] [ "b" get box-full? ] unit-test +[ f ] [ "b" get occupied>> ] unit-test diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index b56a46b6b3..9e2e8a4673 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -1,24 +1,26 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; +USING: kernel accessors ; IN: boxes -TUPLE: box value full? ; +TUPLE: box value occupied ; : ( -- box ) box new ; +ERROR: box-full box ; + : >box ( value box -- ) - dup box-full? [ "Box already has a value" throw ] when - t over set-box-full? - set-box-value ; + dup occupied>> + [ box-full ] [ t >>occupied (>>value) ] if ; + +ERROR: box-empty box ; : box> ( box -- value ) - dup box-full? [ "Box empty" throw ] unless - dup box-value f pick set-box-value - f rot set-box-full? ; + dup occupied>> + [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ; : ?box ( box -- value/f ? ) - dup box-full? [ box> t ] [ drop f f ] if ; + dup occupied>> [ box> t ] [ drop f f ] if ; : if-box? ( box quot -- ) >r ?box r> [ drop ] if ; inline diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor index 27df8771c3..8a51f4c663 100755 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/core/byte-arrays/byte-arrays-docs.factor @@ -26,5 +26,6 @@ HELP: ( n -- byte-array ) HELP: >byte-array { $values { "seq" "a sequence" } { "byte-array" byte-array } } -{ $description "Outputs a freshly-allocated byte array whose elements have the same boolean values as a given sequence." } +{ $description + "Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." } { $errors "Throws an error if the sequence contains elements other than integers." } ; diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor index 9196008ba6..6ef0e85025 100644 --- a/core/checksums/checksums-docs.factor +++ b/core/checksums/checksums-docs.factor @@ -49,4 +49,7 @@ $nl { $vocab-subsection "MD5 checksum" "checksums.md5" } { $vocab-subsection "SHA1 checksum" "checksums.sha1" } { $vocab-subsection "SHA2 checksum" "checksums.sha2" } -{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } ; +{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } +{ $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ; + +ABOUT: "checksums" diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index dfe4a0fbc9..0b8fb9680b 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -1,10 +1,16 @@ -IN: classes.algebra.tests USING: alien arrays definitions generic assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable random inference effects kernel.private sbufs math.order ; +IN: classes.algebra.tests + +\ class< must-infer +\ class-and must-infer +\ class-or must-infer +\ flatten-class must-infer +\ flatten-builtin-class must-infer : class= [ class<= ] [ swap class<= ] 2bi and ; @@ -261,3 +267,38 @@ TUPLE: xg < xb ; TUPLE: xh < xb ; [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test + +INTERSECTION: generic-class generic class ; + +[ t ] [ generic-class generic class<= ] unit-test +[ t ] [ generic-class \ class class<= ] unit-test + +! Later +[ + [ t ] [ \ class generic class-and generic-class class<= ] unit-test + [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test +] drop + +[ t ] [ \ word generic-class classes-intersect? ] unit-test +[ f ] [ number generic-class classes-intersect? ] unit-test + +[ H{ { word word } } ] [ + generic-class flatten-class +] unit-test + +INTERSECTION: empty-intersection ; + +[ t ] [ object empty-intersection class<= ] unit-test +[ t ] [ empty-intersection object class<= ] unit-test +[ t ] [ \ f class-not empty-intersection class<= ] unit-test +[ f ] [ empty-intersection \ f class-not class<= ] unit-test +[ t ] [ \ number empty-intersection class<= ] unit-test +[ t ] [ empty-intersection class-not null class<= ] unit-test +[ t ] [ null empty-intersection class-not class<= ] unit-test + +[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test +[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test + +[ t ] [ object \ f class-not \ f class-or class<= ] unit-test + +[ ] [ object flatten-builtin-class drop ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 4160f4e9d2..a9c1520fc6 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -37,7 +37,7 @@ TUPLE: anonymous-union members ; C: anonymous-union -TUPLE: anonymous-intersection members ; +TUPLE: anonymous-intersection participants ; C: anonymous-intersection @@ -48,57 +48,83 @@ C: anonymous-complement : superclass<= ( first second -- ? ) >r superclass r> class<= ; -: left-union-class<= ( first second -- ? ) - >r members r> [ class<= ] curry all? ; - -: right-union-class<= ( first second -- ? ) - members [ class<= ] with contains? ; - -: left-anonymous-union< ( first second -- ? ) +: left-anonymous-union<= ( first second -- ? ) >r members>> r> [ class<= ] curry all? ; -: right-anonymous-union< ( first second -- ? ) +: right-anonymous-union<= ( first second -- ? ) members>> [ class<= ] with contains? ; -: left-anonymous-intersection< ( first second -- ? ) - >r members>> r> [ class<= ] curry contains? ; +: left-anonymous-intersection<= ( first second -- ? ) + >r participants>> r> [ class<= ] curry contains? ; -: right-anonymous-intersection< ( first second -- ? ) - members>> [ class<= ] with all? ; +: right-anonymous-intersection<= ( first second -- ? ) + participants>> [ class<= ] with all? ; -: anonymous-complement< ( first second -- ? ) +: anonymous-complement<= ( first second -- ? ) [ class>> ] bi@ swap class<= ; -: (class<=) ( first second -- -1/0/1 ) +: normalize-class ( class -- class' ) { - { [ 2dup eq? ] [ 2drop t ] } - { [ dup object eq? ] [ 2drop t ] } - { [ over null eq? ] [ 2drop t ] } - { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] } - { [ over anonymous-union? ] [ left-anonymous-union< ] } - { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] } - { [ over members ] [ left-union-class<= ] } - { [ dup anonymous-union? ] [ right-anonymous-union< ] } - { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] } - { [ over anonymous-complement? ] [ 2drop f ] } - { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } - { [ dup members ] [ right-union-class<= ] } - { [ over superclass ] [ superclass<= ] } - [ 2drop f ] + { [ dup members ] [ members ] } + { [ dup participants ] [ participants ] } + [ ] } cond ; +: normalize-complement ( class -- class' ) + class>> normalize-class { + { [ dup anonymous-union? ] [ + members>> + [ class-not normalize-class ] map + + ] } + { [ dup anonymous-intersection? ] [ + participants>> + [ class-not normalize-class ] map + + ] } + } cond ; + +: left-anonymous-complement<= ( first second -- ? ) + >r normalize-complement r> class<= ; + +PREDICATE: nontrivial-anonymous-complement < anonymous-complement + class>> { + [ anonymous-union? ] + [ anonymous-intersection? ] + [ members ] + [ participants ] + } cleave or or or ; + +PREDICATE: empty-union < anonymous-union members>> empty? ; + +PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; + +: (class<=) ( first second -- -1/0/1 ) + 2dup eq? [ 2drop t ] [ + [ normalize-class ] bi@ { + { [ dup empty-intersection? ] [ 2drop t ] } + { [ over empty-union? ] [ 2drop t ] } + { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } + { [ over anonymous-union? ] [ left-anonymous-union<= ] } + { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } + { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] } + { [ dup anonymous-union? ] [ right-anonymous-union<= ] } + { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] } + { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } + { [ over superclass ] [ superclass<= ] } + [ 2drop f ] + } cond + ] if ; + : anonymous-union-intersect? ( first second -- ? ) members>> [ classes-intersect? ] with contains? ; : anonymous-intersection-intersect? ( first second -- ? ) - members>> [ classes-intersect? ] with all? ; + participants>> [ classes-intersect? ] with all? ; : anonymous-complement-intersect? ( first second -- ? ) class>> class<= not ; -: union-class-intersect? ( first second -- ? ) - members [ classes-intersect? ] with contains? ; - : tuple-class-intersect? ( first second -- ? ) { { [ over tuple eq? ] [ 2drop t ] } @@ -115,61 +141,57 @@ C: anonymous-complement } cond ; : (classes-intersect?) ( first second -- ? ) - { + normalize-class { { [ dup anonymous-union? ] [ anonymous-union-intersect? ] } { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] } { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] } { [ dup tuple-class? ] [ tuple-class-intersect? ] } { [ dup builtin-class? ] [ builtin-class-intersect? ] } { [ dup superclass ] [ superclass classes-intersect? ] } - { [ dup members ] [ union-class-intersect? ] } } cond ; -: left-union-and ( first second -- class ) - >r members r> [ class-and ] curry map ; - -: right-union-and ( first second -- class ) - members [ class-and ] with map ; - -: left-anonymous-union-and ( first second -- class ) - >r members>> r> [ class-and ] curry map ; - -: right-anonymous-union-and ( first second -- class ) +: anonymous-union-and ( first second -- class ) members>> [ class-and ] with map ; -: left-anonymous-intersection-and ( first second -- class ) - >r members>> r> suffix ; - -: right-anonymous-intersection-and ( first second -- class ) - members>> swap suffix ; +: anonymous-intersection-and ( first second -- class ) + participants>> swap suffix ; : (class-and) ( first second -- class ) { { [ 2dup class<= ] [ drop ] } { [ 2dup swap class<= ] [ nip ] } { [ 2dup classes-intersect? not ] [ 2drop null ] } - { [ dup members ] [ right-union-and ] } - { [ dup anonymous-union? ] [ right-anonymous-union-and ] } - { [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] } - { [ over members ] [ left-union-and ] } - { [ over anonymous-union? ] [ left-anonymous-union-and ] } - { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } - [ 2array ] + [ + [ normalize-class ] bi@ { + { [ dup anonymous-union? ] [ anonymous-union-and ] } + { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] } + { [ over anonymous-union? ] [ swap anonymous-union-and ] } + { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] } + [ 2array ] + } cond + ] } cond ; -: left-anonymous-union-or ( first second -- class ) - >r members>> r> suffix ; - -: right-anonymous-union-or ( first second -- class ) +: anonymous-union-or ( first second -- class ) members>> swap suffix ; +: ((class-or)) ( first second -- class ) + [ normalize-class ] bi@ { + { [ dup anonymous-union? ] [ anonymous-union-or ] } + { [ over anonymous-union? ] [ swap anonymous-union-or ] } + [ 2array ] + } cond ; + +: anonymous-complement-or ( first second -- class ) + 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ; + : (class-or) ( first second -- class ) { { [ 2dup class<= ] [ nip ] } { [ 2dup swap class<= ] [ drop ] } - { [ dup anonymous-union? ] [ right-anonymous-union-or ] } - { [ over anonymous-union? ] [ left-anonymous-union-or ] } - [ 2array ] + { [ dup anonymous-complement? ] [ anonymous-complement-or ] } + { [ over anonymous-complement? ] [ swap anonymous-complement-or ] } + [ ((class-or)) ] } cond ; : (class-not) ( class -- complement ) @@ -203,11 +225,23 @@ C: anonymous-complement tuck [ class<= ] with all? [ peek ] [ drop f ] if ] if ; +DEFER: (flatten-class) +DEFER: flatten-builtin-class + +: flatten-intersection-class ( class -- ) + participants [ flatten-builtin-class ] map + dup empty? [ + drop builtins get [ (flatten-class) ] each + ] [ + unclip [ assoc-intersect ] reduce [ swap set ] assoc-each + ] if ; + : (flatten-class) ( class -- ) { { [ dup tuple-class? ] [ dup set ] } { [ dup builtin-class? ] [ dup set ] } { [ dup members ] [ members [ (flatten-class) ] each ] } + { [ dup participants ] [ flatten-intersection-class ] } { [ dup superclass ] [ superclass (flatten-class) ] } [ drop ] } cond ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 744944c281..9fc4f6c4e7 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -40,6 +40,7 @@ $nl "There are several sorts of classes:" { $subsection "builtin-classes" } { $subsection "unions" } +{ $subsection "intersections" } { $subsection "mixins" } { $subsection "predicates" } { $subsection "singletons" } @@ -86,7 +87,11 @@ HELP: members { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } } { $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ; +HELP: participants +{ $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } } +{ $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ; + HELP: define-class -{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } } +{ $values { "word" word } { "superclass" class } { "members" "a sequence of class words" } { "participants" "a sequence of class words" } { "metaclass" class } } { $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." } $low-level-note ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 594b2005b8..2c9e1d4787 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -57,6 +57,10 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; #! Output f for non-classes to work with algebra code dup class? [ "members" word-prop ] [ drop f ] if ; +: participants ( class -- seq ) + #! Output f for non-classes to work with algebra code + dup class? [ "participants" word-prop ] [ drop f ] if ; + GENERIC: rank-class ( class -- n ) GENERIC: reset-class ( class -- ) @@ -67,7 +71,12 @@ M: word reset-class drop ; ! update-map : class-uses ( class -- seq ) - [ members ] [ superclass ] bi [ suffix ] when* ; + [ + [ members % ] + [ participants % ] + [ superclass [ , ] when* ] + tri + ] { } make ; : class-usages ( class -- assoc ) [ update-map get at ] closure ; @@ -78,12 +87,14 @@ M: word reset-class drop ; : update-map- ( class -- ) dup class-uses update-map get remove-vertex ; -: make-class-props ( superclass members metaclass -- assoc ) +: make-class-props ( superclass members participants metaclass -- assoc ) [ - [ dup [ bootstrap-word ] when "superclass" set ] - [ [ bootstrap-word ] map "members" set ] - [ "metaclass" set ] - tri* + { + [ dup [ bootstrap-word ] when "superclass" set ] + [ [ bootstrap-word ] map "members" set ] + [ [ bootstrap-word ] map "participants" set ] + [ "metaclass" set ] + } spread ] H{ } make-assoc ; : (define-class) ( word props -- ) @@ -112,7 +123,7 @@ GENERIC: update-methods ( assoc -- ) [ update-methods ] bi ; -: define-class ( word superclass members metaclass -- ) +: define-class ( word superclass members participants metaclass -- ) #! If it was already a class, update methods after. reset-caches make-class-props diff --git a/core/classes/intersection/intersection-docs.factor b/core/classes/intersection/intersection-docs.factor new file mode 100644 index 0000000000..e9ca706d63 --- /dev/null +++ b/core/classes/intersection/intersection-docs.factor @@ -0,0 +1,28 @@ +USING: generic help.markup help.syntax kernel kernel.private +namespaces sequences words arrays layouts help effects math +layouts classes.private classes compiler.units ; +IN: classes.intersection + +ARTICLE: "intersections" "Intersection classes" +"An object is an instance of a intersection class if it is an instance of all of its participants." +{ $subsection POSTPONE: INTERSECTION: } +{ $subsection define-intersection-class } +"Intersection classes can be introspected:" +{ $subsection participants } +"The set of intersection classes is a class:" +{ $subsection intersection-class } +{ $subsection intersection-class? } +"Intersection classes are used to associate a method with objects which are simultaneously instances of multiple different classes, as well as to conveniently define predicates." ; + +ABOUT: "intersections" + +HELP: define-intersection-class +{ $values { "class" class } { "participants" "a sequence of classes" } } +{ $description "Defines a intersection class with specified participants. This is the run time equivalent of " { $link POSTPONE: INTERSECTION: } "." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } +{ $side-effects "class" } ; + +{ intersection-class define-intersection-class POSTPONE: INTERSECTION: } related-words + +HELP: intersection-class +{ $class-description "The class of intersection classes." } ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor new file mode 100644 index 0000000000..7ea8e24f0a --- /dev/null +++ b/core/classes/intersection/intersection.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: words sequences kernel assocs combinators classes +namespaces arrays math quotations ; +IN: classes.intersection + +PREDICATE: intersection-class < class + "metaclass" word-prop intersection-class eq? ; + +: intersection-predicate-quot ( members -- quot ) + dup empty? [ + drop [ drop t ] + ] [ + unclip "predicate" word-prop swap [ + "predicate" word-prop [ dup ] swap [ not ] 3append + [ drop f ] + ] { } map>assoc alist>quot + ] if ; + +: define-intersection-predicate ( class -- ) + dup participants intersection-predicate-quot define-predicate ; + +M: intersection-class update-class define-intersection-predicate ; + +: define-intersection-class ( class participants -- ) + [ f f rot intersection-class define-class ] + [ drop update-classes ] + 2bi ; + +M: intersection-class reset-class + { "class" "metaclass" "participants" } reset-props ; + +M: intersection-class rank-class drop 2 ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 4e4d1701e4..c8de36582e 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -14,7 +14,7 @@ PREDICATE: predicate-class < class ] [ ] make ; : define-predicate-class ( class superclass definition -- ) - [ drop f predicate-class define-class ] + [ drop f f predicate-class define-class ] [ nip "predicate-definition" set-word-prop ] [ 2drop diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor index 2ed51abb93..10ddde75ae 100644 --- a/core/classes/singleton/singleton-tests.factor +++ b/core/classes/singleton/singleton-tests.factor @@ -10,3 +10,10 @@ GENERIC: zammo ( obj -- str ) [ ] [ SINGLETON: omg ] unit-test [ t ] [ omg singleton-class? ] unit-test [ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test + +SINGLETON: word-and-singleton + +: word-and-singleton 3 ; + +[ t ] [ \ word-and-singleton word-and-singleton? ] unit-test +[ 3 ] [ word-and-singleton ] unit-test diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index fb9530b1c5..0cf7ea3510 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -541,7 +541,7 @@ TUPLE: another-forget-accessors-test ; ] unit-test ! Missing error check -[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail +[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail TUPLE: subclass-forget-test ; @@ -554,3 +554,5 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; [ f ] [ subclass-forget-test-1 tuple-class? ] unit-test [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test [ subclass-forget-test-3 new ] must-fail + +[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 5ebcc7a286..f4054c8468 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -160,7 +160,7 @@ M: tuple-class update-class tri ; : define-new-tuple-class ( class superclass slots -- ) - [ drop f tuple-class define-class ] + [ drop f f tuple-class define-class ] [ nip "slot-names" set-word-prop ] [ 2drop update-classes ] 3tri ; @@ -226,6 +226,12 @@ M: tuple-class reset-class } reset-props ] bi ; +: reset-tuple-class ( class -- ) + [ [ reset-class ] [ update-map- ] bi ] each-subclass ; + +M: tuple-class forget* + [ reset-tuple-class ] [ call-next-method ] bi ; + M: tuple-class rank-class drop 0 ; M: tuple clone diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor index 91726b6697..3d7312a889 100755 --- a/core/classes/union/union-docs.factor +++ b/core/classes/union/union-docs.factor @@ -4,7 +4,7 @@ layouts classes.private classes compiler.units ; IN: classes.union ARTICLE: "unions" "Union classes" -"An object is an instance of a union class if it is an instance of one of its members. Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates." +"An object is an instance of a union class if it is an instance of one of its members." { $subsection POSTPONE: UNION: } { $subsection define-union-class } "Union classes can be introspected:" @@ -12,7 +12,7 @@ ARTICLE: "unions" "Union classes" "The set of union classes is a class:" { $subsection union-class } { $subsection union-class? } -"Unions are used to define behavior shared between a fixed set of classes." +"Unions are used to define behavior shared between a fixed set of classes, as well as to conveniently define predicates." { $see-also "mixins" "tuple-subclassing" } ; ABOUT: "unions" diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 760844afb9..923c11183f 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -7,7 +7,6 @@ IN: classes.union PREDICATE: union-class < class "metaclass" word-prop union-class eq? ; -! Union classes for dispatch on multiple classes. : union-predicate-quot ( members -- quot ) dup empty? [ drop [ drop f ] @@ -24,7 +23,7 @@ PREDICATE: union-class < class M: union-class update-class define-union-predicate ; : define-union-class ( class members -- ) - [ f swap union-class define-class ] + [ f swap f union-class define-class ] [ drop update-classes ] 2bi ; diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 472136da8e..3cb7d8a71e 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private continuations.private parser vectors arrays namespaces -assocs words quotations io ; +assocs words quotations ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -28,13 +28,7 @@ $nl { $heading "Anti-pattern #3: Dropping and rethrowing" } "Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." { $heading "Anti-pattern #4: Logging and rethrowing" } -"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." -{ $heading "Anti-pattern #5: Leaking external resources" } -"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:" -{ $code - " ... do stuff ... dispose" -} -"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ; +"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ; ARTICLE: "errors" "Error handling" "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." @@ -88,19 +82,6 @@ $nl ABOUT: "continuations" -HELP: dispose -{ $values { "object" "a disposable object" } } -{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." -$nl -"No further operations can be performed on a disposable object after this call." -$nl -"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." } -{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ; - -HELP: with-disposal -{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } } -{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ; - HELP: catchstack* { $values { "catchstack" "a vector of continuations" } } { $description "Outputs the current catchstack." } ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 28581820fd..27e1f02b91 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -101,21 +101,6 @@ SYMBOL: error-counter [ 1 ] [ error-counter get ] unit-test ] with-scope -TUPLE: dispose-error ; - -M: dispose-error dispose 3 throw ; - -TUPLE: dispose-dummy disposed? ; - -M: dispose-dummy dispose t >>disposed? drop ; - -T{ dispose-error } "a" set -T{ dispose-dummy } "b" set - -[ f ] [ "b" get disposed?>> ] unit-test - -[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with - -[ t ] [ "b" get disposed?>> ] unit-test - [ ] [ [ return ] with-return ] unit-test + +[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 78effb043a..76f2cdef7a 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -139,20 +139,16 @@ SYMBOL: thread-error-hook over >r compose [ dip rethrow ] curry recover r> call ; inline +ERROR: attempt-all-error ; + : attempt-all ( seq quot -- obj ) - [ - [ [ , f ] compose [ , drop t ] recover ] curry all? - ] { } make peek swap [ rethrow ] when ; inline - -GENERIC: dispose ( object -- ) - -: dispose-each ( seq -- ) - [ - [ [ dispose ] curry [ , ] recover ] each - ] { } make dup empty? [ drop ] [ peek rethrow ] if ; - -: with-disposal ( object quot -- ) - over [ dispose ] curry [ ] cleanup ; inline + over empty? [ + attempt-all-error + ] [ + [ + [ [ , f ] compose [ , drop t ] recover ] curry all? + ] { } make peek swap [ rethrow ] when + ] if ; inline TUPLE: condition error restarts continuation ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 9c44a6a656..ebaa6056ff 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >> : split-struct ( pairs -- seq ) [ [ 8 mod zero? [ t , ] when , ] assoc-each - ] { } make { t } split [ empty? not ] filter ; + ] { } make { t } split harvest ; : flatten-large-struct ( type -- ) heap-size cell align diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index df7d33f41c..e6dfb79e07 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -7,7 +7,7 @@ splitting math.parser classes.tuple continuations continuations.private combinators generic.math classes.builtin classes compiler.units generic.standard vocabs threads threads.private init kernel.private libc io.encodings -mirrors accessors math.order ; +mirrors accessors math.order destructors ; IN: debugger GENERIC: error. ( error -- ) @@ -298,6 +298,10 @@ M: immutable-slot summary drop "Slot is immutable" ; M: bad-create summary drop "Bad parameters to create" ; +M: attempt-all-error summary drop "Nothing to attempt" ; + +M: already-disposed summary drop "Attempting to operate on disposed object" ; + ... do stuff ... dispose" +} +"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ; + +ARTICLE: "destructors" "Deterministic resource disposal" +"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability." +$nl +"Disposable object protocol:" +{ $subsection dispose } +{ $subsection dispose* } +"Utility word for scoped disposal:" +{ $subsection with-disposal } +"Utility word for disposing multiple objects:" +{ $subsection dispose-each } +"Utility words for more complex disposal patterns:" +{ $subsection with-destructors } +{ $subsection &dispose } +{ $subsection |dispose } +{ $subsection "destructors-anti-patterns" } ; + +ABOUT: "destructors" diff --git a/extra/destructors/destructors-tests.factor b/core/destructors/destructors-tests.factor similarity index 62% rename from extra/destructors/destructors-tests.factor rename to core/destructors/destructors-tests.factor index 59c325c490..f442e27a04 100755 --- a/extra/destructors/destructors-tests.factor +++ b/core/destructors/destructors-tests.factor @@ -1,6 +1,24 @@ -USING: destructors kernel tools.test continuations ; +USING: destructors kernel tools.test continuations accessors +namespaces sequences ; IN: destructors.tests +TUPLE: dispose-error ; + +M: dispose-error dispose 3 throw ; + +TUPLE: dispose-dummy disposed? ; + +M: dispose-dummy dispose t >>disposed? drop ; + +T{ dispose-error } "a" set +T{ dispose-dummy } "b" set + +[ f ] [ "b" get disposed?>> ] unit-test + +[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with + +[ t ] [ "b" get disposed?>> ] unit-test + TUPLE: dummy-obj destroyed? ; : dummy-obj new ; @@ -13,10 +31,10 @@ M: dummy-destructor dispose ( obj -- ) dummy-destructor-obj t swap set-dummy-obj-destroyed? ; : destroy-always - add-always-destructor ; + &dispose drop ; : destroy-later - add-error-destructor ; + |dispose drop ; [ t ] [ [ diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor new file mode 100755 index 0000000000..bed1c16bcf --- /dev/null +++ b/core/destructors/destructors.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors continuations kernel namespaces +sequences vectors ; +IN: destructors + +TUPLE: disposable disposed ; + +GENERIC: dispose* ( disposable -- ) + +ERROR: already-disposed disposable ; + +: check-disposed ( disposable -- ) + dup disposed>> [ already-disposed ] [ drop ] if ; inline + +GENERIC: dispose ( disposable -- ) + +M: object dispose + dup disposed>> [ drop ] [ t >>disposed dispose* ] if ; + +: dispose-each ( seq -- ) + [ + [ [ dispose ] curry [ , ] recover ] each + ] { } make dup empty? [ drop ] [ peek rethrow ] if ; + +: with-disposal ( object quot -- ) + over [ dispose ] curry [ ] cleanup ; inline + + dispose-each ; + +: do-error-destructors ( -- ) + error-destructors get dispose-each ; + +PRIVATE> + +: &dispose ( disposable -- disposable ) + dup always-destructors get push ; inline + +: |dispose ( disposable -- disposable ) + dup error-destructors get push ; inline + +: with-destructors ( quot -- ) + [ + V{ } clone always-destructors set + V{ } clone error-destructors set + [ do-always-destructors ] + [ do-error-destructors ] + cleanup + ] with-scope ; inline diff --git a/extra/destructors/summary.txt b/core/destructors/summary.txt similarity index 100% rename from extra/destructors/summary.txt rename to core/destructors/summary.txt diff --git a/core/generic/generic.factor b/core/generic/generic.factor index d35ba01e52..e446689303 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: words kernel sequences namespaces assocs hashtables definitions kernel.private classes classes.private -classes.algebra quotations arrays vocabs effects ; +classes.algebra quotations arrays vocabs effects combinators ; IN: generic ! Method combination protocol @@ -123,12 +123,13 @@ M: method-body definer M: method-body forget* dup "forgotten" word-prop [ drop ] [ [ - [ "method-class" word-prop ] - [ "method-generic" word-prop ] bi - dup generic? [ - [ delete-at* ] with-methods - [ call-next-method ] [ drop ] if - ] [ 2drop ] if + [ ] + [ "method-class" word-prop ] + [ "method-generic" word-prop ] tri + 3dup method eq? [ + [ delete-at ] with-methods + call-next-method + ] [ 3drop ] if ] [ t "forgotten" set-word-prop ] bi ] if ; @@ -146,10 +147,12 @@ M: method-body forget* [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; M: class forget* ( class -- ) - [ forget-methods ] - [ update-map- ] - [ call-next-method ] - tri ; + { + [ forget-methods ] + [ update-map- ] + [ reset-class ] + [ call-next-method ] + } cleave ; M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 5896429ccf..c49e7fda8a 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ; : balanced? ( in out -- ? ) [ dup [ length - ] [ 2drop f ] if ] 2map - [ ] filter all-equal? ; + sift all-equal? ; TUPLE: unbalanced-branches-error quots in out ; @@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ; 2dup balanced? [ over supremum -rot [ >r dupd r> unify-inputs ] 2map - [ ] filter unify-stacks + sift unify-stacks rot drop ] [ unbalanced-branches-error diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index f688f60e56..46d1049a11 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector classes.tuple classes.union classes.predicate debugger threads.private io.streams.string -io.timeouts io.thread sequences.private ; +io.timeouts io.thread sequences.private destructors ; IN: inference.tests [ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index ff5fc478ca..2d45ce0d0c 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -356,7 +356,7 @@ M: object infer-call \ setenv { object fixnum } { } set-primitive-effect -\ exists? { string } { object } set-primitive-effect +\ (exists?) { string } { object } set-primitive-effect \ (directory) { string } { array } set-primitive-effect diff --git a/core/io/binary/binary-docs.factor b/core/io/binary/binary-docs.factor index edf65491fe..507571c044 100644 --- a/core/io/binary/binary-docs.factor +++ b/core/io/binary/binary-docs.factor @@ -6,12 +6,12 @@ ARTICLE: "stream-binary" "Working with binary data" $nl "There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around." $nl -"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Big endian byte order yields the following sequence of bytes:" +"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Little endian byte order yields the following sequence of bytes:" { $table { "Byte:" "1" "2" "3" "4" } { "Value:" { $snippet "be" } { $snippet "ba" } { $snippet "fe" } { $snippet "ca" } } } -"Compare this with little endian byte order:" +"Compare this with big endian byte order:" { $table { "Byte:" "1" "2" "3" "4" } { "Value:" { $snippet "ca" } { $snippet "fe" } { $snippet "ba" } { $snippet "be" } } diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index daaf1c129d..3fe6f9d6aa 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces growable -strings io classes continuations combinators io.styles -io.streams.plain splitting byte-arrays sequences.private -accessors ; +strings io classes continuations destructors combinators +io.styles io.streams.plain splitting byte-arrays +sequences.private accessors ; IN: io.encodings ! The encoding descriptor protocol diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index ec74bb001e..e5034d6103 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -300,8 +300,8 @@ HELP: exists? { $description "Tests if the file named by " { $snippet "path" } " exists." } ; HELP: directory? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "path" } " names a directory." } ; +{ $values { "file-info" file-info } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "file-info" } " is a directory." } ; HELP: (directory) { $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 84b0bd3e09..f10bcef8a9 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,11 +1,14 @@ IN: io.files.tests USING: tools.test io.files io.files.private io threads kernel continuations io.encodings.ascii io.files.unique sequences -strings accessors io.encodings.utf8 math ; +strings accessors io.encodings.utf8 math destructors ; + +\ exists? must-infer +\ (exists?) must-infer [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test -[ t ] [ "blahblah" temp-file directory? ] unit-test +[ t ] [ "blahblah" temp-file file-info directory? ] unit-test [ t ] [ [ temp-directory "loldir" append-path delete-directory ] ignore-errors @@ -66,6 +69,9 @@ strings accessors io.encodings.utf8 math ; [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ "" ] [ "" file-name ] unit-test +[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test +[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test + [ ] [ { "Hello world." } "test-foo.txt" temp-file ascii set-file-lines @@ -99,6 +105,8 @@ strings accessors io.encodings.utf8 math ; [ f ] [ "test-bar.txt" temp-file exists? ] unit-test +[ "test-blah" temp-file delete-tree ] ignore-errors + [ ] [ "test-blah" temp-file make-directory ] unit-test [ ] [ diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 76c7b144d0..87e927304b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -2,8 +2,8 @@ ! 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 io.encodings -io.encodings.binary init accessors math.order ; +system combinators splitting sbufs continuations destructors +io.encodings io.encodings.binary init accessors math.order ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -142,7 +142,9 @@ PRIVATE> : file-name ( path -- string ) dup root-directory? [ right-trim-separators - dup last-path-separator [ 1+ tail ] [ drop ] if + dup last-path-separator [ 1+ tail ] [ + drop "resource:" ?head [ file-name ] when + ] if ] unless ; ! File info @@ -170,11 +172,9 @@ SYMBOL: +socket+ SYMBOL: +unknown+ ! File metadata -: exists? ( path -- ? ) - normalize-path (exists?) ; +: exists? ( path -- ? ) normalize-path (exists?) ; -: directory? ( path -- ? ) - file-info file-info-type +directory+ = ; +: directory? ( file-info -- ? ) type>> +directory+ = ; c-writer +: ( handle -- stream ) f c-writer boa ; M: c-writer stream-write1 - c-writer-handle fputc ; + dup check-disposed + handle>> fputc ; M: c-writer stream-write - c-writer-handle fwrite ; + dup check-disposed + handle>> fwrite ; M: c-writer stream-flush - c-writer-handle fflush ; + dup check-disposed + handle>> fflush ; -M: c-writer dispose - c-writer-handle fclose ; +M: c-writer dispose* + handle>> fclose ; -TUPLE: c-reader handle ; +TUPLE: c-reader handle disposed ; -C: c-reader +: ( handle -- stream ) f c-reader boa ; M: c-reader stream-read - c-reader-handle fread ; + dup check-disposed + handle>> fread ; M: c-reader stream-read-partial stream-read ; M: c-reader stream-read1 - c-reader-handle fgetc ; + dup check-disposed + handle>> fgetc ; : read-until-loop ( stream delim -- ch ) over stream-read1 dup [ @@ -42,11 +47,12 @@ M: c-reader stream-read1 ] if ; M: c-reader stream-read-until + dup check-disposed [ swap read-until-loop ] B{ } make swap over empty? over not and [ 2drop f f ] when ; -M: c-reader dispose - c-reader-handle fclose ; +M: c-reader dispose* + handle>> fclose ; M: object init-io ; diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor index fd67910b6f..bb6a7a9111 100755 --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs kernel namespaces strings -quotations io continuations accessors sequences ; +quotations io continuations destructors accessors sequences ; IN: io.streams.nested TUPLE: filter-writer stream ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index c0b37dbce7..355e913b14 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math namespaces sequences sbufs strings -generic splitting growable continuations io.streams.plain -io.encodings math.order ; +generic splitting growable continuations destructors +io.streams.plain io.encodings math.order ; IN: io.streams.string M: growable dispose drop ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 0ef8919713..e4100557e1 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -148,7 +148,7 @@ $nl { $subsection "spread-shuffle-equivalence" } ; ARTICLE: "apply-combinators" "Apply combinators" -"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application." +"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." $nl "Two quotations:" { $subsection bi@ } @@ -179,6 +179,7 @@ ARTICLE: "compositional-combinators" "Compositional combinators" { $subsection with } { $subsection compose } { $subsection 3compose } +{ $subsection prepose } "Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ; ARTICLE: "implementing-combinators" "Implementing combinators" @@ -717,17 +718,21 @@ $nl HELP: unless* { $values { "cond" "a generalized boolean" } { "false" "a quotation " } } -{ $description "Variant of " { $link if* } " with no true quotation." -$nl +{ $description "Variant of " { $link if* } " with no true quotation." } +{ $notes "The following two lines are equivalent:" -{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ; +{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } +"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" +{ $code "[ L ] unless*" "L or" } } ; HELP: ?if { $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } } -{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." -$nl +{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." } +{ $notes "The following two lines are equivalent:" -{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ; +{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } +"The following two lines are equivalent:" +{ $code "[ ] [ ] ?if" "swap or" } } ; HELP: die { $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } @@ -835,8 +840,16 @@ HELP: compose ( quot1 quot2 -- compose ) "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations." } ; + +HELP: prepose +{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } } +{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." } +{ $notes "See " { $link compose } " for details." } ; + +{ compose prepose } related-words + HELP: 3compose -{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } } +{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." } { $notes "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:" diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index a72e25b9e0..a989d6c833 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -156,10 +156,10 @@ M: callstack clone (clone) ; : with ( param obj quot -- obj curry ) swapd [ swapd call ] 2curry ; inline -: prepose ( quot1 quot2 -- curry ) +: prepose ( quot1 quot2 -- compose ) swap compose ; inline -: 3compose ( quot1 quot2 quot3 -- curry ) +: 3compose ( quot1 quot2 quot3 -- compose ) compose compose ; inline ! Booleans diff --git a/core/libc/libc-docs.factor b/core/libc/libc-docs.factor index 45d6b94326..5e285bf26d 100644 --- a/core/libc/libc-docs.factor +++ b/core/libc/libc-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax alien ; +USING: help.markup help.syntax alien destructors ; IN: libc HELP: malloc @@ -36,5 +36,13 @@ HELP: with-malloc { $values { "size" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } } { $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ; +HELP: &free +{ $values { "alien" c-ptr } } +{ $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ; + +HELP: |free +{ $values { "alien" c-ptr } } +{ $description "Marks the object for deallocation in the event of an error at the end of the current " { $link with-destructors } " scope." } ; + ! Defined in alien-docs.factor ABOUT: "malloc" diff --git a/core/libc/libc-tests.factor b/core/libc/libc-tests.factor new file mode 100755 index 0000000000..249399bdd0 --- /dev/null +++ b/core/libc/libc-tests.factor @@ -0,0 +1,11 @@ +IN: libc.tests +USING: libc libc.private tools.test namespaces assocs +destructors kernel ; + +100 malloc "block" set + +[ t ] [ "block" get mallocs get key? ] unit-test + +[ ] [ [ "block" get &free drop ] with-destructors ] unit-test + +[ f ] [ "block" get mallocs get key? ] unit-test diff --git a/core/libc/libc.factor b/core/libc/libc.factor index 756d29e551..dff6e9e0f1 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2004, 2005 Mackenzie Straight -! Copyright (C) 2007 Slava Pestov -! Copyright (C) 2007 Doug Coleman +! Copyright (C) 2007, 2008 Slava Pestov +! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations init kernel namespaces ; +USING: alien assocs continuations destructors init kernel +namespaces accessors ; IN: libc : with-malloc ( size quot -- ) swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline + +: strlen ( alien -- len ) + "size_t" "libc" "strlen" { "char*" } alien-invoke ; + +> free ; + +PRIVATE> + +: &free ( alien -- alien ) + dup f memory-destructor boa &dispose drop ; inline + +: |free ( alien -- alien ) + dup f memory-destructor boa |dispose drop ; inline diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 9c3c1d9f6c..3df9dc9cb2 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -435,3 +435,28 @@ must-fail-with [ 92 ] [ "CHAR: \\" eval ] unit-test [ 92 ] [ "CHAR: \\\\" eval ] unit-test + +[ ] [ + { + "IN: parser.tests" + "USING: math arrays ;" + "GENERIC: change-combination" + "M: integer change-combination 1 ;" + "M: array change-combination 2 ;" + } "\n" join "change-combination-test" parse-stream drop +] unit-test + +[ ] [ + { + "IN: parser.tests" + "USING: math arrays ;" + "GENERIC# change-combination 1" + "M: integer change-combination 1 ;" + "M: array change-combination 2 ;" + } "\n" join "change-combination-test" parse-stream drop +] unit-test + +[ 2 ] [ + "change-combination" "parser.tests" lookup + "methods" word-prop assoc-size +] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 76c831cf13..f08ba8fbc2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -207,7 +207,7 @@ SYMBOL: in : add-use ( seq -- ) [ use+ ] each ; : set-use ( seq -- ) - [ vocab-words ] map [ ] filter >vector use set ; + [ vocab-words ] V{ } map-as sift use set ; : check-vocab-string ( name -- name ) dup string? @@ -278,7 +278,7 @@ M: no-word-error summary dup forward-reference? [ drop use get - [ at ] with map [ ] filter + [ at ] with map sift [ forward-reference? not ] find nip ] [ nip diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 0faae398e9..ed6b2f3c3c 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -334,5 +334,11 @@ PREDICATE: predicate-see-test < integer even? ; [ \ predicate-see-test see ] with-string-writer ] unit-test +INTERSECTION: intersection-see-test sequence number ; + +[ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [ + [ \ intersection-see-test see ] with-string-writer +] unit-test + [ ] [ \ compose see ] unit-test [ ] [ \ curry see ] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 4974e1df3c..a3c3f4926b 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -7,8 +7,8 @@ vectors words prettyprint.backend prettyprint.sections prettyprint.config sorting splitting math.parser vocabs definitions effects classes.builtin classes.tuple io.files classes continuations hashtables classes.mixin classes.union -classes.predicate classes.singleton combinators quotations -sets ; +classes.intersection classes.predicate classes.singleton +combinators quotations sets ; : make-pprint ( obj quot -- block in use ) [ @@ -238,6 +238,11 @@ M: union-class see-class* dup pprint-word members pprint-elements pprint-; block> ; +M: intersection-class see-class* + ; + M: mixin-class see-class* : remove ( obj seq -- newseq ) [ = not ] with filter ; +: sift ( seq -- newseq ) + [ ] filter ; + +: harvest ( seq -- newseq ) + [ empty? not ] filter ; + : cache-nth ( i seq quot -- elt ) 2over ?nth dup [ >r 3drop r> diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index 90f468a185..3e2f899774 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; { [ over string? ] [ >r dupd r> short-slot ] } { [ over array? ] [ long-slot ] } } cond - ] 2map [ ] filter nip ; + ] 2map sift nip ; : slot-of-reader ( reader specs -- spec/f ) [ slot-spec-reader eq? ] with find nip ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index b72ed9a2cb..0dc834ad6b 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -496,14 +496,17 @@ HELP: M: HELP: UNION: { $syntax "UNION: class members... ;" } { $values { "class" "a new class word to define" } { "members" "a list of class words separated by whitespace" } } -{ $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." } -{ $notes "Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates." } ; +{ $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." } ; + +HELP: INTERSECTION: +{ $syntax "INTERSECTION: class participants... ;" } +{ $values { "class" "a new class word to define" } { "participants" "a list of class words separated by whitespace" } } +{ $description "Defines an intersection class. An object is an instance of a union class if it is an instance of all of its participants." } ; HELP: MIXIN: { $syntax "MIXIN: class" } { $values { "class" "a new class word to define" } } { $description "Defines a mixin class. A mixin is similar to a union class, except it has no members initially, and new members can be added with the " { $link POSTPONE: INSTANCE: } " word." } -{ $notes "Mixins classes are used to mark implementations of a protocol and define default methods." } { $examples "The " { $link sequence } " and " { $link assoc } " mixin classes." } ; HELP: INSTANCE: diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 2e1c46fac1..2410185b18 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -5,8 +5,9 @@ definitions generic hashtables kernel math namespaces parser sequences strings sbufs vectors words quotations io assocs splitting classes.tuple generic.standard generic.math classes io.files vocabs float-arrays -classes.union classes.mixin classes.predicate classes.singleton -compiler.units combinators debugger ; +classes.union classes.intersection classes.mixin +classes.predicate classes.singleton compiler.units +combinators debugger ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -135,6 +136,10 @@ IN: bootstrap.syntax CREATE-CLASS parse-definition define-union-class ] define-syntax + "INTERSECTION:" [ + CREATE-CLASS parse-definition define-intersection-class + ] define-syntax + "MIXIN:" [ CREATE-CLASS define-mixin-class ] define-syntax @@ -153,8 +158,7 @@ IN: bootstrap.syntax ] define-syntax "SINGLETON:" [ - scan create-class-in - dup save-location define-singleton-class + CREATE-CLASS define-singleton-class ] define-syntax "TUPLE:" [ diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index edd82b2596..57951e8642 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- ) : words-named ( str -- seq ) dictionary get values [ vocab-words at ] with map - [ ] filter ; + sift ; : child-vocab? ( prefix name -- ? ) 2dup = pick empty? or diff --git a/core/words/words.factor b/core/words/words.factor index b640cc6384..5812516912 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -3,7 +3,7 @@ USING: arrays definitions graphs assocs kernel kernel.private slots.private math namespaces sequences strings vectors sbufs quotations assocs hashtables sorting words.private vocabs -math.order ; +math.order sets ; IN: words : word ( -- word ) \ word get-global ; @@ -121,7 +121,7 @@ SYMBOL: +called+ compiled-crossref get at ; : compiled-usages ( words -- seq ) - [ [ dup ] H{ } map>assoc dup ] keep [ + [ unique dup ] keep [ compiled-usage [ nip +inlined+ eq? ] assoc-filter update ] with each keys ; diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 247be44bad..7c274edb2e 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -2,9 +2,6 @@ USING: arrays assocs kernel vectors sequences namespaces random math.parser ; IN: assocs.lib -: >set ( seq -- hash ) - [ dup ] H{ } map>assoc ; - : ref-at ( table key -- value ) swap at ; : put-at* ( table key value -- ) swap rot set-at ; diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index abe3250ecf..a409c97815 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: accessors calendar kernel math math.order money sequences ; IN: bank diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 6defd94290..673a67d93f 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,6 +1,7 @@ USING: io.sockets io kernel math threads io.encodings.ascii io.streams.duplex debugger tools.time prettyprint -concurrency.count-downs namespaces arrays continuations ; +concurrency.count-downs namespaces arrays continuations +destructors ; IN: benchmark.sockets SYMBOL: counter diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index 46aca6cc6b..c2e80fee9a 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.image.download -USING: http.client checksums checksums.md5 splitting assocs +USING: http.client checksums checksums.openssl splitting assocs kernel io.files bootstrap.image sequences io ; : url "http://factorcode.org/images/latest/" ; @@ -12,8 +12,11 @@ kernel io.files bootstrap.image sequences io ; : need-new-image? ( image -- ? ) dup exists? - [ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ] - [ drop t ] if ; + [ + [ openssl-md5 checksum-file hex-string ] + [ download-checksums at ] + bi = not + ] [ drop t ] if ; : download-image ( arch -- ) boot-image-name dup need-new-image? [ diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 30d0428744..29c9d5b072 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: http.client checksums checksums.md5 splitting assocs +USING: checksums checksums.openssl splitting assocs kernel io.files bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ; IN: bootstrap.image.upload @@ -19,7 +19,9 @@ SYMBOL: upload-images-destination : compute-checksums ( -- ) checksums ascii [ boot-image-names [ - [ write bl ] [ md5 checksum-file hex-string print ] bi + [ write bl ] + [ openssl-md5 checksum-file hex-string print ] + bi ] each ] with-file-writer ; diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor deleted file mode 100644 index afe277d30b..0000000000 --- a/extra/builder/benchmark/benchmark.factor +++ /dev/null @@ -1,43 +0,0 @@ - -USING: kernel continuations arrays assocs sequences sorting math - io io.styles prettyprint builder.util ; - -IN: builder.benchmark - -! : passing-benchmarks ( table -- table ) -! [ second first2 number? swap number? and ] filter ; - -: passing-benchmarks ( table -- table ) [ second number? ] filter ; - -! : simplify-table ( table -- table ) [ first2 second 2array ] map ; - -: benchmark-difference ( old-table benchmark-result -- result-diff ) - first2 >r - tuck swap at - r> - swap - - 2array ; - -: compare-tables ( old new -- table ) - [ passing-benchmarks ] bi@ - [ benchmark-difference ] with map ; - -: benchmark-deltas ( -- table ) - "../benchmarks" "benchmarks" [ eval-file ] bi@ - compare-tables - sort-values ; - -: benchmark-deltas. ( deltas -- ) - standard-table-style - [ - [ [ "Benchmark" write ] with-cell [ "Delta (ms)" write ] with-cell ] - with-row - [ [ swap [ write ] with-cell pprint-cell ] with-row ] - assoc-each - ] - tabular-output ; - -: show-benchmark-deltas ( -- ) - [ benchmark-deltas benchmark-deltas. ] - [ drop "Error generating benchmark deltas" . ] - recover ; \ No newline at end of file diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index f9ab6c1d1d..db3b476365 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -41,12 +41,17 @@ DEFER: to-strings : host-name* ( -- name ) host-name "." split first ; +! : datestamp ( -- string ) +! now `{ ,[ dup timestamp-year ] +! ,[ dup timestamp-month ] +! ,[ dup timestamp-day ] +! ,[ dup timestamp-hour ] +! ,[ timestamp-minute ] } +! [ pad-00 ] map "-" join ; + : datestamp ( -- string ) - now `{ ,[ dup timestamp-year ] - ,[ dup timestamp-month ] - ,[ dup timestamp-day ] - ,[ dup timestamp-hour ] - ,[ timestamp-minute ] } + now + { year>> month>> day>> hour>> minute>> } [ pad-00 ] map "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index d546f9ea41..b315e4ca5a 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib float-arrays continuations opengl.demo-support multiline ui.gestures bunny.fixed-pipeline -bunny.cel-shaded bunny.outlined bunny.model accessors ; +bunny.cel-shaded bunny.outlined bunny.model accessors destructors ; IN: bunny TUPLE: bunny-gadget model geom draw-seq draw-n ; @@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- ) [ ] [ ] [ ] tri 3array - [ ] filter >>draw-seq + sift >>draw-seq 0 >>draw-n drop ; diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index 08bea0515b..8285cd776f 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -1,5 +1,6 @@ -USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders - opengl.capabilities opengl.gl sequences sequences.lib accessors ; +USING: arrays bunny.model continuations destructors kernel +multiline opengl opengl.shaders opengl.capabilities opengl.gl +sequences sequences.lib accessors ; IN: bunny.cel-shaded STRING: vertex-shader-source diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor index bf0fc45f0f..0bad9cc943 100644 --- a/extra/bunny/fixed-pipeline/fixed-pipeline.factor +++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor @@ -1,4 +1,4 @@ -USING: alien.c-types continuations kernel +USING: alien.c-types continuations destructors kernel opengl opengl.gl bunny.model ; IN: bunny.fixed-pipeline diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 239603755d..2dac9eb688 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -2,11 +2,12 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices 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 -float-arrays continuations namespaces sequences.lib accessors ; +float-arrays continuations destructors namespaces sequences.lib +accessors ; IN: bunny.model : numbers ( str -- seq ) - " " split [ string>number ] map [ ] filter ; + " " split [ string>number ] map sift ; : (parse-model) ( vs is -- vs is ) readln [ diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index fef57d95d2..f3ee4594c7 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,7 +1,7 @@ -USING: arrays bunny.model bunny.cel-shaded continuations kernel -math multiline opengl opengl.shaders opengl.framebuffers -opengl.gl opengl.capabilities sequences ui.gadgets combinators -accessors ; +USING: arrays bunny.model bunny.cel-shaded continuations +destructors kernel math multiline opengl opengl.shaders +opengl.framebuffers opengl.gl opengl.capabilities sequences +ui.gadgets combinators accessors ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source diff --git a/extra/cairo/cairo.factor b/extra/cairo/cairo.factor new file mode 100755 index 0000000000..46d3e42c2b --- /dev/null +++ b/extra/cairo/cairo.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: cairo.ffi kernel accessors sequences +namespaces fry continuations destructors ; +IN: cairo + +TUPLE: cairo-t alien ; +C: cairo-t +M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ; + +TUPLE: cairo-surface-t alien ; +C: cairo-surface-t +M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ; + +: check-cairo ( cairo_status_t -- ) + dup CAIRO_STATUS_SUCCESS = [ drop ] + [ cairo_status_to_string "Cairo error: " prepend throw ] if ; + +SYMBOL: cairo +: cr ( -- cairo ) cairo get ; + +: (with-cairo) ( cairo-t quot -- ) + >r alien>> cairo r> [ cr cairo_status check-cairo ] + compose with-variable ; inline + +: with-cairo ( cairo quot -- ) + >r r> [ (with-cairo) ] curry with-disposal ; inline + +: (with-surface) ( cairo-surface-t quot -- ) + >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline + +: with-surface ( cairo_surface quot -- ) + >r r> [ (with-surface) ] curry with-disposal ; inline + +: with-cairo-from-surface ( cairo_surface quot -- ) + '[ cairo_create , with-cairo ] with-surface ; inline diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index 200c85c929..451806c0a7 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -1,24 +1,48 @@ -! Bindings for Cairo library -! Copyright (c) 2007 Sampo Vuori -! License: http://factorcode.org/license.txt +! Copyright (c) 2007 Sampo Vuori +! Copyright (c) 2008 Matthew Willis +! +! Adapted from cairo.h, version 1.5.14 +! License: http://factorcode.org/license.txt -! Unimplemented: -! - most of the font stuff -! - most of the matrix stuff -! - most of the query functions +USING: system combinators alien alien.syntax kernel +alien.c-types accessors sequences arrays ui.gadgets ; -USING: alien alien.syntax combinators system ; IN: cairo.ffi - << "cairo" { - { [ os winnt? ] [ "libcairo-2.dll" ] } - ! { [ os macosx? ] [ "libcairo.dylib" ] } - { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } - { [ os unix? ] [ "libcairo.so.2" ] } - } cond "cdecl" add-library >> + { [ os winnt? ] [ "libcairo-2.dll" ] } + { [ os macosx? ] [ "libcairo.dylib" ] } + { [ os unix? ] [ "libcairo.so.2" ] } +} cond "cdecl" add-library >> LIBRARY: cairo +FUNCTION: int cairo_version ( ) ; +FUNCTION: char* cairo_version_string ( ) ; + +TYPEDEF: int cairo_bool_t + +! I am leaving these and other void* types as opaque structures +TYPEDEF: void* cairo_t +TYPEDEF: void* cairo_surface_t + +C-STRUCT: cairo_matrix_t + { "double" "xx" } + { "double" "yx" } + { "double" "xy" } + { "double" "yy" } + { "double" "x0" } + { "double" "y0" } ; + +TYPEDEF: void* cairo_pattern_t + +TYPEDEF: void* cairo_destroy_func_t +: cairo-destroy-func ( quot -- callback ) + >r "void" { "void*" } "cdecl" r> alien-callback ; inline + +! See cairo.h for details +C-STRUCT: cairo_user_data_key_t + { "int" "unused" } ; + TYPEDEF: int cairo_status_t C-ENUM: CAIRO_STATUS_SUCCESS @@ -44,137 +68,326 @@ C-ENUM: CAIRO_STATUS_INVALID_DSC_COMMENT CAIRO_STATUS_INVALID_INDEX CAIRO_STATUS_CLIP_NOT_REPRESENTABLE -; + CAIRO_STATUS_TEMP_FILE_ERROR + CAIRO_STATUS_INVALID_STRIDE ; TYPEDEF: int cairo_content_t -: CAIRO_CONTENT_COLOR HEX: 1000 ; -: CAIRO_CONTENT_ALPHA HEX: 2000 ; -: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ; +: CAIRO_CONTENT_COLOR HEX: 1000 ; +: CAIRO_CONTENT_ALPHA HEX: 2000 ; +: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ; +TYPEDEF: void* cairo_write_func_t +: cairo-write-func ( quot -- callback ) + >r "cairo_status_t" { "void*" "uchar*" "int" } + "cdecl" r> alien-callback ; inline + +TYPEDEF: void* cairo_read_func_t +: cairo-read-func ( quot -- callback ) + >r "cairo_status_t" { "void*" "uchar*" "int" } + "cdecl" r> alien-callback ; inline + +! Functions for manipulating state objects +FUNCTION: cairo_t* +cairo_create ( cairo_surface_t* target ) ; + +FUNCTION: cairo_t* +cairo_reference ( cairo_t* cr ) ; + +FUNCTION: void +cairo_destroy ( cairo_t* cr ) ; + +FUNCTION: uint +cairo_get_reference_count ( cairo_t* cr ) ; + +FUNCTION: void* +cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ; + +FUNCTION: cairo_status_t +cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; + +FUNCTION: void +cairo_save ( cairo_t* cr ) ; + +FUNCTION: void +cairo_restore ( cairo_t* cr ) ; + +FUNCTION: void +cairo_push_group ( cairo_t* cr ) ; + +FUNCTION: void +cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ; + +FUNCTION: cairo_pattern_t* +cairo_pop_group ( cairo_t* cr ) ; + +FUNCTION: void +cairo_pop_group_to_source ( cairo_t* cr ) ; + +! Modify state TYPEDEF: int cairo_operator_t C-ENUM: CAIRO_OPERATOR_CLEAR + CAIRO_OPERATOR_SOURCE CAIRO_OPERATOR_OVER CAIRO_OPERATOR_IN CAIRO_OPERATOR_OUT CAIRO_OPERATOR_ATOP + CAIRO_OPERATOR_DEST CAIRO_OPERATOR_DEST_OVER CAIRO_OPERATOR_DEST_IN CAIRO_OPERATOR_DEST_OUT CAIRO_OPERATOR_DEST_ATOP + CAIRO_OPERATOR_XOR CAIRO_OPERATOR_ADD - CAIRO_OPERATOR_SATURATE -; + CAIRO_OPERATOR_SATURATE ; -TYPEDEF: int cairo_line_cap_t -C-ENUM: - CAIRO_LINE_CAP_BUTT - CAIRO_LINE_CAP_ROUND - CAIRO_LINE_CAP_SQUARE -; +FUNCTION: void +cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ; -TYPEDEF: int cair_line_join_t -C-ENUM: - CAIRO_LINE_JOIN_MITER - CAIRO_LINE_JOIN_ROUND - CAIRO_LINE_JOIN_BEVEL -; +FUNCTION: void +cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ; -TYPEDEF: int cairo_fill_rule_t -C-ENUM: - CAIRO_FILL_RULE_WINDING - CAIRO_FILL_RULE_EVEN_ODD -; +FUNCTION: void +cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ; -TYPEDEF: int cairo_font_slant_t -C-ENUM: - CAIRO_FONT_SLANT_NORMAL - CAIRO_FONT_SLANT_ITALIC - CAIRO_FONT_SLANT_OBLIQUE -; +FUNCTION: void +cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ; -TYPEDEF: int cairo_font_weight_t -C-ENUM: - CAIRO_FONT_WEIGHT_NORMAL - CAIRO_FONT_WEIGHT_BOLD -; +FUNCTION: void +cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ; -C-STRUCT: cairo_font_t - { "int" "refcount" } - { "uint" "scale" } ; - -C-STRUCT: cairo_rectangle_t - { "short" "x" } - { "short" "y" } - { "ushort" "width" } - { "ushort" "height" } ; - -C-STRUCT: cairo_clip_rec_t - { "cairo_rectangle_t" "rect" } - { "void*" "region" } - { "void*" "surface" } ; - -C-STRUCT: cairo_matrix_t - { "void*" "m" } ; - -C-STRUCT: cairo_gstate_t - { "uint" "operator" } - { "double" "tolerance" } - { "double" "line_width" } - { "uint" "line_cap" } - { "uint" "line_join" } - { "double" "miter_limit" } - { "uint" "fill_rule" } - { "void*" "dash" } - { "int" "num_dashes" } - { "double" "dash_offset" } - { "char*" "font_family " } - { "uint" "font_slant" } - { "uint" "font_weight" } - { "void*" "font" } - { "void*" "surface" } - { "void*" "pattern " } - { "double" "alpha" } - { "cairo_clip_rec_t" "clip" } - { "double" "pixels_per_inch" } - { "cairo_matrix_t" "font_matrix" } - { "cairo_matrix_t" "ctm" } - { "cairo_matrix_t" "ctm_inverse" } - { "void*" "path" } - { "void*" "pen_regular" } - { "void*" "next" } ; - -C-STRUCT: cairo_t - { "uint" "ref_count" } - { "cairo_gstate_t*" "gstate" } - { "uint" "status ! cairo_status_t" } ; - -C-STRUCT: cairo_matrix_t - { "double" "xx" } - { "double" "yx" } - { "double" "xy" } - { "double" "yy" } - { "double" "x0" } - { "double" "y0" } ; - -TYPEDEF: int cairo_format_t -C-ENUM: - CAIRO_FORMAT_ARGB32 - CAIRO_FORMAT_RGB24 - CAIRO_FORMAT_A8 - CAIRO_FORMAT_A1 -; +FUNCTION: void +cairo_set_tolerance ( cairo_t* cr, double tolerance ) ; TYPEDEF: int cairo_antialias_t C-ENUM: CAIRO_ANTIALIAS_DEFAULT CAIRO_ANTIALIAS_NONE CAIRO_ANTIALIAS_GRAY - CAIRO_ANTIALIAS_SUBPIXEL -; + CAIRO_ANTIALIAS_SUBPIXEL ; + +FUNCTION: void +cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ; + +TYPEDEF: int cairo_fill_rule_t +C-ENUM: + CAIRO_FILL_RULE_WINDING + CAIRO_FILL_RULE_EVEN_ODD ; + +FUNCTION: void +cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ; + +FUNCTION: void +cairo_set_line_width ( cairo_t* cr, double width ) ; + +TYPEDEF: int cairo_line_cap_t +C-ENUM: + CAIRO_LINE_CAP_BUTT + CAIRO_LINE_CAP_ROUND + CAIRO_LINE_CAP_SQUARE ; + +FUNCTION: void +cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ; + +TYPEDEF: int cairo_line_join_t +C-ENUM: + CAIRO_LINE_JOIN_MITER + CAIRO_LINE_JOIN_ROUND + CAIRO_LINE_JOIN_BEVEL ; + +FUNCTION: void +cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ; + +FUNCTION: void +cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ; + +FUNCTION: void +cairo_set_miter_limit ( cairo_t* cr, double limit ) ; + +FUNCTION: void +cairo_translate ( cairo_t* cr, double tx, double ty ) ; + +FUNCTION: void +cairo_scale ( cairo_t* cr, double sx, double sy ) ; + +FUNCTION: void +cairo_rotate ( cairo_t* cr, double angle ) ; + +FUNCTION: void +cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_identity_matrix ( cairo_t* cr ) ; + +FUNCTION: void +cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ; + +FUNCTION: void +cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ; + +FUNCTION: void +cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ; + +FUNCTION: void +cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ; + +! Path creation functions +FUNCTION: void +cairo_new_path ( cairo_t* cr ) ; + +FUNCTION: void +cairo_move_to ( cairo_t* cr, double x, double y ) ; + +FUNCTION: void +cairo_new_sub_path ( cairo_t* cr ) ; + +FUNCTION: void +cairo_line_to ( cairo_t* cr, double x, double y ) ; + +FUNCTION: void +cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ; + +FUNCTION: void +cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ; + +FUNCTION: void +cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ; + +FUNCTION: void +cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ; + +FUNCTION: void +cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ; + +FUNCTION: void +cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ; + +FUNCTION: void +cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ; + +FUNCTION: void +cairo_close_path ( cairo_t* cr ) ; + +FUNCTION: void +cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; + +! Painting functions +FUNCTION: void +cairo_paint ( cairo_t* cr ) ; + +FUNCTION: void +cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ; + +FUNCTION: void +cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ; + +FUNCTION: void +cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ; + +FUNCTION: void +cairo_stroke ( cairo_t* cr ) ; + +FUNCTION: void +cairo_stroke_preserve ( cairo_t* cr ) ; + +FUNCTION: void +cairo_fill ( cairo_t* cr ) ; + +FUNCTION: void +cairo_fill_preserve ( cairo_t* cr ) ; + +FUNCTION: void +cairo_copy_page ( cairo_t* cr ) ; + +FUNCTION: void +cairo_show_page ( cairo_t* cr ) ; + +! Insideness testing +FUNCTION: cairo_bool_t +cairo_in_stroke ( cairo_t* cr, double x, double y ) ; + +FUNCTION: cairo_bool_t +cairo_in_fill ( cairo_t* cr, double x, double y ) ; + +! Rectangular extents +FUNCTION: void +cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; + +FUNCTION: void +cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; + +! Clipping +FUNCTION: void +cairo_reset_clip ( cairo_t* cr ) ; + +FUNCTION: void +cairo_clip ( cairo_t* cr ) ; + +FUNCTION: void +cairo_clip_preserve ( cairo_t* cr ) ; + +FUNCTION: void +cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; + +C-STRUCT: cairo_rectangle_t + { "double" "x" } + { "double" "y" } + { "double" "width" } + { "double" "height" } ; + +C-STRUCT: cairo_rectangle_list_t + { "cairo_status_t" "status" } + { "cairo_rectangle_t*" "rectangles" } + { "int" "num_rectangles" } ; + +FUNCTION: cairo_rectangle_list_t* +cairo_copy_clip_rectangle_list ( cairo_t* cr ) ; + +FUNCTION: void +cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ; + +! Font/Text functions + +TYPEDEF: void* cairo_scaled_font_t + +TYPEDEF: void* cairo_font_face_t + +C-STRUCT: cairo_glyph_t + { "ulong" "index" } + { "double" "x" } + { "double" "y" } ; + +C-STRUCT: cairo_text_extents_t + { "double" "x_bearing" } + { "double" "y_bearing" } + { "double" "width" } + { "double" "height" } + { "double" "x_advance" } + { "double" "y_advance" } ; + +C-STRUCT: cairo_font_extents_t + { "double" "ascent" } + { "double" "descent" } + { "double" "height" } + { "double" "max_x_advance" } + { "double" "max_y_advance" } ; + +TYPEDEF: int cairo_font_slant_t +C-ENUM: + CAIRO_FONT_SLANT_NORMAL + CAIRO_FONT_SLANT_ITALIC + CAIRO_FONT_SLANT_OBLIQUE ; + +TYPEDEF: int cairo_font_weight_t +C-ENUM: + CAIRO_FONT_WEIGHT_NORMAL + CAIRO_FONT_WEIGHT_BOLD ; TYPEDEF: int cairo_subpixel_order_t C-ENUM: @@ -182,8 +395,7 @@ C-ENUM: CAIRO_SUBPIXEL_ORDER_RGB CAIRO_SUBPIXEL_ORDER_BGR CAIRO_SUBPIXEL_ORDER_VRGB - CAIRO_SUBPIXEL_ORDER_VBGR -; + CAIRO_SUBPIXEL_ORDER_VBGR ; TYPEDEF: int cairo_hint_style_t C-ENUM: @@ -191,270 +403,548 @@ C-ENUM: CAIRO_HINT_STYLE_NONE CAIRO_HINT_STYLE_SLIGHT CAIRO_HINT_STYLE_MEDIUM - CAIRO_HINT_STYLE_FULL -; + CAIRO_HINT_STYLE_FULL ; TYPEDEF: int cairo_hint_metrics_t C-ENUM: CAIRO_HINT_METRICS_DEFAULT CAIRO_HINT_METRICS_OFF - CAIRO_HINT_METRICS_ON -; + CAIRO_HINT_METRICS_ON ; -FUNCTION: char* cairo_status_to_string ( cairo_status_t status ) ; -FUNCTION: cairo_status_t cairo_status ( cairo_t* cr ) ; +TYPEDEF: void* cairo_font_options_t -: cairo_create ( cairo_surface_t -- cairo_t ) - "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ; +FUNCTION: cairo_font_options_t* +cairo_font_options_create ( ) ; -: cairo_reference ( cairo_t -- cairo_t ) - "cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_font_options_t* +cairo_font_options_copy ( cairo_font_options_t* original ) ; -: cairo_destroy ( cairo_t -- ) - "void" "cairo" "cairo_destroy" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_font_options_destroy ( cairo_font_options_t* options ) ; -: cairo_save ( cairo_t -- ) - "void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_font_options_status ( cairo_font_options_t* options ) ; -: cairo_restore ( cairo_t -- ) - "void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ; -: cairo_set_operator ( cairo_t cairo_operator_t -- ) - "void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] alien-invoke ; +FUNCTION: cairo_bool_t +cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ; -: cairo_set_source ( cairo_t cairo_pattern_t -- ) - "void" "cairo" "cairo_set_source" [ "cairo_t*" "void*" ] alien-invoke ; +FUNCTION: ulong +cairo_font_options_hash ( cairo_font_options_t* options ) ; -: cairo_set_source_rgb ( cairo_t red green blue -- ) - "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ; -: cairo_set_source_rgba ( cairo_t red green blue alpha -- ) - "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: cairo_antialias_t +cairo_font_options_get_antialias ( cairo_font_options_t* options ) ; -: cairo_set_source_surface ( cairo_t cairo_surface_t x y -- ) - "void" "cairo" "cairo_set_source_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ; -: cairo_set_tolerance ( cairo_t tolerance -- ) - "void" "cairo" "cairo_set_tolerance" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: cairo_subpixel_order_t +cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ; -: cairo_image_surface_create_for_data ( data format width height stride -- cairo_surface_t ) - "void*" "cairo" "cairo_image_surface_create_for_data" [ "void*" "uint" "int" "int" "int" ] alien-invoke ; - +FUNCTION: void +cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ; -: cairo_set_antialias ( cairo_t cairo_antialias_t -- ) - "void" "cairo" "cairo_set_antialias" [ "cairo_t*" "int" ] alien-invoke ; +FUNCTION: cairo_hint_style_t +cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ; -: cairo_set_fill_rule ( cairo_t cairo_fill_rule_t -- ) - "void" "cairo" "cairo_set_fill_rule" [ "cairo_t*" "int" ] alien-invoke ; +FUNCTION: void +cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ; -: cairo_set_line_width ( cairo_t width -- ) - "void" "cairo" "cairo_set_line_width" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: cairo_hint_metrics_t +cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ; -: cairo_set_line_cap ( cairo_t cairo_line_cap_t -- ) - "void" "cairo" "cairo_set_line_cap" [ "cairo_t*" "int" ] alien-invoke ; +! This interface is for dealing with text as text, not caring about the +! font object inside the the cairo_t. -: cairo_set_line_join ( cairo_t cairo_line_join_t -- ) - "void" "cairo" "cairo_set_line_join" [ "cairo_t*" "int" ] alien-invoke ; +FUNCTION: void +cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ; -: cairo_set_dash ( cairo_t dashes num_dashes offset -- ) - "void" "cairo" "cairo_set_dash" [ "cairo_t*" "double" "int" "double" ] alien-invoke ; +FUNCTION: void +cairo_set_font_size ( cairo_t* cr, double size ) ; -: cairo_set_miter_limit ( cairo_t limit -- ) - "void" "cairo" "cairo_set_miter_limit" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: void +cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; -: cairo_translate ( cairo_t x y -- ) - "void" "cairo" "cairo_translate" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; -: cairo_scale ( cairo_t sx sy -- ) - "void" "cairo" "cairo_scale" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ; -: cairo_rotate ( cairo_t angle -- ) - "void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: void +cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ; -: cairo_transform ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; +FUNCTION: void +cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ; -: cairo_set_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; +FUNCTION: cairo_font_face_t* +cairo_get_font_face ( cairo_t* cr ) ; -: cairo_identity_matrix ( cairo_t -- ) - "void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ; -! cairo path creating functions +FUNCTION: cairo_scaled_font_t* +cairo_get_scaled_font ( cairo_t* cr ) ; -: cairo_new_path ( cairo_t -- ) - "void" "cairo" "cairo_new_path" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_show_text ( cairo_t* cr, char* utf8 ) ; -: cairo_move_to ( cairo_t x y -- ) - "void" "cairo" "cairo_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ; -: cairo_new_sub_path ( cairo_t -- ) - "void" "cairo" "cairo_new_sub_path" [ "cairo_t*" ] alien-invoke ; - -: cairo_line_to ( cairo_t x y -- ) - "void" "cairo" "cairo_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_text_path ( cairo_t* cr, char* utf8 ) ; -: cairo_curve_to ( cairo_t x1 y1 x2 y2 x3 y3 -- ) - "void" "cairo" "cairo_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ; -: cairo_arc ( cairo_t xc yc radius angle1 angle2 -- ) - "void" "cairo" "cairo_arc" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ; -: cairo_arc_negative ( cairo_t xc yc radius angle1 angle2 -- ) - "void" "cairo" "cairo_arc_negative" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ; - -: cairo_rel_move_to ( cairo_t dx dy -- ) - "void" "cairo" "cairo_rel_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ; - -: cairo_rel_line_to ( cairo_t dx dy -- ) - "void" "cairo" "cairo_rel_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ; -: cairo_rel_curve_to ( cairo_t dx1 dy1 dx2 dy2 dx3 dy3 -- ) - "void" "cairo" "cairo_rel_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ; -: cairo_rectangle ( cairo_t x y width height -- ) - "void" "cairo" "cairo_rectangle" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; +! Generic identifier for a font style -: cairo_close_path ( cairo_t -- ) - "void" "cairo" "cairo_close_path" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_font_face_t* +cairo_font_face_reference ( cairo_font_face_t* font_face ) ; + +FUNCTION: void +cairo_font_face_destroy ( cairo_font_face_t* font_face ) ; + +FUNCTION: uint +cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ; + +FUNCTION: cairo_status_t +cairo_font_face_status ( cairo_font_face_t* font_face ) ; + +TYPEDEF: int cairo_font_type_t +C-ENUM: + CAIRO_FONT_TYPE_TOY + CAIRO_FONT_TYPE_FT + CAIRO_FONT_TYPE_WIN32 + CAIRO_FONT_TYPE_QUARTZ ; + +FUNCTION: cairo_font_type_t +cairo_font_face_get_type ( cairo_font_face_t* font_face ) ; + +FUNCTION: void* +cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ; + +FUNCTION: cairo_status_t +cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; + +! Portable interface to general font features. + +FUNCTION: cairo_scaled_font_t* +cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ; + +FUNCTION: cairo_scaled_font_t* +cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: void +cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: uint +cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: cairo_status_t +cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: cairo_font_type_t +cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: void* +cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ; + +FUNCTION: cairo_status_t +cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; + +FUNCTION: void +cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ; + +FUNCTION: void +cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ; + +FUNCTION: void +cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ; + +FUNCTION: cairo_font_face_t* +cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: void +cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ; + +FUNCTION: void +cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ; + +FUNCTION: void +cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ; + +! Query functions + +FUNCTION: cairo_operator_t +cairo_get_operator ( cairo_t* cr ) ; + +FUNCTION: cairo_pattern_t* +cairo_get_source ( cairo_t* cr ) ; + +FUNCTION: double +cairo_get_tolerance ( cairo_t* cr ) ; + +FUNCTION: cairo_antialias_t +cairo_get_antialias ( cairo_t* cr ) ; + +FUNCTION: cairo_bool_t +cairo_has_current_point ( cairo_t* cr ) ; + +FUNCTION: void +cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ; + +FUNCTION: cairo_fill_rule_t +cairo_get_fill_rule ( cairo_t* cr ) ; + +FUNCTION: double +cairo_get_line_width ( cairo_t* cr ) ; + +FUNCTION: cairo_line_cap_t +cairo_get_line_cap ( cairo_t* cr ) ; + +FUNCTION: cairo_line_join_t +cairo_get_line_join ( cairo_t* cr ) ; + +FUNCTION: double +cairo_get_miter_limit ( cairo_t* cr ) ; + +FUNCTION: int +cairo_get_dash_count ( cairo_t* cr ) ; + +FUNCTION: void +cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ; + +FUNCTION: void +cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; + +FUNCTION: cairo_surface_t* +cairo_get_target ( cairo_t* cr ) ; + +FUNCTION: cairo_surface_t* +cairo_get_group_target ( cairo_t* cr ) ; + +TYPEDEF: int cairo_path_data_type_t +C-ENUM: + CAIRO_PATH_MOVE_TO + CAIRO_PATH_LINE_TO + CAIRO_PATH_CURVE_TO + CAIRO_PATH_CLOSE_PATH ; + +! NEED TO DO UNION HERE +C-STRUCT: cairo_path_data_t-point + { "double" "x" } + { "double" "y" } ; + +C-STRUCT: cairo_path_data_t-header + { "cairo_path_data_type_t" "type" } + { "int" "length" } ; + +C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ; + +C-STRUCT: cairo_path_t + { "cairo_status_t" "status" } + { "cairo_path_data_t*" "data" } + { "int" "num_data" } ; + +FUNCTION: cairo_path_t* +cairo_copy_path ( cairo_t* cr ) ; + +FUNCTION: cairo_path_t* +cairo_copy_path_flat ( cairo_t* cr ) ; + +FUNCTION: void +cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ; + +FUNCTION: void +cairo_path_destroy ( cairo_path_t* path ) ; + +! Error status queries + +FUNCTION: cairo_status_t +cairo_status ( cairo_t* cr ) ; + +FUNCTION: char* +cairo_status_to_string ( cairo_status_t status ) ; ! Surface manipulation -: cairo_surface_create_similar ( cairo_surface_t cairo_content_t width height -- cairo_surface_t ) - "cairo_surface_t*" "cairo" "cairo_surface_create_similar" [ "cairo_surface_t*" "uint" "int" "int" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ; -: cairo_surface_reference ( cairo_surface_t -- cairo_surface_t ) - "cairo_surface_t*" "cairo" "cairo_surface_reference" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_surface_reference ( cairo_surface_t* surface ) ; -: cairo_surface_finish ( cairo_surface_t -- ) - "void" "cairo" "cairo_surface_finish" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_finish ( cairo_surface_t* surface ) ; -: cairo_surface_destroy ( cairo_surface_t -- ) - "void" "cairo" "cairo_surface_destroy" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_destroy ( cairo_surface_t* surface ) ; -: cairo_surface_get_reference_count ( cairo_surface_t -- count ) - "uint" "cairo" "cairo_surface_get_reference_count" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: uint +cairo_surface_get_reference_count ( cairo_surface_t* surface ) ; -: cairo_surface_status ( cairo_surface_t -- cairo_status_t ) - "uint" "cairo" "cairo_surface_status" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_surface_status ( cairo_surface_t* surface ) ; -: cairo_surface_flush ( cairo_surface_t -- ) - "void" "cairo" "cairo_surface_flush" [ "cairo_surface_t*" ] alien-invoke ; +TYPEDEF: int cairo_surface_type_t +C-ENUM: + CAIRO_SURFACE_TYPE_IMAGE + CAIRO_SURFACE_TYPE_PDF + CAIRO_SURFACE_TYPE_PS + CAIRO_SURFACE_TYPE_XLIB + CAIRO_SURFACE_TYPE_XCB + CAIRO_SURFACE_TYPE_GLITZ + CAIRO_SURFACE_TYPE_QUARTZ + CAIRO_SURFACE_TYPE_WIN32 + CAIRO_SURFACE_TYPE_BEOS + CAIRO_SURFACE_TYPE_DIRECTFB + CAIRO_SURFACE_TYPE_SVG + CAIRO_SURFACE_TYPE_OS2 + CAIRO_SURFACE_TYPE_WIN32_PRINTING + CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ; -! painting functions -: cairo_paint ( cairo_t -- ) - "void" "cairo" "cairo_paint" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_surface_type_t +cairo_surface_get_type ( cairo_surface_t* surface ) ; -: cairo_paint_with_alpha ( cairo_t alpha -- ) - "void" "cairo" "cairo_paint_with_alpha" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: cairo_content_t +cairo_surface_get_content ( cairo_surface_t* surface ) ; -: cairo_mask ( cairo_t cairo_pattern_t -- ) - "void" "cairo" "cairo_mask" [ "cairo_t*" "void*" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ; -: cairo_mask_surface ( cairo_t cairo_pattern_t surface-x surface-y -- ) - "void" "cairo" "cairo_mask_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ; -: cairo_stroke ( cairo_t -- ) - "void" "cairo" "cairo_stroke" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void* +cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ; -: cairo_stroke_preserve ( cairo_t -- ) - "void" "cairo" "cairo_stroke_preserve" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; -: cairo_fill ( cairo_t -- ) - "void" "cairo" "cairo_fill" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ; -: cairo_fill_preserve ( cairo_t -- ) - "void" "cairo" "cairo_fill_preserve" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_flush ( cairo_surface_t* surface ) ; -: cairo_copy_page ( cairo_t -- ) - "void" "cairo" "cairo_copy_page" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_mark_dirty ( cairo_surface_t* surface ) ; -: cairo_show_page ( cairo_t -- ) - "void" "cairo" "cairo_show_page" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ; -! insideness testing -: cairo_in_stroke ( cairo_t x y -- t/f ) - "int" "cairo" "cairo_in_stroke" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ; -: cairo_in_fill ( cairo_t x y -- t/f ) - "int" "cairo" "cairo_in_fill" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ; -! rectangular extents -: cairo_stroke_extents ( cairo_t x1 y1 x2 y2 -- ) - "void" "cairo" "cairo_stroke_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ; -: cairo_fill_extents ( cairo_t x1 y1 x2 y2 -- ) - "void" "cairo" "cairo_fill_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_surface_copy_page ( cairo_surface_t* surface ) ; -! clipping -: cairo_reset_clip ( cairo_t -- ) - "void" "cairo" "cairo_reset_clip" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_show_page ( cairo_surface_t* surface ) ; -: cairo_clip ( cairo_t -- ) - "void" "cairo" "cairo_clip" [ "cairo_t*" ] alien-invoke ; +! Image-surface functions -: cairo_clip_preserve ( cairo_t -- ) - "void" "cairo" "cairo_clip_preserve" [ "cairo_t*" ] alien-invoke ; +TYPEDEF: int cairo_format_t +C-ENUM: + CAIRO_FORMAT_ARGB32 + CAIRO_FORMAT_RGB24 + CAIRO_FORMAT_A8 + CAIRO_FORMAT_A1 + CAIRO_FORMAT_RGB16_565 ; +FUNCTION: cairo_surface_t* +cairo_image_surface_create ( cairo_format_t format, int width, int height ) ; -: cairo_pattern_create_linear ( x0 y0 x1 y1 -- cairo_pattern_t ) - "void*" "cairo" "cairo_pattern_create_linear" [ "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: int +cairo_format_stride_for_width ( cairo_format_t format, int width ) ; -: cairo_pattern_create_radial ( cx0 cy0 radius0 cx1 cy1 radius1 -- cairo_pattern_t ) - "void*" "cairo" "cairo_pattern_create_radial" [ "double" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ; -: cairo_pattern_add_color_stop_rgba ( pattern offset red green blue alpha -- status ) - "uint" "cairo" "cairo_pattern_add_color_stop_rgba" [ "void*" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: uchar* +cairo_image_surface_get_data ( cairo_surface_t* surface ) ; -: cairo_show_text ( cairo_t msg_utf8 -- ) - "void" "cairo" "cairo_show_text" [ "cairo_t*" "char*" ] alien-invoke ; +FUNCTION: cairo_format_t +cairo_image_surface_get_format ( cairo_surface_t* surface ) ; -: cairo_text_path ( cairo_t msg_utf8 -- ) - "void" "cairo" "cairo_text_path" [ "cairo_t*" "char*" ] alien-invoke ; +FUNCTION: int +cairo_image_surface_get_width ( cairo_surface_t* surface ) ; -: cairo_select_font_face ( cairo_t family font_slant font_weight -- ) - "void" "cairo" "cairo_select_font_face" [ "cairo_t*" "char*" "uint" "uint" ] alien-invoke ; +FUNCTION: int +cairo_image_surface_get_height ( cairo_surface_t* surface ) ; -: cairo_set_font_size ( cairo_t scale -- ) - "void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: int +cairo_image_surface_get_stride ( cairo_surface_t* surface ) ; -: cairo_set_font_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_image_surface_create_from_png ( char* filename ) ; -: cairo_get_font_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ; -FUNCTION: uchar* cairo_image_surface_get_data ( cairo_surface_t* surface ) ; -FUNCTION: cairo_format_t cairo_image_surface_get_format ( cairo_surface_t* surface ) ; -FUNCTION: int cairo_image_surface_get_width ( cairo_surface_t* surface ) ; -FUNCTION: int cairo_image_surface_get_height ( cairo_surface_t* surface ) ; -FUNCTION: int cairo_image_surface_get_stride ( cairo_surface_t* surface ) ; +! Pattern creation functions -! Cairo pdf +FUNCTION: cairo_pattern_t* +cairo_pattern_create_rgb ( double red, double green, double blue ) ; -: cairo_pdf_surface_create ( filename width height -- surface ) - "void*" "cairo" "cairo_pdf_surface_create" [ "char*" "double" "double" ] alien-invoke ; +FUNCTION: cairo_pattern_t* +cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ; -! Missing: +FUNCTION: cairo_pattern_t* +cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ; -! cairo_public cairo_surface_t * -! cairo_pdf_surface_create_for_stream (cairo_write_func_t write_func, -! void *closure, -! double width_in_points, -! double height_in_points); +FUNCTION: cairo_pattern_t* +cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ; -: cairo_pdf_surface_set_size ( surface width height -- ) - "void" "cairo" "cairo_pdf_surface_set_size" [ "void*" "double" "double" ] alien-invoke ; +FUNCTION: cairo_pattern_t* +cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ; -! Cairo png +FUNCTION: cairo_pattern_t* +cairo_pattern_reference ( cairo_pattern_t* pattern ) ; -TYPEDEF: void* cairo_write_func_t -TYPEDEF: void* cairo_read_func_t +FUNCTION: void +cairo_pattern_destroy ( cairo_pattern_t* pattern ) ; -FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png ( char* filename ) ; +FUNCTION: uint +cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ; -FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ; +FUNCTION: cairo_status_t +cairo_pattern_status ( cairo_pattern_t* pattern ) ; -FUNCTION: cairo_status_t cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ; +FUNCTION: void* +cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ; -FUNCTION: cairo_status_t cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ; +FUNCTION: cairo_status_t +cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; + +TYPEDEF: int cairo_pattern_type_t +C-ENUM: + CAIRO_PATTERN_TYPE_SOLID + CAIRO_PATTERN_TYPE_SURFACE + CAIRO_PATTERN_TYPE_LINEAR + CAIRO_PATTERN_TYPE_RADIA ; + +FUNCTION: cairo_pattern_type_t +cairo_pattern_get_type ( cairo_pattern_t* pattern ) ; + +FUNCTION: void +cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ; + +FUNCTION: void +cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ; + +FUNCTION: void +cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ; + +TYPEDEF: int cairo_extend_t +C-ENUM: + CAIRO_EXTEND_NONE + CAIRO_EXTEND_REPEAT + CAIRO_EXTEND_REFLECT + CAIRO_EXTEND_PAD ; + +FUNCTION: void +cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ; + +FUNCTION: cairo_extend_t +cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ; + +TYPEDEF: int cairo_filter_t +C-ENUM: + CAIRO_FILTER_FAST + CAIRO_FILTER_GOOD + CAIRO_FILTER_BEST + CAIRO_FILTER_NEAREST + CAIRO_FILTER_BILINEAR + CAIRO_FILTER_GAUSSIAN ; + +FUNCTION: void +cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ; + +FUNCTION: cairo_filter_t +cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ; + +! Matrix functions + +FUNCTION: void +cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ; + +FUNCTION: void +cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ; + +FUNCTION: void +cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ; + +FUNCTION: void +cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ; + +FUNCTION: void +cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ; + +FUNCTION: void +cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ; + +FUNCTION: void +cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ; + +FUNCTION: cairo_status_t +cairo_matrix_invert ( cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ; + +FUNCTION: void +cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ; + +FUNCTION: void +cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ; + +! Functions to be used while debugging (not intended for use in production code) +FUNCTION: void +cairo_debug_reset_static_data ( ) ; diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor new file mode 100644 index 0000000000..e0daefd63c --- /dev/null +++ b/extra/cairo/gadgets/gadgets.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: cairo cairo.ffi ui.render kernel opengl.gl opengl +math byte-arrays ui.gadgets accessors arrays +namespaces io.backend ; + +IN: cairo.gadgets + +! We need two kinds of gadgets: +! one performs the cairo ops once and caches the bytes, the other +! performs cairo ops every refresh + +TUPLE: cairo-gadget width height quot cache? bytes ; +PREDICATE: cached-cairo < cairo-gadget cache?>> ; +: ( width height quot -- cairo-gadget ) + cairo-gadget construct-gadget + swap >>quot + swap >>height + swap >>width ; + +: ( width height quot -- cairo-gadget ) + t >>cache? ; + +: width>stride ( width -- stride ) 4 * ; + +: copy-cairo ( width height quot -- byte-array ) + >r over width>stride + [ * nip dup CAIRO_FORMAT_ARGB32 ] + [ cairo_image_surface_create_for_data ] 3bi + r> with-cairo-from-surface ; + +: (cairo>bytes) ( gadget -- byte-array ) + [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ; + +GENERIC: cairo>bytes +M: cairo-gadget cairo>bytes ( gadget -- byte-array ) + (cairo>bytes) ; + +M: cached-cairo cairo>bytes ( gadget -- byte-array ) + dup bytes>> [ ] [ + dup (cairo>bytes) [ >>bytes drop ] keep + ] ?if ; + +: cairo>png ( gadget path -- ) + >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ] + [ height>> ] tri over width>stride + cairo_image_surface_create_for_data + r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ; + +M: cairo-gadget draw-gadget* ( gadget -- ) + origin get [ + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ] + [ cairo>bytes ] tri glDrawPixels + ] with-translation ; + +M: cairo-gadget pref-dim* ( gadget -- rect ) + [ width>> ] [ height>> ] bi 2array ; + +: copy-surface ( surface -- ) + cr swap 0 0 cairo_set_source_surface + cr cairo_paint ; + +: ( width height bytes -- cairo-gadget ) + >r [ ] r> >>bytes ; + +: ( path -- gadget ) + normalize-path cairo_image_surface_create_from_png + [ cairo_image_surface_get_width ] + [ cairo_image_surface_get_height 2dup ] + [ [ copy-surface ] curry copy-cairo ] tri + ; \ No newline at end of file diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor deleted file mode 100755 index 4f532cd9ec..0000000000 --- a/extra/cairo/lib/lib.factor +++ /dev/null @@ -1,39 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types cairo.ffi continuations destructors -kernel libc locals math shuffle accessors ; -IN: cairo.lib - -TUPLE: cairo-t alien ; -C: cairo-t -M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ; -: cairo-t-destroy-always ( alien -- ) add-always-destructor ; -: cairo-t-destroy-later ( alien -- ) add-error-destructor ; - -TUPLE: cairo-surface-t alien ; -C: cairo-surface-t -M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ; - -: cairo-surface-t-destroy-always ( alien -- ) - add-always-destructor ; - -: cairo-surface-t-destroy-later ( alien -- ) - add-error-destructor ; - -: cairo-surface>array ( surface -- cairo-t byte-array ) - [ - dup - [ drop CAIRO_FORMAT_ARGB32 ] - [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height ] tri - over 4 * - 2dup * [ - malloc dup free-always [ - 5 -nrot cairo_image_surface_create_for_data - dup cairo-surface-t-destroy-always - cairo_create dup cairo-t-destroy-later - [ swap 0 0 cairo_set_source_surface ] keep - dup cairo_paint - ] keep - ] keep memory>byte-array - ] with-destructors ; diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor deleted file mode 100755 index a3b13c9691..0000000000 --- a/extra/cairo/png/png.factor +++ /dev/null @@ -1,65 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel accessors math ui.gadgets ui.render -opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib -inspector sequences combinators io.backend ; -IN: cairo.png - -TUPLE: png surface width height cairo-t array ; -TUPLE: png-gadget png ; - -ERROR: cairo-error string ; - -: check-zero ( n -- n ) - dup zero? [ - "PNG dimension is 0" cairo-error - ] when ; - -: cairo-png-error ( n -- ) - { - { CAIRO_STATUS_NO_MEMORY [ "Cairo: no memory" cairo-error ] } - { CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] } - { CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] } - [ drop ] - } case ; - -: ( path -- png ) - normalize-path - cairo_image_surface_create_from_png - dup cairo_surface_status cairo-png-error - dup [ cairo_image_surface_get_width check-zero ] - [ cairo_image_surface_get_height check-zero ] [ ] tri - cairo-surface>array png boa ; - -: write-png ( png path -- ) - >r png-surface r> - cairo_surface_write_to_png - zero? [ "write png failed" throw ] unless ; - -: ( path -- gadget ) - png-gadget construct-gadget swap - >>png ; - -M: png-gadget pref-dim* ( gadget -- ) - png>> - [ width>> ] [ height>> ] bi 2array ; - -M: png-gadget draw-gadget* ( gadget -- ) - origin get [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - png>> - [ width>> ] - [ height>> GL_RGBA GL_UNSIGNED_BYTE ] - ! [ height>> GL_BGRA GL_UNSIGNED_BYTE ] - [ array>> ] tri - glDrawPixels - ] with-translation ; - -M: png-gadget graft* ( gadget -- ) - drop ; - -M: png-gadget ungraft* ( gadget -- ) - png>> surface>> cairo_destroy ; - -! "resource:misc/icons/Factor_1x16.png" USE: cairo.png gadget. diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor new file mode 100644 index 0000000000..402c3881f4 --- /dev/null +++ b/extra/cairo/samples/samples.factor @@ -0,0 +1,147 @@ +! Copyright (C) 2008 Matthew Willis +! See http://factorcode.org/license.txt for BSD license. +! +! these samples are a subset of the samples on +! http://cairographics.org/samples/ +USING: cairo cairo.ffi locals math.constants math +io.backend kernel alien.c-types libc namespaces ; + +IN: cairo.samples + +:: arc ( -- ) + [let | xc [ 128.0 ] + yc [ 128.0 ] + radius [ 100.0 ] + angle1 [ pi 1/4 * ] + angle2 [ pi ] | + cr 10.0 cairo_set_line_width + cr xc yc radius angle1 angle2 cairo_arc + cr cairo_stroke + + ! draw helping lines + cr 1 0.2 0.2 0.6 cairo_set_source_rgba + cr 6.0 cairo_set_line_width + + cr xc yc 10.0 0 2 pi * cairo_arc + cr cairo_fill + + cr xc yc radius angle1 angle1 cairo_arc + cr xc yc cairo_line_to + cr xc yc radius angle2 angle2 cairo_arc + cr xc yc cairo_line_to + cr cairo_stroke + ] ; + +: clip ( -- ) + cr 128 128 76.8 0 2 pi * cairo_arc + cr cairo_clip + cr cairo_new_path + + cr 0 0 256 256 cairo_rectangle + cr cairo_fill + cr 0 1 0 cairo_set_source_rgb + cr 0 0 cairo_move_to + cr 256 256 cairo_line_to + cr 256 0 cairo_move_to + cr 0 256 cairo_line_to + cr 10 cairo_set_line_width + cr cairo_stroke ; + +:: clip-image ( -- ) + [let* | png [ "resource:misc/icons/Factor_128x128.png" + normalize-path cairo_image_surface_create_from_png ] + w [ png cairo_image_surface_get_width ] + h [ png cairo_image_surface_get_height ] | + cr 128 128 76.8 0 2 pi * cairo_arc + cr cairo_clip + cr cairo_new_path + + cr 192.0 w / 192.0 h / cairo_scale + cr png 32 32 cairo_set_source_surface + cr cairo_paint + png cairo_surface_destroy + ] ; + +:: dash ( -- ) + [let | dashes [ { 50 10 10 10 } >c-double-array ] + ndash [ 4 ] | + cr dashes ndash -50 cairo_set_dash + cr 10 cairo_set_line_width + cr 128.0 25.6 cairo_move_to + cr 230.4 230.4 cairo_line_to + cr -102.4 0 cairo_rel_line_to + cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to + cr cairo_stroke + ] ; + +:: gradient ( -- ) + [let | pat [ 0 0 0 256 cairo_pattern_create_linear ] + radial [ 115.2 102.4 25.6 102.4 102.4 128.0 + cairo_pattern_create_radial ] | + pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba + pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba + cr 0 0 256 256 cairo_rectangle + cr pat cairo_set_source + cr cairo_fill + pat cairo_pattern_destroy + + radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba + radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba + cr radial cairo_set_source + cr 128.0 128.0 76.8 0 2 pi * cairo_arc + cr cairo_fill + radial cairo_pattern_destroy + ] ; + +: text ( -- ) + cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD + cairo_select_font_face + cr 50 cairo_set_font_size + cr 10 135 cairo_move_to + cr "Hello" cairo_show_text + + cr 70 165 cairo_move_to + cr "factor" cairo_text_path + cr 0.5 0.5 1 cairo_set_source_rgb + cr cairo_fill_preserve + cr 0 0 0 cairo_set_source_rgb + cr 2.56 cairo_set_line_width + cr cairo_stroke + + ! draw helping lines + cr 1 0.2 0.2 0.6 cairo_set_source_rgba + cr 10 135 5.12 0 2 pi * cairo_arc + cr cairo_close_path + cr 70 165 5.12 0 2 pi * cairo_arc + cr cairo_fill ; + +: utf8 ( -- ) + cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL + cairo_select_font_face + cr 50 cairo_set_font_size + "cairo_text_extents_t" malloc-object + cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents + cr over + [ cairo_text_extents_t-width 2 / ] + [ cairo_text_extents_t-x_bearing ] bi + + 128 swap - pick + [ cairo_text_extents_t-height 2 / ] + [ cairo_text_extents_t-y_bearing ] bi + + 128 swap - cairo_move_to + free + cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text + + cr 1 0.2 0.2 0.6 cairo_set_source_rgba + cr 6 cairo_set_line_width + cr 128 0 cairo_move_to + cr 0 256 cairo_rel_line_to + cr 0 128 cairo_move_to + cr 256 0 cairo_rel_line_to + cr cairo_stroke ; + + USING: quotations cairo.gadgets ui.gadgets.panes sequences ; + : samples ( -- ) + { arc clip clip-image dash gradient text utf8 } + [ 256 256 rot 1quotation gadget. ] each ; + + MAIN: samples \ No newline at end of file diff --git a/extra/checksums/adler-32/adler-32-docs.factor b/extra/checksums/adler-32/adler-32-docs.factor index b7400cbaa0..3e4e5d8210 100755 --- a/extra/checksums/adler-32/adler-32-docs.factor +++ b/extra/checksums/adler-32/adler-32-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: checksums.adler-32 HELP: adler-32 -{ $description "Adler-32 checksum algorithm." } ; +{ $class-description "Adler-32 checksum algorithm." } ; ARTICLE: "checksums.adler-32" "Adler-32 checksum" "The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync." diff --git a/extra/checksums/md5/md5-docs.factor b/extra/checksums/md5/md5-docs.factor index dca039d1d3..4e475b18a0 100755 --- a/extra/checksums/md5/md5-docs.factor +++ b/extra/checksums/md5/md5-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: checksums.md5 HELP: md5 -{ $description "MD5 checksum algorithm." } ; +{ $class-description "MD5 checksum algorithm." } ; ARTICLE: "checksums.md5" "MD5 checksum" "The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")." diff --git a/extra/checksums/openssl/openssl-docs.factor b/extra/checksums/openssl/openssl-docs.factor new file mode 100644 index 0000000000..fd067997a7 --- /dev/null +++ b/extra/checksums/openssl/openssl-docs.factor @@ -0,0 +1,35 @@ +IN: checksums.openssl +USING: help.syntax help.markup ; + +HELP: openssl-checksum +{ $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ; + +HELP: ( name -- checksum ) +{ $values { "name" "an EVP message digest name" } { "checksum" openssl-checksum } } +{ $description "Creates a new OpenSSL checksum object." } ; + +HELP: openssl-md5 +{ $description "The OpenSSL MD5 message digest implementation." } ; + +HELP: openssl-sha1 +{ $description "The OpenSSL SHA1 message digest implementation." } ; + +HELP: unknown-digest +{ $error-description "Thrown by checksum words if they are passed an " { $link openssl-checksum } " naming a message digest not supported by OpenSSL." } ; + +ARTICLE: "checksums.openssl" "OpenSSL checksums" +"The OpenSSL library provides a large number of efficient checksum (message digest) algorithms which may be used independently of its SSL functionality." +{ $subsection openssl-checksum } +"Constructing a checksum from a known name:" +{ $subsection } +"Two utility words:" +{ $subsection openssl-md5 } +{ $subsection openssl-sha1 } +"An error thrown if the digest name is unrecognized:" +{ $subsection unknown-digest } +"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:" +{ $example "USING: byte-arrays checksums checksums.openssl prettyprint ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } +"If we use the Factor implementation, we get the same result, just slightly slower:" +{ $example "USING: byte-arrays checksums checksums.sha1 prettyprint ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ; + +ABOUT: "checksums.openssl" diff --git a/extra/checksums/openssl/openssl-tests.factor b/extra/checksums/openssl/openssl-tests.factor new file mode 100644 index 0000000000..253069c952 --- /dev/null +++ b/extra/checksums/openssl/openssl-tests.factor @@ -0,0 +1,28 @@ +IN: checksums.openssl.tests +USING: byte-arrays checksums.openssl checksums tools.test +accessors kernel system ; + +[ + B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 } +] +[ + "Hello world from the openssl binding" >byte-array + "md5" checksum-bytes +] unit-test + +[ + B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 82 115 0 } +] +[ + "Hello world from the openssl binding" >byte-array + "sha1" checksum-bytes +] unit-test + +[ + "Bad checksum test" >byte-array + "no such checksum" + checksum-bytes +] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ] +must-fail-with + +[ ] [ image openssl-sha1 checksum-file drop ] unit-test diff --git a/extra/checksums/openssl/openssl.factor b/extra/checksums/openssl/openssl.factor new file mode 100644 index 0000000000..d42febb541 --- /dev/null +++ b/extra/checksums/openssl/openssl.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays alien.c-types kernel continuations +destructors sequences io openssl openssl.libcrypto checksums ; +IN: checksums.openssl + +ERROR: unknown-digest name ; + +TUPLE: openssl-checksum name ; + +: openssl-md5 T{ openssl-checksum f "md5" } ; + +: openssl-sha1 T{ openssl-checksum f "sha1" } ; + +INSTANCE: openssl-checksum checksum + +C: openssl-checksum + + ( -- ctx ) + "EVP_MD_CTX" + dup EVP_MD_CTX_init evp-md-context boa ; + +M: evp-md-context dispose + handle>> EVP_MD_CTX_cleanup drop ; + +: with-evp-md-context ( quot -- ) + maybe-init-ssl >r r> with-disposal ; inline + +: digest-named ( name -- md ) + dup EVP_get_digestbyname + [ ] [ unknown-digest ] ?if ; + +: set-digest ( name ctx -- ) + handle>> swap digest-named f EVP_DigestInit_ex ssl-error ; + +: checksum-loop ( ctx -- ) + dup handle>> + 4096 read-partial dup [ + dup length EVP_DigestUpdate ssl-error + checksum-loop + ] [ 3drop ] if ; + +: digest-value ( ctx -- value ) + handle>> + EVP_MAX_MD_SIZE 0 + [ EVP_DigestFinal_ex ssl-error ] 2keep + *int memory>byte-array ; + +PRIVATE> + +M: openssl-checksum checksum-stream + name>> swap [ + [ + [ set-digest ] + [ checksum-loop ] + [ digest-value ] + tri + ] with-evp-md-context + ] with-input-stream ; diff --git a/extra/checksums/sha1/sha1-docs.factor b/extra/checksums/sha1/sha1-docs.factor index 8b8bf1cfa9..2c9093865f 100644 --- a/extra/checksums/sha1/sha1-docs.factor +++ b/extra/checksums/sha1/sha1-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: checksums.sha1 HELP: sha1 -{ $description "SHA1 checksum algorithm." } ; +{ $class-description "SHA1 checksum algorithm." } ; ARTICLE: "checksums.sha1" "SHA1 checksum" "The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")." diff --git a/extra/checksums/sha2/sha2-docs.factor b/extra/checksums/sha2/sha2-docs.factor index c39831b266..6a128552fd 100644 --- a/extra/checksums/sha2/sha2-docs.factor +++ b/extra/checksums/sha2/sha2-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: checksums.sha2 HELP: sha-256 -{ $description "SHA-256 checksum algorithm." } ; +{ $class-description "SHA-256 checksum algorithm." } ; ARTICLE: "checksums.sha2" "SHA2 checksum" "The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong." diff --git a/extra/cocoa/application/application-docs.factor b/extra/cocoa/application/application-docs.factor index 01a79cf35a..55fa5e10b8 100644 --- a/extra/cocoa/application/application-docs.factor +++ b/extra/cocoa/application/application-docs.factor @@ -27,8 +27,8 @@ HELP: with-cocoa { $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ; HELP: do-event -{ $values { "app" "an " { $snippet "NSApplication" } } } -{ $description "Processes any pending events in the queue. Does not block." } ; +{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } } +{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ; HELP: add-observer { $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } } diff --git a/extra/cocoa/views/views.factor b/extra/cocoa/views/views.factor index 7b8de9067c..ca631d5dea 100644 --- a/extra/cocoa/views/views.factor +++ b/extra/cocoa/views/views.factor @@ -74,3 +74,17 @@ PRIVATE> -> locationInWindow f -> convertPoint:fromView: dup NSPoint-x swap NSPoint-y r> -> frame NSRect-h swap - 2array ; + +USE: opengl.gl +USE: alien.syntax + +: NSOpenGLCPSwapInterval 222 ; + +LIBRARY: OpenGL + +TYPEDEF: int CGLError +TYPEDEF: void* CGLContextObj +TYPEDEF: int CGLContextParameter + +FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ; + diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index ed481f72e6..54847dc8b3 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -19,6 +19,13 @@ IN: combinators.lib.tests [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test [ [ dup 2^ 2array ] 5 napply ] must-infer +[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test + +[ { "foo" "xbarx" } ] +[ + { "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call +] unit-test + ! && [ t ] [ diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 5dfe8527c1..d4a9386649 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel combinators fry namespaces quotations hashtables sequences assocs arrays inference effects math math.ranges -arrays.lib shuffle macros bake continuations ; +arrays.lib shuffle macros continuations locals ; IN: combinators.lib @@ -20,17 +20,15 @@ MACRO: nslip ( n -- ) dup saver [ call ] rot restorer 3append ; MACRO: nkeep ( n -- ) [ ] [ 1+ ] [ ] tri - [ [ , ndup ] dip , -nrot , nslip ] - bake ; + '[ [ , ndup ] dip , -nrot , nslip ] ; : 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline MACRO: ncurry ( n -- ) [ curry ] n*quot ; -MACRO: nwith ( quot n -- ) - tuck 1+ dup - [ , -nrot [ , nrot , call ] , ncurry ] - bake ; +MACRO:: nwith ( quot n -- ) + [let | n' [ n 1+ ] | + [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ; MACRO: napply ( n -- ) 2 [a,b] @@ -110,8 +108,8 @@ MACRO: switch ( quot -- ) ! : pcall ( seq quots -- seq ) [ call ] 2map ; MACRO: parallel-call ( quots -- ) - [ [ unclip % r> dup >r push ] bake ] map concat - [ V{ } clone >r % drop r> >array ] bake ; + [ '[ [ unclip @ ] dip [ push ] keep ] ] map concat + '[ V{ } clone @ nip >array ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! map-call and friends diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index e2abd6deb9..ca1da0deaa 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -13,7 +13,7 @@ concurrency.messaging continuations ; [ ] [ test-node dup 1array swap (start-node) ] unit-test -[ ] [ yield ] unit-test +[ ] [ 100 sleep ] unit-test [ ] [ [ diff --git a/extra/concurrency/exchangers/exchangers.factor b/extra/concurrency/exchangers/exchangers.factor index d9d6809602..6b44886eda 100755 --- a/extra/concurrency/exchangers/exchangers.factor +++ b/extra/concurrency/exchangers/exchangers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel threads boxes ; +USING: kernel threads boxes accessors ; IN: concurrency.exchangers ! Motivated by @@ -12,10 +12,10 @@ TUPLE: exchanger thread object ; exchanger boa ; : exchange ( obj exchanger -- newobj ) - dup exchanger-thread box-full? [ - dup exchanger-object box> - >r exchanger-thread box> resume-with r> + dup thread>> occupied>> [ + dup object>> box> + >r thread>> box> resume-with r> ] [ - [ exchanger-object >box ] keep - [ exchanger-thread >box ] curry "exchange" suspend + [ object>> >box ] keep + [ thread>> >box ] curry "exchange" suspend ] if ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 7fe09cdcf5..61c57bb9e9 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -1,7 +1,7 @@ IN: concurrency.mailboxes.tests USING: concurrency.mailboxes concurrency.count-downs vectors sequences threads tools.test math kernel strings namespaces -continuations calendar ; +continuations calendar destructors ; [ V{ 1 2 3 } ] [ 0 diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index aa4dc2df3d..faa3a29610 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -1,17 +1,13 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: concurrency.mailboxes -USING: dlists threads sequences continuations +USING: dlists threads sequences continuations destructors namespaces random math quotations words kernel arrays assocs init system concurrency.conditions accessors debugger ; -TUPLE: mailbox threads data closed ; +TUPLE: mailbox threads data disposed ; -: check-closed ( mailbox -- ) - closed>> [ "Mailbox closed" throw ] when ; inline - -M: mailbox dispose - t >>closed threads>> notify-all ; +M: mailbox dispose* threads>> notify-all ; : ( -- mailbox ) f mailbox boa ; @@ -27,7 +23,7 @@ M: mailbox dispose >r threads>> r> "mailbox" wait ; : block-unless-pred ( mailbox timeout pred -- ) - pick check-closed + pick check-disposed pick data>> over dlist-contains? [ 3drop ] [ @@ -35,7 +31,7 @@ M: mailbox dispose ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) - over check-closed + over check-disposed over mailbox-empty? [ 2dup wait-for-mailbox block-if-empty ] [ @@ -75,7 +71,7 @@ M: mailbox dispose f swap mailbox-get-timeout? ; inline : wait-for-close-timeout ( mailbox timeout -- ) - over closed>> + over disposed>> [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ; : wait-for-close ( mailbox -- ) diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 4698aa45ae..261e1d045a 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces assocs init accessors continuations combinators core-foundation core-foundation.run-loop -io.encodings.utf8 ; +io.encodings.utf8 destructors ; IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! @@ -187,7 +187,7 @@ SYMBOL: event-stream-callbacks dup [ call drop ] [ 3drop ] if ] alien-callback ; -TUPLE: event-stream info handle closed ; +TUPLE: event-stream info handle disposed ; : ( quot paths latency flags -- event-stream ) >r >r >r @@ -197,13 +197,10 @@ TUPLE: event-stream info handle closed ; dup enable-event-stream f event-stream boa ; -M: event-stream dispose - dup closed>> [ drop ] [ - t >>closed - { - [ info>> remove-event-source-callback ] - [ handle>> disable-event-stream ] - [ handle>> FSEventStreamInvalidate ] - [ handle>> FSEventStreamRelease ] - } cleave - ] if ; +M: event-stream dispose* + { + [ info>> remove-event-source-callback ] + [ handle>> disable-event-stream ] + [ handle>> FSEventStreamInvalidate ] + [ handle>> FSEventStreamRelease ] + } cleave ; diff --git a/extra/db/db.factor b/extra/db/db.factor index 237d8698a6..9514f62cf0 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs classes continuations kernel math +USING: arrays assocs classes continuations destructors kernel math namespaces sequences sequences.lib classes.tuple words strings tools.walker accessors combinators.lib ; IN: db @@ -25,7 +25,7 @@ GENERIC: make-db* ( seq class -- db ) GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) -: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ; +: dispose-statements ( assoc -- ) values dispose-each ; : dispose-db ( db -- ) dup db [ diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index f8700debaa..1767bf3d50 100755 --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for license. -USING: alien continuations io kernel prettyprint sequences -db db.mysql.ffi ; +USING: alien continuations destructors io kernel prettyprint +sequences db db.mysql.ffi ; IN: db.mysql TUPLE: mysql-db handle host user password db port ; diff --git a/extra/db/pooling/pooling.factor b/extra/db/pooling/pooling.factor index 83820294d6..1be05d5d72 100644 --- a/extra/db/pooling/pooling.factor +++ b/extra/db/pooling/pooling.factor @@ -40,4 +40,4 @@ M: return-connection dispose [ db>> ] [ pool>> ] bi return-connection ; : return-connection-later ( db pool -- ) - \ return-connection boa add-always-destructor ; + \ return-connection boa &dispose drop ; diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index ee5ba622e5..3686afa80c 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -52,7 +52,6 @@ IN: db.postgresql.ffi : InvalidOid 0 ; inline -TYPEDEF: int size_t TYPEDEF: int ConnStatusType TYPEDEF: int ExecStatusType TYPEDEF: int PostgresPollingStatusType diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 8b0026b6e5..ebcc67374b 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -67,12 +67,10 @@ M: postgresql-result-null summary ( obj -- str ) in-params>> [ type>> type>oid ] map >c-uint-array ; : malloc-byte-array/length - [ malloc-byte-array dup free-always ] [ length ] bi ; + [ malloc-byte-array &free ] [ length ] bi ; : default-param-value - number>string* dup [ - utf8 malloc-string dup free-always - ] when 0 ; + number>string* dup [ utf8 malloc-string &free ] when 0 ; : param-values ( statement -- seq seq2 ) [ bind-params>> ] [ in-params>> ] bi @@ -128,8 +126,8 @@ C: postgresql-malloc-destructor M: postgresql-malloc-destructor dispose ( obj -- ) alien>> PQfreemem ; -: postgresql-free-always ( alien -- ) - add-always-destructor ; +: &postgresql-free ( alien -- alien ) + dup &dispose drop ; inline : pq-get-blob ( handle row column -- obj/f ) [ PQgetvalue ] 3keep 3dup PQgetlength @@ -142,7 +140,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) PQunescapeBytea dup zero? [ postgresql-result-error-message throw ] [ - dup postgresql-free-always + &postgresql-free ] if ] keep *uint memory>byte-array diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 9f747082c6..3e81b264d6 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,7 +5,7 @@ kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators sequences.lib classes locals words tools.walker -namespaces.lib accessors random db.queries ; +namespaces.lib accessors random db.queries destructors ; USE: tools.walker IN: db.postgresql diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 4aaa9668f0..c10775f1c9 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -6,7 +6,7 @@ prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals io namespaces.lib accessors vectors math.ranges random -math.bitfields.lib db.queries ; +math.bitfields.lib db.queries destructors ; USE: tools.walker IN: db.sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 5747fa7de7..c940d121bb 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays assocs classes db kernel namespaces classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations -mirrors sequences.lib combinators.lib ; +destructors mirrors sequences.lib combinators.lib ; IN: db.tuples : define-persistent ( class table columns -- ) diff --git a/extra/descriptive/descriptive-tests.factor b/extra/descriptive/descriptive-tests.factor index c1e9654fc5..1582ca895d 100755 --- a/extra/descriptive/descriptive-tests.factor +++ b/extra/descriptive/descriptive-tests.factor @@ -4,13 +4,13 @@ IN: descriptive.tests DESCRIPTIVE: divide ( num denom -- fraction ) / ; [ 3 ] [ 9 3 divide ] unit-test -[ T{ descriptive f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test +[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test [ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ; [ 3 ] [ 9 3 divide* ] unit-test -[ T{ descriptive f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test +[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test [ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index a98f379124..56d62d8634 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -3,16 +3,16 @@ locals.private accessors parser namespaces continuations inspector definitions arrays.lib arrays ; IN: descriptive -ERROR: descriptive args underlying word ; +ERROR: descriptive-error args underlying word ; -M: descriptive summary +M: descriptive-error summary word>> "The " swap word-name " word encountered an error." 3append ; r narray r> swap 2array flip ] 2curry - [ 2 ndip descriptive ] 2curry ; + [ 2 ndip descriptive-error ] 2curry ; : [descriptive] ( word def -- newdef ) swap dup "declared-effect" word-prop in>> rethrower @@ -26,19 +26,18 @@ PRIVATE> : DESCRIPTIVE: (:) define-descriptive ; parsing -PREDICATE: descriptive-def < word +PREDICATE: descriptive < word "descriptive-definition" word-prop ; -M: descriptive-def definer drop \ DESCRIPTIVE: \ ; ; +M: descriptive definer drop \ DESCRIPTIVE: \ ; ; -M: descriptive-def definition +M: descriptive definition "descriptive-definition" word-prop ; : DESCRIPTIVE:: (::) define-descriptive ; parsing -PREDICATE: descriptive-lambda < lambda-word - "descriptive-definition" word-prop ; +INTERSECTION: descriptive-lambda descriptive lambda-word ; M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ; diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor deleted file mode 100755 index f96931c412..0000000000 --- a/extra/destructors/destructors-docs.factor +++ /dev/null @@ -1,30 +0,0 @@ -USING: help.markup help.syntax libc kernel continuations ; -IN: destructors - -HELP: free-always -{ $values { "alien" "alien returned by malloc" } } -{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " ends." } -{ $see-also free-later } ; - -HELP: free-later -{ $values { "alien" "alien returned by malloc" } } -{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." } -{ $see-also free-always } ; - -HELP: close-always -{ $values { "handle" "an OS-dependent handle" } } -{ $description "Adds a destructor that will close the system resource upon reaching the end of the quotation passed to " { $link with-destructors } "." } -{ $see-also close-later } ; - -HELP: close-later -{ $values { "handle" "an OS-dependent handle" } } -{ $description "Adds a destructor that will close the system resource if an error occurs in the quotation passed to " { $link with-destructors } ". Otherwise, manual cleanup of the resource is required later." } -{ $see-also close-always } ; - -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 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.factor b/extra/destructors/destructors.factor deleted file mode 100755 index 6fc7ab249f..0000000000 --- a/extra/destructors/destructors.factor +++ /dev/null @@ -1,85 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: continuations io.backend io.nonblocking libc kernel -namespaces sequences system vectors ; -IN: destructors - -SYMBOL: error-destructors -SYMBOL: always-destructors - -TUPLE: destructor object destroyed? ; - -M: destructor dispose - dup destructor-destroyed? [ - drop - ] [ - dup destructor-object dispose - t swap set-destructor-destroyed? - ] if ; - -: ( obj -- newobj ) - f destructor boa ; - -: add-error-destructor ( obj -- ) - error-destructors get push ; - -: add-always-destructor ( obj -- ) - always-destructors get push ; - -: do-always-destructors ( -- ) - always-destructors get dispose-each ; - -: do-error-destructors ( -- ) - error-destructors get dispose-each ; - -: with-destructors ( quot -- ) - [ - V{ } clone always-destructors set - V{ } clone error-destructors set - [ do-always-destructors ] - [ do-error-destructors ] cleanup - ] with-scope ; inline - -! Memory allocations -TUPLE: memory-destructor alien ; - -C: memory-destructor - -M: memory-destructor dispose ( obj -- ) - memory-destructor-alien free ; - -: free-always ( alien -- ) - add-always-destructor ; - -: free-later ( alien -- ) - add-error-destructor ; - -! Handles -TUPLE: handle-destructor alien ; - -C: handle-destructor - -M: handle-destructor dispose ( obj -- ) - handle-destructor-alien close-handle ; - -: close-always ( handle -- ) - add-always-destructor ; - -: close-later ( handle -- ) - add-error-destructor ; - -! Sockets -TUPLE: socket-destructor alien ; - -C: socket-destructor - -HOOK: destruct-socket io-backend ( obj -- ) - -M: socket-destructor dispose ( obj -- ) - socket-destructor-alien destruct-socket ; - -: close-socket-always ( handle -- ) - add-always-destructor ; - -: close-socket-later ( handle -- ) - add-error-destructor ; diff --git a/extra/ftp/client/authors.txt b/extra/ftp/client/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/ftp/client/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor new file mode 100644 index 0000000000..642d2ce8cd --- /dev/null +++ b/extra/ftp/client/client.factor @@ -0,0 +1,168 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays classes.singleton combinators +continuations io io.encodings.binary io.encodings.utf8 +io.files io.sockets kernel io.streams.duplex math +math.parser sequences splitting namespaces strings fry ftp ; +IN: ftp.client + +: (ftp-response-code) ( str -- n ) + 3 head string>number ; + +: ftp-response-code ( string -- n/f ) + dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ; + +: read-response-loop ( ftp-response -- ftp-response ) + readln + [ add-response-line ] [ ftp-response-code ] bi + over n>> = [ read-response-loop ] unless ; + +: read-response ( -- ftp-response ) + readln + [ (ftp-response-code) >>n ] + [ add-response-line ] + [ fourth CHAR: - = ] tri + [ read-response-loop ] when ; + +: ftp-command ( string -- ftp-response ) + ftp-send read-response ; + +: ftp-user ( ftp-client -- ftp-response ) + user>> "USER " prepend ftp-command ; + +: ftp-password ( ftp-client -- ftp-response ) + password>> "PASS " prepend ftp-command ; + +: ftp-set-binary ( -- ftp-response ) + "TYPE I" ftp-command ; + +: ftp-pwd ( -- ftp-response ) + "PWD" ftp-command ; + +: ftp-list ( -- ftp-response ) + "LIST" ftp-command ; + +: ftp-quit ( -- ftp-response ) + "QUIT" ftp-command ; + +: ftp-cwd ( directory -- ftp-response ) + "CWD " prepend ftp-command ; + +: ftp-retr ( filename -- ftp-response ) + "RETR " prepend ftp-command ; + +: parse-epsv ( ftp-response -- port ) + strings>> first + "|" split 2 tail* first string>number ; + +TUPLE: remote-file +type permissions links owner group size month day time year +name target ; + +: ( -- remote-file ) remote-file new ; + +: parse-permissions ( remote-file str -- remote-file ) + [ first ch>type >>type ] [ rest >>permissions ] bi ; + +: parse-list-11 ( lines -- seq ) + [ + 11 f pad-right + swap { + [ 0 swap nth parse-permissions ] + [ 1 swap nth string>number >>links ] + [ 2 swap nth >>owner ] + [ 3 swap nth >>group ] + [ 4 swap nth string>number >>size ] + [ 5 swap nth >>month ] + [ 6 swap nth >>day ] + [ 7 swap nth >>time ] + [ 8 swap nth >>name ] + [ 10 swap nth >>target ] + } cleave + ] map ; + +: parse-list-8 ( lines -- seq ) + [ + swap { + [ 0 swap nth parse-permissions ] + [ 1 swap nth string>number >>links ] + [ 2 swap nth >>owner ] + [ 3 swap nth >>size ] + [ 4 swap nth >>month ] + [ 5 swap nth >>day ] + [ 6 swap nth >>time ] + [ 7 swap nth >>name ] + } cleave + ] map ; + +: parse-list-3 ( lines -- seq ) + [ + swap { + [ 0 swap nth parse-permissions ] + [ 1 swap nth string>number >>links ] + [ 2 swap nth >>name ] + } cleave + ] map ; + +: parse-list ( ftp-response -- ftp-response ) + dup strings>> + [ " " split harvest ] map + dup length { + { 11 [ parse-list-11 ] } + { 9 [ parse-list-11 ] } + { 8 [ parse-list-8 ] } + { 3 [ parse-list-3 ] } + [ drop ] + } case >>parsed ; + +: ftp-epsv ( -- ftp-response ) + "EPSV" ftp-command ; + +ERROR: ftp-error got expected ; +: ftp-assert ( ftp-response n -- ) + 2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ; + +: ftp-login ( ftp-client -- ) + read-response 220 ftp-assert + [ ftp-user 331 ftp-assert ] + [ ftp-password 230 ftp-assert ] bi + ftp-set-binary 200 ftp-assert ; + +: open-remote-port ( -- port ) + ftp-epsv + [ 229 ftp-assert ] [ parse-epsv ] bi ; + +: list ( ftp-client -- ftp-response ) + host>> open-remote-port utf8 drop + ftp-list 150 ftp-assert + lines + swap >>strings + read-response 226 ftp-assert + parse-list ; + +: ftp-get ( filename ftp-client -- ftp-response ) + host>> open-remote-port binary drop + swap + [ ftp-retr 150 ftp-assert drop ] + [ binary stream-copy ] 2bi + read-response dup 226 ftp-assert ; + +: ftp-connect ( ftp-client -- stream ) + [ host>> ] [ port>> ] bi utf8 drop ; + +GENERIC: ftp-download ( path obj -- ) + +: with-ftp-client ( ftp-client quot -- ) + dupd '[ + , [ ftp-login ] [ @ ] bi + ftp-quit drop + ] >r ftp-connect r> with-stream ; inline + +M: ftp-client ftp-download ( path ftp-client -- ) + [ + [ drop parent-directory ftp-cwd drop ] + [ >r file-name r> ftp-get drop ] 2bi + ] with-ftp-client ; + +M: string ftp-download ( path string -- ) + ftp-download ; diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor new file mode 100644 index 0000000000..b2b5ebc9aa --- /dev/null +++ b/extra/ftp/ftp.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators io io.files kernel +math.parser sequences strings ; +IN: ftp + +SINGLETON: active +SINGLETON: passive + +TUPLE: ftp-client host port user password mode state +command-promise ; + +: ( host -- ftp-client ) + ftp-client new + swap >>host + 21 >>port + "anonymous" >>user + "ftp@my.org" >>password ; + +: reset-ftp-client ( ftp-client -- ) + f >>user + f >>password + drop ; + +TUPLE: ftp-response n strings parsed ; + +: ( -- ftp-response ) + ftp-response new + V{ } clone >>strings ; + +: add-response-line ( ftp-response string -- ftp-response ) + over strings>> push ; + +: ftp-send ( string -- ) write "\r\n" write flush ; + +: ftp-ipv4 1 ; inline +: ftp-ipv6 2 ; inline + + +: ch>type ( ch -- type ) + { + { CHAR: d [ +directory+ ] } + { CHAR: l [ +symbolic-link+ ] } + { CHAR: - [ +regular-file+ ] } + [ drop +unknown+ ] + } case ; + +: type>ch ( type -- string ) + { + { +directory+ [ CHAR: d ] } + { +symbolic-link+ [ CHAR: l ] } + { +regular-file+ [ CHAR: - ] } + [ drop CHAR: - ] + } case ; + +: file-info>string ( file-info name -- string ) + >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ] + [ size>> number>string 15 CHAR: \s pad-left ] bi r> + 3array " " join ; + +: directory-list ( -- seq ) + "" directory keys + [ [ link-info ] keep file-info>string ] map ; diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor new file mode 100644 index 0000000000..cce69dde0f --- /dev/null +++ b/extra/ftp/server/server.factor @@ -0,0 +1,324 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators io io.encodings.8-bit +io.encodings io.encodings.binary io.encodings.utf8 io.files +io.server io.sockets kernel math.parser namespaces sequences +ftp io.unix.launcher.parser unicode.case splitting assocs +classes io.server destructors calendar io.timeouts +io.streams.duplex threads continuations math +concurrency.promises byte-arrays ; +IN: ftp.server + +SYMBOL: client + +TUPLE: ftp-command raw tokenized ; + +: ( -- obj ) + ftp-command new ; + +TUPLE: ftp-get path ; + +: ( path -- obj ) + ftp-get new swap >>path ; + +TUPLE: ftp-put path ; + +: ( path -- obj ) + ftp-put new swap >>path ; + +TUPLE: ftp-list ; + +C: ftp-list + +: read-command ( -- ftp-command ) + readln + [ >>raw ] [ tokenize-command >>tokenized ] bi ; + +: (send-response) ( n string separator -- ) + rot number>string write write ftp-send ; + +: send-response ( ftp-response -- ) + [ n>> ] [ strings>> ] bi + [ but-last-slice [ "-" (send-response) ] with each ] + [ first " " (send-response) ] 2bi ; + +: server-response ( n string -- ) + + swap add-response-line + swap >>n + send-response ; + +: ftp-error ( string -- ) + 500 "Unrecognized command: " rot append server-response ; + +: send-banner ( -- ) + 220 "Welcome to " host-name append server-response ; + +: anonymous-only ( -- ) + 530 "This FTP server is anonymous only." server-response ; + +: handle-QUIT ( obj -- ) + drop 221 "Goodbye." server-response ; + +: handle-USER ( ftp-command -- ) + [ + tokenized>> second client get swap >>user drop + 331 "Please specify the password." server-response + ] [ + 2drop "bad USER" ftp-error + ] recover ; + +: handle-PASS ( ftp-command -- ) + [ + tokenized>> second client get swap >>password drop + 230 "Login successful" server-response + ] [ + 2drop "PASS error" ftp-error + ] recover ; + +ERROR: type-error type ; + +: parse-type ( string -- string' ) + >upper { + { "IMAGE" [ "Binary" ] } + { "I" [ "Binary" ] } + [ type-error ] + } case ; + +: handle-TYPE ( obj -- ) + [ + tokenized>> second parse-type + 200 "Switching to " rot " mode" 3append server-response + ] [ + 2drop "TYPE is binary only" ftp-error + ] recover ; + +: random-local-server ( -- server ) + remote-address get class new 0 >>port binary ; + +: port>bytes ( port -- hi lo ) + [ -8 shift ] keep [ HEX: ff bitand ] bi@ ; + +: handle-PWD ( obj -- ) + drop + 257 current-directory get "\"" swap "\"" 3append server-response ; + +: handle-SYST ( obj -- ) + drop + 215 "UNIX Type: L8" server-response ; + +: if-command-promise ( quot -- ) + >r client get command-promise>> r> + [ "Establish an active or passive connection first" ftp-error ] if* ; + +: handle-STOR ( obj -- ) + [ + tokenized>> second + [ >r r> fulfill ] if-command-promise + ] [ + 2drop + ] recover ; + +! EPRT |2|::1|62138| +! : handle-EPRT ( obj -- ) + ! tokenized>> second "|" split harvest ; + +: start-directory ( -- ) + 150 "Here comes the directory listing." server-response ; + +: finish-directory ( -- ) + 226 "Opening " server-response ; + +GENERIC: service-command ( stream obj -- ) + +M: ftp-list service-command ( stream obj -- ) + drop + start-directory + [ + utf8 encode-output + directory-list [ ftp-send ] each + ] with-output-stream + finish-directory ; + +: transfer-outgoing-file ( path -- ) + 150 "Opening BINARY mode data connection for " + rot + [ file-name ] [ + " " swap file-info file-info-size number>string + "(" " bytes)." swapd 3append append + ] bi 3append server-response ; + +: transfer-incoming-file ( path -- ) + 150 "Opening BINARY mode data connection for " rot append + server-response ; + +: finish-file-transfer ( -- ) + 226 "File send OK." server-response ; + +M: ftp-get service-command ( stream obj -- ) + [ + path>> + [ transfer-outgoing-file ] + [ binary swap stream-copy ] bi + finish-file-transfer + ] [ + 3drop "File transfer failed" ftp-error + ] recover ; + +M: ftp-put service-command ( stream obj -- ) + [ + path>> + [ transfer-incoming-file ] + [ binary stream-copy ] bi + finish-file-transfer + ] [ + 3drop "File transfer failed" ftp-error + ] recover ; + +: passive-loop ( server -- ) + [ + [ + |dispose + 30 seconds over set-timeout + accept drop &dispose + client get command-promise>> + 30 seconds ?promise-timeout + service-command + ] + [ client get f >>command-promise drop ] + [ drop ] cleanup + ] with-destructors ; + +: handle-LIST ( obj -- ) + drop + [ >r r> fulfill ] if-command-promise ; + +: handle-SIZE ( obj -- ) + [ + tokenized>> second file-info size>> + 213 swap number>string server-response + ] [ + 2drop + 550 "Could not get file size" server-response + ] recover ; + +: handle-RETR ( obj -- ) + [ tokenized>> second swap fulfill ] + curry if-command-promise ; + +: expect-connection ( -- port ) + random-local-server + client get >>command-promise drop + [ [ passive-loop ] curry in-thread ] + [ addr>> port>> ] bi ; + +: handle-PASV ( obj -- ) + drop client get passive >>mode drop + expect-connection + [ + "Entering Passive Mode (127,0,0,1," % + port>bytes [ number>string ] bi@ "," swap 3append % + ")" % + ] "" make 227 swap server-response ; + +: handle-EPSV ( obj -- ) + drop + client get command-promise>> [ + "You already have a passive stream" ftp-error + ] [ + 229 "Entering Extended Passive Mode (|||" + expect-connection number>string + "|)" 3append server-response + ] if ; + +! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 +! : handle-LPRT ( obj -- ) tokenized>> "," split ; + +ERROR: not-a-directory ; + +: handle-CWD ( obj -- ) + [ + tokenized>> second dup directory? [ + set-current-directory + 250 "Directory successully changed." server-response + ] [ + not-a-directory throw + ] if + ] [ + 2drop + 550 "Failed to change directory." server-response + ] recover ; + +: unrecognized-command ( obj -- ) raw>> ftp-error ; + +: handle-client-loop ( -- ) + readln + [ >>raw ] + [ tokenize-command >>tokenized ] bi + dup tokenized>> first >upper { + { "USER" [ handle-USER t ] } + { "PASS" [ handle-PASS t ] } + { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] } + { "CWD" [ handle-CWD t ] } + ! { "XCWD" [ ] } + ! { "CDUP" [ ] } + ! { "SMNT" [ ] } + + ! { "REIN" [ drop client get reset-ftp-client t ] } + { "QUIT" [ handle-QUIT f ] } + + ! { "PORT" [ ] } ! TODO + { "PASV" [ handle-PASV t ] } + ! { "MODE" [ ] } + { "TYPE" [ handle-TYPE t ] } + ! { "STRU" [ ] } + + ! { "ALLO" [ ] } + ! { "REST" [ ] } + { "STOR" [ handle-STOR t ] } + ! { "STOU" [ ] } + { "RETR" [ handle-RETR t ] } + { "LIST" [ handle-LIST t ] } + { "SIZE" [ handle-SIZE t ] } + ! { "NLST" [ ] } + ! { "APPE" [ ] } + ! { "RNFR" [ ] } + ! { "RNTO" [ ] } + ! { "DELE" [ handle-DELE t ] } + ! { "RMD" [ handle-RMD t ] } + ! ! { "XRMD" [ handle-XRMD t ] } + ! { "MKD" [ handle-MKD t ] } + { "PWD" [ handle-PWD t ] } + ! { "ABOR" [ ] } + + { "SYST" [ handle-SYST t ] } + ! { "STAT" [ ] } + ! { "HELP" [ ] } + + ! { "SITE" [ ] } + ! { "NOOP" [ ] } + + ! { "EPRT" [ handle-EPRT ] } + ! { "LPRT" [ handle-LPRT ] } + { "EPSV" [ handle-EPSV t ] } + ! { "LPSV" [ drop handle-LPSV t ] } + [ drop unrecognized-command t ] + } case [ handle-client-loop ] when ; + +: handle-client ( -- ) + [ + "" [ + host-name client set + send-banner handle-client-loop + ] with-directory + ] with-destructors ; + +: ftpd ( port -- ) + internet-server "ftp.server" + latin1 [ handle-client ] with-server ; + +: ftpd-main ( -- ) 2100 ftpd ; + +MAIN: ftpd-main + +! sudo tcpdump -i en1 -A -s 10000 tcp port 21 diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index 7204693016..4fa56bcf93 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -35,4 +35,4 @@ PRIVATE> : 'glob' just parse-1 just ; : glob-matches? ( input glob -- ? ) - >r >lower r> parse nil? not ; + [ >lower ] [ ] bi* parse nil? not ; diff --git a/extra/hardware-info/linux/linux.factor b/extra/hardware-info/linux/linux.factor index 5d9ca6eaa7..89f42b4384 100644 --- a/extra/hardware-info/linux/linux.factor +++ b/extra/hardware-info/linux/linux.factor @@ -7,7 +7,7 @@ IN: hardware-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep - "\0" split [ empty? not ] filter [ >string ] map + "\0" split harvest [ >string ] map 6 "" pad-right ; : sysname ( -- string ) uname first ; @@ -18,4 +18,4 @@ IN: hardware-info.linux : domainname ( -- string ) uname 5 swap nth ; : kernel-version ( -- seq ) - release ".-" split [ ] filter 5 "" pad-right ; + release ".-" split harvest 5 "" pad-right ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index a8271a0e3b..863a538b47 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -105,6 +105,7 @@ ARTICLE: "objects" "Objects" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." { $subsection "equality" } { $subsection "math.order" } +{ $subsection "destructors" } { $subsection "classes" } { $subsection "tuples" } { $subsection "generic" } @@ -207,7 +208,8 @@ ARTICLE: "io" "Input and output" { $subsection "io.pipes" } { $heading "Other features" } { $subsection "io.timeouts" } -{ $subsection "checksums" } ; +{ $subsection "checksums" } +{ $see-also "destructors" } ; ARTICLE: "tools" "Developer tools" { $subsection "tools.vocabs" } @@ -238,7 +240,7 @@ ARTICLE: "error-index" "Error index" { $index [ all-errors ] } ; ARTICLE: "type-index" "Type index" -{ $index [ builtins get [ ] filter ] } ; +{ $index [ builtins get sift ] } ; ARTICLE: "class-index" "Class index" { $index [ classes ] } ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 2d56251392..75a14e645b 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":vars - list all variables at error time" print ; : :help ( -- ) - error get delegates [ error-help ] map [ ] filter + error get delegates [ error-help ] map sift { { [ dup empty? ] [ (:help-none) ] } { [ dup length 1 = ] [ first help ] } diff --git a/extra/html/html.factor b/extra/html/html.factor index c154c35223..71862b0d01 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -3,7 +3,7 @@ USING: generic assocs help http io io.styles io.files continuations io.streams.string kernel math math.order math.parser namespaces quotations assocs sequences strings words html.elements -xml.entities sbufs continuations ; +xml.entities sbufs continuations destructors ; IN: html GENERIC: browser-link-href ( presented -- href ) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index e9906f3f2a..42355f954e 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,8 +1,11 @@ USING: assocs html.parser kernel math sequences strings ascii arrays shuffle unicode.case namespaces splitting http -sequences.lib ; +sequences.lib accessors io combinators http.client ; IN: html.parser.analyzer +: scrape-html ( url -- vector ) + http-get parse-html ; + : (find-relative) [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; @@ -41,8 +44,8 @@ IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) [ - dup tag-name text = [ - tag-text [ blank? ] all? not + dup name>> text = [ + text>> [ blank? ] all? not ] [ drop t ] if @@ -50,49 +53,50 @@ IN: html.parser.analyzer : trim-text ( vector -- vector' ) [ - dup tag-name text = [ - [ tag-text [ blank? ] trim ] keep + dup name>> text = [ + [ text>> [ blank? ] trim ] keep [ set-tag-text ] keep ] when ] map ; : find-by-id ( id vector -- vector ) - [ tag-attributes "id" swap at = ] with filter ; + [ attributes>> "id" swap at = ] with filter ; : find-by-class ( id vector -- vector ) - [ tag-attributes "class" swap at = ] with filter ; + [ attributes>> "class" swap at = ] with filter ; : find-by-name ( str vector -- vector ) >r >lower r> - [ tag-name = ] with filter ; + [ name>> = ] with filter ; : find-first-name ( str vector -- i/f tag/f ) >r >lower r> - [ tag-name = ] with find ; + [ name>> = ] with find ; : find-matching-close ( str vector -- i/f tag/f ) >r >lower r> - [ [ tag-name = ] keep tag-closing? and ] with find ; + [ [ name>> = ] keep closing?>> and ] with find ; : find-by-attribute-key ( key vector -- vector ) >r >lower r> - [ tag-attributes at ] with filter - [ ] filter ; + [ attributes>> at ] with filter + sift ; : find-by-attribute-key-value ( value key vector -- vector ) >r >lower r> - [ tag-attributes at over = ] with filter nip - [ ] filter ; + [ attributes>> at over = ] with filter nip + sift ; : find-first-attribute-key-value ( value key vector -- i/f tag/f ) >r >lower r> - [ tag-attributes at over = ] with find rot drop ; + [ attributes>> at over = ] with find rot drop ; : find-between* ( i/f tag/f vector -- vector ) pick integer? [ rot tail-slice - >r tag-name r> - [ find-matching-close drop 1+ ] keep swap head + >r name>> r> + [ find-matching-close drop dup [ 1+ ] when ] keep + swap [ head ] [ first ] if* ] [ 3drop V{ } clone ] if ; @@ -105,31 +109,63 @@ IN: html.parser.analyzer : find-between-first ( string vector -- vector' ) [ find-first-name ] keep find-between ; +: find-between-all ( vector quot -- seq ) + [ [ [ closing?>> not ] bi and ] curry find-all ] curry + [ [ >r first2 r> find-between* ] curry map ] bi ; + : tag-link ( tag -- link/f ) - tag-attributes [ "href" swap at ] [ f ] if* ; + attributes>> [ "href" swap at ] [ f ] if* ; -: find-links ( vector -- vector ) - [ tag-name "a" = ] filter - [ tag-link ] filter ; +: find-links ( vector -- vector' ) + [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ] + find-between-all ; +: link. ( vector -- ) + [ second text>> write bl ] + [ first tag-link write nl ] bi ; : find-by-text ( seq quot -- tag ) - [ dup tag-name text = ] prepose find drop ; + [ dup name>> text = ] prepose find drop ; : find-opening-tags-by-name ( name seq -- seq ) - [ [ tag-name = ] keep tag-closing? not and ] with find-all ; + [ [ name>> = ] keep closing?>> not and ] with find-all ; : href-contains? ( str tag -- ? ) - tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; + attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ; + + +: find-forms ( vector -- vector' ) + "form" over find-opening-tags-by-name + over [ >r first2 r> find-between* ] curry map + [ [ name>> { "form" "input" } member? ] filter ] map ; + +: find-html-objects ( string vector -- vector' ) + find-opening-tags-by-name + over [ >r first2 r> find-between* ] curry map ; + +: form-action ( vector -- string ) + [ name>> "form" = ] find nip + attributes>> "action" swap at ; + +: hidden-form-values ( vector -- strings ) + [ attributes>> "type" swap at "hidden" = ] filter ; + +: input. ( tag -- ) + dup name>> print + attributes>> + [ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ; + +: form. ( vector -- ) + [ closing?>> not ] filter + [ + { + { [ dup name>> "form" = ] + [ "form action: " write attributes>> "action" swap at print + ] } + { [ dup name>> "input" = ] [ input. ] } + [ drop ] + } cond + ] each ; : query>assoc* ( str -- hash ) "?" split1 nip query>assoc ; - -! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] filter [ "=" split peek ] map - -! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text -! "a" over find-opening-tags-by-name -! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-filter -! first first 8 + over nth -! tag-attributes "href" swap at query>assoc* -! "lat" over at "lon" rot at diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index bc4dc429fa..1ae5768f98 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -91,7 +91,7 @@ SYMBOL: tagstack read-dtd ] if ; -: read-tag ( -- ) +: read-tag ( -- string ) [ get-char CHAR: > = get-char CHAR: < = or ] take-until get-char CHAR: < = [ next* ] unless ; @@ -135,7 +135,7 @@ SYMBOL: tagstack (parse-tag) make-tag push-tag ] if ; -: (parse-html) ( tag -- ) +: (parse-html) ( -- ) get-next [ parse-text parse-tag diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 1d947b99e5..9ad805b81b 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,9 +1,7 @@ USING: http.client http.client.private http tools.test tuple-syntax namespaces ; -[ "localhost" 80 ] [ "localhost" parse-host ] unit-test +[ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] 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.arc.com/foo.txt?xxx" download-name ] unit-test @@ -12,10 +10,11 @@ tuple-syntax namespaces ; [ TUPLE{ request + protocol: http method: "GET" host: "www.apple.com" - path: "/index.html" port: 80 + path: "/index.html" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } } @@ -26,3 +25,21 @@ tuple-syntax namespaces ; ] with-scope ] unit-test + +[ + TUPLE{ request + protocol: https + method: "GET" + host: "www.amazon.com" + port: 443 + path: "/index.html" + version: "1.1" + cookies: V{ } + header: H{ { "connection" "close" } } + } +] [ + [ + "https://www.amazon.com/index.html" + + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 17882277a3..cec1bb931a 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -19,22 +19,8 @@ DEFER: http-request r >>path r> dup [ query>assoc ] when >>query ; - -: request-with-url ( request url -- request ) - parse-url >r >r store-path r> >>host r> >>port ; - SYMBOL: redirects -: absolute-url? ( url -- ? ) - [ "http://" head? ] [ "https://" head? ] bi or ; - : do-redirect ( response data -- response data ) over code>> 300 399 between? [ drop @@ -42,7 +28,7 @@ SYMBOL: redirects redirects get max-redirects < [ request get swap "location" header dup absolute-url? - [ request-with-url ] [ store-path ] if + [ request-with-url ] [ request-with-path ] if "GET" >>method http-request ] [ too-many-redirects diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 21eb241b84..89480b43ba 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -45,6 +45,7 @@ blah [ TUPLE{ request + protocol: http port: 80 method: "GET" path: "/bar" @@ -84,6 +85,7 @@ Host: www.sex.com [ TUPLE{ request + protocol: http port: 80 method: "HEAD" path: "/bar" @@ -177,6 +179,8 @@ test-db [ ] with-scope ] unit-test +[ ] [ 100 sleep ] unit-test + [ t ] [ "resource:extra/http/test/foo.html" ascii file-contents "http://localhost:1237/nested/foo.html" http-get = @@ -218,7 +222,7 @@ test-db [ ] with-scope ] unit-test -[ ] [ 1000 sleep ] unit-test +[ ] [ 100 sleep ] unit-test : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; @@ -245,7 +249,7 @@ test-db [ ] with-scope ] unit-test -[ ] [ 1000 sleep ] unit-test +[ ] [ 100 sleep ] unit-test [ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 786210123d..bc79424552 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -7,7 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format io io.streams.string io.encodings.utf8 io.encodings.string -io.sockets +io.sockets io.sockets.secure unicode.case unicode.categories qualified ; @@ -15,7 +15,31 @@ EXCLUDE: fry => , ; IN: http -: http-port 80 ; inline +SINGLETON: http + +SINGLETON: https + +GENERIC: http-port ( protocol -- port ) + +M: http http-port drop 80 ; + +M: https http-port drop 443 ; + +GENERIC: protocol>string ( protocol -- string ) + +M: http protocol>string drop "http" ; + +M: https protocol>string drop "https" ; + +: string>protocol ( string -- protocol ) + { + { "http" [ http ] } + { "https" [ https ] } + [ "Unknown protocol: " swap append throw ] + } case ; + +: absolute-url? ( url -- ? ) + [ "http://" head? ] [ "https://" head? ] bi or ; : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -210,6 +234,7 @@ TUPLE: cookie name value path domain expires max-age http-only ; [ unparse-cookie ] map concat "; " join ; TUPLE: request +protocol host port method @@ -227,7 +252,7 @@ cookies ; : request new "1.1" >>version - http-port >>port + http >>protocol H{ } clone >>header H{ } clone >>query V{ } clone >>cookies @@ -240,6 +265,7 @@ cookies ; pick query>> set-at ; : chop-hostname ( str -- str' ) + ":" split1 "//" ?head drop nip CHAR: / over index over length or tail dup empty? [ drop "/" ] when ; @@ -247,7 +273,9 @@ cookies ; #! 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 ; + url-decode + dup { "http://" "https://" } [ head? ] with contains? + [ chop-hostname ] when ; : read-method ( request -- request ) " " read-until [ "Bad request: method" throw ] unless @@ -296,10 +324,11 @@ SYMBOL: max-post-request : parse-host ( string -- host port ) "." ?tail drop ":" split1 - [ string>number ] [ http-port ] if* ; + dup [ string>number ] when ; : extract-host ( request -- request ) - dup "host" header parse-host >r >>host r> >>port ; + dup [ "host" header parse-host ] keep protocol>> http-port or + [ >>host ] [ >>port ] bi* ; : extract-post-data-type ( request -- request ) dup "content-type" header >>post-data-type ; @@ -312,7 +341,7 @@ SYMBOL: max-post-request dup "cookie" header [ parse-cookies >>cookies ] when* ; : parse-content-type-attributes ( string -- attributes ) - " " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ; + " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ; : parse-content-type ( content-type -- type encoding ) ";" split1 parse-content-type-attributes "charset" swap at ; @@ -351,12 +380,20 @@ SYMBOL: max-post-request "application/x-www-form-urlencoded" >>post-data-type ] if ; +GENERIC: protocol-addr ( request protocol -- addr ) + +M: object protocol-addr + drop [ host>> ] [ port>> ] bi ; + +M: https protocol-addr + call-next-method ; + : request-addr ( request -- addr ) - [ host>> ] [ port>> ] bi ; + dup protocol>> protocol-addr ; : request-host ( request -- string ) - [ host>> ] [ port>> ] bi - dup 80 = [ drop ] [ ":" swap number>string 3append ] if ; + [ host>> ] [ port>> ] bi dup http http-port = + [ drop ] [ ":" swap number>string 3append ] if ; : write-request-header ( request -- request ) dup header>> >hashtable @@ -379,13 +416,32 @@ SYMBOL: max-post-request flush drop ; +: request-with-path ( request path -- request ) + [ "/" prepend ] [ "/" ] if* + "?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ; + +: request-with-url ( request url -- request ) + ":" split1 + [ string>protocol >>protocol ] + [ + "//" ?head [ "Invalid URL" throw ] unless + "/" split1 + [ + parse-host [ >>host ] [ >>port ] bi* + dup protocol>> http-port '[ , or ] change-port + ] + [ request-with-path ] + bi* + ] bi* ; + : request-url ( request -- url ) [ [ dup host>> [ - [ "http://" write host>> url-encode write ] - [ ":" write port>> number>string write ] - bi + [ protocol>> protocol>string write "://" write ] + [ host>> url-encode write ":" write ] + [ [ port>> ] [ protocol>> http-port or ] bi number>string write ] + tri ] [ drop ] if ] [ path>> "/" head? [ "/" write ] unless ] diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 9f1fe6fe77..bb77532a22 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -58,7 +58,7 @@ M: user-saver dispose user>> dup changed?>> [ users update-user ] [ drop ] if ; : save-user-after ( user -- ) - add-always-destructor ; + &dispose drop ; : login-template ( name -- template ) "resource:extra/http/server/auth/login/" swap ".xml" diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index a5dffbc58b..af27eda527 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -6,6 +6,7 @@ IN: http.server.tests [ + http >>protocol "www.apple.com" >>host "/xxx/bar" >>path { { "a" "b" } } >>query diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 70c1e9a1f5..4e561220f9 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -240,7 +240,7 @@ SYMBOL: exit-continuation '[ exit-continuation set @ ] callcc1 exit-continuation off ; : split-path ( string -- path ) - "/" split [ empty? not ] filter ; + "/" split harvest ; : init-request ( -- ) H{ } clone base-paths set diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index fe32327c24..a7e1a141c4 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -102,7 +102,7 @@ M: session-saver dispose ] [ drop ] if ; : save-session-after ( session -- ) - add-always-destructor ; + &dispose drop ; : existing-session ( path session -- response ) [ session set ] [ save-session-after ] bi diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index b9a8e9d46e..2f7a6eb221 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -91,7 +91,7 @@ TUPLE: file-responder root hook special allow-listings ; : serve-object ( filename -- response ) serving-path dup exists? - [ dup directory? [ serve-directory ] [ serve-file ] if ] + [ dup file-info directory? [ serve-directory ] [ serve-file ] if ] [ drop <404> ] if ; diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 88414efd16..a8cd1fea91 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -37,8 +37,7 @@ IN: io.encodings.8-bit 2dup swap length <= [ tail ] [ drop ] if ; : process-contents ( lines -- assoc ) - [ "#" split1 drop ] map - [ empty? not ] filter + [ "#" split1 drop ] map harvest [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ; : byte>ch ( assoc -- array ) diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor index 01b8e131cc..bb4e9ef01f 100644 --- a/extra/io/files/unique/unique-docs.factor +++ b/extra/io/files/unique/unique-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io io.nonblocking kernel math +USING: help.markup help.syntax io io.ports kernel math io.files.unique.private math.parser io.files ; IN: io.files.unique diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index e8eb973e34..54715e23da 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.nonblocking ; +io.streams.duplex io.ports ; IN: io.launcher TUPLE: process < identity-tuple @@ -151,21 +151,21 @@ M: process timed-out kill-process ; M: object run-pipeline-element [ >process swap >>stdout swap >>stdin run-detached ] - [ drop [ [ close-handle ] when* ] bi@ ] + [ drop [ [ dispose ] when* ] bi@ ] 3bi wait-for-process ; : ( process encoding -- process stream ) [ >r (pipe) { - [ add-error-destructor ] + [ |dispose drop ] [ swap >process [ swap out>> or ] change-stdout run-detached ] - [ out>> close-handle ] - [ in>> ] + [ out>> dispose ] + [ in>> ] } cleave r> ] with-destructors ; @@ -175,14 +175,14 @@ M: object run-pipeline-element : ( process encoding -- process stream ) [ >r (pipe) { - [ add-error-destructor ] + [ |dispose drop ] [ swap >process [ swap in>> or ] change-stdout run-detached ] - [ in>> close-handle ] - [ out>> ] + [ in>> dispose ] + [ out>> ] } cleave r> ] with-destructors ; @@ -192,15 +192,15 @@ M: object run-pipeline-element : ( process encoding -- process stream ) [ >r (pipe) (pipe) { - [ [ add-error-destructor ] bi@ ] + [ [ |dispose drop ] bi@ ] [ rot >process [ swap out>> or ] change-stdout [ swap in>> or ] change-stdin run-detached ] - [ [ in>> close-handle ] [ out>> close-handle ] bi* ] - [ [ in>> ] [ out>> ] bi* ] + [ [ out>> dispose ] [ in>> dispose ] bi* ] + [ [ in>> ] [ out>> ] bi* ] } 2cleave r> ] with-destructors ; diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor index cb51088e58..4ac85232b8 100755 --- a/extra/io/mmap/mmap-docs.factor +++ b/extra/io/mmap/mmap-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax alien math continuations ; +USING: help.markup help.syntax alien math continuations +destructors ; IN: io.mmap HELP: mapped-file @@ -15,6 +16,11 @@ HELP: { $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." } { $errors "Throws an error if a memory mapping could not be established." } ; +HELP: with-mapped-file +{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } } +{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $errors "Throws an error if a memory mapping could not be established." } ; + HELP: close-mapped-file { $values { "mmap" mapped-file } } { $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." } diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index da3ed38688..57faca01c7 100755 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -2,11 +2,9 @@ USING: io io.mmap io.files kernel tools.test continuations sequences io.encodings.ascii accessors ; IN: io.mmap.tests -[ "resource:mmap-test-file.txt" delete-file ] ignore-errors -[ ] [ "12345" "resource:mmap-test-file.txt" ascii set-file-contents ] unit-test -[ ] [ "resource:mmap-test-file.txt" dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test -[ 5 ] [ "resource:mmap-test-file.txt" dup file-info size>> [ length ] with-mapped-file ] unit-test -[ "22345" ] [ "resource:mmap-test-file.txt" ascii file-contents ] unit-test -[ "resource:mmap-test-file.txt" delete-file ] ignore-errors - - +[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors +[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test +[ ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test +[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test +[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index a07443783c..dde5210995 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,37 +1,31 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: continuations io.backend kernel quotations sequences -system alien alien.accessors sequences.private ; +USING: continuations destructors io.backend kernel quotations +sequences system alien alien.accessors accessors +sequences.private ; IN: io.mmap -TUPLE: mapped-file length address handle closed? ; +TUPLE: mapped-file address handle length disposed ; -: check-closed ( mapped-file -- mapped-file ) - dup mapped-file-closed? [ - "Mapped file is closed" throw - ] when ; inline - -M: mapped-file length check-closed mapped-file-length ; +M: mapped-file length dup check-disposed length>> ; M: mapped-file nth-unsafe - check-closed mapped-file-address swap alien-unsigned-1 ; + dup check-disposed address>> swap alien-unsigned-1 ; M: mapped-file set-nth-unsafe - check-closed mapped-file-address swap set-alien-unsigned-1 ; + dup check-disposed address>> swap set-alien-unsigned-1 ; INSTANCE: mapped-file sequence -HOOK: (mapped-file) io-backend ( path length -- mmap ) +HOOK: (mapped-file) io-backend ( path length -- address handle ) : ( path length -- mmap ) - >r normalize-path r> (mapped-file) ; + [ >r normalize-path r> (mapped-file) ] keep + f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) -M: mapped-file dispose ( mmap -- ) - check-closed - t over set-mapped-file-closed? - close-mapped-file ; +M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file ( path length quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index cd6a06a8e9..b81bd1d303 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -1,5 +1,5 @@ IN: io.monitors -USING: help.markup help.syntax continuations +USING: help.markup help.syntax continuations destructors concurrency.mailboxes quotations ; HELP: with-monitors diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor old mode 100644 new mode 100755 index 77d539259e..bd33954436 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -1,7 +1,7 @@ IN: io.monitors.tests USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io -threads calendar prettyprint ; +threads calendar prettyprint destructors io.timeouts ; os { winnt linux macosx } member? [ [ @@ -89,5 +89,23 @@ os { winnt linux macosx } member? [ ] with-monitors ! Out-of-scope disposal should not fail - [ "" resource-path t ] with-monitors dispose + [ ] [ [ "" resource-path f ] with-monitors dispose ] unit-test + [ ] [ [ "" resource-path t ] with-monitors dispose ] unit-test + + ! Timeouts + [ + [ ] [ "monitor-timeout-test" temp-file make-directories ] unit-test + + ! Non-recursive + [ ] [ "monitor-timeout-test" temp-file f "m" set ] unit-test + [ ] [ 3 seconds "m" get set-timeout ] unit-test + [ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail + [ ] [ "m" get dispose ] unit-test + + ! Recursive + [ ] [ "monitor-timeout-test" temp-file t "m" set ] unit-test + [ ] [ 3 seconds "m" get set-timeout ] unit-test + [ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail + [ ] [ "m" get dispose ] unit-test + ] with-monitors ] when diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 863c8fc95c..65c1eb7e82 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays threads boxes io.timeouts -accessors concurrency.mailboxes ; +USING: io.backend kernel continuations destructors namespaces +sequences assocs hashtables sorting arrays threads boxes +io.timeouts accessors concurrency.mailboxes ; IN: io.monitors HOOK: init-monitors io-backend ( -- ) diff --git a/extra/io/monitors/recursive/recursive-tests.factor b/extra/io/monitors/recursive/recursive-tests.factor index 44baadf39a..fba879a6d2 100644 --- a/extra/io/monitors/recursive/recursive-tests.factor +++ b/extra/io/monitors/recursive/recursive-tests.factor @@ -1,7 +1,6 @@ USING: accessors math kernel namespaces continuations io.files io.monitors io.monitors.recursive io.backend -concurrency.mailboxes -tools.test ; +concurrency.mailboxes tools.test destructors ; IN: io.monitors.recursive.tests \ pump-thread must-infer diff --git a/extra/io/monitors/recursive/recursive.factor b/extra/io/monitors/recursive/recursive.factor index 04d491edbe..383e166214 100644 --- a/extra/io/monitors/recursive/recursive.factor +++ b/extra/io/monitors/recursive/recursive.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors sequences assocs arrays continuations combinators kernel -threads concurrency.messaging concurrency.mailboxes concurrency.promises -io.files io.monitors debugger ; +USING: accessors sequences assocs arrays continuations +destructors combinators kernel threads concurrency.messaging +concurrency.mailboxes concurrency.promises io.files io.monitors +debugger ; IN: io.monitors.recursive ! Simulate recursive monitors on platforms that don't have them -TUPLE: recursive-monitor < monitor children thread ready ; +TUPLE: recursive-monitor < monitor children thread ready disposed ; : notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ; @@ -35,13 +36,10 @@ DEFER: add-child-monitor : remove-child-monitor ( monitor -- ) monitor tget children>> delete-at* [ dispose ] [ drop ] if ; -M: recursive-monitor dispose - dup queue>> closed>> [ - drop - ] [ - [ "stop" swap thread>> send-synchronous drop ] - [ queue>> dispose ] bi - ] if ; +M: recursive-monitor dispose* + [ "stop" swap thread>> send-synchronous drop ] + [ queue>> dispose ] + bi ; : stop-pump ( -- ) monitor tget children>> [ nip dispose ] assoc-each ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor deleted file mode 100755 index d25d4b7050..0000000000 --- a/extra/io/nonblocking/nonblocking.factor +++ /dev/null @@ -1,171 +0,0 @@ -! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman -! See http://factorcode.org/license.txt for BSD license. -USING: math kernel io sequences io.buffers io.timeouts generic -byte-vectors system io.encodings math.order io.backend -continuations debugger classes byte-arrays namespaces splitting -dlists assocs io.encodings.binary inspector accessors ; -IN: io.nonblocking - -SYMBOL: default-buffer-size -64 1024 * default-buffer-size set-global - -TUPLE: port handle buffer error timeout closed eof ; - -M: port timeout timeout>> ; - -M: port set-timeout (>>timeout) ; - -GENERIC: init-handle ( handle -- ) - -GENERIC: close-handle ( handle -- ) - -: ( handle class -- port ) - new - swap dup init-handle >>handle ; inline - -: ( handle class -- port ) - - default-buffer-size get >>buffer ; inline - -TUPLE: input-port < port ; - -: ( handle -- input-port ) - input-port ; - -TUPLE: output-port < port ; - -: ( handle -- output-port ) - output-port ; - -: ( read-handle write-handle -- input-port output-port ) - swap [ swap ] [ ] [ dispose drop ] cleanup ; - -: pending-error ( port -- ) - [ f ] change-error drop [ throw ] when* ; - -ERROR: port-closed-error port ; - -M: port-closed-error summary - drop "Port has been closed" ; - -: check-closed ( port -- port ) - dup closed>> [ port-closed-error ] when ; - -HOOK: cancel-io io-backend ( port -- ) - -M: object cancel-io drop ; - -M: port timed-out cancel-io ; - -GENERIC: (wait-to-read) ( port -- ) - -: wait-to-read ( count port -- ) - tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ; - -: wait-to-read1 ( port -- ) - 1 swap wait-to-read ; - -: unless-eof ( port quot -- value ) - >r dup buffer>> buffer-empty? over eof>> and - [ f >>eof drop f ] r> if ; inline - -M: input-port stream-read1 - check-closed - dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ; - -: read-step ( count port -- byte-array/f ) - [ wait-to-read ] 2keep - [ dupd buffer>> buffer-read ] unless-eof nip ; - -: read-loop ( count port accum -- ) - pick over length - dup 0 > [ - pick read-step dup [ - over push-all read-loop - ] [ - 2drop 2drop - ] if - ] [ - 2drop 2drop - ] if ; - -M: input-port stream-read - check-closed - >r 0 max >fixnum r> - 2dup read-step dup [ - pick over length > [ - pick - [ push-all ] keep - [ read-loop ] keep - B{ } like - ] [ 2nip ] if - ] [ 2nip ] if ; - -M: input-port stream-read-partial ( max stream -- byte-array/f ) - check-closed - >r 0 max >fixnum r> read-step ; - -: can-write? ( len buffer -- ? ) - [ buffer-fill + ] keep buffer-capacity <= ; - -: wait-to-write ( len port -- ) - tuck buffer>> can-write? [ drop ] [ stream-flush ] if ; - -M: output-port stream-write1 - check-closed - 1 over wait-to-write - buffer>> byte>buffer ; - -M: output-port stream-write - check-closed - over length over buffer>> buffer-size > [ - [ buffer>> buffer-size ] - [ [ stream-write ] curry ] bi - each - ] [ - [ >r length r> wait-to-write ] - [ buffer>> >buffer ] 2bi - ] if ; - -GENERIC: port-flush ( port -- ) - -M: output-port stream-flush ( port -- ) - check-closed - [ port-flush ] [ pending-error ] bi ; - -GENERIC: close-port ( port -- ) - -M: output-port close-port - [ port-flush ] [ call-next-method ] bi ; - -M: port close-port - dup cancel-io - dup handle>> close-handle - [ [ buffer-free ] when* f ] change-buffer drop ; - -M: port dispose - dup closed>> [ drop ] [ t >>closed close-port ] if ; - -TUPLE: server-port < port addr client client-addr encoding ; - -: ( handle addr encoding -- server ) - rot server-port - swap >>encoding - swap >>addr ; - -: check-server-port ( port -- port ) - dup server-port? [ "Not a server port" throw ] unless ; inline - -TUPLE: datagram-port < port addr packet packet-addr ; - -: ( handle addr -- datagram ) - swap datagram-port - swap >>addr ; - -: check-datagram-port ( port -- port ) - check-closed - dup datagram-port? [ "Not a datagram port" throw ] unless ; inline - -: check-datagram-send ( packet addrspec port -- packet addrspec port ) - check-datagram-port - 2dup addr>> [ class ] bi@ assert= - pick class byte-array assert= ; diff --git a/extra/io/pipes/pipes-docs.factor b/extra/io/pipes/pipes-docs.factor index d51ae94bc7..221cce1dbe 100644 --- a/extra/io/pipes/pipes-docs.factor +++ b/extra/io/pipes/pipes-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax continuations io ; +USING: help.markup help.syntax continuations destructors io ; IN: io.pipes HELP: pipe diff --git a/extra/io/pipes/pipes-tests.factor b/extra/io/pipes/pipes-tests.factor index c1b37f6efc..d1c2e54bb0 100755 --- a/extra/io/pipes/pipes-tests.factor +++ b/extra/io/pipes/pipes-tests.factor @@ -1,6 +1,6 @@ USING: io io.pipes io.streams.string io.encodings.utf8 -io.streams.duplex io.encodings namespaces continuations -tools.test kernel ; +io.streams.duplex io.encodings io.timeouts namespaces +continuations tools.test kernel calendar destructors ; IN: io.pipes.tests [ "Hello" ] [ @@ -24,3 +24,10 @@ IN: io.pipes.tests [ input-stream [ utf8 ] change readln ] } run-pipeline ] unit-test + +[ + utf8 [ + 5 seconds over set-timeout + stream-readln + ] with-disposal +] must-fail diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index 72d27372f3..f98fa4b0d4 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.encodings io.backend io.nonblocking io.streams.duplex +USING: io.encodings io.backend io.ports io.streams.duplex io splitting sequences sequences.lib namespaces kernel destructors math concurrency.combinators accessors arrays continuations quotations ; @@ -9,24 +9,21 @@ IN: io.pipes TUPLE: pipe in out ; M: pipe dispose ( pipe -- ) - [ in>> close-handle ] [ out>> close-handle ] bi ; + [ in>> dispose ] [ out>> dispose ] bi ; HOOK: (pipe) io-backend ( -- pipe ) : ( encoding -- stream ) [ - >r (pipe) - [ add-error-destructor ] - [ in>> ] - [ out>> ] - tri + >r (pipe) |dispose + [ in>> ] [ out>> ] bi r> ] with-destructors ; dup add-always-destructor ] [ input-stream get ] if* ; -: ?writer [ dup add-always-destructor ] [ output-stream get ] if* ; +: ?reader [ &dispose ] [ input-stream get ] if* ; +: ?writer [ &dispose ] [ output-stream get ] if* ; GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot ) @@ -38,7 +35,7 @@ M: callable run-pipeline-element : ( n -- pipes ) [ - [ (pipe) dup add-error-destructor ] replicate + [ (pipe) |dispose ] replicate T{ pipe } [ prefix ] [ suffix ] bi 2 ] with-destructors ; diff --git a/extra/io/nonblocking/authors.txt b/extra/io/ports/authors.txt similarity index 100% rename from extra/io/nonblocking/authors.txt rename to extra/io/ports/authors.txt diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/ports/ports-docs.factor similarity index 57% rename from extra/io/nonblocking/nonblocking-docs.factor rename to extra/io/ports/ports-docs.factor index bd2be34c9d..7420cac115 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -1,9 +1,10 @@ USING: io io.buffers io.backend help.markup help.syntax kernel -byte-arrays sbufs words continuations byte-vectors classes ; -IN: io.nonblocking +byte-arrays sbufs words continuations destructors +byte-vectors classes ; +IN: io.ports -ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" -"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.nonblocking" } " vocabulary." +ARTICLE: "io.ports" "Non-blocking I/O implementation" +"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.ports" } " vocabulary." $nl "A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:" { $subsection port } @@ -11,36 +12,24 @@ $nl { $subsection } "Input ports:" { $subsection input-port } -{ $subsection } +{ $subsection } "Output ports:" { $subsection output-port } -{ $subsection } +{ $subsection } "Global native I/O protocol:" { $subsection io-backend } { $subsection init-io } { $subsection init-stdio } { $subsection io-multiplex } "Per-port native I/O protocol:" -{ $subsection init-handle } { $subsection (wait-to-read) } -"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words." -$nl -"Dummy ports which should be used to implement networking:" -{ $subsection server-port } -{ $subsection datagram-port } ; +{ $subsection (wait-to-write) } +"Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ; -ABOUT: "io.nonblocking" +ABOUT: "io.ports" HELP: port -{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." -$nl -"Ports have the following slots:" -{ $list - { { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" } - { { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" } - { { $snippet "type" } " - a symbol identifying the port's intended purpose" } - { { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" } -} } ; +{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." } ; HELP: input-port { $class-description "The class of ports implementing the input stream protocol." } ; @@ -48,10 +37,6 @@ HELP: input-port HELP: output-port { $class-description "The class of ports implementing the output stream protocol." } ; -HELP: init-handle -{ $values { "handle" "a native handle identifying an I/O resource" } } -{ $contract "Prepares a native handle for use by the port; called by " { $link } "." } ; - HELP: { $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } } { $description "Creates a new " { $link port } " with no buffer." } @@ -62,35 +47,23 @@ HELP: { $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." } $low-level-note ; -HELP: +HELP: { $values { "handle" "a native handle identifying an I/O resource" } { "input-port" "a new " { $link input-port } } } { $description "Creates a new " { $link input-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; -HELP: +HELP: { $values { "handle" "a native handle identifying an I/O resource" } { "output-port" "a new " { $link output-port } } } { $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; -HELP: pending-error -{ $values { "port" port } } -{ $description "If an error occurred while the I/O thread was performing input or output on this port, this error will be thrown to the caller." } ; - HELP: (wait-to-read) { $values { "port" input-port } } { $contract "Suspends the current thread until the port's buffer has data available for reading." } ; HELP: wait-to-read -{ $values { "count" "a non-negative integer" } { "port" input-port } } -{ $description "If the port's buffer has at least " { $snippet "count" } " unread bytes, returns immediately, otherwise suspends the current thread until some data is available for reading." } ; - -HELP: wait-to-read1 -{ $values { "port" input-port } } -{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ; - -HELP: unless-eof -{ $values { "port" input-port } { "quot" "a quotation with stack effect " { $snippet "( port -- value )" } } { "value" object } } -{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ; +{ $values { "port" input-port } { "eof?" "a boolean" } } +{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ; HELP: can-write? { $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } } diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor new file mode 100755 index 0000000000..b82797354f --- /dev/null +++ b/extra/io/ports/ports.factor @@ -0,0 +1,128 @@ +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman +! See http://factorcode.org/license.txt for BSD license. +USING: math kernel io sequences io.buffers io.timeouts generic +byte-vectors system io.encodings math.order io.backend +continuations debugger classes byte-arrays namespaces splitting +dlists assocs io.encodings.binary inspector accessors +destructors ; +IN: io.ports + +SYMBOL: default-buffer-size +64 1024 * default-buffer-size set-global + +TUPLE: port handle timeout disposed ; + +M: port timeout timeout>> ; + +M: port set-timeout (>>timeout) ; + +: ( handle class -- port ) + new swap >>handle ; inline + +TUPLE: buffered-port < port buffer ; + +: ( handle class -- port ) + + default-buffer-size get >>buffer ; inline + +TUPLE: input-port < buffered-port ; + +: ( handle -- input-port ) + input-port ; + +HOOK: (wait-to-read) io-backend ( port -- ) + +: wait-to-read ( port -- eof? ) + dup buffer>> buffer-empty? [ + dup (wait-to-read) buffer>> buffer-empty? + ] [ drop f ] if ; + +M: input-port stream-read1 + dup check-disposed + dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; + +: read-step ( count port -- byte-array/f ) + dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ; + +M: input-port stream-read-partial ( max stream -- byte-array/f ) + dup check-disposed + >r 0 max >integer r> read-step ; + +: read-loop ( count port accum -- ) + pick over length - dup 0 > [ + pick read-step dup [ + over push-all read-loop + ] [ + 2drop 2drop + ] if + ] [ + 2drop 2drop + ] if ; + +M: input-port stream-read + dup check-disposed + >r 0 max >fixnum r> + 2dup read-step dup [ + pick over length > [ + pick + [ push-all ] keep + [ read-loop ] keep + B{ } like + ] [ 2nip ] if + ] [ 2nip ] if ; + +TUPLE: output-port < buffered-port ; + +: ( handle -- output-port ) + output-port ; + +: can-write? ( len buffer -- ? ) + [ buffer-fill + ] keep buffer-capacity <= ; + +: wait-to-write ( len port -- ) + tuck buffer>> can-write? [ drop ] [ stream-flush ] if ; + +M: output-port stream-write1 + dup check-disposed + 1 over wait-to-write + buffer>> byte>buffer ; + +M: output-port stream-write + dup check-disposed + over length over buffer>> buffer-size > [ + [ buffer>> buffer-size ] + [ [ stream-write ] curry ] bi + each + ] [ + [ >r length r> wait-to-write ] + [ buffer>> >buffer ] 2bi + ] if ; + +HOOK: (wait-to-write) io-backend ( port -- ) + +: port-flush ( port -- ) + dup buffer>> buffer-empty? + [ drop ] [ dup (wait-to-write) port-flush ] if ; + +M: output-port stream-flush ( port -- ) + [ check-disposed ] [ port-flush ] bi ; + +M: output-port dispose* + [ port-flush ] [ call-next-method ] bi ; + +M: buffered-port dispose* + [ call-next-method ] + [ [ [ buffer-free ] when* f ] change-buffer drop ] + bi ; + +HOOK: cancel-io io-backend ( port -- ) + +M: port timed-out cancel-io ; + +M: port dispose* [ cancel-io ] [ handle>> dispose ] bi ; + +: ( read-handle write-handle -- input-port output-port ) + [ + [ |dispose ] + [ |dispose ] bi* + ] with-destructors ; diff --git a/extra/io/nonblocking/summary.txt b/extra/io/ports/summary.txt similarity index 100% rename from extra/io/nonblocking/summary.txt rename to extra/io/ports/summary.txt diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index e1297a9839..86cfe35bc1 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,7 @@ IN: io.server.tests -USING: tools.test io.server io.server.private ; +USING: tools.test io.server io.server.private kernel ; { 2 0 } [ [ ] server-loop ] must-infer-as +{ 2 0 } [ [ ] with-connection ] must-infer-as +{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as +{ 2 0 } [ [ ] with-datagrams ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 1d626a9e15..359b9c6fb4 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,33 +1,36 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.files io.streams.duplex logging -continuations kernel math math.parser namespaces parser -sequences strings prettyprint debugger quotations calendar -threads concurrency.combinators assocs ; +USING: io io.sockets io.sockets.secure io.files +io.streams.duplex logging continuations destructors kernel math +math.parser namespaces parser sequences strings prettyprint +debugger quotations calendar threads concurrency.combinators +assocs fry ; IN: io.server SYMBOL: servers +SYMBOL: remote-address + r accept r> [ with-client ] 3curry "Client" spawn drop + >r accept r> '[ , , , with-connection ] "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec encoding quot -- ) >r dup servers get push r> - [ accept-loop ] curry with-disposal ; inline + '[ , accept-loop ] with-disposal ; inline \ server-loop NOTICE add-error-logging @@ -39,11 +42,12 @@ PRIVATE> : internet-server ( port -- seq ) f swap t resolve-host ; +: secure-server ( port -- seq ) + internet-server [ ] map ; + : with-server ( seq service encoding quot -- ) V{ } clone servers [ - [ - [ server-loop ] 2curry with-logging - ] 3curry parallel-each + '[ , [ , , server-loop ] with-logging ] parallel-each ] with-variable ; inline : stop-server ( -- ) @@ -56,7 +60,7 @@ LOG: received-datagram NOTICE : datagram-loop ( quot datagram -- ) [ [ receive dup received-datagram >r swap call r> ] keep - pick [ send ] [ 3drop ] keep + pick [ send ] [ 3drop ] if ] 2keep datagram-loop ; inline : spawn-datagrams ( quot addrspec -- ) @@ -67,6 +71,4 @@ LOG: received-datagram NOTICE PRIVATE> : with-datagrams ( seq service quot -- ) - [ - [ swap spawn-datagrams ] curry parallel-each - ] curry with-logging ; inline + '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/sockets/headers/headers.factor b/extra/io/sockets/headers/headers.factor index 2547fee5ae..7ae9265220 100755 --- a/extra/io/sockets/headers/headers.factor +++ b/extra/io/sockets/headers/headers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax byte-arrays io -io.sockets.impl kernel structs math math.parser +io.sockets kernel structs math math.parser prettyprint sequences ; IN: io.sockets.headers diff --git a/extra/io/sockets/impl/authors.txt b/extra/io/sockets/impl/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/io/sockets/impl/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/io/sockets/impl/impl-tests.factor b/extra/io/sockets/impl/impl-tests.factor deleted file mode 100644 index 6b930a994e..0000000000 --- a/extra/io/sockets/impl/impl-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: io.sockets.impl io.sockets kernel tools.test ; -IN: io.sockets.impl.tests - -[ B{ 1 2 3 4 } ] -[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test - -[ "1.2.3.4" ] -[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test - -[ "255.255.255.255" ] -[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test - -[ B{ 255 255 255 255 } ] -[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test - -[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ] -[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test - -[ "1:2:3:4:5:6:7:8" ] -[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test - -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] -[ "::" T{ inet6 } inet-pton ] unit-test - -[ "0:0:0:0:0:0:0:0" ] -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] -[ "1::" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ] -[ "::1" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ] -[ "1::2" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ] -[ "1::2:3" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ] -[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test - -[ "1:2:0:0:0:0:3:4" ] -[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test - diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor deleted file mode 100755 index fa82080259..0000000000 --- a/extra/io/sockets/impl/impl.factor +++ /dev/null @@ -1,134 +0,0 @@ -! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays io.backend io.binary io.sockets -io.encodings.ascii kernel math math.parser sequences splitting -system alien.c-types alien.strings alien combinators namespaces -parser ; -IN: io.sockets.impl - -<< { - { [ os windows? ] [ "windows.winsock" ] } - { [ os unix? ] [ "unix" ] } -} cond use+ >> - -GENERIC: protocol-family ( addrspec -- af ) - -GENERIC: sockaddr-type ( addrspec -- type ) - -GENERIC: make-sockaddr ( addrspec -- sockaddr ) - -: make-sockaddr/size ( addrspec -- sockaddr size ) - dup make-sockaddr swap sockaddr-type heap-size ; - -GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) - -HOOK: addrinfo-error io-backend ( n -- ) - -! IPV4 and IPV6 -GENERIC: address-size ( addrspec -- n ) - -GENERIC: inet-ntop ( data addrspec -- str ) - -GENERIC: inet-pton ( str addrspec -- data ) - - -M: inet4 inet-ntop ( data addrspec -- str ) - drop 4 memory>byte-array [ number>string ] { } map-as "." join ; - -M: inet4 inet-pton ( str addrspec -- data ) - drop "." split [ string>number ] B{ } map-as ; - -M: inet4 address-size drop 4 ; - -M: inet4 protocol-family drop PF_INET ; - -M: inet4 sockaddr-type drop "sockaddr-in" c-type ; - -M: inet4 make-sockaddr ( inet -- sockaddr ) - "sockaddr-in" - AF_INET over set-sockaddr-in-family - over inet4-port htons over set-sockaddr-in-port - over inet4-host - "0.0.0.0" or - rot inet-pton *uint over set-sockaddr-in-addr ; - -SYMBOL: port-override - -: (port) port-override get swap or ; - -M: inet4 parse-sockaddr - >r dup sockaddr-in-addr r> inet-ntop - swap sockaddr-in-port ntohs (port) ; - -M: inet6 inet-ntop ( data addrspec -- str ) - drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; - -M: inet6 inet-pton ( str addrspec -- data ) - drop "::" split1 - [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@ - 2dup [ length ] bi@ + 8 swap - 0 swap 3append - [ 2 >be ] map concat >byte-array ; - -M: inet6 address-size drop 16 ; - -M: inet6 protocol-family drop PF_INET6 ; - -M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; - -M: inet6 make-sockaddr ( inet -- sockaddr ) - "sockaddr-in6" - AF_INET6 over set-sockaddr-in6-family - over inet6-port htons over set-sockaddr-in6-port - over inet6-host "::" or - rot inet-pton over set-sockaddr-in6-addr ; - -M: inet6 parse-sockaddr - >r dup sockaddr-in6-addr r> inet-ntop - swap sockaddr-in6-port ntohs (port) ; - -: addrspec-of-family ( af -- addrspec ) - { - { [ dup AF_INET = ] [ T{ inet4 } ] } - { [ dup AF_INET6 = ] [ T{ inet6 } ] } - { [ dup AF_UNIX = ] [ T{ local } ] } - [ f ] - } cond nip ; - -M: f parse-sockaddr nip ; - -: addrinfo>addrspec ( addrinfo -- addrspec ) - [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi - parse-sockaddr ; - -: parse-addrinfo-list ( addrinfo -- seq ) - [ addrinfo-next ] follow - [ addrinfo>addrspec ] map - [ ] filter ; - -: prepare-resolve-host ( host serv passive? -- host' serv' flags ) - #! If the port is a number, we resolve for 'http' then - #! change it later. This is a workaround for a FreeBSD - #! getaddrinfo() limitation -- on Windows, Linux and Mac, - #! we can convert a number to a string and pass that as the - #! service name, but on FreeBSD this gives us an unknown - #! service error. - >r - dup integer? [ port-override set "http" ] when - r> AI_PASSIVE 0 ? ; - -M: object resolve-host ( host serv passive? -- seq ) - [ - prepare-resolve-host - "addrinfo" - [ set-addrinfo-flags ] keep - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo - ] with-scope ; - -M: object host-name ( -- name ) - 256 dup dup length gethostname - zero? [ "gethostname failed" throw ] unless - ascii alien>string ; diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor new file mode 100644 index 0000000000..9b9436a8db --- /dev/null +++ b/extra/io/sockets/secure/secure-tests.factor @@ -0,0 +1 @@ +! No unit tests here, until Windows SSL is implemented diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor new file mode 100644 index 0000000000..22265b9069 --- /dev/null +++ b/extra/io/sockets/secure/secure.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel symbols namespaces continuations +destructors io.sockets sequences inspector ; +IN: io.sockets.secure + +SYMBOL: secure-socket-backend + +SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ; + +TUPLE: secure-config +method +key-file password +ca-file ca-path +dh-file +ephemeral-key-bits ; + +: ( -- config ) + secure-config new + SSLv23 >>method + 512 >>ephemeral-key-bits ; + +TUPLE: secure-context config handle disposed ; + +HOOK: secure-socket-backend ( config -- context ) + +: with-secure-context ( config quot -- ) + [ + [ ] [ [ secure-context set ] prepose ] bi* + with-disposal + ] with-scope ; inline + +TUPLE: secure addrspec ; + +C: secure + +: resolve-secure-host ( host port passive? -- seq ) + resolve-host [ ] map ; + +HOOK: check-certificate secure-socket-backend ( host handle -- ) + +> inet? ; + +M: secure-inet (client) + [ + addrspec>> + [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep + host>> pick handle>> check-certificate + ] with-destructors ; + +PRIVATE> + +ERROR: premature-close ; + +M: premature-close summary + drop "Connection closed prematurely - potential truncation attack" ; + +ERROR: certificate-verify-error result ; + +M: certificate-verify-error summary + drop "Certificate verification failed" ; + +ERROR: common-name-verify-error expected got ; + +M: common-name-verify-error summary + drop "Common name verification failed" ; diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index ee3cb3aa7b..e7d68d6111 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.backend threads -strings byte-arrays continuations ; +strings byte-arrays continuations destructors quotations ; IN: io.sockets ARTICLE: "network-addressing" "Address specifiers" @@ -37,7 +37,7 @@ ARTICLE: "network-packet" "Packet-oriented networking" { $subsection receive } "Packet-oriented sockets are closed by calling " { $link dispose } "." $nl -"Address specifiers have the following interpretation with connection-oriented networking words:" +"Address specifiers have the following interpretation with packet-oriented networking words:" { $list { { $link local } " - Unix domain datagram sockets on Unix systems" } { { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" } @@ -64,7 +64,7 @@ HELP: local } ; HELP: inet -{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet-host } " and " { $link inet-port } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link } "." } { $notes "This address specifier is only supported by " { $link } ", which calls " { $link resolve-host } " to obtain a list of IP addresses associated with the host name, and attempts a connection to each one in turn until one succeeds. Other network words do not accept this address specifier, and " { $link resolve-host } " must be called directly; it is then up to the application to pick the correct address from the (possibly several) addresses associated to the host name." } @@ -74,7 +74,7 @@ HELP: inet } ; HELP: inet4 -{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet4-host } " and " { $link inet4-port } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes "New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible." } @@ -83,7 +83,7 @@ HELP: inet4 } ; HELP: inet6 -{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet6-host } " and " { $link inet6-port } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes "New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." } { $examples @@ -91,13 +91,19 @@ HELP: inet6 } ; HELP: -{ $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." } +{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } } +{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding, together with the local address the socket was bound to." } { $errors "Throws an error if the connection cannot be established." } +{ $notes "The " { $link with-client } " word is easier to use in most situations." } { $examples { $code "\"www.apple.com\" \"http\" utf8 " } } ; +HELP: with-client +{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "quot" quotation } } +{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." } +{ $errors "Throws an error if the connection cannot be established." } ; + HELP: { $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $description @@ -113,11 +119,18 @@ HELP: "To start a server which listens for connections 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 server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this." + $nl + "To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:" + { $unchecked-example + "f 0 ascii " + "[ addr>> . ] [ dispose ] bi" + "T{ inet4 f \"0.0.0.0\" 58901 }" + } } { $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ; HELP: accept -{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } } +{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "remote" "an address specifier" } } { $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." } { $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor old mode 100644 new mode 100755 index 1810b8587b..8264bec032 --- a/extra/io/sockets/sockets-tests.factor +++ b/extra/io/sockets/sockets-tests.factor @@ -1,4 +1,92 @@ IN: io.sockets.tests -USING: io.sockets sequences math tools.test ; +USING: io.sockets sequences math tools.test namespaces accessors +kernel destructors calendar io.timeouts io.encodings.utf8 io +concurrency.promises threads io.streams.string ; + +[ B{ 1 2 3 4 } ] +[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test + +[ "1.2.3.4" ] +[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test + +[ "255.255.255.255" ] +[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test + +[ B{ 255 255 255 255 } ] +[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test + +[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ] +[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test + +[ "1:2:3:4:5:6:7:8" ] +[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test + +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] +[ "::" T{ inet6 } inet-pton ] unit-test + +[ "0:0:0:0:0:0:0:0" ] +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] +[ "1::" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ] +[ "::1" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ] +[ "1::2" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ] +[ "1::2:3" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ] +[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test + +[ "1:2:0:0:0:0:3:4" ] +[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test [ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test + +! Smoke-test UDP +[ ] [ "127.0.0.1" 0 "datagram1" set ] unit-test +[ ] [ "datagram1" get addr>> "addr1" set ] unit-test +[ f ] [ "addr1" get port>> 0 = ] unit-test + +[ ] [ "127.0.0.1" 0 "datagram2" set ] unit-test +[ ] [ "datagram2" get addr>> "addr2" set ] unit-test +[ f ] [ "addr2" get port>> 0 = ] unit-test + +[ ] [ B{ 1 2 3 4 } "addr2" get "datagram1" get send ] unit-test +[ B{ 1 2 3 4 } ] [ "datagram2" get receive "from" set ] unit-test +[ ] [ B{ 4 3 2 1 } "from" get "datagram2" get send ] unit-test +[ B{ 4 3 2 1 } t ] [ "datagram1" get receive "addr2" get = ] unit-test + +[ ] [ "datagram1" get dispose ] unit-test +[ ] [ "datagram2" get dispose ] unit-test + +! Test timeouts +[ ] [ "127.0.0.1" 0 "datagram3" set ] unit-test + +[ ] [ 1 seconds "datagram3" get set-timeout ] unit-test +[ "datagram3" get receive ] must-fail + +! See what happens if other end is closed +[ ] [ "port" set ] unit-test + +[ ] [ + [ + "127.0.0.1" 0 utf8 + dup addr>> "port" get fulfill + [ + accept drop + dup stream-readln drop + "hello" swap stream-copy + ] with-disposal + ] "Socket close test" spawn drop +] unit-test + +[ "hello" f ] [ + "port" get ?promise utf8 [ + "hi\n" write flush readln readln + ] with-client +] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index f835f0beb2..93185f50f6 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -1,10 +1,39 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman, +! Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: generic kernel io.backend namespaces continuations -sequences arrays io.encodings io.nonblocking io.streams.duplex -accessors ; +sequences arrays io.encodings io.ports io.streams.duplex +io.encodings.ascii alien.strings io.binary accessors destructors +classes debugger byte-arrays system combinators parser +alien.c-types math.parser splitting math assocs inspector ; IN: io.sockets +<< { + { [ os windows? ] [ "windows.winsock" ] } + { [ os unix? ] [ "unix" ] } +} cond use+ >> + +! Addressing +GENERIC: protocol-family ( addrspec -- af ) + +GENERIC: sockaddr-type ( addrspec -- type ) + +GENERIC: make-sockaddr ( addrspec -- sockaddr ) + +GENERIC: address-size ( addrspec -- n ) + +GENERIC: inet-ntop ( data addrspec -- str ) + +GENERIC: inet-pton ( str addrspec -- data ) + +: make-sockaddr/size ( addrspec -- sockaddr size ) + [ make-sockaddr ] [ sockaddr-type heap-size ] bi ; + +: empty-sockaddr/size ( addrspec -- sockaddr size ) + sockaddr-type [ ] [ heap-size ] bi ; + +GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) + TUPLE: local path ; : ( path -- addrspec ) @@ -14,49 +43,257 @@ TUPLE: inet4 host port ; C: inet4 +M: inet4 inet-ntop ( data addrspec -- str ) + drop 4 memory>byte-array [ number>string ] { } map-as "." join ; + +ERROR: invalid-inet4 string reason ; + +M: invalid-inet4 summary drop "Invalid IPv4 address" ; + +M: inet4 inet-pton ( str addrspec -- data ) + drop + [ + "." split dup length 4 = [ + "Must have four components" throw + ] unless + [ + string>number + [ "Dotted component not a number" throw ] unless* + ] B{ } map-as + ] [ invalid-inet4 ] recover ; + +M: inet4 address-size drop 4 ; + +M: inet4 protocol-family drop PF_INET ; + +M: inet4 sockaddr-type drop "sockaddr-in" c-type ; + +M: inet4 make-sockaddr ( inet -- sockaddr ) + "sockaddr-in" + AF_INET over set-sockaddr-in-family + over inet4-port htons over set-sockaddr-in-port + over inet4-host + "0.0.0.0" or + rot inet-pton *uint over set-sockaddr-in-addr ; + + + +M: inet4 parse-sockaddr + >r dup sockaddr-in-addr r> inet-ntop + swap sockaddr-in-port ntohs (port) ; + TUPLE: inet6 host port ; C: inet6 +M: inet6 inet-ntop ( data addrspec -- str ) + drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; + +ERROR: invalid-inet6 string reason ; + +M: invalid-inet6 summary drop "Invalid IPv6 address" ; + + [ "Component not a number" throw ] unless* + ] B{ } map-as + ] if ; + +: pad-inet6 ( string1 string2 -- seq ) + 2dup [ length ] bi@ + 8 swap - + dup 0 < [ "More than 8 components" throw ] when + swap 3append ; + +: inet6-bytes ( seq -- bytes ) + [ 2 >be ] { } map-as concat >byte-array ; + +PRIVATE> + +M: inet6 inet-pton ( str addrspec -- data ) + drop + [ + "::" split1 [ parse-inet6 ] bi@ pad-inet6 inet6-bytes + ] [ invalid-inet6 ] recover ; + +M: inet6 address-size drop 16 ; + +M: inet6 protocol-family drop PF_INET6 ; + +M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; + +M: inet6 make-sockaddr ( inet -- sockaddr ) + "sockaddr-in6" + AF_INET6 over set-sockaddr-in6-family + over inet6-port htons over set-sockaddr-in6-port + over inet6-host "::" or + rot inet-pton over set-sockaddr-in6-addr ; + +M: inet6 parse-sockaddr + >r dup sockaddr-in6-addr r> inet-ntop + swap sockaddr-in6-port ntohs (port) ; + +: addrspec-of-family ( af -- addrspec ) + { + { AF_INET [ T{ inet4 } ] } + { AF_INET6 [ T{ inet6 } ] } + { AF_UNIX [ T{ local } ] } + [ drop f ] + } case ; + +M: f parse-sockaddr nip ; + +GENERIC: (get-local-address) ( handle remote -- sockaddr ) + +: get-local-address ( handle remote -- local ) + [ (get-local-address) ] keep parse-sockaddr ; + +GENERIC: (get-remote-address) ( handle remote -- sockaddr ) + +: get-remote-address ( handle local -- remote ) + [ (get-remote-address) ] keep parse-sockaddr ; + +GENERIC: establish-connection ( client-out remote -- ) + +GENERIC: ((client)) ( remote -- handle ) + +GENERIC: (client) ( remote -- client-in client-out local ) + +M: array (client) [ (client) 3array ] attempt-all first3 ; + +M: object (client) ( remote -- client-in client-out local ) + [ + [ ((client)) ] keep + [ + >r dup [ |dispose ] bi@ dup r> + establish-connection + ] + [ get-local-address ] + 2bi + ] with-destructors ; + +: ( remote encoding -- stream local ) + >r (client) -rot r> swap ; + +SYMBOL: local-address + +: with-client ( remote encoding quot -- ) + >r [ local-address set ] curry + r> compose with-stream ; inline + +TUPLE: server-port < port addr encoding ; + +: check-server-port ( port -- port ) + dup check-disposed + dup server-port? [ "Not a server port" throw ] unless ; inline + +GENERIC: (server) ( addrspec -- handle ) + +: ( addrspec encoding -- server ) + >r + [ (server) ] keep + [ drop server-port ] [ get-local-address ] 2bi + >>addr r> >>encoding ; + +GENERIC: (accept) ( server addrspec -- handle sockaddr ) + +: accept ( server -- client remote ) + [ + dup addr>> + [ (accept) ] keep + parse-sockaddr swap + dup + ] keep encoding>> swap ; + +TUPLE: datagram-port < port addr ; + +HOOK: (datagram) io-backend ( addr -- datagram ) + +: ( addrspec -- datagram ) + [ + [ (datagram) |dispose ] keep + [ drop datagram-port ] [ get-local-address ] 2bi + >>addr + ] with-destructors ; + +: check-datagram-port ( port -- port ) + dup check-disposed + dup datagram-port? [ "Not a datagram port" throw ] unless ; inline + +HOOK: (receive) io-backend ( datagram -- packet addrspec ) + +: receive ( datagram -- packet addrspec ) + check-datagram-port + [ (receive) ] [ addr>> ] bi parse-sockaddr ; + +: check-datagram-send ( packet addrspec port -- packet addrspec port ) + check-datagram-port + 2dup addr>> [ class ] bi@ assert= + pick class byte-array assert= ; + +HOOK: (send) io-backend ( packet addrspec datagram -- ) + +: send ( packet addrspec datagram -- ) + check-datagram-send (send) ; + +: addrinfo>addrspec ( addrinfo -- addrspec ) + [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi + parse-sockaddr ; + +: parse-addrinfo-list ( addrinfo -- seq ) + [ addrinfo-next ] follow + [ addrinfo>addrspec ] map + sift ; + +: prepare-resolve-host ( host serv passive? -- host' serv' flags ) + #! If the port is a number, we resolve for 'http' then + #! change it later. This is a workaround for a FreeBSD + #! getaddrinfo() limitation -- on Windows, Linux and Mac, + #! we can convert a number to a string and pass that as the + #! service name, but on FreeBSD this gives us an unknown + #! service error. + >r + dup integer? [ port-override set "http" ] when + r> AI_PASSIVE 0 ? ; + +HOOK: addrinfo-error io-backend ( n -- ) + +: resolve-host ( host serv passive? -- seq ) + [ + prepare-resolve-host + "addrinfo" + [ set-addrinfo-flags ] keep + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol + f [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep + freeaddrinfo + ] with-scope ; + +: host-name ( -- string ) + 256 dup dup length gethostname + zero? [ "gethostname failed" throw ] unless + ascii alien>string ; + TUPLE: inet host port ; C: inet -HOOK: ((client)) io-backend ( addrspec -- client-in client-out ) - -GENERIC: (client) ( addrspec -- client-in client-out ) -M: array (client) [ ((client)) 2array ] attempt-all first2 ; -M: object (client) ((client)) ; - -: ( addrspec encoding -- stream ) - >r (client) r> ; - -: with-client ( addrspec encoding quot -- ) - >r r> with-stream ; inline - -HOOK: (server) io-backend ( addrspec -- handle ) - -: ( addrspec encoding -- server ) - >r [ (server) ] keep r> ; - -HOOK: (accept) io-backend ( server -- addrspec handle ) - -: accept ( server -- client addrspec ) - [ (accept) dup ] [ encoding>> ] bi - swap ; - -HOOK: io-backend ( addrspec -- datagram ) - -HOOK: receive io-backend ( datagram -- packet addrspec ) - -HOOK: send io-backend ( packet addrspec datagram -- ) - -HOOK: resolve-host io-backend ( host serv passive? -- seq ) - -HOOK: host-name io-backend ( -- string ) - M: inet (client) - [ host>> ] [ port>> ] bi f resolve-host - [ empty? [ "Host name lookup failed" throw ] when ] - [ (client) ] - bi ; + [ host>> ] [ port>> ] bi f resolve-host (client) ; + +ERROR: invalid-inet-server addrspec ; + +M: invalid-inet-server summary + drop "Cannot use with ; use or instead" ; + +M: inet (server) + invalid-inet-server ; diff --git a/extra/io/streams/duplex/duplex-docs.factor b/extra/io/streams/duplex/duplex-docs.factor index 15d401ad68..ca4f424fb6 100755 --- a/extra/io/streams/duplex/duplex-docs.factor +++ b/extra/io/streams/duplex/duplex-docs.factor @@ -18,9 +18,6 @@ HELP: { $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } } { $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ; -HELP: stream-closed-twice -{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ; - HELP: with-stream { $values { "stream" duplex-stream } { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ; diff --git a/extra/io/streams/duplex/duplex-tests.factor b/extra/io/streams/duplex/duplex-tests.factor index 9377256c0d..860702c563 100755 --- a/extra/io/streams/duplex/duplex-tests.factor +++ b/extra/io/streams/duplex/duplex-tests.factor @@ -1,18 +1,13 @@ USING: io.streams.duplex io io.streams.string -kernel continuations tools.test ; +kernel continuations tools.test destructors accessors ; IN: io.streams.duplex.tests ! Test duplex stream close behavior -TUPLE: closing-stream closed? ; +TUPLE: closing-stream < disposable ; : closing-stream new ; -M: closing-stream dispose - dup closing-stream-closed? [ - "Closing twice!" throw - ] [ - t swap set-closing-stream-closed? - ] if ; +M: closing-stream dispose* drop ; TUPLE: unclosable-stream ; @@ -30,14 +25,14 @@ M: unclosable-stream dispose [ [ dup dispose ] [ 2drop ] recover - ] keep closing-stream-closed? + ] keep disposed>> ] unit-test [ t ] [ [ [ dup dispose ] [ 2drop ] recover - ] keep closing-stream-closed? + ] keep disposed>> ] unit-test [ "Hey" ] [ diff --git a/extra/io/streams/duplex/duplex.factor b/extra/io/streams/duplex/duplex.factor index 6ac663f9f2..02d7ab61be 100755 --- a/extra/io/streams/duplex/duplex.factor +++ b/extra/io/streams/duplex/duplex.factor @@ -1,50 +1,33 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations io io.encodings io.encodings.private -io.timeouts debugger inspector listener accessors delegate -delegate.protocols ; +USING: kernel continuations destructors io io.encodings +io.encodings.private io.timeouts debugger inspector listener +accessors delegate delegate.protocols ; IN: io.streams.duplex ! We ensure that the stream can only be closed once, to preserve ! integrity of duplex I/O ports. -TUPLE: duplex-stream in out closed ; +TUPLE: duplex-stream in out ; -: ( in out -- stream ) - f duplex-stream boa ; +C: duplex-stream -ERROR: stream-closed-twice ; +CONSULT: input-stream-protocol duplex-stream in>> ; -M: stream-closed-twice summary - drop "Attempt to perform I/O on closed stream" ; - -> [ stream-closed-twice ] when ; inline - -: in ( duplex -- stream ) check-closed in>> ; - -: out ( duplex -- stream ) check-closed out>> ; - -PRIVATE> - -CONSULT: input-stream-protocol duplex-stream in ; - -CONSULT: output-stream-protocol duplex-stream out ; +CONSULT: output-stream-protocol duplex-stream out>> ; M: duplex-stream set-timeout - [ in set-timeout ] [ out set-timeout ] 2bi ; + [ in>> set-timeout ] [ out>> set-timeout ] 2bi ; M: duplex-stream dispose #! The output stream is closed first, in case both streams #! are attached to the same file descriptor, the output #! buffer needs to be flushed before we close the fd. - dup closed>> [ - t >>closed - [ dup out>> dispose ] - [ dup in>> dispose ] [ ] cleanup - ] unless drop ; + [ + [ in>> &dispose drop ] + [ out>> &dispose drop ] + bi + ] with-destructors ; : ( stream-in stream-out encoding -- duplex ) tuck re-encode >r re-decode r> ; diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor index 384a3806b8..191c8dce91 100755 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.null -USING: kernel io io.timeouts io.streams.duplex continuations ; +USING: kernel io io.timeouts io.streams.duplex destructors ; TUPLE: null-stream ; diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index f9ffd5e98f..816bfd1b19 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -4,7 +4,6 @@ USING: kernel calendar alarms io io.encodings accessors namespaces ; IN: io.timeouts -! Won't need this with new slot accessors GENERIC: timeout ( obj -- dt/f ) GENERIC: set-timeout ( dt/f obj -- ) @@ -14,8 +13,6 @@ M: encoder set-timeout stream>> set-timeout ; GENERIC: timed-out ( obj -- ) -M: object timed-out drop ; - : queue-timeout ( obj timeout -- alarm ) >r [ timed-out ] curry r> later ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor old mode 100644 new mode 100755 index 902af8fe0d..8f5b6c7540 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,65 +1,99 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! 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.ffi unix +io.ports sequences strings structs sbufs threads unix vectors io.buffers io.backend io.encodings math.parser continuations system libc qualified namespaces io.timeouts -io.encodings.utf8 accessors ; +io.encodings.utf8 destructors accessors inspector combinators ; QUALIFIED: io IN: io.unix.backend ! I/O tasks -TUPLE: io-task port callbacks ; +GENERIC: handle-fd ( handle -- fd ) -: io-task-fd port>> handle>> ; +TUPLE: fd fd disposed ; -: ( port continuation/f class -- task ) - new - swap [ 1vector ] [ V{ } clone ] if* >>callbacks - swap >>port ; inline +: ( n -- fd ) + #! We drop the error code rather than calling io-error, + #! since on OS X 10.3, this operation fails from init-io + #! when running the Factor.app (presumably because fd 0 and + #! 1 are closed). + [ F_SETFL O_NONBLOCK fcntl drop ] + [ F_SETFD FD_CLOEXEC fcntl drop ] + [ f fd boa ] + tri ; -TUPLE: input-task < io-task ; +M: fd dispose* fd>> close-file ; -TUPLE: output-task < io-task ; - -GENERIC: do-io-task ( task -- ? ) -GENERIC: io-task-container ( mx task -- hashtable ) +M: fd handle-fd fd>> ; ! I/O multiplexers TUPLE: mx fd reads writes ; -M: input-task io-task-container drop reads>> ; - -M: output-task io-task-container drop writes>> ; - : new-mx ( class -- obj ) new H{ } clone >>reads H{ } clone >>writes ; inline -GENERIC: register-io-task ( task mx -- ) -GENERIC: unregister-io-task ( task mx -- ) +GENERIC: add-input-callback ( thread fd mx -- ) + +: add-callback ( thread fd assoc -- ) + [ ?push ] change-at ; + +M: mx add-input-callback reads>> add-callback ; + +GENERIC: add-output-callback ( thread fd mx -- ) + +M: mx add-output-callback writes>> add-callback ; + +GENERIC: remove-input-callbacks ( fd mx -- callbacks ) + +M: mx remove-input-callbacks reads>> delete-at* drop ; + +GENERIC: remove-output-callbacks ( fd mx -- callbacks ) + +M: mx remove-output-callbacks writes>> delete-at* drop ; + GENERIC: wait-for-events ( ms mx -- ) -: fd/container ( task mx -- task fd container ) - over io-task-container >r dup io-task-fd r> ; inline +: input-available ( fd mx -- ) + remove-input-callbacks [ resume ] each ; -: check-io-task ( task mx -- ) - fd/container key? nip [ - "Cannot perform multiple reads from the same port" throw - ] when ; +: output-available ( fd mx -- ) + remove-output-callbacks [ resume ] each ; -M: mx register-io-task ( task mx -- ) - 2dup check-io-task fd/container set-at ; +M: unix cancel-io ( port -- ) + handle>> handle-fd mx get-global + [ remove-input-callbacks [ t swap resume-with ] each ] + [ remove-output-callbacks [ t swap resume-with ] each ] + 2bi ; -: add-io-task ( task -- ) - mx get-global register-io-task ; +SYMBOL: +retry+ ! just try the operation again without blocking +SYMBOL: +input+ +SYMBOL: +output+ -: with-port-continuation ( port quot -- port ) - [ "I/O" suspend drop ] curry with-timeout ; inline +: wait-for-fd ( handle event -- timeout? ) + dup +retry+ eq? [ 2drop f ] [ + [ + >r + swap handle-fd + mx get-global + r> { + { +input+ [ add-input-callback ] } + { +output+ [ add-output-callback ] } + } case + ] curry "I/O" suspend nip + ] if ; -M: mx unregister-io-task ( task mx -- ) - fd/container delete-at drop ; +ERROR: io-timeout ; + +M: io-timeout summary drop "I/O operation timed out" ; + +: wait-for-port ( port event -- ) + [ + >r handle>> r> wait-for-fd + [ io-timeout ] when + ] curry with-timeout ; ! Some general stuff : file-mode OCT: 0666 ; @@ -73,122 +107,54 @@ M: mx unregister-io-task ( task mx -- ) : io-error ( n -- ) 0 < [ (io-error) ] when ; -M: integer init-handle ( fd -- ) - #! We drop the error code rather than calling io-error, - #! since on OS X 10.3, this operation fails from init-io - #! when running the Factor.app (presumably because fd 0 and - #! 1 are closed). - [ F_SETFL O_NONBLOCK fcntl drop ] - [ F_SETFD FD_CLOEXEC fcntl drop ] bi ; - -M: integer close-handle ( fd -- ) - close ; - -: report-error ( error port -- ) - [ "Error on fd " % dup handle>> # ": " % swap % ] "" make - >>error drop ; - -: ignorable-error? ( n -- ? ) - [ EAGAIN number= ] [ EINTR number= ] bi or ; - -: defer-error ( port -- ? ) - #! Return t if it is an unrecoverable error. - err_no dup ignorable-error? - [ 2drop f ] [ strerror swap report-error t ] if ; - -: pop-callbacks ( mx task -- ) - dup rot unregister-io-task - io-task-callbacks [ resume ] each ; - -: handle-io-task ( mx task -- ) - dup do-io-task [ pop-callbacks ] [ 2drop ] if ; - -: handle-timeout ( port mx assoc -- ) - >r swap port-handle r> delete-at* [ - "I/O operation cancelled" over port>> report-error - pop-callbacks - ] [ - 2drop - ] if ; - -: cancel-io-tasks ( port mx -- ) - [ dup reads>> handle-timeout ] - [ dup writes>> handle-timeout ] 2bi ; - -M: unix cancel-io ( port -- ) - mx get-global cancel-io-tasks ; - ! Readers -: reader-eof ( reader -- ) - dup buffer>> buffer-empty? [ t >>eof ] when drop ; - : (refill) ( port -- n ) [ handle>> ] [ buffer>> buffer-end ] [ buffer>> buffer-capacity ] tri read ; -: refill ( port -- ? ) - #! Return f if there is a recoverable error - dup buffer>> buffer-empty? [ - dup (refill) dup 0 >= [ - swap buffer>> n>buffer t - ] [ - drop defer-error - ] if - ] [ - drop t - ] if ; +! Returns an event to wait for which will ensure completion of +! this request +GENERIC: refill ( port handle -- event/f ) -TUPLE: read-task < input-task ; +M: fd refill + fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read + { + { [ dup 0 >= ] [ swap buffer>> n>buffer f ] } + { [ err_no EINTR = ] [ 2drop +retry+ ] } + { [ err_no EAGAIN = ] [ 2drop +input+ ] } + [ (io-error) ] + } cond ; -: ( port continuation -- task ) - read-task ; - -M: read-task do-io-task - io-task-port dup refill - [ [ reader-eof ] [ drop ] if ] keep ; - -M: input-port (wait-to-read) - [ add-io-task ] with-port-continuation - pending-error ; +M: unix (wait-to-read) ( port -- ) + dup dup handle>> refill dup + [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; ! Writers -: write-step ( port -- ? ) - dup - [ handle>> ] - [ buffer>> buffer@ ] - [ buffer>> buffer-length ] tri - write dup 0 >= - [ swap buffer>> buffer-consume f ] - [ drop defer-error ] if ; +GENERIC: drain ( port handle -- event/f ) -TUPLE: write-task < output-task ; +M: fd drain + fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write + { + { [ dup 0 >= ] [ + over buffer>> buffer-consume + buffer>> buffer-empty? f +output+ ? + ] } + { [ err_no EINTR = ] [ 2drop +retry+ ] } + { [ err_no EAGAIN = ] [ 2drop +output+ ] } + [ (io-error) ] + } cond ; -: ( port continuation -- task ) - write-task ; - -M: write-task do-io-task - io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or - [ 0 swap buffer>> buffer-reset t ] [ write-step ] if ; - -: add-write-io-task ( port continuation -- ) - over handle>> mx get-global writes>> at* - [ io-task-callbacks push drop ] - [ drop add-io-task ] if ; - -: (wait-to-write) ( port -- ) - [ add-write-io-task ] with-port-continuation drop ; - -M: output-port port-flush ( port -- ) - dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; +M: unix (wait-to-write) ( port -- ) + dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ; M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; M: unix (init-stdio) ( -- ) - 0 - 1 - 2 ; + 0 + 1 + 2 ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; @@ -196,16 +162,11 @@ TUPLE: mx-port < port mx ; : ( mx -- port ) dup fd>> mx-port swap >>mx ; -TUPLE: mx-task < io-task ; - -: ( port -- task ) - f mx-task ; - -M: mx-task do-io-task - port>> mx>> 0 swap wait-for-events f ; - : multiplexer-error ( n -- ) - 0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ; + 0 < [ + err_no [ EAGAIN = ] [ EINTR = ] bi or + [ (io-error) ] unless + ] when ; : ?flag ( n mask symbol -- n ) pick rot bitand 0 > [ , ] [ drop ] if ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index d74c355642..c8219a9f63 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -3,16 +3,16 @@ IN: io.unix.bsd USING: namespaces system kernel accessors assocs continuations unix -io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ; +io.backend io.unix.backend io.unix.select io.monitors ; M: bsd init-io ( -- ) - mx set-global - kqueue-mx set-global - kqueue-mx get-global - dup io-task-fd - [ mx get-global reads>> set-at ] - [ mx get-global writes>> set-at ] 2bi ; + mx set-global ; +! kqueue-mx set-global +! kqueue-mx get-global +! dup io-task-fd +! [ mx get-global reads>> set-at ] +! [ mx get-global writes>> set-at ] 2bi ; -M: bsd (monitor) ( path recursive? mailbox -- ) - swap [ "Recursive kqueue monitors not supported" throw ] when - ; +! M: bsd (monitor) ( path recursive? mailbox -- ) +! swap [ "Recursive kqueue monitors not supported" throw ] when +! ; diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index db1e7086e0..406a7fcb50 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.nonblocking io.unix.backend +USING: alien.c-types kernel io.ports io.unix.backend bit-arrays sequences assocs unix unix.linux.epoll math namespaces structs ; IN: io.unix.epoll @@ -43,10 +43,10 @@ M: epoll-mx unregister-io-task ( task mx -- ) r> epoll_wait dup multiplexer-error ; : epoll-read-task ( mx fd -- ) - over mx-reads at* [ handle-io-task ] [ 2drop ] if ; + over mx-reads at* [ perform-io-task ] [ 2drop ] if ; : epoll-write-task ( mx fd -- ) - over mx-writes at* [ handle-io-task ] [ 2drop ] if ; + over mx-writes at* [ perform-io-task ] [ 2drop ] if ; : handle-event ( mx kevent -- ) epoll-event-fd 2dup epoll-read-task epoll-write-task ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 28e08d4bf2..9f554a044b 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,59 +1,58 @@ ! 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 +USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitfields byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system -io.files.private ; +io.files.private destructors ; IN: io.unix.files M: unix cwd ( -- path ) - MAXPATHLEN [ ] [ ] bi getcwd + MAXPATHLEN [ ] keep getcwd [ (io-error) ] unless* ; -M: unix cd ( path -- ) - chdir io-error ; +M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; : read-flags O_RDONLY ; inline -: open-read ( path -- fd ) - O_RDONLY file-mode open dup io-error ; +: open-read ( path -- fd ) O_RDONLY file-mode open-file ; M: unix (file-reader) ( path -- stream ) - open-read ; + open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline : open-write ( path -- fd ) - write-flags file-mode open dup io-error ; + write-flags file-mode open-file ; M: unix (file-writer) ( path -- stream ) - open-write ; + open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline : open-append ( path -- fd ) - append-flags file-mode open dup io-error - [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; + [ + append-flags file-mode open-file |dispose + dup 0 SEEK_END lseek io-error + ] with-destructors ; M: unix (file-appender) ( path -- stream ) - open-append ; + open-append ; : touch-mode ( -- n ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable M: unix touch-file ( path -- ) normalize-path - dup exists? [ f utime ] [ - touch-mode file-mode open close + dup exists? [ touch ] [ + touch-mode file-mode open-file close-file ] if ; M: unix move-file ( from to -- ) [ normalize-path ] bi@ rename io-error ; -M: unix delete-file ( path -- ) - normalize-path unlink io-error ; +M: unix delete-file ( path -- ) normalize-path unlink-file ; M: unix make-directory ( path -- ) normalize-path OCT: 777 mkdir io-error ; @@ -97,15 +96,13 @@ M: unix copy-file ( from to -- ) \ file-info boa ; M: unix file-info ( path -- info ) - normalize-path stat* stat>file-info ; + normalize-path file-status stat>file-info ; M: unix link-info ( path -- info ) - normalize-path lstat* stat>file-info ; + normalize-path link-status stat>file-info ; M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; M: unix read-link ( path -- path' ) - normalize-path - PATH_MAX [ tuck ] [ ] bi readlink - dup io-error head-slice >string ; + normalize-path read-symbolic-link ; \ No newline at end of file diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index 035e6398ee..dca2f51958 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -1,4 +1,4 @@ -USING: kernel io.nonblocking io.unix.backend math.bitfields +USING: kernel io.ports io.unix.backend math.bitfields unix io.files.unique.backend system ; IN: io.unix.files.unique @@ -6,6 +6,6 @@ IN: io.unix.files.unique { O_RDWR O_CREAT O_EXCL } flags ; M: unix (make-unique-file) ( path -- ) - open-unique-flags file-mode open dup io-error close ; + open-unique-flags file-mode open-file close-file ; M: unix temporary-path ( -- path ) "/tmp" ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index ec82a426d3..8888d0182f 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -3,8 +3,8 @@ USING: alien.c-types kernel math math.bitfields namespaces locals accessors combinators threads vectors hashtables sequences assocs continuations sets -unix.ffi unix unix.time unix.kqueue unix.process -io.nonblocking io.unix.backend io.launcher io.unix.launcher +unix unix.time unix.kqueue unix.process +io.ports io.unix.backend io.launcher io.unix.launcher io.monitors ; IN: io.unix.kqueue @@ -57,10 +57,10 @@ M: kqueue-mx unregister-io-task ( task mx -- ) dup multiplexer-error ; :: kevent-read-task ( mx fd kevent -- ) - mx fd mx reads>> at handle-io-task ; + mx fd mx reads>> at perform-io-task ; :: kevent-write-task ( mx fd kevent -- ) - mx fd mx writes>> at handle-io-task ; + mx fd mx writes>> at perform-io-task ; :: kevent-proc-task ( mx pid kevent -- ) pid wait-for-pid diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 177c5775dc..6d1f7f1796 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ IN: io.unix.launcher.tests USING: io.files tools.test io.launcher arrays io namespaces continuations math io.encodings.binary io.encodings.ascii -accessors kernel sequences io.encodings.utf8 ; +accessors kernel sequences io.encodings.utf8 destructors ; [ ] [ [ "launcher-test-1" temp-file delete-file ] ignore-errors @@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ; ] times "append-test" temp-file utf8 file-contents ] unit-test + +[ ] [ "ls" utf8 contents drop ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 043b2bd73e..3b9c8fc7af 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -3,7 +3,7 @@ USING: kernel namespaces math system sequences debugger continuations arrays assocs combinators alien.c-types strings threads accessors -io io.backend io.launcher io.nonblocking io.files +io io.backend io.launcher io.ports io.files io.files.private io.unix.files io.unix.backend io.unix.launcher.parser unix unix.process ; @@ -31,7 +31,7 @@ USE: unix ] when* ; : redirect-fd ( oldfd fd -- ) - 2dup = [ 2drop ] [ dupd dup2 io-error close ] if ; + 2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ; : reset-fd ( fd -- ) #! We drop the error code because on *BSD, fcntl of @@ -44,7 +44,7 @@ USE: unix : redirect-file ( obj mode fd -- ) >r >r normalize-path r> file-mode - open dup io-error r> redirect-fd ; + open-file r> redirect-fd ; : redirect-file-append ( obj mode fd -- ) >r drop path>> normalize-path open-append r> redirect-fd ; @@ -58,7 +58,7 @@ USE: unix { [ pick string? ] [ redirect-file ] } { [ pick appender? ] [ redirect-file-append ] } { [ pick +closed+ eq? ] [ redirect-closed ] } - { [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] } + { [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] } [ >r >r underlying-handle r> r> redirect ] } cond ; diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index cd17dfbbce..562e12699c 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -1,18 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.backend io.monitors io.monitors.recursive -io.files io.buffers io.monitors io.nonblocking io.timeouts +io.files io.buffers io.monitors io.ports io.timeouts io.unix.backend io.unix.select io.encodings.utf8 unix.linux.inotify assocs namespaces threads continuations init math math.bitfields sets alien alien.strings alien.c-types -vocabs.loader accessors system hashtables ; +vocabs.loader accessors system hashtables destructors ; IN: io.unix.linux.monitors SYMBOL: watches SYMBOL: inotify -TUPLE: linux-monitor < monitor wd inotify watches ; +TUPLE: linux-monitor < monitor wd inotify watches disposed ; : ( wd path mailbox -- monitor ) linux-monitor new-monitor @@ -23,9 +23,9 @@ TUPLE: linux-monitor < monitor wd inotify watches ; : wd>monitor ( wd -- monitor ) watches get at ; : ( -- port/f ) - inotify_init dup 0 < [ drop f ] [ ] if ; + inotify_init dup 0 < [ drop f ] [ ] if ; -: inotify-fd inotify get handle>> ; +: inotify-fd inotify get handle>> handle-fd ; : check-existing ( wd -- ) watches get key? [ @@ -54,14 +54,14 @@ M: linux (monitor) ( path recursive? mailbox -- monitor ) IN_CHANGE_EVENTS swap add-watch ] if ; -M: linux-monitor dispose ( monitor -- ) - dup inotify>> closed>> [ drop ] [ - [ [ wd>> ] [ watches>> ] bi delete-at ] - [ - [ inotify>> handle>> ] [ wd>> ] bi +M: linux-monitor dispose* ( monitor -- ) + [ [ wd>> ] [ watches>> ] bi delete-at ] + [ + dup inotify>> disposed>> [ drop ] [ + [ inotify>> handle>> handle-fd ] [ wd>> ] bi inotify_rm_watch io-error - ] bi - ] if ; + ] if + ] bi ; : ignore-flags? ( mask -- ? ) { @@ -110,7 +110,8 @@ M: linux-monitor dispose ( monitor -- ) ] if ; : inotify-read-loop ( port -- ) - dup wait-to-read1 + dup check-disposed + dup wait-to-read drop 0 over buffer>> parse-file-notifications 0 over buffer>> buffer-reset inotify-read-loop ; diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 8a5d0c490f..3471dc856a 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents continuations kernel sequences namespaces arrays system locals -accessors ; +accessors destructors ; IN: io.unix.macosx TUPLE: macosx-monitor < monitor handle ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index ada1f94d87..c31e23849e 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -1,22 +1,24 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien io io.files kernel math system unix io.unix.backend -io.mmap ; +USING: alien io io.files kernel math math.bitfields system unix +io.unix.backend io.ports io.mmap destructors locals accessors ; IN: io.unix.mmap -: open-r/w ( path -- fd ) O_RDWR file-mode open dup io-error ; +: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; -: mmap-open ( length prot flags path -- alien fd ) - >r f -roll r> open-r/w [ 0 mmap ] keep - over MAP_FAILED = [ close (io-error) ] when ; +:: mmap-open ( path length prot flags -- alien fd ) + [ + f length prot flags + path open-r/w |dispose + [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep + ] with-destructors ; -M: unix (mapped-file) ( path length -- obj ) - swap >r - dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor - r> mmap-open f mapped-file boa ; +M: unix (mapped-file) + { PROT_READ PROT_WRITE } flags + { MAP_FILE MAP_SHARED } flags + mmap-open ; M: unix close-mapped-file ( mmap -- ) - [ mapped-file-address ] keep - [ mapped-file-length munmap ] keep - mapped-file-handle close - io-error ; + [ [ address>> ] [ length>> ] bi munmap io-error ] + [ handle>> close-file ] + bi ; diff --git a/extra/io/unix/pipes/pipes.factor b/extra/io/unix/pipes/pipes.factor index 4fc5acf634..71366bfa4a 100644 --- a/extra/io/unix/pipes/pipes.factor +++ b/extra/io/unix/pipes/pipes.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: system alien.c-types kernel unix math sequences -qualified io.unix.backend io.nonblocking ; +qualified io.unix.backend io.ports ; IN: io.unix.pipes QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) 2 "int" dup pipe io-error - 2 c-int-array> first2 - [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ; + 2 c-int-array> first2 [ ] bi@ io.pipes:pipe boa ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 74b7136823..fea5f4e9ae 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.nonblocking io.unix.backend +USING: alien.c-types kernel io.ports io.unix.backend bit-arrays sequences assocs unix math namespaces structs -accessors math.order ; +accessors math.order locals ; IN: io.unix.select TUPLE: select-mx < mx read-fdset write-fdset ; @@ -21,21 +21,20 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : clear-nth ( n seq -- ? ) [ nth ] [ f -rot set-nth ] 2bi ; -: handle-fd ( fd task fdset mx -- ) - roll munge rot clear-nth - [ swap handle-io-task ] [ 2drop ] if ; +:: check-fd ( fd fdset mx quot -- ) + fd munge fdset clear-nth [ fd mx quot call ] when ; inline -: handle-fdset ( tasks fdset mx -- ) - [ handle-fd ] 2curry assoc-each ; +: check-fdset ( fds fdset mx quot -- ) + [ check-fd ] 3curry each ; inline -: init-fdset ( tasks fdset -- ) - [ >r drop t swap munge r> set-nth ] curry assoc-each ; +: init-fdset ( fds fdset -- ) + [ >r t swap munge r> set-nth ] curry each ; : read-fdset/tasks - [ reads>> ] [ read-fdset>> ] bi ; + [ reads>> keys ] [ read-fdset>> ] bi ; : write-fdset/tasks - [ writes>> ] [ write-fdset>> ] bi ; + [ writes>> keys ] [ write-fdset>> ] bi ; : max-fd ( assoc -- n ) dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; @@ -45,12 +44,13 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] - [ read-fdset/tasks tuck init-fdset ] - [ write-fdset/tasks tuck init-fdset ] tri + [ read-fdset/tasks [ init-fdset ] keep ] + [ write-fdset/tasks [ init-fdset ] keep ] tri f ; -M: select-mx wait-for-events ( ms mx -- ) - swap >r dup init-fdsets r> dup [ make-timeval ] when - select multiplexer-error - dup read-fdset/tasks pick handle-fdset - dup write-fdset/tasks rot handle-fdset ; +M:: select-mx wait-for-events ( ms mx -- ) + mx + [ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ] + [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] + [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] + tri ; diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor new file mode 100644 index 0000000000..5b8fd5ac23 --- /dev/null +++ b/extra/io/unix/sockets/secure/secure-tests.factor @@ -0,0 +1,65 @@ +IN: io.sockets.secure.tests +USING: accessors kernel namespaces io io.sockets +io.sockets.secure io.encodings.ascii io.streams.duplex +classes words destructors threads tools.test +concurrency.promises byte-arrays locals ; + +\ must-infer +{ 1 0 } [ [ ] with-secure-context ] must-infer-as + +[ ] [ "port" set ] unit-test + +: with-test-context + + "resource:extra/openssl/test/server.pem" >>key-file + "resource:extra/openssl/test/root.pem" >>ca-file + "resource:extra/openssl/test/dh1024.pem" >>dh-file + "password" >>password + swap with-secure-context ; + +:: server-test ( quot -- ) + [ + [ + "127.0.0.1" 0 ascii [ + dup addr>> addrspec>> port>> "port" get fulfill + accept [ + quot call + ] curry with-stream + ] with-disposal + ] with-test-context + ] "SSL server test" spawn drop ; + +: client-test + [ + "127.0.0.1" "port" get ?promise ascii drop contents + ] with-secure-context ; + +[ ] [ [ class word-name write ] server-test ] unit-test + +[ "secure" ] [ client-test ] unit-test + +! Now, see what happens if the server closes the connection prematurely +[ ] [ "port" set ] unit-test + +[ ] [ + [ + drop + input-stream get stream>> handle>> f >>connected drop + "hello" write flush + ] server-test +] unit-test + +[ client-test ] [ premature-close? ] must-fail-with + +! Now, try validating the certificate. This should fail because its +! actually an invalid certificate +[ ] [ "port" set ] unit-test + +[ ] [ [ drop ] server-test ] unit-test + +[ + [ + "localhost" "port" get ?promise ascii + drop dispose + ] with-secure-context +] [ certificate-verify-error? ] must-fail-with diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor new file mode 100755 index 0000000000..35f72a5d16 --- /dev/null +++ b/extra/io/unix/sockets/secure/secure.factor @@ -0,0 +1,152 @@ +! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays kernel debugger sequences namespaces math +math.order combinators init alien alien.c-types alien.strings libc +continuations destructors +openssl openssl.libcrypto openssl.libssl +io.files io.ports io.unix.backend io.unix.sockets +io.encodings.ascii io.buffers io.sockets io.sockets.secure +unix system inspector ; +IN: io.unix.sockets.secure + +M: ssl-handle handle-fd file>> handle-fd ; + +: syscall-error ( r -- * ) + ERR_get_error dup zero? [ + drop + { + { -1 [ (io-error) ] } + { 0 [ premature-close ] } + } case + ] [ + nip (ssl-error) + ] if ; + +: check-response ( port r -- port r n ) + over handle>> handle>> over SSL_get_error ; inline + +! Input ports +: check-read-response ( port r -- event ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } + { SSL_ERROR_ZERO_RETURN [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: ssl-handle refill + handle>> ! ssl + over buffer>> + [ buffer-end ] ! buf + [ buffer-capacity ] bi ! len + SSL_read + check-read-response ; + +! Output ports +: check-write-response ( port r -- event ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: ssl-handle drain + handle>> ! ssl + over buffer>> + [ buffer@ ] ! buf + [ buffer-length ] bi ! len + SSL_write + check-write-response ; + +! Client sockets +: ( fd -- ssl ) + [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep + [ handle>> swap dup SSL_set_bio ] keep ; + +M: secure ((client)) ( addrspec -- handle ) + addrspec>> ((client)) ; + +M: secure parse-sockaddr addrspec>> parse-sockaddr ; + +M: secure (get-local-address) addrspec>> (get-local-address) ; + +: check-connect-response ( port r -- event ) + check-response + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: do-ssl-connect ( port -- ) + dup dup handle>> handle>> SSL_connect + check-connect-response dup + [ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ; + +M: secure establish-connection ( client-out remote -- ) + [ addrspec>> establish-connection ] + [ drop do-ssl-connect ] + [ drop handle>> t >>connected drop ] + 2tri ; + +M: secure (server) addrspec>> (server) ; + +: check-accept-response ( handle r -- event ) + over handle>> over SSL_get_error + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: do-ssl-accept ( ssl-handle -- ) + dup dup handle>> SSL_accept check-accept-response dup + [ >r dup file>> r> wait-for-fd drop do-ssl-accept ] [ 2drop ] if ; + +M: secure (accept) + [ + addrspec>> (accept) >r + |dispose t >>connected |dispose + dup do-ssl-accept r> + ] with-destructors ; + +: check-shutdown-response ( handle r -- event ) + #! SSL_shutdown always returns 0 due to openssl bugs? + { + { 1 [ drop f ] } + { 0 [ + dup handle>> dup f 0 SSL_read 2dup SSL_get_error + { + { SSL_ERROR_ZERO_RETURN [ 2drop dup handle>> SSL_shutdown check-shutdown-response ] } + { SSL_ERROR_WANT_READ [ 3drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 3drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case + ] } + { -1 [ + handle>> -1 SSL_get_error + { + { SSL_ERROR_WANT_READ [ +input+ ] } + { SSL_ERROR_WANT_WRITE [ +output+ ] } + { SSL_ERROR_SYSCALL [ -1 syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case + ] } + } case ; + +M: unix ssl-shutdown + dup connected>> [ + dup dup handle>> SSL_shutdown check-shutdown-response + dup [ dupd wait-for-fd drop ssl-shutdown ] [ 2drop ] if + ] [ drop ] if ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 71edbc5500..d4059c102a 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -1,108 +1,96 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings generic kernel math -namespaces threads sequences byte-arrays io.nonblocking -io.binary io.unix.backend io.streams.duplex io.sockets.impl -io.backend io.files io.files.private io.encodings.utf8 -math.parser continuations libc combinators system accessors -qualified unix.ffi unix ; +namespaces threads sequences byte-arrays io.ports +io.binary io.unix.backend io.streams.duplex +io.backend io.ports io.files io.files.private +io.encodings.utf8 math.parser continuations libc combinators +system accessors qualified destructors unix locals ; EXCLUDE: io => read write close ; EXCLUDE: io.sockets => accept ; IN: io.unix.sockets -: pending-init-error ( port -- ) - #! We close it here to avoid a resource leak; callers of - #! don't set up error handlers until after - #! returns (and if they did before, they wouldn't have - #! anything to close!) - dup port-error dup [ swap dispose throw ] [ 2drop ] if ; +: socket-fd ( domain type -- fd ) + 0 socket dup io-error |dispose ; -: socket-fd ( domain type -- socket ) - 0 socket dup io-error dup init-handle ; - -: sockopt ( fd level opt -- ) - 1 "int" heap-size setsockopt io-error ; +: set-socket-option ( fd level opt -- ) + >r >r handle-fd r> r> 1 "int" heap-size setsockopt io-error ; M: unix addrinfo-error ( n -- ) dup zero? [ drop ] [ gai_strerror throw ] if ; ! Client sockets - TCP and Unix domain +M: object (get-local-address) ( handle remote -- sockaddr ) + >r handle-fd r> empty-sockaddr/size + [ getsockname io-error ] 2keep drop ; + +M: object (get-remote-address) ( handle local -- sockaddr ) + >r handle-fd r> empty-sockaddr/size + [ getpeername io-error ] 2keep drop ; + : init-client-socket ( fd -- ) - SOL_SOCKET SO_OOBINLINE sockopt ; - -TUPLE: connect-task < output-task ; - -: ( port continuation -- task ) - connect-task ; - -M: connect-task do-io-task - port>> dup handle>> f 0 write - 0 < [ defer-error ] [ drop t ] if ; + SOL_SOCKET SO_OOBINLINE set-socket-option ; : wait-to-connect ( port -- ) - [ add-io-task ] with-port-continuation drop ; + dup handle>> handle-fd f 0 write + { + { [ 0 = ] [ drop ] } + { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } + { [ err_no EINTR = ] [ wait-to-connect ] } + [ (io-error) ] + } cond ; -M: unix ((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 - dup wait-to-connect - dup pending-init-error - ] [ - dup close (io-error) - ] if ; +M: object establish-connection ( client-out remote -- ) + [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi + { + { [ 0 = ] [ drop ] } + { [ err_no EINPROGRESS = ] [ + [ +output+ wait-for-port ] [ wait-to-connect ] bi + ] } + [ (io-error) ] + } cond ; + +M: object ((client)) ( addrspec -- fd ) + protocol-family SOCK_STREAM socket-fd dup init-client-socket ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) - SOL_SOCKET SO_REUSEADDR sockopt ; + SOL_SOCKET SO_REUSEADDR set-socket-option ; -TUPLE: accept-task < input-task ; - -: ( port continuation -- task ) - accept-task ; - -: accept-sockaddr ( port -- fd sockaddr ) - dup port-handle swap server-port-addr sockaddr-type - dup [ swap heap-size accept ] keep ; inline - -: do-accept ( port fd sockaddr -- ) - 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 - over 0 >= [ do-accept t ] [ 2drop defer-error ] if ; - -: wait-to-accept ( server -- ) - [ add-io-task ] with-port-continuation drop ; - -: server-fd ( addrspec type -- fd ) - >r dup protocol-family r> socket-fd +: server-socket-fd ( addrspec type -- fd ) + >r dup protocol-family r> socket-fd dup init-server-socket - dup rot make-sockaddr/size bind - zero? [ dup close (io-error) ] unless ; + dup handle-fd rot make-sockaddr/size bind io-error ; -M: unix (server) ( addrspec -- handle ) - SOCK_STREAM server-fd - dup 10 listen zero? [ dup close (io-error) ] unless ; +M: object (server) ( addrspec -- handle ) + [ + SOCK_STREAM server-socket-fd + dup handle-fd 10 listen io-error + ] with-destructors ; -M: unix (accept) ( server -- addrspec handle ) - #! Wait for a client connection. - check-server-port - [ wait-to-accept ] - [ pending-error ] - [ [ client-addr>> ] [ client>> ] bi ] tri ; +: do-accept ( server addrspec -- fd sockaddr ) + [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* + [ accept ] 2keep drop ; inline + +M: object (accept) ( server addrspec -- fd sockaddr ) + 2dup do-accept + { + { [ over 0 >= ] [ >r 2nip r> ] } + { [ err_no EINTR = ] [ 2drop (accept) ] } + { [ err_no EAGAIN = ] [ + 2drop + [ drop +input+ wait-for-port ] + [ (accept) ] + 2bi + ] } + [ (io-error) ] + } cond ; ! Datagram sockets - UDP and Unix domain -M: unix - [ SOCK_DGRAM server-fd ] keep ; +M: unix (datagram) + [ SOCK_DGRAM server-socket-fd ] with-destructors ; SYMBOL: receive-buffer @@ -110,76 +98,45 @@ SYMBOL: receive-buffer packet-size receive-buffer set-global -: setup-receive ( port -- s buffer len flags from fromlen ) - dup port-handle - swap datagram-port-addr sockaddr-type - dup swap heap-size - >r >r receive-buffer get-global packet-size 0 r> r> ; +:: do-receive ( port -- packet sockaddr ) + port addr>> empty-sockaddr/size [| sockaddr len | + port handle>> handle-fd ! s + receive-buffer get-global ! buf + packet-size ! nbytes + 0 ! flags + sockaddr ! from + len ! fromlen + recvfrom dup 0 >= [ + receive-buffer get-global swap head sockaddr + ] [ + drop f f + ] if + ] call ; -: do-receive ( s buffer len flags from fromlen -- sockaddr data ) - over >r recvfrom r> - over -1 = [ - 2drop f f - ] [ - receive-buffer get-global - rot head +M: unix (receive) ( datagram -- packet sockaddr ) + dup do-receive dup [ rot drop ] [ + 2drop [ +input+ wait-for-port ] [ (receive) ] bi ] if ; -TUPLE: receive-task < input-task ; +:: do-send ( packet sockaddr len socket datagram -- ) + socket handle-fd packet dup length 0 sockaddr len sendto + 0 < [ + err_no EINTR = [ + packet sockaddr len socket datagram do-send + ] [ + err_no EAGAIN = [ + datagram +output+ wait-for-port + packet sockaddr len socket datagram do-send + ] [ + (io-error) + ] if + ] if + ] when ; -: ( stream continuation -- task ) - receive-task ; - -M: receive-task do-io-task - io-task-port - dup setup-receive do-receive dup [ - pick set-datagram-port-packet - over datagram-port-addr parse-sockaddr - swap set-datagram-port-packet-addr - t - ] [ - 2drop defer-error - ] if ; - -: wait-receive ( stream -- ) - [ add-io-task ] with-port-continuation drop ; - -M: unix receive ( datagram -- packet addrspec ) - check-datagram-port - [ wait-receive ] - [ pending-error ] - [ [ packet>> ] [ packet-addr>> ] bi ] tri ; - -: do-send ( socket data sockaddr len -- n ) - >r >r dup length 0 r> r> sendto ; - -TUPLE: send-task < output-task packet sockaddr len ; - -: ( packet sockaddr len stream continuation -- task ) - send-task [ - { - set-send-task-packet - set-send-task-sockaddr - set-send-task-len - } set-slots - ] keep ; - -M: send-task do-io-task - [ io-task-port port-handle ] keep - [ send-task-packet ] keep - [ send-task-sockaddr ] keep - [ send-task-len do-send ] keep - swap 0 < [ io-task-port defer-error ] [ drop t ] if ; - -: wait-send ( packet sockaddr len stream -- ) - [ add-io-task ] with-port-continuation - 2drop 2drop ; - -M: unix send ( packet addrspec datagram -- ) - check-datagram-send - [ >r make-sockaddr/size r> wait-send ] keep - pending-error ; +M: unix (send) ( packet addrspec datagram -- ) + [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ; +! Unix domain sockets M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 61a667b70f..3147d7144b 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 io.encodings.binary io.encodings.ascii -io.streams.duplex ; +io.streams.duplex destructors ; IN: io.unix.tests ! Unix domain stream sockets diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index e8e7135e1a..3a379de78f 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,6 +1,13 @@ -USING: io.unix.backend io.unix.files io.unix.sockets -io.unix.launcher io.unix.mmap io.unix.pipes io.timeouts -io.backend combinators namespaces system vocabs.loader -sequences words init ; +USING: system words sequences vocabs.loader ; + +{ + "io.unix.backend" + "io.unix.files" + "io.unix.sockets" + "io.unix.sockets.secure" + "io.unix.launcher" + "io.unix.mmap" + "io.unix.pipes" +} [ require ] each "io.unix." os word-name append require diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index a8ff4c14e3..7209a68ebf 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,4 +1,4 @@ -USING: io.nonblocking io.windows threads.private kernel +USING: io.ports io.windows threads.private kernel io.backend windows.winsock windows.kernel32 windows io.streams.duplex io namespaces alien.syntax system combinators io.buffers io.encodings io.encodings.utf8 combinators.lib ; @@ -46,5 +46,5 @@ M: wince (init-stdio) ( -- ) 1 _getstdfilex _fileno 2 _getstdfilex _fileno ] if [ f ] 3apply - rot -rot [ ] bi@ + [ ] [ ] [ ] tri* ] with-variable ; diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 8f7390aa7c..83d456832b 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types combinators io io.backend io.buffers -io.files io.nonblocking io.windows kernel libc math namespaces +io.files io.ports io.windows kernel libc math namespaces prettyprint sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend system ; IN: windows.ce.files diff --git a/extra/io/windows/ce/privileges/privileges.factor b/extra/io/windows/ce/privileges/privileges.factor new file mode 100755 index 0000000000..e0aa186b3d --- /dev/null +++ b/extra/io/windows/ce/privileges/privileges.factor @@ -0,0 +1,4 @@ +IN: io.windows.ce.privileges +USING: io.windows.privileges system ; + +M: wince set-privilege 2drop ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 0001bb5142..b3117dcde1 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types combinators io io.backend io.buffers -io.nonblocking io.sockets io.sockets.impl io.windows kernel libc +io.ports io.sockets io.windows kernel libc math namespaces prettyprint qualified sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend byte-arrays system ; @@ -32,7 +32,7 @@ M: win32-socket wince-write ( port port-handle -- ) windows.winsock:winsock-error!=0/f ; M: wince (client) ( addrspec -- reader writer ) - do-connect dup ; + do-connect dup ; M: wince (server) ( addrspec -- handle ) windows.winsock:SOCK_STREAM server-fd @@ -41,7 +41,6 @@ M: wince (server) ( addrspec -- handle ) M: wince (accept) ( server -- client ) [ - dup check-server-port [ dup port-handle win32-file-handle swap server-port-addr sockaddr-type heap-size @@ -52,7 +51,7 @@ M: wince (accept) ( server -- client ) [ windows.winsock:winsock-error ] when ] keep ] keep server-port-addr parse-sockaddr swap - + ] with-timeout ; M: wince ( addrspec -- datagram ) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 8a15a57f83..ef3db0dcd1 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -1,11 +1,121 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types io.backend io.files io.windows kernel math +USING: alien.c-types io.binary io.backend io.files io.buffers +io.windows kernel math splitting windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces words symbols system -combinators.lib io.nonblocking destructors math.bitfields.lib ; +combinators.lib io.ports destructors accessors +math.bitfields math.bitfields.lib ; IN: io.windows.files +: open-file ( path access-mode create-mode flags -- handle ) + [ + >r >r share-mode security-attributes-inherit r> r> + CreateFile-flags f CreateFile opened-file + ] with-destructors ; + +: open-pipe-r/w ( path -- win32-file ) + { GENERIC_READ GENERIC_WRITE } flags + OPEN_EXISTING 0 open-file ; + +: open-read ( path -- win32-file ) + GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ; + +: open-write ( path -- win32-file ) + GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ; + +: (open-append) ( path -- win32-file ) + GENERIC_WRITE OPEN_ALWAYS 0 open-file ; + +: open-existing ( path -- win32-file ) + { GENERIC_READ GENERIC_WRITE } flags + share-mode + f + OPEN_EXISTING + FILE_FLAG_BACKUP_SEMANTICS + f CreateFileW dup win32-error=0/f ; + +: maybe-create-file ( path -- win32-file ? ) + #! return true if file was just created + { GENERIC_READ GENERIC_WRITE } flags + share-mode + f + OPEN_ALWAYS + 0 CreateFile-flags + f CreateFileW dup win32-error=0/f + GetLastError ERROR_ALREADY_EXISTS = not ; + +: set-file-pointer ( handle length method -- ) + >r dupd d>w/w r> SetFilePointer + INVALID_SET_FILE_POINTER = [ + CloseHandle "SetFilePointer failed" throw + ] when drop ; + +HOOK: open-append os ( path -- win32-file ) + +TUPLE: FileArgs + hFile lpBuffer nNumberOfBytesToRead + lpNumberOfBytesRet lpOverlapped ; + +C: FileArgs + +: make-FileArgs ( port -- ) + { + [ handle>> handle>> ] + [ buffer>> ] + [ buffer>> buffer-length ] + [ drop "DWORD" ] + [ FileArgs-overlapped ] + } cleave ; + +: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer-end ] + [ lpBuffer>> buffer-capacity ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +: setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer@ ] + [ lpBuffer>> buffer-length ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +M: windows (file-reader) ( path -- stream ) + open-read ; + +M: windows (file-writer) ( path -- stream ) + open-write ; + +M: windows (file-appender) ( path -- stream ) + open-append ; + +M: windows move-file ( from to -- ) + [ normalize-path ] bi@ MoveFile win32-error=0/f ; + +M: windows delete-file ( path -- ) + normalize-path DeleteFile win32-error=0/f ; + +M: windows copy-file ( from to -- ) + dup parent-directory make-directories + [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; + +M: windows make-directory ( path -- ) + normalize-path + f CreateDirectory win32-error=0/f ; + +M: windows delete-directory ( path -- ) + normalize-path + RemoveDirectory win32-error=0/f ; + +M: windows normalize-directory ( string -- string ) + normalize-path "\\" ?tail drop "\\*" append ; + SYMBOLS: +read-only+ +hidden+ +system+ +archive+ +device+ +normal+ +temporary+ +sparse-file+ +reparse-point+ +compressed+ +offline+ @@ -68,6 +178,11 @@ SYMBOLS: +read-only+ +hidden+ +system+ ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ] + ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ] + ! [ + ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] + ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit + ! ] } cleave \ file-info boa ; @@ -96,7 +211,7 @@ M: winnt link-info ( path -- info ) : file-times ( path -- timestamp timestamp timestamp ) [ - normalize-path open-existing dup close-always + normalize-path open-existing &dispose handle>> "FILETIME" "FILETIME" "FILETIME" @@ -112,7 +227,7 @@ M: winnt link-info ( path -- info ) #! timestamp order: creation access write [ >r >r >r - normalize-path open-existing dup close-always + normalize-path open-existing &dispose handle>> r> r> r> (set-file-times) ] with-destructors ; @@ -128,6 +243,6 @@ M: winnt link-info ( path -- info ) M: winnt touch-file ( path -- ) [ normalize-path - maybe-create-file over close-always - [ drop ] [ f now dup (set-file-times) ] if + maybe-create-file >r &dispose r> + [ drop ] [ handle>> f now dup (set-file-times) ] if ] with-destructors ; diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor old mode 100644 new mode 100755 index 0449980286..dcb713df7f --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,10 +1,10 @@ USING: kernel system io.files.unique.backend -windows.kernel32 io.windows io.nonblocking windows ; +windows.kernel32 io.windows io.windows.files io.ports windows +destructors ; IN: io.windows.files.unique M: windows (make-unique-file) ( path -- ) - GENERIC_WRITE CREATE_NEW 0 open-file - CloseHandle win32-error=0/f ; + GENERIC_WRITE CREATE_NEW 0 open-file dispose ; M: windows temporary-path ( -- path ) "TEMP" os-env ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index a5d7338cd6..1cfb91d716 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations io -io.windows io.windows.nt.pipes libc io.nonblocking +io.windows io.windows.nt.pipes libc io.ports windows.types math windows.kernel32 namespaces io.launcher kernel sequences windows.errors splitting system threads init strings combinators io.backend accessors concurrency.flags io.files assocs -io.files.private windows destructors ; +io.files.private windows destructors classes.tuple.lib ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -19,8 +19,7 @@ TUPLE: CreateProcess-args lpEnvironment lpCurrentDirectory lpStartupInfo - lpProcessInformation - stdout-pipe stdin-pipe ; + lpProcessInformation ; : default-CreateProcess-args ( -- obj ) CreateProcess-args new @@ -31,18 +30,7 @@ TUPLE: CreateProcess-args 0 >>dwCreateFlags ; : call-CreateProcess ( CreateProcess-args -- ) - { - lpApplicationName>> - lpCommandLine>> - lpProcessAttributes>> - lpThreadAttributes>> - bInheritHandles>> - dwCreateFlags>> - lpEnvironment>> - lpCurrentDirectory>> - lpStartupInfo>> - lpProcessInformation>> - } get-slots CreateProcess win32-error=0/f ; + CreateProcess-args >tuple< CreateProcess win32-error=0/f ; : count-trailing-backslashes ( str n -- str n ) >r "\\" ?tail [ diff --git a/extra/io/windows/mmap/mmap-tests.factor b/extra/io/windows/mmap/mmap-tests.factor new file mode 100644 index 0000000000..a8430108e8 --- /dev/null +++ b/extra/io/windows/mmap/mmap-tests.factor @@ -0,0 +1,8 @@ +USING: io io.mmap io.files kernel tools.test continuations +sequences io.encodings.ascii accessors ; +IN: io.windows.mmap.tests + +[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test +[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test +[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test +[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index dc29405b12..72dfca9df3 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -1,88 +1,44 @@ -USING: alien alien.c-types alien.syntax arrays continuations -destructors generic io.mmap io.nonblocking io.windows -kernel libc math namespaces quotations sequences windows -windows.advapi32 windows.kernel32 io.backend system ; +USING: alien alien.c-types arrays destructors generic io.mmap +io.ports io.windows io.windows.files io.windows.privileges +kernel libc math math.bitfields namespaces quotations sequences +windows windows.advapi32 windows.kernel32 io.backend system +accessors locals ; IN: io.windows.mmap -TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES +: create-file-mapping + CreateFileMapping [ win32-error=0/f ] keep ; -! Security tokens -! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ +: map-view-of-file + MapViewOfFile [ win32-error=0/f ] keep ; -: (open-process-token) ( handle -- handle ) - TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY bitor "PHANDLE" - [ OpenProcessToken win32-error=0/f ] keep *void* ; +:: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) + [let | lo [ length HEX: ffffffff bitand ] + hi [ length -32 shift HEX: ffffffff bitand ] | + { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ + path access-mode create-mode 0 open-file |dispose + dup handle>> f protect hi lo f create-file-mapping |dispose + dup handle>> access 0 0 0 map-view-of-file + ] with-privileges + ] ; -: open-process-token ( -- handle ) - #! remember to handle-close this - GetCurrentProcess (open-process-token) ; +TUPLE: win32-mapped-file file mapping ; -: with-process-token ( quot -- ) - #! quot: ( token-handle -- token-handle ) - >r open-process-token r> - [ keep ] curry - [ CloseHandle drop ] [ ] cleanup ; inline +M: win32-mapped-file dispose + [ file>> dispose ] [ mapping>> dispose ] bi ; -: lookup-privilege ( string -- luid ) - >r f r> "LUID" - [ LookupPrivilegeValue win32-error=0/f ] keep ; +C: win32-mapped-file -: make-token-privileges ( name ? -- obj ) - "TOKEN_PRIVILEGES" - 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep - "LUID_AND_ATTRIBUTES" malloc-array - dup free-always over set-TOKEN_PRIVILEGES-Privileges - - swap [ - SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges - set-LUID_AND_ATTRIBUTES-Attributes - ] when - - >r lookup-privilege r> +M: windows (mapped-file) [ - TOKEN_PRIVILEGES-Privileges - >r 0 r> LUID_AND_ATTRIBUTES-nth - set-LUID_AND_ATTRIBUTES-Luid - ] keep ; - -: set-privilege ( name ? -- ) - [ - -rot 0 -rot make-token-privileges - dup length f f AdjustTokenPrivileges win32-error=0/f - ] with-process-token ; - -HOOK: with-privileges io-backend ( seq quot -- ) inline - -M: winnt with-privileges - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; - -M: wince with-privileges - nip call ; - -: mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) - { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ - >r >r 0 open-file dup f r> 0 0 f - CreateFileMapping [ win32-error=0/f ] keep - dup close-later - dup - r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep - dup close-later - ] with-privileges ; - -M: windows (mapped-file) ( path length -- mmap ) - [ - swap - GENERIC_WRITE GENERIC_READ bitor + { GENERIC_WRITE GENERIC_READ } flags OPEN_ALWAYS - PAGE_READWRITE SEC_COMMIT bitor + { PAGE_READWRITE SEC_COMMIT } flags FILE_MAP_ALL_ACCESS mmap-open - -rot 2array - f \ mapped-file boa + -rot ] with-destructors ; M: windows close-mapped-file ( mapped-file -- ) [ - dup mapped-file-handle [ close-always ] each - mapped-file-address UnmapViewOfFile win32-error=0/f + [ handle>> &dispose drop ] + [ address>> UnmapViewOfFile win32-error=0/f ] bi ] with-destructors ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index fe7f1ecc61..5cc0751c55 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,24 +1,26 @@ USING: alien alien.c-types arrays assocs combinators -continuations destructors io io.backend io.nonblocking -io.windows libc kernel math namespaces sequences -threads classes.tuple.lib windows windows.errors -windows.kernel32 strings splitting io.files qualified ascii -combinators.lib system accessors ; +continuations destructors io io.backend io.ports io.timeouts +io.windows io.windows.files libc kernel math namespaces +sequences threads classes.tuple.lib windows windows.errors +windows.kernel32 strings splitting io.files +io.buffers qualified ascii combinators.lib system +accessors locals ; QUALIFIED: windows.winsock IN: io.windows.nt.backend -SYMBOL: io-hash +! Global variable with assoc mapping overlapped to threads +SYMBOL: pending-overlapped TUPLE: io-callback port thread ; C: io-callback : (make-overlapped) ( -- overlapped-ext ) - "OVERLAPPED" malloc-object dup free-always ; + "OVERLAPPED" malloc-object &free ; : make-overlapped ( port -- overlapped-ext ) - >r (make-overlapped) r> port-handle win32-file-ptr - [ over set-OVERLAPPED-offset ] when* ; + >r (make-overlapped) + r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ; : ( handle existing -- handle ) f 1 CreateIoCompletionPort dup win32-error=0/f ; @@ -28,74 +30,92 @@ SYMBOL: master-completion-port : ( -- handle ) INVALID_HANDLE_VALUE f ; -M: winnt add-completion ( handle -- ) - master-completion-port get-global drop ; +M: winnt add-completion ( win32-handle -- ) + handle>> master-completion-port get-global drop ; : eof? ( error -- ? ) - dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ; + [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ; -: overlapped-error? ( port n -- ? ) - zero? [ - GetLastError { - { [ dup expected-io-error? ] [ 2drop t ] } - { [ dup eof? ] [ drop t >>eof drop f ] } - [ (win32-error-string) throw ] - } cond - ] [ - drop t - ] if ; - -: get-overlapped-result ( overlapped port -- bytes-transferred ) - dup handle>> handle>> rot 0 - [ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ; - -: save-callback ( overlapped port -- ) +: twiddle-thumbs ( overlapped port -- bytes-transferred ) [ - swap - dup alien? [ "bad overlapped in save-callback" throw ] unless - io-hash get-global set-at - ] "I/O" suspend 3drop ; + drop + [ pending-overlapped get-global set-at ] curry "I/O" suspend + { + { [ dup integer? ] [ ] } + { [ dup array? ] [ + first dup eof? + [ drop 0 ] [ (win32-error-string) throw ] if + ] } + } cond + ] with-timeout ; -: wait-for-overlapped ( ms -- overlapped ? ) - >r master-completion-port get-global - r> INFINITE or ! timeout - 0 ! bytes - f ! key - f ! overlapped - [ roll GetQueuedCompletionStatus ] keep *void* swap zero? ; +:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? ) + master-completion-port get-global + 0 [ ! bytes + f ! key + f [ ! overlapped + ms INFINITE or ! timeout + GetQueuedCompletionStatus zero? + ] keep *void* + ] keep *int spin ; -: lookup-callback ( overlapped -- callback ) - io-hash get-global delete-at* drop - dup io-callback? [ "no callback in io-hash" throw ] unless ; +: resume-callback ( result overlapped -- ) + pending-overlapped get-global delete-at* drop resume-with ; : handle-overlapped ( timeout -- ? ) wait-for-overlapped [ - GetLastError dup expected-io-error? [ - 2drop t - ] [ - dup eof? [ - drop lookup-callback - dup port>> t >>eof drop - ] [ - (win32-error-string) swap lookup-callback - [ port>> set-port-error ] keep - ] if thread>> resume f - ] if + >r drop GetLastError + [ 1array ] [ expected-io-error? ] bi + [ r> 2drop f ] [ r> resume-callback t ] if ] [ - lookup-callback - io-callback-thread resume f + resume-callback t ] if ; -: drain-overlapped ( timeout -- ) - handle-overlapped [ 0 drain-overlapped ] unless ; - M: winnt cancel-io handle>> handle>> CancelIo drop ; M: winnt io-multiplex ( ms -- ) - drain-overlapped ; + handle-overlapped [ 0 io-multiplex ] when ; M: winnt init-io ( -- ) master-completion-port set-global - H{ } clone io-hash set-global + H{ } clone pending-overlapped set-global windows.winsock:init-winsock ; + +: file-error? ( n -- eof? ) + zero? [ + GetLastError { + { [ dup expected-io-error? ] [ drop f ] } + { [ dup eof? ] [ drop t ] } + [ (win32-error-string) throw ] + } cond + ] [ f ] if ; + +: wait-for-file ( FileArgs n port -- n ) + swap file-error? + [ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ; + +: update-file-ptr ( n port -- ) + handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; + +: finish-write ( n port -- ) + [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; + +M: winnt (wait-to-write) + [ + [ make-FileArgs dup setup-write WriteFile ] + [ wait-for-file ] + [ finish-write ] + tri + ] with-destructors ; + +: finish-read ( n port -- ) + [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ; + +M: winnt (wait-to-read) ( port -- ) + [ + [ make-FileArgs dup setup-read ReadFile ] + [ wait-for-file ] + [ finish-read ] + tri + ] with-destructors ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 8839410d91..67161716a3 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,6 +1,7 @@ USING: continuations destructors io.buffers io.files io.backend -io.timeouts io.nonblocking io.windows io.windows.nt.backend -kernel libc math threads windows windows.kernel32 system +io.timeouts io.ports io.windows io.windows.files +io.windows.nt.backend windows windows.kernel32 +kernel libc math threads system alien.c-types alien.arrays alien.strings sequences combinators combinators.lib sequences.lib ascii splitting alien strings assocs namespaces io.files.private accessors ; @@ -29,6 +30,7 @@ M: winnt root-directory? ( path -- ? ) } cond nip ; ERROR: not-absolute-path ; + : root-directory ( string -- string' ) { [ dup length 2 >= ] @@ -54,57 +56,4 @@ M: winnt FileArgs-overlapped ( port -- overlapped ) M: winnt open-append [ dup file-info size>> ] [ drop 0 ] recover - >r (open-append) r> ; - -: update-file-ptr ( n port -- ) - port-handle - dup win32-file-ptr [ - rot + swap set-win32-file-ptr - ] [ - 2drop - ] if* ; - -: finish-flush ( overlapped port -- ) - dup pending-error - tuck get-overlapped-result - dup pick update-file-ptr - swap buffer>> buffer-consume ; - -: (flush-output) ( port -- ) - dup make-FileArgs - tuck setup-write WriteFile - dupd overlapped-error? [ - >r FileArgs-lpOverlapped r> - [ save-callback ] 2keep - [ finish-flush ] keep - dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if - ] [ - 2drop - ] if ; - -: flush-output ( port -- ) - [ [ (flush-output) ] with-timeout ] with-destructors ; - -M: port port-flush - dup buffer>> buffer-empty? [ dup flush-output ] unless drop ; - -: finish-read ( overlapped port -- ) - dup pending-error - tuck get-overlapped-result dup zero? [ - drop t >>eof drop - ] [ - dup pick buffer>> n>buffer - swap update-file-ptr - ] if ; - -: ((wait-to-read)) ( port -- ) - dup make-FileArgs - tuck setup-read ReadFile - dupd overlapped-error? [ - >r FileArgs-lpOverlapped r> - [ save-callback ] 2keep - finish-read - ] [ 2drop ] if ; - -M: input-port (wait-to-read) ( port -- ) - [ [ ((wait-to-read)) ] with-timeout ] with-destructors ; + >r (open-append) r> >>ptr ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 39edd931b1..6c86b53049 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -1,11 +1,12 @@ ! 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.pipes windows.types +io.windows libc io.ports io.pipes 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 io.files -io.files.private combinators shuffle accessors locals ; +io.windows.launcher io.windows.files +io.backend io.files io.files.private combinators shuffle +accessors locals ; IN: io.windows.nt.launcher : duplicate-handle ( handle -- handle' ) @@ -21,10 +22,10 @@ IN: io.windows.nt.launcher ! /dev/null simulation : null-input ( -- pipe ) - (pipe) [ in>> handle>> ] [ out>> close-handle ] bi ; + (pipe) [ in>> handle>> ] [ out>> dispose ] bi ; : null-output ( -- pipe ) - (pipe) [ in>> close-handle ] [ out>> handle>> ] bi ; + (pipe) [ in>> dispose ] [ out>> handle>> ] bi ; : null-pipe ( mode -- pipe ) { @@ -35,13 +36,13 @@ IN: io.windows.nt.launcher ! The below code is based on the example given in ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx -: redirect-default ( default obj access-mode create-mode -- handle ) - 3drop ; +: redirect-default ( obj access-mode create-mode -- handle ) + 3drop f ; -: redirect-closed ( default obj access-mode create-mode -- handle ) - drop 2nip null-pipe ; +: redirect-closed ( obj access-mode create-mode -- handle ) + drop nip null-pipe ; -:: redirect-file ( default path access-mode create-mode -- handle ) +:: redirect-file ( path access-mode create-mode -- handle ) path normalize-path access-mode share-mode @@ -49,9 +50,9 @@ IN: io.windows.nt.launcher create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file - CreateFile dup invalid-handle? dup close-always ; + CreateFile dup invalid-handle? &dispose handle>> ; -: redirect-append ( default path access-mode create-mode -- handle ) +: redirect-append ( path access-mode create-mode -- handle ) >r >r path>> r> r> drop OPEN_ALWAYS redirect-file @@ -60,14 +61,13 @@ IN: io.windows.nt.launcher : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; -: redirect-handle ( default handle access-mode create-mode -- handle ) - 2drop nip - handle>> duplicate-handle dup t set-inherit ; +: redirect-handle ( handle access-mode create-mode -- handle ) + 2drop handle>> duplicate-handle dup t set-inherit ; -: redirect-stream ( default stream access-mode create-mode -- handle ) - >r >r underlying-handle r> r> redirect-handle ; +: redirect-stream ( stream access-mode create-mode -- handle ) + >r >r underlying-handle handle>> r> r> redirect-handle ; -: redirect ( default obj access-mode create-mode -- handle ) +: redirect ( obj access-mode create-mode -- handle ) { { [ pick not ] [ redirect-default ] } { [ pick +closed+ eq? ] [ redirect-closed ] } @@ -77,12 +77,9 @@ IN: io.windows.nt.launcher [ redirect-stream ] } cond ; -: default-stdout ( args -- handle ) - stdout-pipe>> dup [ out>> ] when ; - : redirect-stdout ( process args -- handle ) - default-stdout - swap stdout>> + drop + stdout>> GENERIC_WRITE CREATE_ALWAYS redirect @@ -90,25 +87,20 @@ IN: io.windows.nt.launcher : redirect-stderr ( process args -- handle ) over stderr>> +stdout+ eq? [ - lpStartupInfo>> - STARTUPINFO-hStdOutput nip + lpStartupInfo>> STARTUPINFO-hStdOutput ] [ drop - f - swap stderr>> + stderr>> GENERIC_WRITE CREATE_ALWAYS redirect STD_ERROR_HANDLE GetStdHandle or ] if ; -: default-stdin ( args -- handle ) - stdin-pipe>> dup [ in>> ] when ; - : redirect-stdin ( process args -- handle ) - default-stdin - swap stdin>> + drop + stdin>> GENERIC_READ OPEN_EXISTING redirect diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 37784c673c..fa4d19a46e 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ kernel math assocs namespaces continuations sequences hashtables sorting arrays combinators math.bitfields strings system accessors threads splitting io.backend io.windows io.windows.nt.backend io.windows.nt.files -io.monitors io.nonblocking io.buffers io.files io.timeouts io +io.monitors io.ports io.buffers io.files io.timeouts io windows windows.kernel32 windows.types ; IN: io.windows.nt.monitors @@ -17,11 +17,7 @@ IN: io.windows.nt.monitors OPEN_EXISTING { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags f - CreateFile - dup invalid-handle? - dup close-later - dup add-completion - f ; + CreateFile opened-file ; TUPLE: win32-monitor-port < input-port recursive ; @@ -39,13 +35,9 @@ TUPLE: win32-monitor < monitor port ; (make-overlapped) [ f ReadDirectoryChangesW win32-error=0/f ] keep ; -: read-changes ( port -- bytes ) +: read-changes ( port -- bytes-transferred ) [ - dup begin-reading-changes - swap [ save-callback ] 2keep - check-closed ! we may have closed it... - dup eof>> [ "EOF??" throw ] when - get-overlapped-result + [ begin-reading-changes ] [ twiddle-thumbs ] bi ] with-destructors ; : parse-action ( action -- changed ) @@ -87,7 +79,7 @@ TUPLE: win32-monitor < monitor port ; ] each ; : fill-queue ( monitor -- ) - dup port>> check-closed + dup port>> dup check-disposed [ buffer>> ptr>> ] [ read-changes zero? ] bi [ 2dup parse-notify-records ] unless 2drop ; @@ -97,7 +89,7 @@ TUPLE: win32-monitor < monitor port ; : fill-queue-thread ( monitor -- ) [ dup fill-queue (fill-queue-thread) ] - [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ; + [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ; M:: winnt (monitor) ( path recursive? mailbox -- monitor ) [ diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 33bb3a88b9..8e59a4d555 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -7,6 +7,7 @@ USE: io.windows.nt.backend USE: io.windows.nt.files USE: io.windows.nt.launcher USE: io.windows.nt.monitors +USE: io.windows.nt.privileges USE: io.windows.nt.sockets USE: io.windows.mmap USE: io.windows.files diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index aa565b52e8..97c2e49627 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays destructors io io.windows libc windows.types math.bitfields windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random -combinators accessors io.pipes io.nonblocking ; +combinators accessors io.pipes io.ports ; IN: io.windows.nt.pipes ! This code is based on @@ -17,10 +17,7 @@ IN: io.windows.nt.pipes 4096 0 security-attributes-inherit - CreateNamedPipe - dup win32-error=0/f - dup add-completion - f ; + CreateNamedPipe opened-file ; : open-other-end ( name -- handle ) GENERIC_WRITE @@ -29,10 +26,7 @@ IN: io.windows.nt.pipes OPEN_EXISTING FILE_FLAG_OVERLAPPED f - CreateFile - dup win32-error=0/f - dup add-completion - f ; + CreateFile opened-file ; : unique-pipe-name ( -- string ) [ @@ -47,7 +41,6 @@ IN: io.windows.nt.pipes M: winnt (pipe) ( -- pipe ) [ unique-pipe-name - [ create-named-pipe dup close-later ] - [ open-other-end dup close-later ] - bi pipe boa + [ create-named-pipe ] [ open-other-end ] bi + pipe boa ] with-destructors ; diff --git a/extra/io/windows/nt/privileges/privileges.factor b/extra/io/windows/nt/privileges/privileges.factor new file mode 100755 index 0000000000..007d05f9af --- /dev/null +++ b/extra/io/windows/nt/privileges/privileges.factor @@ -0,0 +1,53 @@ +USING: alien alien.c-types alien.syntax arrays continuations +destructors generic io.mmap io.ports io.windows io.windows.files +kernel libc math math.bitfields namespaces quotations sequences windows +windows.advapi32 windows.kernel32 io.backend system accessors +io.windows.privileges ; +IN: io.windows.nt.privileges + +TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES + +! Security tokens +! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ + +: (open-process-token) ( handle -- handle ) + { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" + [ OpenProcessToken win32-error=0/f ] keep *void* ; + +: open-process-token ( -- handle ) + #! remember to CloseHandle + GetCurrentProcess (open-process-token) ; + +: with-process-token ( quot -- ) + #! quot: ( token-handle -- token-handle ) + >r open-process-token r> + [ keep ] curry + [ CloseHandle drop ] [ ] cleanup ; inline + +: lookup-privilege ( string -- luid ) + >r f r> "LUID" + [ LookupPrivilegeValue win32-error=0/f ] keep ; + +: make-token-privileges ( name ? -- obj ) + "TOKEN_PRIVILEGES" + 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep + "LUID_AND_ATTRIBUTES" malloc-array &free + over set-TOKEN_PRIVILEGES-Privileges + + swap [ + SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges + set-LUID_AND_ATTRIBUTES-Attributes + ] when + + >r lookup-privilege r> + [ + TOKEN_PRIVILEGES-Privileges + >r 0 r> LUID_AND_ATTRIBUTES-nth + set-LUID_AND_ATTRIBUTES-Luid + ] keep ; + +M: winnt set-privilege ( name ? -- ) + [ + -rot 0 -rot make-token-privileges + dup length f f AdjustTokenPrivileges win32-error=0/f + ] with-process-token ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 79e767177d..a31c41942f 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,8 +1,9 @@ USING: alien alien.accessors alien.c-types byte-arrays -continuations destructors io.nonblocking io.timeouts io.sockets -io.sockets.impl io namespaces io.streams.duplex io.windows +continuations destructors io.ports io.timeouts io.sockets +io.sockets io namespaces io.streams.duplex io.windows +io.windows.sockets io.windows.nt.backend windows.winsock kernel libc math sequences -threads classes.tuple.lib system accessors ; +threads classes.tuple.lib system combinators accessors ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) @@ -30,121 +31,78 @@ TUPLE: ConnectEx-args port s* name* namelen* lpSendBuffer* dwSendDataLength* lpdwBytesSent* lpOverlapped* ptr* ; -: init-connect ( sockaddr size ConnectEx -- ) - [ set-ConnectEx-args-namelen* ] keep - [ set-ConnectEx-args-name* ] keep - f over set-ConnectEx-args-lpSendBuffer* - 0 over set-ConnectEx-args-dwSendDataLength* - f over set-ConnectEx-args-lpdwBytesSent* - (make-overlapped) swap set-ConnectEx-args-lpOverlapped* ; +: wait-for-socket ( args -- n ) + [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; -: (ConnectEx) ( ConnectEx -- ) - \ ConnectEx-args >tuple*< +: ( sockaddr size -- ConnectEx ) + ConnectEx-args new + swap >>namelen* + swap >>name* + f >>lpSendBuffer* + 0 >>dwSendDataLength* + f >>lpdwBytesSent* + (make-overlapped) >>lpOverlapped* ; + +: call-ConnectEx ( ConnectEx -- ) + ConnectEx-args >tuple*< "int" { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" } "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: connect-continuation ( ConnectEx port -- ) - >r ConnectEx-args-lpOverlapped* r> - 2dup save-callback - get-overlapped-result drop ; - -M: winnt ((client)) ( addrspec -- client-in client-out ) - [ - \ ConnectEx-args new - over make-sockaddr/size pick init-connect - over tcp-socket over set-ConnectEx-args-s* - dup ConnectEx-args-s* add-completion - dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr* - dup ConnectEx-args-s* INADDR_ANY roll bind-socket - dup (ConnectEx) - - dup ConnectEx-args-s* dup - >r [ connect-continuation ] keep [ pending-error ] keep r> - ] with-destructors ; +M: object establish-connection ( client-out remote -- ) + make-sockaddr/size + swap >>port + dup port>> handle>> handle>> >>s* + dup s*>> get-ConnectEx-ptr >>ptr* + dup call-ConnectEx + wait-for-socket drop ; TUPLE: AcceptEx-args port sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength* dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ; -: init-accept-buffer ( server-port AcceptEx -- ) - >r server-port-addr sockaddr-type heap-size 16 + - dup dup 2 * malloc dup free-always r> - [ set-AcceptEx-args-lpOutputBuffer* ] keep - [ set-AcceptEx-args-dwLocalAddressLength* ] keep - set-AcceptEx-args-dwRemoteAddressLength* ; +: init-accept-buffer ( addr AcceptEx -- ) + swap sockaddr-type heap-size 16 + + [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi + dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer* + drop ; -: init-accept ( server-port AcceptEx -- ) - [ init-accept-buffer ] 2keep - [ set-AcceptEx-args-port ] 2keep - >r port-handle win32-file-handle r> [ set-AcceptEx-args-sListenSocket* ] keep - dup AcceptEx-args-port server-port-addr tcp-socket - over set-AcceptEx-args-sAcceptSocket* - 0 over set-AcceptEx-args-dwReceiveDataLength* - f over set-AcceptEx-args-lpdwBytesReceived* - (make-overlapped) swap set-AcceptEx-args-lpOverlapped* ; +: ( server addr -- AcceptEx ) + AcceptEx-args new + 2dup init-accept-buffer + swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket* + over handle>> handle>> >>sListenSocket* + swap >>port + 0 >>dwReceiveDataLength* + f >>lpdwBytesReceived* + (make-overlapped) >>lpOverlapped* ; -: ((accept)) ( AcceptEx -- ) - \ AcceptEx-args >tuple*< - AcceptEx drop +: call-AcceptEx ( AcceptEx -- ) + AcceptEx-args >tuple*< AcceptEx drop winsock-error-string [ throw ] when* ; -: make-accept-continuation ( AcceptEx -- ) - dup AcceptEx-args-lpOverlapped* - swap AcceptEx-args-port save-callback ; +: extract-remote-address ( AcceptEx -- sockaddr ) + { + [ lpOutputBuffer*>> ] + [ dwReceiveDataLength*>> ] + [ dwLocalAddressLength*>> ] + [ dwRemoteAddressLength*>> ] + } cleave + f + 0 + f + [ 0 GetAcceptExSockaddrs ] keep *void* ; -: check-accept-error ( AcceptEx -- ) - dup AcceptEx-args-lpOverlapped* - swap AcceptEx-args-port get-overlapped-result drop ; - -: extract-remote-host ( AcceptEx -- addrspec ) +M: object (accept) ( server addr -- handle sockaddr ) [ - [ AcceptEx-args-lpOutputBuffer* ] keep - [ AcceptEx-args-dwReceiveDataLength* ] keep - [ AcceptEx-args-dwLocalAddressLength* ] keep - AcceptEx-args-dwRemoteAddressLength* - f - 0 - f [ - 0 GetAcceptExSockaddrs - ] keep *void* - ] keep AcceptEx-args-port server-port-addr parse-sockaddr ; - -: 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* ; - -M: winnt (accept) ( server -- addrspec handle ) - [ - [ - check-server-port - \ AcceptEx-args new - [ init-accept ] keep - [ ((accept)) ] keep - [ accept-continuation ] keep - AcceptEx-args-port pending-error - ] with-timeout - ] with-destructors ; - -M: winnt (server) ( addrspec -- handle ) - [ - SOCK_STREAM server-fd dup listen-on-socket - dup add-completion - - ] with-destructors ; - -M: winnt ( addrspec -- datagram ) - [ - [ - SOCK_DGRAM server-fd - dup add-completion - - ] keep + + { + [ call-AcceptEx ] + [ wait-for-socket drop ] + [ sAcceptSocket*>> ] + [ extract-remote-address ] + } cleave ] with-destructors ; TUPLE: WSARecvFrom-args port @@ -152,53 +110,37 @@ TUPLE: WSARecvFrom-args port lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ; : make-receive-buffer ( -- WSABUF ) - "WSABUF" malloc-object dup free-always + "WSABUF" malloc-object &free default-buffer-size get over set-WSABUF-len - default-buffer-size get malloc dup free-always over set-WSABUF-buf ; + default-buffer-size get malloc &free over set-WSABUF-buf ; -: init-WSARecvFrom ( datagram WSARecvFrom -- ) - [ set-WSARecvFrom-args-port ] 2keep - [ - >r handle>> handle>> r> - set-WSARecvFrom-args-s* - ] 2keep [ - >r datagram-port-addr sockaddr-type heap-size r> - 2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom* - >r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen* - ] keep - make-receive-buffer over set-WSARecvFrom-args-lpBuffers* - 1 over set-WSARecvFrom-args-dwBufferCount* - 0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags* - 0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd* - (make-overlapped) swap set-WSARecvFrom-args-lpOverlapped* ; - -: WSARecvFrom-continuation ( WSARecvFrom -- n ) - dup WSARecvFrom-args-lpOverlapped* - swap WSARecvFrom-args-port [ save-callback ] 2keep - get-overlapped-result ; +: ( datagram -- WSARecvFrom ) + WSARecvFrom-args new + swap >>port + dup port>> handle>> handle>> >>s* + dup port>> addr>> sockaddr-type heap-size + [ malloc &free >>lpFrom* ] + [ malloc-int &free >>lpFromLen* ] bi + make-receive-buffer >>lpBuffers* + 1 >>dwBufferCount* + 0 malloc-int &free >>lpFlags* + 0 malloc-int &free >>lpNumberOfBytesRecvd* + (make-overlapped) >>lpOverlapped* ; : call-WSARecvFrom ( WSARecvFrom -- ) - \ WSARecvFrom-args >tuple*< - WSARecvFrom - socket-error* ; + WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ; -: parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec ) - [ - WSARecvFrom-args-lpBuffers* WSABUF-buf - swap memory>byte-array - ] keep - [ WSARecvFrom-args-lpFrom* ] keep - WSARecvFrom-args-port datagram-port-addr parse-sockaddr ; +: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) + [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] + [ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ; -M: winnt receive ( datagram -- packet addrspec ) +M: winnt (receive) ( datagram -- packet addrspec ) [ - check-datagram-port - \ WSARecvFrom-args new - [ init-WSARecvFrom ] keep - [ call-WSARecvFrom ] keep - [ WSARecvFrom-continuation ] keep - [ WSARecvFrom-args-port pending-error ] keep - parse-WSARecvFrom + + [ call-WSARecvFrom ] + [ wait-for-socket ] + [ parse-WSARecvFrom ] + tri ] with-destructors ; TUPLE: WSASendTo-args port @@ -206,49 +148,32 @@ TUPLE: WSASendTo-args port dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ; : make-send-buffer ( packet -- WSABUF ) - "WSABUF" malloc-object dup free-always - over malloc-byte-array dup free-always over set-WSABUF-buf - swap length over set-WSABUF-len ; + "WSABUF" malloc-object &free + [ >r malloc-byte-array &free r> set-WSABUF-buf ] + [ >r length r> set-WSABUF-len ] + [ nip ] + 2tri ; -: init-WSASendTo ( packet addrspec datagram WSASendTo -- ) - [ set-WSASendTo-args-port ] 2keep - [ - >r port-handle win32-file-handle r> set-WSASendTo-args-s* - ] keep - [ - >r make-sockaddr/size >r - malloc-byte-array dup free-always - r> r> - [ set-WSASendTo-args-iToLen* ] keep - set-WSASendTo-args-lpTo* - ] keep - [ - >r make-send-buffer r> set-WSASendTo-args-lpBuffers* - ] keep - 1 over set-WSASendTo-args-dwBufferCount* - 0 over set-WSASendTo-args-dwFlags* - 0 over set-WSASendTo-args-lpNumberOfBytesSent* - (make-overlapped) swap set-WSASendTo-args-lpOverlapped* ; - -: WSASendTo-continuation ( WSASendTo -- ) - dup WSASendTo-args-lpOverlapped* - swap WSASendTo-args-port - [ save-callback ] 2keep - get-overlapped-result drop ; +: ( packet addrspec datagram -- WSASendTo ) + WSASendTo-args new + swap >>port + dup port>> handle>> handle>> >>s* + swap make-sockaddr/size + >r malloc-byte-array &free + r> [ >>lpTo* ] [ >>iToLen* ] bi* + swap make-send-buffer >>lpBuffers* + 1 >>dwBufferCount* + 0 >>dwFlags* + 0 >>lpNumberOfBytesSent* + (make-overlapped) >>lpOverlapped* ; : call-WSASendTo ( WSASendTo -- ) - \ WSASendTo-args >tuple*< - WSASendTo socket-error* ; + WSASendTo-args >tuple*< WSASendTo socket-error* ; -USE: io.sockets - -M: winnt send ( packet addrspec datagram -- ) +M: winnt (send) ( packet addrspec datagram -- ) [ - check-datagram-send - \ WSASendTo-args new - [ init-WSASendTo ] keep - [ call-WSASendTo ] keep - [ WSASendTo-continuation ] keep - WSASendTo-args-port pending-error + + [ call-WSASendTo ] + [ wait-for-socket drop ] + bi ] with-destructors ; - diff --git a/extra/io/windows/privileges/privileges.factor b/extra/io/windows/privileges/privileges.factor new file mode 100755 index 0000000000..144c799912 --- /dev/null +++ b/extra/io/windows/privileges/privileges.factor @@ -0,0 +1,8 @@ +USING: io.backend kernel continuations sequences ; +IN: io.windows.privileges + +HOOK: set-privilege io-backend ( name ? -- ) inline + +: with-privileges ( seq quot -- ) + over [ [ t set-privilege ] each ] curry compose + swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline diff --git a/extra/io/windows/sockets/sockets.factor b/extra/io/windows/sockets/sockets.factor new file mode 100755 index 0000000000..359776d639 --- /dev/null +++ b/extra/io/windows/sockets/sockets.factor @@ -0,0 +1,62 @@ +USING: kernel accessors io.sockets io.windows io.backend +windows.winsock system destructors alien.c-types ; +IN: io.windows.sockets + +HOOK: WSASocket-flags io-backend ( -- DWORD ) + +TUPLE: win32-socket < win32-file ; + +: ( handle -- win32-socket ) + win32-socket new + swap >>handle ; + +M: win32-socket dispose ( stream -- ) + handle>> closesocket drop ; + +: unspecific-sockaddr/size ( addrspec -- sockaddr len ) + [ empty-sockaddr/size ] [ protocol-family ] bi + pick set-sockaddr-in-family ; + +: opened-socket ( handle -- win32-socket ) + |dispose dup add-completion ; + +: open-socket ( addrspec type -- win32-socket ) + >r protocol-family r> + 0 f 0 WSASocket-flags WSASocket + dup socket-error + opened-socket ; + +M: object (get-local-address) ( socket addrspec -- sockaddr ) + >r handle>> r> empty-sockaddr/size + [ getsockname socket-error ] 2keep drop ; + +M: object (get-remote-address) ( socket addrspec -- sockaddr ) + >r handle>> r> empty-sockaddr/size + [ getpeername socket-error ] 2keep drop ; + +: bind-socket ( win32-socket sockaddr len -- ) + >r >r handle>> r> r> bind socket-error ; + +M: object ((client)) ( addrspec -- handle ) + [ SOCK_STREAM open-socket ] keep + [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ; + +: server-socket ( addrspec type -- fd ) + [ open-socket ] [ drop ] 2bi + [ make-sockaddr/size bind-socket ] [ drop ] 2bi ; + +! http://support.microsoft.com/kb/127144 +! NOTE: Possibly tweak this because of SYN flood attacks +: listen-backlog ( -- n ) HEX: 7fffffff ; inline + +M: object (server) ( addrspec -- handle ) + [ + SOCK_STREAM server-socket + dup handle>> listen-backlog listen winsock-return-check + ] with-destructors ; + +M: windows (datagram) ( addrspec -- handle ) + [ SOCK_DGRAM server-socket ] with-destructors ; + +M: windows addrinfo-error ( n -- ) + winsock-return-check ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 85c448bdbd..30b72f3e2f 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -1,25 +1,37 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend -io.buffers io.files io.nonblocking io.sockets io.binary -io.sockets.impl windows.errors strings +io.buffers io.files io.ports io.sockets io.binary +io.sockets windows.errors strings kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting continuations math.bitfields system accessors ; IN: io.windows -M: windows destruct-socket closesocket drop ; +TUPLE: win32-handle handle disposed ; -TUPLE: win32-file handle ptr ; +: new-win32-handle ( handle class -- win32-handle ) + new swap >>handle ; -C: win32-file +: ( handle -- win32-handle ) + win32-handle new-win32-handle ; + +M: win32-handle dispose* ( handle -- ) + handle>> CloseHandle drop ; + +TUPLE: win32-file < win32-handle ptr ; + +: ( handle -- win32-file ) + win32-file new-win32-handle ; HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) -M: windows normalize-directory ( string -- string ) - normalize-path "\\" ?tail drop "\\*" append ; +: opened-file ( handle -- win32-file ) + dup invalid-handle? + |dispose + dup add-completion ; : share-mode ( -- fixnum ) { @@ -36,162 +48,3 @@ M: windows normalize-directory ( string -- string ) : security-attributes-inherit ( -- obj ) default-security-attributes TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable - -M: win32-file init-handle ( handle -- ) - drop ; - -M: win32-file close-handle ( handle -- ) - win32-file-handle close-handle ; - -M: alien close-handle ( handle -- ) - CloseHandle drop ; - -! Clean up resources (open handle) if add-completion fails -: open-file ( path access-mode create-mode flags -- handle ) - [ - >r >r share-mode security-attributes-inherit r> r> - CreateFile-flags f CreateFile - dup invalid-handle? dup close-later - dup add-completion - ] with-destructors ; - -: open-pipe-r/w ( path -- handle ) - { GENERIC_READ GENERIC_WRITE } flags - OPEN_EXISTING 0 open-file ; - -: open-read ( path -- handle length ) - GENERIC_READ OPEN_EXISTING 0 open-file 0 ; - -: open-write ( path -- handle length ) - GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ; - -: (open-append) ( path -- handle ) - GENERIC_WRITE OPEN_ALWAYS 0 open-file ; - -: open-existing ( path -- handle ) - { GENERIC_READ GENERIC_WRITE } flags - share-mode - f - OPEN_EXISTING - FILE_FLAG_BACKUP_SEMANTICS - f CreateFileW dup win32-error=0/f ; - -: maybe-create-file ( path -- handle ? ) - #! return true if file was just created - { GENERIC_READ GENERIC_WRITE } flags - share-mode - f - OPEN_ALWAYS - 0 CreateFile-flags - f CreateFileW dup win32-error=0/f - GetLastError ERROR_ALREADY_EXISTS = not ; - -: set-file-pointer ( handle length method -- ) - >r dupd d>w/w r> SetFilePointer - INVALID_SET_FILE_POINTER = [ - CloseHandle "SetFilePointer failed" throw - ] when drop ; - -HOOK: open-append os ( path -- handle length ) - -TUPLE: FileArgs - hFile lpBuffer nNumberOfBytesToRead - lpNumberOfBytesRet lpOverlapped ; - -C: FileArgs - -: make-FileArgs ( port -- ) - [ port-handle win32-file-handle ] keep - [ buffer>> ] keep - [ - buffer>> buffer-length - "DWORD" - ] keep FileArgs-overlapped ; - -: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) - [ FileArgs-hFile ] keep - [ FileArgs-lpBuffer buffer-end ] keep - [ FileArgs-lpBuffer buffer-capacity ] keep - [ FileArgs-lpNumberOfBytesRet ] keep - FileArgs-lpOverlapped ; - -: setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) - [ FileArgs-hFile ] keep - [ FileArgs-lpBuffer buffer@ ] keep - [ FileArgs-lpBuffer buffer-length ] keep - [ FileArgs-lpNumberOfBytesRet ] keep - FileArgs-lpOverlapped ; - -M: windows (file-reader) ( path -- stream ) - open-read ; - -M: windows (file-writer) ( path -- stream ) - open-write ; - -M: windows (file-appender) ( path -- stream ) - open-append ; - -M: windows move-file ( from to -- ) - [ normalize-path ] bi@ MoveFile win32-error=0/f ; - -M: windows delete-file ( path -- ) - normalize-path DeleteFile win32-error=0/f ; - -M: windows copy-file ( from to -- ) - dup parent-directory make-directories - [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; - -M: windows make-directory ( path -- ) - normalize-path - f CreateDirectory win32-error=0/f ; - -M: windows delete-directory ( path -- ) - normalize-path - RemoveDirectory win32-error=0/f ; - -HOOK: WSASocket-flags io-backend ( -- DWORD ) - -TUPLE: win32-socket < win32-file ; - -: ( handle -- win32-socket ) - f win32-file boa ; - -: open-socket ( family type -- socket ) - 0 f 0 WSASocket-flags WSASocket dup socket-error ; - -USE: windows.winsock -: init-sockaddr ( port# addrspec -- sockaddr ) - dup sockaddr-type - [ swap protocol-family swap set-sockaddr-in-family ] keep - [ >r htons r> set-sockaddr-in-port ] keep ; - -: server-sockaddr ( port# addrspec -- sockaddr ) - init-sockaddr - [ INADDR_ANY swap set-sockaddr-in-addr ] keep ; - -: bind-socket ( socket sockaddr addrspec -- ) - [ server-sockaddr ] keep - sockaddr-type heap-size bind socket-error ; - -: server-fd ( addrspec type -- fd ) - >r dup protocol-family r> open-socket - dup close-socket-later - dup rot make-sockaddr/size bind socket-error ; - -USE: namespaces - -! http://support.microsoft.com/kb/127144 -! NOTE: Possibly tweak this because of SYN flood attacks -: listen-backlog ( -- n ) HEX: 7fffffff ; inline - -: listen-on-socket ( socket -- ) - listen-backlog listen winsock-return-check ; - -M: win32-socket dispose ( stream -- ) - win32-file-handle closesocket drop ; - -M: windows addrinfo-error ( n -- ) - winsock-return-check ; - -: tcp-socket ( addrspec -- socket ) - protocol-family SOCK_STREAM open-socket ; diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 1db17278ad..9a278fb67f 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -3,7 +3,7 @@ USING: arrays calendar combinators channels concurrency.messaging fry io io.encodings.8-bit io.sockets kernel math namespaces sequences sequences.lib splitting strings threads - continuations classes.tuple ascii accessors ; + continuations destructors classes.tuple ascii accessors ; IN: irc ! utils @@ -143,7 +143,7 @@ SYMBOL: irc-client " hostname servername :irc.factor" irc-print ; : CONNECT ( server port -- stream ) - latin1 ; + latin1 drop ; : JOIN ( channel password -- ) "JOIN " irc-write diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index dcb82d1de0..938605ce9f 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ; +USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ; IN: jamshred.game TUPLE: jamshred sounds tunnel players running quit ; @@ -29,3 +29,12 @@ TUPLE: jamshred sounds tunnel players running quit ; : mouse-moved ( x-radians y-radians jamshred -- ) jamshred-player -rot turn-player ; +: units-per-full-roll ( -- n ) 50 ; + +: jamshred-roll ( jamshred n -- ) + [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ; + +: mouse-scroll-x ( jamshred x -- ) jamshred-roll ; + +: mouse-scroll-y ( jamshred y -- ) + neg swap jamshred-player change-player-speed ; diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 58e2b1f882..fffc97b4c6 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -51,18 +51,18 @@ IN: jamshred.gl GL_LIGHT0 glEnable GL_FOG glEnable GL_FOG_DENSITY 0.09 glFogf + GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial GL_COLOR_MATERIAL glEnable - GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial - GL_LIGHT0 GL_POSITION F{ 0.0 0.0 -3.0 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ; : player-view ( player -- ) - [ location>> first3 ] - [ [ location>> ] [ forward>> ] bi v+ first3 ] - [ up>> first3 ] tri gluLookAt ; + [ location>> ] + [ [ location>> ] [ forward>> ] bi v+ ] + [ up>> ] tri gl-look-at ; : draw-jamshred ( jamshred width height -- ) - init-graphics jamshred-player dup player-view draw-tunnel ; + init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 3fb7113fde..078a23f5db 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -21,9 +21,9 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) dup jamshred>> quit>> [ drop ] [ - dup [ jamshred>> jamshred-update ] - [ relayout-1 ] bi - yield jamshred-loop + [ jamshred>> jamshred-update ] + [ relayout-1 ] + [ yield jamshred-loop ] tri ] if ; : fullscreen ( gadget -- ) @@ -45,7 +45,7 @@ M: jamshred-gadget ungraft* ( gadget -- ) >>jamshred drop ; : pix>radians ( n m -- theta ) - 2 / / pi 2 * * ; + / pi 4 * * ; ! 2 / / pi 2 * * ; : x>radians ( x gadget -- theta ) #! translate motion of x pixels to an angle @@ -68,8 +68,9 @@ M: jamshred-gadget ungraft* ( gadget -- ) ] 2keep >>last-hand-loc drop ; : handle-mouse-scroll ( jamshred-gadget -- ) - jamshred>> jamshred-player scroll-direction get - second neg swap change-player-speed ; + jamshred>> scroll-direction get + [ first mouse-scroll-x ] + [ second mouse-scroll-y ] 2bi ; : quit ( gadget -- ) [ no-fullscreen ] [ close-window ] bi ; @@ -78,6 +79,10 @@ jamshred-gadget H{ { T{ key-down f f "r" } [ jamshred-restart ] } { T{ key-down f f " " } [ jamshred>> toggle-running ] } { T{ key-down f f "f" } [ find-world toggle-fullscreen ] } + { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] } + { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] } + { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] } + { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] } { T{ key-down f f "q" } [ quit ] } { T{ motion } [ handle-mouse-motion ] } { T{ mouse-scroll } [ handle-mouse-scroll ] } diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index e2104b6f41..d50a93a3d2 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -29,6 +29,9 @@ C: oint : up-pivot ( oint theta -- ) over up>> rotate-oint ; +: forward-pivot ( oint theta -- ) + over forward>> rotate-oint ; + : random-float+- ( n -- m ) #! find a random float between -n/2 and n/2 dup 10000 * >fixnum random 10000 / swap 2 / - ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index bea4ab4836..8dc5125143 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ; +USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ; IN: jamshred.player TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; @@ -16,6 +16,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : turn-player ( player x-radians y-radians -- ) >r over r> left-pivot up-pivot ; +: roll-player ( player z-radians -- ) + forward-pivot ; + : to-tunnel-start ( player -- ) [ tunnel>> first dup location>> ] [ tuck (>>location) (>>nearest-segment) ] bi ; @@ -35,6 +38,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : change-player-speed ( inc player -- ) [ + speed-range clamp-to-range ] change-speed drop ; +: multiply-player-speed ( n player -- ) + [ * speed-range clamp-to-range ] change-speed drop ; + : distance-to-move ( player -- distance ) [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ] [ (>>last-move) ] tri ; @@ -43,8 +49,12 @@ DEFER: (move-player) : ?bounce ( distance-remaining player -- ) over 0 > [ - [ dup nearest-segment>> bounce ] [ sounds>> bang ] - [ (move-player) ] tri + { + [ dup nearest-segment>> bounce ] + [ sounds>> bang ] + [ 3/4 swap multiply-player-speed ] + [ (move-player) ] + } cleave ] [ 2drop ] if ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index c6755318e6..903ff94739 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; +USING: arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ; IN: jamshred.tunnel.tests [ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } @@ -41,4 +41,5 @@ IN: jamshred.tunnel.tests [ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test [ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test -[ { 0 1 0 } ] [ simple-collision-up collision-vector ] unit-test +[ { 0 1 0 } ] +[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index f3fa9a0354..5cf1e33e64 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -126,10 +126,14 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; +: bounce-offset 0.1 ; inline + +: bounce-radius ( segment -- r ) + radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?) + : collision-vector ( oint segment -- v ) [ sideways-heading ] [ sideways-relative-location ] - [ radius>> 0.1 - ] ! bounce before we hit so that we can't see through the wall (hack?) - 2tri + [ bounce-radius ] 2tri swap [ collision-coefficient ] dip forward>> n*v ; : distance-to-collision ( oint segment -- distance ) diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index aecae1cf88..4194ff6609 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -148,7 +148,7 @@ DEFER: (d) : nth-basis-elt ( generators n -- elt ) over length [ 3dup bit? [ nth ] [ 2drop f ] if - ] map [ ] filter 2nip ; + ] map sift 2nip ; : basis ( generators -- seq ) natural-sort dup length 2^ [ nth-basis-elt ] with map ; diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index ec376569f0..df37de2475 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -1,13 +1,9 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp lisp.parser tools.test sequences math kernel ; +USING: lisp lisp.parser tools.test sequences math kernel parser ; IN: lisp.test -{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [ - "(foo 1 2 \"aoeu\")" lisp-string>factor -] unit-test - init-env "+" [ first2 + ] lisp-define @@ -17,5 +13,7 @@ init-env ] unit-test { 3 } [ - "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call + [ + "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call + ] with-interactive-vocabs ] unit-test \ No newline at end of file diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 7d4b9af02a..3e4cdca41f 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -26,27 +26,30 @@ DEFER: funcall unclip convert-form swap convert-body [ , % funcall ] bake ; > swap member? [ name>> make-local ] [ ] if ] - [ dup s-exp? [ body>> localize-body ] [ nip ] if ] if - ] with map ; +: localize-body ( assoc body -- assoc newbody ) + [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ] + [ dup s-exp? [ body>> localize-body ] when ] if + ] map ; : localize-lambda ( body vars -- newbody newvars ) - dup make-locals dup push-locals [ swap localize-body convert-form ] dipd - pop-locals swap ; + make-locals dup push-locals swap + [ swap localize-body convert-form swap pop-locals ] dip swap ; PRIVATE> : split-lambda ( s-exp -- body vars ) - first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline + first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline -: rest-lambda-vars ( seq -- n newseq ) - "&rest" swap [ remove ] [ index ] 2bi ; +: rest-lambda ( body vars -- quot ) + "&rest" swap [ remove ] [ index ] 2bi + [ localize-lambda ] dip + [ , cut swap [ % , ] bake , compose ] bake ; + +: normal-lambda ( body vars -- quot ) + localize-lambda [ , compose ] bake ; : convert-lambda ( s-exp -- quot ) - split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if - [ localize-lambda ] dip - [ , cut [ dup length firstn ] dip dup empty? [ drop ] when , ] bake ; + split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ; : convert-quoted ( s-exp -- quot ) second [ , ] bake ; @@ -64,16 +67,16 @@ PRIVATE> [ drop convert-general-form ] if ; : convert-form ( lisp-form -- quot ) - { { [ dup s-exp? ] [ body>> convert-list-form ] } - [ [ , ] [ ] make ] - } cond ; - + dup s-exp? [ body>> convert-list-form ] + [ [ , ] [ ] make ] if ; + : lisp-string>factor ( str -- quot ) - lisp-expr parse-result-ast convert-form ; + lisp-expr parse-result-ast convert-form lambda-rewrite call ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env +ERROR: no-such-var var ; : init-env ( -- ) H{ } clone lisp-env set ; @@ -82,7 +85,7 @@ SYMBOL: lisp-env swap lisp-env get set-at ; : lisp-get ( name -- word ) - lisp-env get at ; + dup lisp-env get at [ ] [ no-such-var ] ?if ; : funcall ( quot sym -- * ) dup lisp-symbol? [ name>> lisp-get ] when call ; inline \ No newline at end of file diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 9e6b54ab0c..98a6d2a6ba 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -8,6 +8,14 @@ IN: lisp.parser.tests "1234" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test +{ -42 } [ + "-42" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ 37/52 } [ + "37/52" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + { 123.98 } [ "123.98" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 65ad01aa6f..32886f9367 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib ; +combinators.lib math ; IN: lisp.parser @@ -18,9 +18,11 @@ RPAREN = ")" dquote = '"' squote = "'" digit = [0-9] -integer = (digit)+ => [[ string>number ]] -float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]] +integer = ("-")? (digit)+ => [[ first2 append string>number ]] +float = integer "." (digit)* => [[ first3 >string [ number>string ] dipd 3append string>number ]] +rational = integer "/" (digit)+ => [[ first3 nip string>number / ]] number = float + | rational | integer id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index 5c3d2005a8..c5adaa5e5e 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -246,3 +246,11 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; : no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ; [ { 4 5 6 } ] [ no-with-locals-test ] unit-test + +{ 3 0 } [| a b c | ] must-infer-as + +[ ] [ 1 [let | a [ ] | ] ] unit-test + +[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test + +[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index d4fc920b25..af4f1a77b6 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -116,7 +116,9 @@ UNION: special local quote local-word local-reader local-writer ; 2tri 3append >quotation ; : point-free ( quot args -- newquot ) - over empty? [ drop ] [ (point-free) ] if ; + over empty? + [ nip length \ drop >quotation ] + [ (point-free) ] if ; UNION: lexical local local-reader local-writer local-word ; @@ -355,30 +357,34 @@ M: wlet pprint* \ [wlet pprint-let ; M: let* pprint* \ [let* pprint-let ; -PREDICATE: lambda-word < word - "lambda" word-prop >boolean ; +PREDICATE: lambda-word < word "lambda" word-prop >boolean ; M: lambda-word definer drop \ :: \ ; ; M: lambda-word definition "lambda" word-prop body>> ; -PREDICATE: lambda-macro < macro - "lambda" word-prop >boolean ; +INTERSECTION: lambda-macro macro lambda-word ; M: lambda-macro definer drop \ MACRO:: \ ; ; M: lambda-macro definition "lambda" word-prop body>> ; -PREDICATE: lambda-method < method-body - "lambda" word-prop >boolean ; +INTERSECTION: lambda-method method-body lambda-word ; M: lambda-method definer drop \ M:: \ ; ; M: lambda-method definition "lambda" word-prop body>> ; +INTERSECTION: lambda-memoized memoized lambda-word ; + +M: lambda-memoized definer drop \ MEMO:: \ ; ; + +M: lambda-memoized definition + "lambda" word-prop body>> ; + : method-stack-effect ( method -- effect ) dup "lambda" word-prop vars>> swap "method-generic" word-prop stack-effect diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 3bc8637f90..2a4e34e015 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 -io.encodings.utf8 ; +io.sockets continuations destructors prettyprint assocs +math.parser words debugger math combinators +concurrency.messaging threads arrays init math.ranges strings +calendar.format io.encodings.utf8 ; IN: logging.server : log-root ( -- string ) @@ -37,7 +37,7 @@ SYMBOL: log-files write bl write ": " write print ; : write-message ( msg word-name level -- ) - rot [ empty? not ] filter { + rot harvest { { [ dup empty? ] [ 3drop ] } { [ dup length 1 = ] [ first -rot f (write-message) ] } [ diff --git a/extra/money/money.factor b/extra/money/money.factor index 4584daf592..1fd0a66555 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -15,17 +15,14 @@ IN: money "." % number>string 2 CHAR: 0 pad-left % ] "" make print ; -TUPLE: not-a-decimal ; - -: not-a-decimal ( -- * ) - T{ not-a-decimal } throw ; +ERROR: not-a-decimal x ; : parse-decimal ( str -- ratio ) "." split1 >r dup "-" head? [ drop t "0" ] [ f swap ] if r> [ dup empty? [ drop "0" ] when ] bi@ dup length - >r [ string>number dup [ not-a-decimal ] unless ] bi@ r> + >r [ dup string>number [ nip ] [ not-a-decimal ] if* ] bi@ r> 10 swap ^ / + swap [ neg ] when ; : DECIMAL: diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index 9bfdc6b50c..144448917f 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -9,5 +9,5 @@ USING: arrays morse strings tools.test ; [ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test [ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test [ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test -[ ] [ "sos" 0.075 play-as-morse* ] unit-test -[ ] [ "Factor rocks!" play-as-morse ] unit-test +! [ ] [ "sos" 0.075 play-as-morse* ] unit-test +! [ ] [ "Factor rocks!" play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index ecade14cdb..9d335896be 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,8 +1,6 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: assocs combinators hashtables kernel lazy-lists math namespaces -openal openal.waves parser-combinators promises sequences strings symbols -unicode.case ; +USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ; IN: morse ( -- buffer ) + half-sample-freq <8bit-mono-buffer> ; + : sine-buffer ( seconds -- id ) - >r 8 22000 880 r> send-buffer* ; + beep-freq swap >sine-wave-buffer + send-buffer id>> ; : silent-buffer ( seconds -- id ) - 8 22000 rot send-buffer* ; + >silent-buffer send-buffer id>> ; : make-buffers ( unit-length -- ) { diff --git a/extra/morse/summary.txt b/extra/morse/summary.txt new file mode 100644 index 0000000000..2c1f091a9a --- /dev/null +++ b/extra/morse/summary.txt @@ -0,0 +1 @@ +Converts between text and morse code, and plays morse code. diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index c0a79d8353..38d61a8823 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -235,13 +235,13 @@ SYMBOL: init : init-openal ( -- ) init get-global expired? [ - f f alutInit drop + f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when 1337 init set-global ] when ; : exit-openal ( -- ) init get-global expired? [ - alutExit drop + alutExit 0 = [ "Could not close OpenAL" throw ] when f init set-global ] unless ; diff --git a/extra/openal/waves/waves-tests.factor b/extra/openal/waves/waves-tests.factor deleted file mode 100644 index b295283aac..0000000000 --- a/extra/openal/waves/waves-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: kernel openal openal.waves sequences tools.test ; -IN: openal.waves.tests - - -[ ] [ 8 22000 440 1 play-sine-wave ] unit-test diff --git a/extra/openal/waves/waves.factor b/extra/openal/waves/waves.factor deleted file mode 100644 index abe9f8fb69..0000000000 --- a/extra/openal/waves/waves.factor +++ /dev/null @@ -1,53 +0,0 @@ -USING: accessors alien.c-types combinators kernel locals math -math.constants math.functions math.ranges openal sequences ; -IN: openal.waves - -TUPLE: buffer bits channels sample-freq seq id ; - -: ( bits sample-freq seq -- buffer ) - ! defaults to 1 channel - 1 -rot gen-buffer buffer boa ; - -: buffer-format ( buffer -- format ) - dup buffer-channels 1 = swap buffer-bits 8 = [ - AL_FORMAT_MONO8 AL_FORMAT_STEREO8 - ] [ - AL_FORMAT_MONO16 AL_FORMAT_STEREO16 - ] if ? ; - -: buffer-data ( buffer -- data size ) - #! 8 bit data is integers between 0 and 255, - #! 16 bit data is integers between -32768 and 32768 - #! size is in bytes - [ seq>> ] [ bits>> ] bi 8 = [ - [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi - ] [ - [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi - ] if ; - -: send-buffer ( buffer -- ) - { [ id>> ] [ buffer-format ] [ buffer-data ] [ sample-freq>> ] } cleave - alBufferData ; - -: send-buffer* ( buffer -- id ) - [ send-buffer ] [ id>> ] bi ; - -: (sine-wave-seq) ( samples/wave n-samples -- seq ) - pi 2 * rot / [ * sin ] curry map ; - -: sine-wave-seq ( sample-freq freq seconds -- seq ) - pick * >integer [ / ] dip (sine-wave-seq) ; - -: ( bits sample-freq freq seconds -- buffer ) - >r dupd r> sine-wave-seq ; - -: ( bits sample-freq seconds -- buffer ) - dupd * >integer [ drop 0 ] map ; - -: play-sine-wave ( bits sample-freq freq seconds -- ) - init-openal - send-buffer* - 1 gen-sources first - [ AL_BUFFER rot set-source-param ] [ source-play ] bi - check-error ; - diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index ee58a4e345..a6e76cdc9e 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -154,7 +154,7 @@ MACRO: set-draw-buffers ( buffers -- ) swap glPushAttrib call glPopAttrib ; inline : gl-look-at ( eye focus up -- ) - >r >r first3 r> first3 r> first3 gluLookAt ; + [ first3 ] tri@ gluLookAt ; TUPLE: sprite loc dim dim2 dlist texture ; diff --git a/unmaintained/openssl/authors.txt b/extra/openssl/authors.txt similarity index 100% rename from unmaintained/openssl/authors.txt rename to extra/openssl/authors.txt diff --git a/unmaintained/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor similarity index 73% rename from unmaintained/openssl/libcrypto/libcrypto.factor rename to extra/openssl/libcrypto/libcrypto.factor index 312c7b04b3..20b606db66 100755 --- a/unmaintained/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -88,6 +88,8 @@ FUNCTION: int BIO_puts ( void* bp, char* buf ) ; FUNCTION: ulong ERR_get_error ( ) ; +FUNCTION: void ERR_clear_error ( ) ; + FUNCTION: char* ERR_error_string ( ulong e, void* buf ) ; FUNCTION: void* BIO_f_buffer ( ) ; @@ -96,6 +98,17 @@ FUNCTION: void* BIO_f_buffer ( ) ; ! evp.h ! =============================================== +: EVP_MAX_MD_SIZE 64 ; + +C-STRUCT: EVP_MD_CTX + { "EVP_MD*" "digest" } + { "ENGINE*" "engine" } + { "ulong" "flags" } + { "void*" "md_data" } ; + +TYPEDEF: void* EVP_MD* +TYPEDEF: void* ENGINE* + ! Initialize ciphers and digest tables FUNCTION: void OpenSSL_add_all_ciphers ( ) ; @@ -104,19 +117,35 @@ FUNCTION: void OpenSSL_add_all_digests ( ) ; ! Clean them up before exiting FUNCTION: void EVP_cleanup ( ) ; -FUNCTION: void* EVP_get_digestbyname ( char* name ) ; +FUNCTION: EVP_MD* EVP_get_digestbyname ( char* name ) ; -FUNCTION: void EVP_MD_CTX_init ( void* ctx ) ; +FUNCTION: void EVP_MD_CTX_init ( EVP_MD* ctx ) ; + +FUNCTION: int EVP_MD_CTX_cleanup ( EVP_MD_CTX* ctx ) ; + +FUNCTION: EVP_MD_CTX* EVP_MD_CTX_create ( ) ; + +FUNCTION: void EVP_MD_CTX_destroy ( EVP_MD_CTX* ctx ) ; + +FUNCTION: int EVP_MD_CTX_copy_ex ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ; + +FUNCTION: int EVP_DigestInit_ex ( EVP_MD_CTX* ctx, EVP_MD* type, ENGINE* impl ) ; + +FUNCTION: int EVP_DigestUpdate ( EVP_MD_CTX* ctx, void* d, uint cnt ) ; + +FUNCTION: int EVP_DigestFinal_ex ( EVP_MD_CTX* ctx, void* md, uint* s ) ; + +FUNCTION: int EVP_Digest ( void* data, uint count, void* md, uint* size, EVP_MD* type, ENGINE* impl ) ; + +FUNCTION: int EVP_MD_CTX_copy ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ; + +FUNCTION: int EVP_DigestInit ( EVP_MD_CTX* ctx, EVP_MD* type ) ; + +FUNCTION: int EVP_DigestFinal ( EVP_MD_CTX* ctx, void* md, uint* s ) ; FUNCTION: void* PEM_read_bio_DHparams ( void* bp, void* x, void* cb, void* u ) ; -! =============================================== -! md5.h -! =============================================== - -FUNCTION: uchar* MD5 ( uchar* d, ulong n, uchar* md ) ; - ! =============================================== ! rsa.h ! =============================================== diff --git a/unmaintained/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor similarity index 64% rename from unmaintained/openssl/libssl/libssl.factor rename to extra/openssl/libssl/libssl.factor index 0f2e7b3184..f5680972f3 100755 --- a/unmaintained/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -5,7 +5,8 @@ ! ! export LD_LIBRARY_PATH=/opt/local/lib -USING: alien alien.syntax combinators kernel system ; +USING: alien alien.syntax combinators kernel system namespaces +assocs parser sequences words quotations ; IN: openssl.libssl @@ -97,6 +98,7 @@ FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ; ! Load the certificates and private keys into the SSL_CTX FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx, char* file ) ; ! PEM type + FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ; FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ; @@ -117,10 +119,21 @@ FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ; FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ; -FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ; FUNCTION: void SSL_free ( ssl-pointer ssl ) ; +FUNCTION: int SSL_want ( ssl-pointer ssl ) ; + +: SSL_NOTHING 1 ; inline +: SSL_WRITING 2 ; inline +: SSL_READING 3 ; inline +: SSL_X509_LOOKUP 4 ; inline + +FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ; + +FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ; + FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ; FUNCTION: void RAND_seed ( void* buf, int num ) ; @@ -164,11 +177,87 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ; FUNCTION: void* BIO_f_ssl ( ) ; +: SSL_CTX_set_tmp_rsa ( ctx rsa -- n ) + >r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ; + +: SSL_CTX_set_tmp_dh ( ctx dh -- n ) + >r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ; + ! =============================================== -! sha.h +! x509.h ! =============================================== -! For a high level interface to message digests -! use the EVP digest routines in libcrypto.factor +TYPEDEF: void* X509_NAME* -FUNCTION: uchar* SHA1 ( uchar* d, ulong n, uchar* md ) ; +TYPEDEF: void* X509* + +FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ; +FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ; + +! =============================================== +! x509_vfy.h +! =============================================== + +<< + +SYMBOL: verify-messages + +H{ } clone verify-messages set-global + +: verify-message ( n -- word ) verify-messages get-global at ; + +: X509_V_: + scan "X509_V_" prepend create-in + scan-word + [ 1quotation define-inline ] + [ verify-messages get set-at ] 2bi ; parsing + +>> + +X509_V_: OK 0 +X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT 2 +X509_V_: ERR_UNABLE_TO_GET_CRL 3 +X509_V_: ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4 +X509_V_: ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5 +X509_V_: ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6 +X509_V_: ERR_CERT_SIGNATURE_FAILURE 7 +X509_V_: ERR_CRL_SIGNATURE_FAILURE 8 +X509_V_: ERR_CERT_NOT_YET_VALID 9 +X509_V_: ERR_CERT_HAS_EXPIRED 10 +X509_V_: ERR_CRL_NOT_YET_VALID 11 +X509_V_: ERR_CRL_HAS_EXPIRED 12 +X509_V_: ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13 +X509_V_: ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14 +X509_V_: ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15 +X509_V_: ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16 +X509_V_: ERR_OUT_OF_MEM 17 +X509_V_: ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18 +X509_V_: ERR_SELF_SIGNED_CERT_IN_CHAIN 19 +X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20 +X509_V_: ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21 +X509_V_: ERR_CERT_CHAIN_TOO_LONG 22 +X509_V_: ERR_CERT_REVOKED 23 +X509_V_: ERR_INVALID_CA 24 +X509_V_: ERR_PATH_LENGTH_EXCEEDED 25 +X509_V_: ERR_INVALID_PURPOSE 26 +X509_V_: ERR_CERT_UNTRUSTED 27 +X509_V_: ERR_CERT_REJECTED 28 +X509_V_: ERR_SUBJECT_ISSUER_MISMATCH 29 +X509_V_: ERR_AKID_SKID_MISMATCH 30 +X509_V_: ERR_AKID_ISSUER_SERIAL_MISMATCH 31 +X509_V_: ERR_KEYUSAGE_NO_CERTSIGN 32 +X509_V_: ERR_UNABLE_TO_GET_CRL_ISSUER 33 +X509_V_: ERR_UNHANDLED_CRITICAL_EXTENSION 34 +X509_V_: ERR_KEYUSAGE_NO_CRL_SIGN 35 +X509_V_: ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36 +X509_V_: ERR_INVALID_NON_CA 37 +X509_V_: ERR_PROXY_PATH_LENGTH_EXCEEDED 38 +X509_V_: ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39 +X509_V_: ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40 +X509_V_: ERR_APPLICATION_VERIFICATION 50 + +! =============================================== +! obj_mac.h +! =============================================== + +: NID_commonName 13 ; inline diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor new file mode 100755 index 0000000000..5990153073 --- /dev/null +++ b/extra/openssl/openssl-tests.factor @@ -0,0 +1,21 @@ +USING: io.sockets.secure io.encodings.ascii alien.strings +openssl namespaces accessors tools.test continuations kernel ; + +openssl secure-socket-backend [ + [ ] [ + + "resource:extra/openssl/test/server.pem" >>key-file + "resource:extra/openssl/test/root.pem" >>ca-file + "resource:extra/openssl/test/dh1024.pem" >>dh-file + "password" >>password + [ ] with-secure-context + ] unit-test + + [ + + "resource:extra/openssl/test/server.pem" >>key-file + "resource:extra/openssl/test/root.pem" >>ca-file + "wrong password" >>password + [ ] with-secure-context + ] must-fail +] with-variable diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor new file mode 100755 index 0000000000..a7ba2eab0f --- /dev/null +++ b/extra/openssl/openssl.factor @@ -0,0 +1,196 @@ +! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays kernel debugger sequences namespaces math +math.order combinators init alien alien.c-types alien.strings libc +continuations destructors debugger inspector +locals unicode.case +openssl.libcrypto openssl.libssl +io.backend io.ports io.files io.encodings.8-bit io.sockets.secure ; +IN: openssl + +! This code is based on http://www.rtfm.com/openssl-examples/ + +SINGLETON: openssl + +GENERIC: ssl-method ( symbol -- method ) + +M: SSLv2 ssl-method drop SSLv2_client_method ; +M: SSLv23 ssl-method drop SSLv23_method ; +M: SSLv3 ssl-method drop SSLv3_method ; +M: TLSv1 ssl-method drop TLSv1_method ; + +: (ssl-error-string) ( n -- string ) + ERR_clear_error f ERR_error_string ; + +: ssl-error-string ( -- string ) + ERR_get_error ERR_clear_error f ERR_error_string ; + +: (ssl-error) ( -- * ) + ssl-error-string throw ; + +: ssl-error ( obj -- ) + { f 0 } member? [ (ssl-error) ] when ; + +: init-ssl ( -- ) + SSL_library_init ssl-error + SSL_load_error_strings + OpenSSL_add_all_digests + OpenSSL_add_all_ciphers ; + +SYMBOL: ssl-initiazed? + +: maybe-init-ssl ( -- ) + ssl-initiazed? get-global [ + init-ssl + t ssl-initiazed? set-global + ] unless ; + +[ f ssl-initiazed? set-global ] "openssl" add-init-hook + +TUPLE: openssl-context < secure-context aliens ; + +: load-certificate-chain ( ctx -- ) + dup config>> key-file>> [ + [ handle>> ] [ config>> key-file>> (normalize-path) ] bi + SSL_CTX_use_certificate_chain_file + ssl-error + ] [ drop ] if ; + +: password-callback ( -- alien ) + "int" { "void*" "int" "bool" "void*" } "cdecl" + [| buf size rwflag password! | + password [ B{ 0 } password! ] unless + + [let | len [ password strlen ] | + buf password len 1+ size min memcpy + len + ] + ] alien-callback ; + +: default-pasword ( ctx -- alien ) + [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi + [ push ] [ drop ] 2bi ; + +: set-default-password ( ctx -- ) + [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] + [ + [ handle>> ] [ default-pasword ] bi + SSL_CTX_set_default_passwd_cb_userdata + ] bi ; + +: use-private-key-file ( ctx -- ) + dup config>> key-file>> [ + [ handle>> ] [ config>> key-file>> (normalize-path) ] bi + SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file + ssl-error + ] [ drop ] if ; + +: load-verify-locations ( ctx -- ) + dup config>> [ ca-file>> ] [ ca-path>> ] bi or [ + [ handle>> ] + [ + config>> + [ ca-file>> dup [ (normalize-path) ] when ] + [ ca-path>> dup [ (normalize-path) ] when ] bi + ] bi + SSL_CTX_load_verify_locations ssl-error + ] [ drop ] if ; + +: set-verify-depth ( ctx -- ) + handle>> 1 SSL_CTX_set_verify_depth ; + +TUPLE: bio handle disposed ; + +: f bio boa ; + +M: bio dispose* handle>> BIO_free ssl-error ; + +: ( path -- bio ) + normalize-path "r" BIO_new_file dup ssl-error ; + +: load-dh-params ( ctx -- ) + dup config>> dh-file>> [ + [ handle>> ] [ config>> dh-file>> ] bi &dispose + handle>> f f f PEM_read_bio_DHparams dup ssl-error + SSL_CTX_set_tmp_dh ssl-error + ] [ drop ] if ; + +TUPLE: rsa handle disposed ; + +: f rsa boa ; + +M: rsa dispose* handle>> RSA_free ; + +: generate-eph-rsa-key ( ctx -- ) + [ handle>> ] + [ + config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key + dup ssl-error &dispose handle>> + ] bi + SSL_CTX_set_tmp_rsa ssl-error ; + +M: openssl ( config -- context ) + maybe-init-ssl + [ + dup method>> ssl-method SSL_CTX_new + dup ssl-error f V{ } clone openssl-context boa |dispose + { + [ load-certificate-chain ] + [ set-default-password ] + [ use-private-key-file ] + [ load-verify-locations ] + [ set-verify-depth ] + [ load-dh-params ] + [ generate-eph-rsa-key ] + [ ] + } cleave + ] with-destructors ; + +M: openssl-context dispose* + [ aliens>> [ free ] each ] + [ handle>> SSL_CTX_free ] + bi ; + +TUPLE: ssl-handle file handle connected disposed ; + +ERROR: no-ssl-context ; + +M: no-ssl-context summary + drop "SSL operations must be wrapped in calls to with-ssl-context" ; + +: current-ssl-context ( -- ctx ) + secure-context get [ no-ssl-context ] unless* ; + +: ( fd -- ssl ) + current-ssl-context handle>> SSL_new dup ssl-error + f f ssl-handle boa ; + +HOOK: ssl-shutdown io-backend ( handle -- ) + +M: ssl-handle dispose* + [ ssl-shutdown ] + [ handle>> SSL_free ] + [ file>> dispose ] + tri ; + +: check-verify-result ( ssl-handle -- ) + SSL_get_verify_result dup X509_V_OK = + [ drop ] [ verify-message certificate-verify-error ] if ; + +: common-name ( certificate -- host ) + X509_get_subject_name + NID_commonName 256 + [ 256 X509_NAME_get_text_by_NID ] keep + swap -1 = [ drop f ] [ latin1 alien>string ] if ; + +: check-common-name ( host ssl-handle -- ) + SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ = + [ 2drop ] [ common-name-verify-error ] if ; + +M: openssl check-certificate ( host ssl -- ) + handle>> + [ nip check-verify-result ] + [ check-common-name ] + 2bi ; + +openssl secure-socket-backend set-global diff --git a/unmaintained/openssl/summary.txt b/extra/openssl/summary.txt similarity index 100% rename from unmaintained/openssl/summary.txt rename to extra/openssl/summary.txt diff --git a/unmaintained/openssl/tags.txt b/extra/openssl/tags.txt similarity index 100% rename from unmaintained/openssl/tags.txt rename to extra/openssl/tags.txt diff --git a/unmaintained/openssl/test/dh1024.pem b/extra/openssl/test/dh1024.pem similarity index 100% rename from unmaintained/openssl/test/dh1024.pem rename to extra/openssl/test/dh1024.pem diff --git a/unmaintained/openssl/test/errors.txt b/extra/openssl/test/errors.txt similarity index 100% rename from unmaintained/openssl/test/errors.txt rename to extra/openssl/test/errors.txt diff --git a/unmaintained/openssl/test/root.pem b/extra/openssl/test/root.pem similarity index 100% rename from unmaintained/openssl/test/root.pem rename to extra/openssl/test/root.pem diff --git a/unmaintained/openssl/test/server.pem b/extra/openssl/test/server.pem similarity index 100% rename from unmaintained/openssl/test/server.pem rename to extra/openssl/test/server.pem diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor index 7af69a97bb..aa04aef39f 100644 --- a/extra/oracle/liboci/liboci.factor +++ b/extra/oracle/liboci/liboci.factor @@ -124,7 +124,6 @@ TYPEDEF: ushort ub2 TYPEDEF: short sb2 TYPEDEF: uint ub4 TYPEDEF: int sb4 -TYPEDEF: ulong size_t ! =============================================== ! Input data types (ocidfn.h) diff --git a/extra/peg/search/search.factor b/extra/peg/search/search.factor index 3da676dcb2..7ab7e83d12 100755 --- a/extra/peg/search/search.factor +++ b/extra/peg/search/search.factor @@ -17,14 +17,14 @@ MEMO: any-char-parser ( -- parser ) : search ( string parser -- seq ) any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ - parse-result-ast [ ] filter + parse-result-ast sift ] [ drop { } ] if ; : (replace) ( string parser -- seq ) - any-char-parser 2array choice repeat0 parse parse-result-ast [ ] filter ; + any-char-parser 2array choice repeat0 parse parse-result-ast sift ; : replace ( string parser -- result ) [ (replace) [ tree-write ] each ] with-string-writer ; diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index e48714bc44..3ce6d30819 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -23,7 +23,7 @@ IN: qualified ] curry map zip ; : partial-vocab-ignoring ( words name -- assoc ) - [ vocab-words keys swap diff ] keep partial-vocab ; + [ load-vocab vocab-words keys swap diff ] keep partial-vocab ; : EXCLUDE: #! Syntax: EXCLUDE: vocab => words ... ; @@ -32,12 +32,12 @@ IN: qualified : FROM: #! Syntax: FROM: vocab => words... ; - scan expect=> + scan dup load-vocab drop expect=> ";" parse-tokens swap partial-vocab use get push ; parsing : RENAME: #! Syntax: RENAME: word vocab => newname - scan scan lookup [ "No such word" throw ] unless* + scan scan dup load-vocab drop lookup [ "No such word" throw ] unless* expect=> scan associate use get push ; parsing diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 7fda7c5d1d..e534691ecd 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,4 +1,4 @@ -USING: alien.c-types io io.files io.nonblocking kernel +USING: alien.c-types io io.files io.ports kernel namespaces random io.encodings.binary init accessors system ; IN: random.unix diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index 6f47d3e6bf..a4cf74e1df 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -1,7 +1,6 @@ USING: accessors alien.c-types byte-arrays continuations kernel windows windows.advapi32 init namespaces random destructors locals ; -USE: tools.walker IN: random.windows TUPLE: windows-rng provider type ; @@ -36,9 +35,8 @@ M: windows-crypto-context dispose ( tuple -- ) M: windows-rng random-bytes* ( n tuple -- bytes ) [ [ provider>> ] [ type>> ] bi - windows-crypto-context - dup add-always-destructor handle>> - swap dup + windows-crypto-context &dispose + handle>> swap dup [ CryptGenRandom win32-error=0/f ] keep ] with-destructors ; diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 3044c8872f..7d50d384e2 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -3,7 +3,7 @@ USING: accessors arrays combinators combinators.cleave combinators.lib continuations db db.tuples db.types db.sqlite kernel math math.parser namespaces parser sets sequences sequences.deep -sequences.lib strings words ; +sequences.lib strings words destructors ; IN: semantic-db TUPLE: node id content ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ac3c91f8ce..ac12505771 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -216,7 +216,7 @@ USE: continuations >r dup length swap r> [ = [ ] [ drop f ] if ] curry 2map - [ ] filter ; + sift ; } +{ $subsection <2merged> } +{ $subsection <3merged> } ; + +ABOUT: "sequences-merge" + +HELP: merged +{ $class-description "A virtual sequence which presents a merged view of its underlying elements. New instances are created by calling one of " { $link } ", " { $link <2merged> } ", or " { $link <3merged> } "." } +{ $see-also merge } ; + +HELP: ( seqs -- merged ) +{ $values { "seqs" "a sequence of sequences to merge" } { "merged" "a virtual sequence" } } +{ $description "Creates an instance of the " { $link merged } " virtual sequence." } +{ $see-also <2merged> <3merged> merge } ; + +HELP: <2merged> ( seq1 seq2 -- merged ) +{ $values { "seq1" sequence } { "seq2" sequence } { "merged" "a virtual sequence" } } +{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the two input sequences." } +{ $see-also <3merged> 2merge } ; + +HELP: <3merged> ( seq1 seq2 seq3 -- merged ) +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "merged" "a virtual sequence" } } +{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the three input sequences." } +{ $see-also <2merged> 3merge } ; + +HELP: merge ( seqs -- seq ) +{ $values { "seqs" "a sequence of sequences to merge" } { "seq" "a new sequence" } } +{ $description "Outputs a new sequence which merges the elements of each sequence in " { $snippet "seqs" } "." } +{ $examples + { $example "USING: prettyprint sequences.merged ;" "{ { 1 2 } { 3 4 } { 5 6 } } merge ." "{ 1 3 5 2 4 6 }" } + { $example "USING: prettyprint sequences.merged ;" "{ \"abc\" \"def\" } merge ." "\"adbecf\"" } +} +{ $see-also 2merge 3merge } ; + +HELP: 2merge ( seq1 seq2 -- seq ) +{ $values { "seq1" sequence } { "seq2" sequence } { "seq" "a new sequence" } } +{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of " { $snippet "seq1" } " and " { $snippet "seq2" } } +{ $see-also merge 3merge <2merged> } ; + +HELP: 3merge ( seq1 seq2 seq3 -- seq ) +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "seq" "a new sequence" } } +{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of all three sequences" } +{ $see-also merge 2merge <3merged> } ; diff --git a/extra/sequences/merged/merged-tests.factor b/extra/sequences/merged/merged-tests.factor new file mode 100644 index 0000000000..13a46f0b72 --- /dev/null +++ b/extra/sequences/merged/merged-tests.factor @@ -0,0 +1,17 @@ +USING: sequences sequences.merged tools.test ; +IN: sequences.merged.tests + +[ 0 { 1 2 } ] [ 0 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test +[ 0 { 3 4 } ] [ 1 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test +[ 1 { 1 2 } ] [ 2 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test +[ 4 ] [ 3 { { 1 2 3 4 } } nth ] unit-test +[ 4 { { 1 2 3 4 } } nth ] must-fail + +[ 1 ] [ 0 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test +[ 4 ] [ 1 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test +[ 2 ] [ 2 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test +[ 5 ] [ 3 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test +[ 3 ] [ 4 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test +[ 6 ] [ 5 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test + +[ 4 ] [ 4 { 1 2 } { 3 4 } { 5 6 } 3merge nth ] unit-test diff --git a/extra/sequences/merged/merged.factor b/extra/sequences/merged/merged.factor new file mode 100644 index 0000000000..829555cfb1 --- /dev/null +++ b/extra/sequences/merged/merged.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel math sequences ; +IN: sequences.merged + +TUPLE: merged seqs ; +C: merged + +: <2merged> ( seq1 seq2 -- merged ) 2array ; +: <3merged> ( seq1 seq2 seq3 -- merged ) 3array ; + +: merge ( seqs -- seq ) + dup swap first like ; + +: 2merge ( seq1 seq2 -- seq ) + dupd <2merged> swap like ; + +: 3merge ( seq1 seq2 seq3 -- seq ) + pick >r <3merged> r> like ; + +M: merged length seqs>> [ length ] map sum ; + +M: merged virtual@ ( n seq -- n' seq' ) + seqs>> [ length /mod ] [ nth ] bi ; + +M: merged virtual-seq ( merged -- seq ) [ ] { } map-as ; + +INSTANCE: merged virtual-sequence diff --git a/extra/sequences/merged/summary.txt b/extra/sequences/merged/summary.txt new file mode 100644 index 0000000000..1a514df4e2 --- /dev/null +++ b/extra/sequences/merged/summary.txt @@ -0,0 +1 @@ +A virtual sequence which merges (interleaves) other sequences. diff --git a/extra/sequences/merged/tags.txt b/extra/sequences/merged/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/sequences/merged/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/sequences/modified/modified-tests.factor b/extra/sequences/modified/modified-tests.factor new file mode 100644 index 0000000000..4bcbb29da6 --- /dev/null +++ b/extra/sequences/modified/modified-tests.factor @@ -0,0 +1,15 @@ +USING: accessors arrays kernel sequences sequences.modified tools.test ; +IN: sequences.modified.tests + +[ { 2 4 6 } ] [ { 1 2 3 } 2 scale ] unit-test +[ { 1 4 3 } ] [ { 1 2 3 } 2 8 1 pick set-nth seq>> ] unit-test +[ { 2 8 6 } ] [ { 1 2 3 } 2 8 1 pick set-nth >array ] unit-test + +[ { 2 3 4 } ] [ { 1 2 3 } 1 seq-offset ] unit-test +[ { 1 5 3 } ] [ { 1 2 3 } 1 6 1 pick set-nth seq>> ] unit-test +[ { 2 6 4 } ] [ { 1 2 3 } 1 6 1 pick set-nth >array ] unit-test + +[ 4 ] [ { { 1 2 } { 3 4 } } 0 swap nth ] unit-test +[ 6 ] [ { { 1 2 } { 3 4 } } 1 swap nth ] unit-test +[ 2 ] [ { { 1 2 } { 3 4 } } length ] unit-test +[ { 4 6 } ] [ { { 1 2 } { 3 4 } } >array ] unit-test diff --git a/extra/sequences/modified/modified.factor b/extra/sequences/modified/modified.factor new file mode 100644 index 0000000000..3e4c1b1bdc --- /dev/null +++ b/extra/sequences/modified/modified.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel math sequences sequences.private shuffle ; +IN: sequences.modified + +TUPLE: modified ; + +GENERIC: modified-nth ( n seq -- elt ) +M: modified nth modified-nth ; +M: modified nth-unsafe modified-nth ; + +GENERIC: modified-set-nth ( elt n seq -- ) +M: modified set-nth modified-set-nth ; +M: modified set-nth-unsafe modified-set-nth ; + +INSTANCE: modified virtual-sequence + +TUPLE: 1modified < modified seq ; + +M: modified length seq>> length ; +M: modified set-length seq>> set-length ; + +M: 1modified virtual-seq seq>> ; + +TUPLE: scaled < 1modified c ; +C: scaled + +: scale ( seq c -- new-seq ) + dupd swap like ; + +M: scaled modified-nth ( n seq -- elt ) + [ seq>> nth ] [ c>> * ] bi ; + +M: scaled modified-set-nth ( elt n seq -- elt ) + ! don't set c to 0! + tuck [ c>> / ] 2dip seq>> set-nth ; + +TUPLE: offset < 1modified n ; +C: offset + +: seq-offset ( seq n -- new-seq ) + dupd swap like ; + +M: offset modified-nth ( n seq -- elt ) + [ seq>> nth ] [ n>> + ] bi ; + +M: offset modified-set-nth ( elt n seq -- ) + tuck [ n>> - ] 2dip seq>> set-nth ; + +TUPLE: summed < modified seqs ; +C: summed + +M: summed length seqs>> [ length ] map supremum ; + + + +M: summed modified-nth ( n seq -- ) + seqs>> [ ?nth ?+ ] with 0 swap reduce ; + +M: summed modified-set-nth ( elt n seq -- ) immutable ; + +M: summed set-length ( n seq -- ) + seqs>> [ set-length ] with each ; + +M: summed virtual-seq ( summed -- seq ) [ ] { } map-as ; + +: <2summed> ( seq seq -- summed-seq ) 2array ; +: <3summed> ( seq seq seq -- summed-seq ) 3array ; diff --git a/extra/sequences/repeating/authors.txt b/extra/sequences/repeating/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/sequences/repeating/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/sequences/repeating/repeating-tests.factor b/extra/sequences/repeating/repeating-tests.factor new file mode 100644 index 0000000000..15b7ef444b --- /dev/null +++ b/extra/sequences/repeating/repeating-tests.factor @@ -0,0 +1,5 @@ +USING: sequences.repeating tools.test ; +IN: sequences.repeating.tests + +[ { 1 2 3 1 2 } ] [ { 1 2 3 } 5 repeated ] unit-test +[ { 1 2 3 1 2 3 1 2 3 } ] [ { 1 2 3 } 9 repeated ] unit-test diff --git a/extra/sequences/repeating/repeating.factor b/extra/sequences/repeating/repeating.factor new file mode 100644 index 0000000000..92b0925907 --- /dev/null +++ b/extra/sequences/repeating/repeating.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Alex Chapman +! See http;//factorcode.org/license.txt for BSD license +USING: accessors circular kernel sequences ; +IN: sequences.repeating + +TUPLE: repeating circular len ; + +: ( seq length -- repeating ) + [ ] dip repeating boa ; + +: repeated ( seq length -- new-seq ) + dupd swap like ; + +M: repeating length repeating-len ; +M: repeating set-length (>>len) ; + +M: repeating virtual@ ( n seq -- n' seq' ) circular>> ; + +M: repeating virtual-seq circular>> ; + +INSTANCE: repeating virtual-sequence diff --git a/extra/shell/parser/parser.factor b/extra/shell/parser/parser.factor index 46548bb34f..2ecca6199c 100644 --- a/extra/shell/parser/parser.factor +++ b/extra/shell/parser/parser.factor @@ -23,8 +23,8 @@ TUPLE: factor-expr expr ; pipeline-expr new over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands over 2nd >>stdin - over 5th >>stdout - swap 6th >>background ; + over 6th >>stdout + swap 7th >>background ; : ast>single-quoted-expr ( ast -- obj ) 2nd >string single-quoted-expr boa ; diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor index 7f30104e21..8ba5b66d5a 100644 --- a/extra/shell/shell.factor +++ b/extra/shell/shell.factor @@ -1,7 +1,7 @@ USING: kernel parser words continuations namespaces debugger sequences combinators splitting prettyprint - system io io.files io.launcher io.encodings.utf8 sequences.deep + system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep accessors multi-methods newfx shell.parser ; IN: shell @@ -95,8 +95,7 @@ METHOD: expand { object } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: pipeline-chant ( pipeline-chant -- ) - drop "ix: pipelines not supported" print ; +: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index 89522d1f76..3d8a390d13 100644 --- a/extra/shuffle/shuffle.factor +++ b/extra/shuffle/shuffle.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces math inference.transforms - combinators macros quotations math.ranges bake ; + combinators macros quotations math.ranges fry ; IN: shuffle @@ -19,7 +19,7 @@ MACRO: ndrop ( n -- ) [ drop ] n*quot ; : nnip ( n -- ) swap >r ndrop r> ; inline -MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ; +MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ; : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index f23ee138d5..824651030d 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -2,7 +2,7 @@ ! 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 io.streams.duplex ; +io.encodings.ascii io.streams.duplex destructors ; IN: smtp.server ! Mock SMTP server for testing purposes. diff --git a/extra/synth/authors.txt b/extra/synth/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/synth/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/synth/buffers/authors.txt b/extra/synth/buffers/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/synth/buffers/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor new file mode 100644 index 0000000000..faff19d8fd --- /dev/null +++ b/extra/synth/buffers/buffers.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged ; +IN: synth.buffers + +TUPLE: buffer sample-freq 8bit? id ; + +: ( sample-freq 8bit? -- buffer ) + f buffer boa ; + +TUPLE: mono-buffer < buffer data ; + +: ( sample-freq 8bit? -- buffer ) + f f mono-buffer boa ; + +: <8bit-mono-buffer> ( sample-freq -- buffer ) t ; +: <16bit-mono-buffer> ( sample-freq -- buffer ) f ; + +TUPLE: stereo-buffer < buffer left-data right-data ; + +: ( sample-freq 8bit? -- buffer ) + f f f stereo-buffer boa ; + +: <8bit-stereo-buffer> ( sample-freq -- buffer ) t ; +: <16bit-stereo-buffer> ( sample-freq -- buffer ) f ; + +PREDICATE: 8bit-buffer < buffer 8bit?>> ; +PREDICATE: 16bit-buffer < buffer 8bit?>> not ; +INTERSECTION: 8bit-mono-buffer 8bit-buffer mono-buffer ; +INTERSECTION: 16bit-mono-buffer 16bit-buffer mono-buffer ; +INTERSECTION: 8bit-stereo-buffer 8bit-buffer stereo-buffer ; +INTERSECTION: 16bit-stereo-buffer 16bit-buffer stereo-buffer ; + +GENERIC: buffer-format ( buffer -- format ) +M: 8bit-mono-buffer buffer-format drop AL_FORMAT_MONO8 ; +M: 16bit-mono-buffer buffer-format drop AL_FORMAT_MONO16 ; +M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ; +M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ; + +: 8bit-buffer-data ( seq -- data size ) + [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi ; + +: 16bit-buffer-data ( seq -- data size ) + [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi ; + +: stereo-data ( stereo-buffer -- left right ) + [ left-data>> ] [ right-data>> ] bi@ ; + +: interleaved-stereo-data ( stereo-buffer -- data ) + stereo-data <2merged> ; + +GENERIC: buffer-data ( buffer -- data size ) +M: 8bit-mono-buffer buffer-data data>> 8bit-buffer-data ; +M: 16bit-mono-buffer buffer-data data>> 16bit-buffer-data ; +M: 8bit-stereo-buffer buffer-data + interleaved-stereo-data 8bit-buffer-data ; +M: 16bit-stereo-buffer buffer-data + interleaved-stereo-data 16bit-buffer-data ; + +: telephone-sample-freq 8000 ; +: half-sample-freq 22050 ; +: cd-sample-freq 44100 ; +: digital-sample-freq 48000 ; +: professional-sample-freq 88200 ; + +: send-buffer ( buffer -- buffer ) + { + [ gen-buffer dup [ >>id ] dip ] + [ buffer-format ] + [ buffer-data ] + [ sample-freq>> alBufferData ] + } cleave ; + +: ?send-buffer ( buffer -- buffer ) + dup id>> [ send-buffer ] unless ; + diff --git a/extra/synth/example/authors.txt b/extra/synth/example/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/synth/example/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/synth/example/example.factor b/extra/synth/example/example.factor new file mode 100644 index 0000000000..3357c103ad --- /dev/null +++ b/extra/synth/example/example.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel namespaces openal sequences synth synth.buffers ; +IN: synth.example + +: play-sine-wave ( freq seconds sample-freq -- ) + init-openal + <16bit-mono-buffer> >sine-wave-buffer send-buffer id>> + 1 gen-sources first + [ AL_BUFFER rot set-source-param ] [ source-play ] bi + check-error ; + +: test-instrument1 ( -- harmonics ) + [ + 1 0.5 , + 2 0.125 , + 3 0.0625 , + 4 0.03125 , + ] { } make ; + +: test-instrument2 ( -- harmonics ) + [ + 1 0.25 , + 2 0.25 , + 3 0.25 , + 4 0.25 , + ] { } make ; + +: sine-instrument ( -- harmonics ) + 1 1 1array ; + +: test-note-buffer ( note -- ) + init-openal + test-instrument2 swap cd-sample-freq <16bit-mono-buffer> + >note send-buffer id>> + 1 gen-sources first [ swap queue-buffer ] [ source-play ] bi + check-error ; diff --git a/extra/synth/summary.txt b/extra/synth/summary.txt new file mode 100644 index 0000000000..ece589350d --- /dev/null +++ b/extra/synth/summary.txt @@ -0,0 +1 @@ +Simple sound synthesis using OpenAL. diff --git a/extra/synth/synth.factor b/extra/synth/synth.factor new file mode 100644 index 0000000000..be1e5943af --- /dev/null +++ b/extra/synth/synth.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ; +IN: synth + +MEMO: single-sine-wave ( samples/wave -- seq ) + pi 2 * over / [ * sin ] curry map ; + +: (sine-wave) ( samples/wave n-samples -- seq ) + [ single-sine-wave ] dip ; + +: sine-wave ( sample-freq freq seconds -- seq ) + pick * >integer [ /i ] dip (sine-wave) ; + +: >sine-wave-buffer ( freq seconds buffer -- buffer ) + [ sample-freq>> -rot sine-wave ] keep swap >>data ; + +: >silent-buffer ( seconds buffer -- buffer ) + tuck sample-freq>> * >integer 0 >>data ; + +TUPLE: harmonic n amplitude ; +C: harmonic + +TUPLE: note hz secs ; +C: note + +: harmonic-freq ( note harmonic -- freq ) + n>> swap hz>> * ; + +:: note-harmonic-data ( harmonic note buffer -- data ) + buffer sample-freq>> note harmonic harmonic-freq note secs>> sine-wave + harmonic amplitude>> ; + +: >note ( harmonics note buffer -- buffer ) + dup -roll [ note-harmonic-data ] 2curry map >>data ; + diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 6dff511238..6c5f7e7775 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -6,16 +6,16 @@ continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.files io.backend quotations io.launcher words.private tools.deploy.config -bootstrap.image io.encodings.utf8 accessors ; +bootstrap.image io.encodings.utf8 destructors accessors ; IN: tools.deploy.backend - + : copy-vm ( executable bundle-name extension -- vm ) [ prepend-path ] dip append vm over copy-file ; - -: copy-fonts ( name dir -- ) - append-path "fonts/" resource-path swap copy-tree-into ; - -: image-name ( vocab bundle-name -- str ) + +: copy-fonts ( name dir -- ) + append-path "resource:fonts/" swap copy-tree-into ; + +: image-name ( vocab bundle-name -- str ) prepend-path ".image" append ; : (copy-lines) ( stream -- ) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 1374254612..4f0d6ac036 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -133,7 +133,7 @@ IN: tools.deploy.shaker [ io.backend:io-backend , - "default-buffer-size" "io.nonblocking" lookup , + "default-buffer-size" "io.ports" lookup , ] { } make { "alarms" "io" "tools" } strip-vocab-globals % diff --git a/extra/tools/deploy/windows/windows-tests.factor b/extra/tools/deploy/windows/windows-tests.factor new file mode 100755 index 0000000000..cfc9f6af90 --- /dev/null +++ b/extra/tools/deploy/windows/windows-tests.factor @@ -0,0 +1,7 @@ +IN: tools.deploy.windows.tests +USING: tools.deploy.windows tools.test sequences ; + +[ t ] [ + "foo" "resource:temp/test-copy-files" create-exe-dir + ".exe" tail? +] unit-test diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 5af3062e39..e0ce2c268a 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -2,12 +2,15 @@ ! 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 windows.shell32 windows.user32 ; +prettyprint combinators windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-dlls ( bundle-name -- ) - { "resource:freetype6.dll" "resource:zlib1.dll" "resource:factor.dll" } - swap copy-files-into ; + { + "resource:freetype6.dll" + "resource:zlib1.dll" + "resource:factor.dll" + } swap copy-files-into ; : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dlls @@ -15,11 +18,15 @@ IN: tools.deploy.windows ".exe" copy-vm ; M: winnt deploy* - "." resource-path [ - dup deploy-config [ - [ deploy-name get create-exe-dir ] keep - [ deploy-name get image-name ] keep - [ namespace make-deploy-image ] keep - open-in-explorer - ] bind + "resource:" [ + deploy-name over deploy-config at + [ + { + [ create-exe-dir ] + [ image-name ] + [ drop ] + [ drop deploy-config ] + } 2cleave make-deploy-image + ] + [ nip open-in-explorer ] 2bi ] with-directory ; diff --git a/extra/tools/time/time-docs.factor b/extra/tools/time/time-docs.factor old mode 100644 new mode 100755 index 5fedba1700..fe3d709f78 --- a/extra/tools/time/time-docs.factor +++ b/extra/tools/time/time-docs.factor @@ -16,7 +16,7 @@ ABOUT: "timing" HELP: benchmark { $values { "quot" "a quotation" } { "runtime" "an integer denoting milliseconds" } } -{ $description "Runs a quotation, measuring the total wall clock time and the total time spent in the garbage collector." } + { $description "Runs a quotation, measuring the total wall clock time." } { $notes "A nicer word for interactive use is " { $link time } "." } ; HELP: time diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 2b28e158df..86035ae1a4 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -106,7 +106,7 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map [ [ word? ] filter [ word-vocabulary ] map ] map>set - remove [ ] filter [ vocab ] map ; inline + remove sift [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 83890788e3..20e6e19de5 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs cocoa kernel math cocoa.messages +USING: alien alien.c-types arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application -cocoa.pasteboard cocoa.types cocoa.windows sequences ui -ui.gadgets ui.gadgets.worlds ui.gestures core-foundation -threads combinators ; +cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets +ui.gadgets.worlds ui.gestures core-foundation threads combinators ; IN: ui.cocoa.views : send-mouse-moved ( view event -- ) @@ -360,8 +359,14 @@ CLASS: { ] } ; +: sync-refresh-to-screen ( GLView -- ) + -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 + CGLSetParameter drop ; + : ( world -- view ) - FactorView over rect-dim [ register-window ] keep ; + FactorView over rect-dim + [ sync-refresh-to-screen ] keep + [ register-window ] keep ; CLASS: { { +superclass+ "NSObject" } diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 533a6c42b7..960c34118a 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -8,7 +8,8 @@ hashtables io kernel namespaces sequences io.styles strings quotations math opengl combinators math.vectors sorting splitting io.streams.nested assocs ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids -ui.gadgets.grid-lines classes.tuple models continuations ; +ui.gadgets.grid-lines classes.tuple models continuations +destructors ; IN: ui.gadgets.panes TUPLE: pane output current prototype scrolls? diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index 56a0fbc3ee..cf97bedb8d 100644 --- a/extra/ui/gadgets/tracks/tracks.factor +++ b/extra/ui/gadgets/tracks/tracks.factor @@ -8,7 +8,7 @@ TUPLE: track sizes ; : normalized-sizes ( track -- seq ) track-sizes - [ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ; + [ sift sum ] keep [ dup [ over / ] when ] map nip ; : ( orientation -- track ) V{ } clone diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index 6d22083096..47b0d51705 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -17,7 +17,7 @@ IN: ui.tools.tests [ ] [ "w" get com-scroll-down ] unit-test [ t ] [ "w" get workspace-book gadget-children - [ tool-scroller ] map [ ] filter [ scroller? ] all? + [ tool-scroller ] map sift [ scroller? ] all? ] unit-test [ ] [ "w" get hide-popup ] unit-test [ ] [ "w" get show-popup ] unit-test diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 7ef97d553c..53f81ccbf9 100755 --- 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 math.ranges unicode.normalize values io.encodings.ascii -unicode.syntax unicode.data compiler.units alien.syntax ; +unicode.syntax unicode.data compiler.units alien.syntax sets ; IN: unicode.breaks C-ENUM: Any L V T Extend Control CR LF graphemes ; @@ -24,10 +24,9 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; [ blank? ] right-trim ; : process-other-extend ( lines -- set ) - [ "#" split1 drop ";" split1 drop trim-blank ] map - [ empty? not ] filter + [ "#" split1 drop ";" split1 drop trim-blank ] map harvest [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map - concat [ dup ] H{ } map>assoc ; + concat unique ; : other-extend-lines ( -- lines ) "resource:extra/unicode/PropList.txt" ascii file-lines ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 52706647a9..b411e4e209 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -89,7 +89,7 @@ IN: unicode.data ] assoc-map >hashtable ; : multihex ( hexstring -- string ) - " " split [ hex> ] map [ ] filter ; + " " split [ hex> ] map sift ; TUPLE: code-point lower title upper ; diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor index 846f797f71..2d07ba2caa 100755 --- a/extra/unicode/script/script.factor +++ b/extra/unicode/script/script.factor @@ -10,7 +10,7 @@ SYMBOL: interned : parse-script ( stream -- assoc ) ! assoc is code point/range => name - lines [ "#" split1 drop ] map [ empty? not ] filter [ + lines [ "#" split1 drop ] map harvest [ ";" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ; diff --git a/extra/unix/bsd/macosx/macosx.factor b/extra/unix/bsd/macosx/macosx.factor index edef2aaa0c..174dcbf632 100644 --- a/extra/unix/bsd/macosx/macosx.factor +++ b/extra/unix/bsd/macosx/macosx.factor @@ -12,3 +12,16 @@ C-STRUCT: addrinfo { "char*" "canonname" } { "void*" "addr" } { "addrinfo*" "next" } ; + +C-STRUCT: passwd + { "char*" "pw_name" } + { "char*" "pw_passwd" } + { "uid_t" "pw_uid" } + { "gid_t" "pw_gid" } + { "time_t" "pw_change" } + { "char*" "pw_class" } + { "char*" "pw_gecos" } + { "char*" "pw_dir" } + { "char*" "pw_shell" } + { "time_t" "pw_expire" } + { "int" "pw_fields" } ; diff --git a/extra/unix/ffi/ffi.factor b/extra/unix/ffi/ffi.factor deleted file mode 100644 index e39d95dfa3..0000000000 --- a/extra/unix/ffi/ffi.factor +++ /dev/null @@ -1,15 +0,0 @@ - -USING: alien.syntax ; - -IN: unix.ffi - -FUNCTION: int open ( char* path, int flags, int prot ) ; - -C-STRUCT: utimbuf - { "time_t" "actime" } - { "time_t" "modtime" } ; - -FUNCTION: int utime ( char* path, utimebuf* buf ) ; - -FUNCTION: int err_no ( ) ; -FUNCTION: char* strerror ( int errno ) ; \ No newline at end of file diff --git a/extra/unix/linux/ifreq/ifreq.factor b/extra/unix/linux/ifreq/ifreq.factor index d688153bd0..5dc1c0fde2 100755 --- a/extra/unix/linux/ifreq/ifreq.factor +++ b/extra/unix/linux/ifreq/ifreq.factor @@ -1,7 +1,6 @@ USING: kernel alien alien.c-types io.sockets - io.sockets.impl unix unix.linux.sockios unix.linux.if ; diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor index 74195fae36..9450663aaa 100755 --- a/extra/unix/linux/linux.factor +++ b/extra/unix/linux/linux.factor @@ -84,3 +84,12 @@ C-STRUCT: sockaddr-un : SEEK_SET 0 ; inline : SEEK_CUR 1 ; inline : SEEK_END 2 ; inline + +C-STRUCT: passwd + { "char*" "pw_name" } + { "char*" "pw_passwd" } + { "uid_t" "pw_uid" } + { "gid_t" "pw_gid" } + { "char*" "pw_gecos" } + { "char*" "pw_dir" } + { "char*" "pw_shell" } ; diff --git a/extra/unix/linux/route/route.factor b/extra/unix/linux/route/route.factor index c4eeadb69e..4d9bbfae99 100644 --- a/extra/unix/linux/route/route.factor +++ b/extra/unix/linux/route/route.factor @@ -42,7 +42,7 @@ C-STRUCT: struct-rtentry ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: kernel alien.c-types io.sockets io.sockets.impl +USING: kernel alien.c-types io.sockets unix unix.linux.sockios ; : route ( dst gateway genmask flags -- ) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 0abefe14f1..644276ef7d 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -1,12 +1,20 @@ -USING: kernel alien.c-types alien.strings sequences math unix -vectors kernel namespaces continuations threads assocs vectors -io.unix.backend io.encodings.utf8 ; +USING: kernel alien.c-types alien.strings sequences math alien.syntax unix + vectors kernel namespaces continuations threads assocs vectors + io.unix.backend io.encodings.utf8 ; IN: unix.process ! Low-level Unix process launching utilities. These are used ! to implement io.launcher on Unix. User code should use ! io.launcher instead. +FUNCTION: pid_t fork ( ) ; + +: fork-process ( -- pid ) [ fork ] unix-system-call ; + +FUNCTION: int execv ( char* path, char** argv ) ; +FUNCTION: int execvp ( char* path, char** argv ) ; +FUNCTION: int execve ( char* path, char** argv, char** envp ) ; + : >argv ( seq -- alien ) [ utf8 malloc-string ] map f suffix >c-void*-array ; @@ -29,10 +37,65 @@ IN: unix.process >r [ first ] [ ] bi r> exec-with-env ; : with-fork ( child parent -- ) - fork dup io-error dup zero? -roll swap curry if ; inline + fork-process dup zero? -roll swap curry if ; inline -: wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; +: SIGKILL 9 ; inline +: SIGTERM 15 ; inline + +FUNCTION: int kill ( pid_t pid, int sig ) ; + +: PRIO_PROCESS 0 ; inline +: PRIO_PGRP 1 ; inline +: PRIO_USER 2 ; inline + +: PRIO_MIN -20 ; inline +: PRIO_MAX 20 ; inline + +! which/who = 0 for current process +FUNCTION: int getpriority ( int which, int who ) ; +FUNCTION: int setpriority ( int which, int who, int prio ) ; : set-priority ( n -- ) - 0 0 rot setpriority io-error ; \ No newline at end of file + 0 0 rot setpriority io-error ; + +! Flags for waitpid + +: WNOHANG 1 ; inline +: WUNTRACED 2 ; inline + +: WSTOPPED 2 ; inline +: WEXITED 4 ; inline +: WCONTINUED 8 ; inline +: WNOWAIT HEX: 1000000 ; inline + +! Examining status + +: WTERMSIG ( status -- value ) + HEX: 7f bitand ; inline + +: WIFEXITED ( status -- ? ) + WTERMSIG zero? ; inline + +: WEXITSTATUS ( status -- value ) + HEX: ff00 bitand -8 shift ; inline + +: WIFSIGNALED ( status -- ? ) + HEX: 7f bitand 1+ -1 shift 0 > ; inline + +: WCOREFLAG ( -- value ) + HEX: 80 ; inline + +: WCOREDUMP ( status -- ? ) + WCOREFLAG bitand zero? not ; inline + +: WIFSTOPPED ( status -- ? ) + HEX: ff bitand HEX: 7f = ; inline + +: WSTOPSIG ( status -- value ) + WEXITSTATUS ; inline + +FUNCTION: pid_t wait ( int* status ) ; +FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; + +: wait-for-pid ( pid -- status ) + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index cb1c939878..2bc60105b4 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -1,6 +1,6 @@ USING: kernel system combinators alien.syntax alien.c-types - math io.unix.backend vocabs.loader ; + math io.unix.backend vocabs.loader unix ; IN: unix.stat @@ -60,14 +60,12 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; >> ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: check-status ( n -- ) io-error ; +: file-status ( pathname -- stat ) + "stat" dup >r + [ stat ] unix-system-call drop + r> ; -: stat* ( pathname -- stat ) - "stat" dup >r - stat check-status - r> ; - -: lstat* ( pathname -- stat ) - "stat" dup >r - lstat check-status - r> ; +: link-status ( pathname -- stat ) + "stat" dup >r + [ lstat ] unix-system-call drop + r> ; diff --git a/extra/unix/system-call/system-call.factor b/extra/unix/system-call/system-call.factor deleted file mode 100644 index bfcb9ae6ea..0000000000 --- a/extra/unix/system-call/system-call.factor +++ /dev/null @@ -1,15 +0,0 @@ - -USING: kernel continuations sequences math accessors inference macros - fry arrays.lib unix.ffi ; - -IN: unix.system-call - -ERROR: unix-system-call-error word args message ; - -MACRO: unix-system-call ( quot -- ) - [ ] [ infer in>> ] [ first ] tri - '[ - [ @ dup 0 < [ dup throw ] [ ] if ] - [ drop , narray , swap err_no strerror unix-system-call-error ] - recover - ] ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index c68f127226..f1f46fc184 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -1,17 +1,16 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax kernel libc structs +USING: alien alien.c-types alien.syntax kernel libc structs sequences + continuations byte-arrays strings math namespaces system combinators vocabs.loader qualified - unix.ffi unix.types unix.system-call ; - -QUALIFIED: unix.ffi + accessors inference macros locals shuffle arrays.lib + unix.types ; IN: unix TYPEDEF: uint in_addr_t TYPEDEF: uint socklen_t -TYPEDEF: ulong size_t : PROT_NONE 0 ; inline : PROT_READ 1 ; inline @@ -27,43 +26,53 @@ TYPEDEF: ulong size_t : ESRCH 3 ; inline : EEXIST 17 ; inline +: NGROUPS_MAX 16 ; inline + C-STRUCT: group { "char*" "gr_name" } { "char*" "gr_passwd" } { "int" "gr_gid" } { "char**" "gr_mem" } ; -C-STRUCT: passwd - { "char*" "pw_name" } - { "char*" "pw_passwd" } - { "uid_t" "pw_uid" } - { "gid_t" "pw_gid" } - { "time_t" "pw_change" } - { "char*" "pw_class" } - { "char*" "pw_gecos" } - { "char*" "pw_dir" } - { "char*" "pw_shell" } - { "time_t" "pw_expire" } - { "int" "pw_fields" } ; - -! ! ! Unix functions LIBRARY: factor + FUNCTION: void clear_err_no ( ) ; +FUNCTION: int err_no ( ) ; LIBRARY: libc +ERROR: unix-system-call-error args message word ; + +FUNCTION: char* strerror ( int errno ) ; + +MACRO:: unix-system-call ( quot -- ) + [let | n [ quot infer in>> ] + word [ quot first ] | + [ + n ndup quot call dup 0 < [ + drop + n narray + err_no strerror + word unix-system-call-error + ] [ + n nnip + ] if + ] + ] ; + FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int chdir ( char* path ) ; FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ; FUNCTION: int chroot ( char* path ) ; -FUNCTION: void close ( int fd ) ; + +FUNCTION: int close ( int fd ) ; + +: close-file ( fd -- ) [ close ] unix-system-call drop ; + FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ; FUNCTION: int dup2 ( int oldd, int newd ) ; ! FUNCTION: int dup ( int oldd ) ; -FUNCTION: int execv ( char* path, char** argv ) ; -FUNCTION: int execvp ( char* path, char** argv ) ; -FUNCTION: int execve ( char* path, char** argv, char** envp ) ; : _exit ( status -- * ) #! We throw to give this a terminating stack effect. "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ; @@ -71,7 +80,6 @@ FUNCTION: int fchdir ( int fd ) ; FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ; FUNCTION: int fcntl ( int fd, int cmd, int arg ) ; FUNCTION: int flock ( int fd, int operation ) ; -FUNCTION: pid_t fork ( ) ; FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: char* gai_strerror ( int ecode ) ; @@ -87,6 +95,8 @@ FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ; FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int gethostname ( char* name, int len ) ; +FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ; +FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ; FUNCTION: uid_t getuid ; FUNCTION: uint htonl ( uint n ) ; FUNCTION: ushort htons ( ushort n ) ; @@ -99,16 +109,41 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_ FUNCTION: int munmap ( void* addr, size_t len ) ; FUNCTION: uint ntohl ( uint n ) ; FUNCTION: ushort ntohs ( ushort n ) ; +FUNCTION: int shutdown ( int fd, int how ) ; -: open ( path flags prot -- int ) [ unix.ffi:open ] unix-system-call ; +FUNCTION: int open ( char* path, int flags, int prot ) ; -: utime ( path buf -- ) [ unix.ffi:utime ] unix-system-call drop ; +: open-file ( path flags mode -- fd ) [ open ] unix-system-call ; + +C-STRUCT: utimbuf + { "time_t" "actime" } + { "time_t" "modtime" } ; + +FUNCTION: int utime ( char* path, utimebuf* buf ) ; + +: touch ( filename -- ) f [ utime ] unix-system-call drop ; + +: change-file-times ( filename access modification -- ) + "utimebuf" + tuck set-utimbuf-modtime + tuck set-utimbuf-actime + [ utime ] unix-system-call drop ; FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; FUNCTION: void* popen ( char* command, char* type ) ; FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; + FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; + +: PATH_MAX 1024 ; inline + +: read-symbolic-link ( path -- path ) + PATH_MAX dup >r + PATH_MAX + [ readlink ] unix-system-call + r> swap head-slice >string ; + FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ; FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ; FUNCTION: int rename ( char* from, char* to ) ; @@ -126,66 +161,13 @@ FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; FUNCTION: int symlink ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; + FUNCTION: int unlink ( char* path ) ; + +: unlink-file ( path -- ) [ unlink ] unix-system-call drop ; + FUNCTION: int utimes ( char* path, timeval[2] times ) ; -: SIGKILL 9 ; inline -: SIGTERM 15 ; inline - -FUNCTION: int kill ( pid_t pid, int sig ) ; - -: PATH_MAX 1024 ; inline - -: PRIO_PROCESS 0 ; inline -: PRIO_PGRP 1 ; inline -: PRIO_USER 2 ; inline - -: PRIO_MIN -20 ; inline -: PRIO_MAX 20 ; inline - -! which/who = 0 for current process -FUNCTION: int getpriority ( int which, int who ) ; -FUNCTION: int setpriority ( int which, int who, int prio ) ; - -! Flags for waitpid - -: WNOHANG 1 ; inline -: WUNTRACED 2 ; inline - -: WSTOPPED 2 ; inline -: WEXITED 4 ; inline -: WCONTINUED 8 ; inline -: WNOWAIT HEX: 1000000 ; inline - -! Examining status - -: WTERMSIG ( status -- value ) - HEX: 7f bitand ; inline - -: WIFEXITED ( status -- ? ) - WTERMSIG zero? ; inline - -: WEXITSTATUS ( status -- value ) - HEX: ff00 bitand -8 shift ; inline - -: WIFSIGNALED ( status -- ? ) - HEX: 7f bitand 1+ -1 shift 0 > ; inline - -: WCOREFLAG ( -- value ) - HEX: 80 ; inline - -: WCOREDUMP ( status -- ? ) - WCOREFLAG bitand zero? not ; inline - -: WIFSTOPPED ( status -- ? ) - HEX: ff bitand HEX: 7f = ; inline - -: WSTOPSIG ( status -- value ) - WEXITSTATUS ; inline - -FUNCTION: pid_t wait ( int* status ) ; -FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; - FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor old mode 100644 new mode 100755 index e2685db1d0..abba8874d6 --- a/extra/windows/com/com-tests.factor +++ b/extra/windows/com/com-tests.factor @@ -1,7 +1,7 @@ USING: kernel windows.com windows.com.syntax windows.ole32 alien alien.syntax tools.test libc alien.c-types arrays.lib namespaces arrays continuations accessors math windows.com.wrapper -windows.com.wrapper.private ; +windows.com.wrapper.private destructors ; IN: windows.com.tests COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index b3c803be2d..b63a5c3337 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -45,8 +45,7 @@ unless ; : parse-com-functions ( -- functions ) - ";" parse-tokens { ")" } split - [ empty? not ] filter + ";" parse-tokens { ")" } split harvest [ (parse-com-function) ] map ; : (iid-word) ( definition -- word ) diff --git a/extra/windows/com/wrapper/wrapper-docs.factor b/extra/windows/com/wrapper/wrapper-docs.factor old mode 100644 new mode 100755 index 51a3549047..89b199a38b --- a/extra/windows/com/wrapper/wrapper-docs.factor +++ b/extra/windows/com/wrapper/wrapper-docs.factor @@ -1,5 +1,6 @@ USING: help.markup help.syntax io kernel math quotations -multiline alien windows.com windows.com.syntax continuations ; +multiline alien windows.com windows.com.syntax continuations +destructors ; IN: windows.com.wrapper HELP: diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index ae5f03a594..5b7bb63590 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types windows.com.syntax windows.com.syntax.private windows.com continuations kernel sequences.lib namespaces windows.ole32 libc assocs accessors arrays sequences quotations combinators -math combinators.lib words compiler.units ; +math combinators.lib words compiler.units destructors ; IN: windows.com.wrapper TUPLE: com-wrapper vtbls freed? ; diff --git a/extra/windows/types/types.factor b/extra/windows/types/types.factor index 8b4b2d98d2..3fef691741 100644 --- a/extra/windows/types/types.factor +++ b/extra/windows/types/types.factor @@ -198,7 +198,6 @@ TYPEDEF: void* MSGBOXPARAMSA TYPEDEF: void* MSGBOXPARAMSW TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE -TYPEDEF: int size_t TYPEDEF: size_t socklen_t TYPEDEF: void* WNDPROC diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor old mode 100644 new mode 100755 index 39d11b562b..57181d2704 --- a/extra/windows/winsock/winsock.factor +++ b/extra/windows/winsock/winsock.factor @@ -167,6 +167,9 @@ FUNCTION: int shutdown ( SOCKET s, int how ) ; FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ; FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ; +FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ; +FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ; + TYPEDEF: uint SERVICETYPE TYPEDEF: OVERLAPPED WSAOVERLAPPED TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index 9b1eeede96..29a8bbf10f 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -8,7 +8,7 @@ IN: wrap SYMBOL: width : line-chunks ( string -- words-lines ) - "\n" split [ " \t" split [ empty? not ] filter ] map ; + "\n" split [ " \t" split harvest ] map ; : (split-chunk) ( words -- ) -1 over [ length + 1+ dup width get > ] find drop nip diff --git a/unmaintained/openssl/openssl-docs.factor b/unmaintained/openssl/openssl-docs.factor deleted file mode 100644 index dd31bfd001..0000000000 --- a/unmaintained/openssl/openssl-docs.factor +++ /dev/null @@ -1,10 +0,0 @@ - -USING: help.syntax help.markup ; - -IN: openssl - -ARTICLE: "openssl" "OpenSSL" - -"Factor on Windows has been tested with this version of OpenSSL: " - -{ $url "http://www.openssl.org/related/binaries.html" } ; \ No newline at end of file diff --git a/unmaintained/openssl/openssl-tests.factor b/unmaintained/openssl/openssl-tests.factor deleted file mode 100755 index 2b840bdb9c..0000000000 --- a/unmaintained/openssl/openssl-tests.factor +++ /dev/null @@ -1,146 +0,0 @@ -USING: alien alien.c-types alien.strings assocs bit-arrays -hashtables io io.files io.encodings.ascii io.sockets kernel -mirrors openssl.libcrypto openssl.libssl namespaces math -math.parser openssl prettyprint sequences tools.test ; - -! ========================================================= -! Some crypto functions (still to be turned into words) -! ========================================================= - -[ - B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 } -] -[ "Hello world from the openssl binding" >md5 ] unit-test - -! Not found on netbsd, windows -- why? -! [ - ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 - ! 82 115 0 } -! ] -! [ "Hello world from the openssl binding" >sha1 ] unit-test - -! ========================================================= -! Initialize context -! ========================================================= - -[ ] [ init load-error-strings ] unit-test - -[ ] [ ssl-v23 new-ctx ] unit-test - -[ ] [ get-ctx "resource:extra/openssl/test/server.pem" use-cert-chain ] unit-test - -! TODO: debug 'Memory protection fault at address 6c' -! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd - -[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test - -! Enter PEM pass phrase: password -[ ] [ get-ctx "resource:extra/openssl/test/server.pem" -SSL_FILETYPE_PEM use-private-key ] unit-test - -[ ] [ get-ctx "resource:extra/openssl/test/root.pem" f -verify-load-locations ] unit-test - -[ ] [ get-ctx 1 set-verify-depth ] unit-test - -! ========================================================= -! Load Diffie-Hellman parameters -! ========================================================= - -[ ] [ "resource:extra/openssl/test/dh1024.pem" "r" bio-new-file ] unit-test - -[ ] [ get-bio f f f read-pem-dh-params ] unit-test - -[ ] [ get-bio bio-free ] unit-test - -! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol' -[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test - -! Workaround (this function should never be called directly) -! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test - -! ========================================================= -! Generate ephemeral RSA key -! ========================================================= - -[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test - -! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol' -! get-ctx get-rsa set-tmp-rsa-callback - -! Workaround (this function should never be called directly) -[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test - -[ ] [ get-rsa free-rsa ] unit-test - -! ========================================================= -! Listen and accept on socket -! ========================================================= - -! SYMBOL: sock -! SYMBOL: fdset -! SYMBOL: acset -! SYMBOL: sbio -! SYMBOL: ssl -! -! : is-set ( seq -- newseq ) -! >alist [ nip ] assoc-filter >hashtable keys ; -! -! ! 1234 server-socket sock set -! "127.0.0.1" 1234 SOCK_STREAM server-fd sock set -! -! FD_SETSIZE 8 * fdset set -! -! FD_SETSIZE 8 * t 8 rot [ set-nth ] keep fdset set -! -! fdset get is-set . - -! : loop ( -- ) -! sock get f f accept -! dup -1 = [ drop ] [ -! dup number>string print flush -! ! BIO_NOCLOSE bio-new-socket sbio set -! [ get-ctx new-ssl ssl set ] keep -! ssl get swap set-ssl-fd -! ! ssl get sbio get dup set-ssl-bio -! ! ssl get ssl-accept -! ! dup 0 <= [ -! ! ssl get swap ssl-get-error -! ! ] [ drop ] if -! ] if -! loop ; - -! { } acset set -! -! : loop ( -- ) -! ! FD_SETSIZE fdset get f f f select . flush -! FD_SETSIZE fdset get f f 10000 make-timeval select -! 0 <= [ acset get [ close ] each "timeout" print ] [ -! fdset get is-set sock get swap member? [ -! sock get f f accept dup . flush -! acset get swap add acset set -! ] [ ] if -! loop -! ] if ; -! -! loop -! -! sock get close - -! ========================================================= -! Dump errors to file -! ========================================================= - -[ ] [ "resource:extra/openssl/test/errors.txt" "w" bio-new-file ] unit-test - -[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test - -[ ] [ get-bio bio-free ] unit-test - -! ========================================================= -! Clean-up -! ========================================================= - -! sock get close - -get-ctx destroy-ctx diff --git a/unmaintained/openssl/openssl.factor b/unmaintained/openssl/openssl.factor deleted file mode 100755 index 9b23774598..0000000000 --- a/unmaintained/openssl/openssl.factor +++ /dev/null @@ -1,154 +0,0 @@ -! Copyright (C) 2007 Elie CHAFTARI -! See http://factorcode.org/license.txt for BSD license. -! -! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC - -USING: alien alien.c-types alien.strings assocs kernel libc -namespaces openssl.libcrypto openssl.libssl sequences -io.encodings.ascii ; - -IN: openssl - -SYMBOL: bio -SYMBOL: ssl-bio - -SYMBOL: ctx -SYMBOL: dh -SYMBOL: rsa - -! ========================================================= -! Callback routines -! ========================================================= - -: password-cb ( -- alien ) - "int" { "char*" "int" "int" "void*" } "cdecl" - [ 3drop "password" ascii string>alien 1023 memcpy - "password" length ] alien-callback ; - -! ========================================================= -! Error-handling routines -! ========================================================= - -: get-error ( -- num ) - ERR_get_error ; - -: error-string ( num -- str ) - f ERR_error_string ; - -: check-result ( result -- ) - 1 = [ ] [ - get-error error-string throw - ] if ; - -: ssl-get-error ( ssl ret -- ) - SSL_get_error error-messages at throw ; - -! Write errors to a file -: bio-new-file ( path mode -- ) - BIO_new_file bio set ; - -: bio-print ( bio str -- n ) - BIO_printf ; - -: bio-free ( bio -- ) - BIO_free check-result ; - -! ========================================================= -! Initialization routines -! ========================================================= - -: init ( -- ) - SSL_library_init drop ; ! always returns 1 - -: load-error-strings ( -- ) - SSL_load_error_strings ; - -: ssl-v23 ( -- method ) - SSLv23_method ; - -: new-ctx ( method -- ) - SSL_CTX_new ctx set ; - -: use-cert-chain ( ctx file -- ) - SSL_CTX_use_certificate_chain_file check-result ; - -: set-default-passwd ( ctx cb -- ) - SSL_CTX_set_default_passwd_cb ; - -: set-default-passwd-userdata ( ctx passwd -- ) - SSL_CTX_set_default_passwd_cb_userdata ; - -: use-private-key ( ctx file type -- ) - SSL_CTX_use_PrivateKey_file check-result ; - -: verify-load-locations ( ctx file path -- ) - SSL_CTX_load_verify_locations check-result ; - -: set-verify-depth ( ctx depth -- ) - SSL_CTX_set_verify_depth ; - -: read-pem-dh-params ( bio x cb u -- ) - PEM_read_bio_DHparams dh set ; - -: set-tmp-dh-callback ( ctx dh -- ) - SSL_CTX_set_tmp_dh_callback ; - -: set-ctx-ctrl ( ctx cmd larg parg -- ) - SSL_CTX_ctrl check-result ; - -: generate-rsa-key ( n e cb cbarg -- ) - RSA_generate_key rsa set ; - -: set-tmp-rsa-callback ( ctx rsa -- ) - SSL_CTX_set_tmp_rsa_callback ; - -: free-rsa ( rsa -- ) - RSA_free ; - -: bio-new-socket ( fd flag -- sbio ) - BIO_new_socket ; - -: new-ssl ( ctx -- ssl ) - SSL_new ; - -: set-ssl-bio ( ssl bio bio -- ) - SSL_set_bio ; - -: set-ssl-fd ( ssl fd -- ) - SSL_set_fd check-result ; - -: ssl-accept ( ssl -- result ) - SSL_accept ; - -! ========================================================= -! Clean-up and termination routines -! ========================================================= - -: destroy-ctx ( ctx -- ) - SSL_CTX_free ; - -! ========================================================= -! Public routines -! ========================================================= - -: get-bio ( -- bio ) - bio get ; - -: get-ssl-bio ( -- bio ) - ssl-bio get ; - -: get-ctx ( -- ctx ) - ctx get ; - -: get-dh ( -- dh ) - dh get ; - -: get-rsa ( -- rsa ) - rsa get ; - -: >md5 ( str -- byte-array ) - dup length 16 "uchar" [ MD5 ] keep nip ; - -: >sha1 ( str -- byte-array ) - dup length 20 "uchar" [ SHA1 ] keep nip ; - diff --git a/vm/data_gc.c b/vm/data_gc.c index 6e32e14991..a52f2490e9 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -648,12 +648,63 @@ void do_code_slots(CELL scan) } } +/* This function is performance-critical */ CELL collect_next(CELL scan) { - do_slots(scan,copy_handle); + CELL *obj = (CELL *)scan; + CELL *end = (CELL *)(scan + binary_payload_start(scan)); + + obj++; + + CELL newspace_start = newspace->start; + CELL newspace_end = newspace->end; + + if(HAVE_NURSERY_P && collecting_gen == NURSERY) + { + CELL nursery_start = nursery.start; + CELL nursery_end = nursery.end; + + for(; obj < end; obj++) + { + CELL pointer = *obj; + + if(!immediate_p(pointer) + && (pointer >= nursery_start && pointer < nursery_end)) + *obj = copy_object(pointer); + } + } + else if(HAVE_AGING_P && collecting_gen == AGING) + { + F_ZONE *tenured = &data_heap->generations[TENURED]; + + CELL tenured_start = tenured->start; + CELL tenured_end = tenured->end; + + for(; obj < end; obj++) + { + CELL pointer = *obj; + + if(!immediate_p(pointer) + && !(pointer >= newspace_start && pointer < newspace_end) + && !(pointer >= tenured_start && pointer < tenured_end)) + *obj = copy_object(pointer); + } + } + else if(collecting_gen == TENURED) + { + for(; obj < end; obj++) + { + CELL pointer = *obj; + + if(!immediate_p(pointer) + && !(pointer >= newspace_start && pointer < newspace_end)) + *obj = copy_object(pointer); + } - if(collecting_gen == TENURED) do_code_slots(scan); + } + else + critical_error("Bug in collect_next",0); return scan + untagged_object_size(scan); } diff --git a/vm/layouts.h b/vm/layouts.h index ff938309e7..89af0a306c 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -64,7 +64,7 @@ typedef signed long long s64; INLINE bool immediate_p(CELL obj) { - return (TAG(obj) == FIXNUM_TYPE || obj == F); + return (obj == F || TAG(obj) == FIXNUM_TYPE); } INLINE F_FIXNUM untag_fixnum_fast(CELL tagged)