diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index ac1895e37e..60bbbcd259 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators compiler.errors continuations layouts accessors -init ; +init sets ; IN: alien.compiler TUPLE: #alien-node < node return parameters abi ; @@ -339,7 +339,7 @@ SYMBOL: callbacks [ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook -: register-callback ( word -- ) dup callbacks get set-at ; +: register-callback ( word -- ) callbacks get conjoin ; M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index b33773cf9e..0e1042391c 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -79,7 +79,6 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" ARTICLE: "assocs-mutation" "Storing keys and values in assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" { $subsection delete-at* } -{ $subsection delete-any } { $subsection rename-at } { $subsection change-at } { $subsection at+ } @@ -242,12 +241,6 @@ HELP: delete-at* { $description "Removes an entry from the assoc and outputs the previous value together with a boolean indicating whether it was present." } { $side-effects "assoc" } ; -HELP: delete-any -{ $values { "assoc" assoc } { "key" "a key" } { "value" "a value" } } -{ $description "Removes an undetermined entry from the assoc and outputs it." } -{ $errors "Throws an error if the assoc is empty." } -{ $notes "This word is useful when using an assoc as an unordered queue which requires constant-time membership tests. Entries are enqueued with " { $link set-at } " and dequeued with " { $link delete-any } "." } ; - HELP: rename-at { $values { "newkey" object } { "key" object } { "assoc" assoc } } { $description "Removes the values associated to " { $snippet "key" } " and re-adds it as " { $snippet "newkey" } ". Does nothing if the assoc does not contain " { $snippet "key" } "." } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 15afce3e93..ca49b550b0 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -76,12 +76,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : rename-at ( newkey key assoc -- ) tuck delete-at* [ -rot set-at ] [ 3drop ] if ; -: delete-any ( assoc -- key value ) - [ - [ 2drop t ] assoc-find - [ "Assoc is empty" throw ] unless over - ] keep delete-at ; - : assoc-empty? ( assoc -- ? ) assoc-size zero? ; diff --git a/core/bit-arrays/bit-arrays-docs.factor b/core/bit-arrays/bit-arrays-docs.factor index f804ed21f4..6f3afe0867 100644 --- a/core/bit-arrays/bit-arrays-docs.factor +++ b/core/bit-arrays/bit-arrays-docs.factor @@ -1,5 +1,5 @@ USING: arrays help.markup help.syntax kernel -kernel.private prettyprint strings vectors sbufs ; +kernel.private math prettyprint strings vectors sbufs ; IN: bit-arrays ARTICLE: "bit-arrays" "Bit arrays" @@ -17,7 +17,10 @@ $nl { $subsection } "Efficiently setting and clearing all bits in a bit array:" { $subsection set-bits } -{ $subsection clear-bits } ; +{ $subsection clear-bits } +"Converting between unsigned integers and their binary representation:" +{ $subsection integer>bit-array } +{ $subsection bit-array>integer } ; ABOUT: "bit-arrays" @@ -47,3 +50,13 @@ HELP: set-bits { $code "[ drop t ] change-each" } } { $side-effects "bit-array" } ; + +HELP: integer>bit-array +{ $values { "integer" integer } { "bit-array" bit-array } } +{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." } +{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ; + +HELP: bit-array>integer +{ $values { "bit-array" bit-array } { "integer" integer } } +{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." } +{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ; diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index e28c16c3c2..03961c2db6 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -52,3 +52,23 @@ IN: bit-arrays.tests [ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test [ -10 ?{ } resize-bit-array ] must-fail + +[ -1 integer>bit-array ] must-fail +[ ?{ f t } ] [ 2 integer>bit-array ] unit-test +[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test +[ ?{ + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t +} ] [ + HEX: ffffffffffffffffffffffffffffffff integer>bit-array +] unit-test + +[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test +[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{ + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t +} bit-array>integer ] unit-test diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index ffb9f5d195..4446bb5556 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -51,4 +51,17 @@ M: bit-array equal? M: bit-array resize resize-bit-array ; +: integer>bit-array ( int -- bit-array ) + [ log2 1+ 0 ] keep + [ dup zero? not ] [ + [ -8 shift ] [ 255 bitand ] bi + -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip + ] [ ] while + 2drop ; + +: bit-array>integer ( bit-array -- int ) + dup >r length 7 + n>byte 0 r> [ + swap alien-unsigned-1 swap 8 shift bitor + ] curry reduce ; + INSTANCE: bit-array sequence diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 0187a6ce52..64b2cdb550 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -397,7 +397,7 @@ M: quotation ' [ { dictionary source-files builtins - update-map class<=-cache + update-map implementors-map class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache } [ dup get swap bootstrap-word set ] each diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6a3c1c35d5..e4e0db8609 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -37,6 +37,7 @@ H{ } clone forgotten-definitions set H{ } clone root-cache set H{ } clone source-files set H{ } clone update-map set +H{ } clone implementors-map set init-caches ! Vocabulary for slot accessors @@ -492,7 +493,8 @@ tuple "curry" "kernel" lookup [ f "inline" set-word-prop ] [ ] -[ tuple-layout [ ] curry ] tri define +[ tuple-layout [ ] curry ] tri +(( obj quot -- curry )) define-declared "compose" "kernel" create tuple @@ -513,7 +515,8 @@ tuple "compose" "kernel" lookup [ f "inline" set-word-prop ] [ ] -[ tuple-layout [ ] curry ] tri define +[ tuple-layout [ ] curry ] tri +(( quot1 quot2 -- compose )) define-declared ! Primitive words : make-primitive ( word vocab n -- ) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f94cc0ed37..5ee263469e 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -49,7 +49,7 @@ millis >r default-image-name "output-image" set-global -"math compiler help random tools ui ui.tools io handbook" "include" set-global +"math compiler help io random tools ui ui.tools unicode handbook" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 9fc4f6c4e7..1325fa65db 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -68,7 +68,10 @@ HELP: tuple-class { $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; HELP: update-map -{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; +{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; + +! HELP: implementors-map +! { $var-description "Assoc mapping each class to a set of generic words defining methods on this class." } ; HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index a03fed7fcb..7eaa6c0e12 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files -compiler.units kernel.private ; +compiler.units kernel.private sorting vocabs ; IN: classes.tests ! DEFER: bah @@ -169,3 +169,9 @@ M: method-forget-class method-forget-test ; [ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test + +[ t ] [ + all-words [ class? ] filter + implementors-map get keys + [ natural-sort ] bi@ = +] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 593213c5c6..0fef6de748 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions assocs kernel kernel.private slots.private namespaces sequences strings words vectors math -quotations combinators sorting effects graphs vocabs ; +quotations combinators sorting effects graphs vocabs sets ; IN: classes SYMBOL: class<=-cache @@ -27,24 +27,24 @@ SYMBOL: class-or-cache SYMBOL: update-map +SYMBOL: implementors-map + PREDICATE: class < word "class" word-prop ; PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; -: classes ( -- seq ) all-words [ class? ] filter ; +: classes ( -- seq ) implementors-map get keys ; : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; -: predicate-effect T{ effect f 1 { "?" } } ; - PREDICATE: predicate < word "predicating" word-prop >boolean ; : define-predicate ( class quot -- ) >r "predicate" word-prop first - r> predicate-effect define-declared ; + r> (( object -- ? )) define-declared ; : superclass ( class -- super ) #! Output f for non-classes to work with algebra code @@ -67,6 +67,8 @@ GENERIC: reset-class ( class -- ) M: word reset-class drop ; +GENERIC: implementors ( class/classes -- seq ) + ! update-map : class-uses ( class -- seq ) [ @@ -76,8 +78,8 @@ M: word reset-class drop ; tri ] { } make ; -: class-usages ( class -- assoc ) - [ update-map get at ] closure ; +: class-usages ( class -- seq ) + [ update-map get at ] closure keys ; r + dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless dup reset-class - dup class? [ dup new-class ] unless dup deferred? [ dup define-symbol ] when dup word-props r> assoc-union over set-word-props @@ -116,13 +128,11 @@ GENERIC: update-class ( class -- ) M: class update-class drop ; -GENERIC: update-methods ( class assoc -- ) +GENERIC: update-methods ( class seq -- ) : update-classes ( class -- ) dup class-usages - [ nip keys [ update-class ] each ] - [ update-methods ] - 2bi ; + [ nip [ update-class ] each ] [ update-methods ] 2bi ; : define-class ( word superclass members participants metaclass -- ) #! If it was already a class, update methods after. @@ -133,6 +143,31 @@ GENERIC: update-methods ( class assoc -- ) [ drop update-map+ ] 2tri ; +: forget-predicate ( class -- ) + dup "predicate" word-prop + dup length 1 = [ + first + tuck "predicating" word-prop = + [ forget ] [ drop ] if + ] [ 2drop ] if ; + +: forget-methods ( class -- ) + [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; + +: forget-class ( class -- ) + class-usages [ + { + [ forget-predicate ] + [ forget-methods ] + [ implementors-map- ] + [ update-map- ] + [ reset-class ] + } cleave + ] each ; + +M: class forget* ( class -- ) + [ forget-class ] [ call-next-method ] bi ; + GENERIC: class ( object -- class ) : instance? ( obj class -- ? ) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 9ffcd952e3..a2debe55a1 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -39,7 +39,7 @@ TUPLE: check-mixin-class mixin ; : update-classes/new ( mixin -- ) class-usages - [ keys [ update-class ] each ] + [ [ update-class ] each ] [ implementors [ make-generic ] each ] bi ; : add-mixin-instance ( class mixin -- ) @@ -51,8 +51,12 @@ TUPLE: check-mixin-class mixin ; #! updated by transitivity; the mixins usages appear in #! class-usages of the member, now that it's been added. [ 2drop ] [ - [ [ suffix ] change-mixin-class ] 2keep drop - dup new-class? [ update-classes/new ] [ update-classes ] if + [ [ suffix ] change-mixin-class ] 2keep + tuck [ new-class? ] either? [ + update-classes/new + ] [ + update-classes + ] if ] if-mixin-member? ; : remove-mixin-instance ( class mixin -- ) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index dc99734ce5..604914bd5c 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -109,6 +109,7 @@ TUPLE: yo-momma ; [ [ t ] [ \ yo-momma class? ] unit-test [ ] [ \ yo-momma forget ] unit-test + [ ] [ \ forget ] unit-test [ f ] [ \ yo-momma update-map get values memq? ] unit-test [ f ] [ \ yo-momma crossref get at ] unit-test @@ -552,11 +553,11 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test -[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ] +[ { subclass-forget-test-2 } ] [ subclass-forget-test-2 class-usages ] unit-test -[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ] +[ { subclass-forget-test-3 } ] [ subclass-forget-test-3 class-usages ] unit-test @@ -565,3 +566,32 @@ 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 + +! More +DEFER: subclass-reset-test +DEFER: subclass-reset-test-1 +DEFER: subclass-reset-test-2 +DEFER: subclass-reset-test-3 + +GENERIC: break-me ( obj -- ) + +[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test + +[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test + +[ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test + +[ f ] [ subclass-reset-test-1 tuple-class? ] unit-test +[ f ] [ subclass-reset-test-2 tuple-class? ] unit-test +[ subclass-forget-test-3 new ] must-fail + +[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test + +[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test + +[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 0b54d7d69f..5ba0b7e69c 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -166,7 +166,7 @@ M: tuple-class update-class 3tri ; : subclasses ( class -- classes ) - class-usages keys [ tuple-class? ] filter ; + class-usages [ tuple-class? ] filter ; : each-subclass ( class quot -- ) >r subclasses r> each ; inline diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 8c653b866e..4ee2fd5cdf 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -4,20 +4,25 @@ USING: kernel namespaces arrays sequences io inference.backend inference.state generator debugger words compiler.units continuations vocabs assocs alien.compiler dlists optimizer definitions math compiler.errors threads graphs generic -inference combinators ; +inference combinators dequeues search-dequeues ; IN: compiler -: ripple-up ( word -- ) - compiled-usage [ drop queue-compile ] assoc-each ; +SYMBOL: +failed+ + +: ripple-up ( words -- ) + dup "compiled-effect" word-prop +failed+ eq? + [ usage [ word? ] filter ] [ compiled-usage keys ] if + [ queue-compile ] each ; + +: ripple-up? ( word effect -- ? ) + #! If the word has previously been compiled and had a + #! different stack effect, we have to recompile any callers. + swap "compiled-effect" word-prop [ = not ] keep and ; : save-effect ( word effect -- ) - [ - over "compiled-effect" word-prop = [ - dup "compiled-uses" word-prop - [ dup ripple-up ] when - ] unless drop - ] - [ "compiled-effect" set-word-prop ] 2bi ; + [ dupd ripple-up? [ ripple-up ] [ drop ] if ] + [ "compiled-effect" set-word-prop ] + 2bi ; : compile-begins ( word -- ) f swap compiler-error ; @@ -26,9 +31,10 @@ IN: compiler [ swap compiler-error ] [ drop + [ compiled-unxref ] [ f swap compiled get set-at ] - [ f save-effect ] - bi + [ +failed+ save-effect ] + tri ] 2bi ; : compile-succeeded ( effect word -- ) @@ -40,6 +46,7 @@ IN: compiler ] tri ; : (compile) ( word -- ) + dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop [ H{ } clone dependencies set @@ -54,19 +61,15 @@ IN: compiler } cleave ] curry with-return ; -: compile-loop ( assoc -- ) - dup assoc-empty? [ drop ] [ - dup delete-any drop (compile) - yield - compile-loop - ] if ; +: compile-loop ( dequeue -- ) + [ (compile) yield ] slurp-dequeue ; : decompile ( word -- ) f 2array 1array t modify-code-heap ; : optimized-recompile-hook ( words -- alist ) [ - H{ } clone compile-queue set + compile-queue set H{ } clone compiled set [ queue-compile ] each compile-queue get compile-loop diff --git a/core/compiler/tests/insane.factor b/core/compiler/tests/insane.factor new file mode 100644 index 0000000000..79e17f7343 --- /dev/null +++ b/core/compiler/tests/insane.factor @@ -0,0 +1,4 @@ +IN: compiler.tests +USING: words kernel inference alien.strings tools.test ; + +[ ] [ \ if redefined [ string>alien ] infer. ] unit-test diff --git a/core/compiler/tests/redefine.factor b/core/compiler/tests/redefine.factor deleted file mode 100644 index b87898c649..0000000000 --- a/core/compiler/tests/redefine.factor +++ /dev/null @@ -1,14 +0,0 @@ -IN: compiler.tests -USING: compiler tools.test math parser ; - -GENERIC: method-redefine-test ( a -- b ) - -M: integer method-redefine-test 3 + ; - -: method-redefine-test-1 ( -- b ) 3 method-redefine-test ; - -[ 6 ] [ method-redefine-test-1 ] unit-test - -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test - -[ 7 ] [ method-redefine-test-1 ] unit-test diff --git a/core/compiler/tests/redefine1.factor b/core/compiler/tests/redefine1.factor new file mode 100644 index 0000000000..b7abacc6e4 --- /dev/null +++ b/core/compiler/tests/redefine1.factor @@ -0,0 +1,67 @@ +IN: compiler.tests +USING: compiler compiler.units tools.test math parser kernel +sequences sequences.private classes.mixin generic definitions +arrays words assocs ; + +GENERIC: method-redefine-test ( a -- b ) + +M: integer method-redefine-test 3 + ; + +: method-redefine-test-1 ( -- b ) 3 method-redefine-test ; + +[ 6 ] [ method-redefine-test-1 ] unit-test + +[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test + +[ 7 ] [ method-redefine-test-1 ] unit-test + +[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test + +[ 6 ] [ method-redefine-test-1 ] unit-test + +! Test ripple-up behavior +: hey ( -- ) ; +: there ( -- ) hey ; + +[ t ] [ \ hey compiled? ] unit-test +[ t ] [ \ there compiled? ] unit-test +[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test +[ f ] [ \ hey compiled? ] unit-test +[ f ] [ \ there compiled? ] unit-test +[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test +[ t ] [ \ there compiled? ] unit-test + +! Just changing the stack effect didn't mark a word for recompilation +DEFER: change-effect + +[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- b )" eval ] unit-test +{ 1 1 } [ change-effect ] must-infer-as + +[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- )" eval ] unit-test +{ 1 0 } [ change-effect ] must-infer-as + +: good ( -- ) ; +: bad ( -- ) good ; +: ugly ( -- ) bad ; + +[ t ] [ \ good compiled? ] unit-test +[ t ] [ \ bad compiled? ] unit-test +[ t ] [ \ ugly compiled? ] unit-test + +[ f ] [ \ good compiled-usage assoc-empty? ] unit-test + +[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test + +[ f ] [ \ good compiled? ] unit-test +[ f ] [ \ bad compiled? ] unit-test +[ f ] [ \ ugly compiled? ] unit-test + +[ t ] [ \ good compiled-usage assoc-empty? ] unit-test + +[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test + +[ t ] [ \ good compiled? ] unit-test +[ t ] [ \ bad compiled? ] unit-test +[ t ] [ \ ugly compiled? ] unit-test + +[ f ] [ \ good compiled-usage assoc-empty? ] unit-test diff --git a/core/compiler/tests/redefine2.factor b/core/compiler/tests/redefine2.factor new file mode 100644 index 0000000000..107381c4d3 --- /dev/null +++ b/core/compiler/tests/redefine2.factor @@ -0,0 +1,18 @@ +IN: compiler.tests +USING: compiler compiler.units tools.test math parser kernel +sequences sequences.private classes.mixin generic definitions +arrays words assocs ; + +DEFER: blah + +[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test + +[ t ] [ blah new sequence? ] unit-test + +[ 3 ] [ 0 blah new nth-unsafe ] unit-test + +[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test + +[ f ] [ blah new sequence? ] unit-test + +[ 0 blah new nth-unsafe ] must-fail diff --git a/core/compiler/tests/redefine3.factor b/core/compiler/tests/redefine3.factor new file mode 100644 index 0000000000..2b27b64b61 --- /dev/null +++ b/core/compiler/tests/redefine3.factor @@ -0,0 +1,32 @@ +IN: compiler.tests +USING: compiler compiler.units tools.test math parser kernel +sequences sequences.private classes.mixin generic definitions +arrays words assocs ; + +GENERIC: sheeple ( obj -- x ) + +M: object sheeple drop "sheeple" ; + +MIXIN: empty-mixin + +M: empty-mixin sheeple drop "wake up" ; + +: sheeple-test ( -- string ) { } sheeple ; + +[ "sheeple" ] [ sheeple-test ] unit-test +[ t ] [ \ sheeple-test compiled? ] unit-test +[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test +[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test + +[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test + +[ "wake up" ] [ sheeple-test ] unit-test +[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test +[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test + +[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test + +[ "sheeple" ] [ sheeple-test ] unit-test +[ t ] [ \ sheeple-test compiled? ] unit-test +[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test +[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/core/compiler/tests/reload.factor b/core/compiler/tests/reload.factor new file mode 100644 index 0000000000..1e31757fca --- /dev/null +++ b/core/compiler/tests/reload.factor @@ -0,0 +1,6 @@ +IN: compiler.tests +USE: vocabs.loader + +"parser" reload +"sequences" reload +"kernel" reload diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 658a64315e..b0c4948956 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -79,9 +79,15 @@ SYMBOL: update-tuples-hook : call-update-tuples-hook ( -- ) update-tuples-hook get call ; +: unxref-forgotten-definitions ( -- ) + forgotten-definitions get + keys [ word? ] filter + [ delete-compiled-xref ] each ; + : finish-compilation-unit ( -- ) call-recompile-hook call-update-tuples-hook + unxref-forgotten-definitions dup [ drop crossref? ] assoc-contains? modify-code-heap ; : with-nested-compilation-unit ( quot -- ) diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index 16083a8628..312b952b84 100755 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -6,13 +6,13 @@ IN: bootstrap.x86 4 \ cell set -: arg0 EAX ; -: arg1 EDX ; -: temp-reg EBX ; -: stack-reg ESP ; -: ds-reg ESI ; -: fixnum>slot@ arg0 1 SAR ; -: rex-length 0 ; +: arg0 ( -- reg ) EAX ; +: arg1 ( -- reg ) EDX ; +: temp-reg ( -- reg ) EBX ; +: stack-reg ( -- reg ) ESP ; +: ds-reg ( -- reg ) ESI ; +: fixnum>slot@ ( -- ) arg0 1 SAR ; +: rex-length ( -- n ) 0 ; << "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor index 93bf7cca17..d167c2882a 100755 --- a/core/cpu/x86/64/bootstrap.factor +++ b/core/cpu/x86/64/bootstrap.factor @@ -6,13 +6,13 @@ IN: bootstrap.x86 8 \ cell set -: arg0 RDI ; -: arg1 RSI ; -: temp-reg RBX ; -: stack-reg RSP ; -: ds-reg R14 ; -: fixnum>slot@ ; -: rex-length 1 ; +: arg0 ( -- reg ) RDI ; +: arg1 ( -- reg ) RSI ; +: temp-reg ( -- reg ) RBX ; +: stack-reg ( -- reg ) RSP ; +: ds-reg ( -- reg ) R14 ; +: fixnum>slot@ ( -- ) ; +: rex-length ( -- n ) 1 ; << "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index bd1b0f2871..011c27112e 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -9,7 +9,7 @@ big-endian off 1 jit-code-format set -: stack-frame-size 4 bootstrap-cells ; +: stack-frame-size ( -- n ) 4 bootstrap-cells ; [ ! Load word diff --git a/core/dequeues/authors.txt b/core/dequeues/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/core/dequeues/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/dequeues/dequeues-docs.factor b/core/dequeues/dequeues-docs.factor new file mode 100644 index 0000000000..25cc969ff2 --- /dev/null +++ b/core/dequeues/dequeues-docs.factor @@ -0,0 +1,89 @@ +IN: dequeues +USING: help.markup help.syntax kernel ; + +ARTICLE: "dequeues" "Dequeues" +"A dequeue is a data structure with constant-time insertion and removal of elements at both ends. Dequeue operations are defined in the " { $vocab-link "dequeues" } " vocabulary." +$nl +"Dequeues must be instances of a mixin class:" +{ $subsection dequeue } +"Dequeues must implement a protocol." +$nl +"Querying the dequeue:" +{ $subsection peek-front } +{ $subsection peek-back } +{ $subsection dequeue-length } +{ $subsection dequeue-member? } +"Adding and removing elements:" +{ $subsection push-front* } +{ $subsection push-back* } +{ $subsection pop-front* } +{ $subsection pop-back* } +{ $subsection clear-dequeue } +"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":" +{ $subsection delete-node } +{ $subsection node-value } +"Utility operations built in terms of the above:" +{ $subsection dequeue-empty? } +{ $subsection push-front } +{ $subsection push-all-front } +{ $subsection push-back } +{ $subsection push-all-back } +{ $subsection pop-front } +{ $subsection pop-back } +{ $subsection slurp-dequeue } +"When using a dequeue as a queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "." ; + +ABOUT: "dequeues" + +HELP: dequeue-empty? +{ $values { "dequeue" { $link dequeue } } { "?" "a boolean" } } +{ $description "Returns true if a dequeue is empty." } +{ $notes "This operation is O(1)." } ; + +HELP: push-front +{ $values { "obj" object } { "dequeue" dequeue } } +{ $description "Push the object onto the front of the dequeue." } +{ $notes "This operation is O(1)." } ; + +HELP: push-front* +{ $values { "obj" object } { "dequeue" dequeue } { "node" "a node" } } +{ $description "Push the object onto the front of the dequeue and return the newly created node." } +{ $notes "This operation is O(1)." } ; + +HELP: push-back +{ $values { "obj" object } { "dequeue" dequeue } } +{ $description "Push the object onto the back of the dequeue." } +{ $notes "This operation is O(1)." } ; + +HELP: push-back* +{ $values { "obj" object } { "dequeue" dequeue } { "node" "a node" } } +{ $description "Push the object onto the back of the dequeue and return the newly created node." } +{ $notes "This operation is O(1)." } ; + +HELP: peek-front +{ $values { "dequeue" dequeue } { "obj" object } } +{ $description "Returns the object at the front of the dequeue." } ; + +HELP: pop-front +{ $values { "dequeue" dequeue } { "obj" object } } +{ $description "Pop the object off the front of the dequeue and return the object." } +{ $notes "This operation is O(1)." } ; + +HELP: pop-front* +{ $values { "dequeue" dequeue } } +{ $description "Pop the object off the front of the dequeue." } +{ $notes "This operation is O(1)." } ; + +HELP: peek-back +{ $values { "dequeue" dequeue } { "obj" object } } +{ $description "Returns the object at the back of the dequeue." } ; + +HELP: pop-back +{ $values { "dequeue" dequeue } { "obj" object } } +{ $description "Pop the object off the back of the dequeue and return the object." } +{ $notes "This operation is O(1)." } ; + +HELP: pop-back* +{ $values { "dequeue" dequeue } } +{ $description "Pop the object off the back of the dequeue." } +{ $notes "This operation is O(1)." } ; diff --git a/core/dequeues/dequeues.factor b/core/dequeues/dequeues.factor new file mode 100644 index 0000000000..67c87d79c3 --- /dev/null +++ b/core/dequeues/dequeues.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences math ; +IN: dequeues + +GENERIC: push-front* ( obj dequeue -- node ) +GENERIC: push-back* ( obj dequeue -- node ) +GENERIC: peek-front ( dequeue -- obj ) +GENERIC: peek-back ( dequeue -- obj ) +GENERIC: pop-front* ( dequeue -- ) +GENERIC: pop-back* ( dequeue -- ) +GENERIC: delete-node ( node dequeue -- ) +GENERIC: dequeue-length ( dequeue -- n ) +GENERIC: dequeue-member? ( value dequeue -- ? ) +GENERIC: clear-dequeue ( dequeue -- ) +GENERIC: node-value ( node -- value ) + +: dequeue-empty? ( dequeue -- ? ) + dequeue-length zero? ; + +: push-front ( obj dequeue -- ) + push-front* drop ; + +: push-all-front ( seq dequeue -- ) + [ push-front ] curry each ; + +: push-back ( obj dequeue -- ) + push-back* drop ; + +: push-all-back ( seq dequeue -- ) + [ push-back ] curry each ; + +: pop-front ( dequeue -- obj ) + [ peek-front ] [ pop-front* ] bi ; + +: pop-back ( dequeue -- obj ) + [ peek-back ] [ pop-back* ] bi ; + +: slurp-dequeue ( dequeue quot -- ) + over dequeue-empty? [ 2drop ] [ + [ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi + ] if ; inline + +MIXIN: dequeue diff --git a/core/dequeues/summary.txt b/core/dequeues/summary.txt new file mode 100644 index 0000000000..2f348ebb05 --- /dev/null +++ b/core/dequeues/summary.txt @@ -0,0 +1 @@ +Double-ended queue protocol and common operations diff --git a/core/dequeues/tags.txt b/core/dequeues/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/dequeues/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor index 8616d1f253..8ee3510bb9 100755 --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -1,103 +1,27 @@ -USING: help.markup help.syntax kernel quotations dlists.private ; +USING: help.markup help.syntax kernel quotations +dequeues ; IN: dlists -ARTICLE: "dlists" "Doubly-linked lists" -"A doubly-linked list, or dlist, is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object." +ARTICLE: "dlists" "Double-linked lists" +"A double-linked list is the canonical implementation of a " { $link dequeue } "." $nl -"While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time." -$nl -"When using a dlist as a simple queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "." -$nl -"Dlists form a class:" +"Double-linked lists form a class:" { $subsection dlist } { $subsection dlist? } -"Constructing a dlist:" +"Constructing a double-linked list:" { $subsection } -"Working with the front of the list:" -{ $subsection push-front } -{ $subsection push-front* } -{ $subsection peek-front } -{ $subsection pop-front } -{ $subsection pop-front* } -"Working with the back of the list:" -{ $subsection push-back } -{ $subsection push-back* } -{ $subsection peek-back } -{ $subsection pop-back } -{ $subsection pop-back* } -"Finding out the length:" -{ $subsection dlist-empty? } -{ $subsection dlist-length } +"Double-linked lists support all the operations of the dequeue protocol (" { $link "dequeues" } ") as well as the following." +$nl "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } { $subsection dlist-contains? } -"Deleting a node:" -{ $subsection delete-node } -{ $subsection dlist-delete } "Deleting a node matching a predicate:" { $subsection delete-node-if* } -{ $subsection delete-node-if } -"Consuming all nodes:" -{ $subsection dlist-slurp } ; +{ $subsection delete-node-if } ; ABOUT: "dlists" -HELP: dlist-empty? -{ $values { "dlist" { $link dlist } } { "?" "a boolean" } } -{ $description "Returns true if a " { $link dlist } " is empty." } -{ $notes "This operation is O(1)." } ; - -HELP: push-front -{ $values { "obj" "an object" } { "dlist" dlist } } -{ $description "Push the object onto the front of the " { $link dlist } "." } -{ $notes "This operation is O(1)." } ; - -HELP: push-front* -{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } } -{ $description "Push the object onto the front of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." } -{ $notes "This operation is O(1)." } ; - -HELP: push-back -{ $values { "obj" "an object" } { "dlist" dlist } } -{ $description "Push the object onto the back of the " { $link dlist } "." } -{ $notes "This operation is O(1)." } ; - -HELP: push-back* -{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } } -{ $description "Push the object onto the back of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." } -{ $notes "This operation is O(1)." } ; - -HELP: peek-front -{ $values { "dlist" dlist } { "obj" "an object" } } -{ $description "Returns the object at the front of the " { $link dlist } "." } ; - -HELP: pop-front -{ $values { "dlist" dlist } { "obj" "an object" } } -{ $description "Pop the object off the front of the " { $link dlist } " and return the object." } -{ $notes "This operation is O(1)." } ; - -HELP: pop-front* -{ $values { "dlist" dlist } } -{ $description "Pop the object off the front of the " { $link dlist } "." } -{ $notes "This operation is O(1)." } ; - -HELP: peek-back -{ $values { "dlist" dlist } { "obj" "an object" } } -{ $description "Returns the object at the back of the " { $link dlist } "." } ; - -HELP: pop-back -{ $values { "dlist" dlist } { "obj" "an object" } } -{ $description "Pop the object off the back of the " { $link dlist } " and return the object." } -{ $notes "This operation is O(1)." } ; - -HELP: pop-back* -{ $values { "dlist" dlist } } -{ $description "Pop the object off the back of the " { $link dlist } "." } -{ $notes "This operation is O(1)." } ; - -{ push-front push-front* push-back push-back* peek-front pop-front pop-front* peek-back pop-back pop-back* } related-words - HELP: dlist-find { $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 886572c867..ff015bf95b 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -1,17 +1,17 @@ -USING: dlists dlists.private kernel tools.test random assocs -sets sequences namespaces sorting debugger io prettyprint +USING: dequeues dlists dlists.private kernel tools.test random +assocs sets sequences namespaces sorting debugger io prettyprint math accessors classes ; IN: dlists.tests -[ t ] [ dlist-empty? ] unit-test +[ t ] [ dequeue-empty? ] unit-test [ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ] [ 1 over push-front ] unit-test ! Make sure empty lists are empty -[ t ] [ dlist-empty? ] unit-test -[ f ] [ 1 over push-front dlist-empty? ] unit-test -[ f ] [ 1 over push-back dlist-empty? ] unit-test +[ t ] [ dequeue-empty? ] unit-test +[ f ] [ 1 over push-front dequeue-empty? ] unit-test +[ f ] [ 1 over push-back dequeue-empty? ] unit-test [ 1 ] [ 1 over push-front pop-front ] unit-test [ 1 ] [ 1 over push-front pop-back ] unit-test @@ -25,22 +25,22 @@ IN: dlists.tests ! Test the prev,next links for two nodes [ f ] [ 1 over push-back 2 over push-back - dlist-front dlist-node-prev + front>> prev>> ] unit-test [ 2 ] [ 1 over push-back 2 over push-back - dlist-front dlist-node-next dlist-node-obj + front>> next>> obj>> ] unit-test [ 1 ] [ 1 over push-back 2 over push-back - dlist-front dlist-node-next dlist-node-prev dlist-node-obj + front>> next>> prev>> obj>> ] unit-test [ f ] [ 1 over push-back 2 over push-back - dlist-front dlist-node-next dlist-node-next + front>> next>> next>> ] unit-test [ f f ] [ [ 1 = ] dlist-find ] unit-test @@ -50,55 +50,24 @@ IN: dlists.tests [ t ] [ 1 over push-back [ 1 = ] dlist-contains? ] unit-test [ 1 ] [ 1 over push-back [ 1 = ] delete-node-if ] unit-test -[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test -[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test -[ 0 ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test +[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-empty? ] unit-test +[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-empty? ] unit-test +[ 0 ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dequeue-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dequeue-length ] unit-test -[ 0 ] [ dlist-length ] unit-test -[ 1 ] [ 1 over push-front dlist-length ] unit-test -[ 0 ] [ 1 over push-front dup pop-front* dlist-length ] unit-test - -: assert-same-elements - [ prune natural-sort ] bi@ assert= ; - -: dlist-delete-all [ dlist-delete drop ] curry each ; - -: dlist>array [ [ , ] dlist-slurp ] { } make ; - -[ ] [ - 5 [ drop 30 random >fixnum ] map prune - 6 [ drop 30 random >fixnum ] map prune [ - - [ push-all-front ] - [ dlist-delete-all ] - [ dlist>array ] tri - ] 2keep swap diff assert-same-elements -] unit-test - -[ ] [ - "d" set - 1 "d" get push-front - 2 "d" get push-front - 3 "d" get push-front - 4 "d" get push-front - 2 "d" get dlist-delete drop - 3 "d" get dlist-delete drop - 4 "d" get dlist-delete drop -] unit-test - -[ 1 ] [ "d" get dlist-length ] unit-test -[ 1 ] [ "d" get dlist>array length ] unit-test +[ 0 ] [ dequeue-length ] unit-test +[ 1 ] [ 1 over push-front dequeue-length ] unit-test +[ 0 ] [ 1 over push-front dup pop-front* dequeue-length ] unit-test [ t ] [ 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test [ t ] [ 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test [ t ] [ 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test [ ] [ 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test -[ peek-front ] must-fail -[ peek-back ] must-fail +[ peek-front ] [ empty-dlist? ] must-fail-with +[ peek-back ] [ empty-dlist? ] must-fail-with [ pop-front ] [ empty-dlist? ] must-fail-with [ pop-back ] [ empty-dlist? ] must-fail-with diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index e07bfcdabe..2b6c7f11f7 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -1,16 +1,17 @@ ! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math sequences accessors inspector ; +USING: combinators kernel math sequences accessors inspector +dequeues ; IN: dlists TUPLE: dlist front back length ; : ( -- obj ) dlist new - 0 >>length ; + 0 >>length ; -: dlist-empty? ( dlist -- ? ) front>> not ; +M: dlist dequeue-length length>> ; dlist-node +M: dlist-node node-value obj>> ; + : inc-length ( dlist -- ) [ 1+ ] change-length drop ; inline @@ -57,69 +60,59 @@ C: dlist-node : dlist-each-node ( dlist quot -- ) [ f ] compose dlist-find-node 2drop ; inline +: unlink-node ( dlist-node -- ) + dup prev>> over next>> set-prev-when + dup next>> swap prev>> set-next-when ; + PRIVATE> -: push-front* ( obj dlist -- dlist-node ) +M: dlist push-front* ( obj dlist -- dlist-node ) [ front>> f swap dup dup set-next-prev ] keep [ (>>front) ] keep [ set-back-to-front ] keep inc-length ; -: push-front ( obj dlist -- ) - push-front* drop ; - -: push-all-front ( seq dlist -- ) - [ push-front ] curry each ; - -: push-back* ( obj dlist -- dlist-node ) +M: dlist push-back* ( obj dlist -- dlist-node ) [ back>> f ] keep [ back>> set-next-when ] 2keep [ (>>back) ] 2keep [ set-front-to-back ] keep inc-length ; -: push-back ( obj dlist -- ) - push-back* drop ; - -: push-all-back ( seq dlist -- ) - [ push-back ] curry each ; - ERROR: empty-dlist ; M: empty-dlist summary ( dlist -- ) - drop "Emtpy dlist" ; + drop "Empty dlist" ; -: peek-front ( dlist -- obj ) - front>> [ empty-dlist ] unless* obj>> ; +M: dlist peek-front ( dlist -- obj ) + front>> [ obj>> ] [ empty-dlist ] if* ; -: pop-front ( dlist -- obj ) - dup front>> [ empty-dlist ] unless* +M: dlist pop-front* ( dlist -- ) + dup front>> [ empty-dlist ] unless [ + dup front>> dup next>> f rot (>>next) f over set-prev-when swap (>>front) - ] 2keep obj>> - swap [ normalize-back ] keep dec-length ; + ] keep + [ normalize-back ] keep + dec-length ; -: pop-front* ( dlist -- ) - pop-front drop ; +M: dlist peek-back ( dlist -- obj ) + back>> [ obj>> ] [ empty-dlist ] if* ; -: peek-back ( dlist -- obj ) - back>> [ empty-dlist ] unless* obj>> ; - -: pop-back ( dlist -- obj ) - dup back>> [ empty-dlist ] unless* +M: dlist pop-back* ( dlist -- ) + dup back>> [ empty-dlist ] unless [ + dup back>> dup prev>> f rot (>>prev) f over set-next-when swap (>>back) - ] 2keep obj>> - swap [ normalize-front ] keep dec-length ; - -: pop-back* ( dlist -- ) - pop-back drop ; + ] keep + [ normalize-front ] keep + dec-length ; : dlist-find ( dlist quot -- obj/f ? ) [ obj>> ] prepose @@ -128,21 +121,20 @@ M: empty-dlist summary ( dlist -- ) : dlist-contains? ( dlist quot -- ? ) dlist-find nip ; inline -: unlink-node ( dlist-node -- ) - dup prev>> over next>> set-prev-when - dup next>> swap prev>> set-next-when ; +M: dlist dequeue-member? ( value dlist -- ? ) + [ = ] curry dlist-contains? ; -: delete-node ( dlist dlist-node -- ) +M: dlist delete-node ( dlist-node dlist -- ) { - { [ over front>> over eq? ] [ drop pop-front* ] } - { [ over back>> over eq? ] [ drop pop-back* ] } - [ unlink-node dec-length ] + { [ 2dup front>> eq? ] [ nip pop-front* ] } + { [ 2dup back>> eq? ] [ nip pop-back* ] } + [ dec-length unlink-node ] } cond ; : delete-node-if* ( dlist quot -- obj/f ? ) dupd dlist-find-node [ dup [ - [ delete-node ] keep obj>> t + [ swap delete-node ] keep obj>> t ] [ 2drop f f ] if @@ -151,13 +143,9 @@ M: empty-dlist summary ( dlist -- ) ] if ; inline : delete-node-if ( dlist quot -- obj/f ) - [ obj>> ] prepose - delete-node-if* drop ; inline + [ obj>> ] prepose delete-node-if* drop ; inline -: dlist-delete ( obj dlist -- obj/f ) - swap [ eq? ] curry delete-node-if ; - -: dlist-delete-all ( dlist -- ) +M: dlist clear-dequeue ( dlist -- ) f >>front f >>back 0 >>length @@ -166,9 +154,6 @@ M: empty-dlist summary ( dlist -- ) : dlist-each ( dlist quot -- ) [ obj>> ] prepose dlist-each-node ; inline -: dlist-slurp ( dlist quot -- ) - over dlist-empty? - [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ; - inline - : 1dlist ( obj -- dlist ) [ push-front ] keep ; + +INSTANCE: dlist dequeue diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 66beae443f..bee2f5f2fd 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -11,6 +11,7 @@ $nl "Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:" { $table { { { $snippet "?" } } "a boolean" } + { { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } } { { { $snippet "elt" } } "an object which is an element of a sequence" } { { { $snippet "m" } ", " { $snippet "n" } } "an integer" } { { { $snippet "obj" } } "an object" } diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 684c058913..241858c95b 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2008 Slava Pestov. + ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel kernel.private layouts math namespaces optimizer optimizer.specializers prettyprint quotations sequences system -threads words vectors ; +threads words vectors sets dequeues ; IN: generator SYMBOL: compile-queue @@ -16,7 +16,7 @@ SYMBOL: compiled { [ dup compiled get key? ] [ drop ] } { [ dup inlined-block? ] [ drop ] } { [ dup primitive? ] [ drop ] } - [ dup compile-queue get set-at ] + [ compile-queue get push-front ] } cond ; : maybe-compile ( word -- ) @@ -72,10 +72,12 @@ GENERIC: generate-node ( node -- next ) : word-dataflow ( word -- effect dataflow ) [ - dup "cannot-infer" word-prop [ cannot-infer-effect ] when - dup "no-compile" word-prop [ cannot-infer-effect ] when - dup specialized-def over dup 2array 1array infer-quot - finish-word + [ + dup "cannot-infer" word-prop [ cannot-infer-effect ] when + dup "no-compile" word-prop [ cannot-infer-effect ] when + dup specialized-def over dup 2array 1array infer-quot + finish-word + ] maybe-cannot-infer ] with-infer ; : intrinsics ( #call -- quot ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index fb9820008a..ca6949366a 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -2,7 +2,8 @@ ! 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 combinators ; +classes.algebra quotations arrays vocabs effects combinators +sets ; IN: generic ! Method combination protocol @@ -58,18 +59,17 @@ TUPLE: check-method class generic ; : affected-methods ( class generic -- seq ) "methods" word-prop swap - [ nip classes-intersect? ] curry assoc-filter + [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter values ; : update-generic ( class generic -- ) - [ affected-methods [ +called+ changed-definition ] each ] - [ make-generic ] - bi ; + affected-methods [ +called+ changed-definition ] each ; : with-methods ( class generic quot -- ) + [ drop update-generic ] [ [ "methods" word-prop ] dip call ] - [ drop update-generic ] 3bi ; - inline + [ drop make-generic drop ] + 3tri ; inline : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; @@ -81,7 +81,7 @@ M: method-body stack-effect "method-generic" word-prop stack-effect ; M: method-body crossref? - drop t ; + "forgotten" word-prop not ; : method-word-props ( class generic -- assoc ) [ @@ -95,8 +95,13 @@ M: method-body crossref? method-word-name f [ set-word-props ] keep ; +: with-implementors ( class generic quot -- ) + [ swap implementors-map get at ] dip call ; inline + : reveal-method ( method class generic -- ) - [ set-at ] with-methods ; + [ [ conjoin ] with-implementors ] + [ [ set-at ] with-methods ] + 2bi ; : create-method ( class generic -- method ) 2dup method dup [ @@ -106,8 +111,8 @@ M: method-body crossref? ] if ; : ( generic combination -- method ) - object bootstrap-word pick - [ -rot make-default-method define ] keep ; + [ drop object bootstrap-word swap ] [ make-default-method ] 2bi + [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ; : define-default-method ( generic combination -- ) dupd "default-method" set-word-prop ; @@ -137,54 +142,36 @@ M: method-body definer M: method-body forget* dup "forgotten" word-prop [ drop ] [ [ - [ ] - [ "method-class" word-prop ] - [ "method-generic" word-prop ] tri - 3dup method eq? [ - [ delete-at ] with-methods - call-next-method - ] [ 3drop ] if + dup "default" word-prop [ drop ] [ + [ + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + 2dup method + ] keep eq? + [ + [ [ delete-at ] with-methods ] + [ [ delete-at ] with-implementors ] + 2bi + ] [ 2drop ] if + ] if ] - [ t "forgotten" set-word-prop ] bi + [ call-next-method ] bi ] if ; M: method-body smart-usage "method-generic" word-prop smart-usage ; -GENERIC: implementors ( class/classes -- seq ) - -M: class implementors - all-words [ "methods" word-prop key? ] with filter ; - -M: assoc implementors - all-words [ - "methods" word-prop keys - swap [ key? ] curry contains? - ] with filter ; - -: forget-methods ( class -- ) - [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; - -M: class forget* ( class -- ) - [ - class-usages [ - drop - [ forget-methods ] - [ update-map- ] - [ reset-class ] - tri - ] assoc-each - ] - [ call-next-method ] bi ; - -M: assoc update-methods ( class assoc -- ) - implementors [ update-generic ] with each ; +M: sequence update-methods ( class seq -- ) + implementors [ + [ update-generic ] [ make-generic drop ] 2bi + ] with each ; : define-generic ( word combination -- ) over "combination" word-prop over = [ 2drop ] [ 2dup "combination" set-word-prop + over "methods" word-prop values forget-all over H{ } clone "methods" set-word-prop dupd define-default-method make-generic diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 9a780383b5..2654490d88 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -64,7 +64,7 @@ M: engine-word stack-effect [ extra-values ] [ stack-effect ] bi dup [ clone [ length + ] change-in ] [ 2drop f ] if ; -M: engine-word crossref? drop t ; +M: engine-word crossref? "forgotten" word-prop not ; M: engine-word irrelevant? drop t ; diff --git a/core/graphs/graphs.factor b/core/graphs/graphs.factor index 973d49f1fa..792b2ab340 100644 --- a/core/graphs/graphs.factor +++ b/core/graphs/graphs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel namespaces sequences ; +USING: assocs kernel namespaces sequences sets ; IN: graphs SYMBOL: graph @@ -41,7 +41,7 @@ SYMBOL: previous over previous get key? [ 2drop ] [ - over dup previous get set-at + over previous get conjoin dup slip [ nip (closure) ] curry assoc-each ] if ; inline diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor index 894412d922..f7a37691a6 100644 --- a/core/grouping/grouping-docs.factor +++ b/core/grouping/grouping-docs.factor @@ -33,7 +33,7 @@ HELP: group { $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." } { $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } { $examples - { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" } + { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" } } ; HELP: @@ -41,7 +41,7 @@ HELP: { $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example - "USING: arrays kernel prettyprint sequences splitting ;" + "USING: arrays kernel prettyprint sequences grouping ;" "9 >array 3 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" } } ; @@ -51,7 +51,7 @@ HELP: { $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example - "USING: arrays kernel prettyprint sequences splitting ;" + "USING: arrays kernel prettyprint sequences grouping ;" "9 >array 3 " "dup [ reverse-here ] each concat >array ." "{ 2 1 0 5 4 3 8 7 6 }" @@ -68,7 +68,7 @@ HELP: clump { $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." } { $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." } { $examples - { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" } + { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" } } ; HELP: @@ -77,7 +77,7 @@ HELP: { $examples "Running averages:" { $example - "USING: splitting sequences math prettyprint kernel ;" + "USING: grouping sequences math prettyprint kernel ;" "IN: scratchpad" ": share-price" " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;" diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 080e77af02..8966a38496 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -4,7 +4,8 @@ USING: inference.dataflow inference.state arrays generic io io.streams.string kernel math namespaces parser prettyprint sequences strings vectors words quotations effects classes continuations debugger assocs combinators compiler.errors -generic.standard.engines.tuple accessors math.order definitions ; +generic.standard.engines.tuple accessors math.order definitions +sets ; IN: inference.backend : recursive-label ( word -- label/f ) @@ -28,7 +29,7 @@ SYMBOL: visited : (redefined) ( word -- ) dup visited get key? [ drop ] [ [ reset-on-redefine reset-props ] - [ dup visited get set-at ] + [ visited get conjoin ] [ crossref get at keys [ word? ] filter @@ -420,6 +421,9 @@ TUPLE: missing-effect word ; [ "inferred-effect" set-word-prop ] 2tri ; +: maybe-cannot-infer ( word quot -- ) + [ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline + : infer-word ( word -- effect ) [ [ @@ -430,7 +434,7 @@ TUPLE: missing-effect word ; finish-word current-effect ] with-scope - ] [ ] [ t "cannot-infer" set-word-prop ] cleanup ; + ] maybe-cannot-infer ; : custom-infer ( word -- ) #! Customized inference behavior diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 7f073bfad9..c9c3f1de6b 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -546,26 +546,26 @@ ERROR: custom-error ; [ [ erg's-inference-bug ] infer ] must-fail -! : inference-invalidation-a ( -- ); -! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline -! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; -! -! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test -! -! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as -! -! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test -! -! [ 3 ] [ inference-invalidation-c ] unit-test -! -! { 0 1 } [ inference-invalidation-c ] must-infer-as -! -! GENERIC: inference-invalidation-d ( obj -- ) -! -! M: object inference-invalidation-d inference-invalidation-c 2drop ; -! -! \ inference-invalidation-d must-infer -! -! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test -! -! [ [ inference-invalidation-d ] infer ] must-fail +: inference-invalidation-a ( -- ) ; +: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline +: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline + +[ 7 ] [ 4 3 inference-invalidation-c ] unit-test + +{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as + +[ ] [ "IN: inference.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test + +[ 3 ] [ inference-invalidation-c ] unit-test + +{ 0 1 } [ inference-invalidation-c ] must-infer-as + +GENERIC: inference-invalidation-d ( obj -- ) + +M: object inference-invalidation-d inference-invalidation-c 2drop ; + +\ inference-invalidation-d must-infer + +[ ] [ "IN: inference.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test + +[ [ inference-invalidation-d ] infer ] must-fail diff --git a/core/inference/inference.factor b/core/inference/inference.factor index d73e43cdfc..da9e6ff10d 100755 --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -9,19 +9,22 @@ IN: inference GENERIC: infer ( quot -- effect ) M: callable infer ( quot -- effect ) - [ f infer-quot ] with-infer drop ; + [ recursive-state get infer-quot ] with-infer drop ; : infer. ( quot -- ) + #! Safe to call from inference transforms. infer effect>string print ; GENERIC: dataflow ( quot -- dataflow ) M: callable dataflow + #! Not safe to call from inference transforms. [ f infer-quot ] with-infer nip ; GENERIC# dataflow-with 1 ( quot stack -- dataflow ) M: callable dataflow-with + #! Not safe to call from inference transforms. [ V{ } like meta-d set f infer-quot diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index 0ab016b0fa..fd4e11901a 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -95,10 +95,8 @@ SYMBOL: +editable+ : describe ( obj -- ) H{ } describe* ; : namestack. ( seq -- ) - [ - [ global eq? not ] filter - [ keys ] map concat prune - ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ; + [ [ global eq? not ] filter [ keys ] gather ] keep + [ dupd assoc-stack ] curry H{ } map>assoc describe ; : .vars ( -- ) namestack namestack. ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 3fe6f9d6aa..4a9f90cb32 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -14,7 +14,7 @@ GENERIC: encode-char ( char stream encoding -- ) GENERIC: ( stream encoding -- newstream ) -: replacement-char HEX: fffd ; +: replacement-char HEX: fffd ; inline TUPLE: decoder stream code cr ; @@ -121,14 +121,28 @@ M: encoder stream-flush encoder-stream stream-flush ; INSTANCE: encoder plain-writer PRIVATE> -: re-encode ( stream encoding -- newstream ) - over encoder? [ >r encoder-stream r> ] when ; +GENERIC# re-encode 1 ( stream encoding -- newstream ) + +M: object re-encode ; + +M: encoder re-encode [ stream>> ] dip re-encode ; : encode-output ( encoding -- ) output-stream [ swap re-encode ] change ; -: re-decode ( stream encoding -- newstream ) - over decoder? [ >r decoder-stream r> ] when ; +: with-encoded-output ( encoding quot -- ) + [ [ output-stream get ] dip re-encode ] dip + with-output-stream* ; inline + +GENERIC# re-decode 1 ( stream encoding -- newstream ) + +M: object re-decode ; + +M: decoder re-decode [ stream>> ] dip re-decode ; : decode-input ( encoding -- ) input-stream [ swap re-decode ] change ; + +: with-decoded-input ( encoding quot -- ) + [ [ input-stream get ] dip re-decode ] dip + with-input-stream* ; inline diff --git a/core/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor index ac5caba61c..fd251c76db 100755 --- a/core/io/encodings/utf16/utf16-tests.factor +++ b/core/io/encodings/utf16/utf16-tests.factor @@ -1,5 +1,6 @@ USING: kernel tools.test io.encodings.utf16 arrays sbufs -io.streams.byte-array sequences io.encodings io unicode +io.streams.byte-array sequences io.encodings io +bootstrap.unicode io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf16.tests diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index af169854c9..a99575b4ba 100755 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,4 +1,5 @@ -USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ; +USING: io.encodings.utf8 tools.test io.encodings.string strings arrays +bootstrap.unicode ; IN: io.encodings.utf8.tests : decode-utf8-w/stream ( array -- newarray ) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 82f0db1364..a04a698965 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -401,7 +401,7 @@ HELP: clone { $values { "obj" object } { "cloned" "a new object" } } { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ; -HELP: ? ( ? true false -- true/false ) +HELP: ? { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; @@ -409,7 +409,7 @@ HELP: >boolean { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ; -HELP: not ( obj -- ? ) +HELP: not { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "For " { $link f } " outputs " { $link t } " and for anything else outputs " { $link f } "." } { $notes "This word implements boolean not, so applying it to integers will not yield useful results (all integers have a true value). Bitwise not is the " { $link bitnot } " word." } ; @@ -692,26 +692,26 @@ HELP: tri@ } } ; -HELP: if ( cond true false -- ) -{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } } +HELP: if +{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ; HELP: when -{ $values { "cond" "a generalized boolean" } { "true" quotation } } +{ $values { "?" "a generalized boolean" } { "true" quotation } } { $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; HELP: unless -{ $values { "cond" "a generalized boolean" } { "false" quotation } } +{ $values { "?" "a generalized boolean" } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; HELP: if* -{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } } +{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } } { $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true." $nl "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called." @@ -720,14 +720,14 @@ $nl { $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ; HELP: when* -{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } } +{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } } { $description "Variant of " { $link if* } " with no false quotation." $nl "The following two lines are equivalent:" { $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ; HELP: unless* -{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } } +{ $values { "?" "a generalized boolean" } { "false" "a quotation " } } { $description "Variant of " { $link if* } " with no true quotation." } { $notes "The following two lines are equivalent:" @@ -794,7 +794,7 @@ HELP: most { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } } { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ; -HELP: curry ( obj quot -- curry ) +HELP: curry { $values { "obj" object } { "quot" callable } { "curry" curry } } { $description "Partial application. Outputs a " { $link callable } " which first pushes " { $snippet "obj" } " and then calls " { $snippet "quot" } "." } { $class-description "The class of objects created by " { $link curry } ". These objects print identically to quotations and implement the sequence protocol, however they only use two cells of storage; a reference to the object and a reference to the underlying quotation." } @@ -832,7 +832,7 @@ HELP: with { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } } ; -HELP: compose ( quot1 quot2 -- compose ) +HELP: compose { $values { "quot1" callable } { "quot2" callable } { "compose" compose } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." } { $notes diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 61f687c95a..1a7d1de47c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -28,20 +28,20 @@ DEFER: if : if ( ? true false -- ) ? call ; ! Single branch -: unless ( cond false -- ) +: unless ( ? false -- ) swap [ drop ] [ call ] if ; inline -: when ( cond true -- ) +: when ( ? true -- ) swap [ call ] [ drop ] if ; inline ! Anaphoric -: if* ( cond true false -- ) +: if* ( ? true false -- ) pick [ drop call ] [ 2nip call ] if ; inline -: when* ( cond true -- ) +: when* ( ? true -- ) over [ call ] [ 2drop ] if ; inline -: unless* ( cond false -- ) +: unless* ( ? false -- ) over [ drop ] [ nip call ] if ; inline ! Default diff --git a/core/libc/libc.factor b/core/libc/libc.factor index dff6e9e0f1..cda5260397 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -3,7 +3,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: alien assocs continuations destructors init kernel -namespaces accessors ; +namespaces accessors sets ; IN: libc float ( x -- y ) +HELP: >float { $values { "x" real } { "y" float } } { $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ; diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index 056e19e1de..c75040b6bb 100755 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -23,17 +23,21 @@ ABOUT: "integers" HELP: fixnum { $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ; -HELP: >fixnum ( x -- n ) +HELP: >fixnum { $values { "x" real } { "n" fixnum } } { $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ; HELP: bignum { $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ; -HELP: >bignum ( x -- n ) +HELP: >bignum { $values { "x" real } { "n" bignum } } { $description "Converts a real number to a bignum, with a possible loss of precision." } ; +HELP: >integer +{ $values { "x" real } { "n" bignum } } +{ $description "Converts a real number to an integer, with a possible loss of precision." } ; + HELP: integer { $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 0218ded6ff..1dfbf1fc3e 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -3,9 +3,9 @@ USING: kernel math.private ; IN: math -GENERIC: >fixnum ( x -- y ) foldable -GENERIC: >bignum ( x -- y ) foldable -GENERIC: >integer ( x -- y ) foldable +GENERIC: >fixnum ( x -- n ) foldable +GENERIC: >bignum ( x -- n ) foldable +GENERIC: >integer ( x -- n ) foldable GENERIC: >float ( x -- y ) foldable MATH: number= ( x y -- ? ) foldable diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index 23ea1058ad..65edbdaaae 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -3,9 +3,9 @@ math.private words ; IN: math.order HELP: <=> -{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } } +{ $values { "obj1" object } { "obj2" object } { "<=>" "an ordering specifier" } } { $contract - "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings." + "Compares two objects using an intrinsic linear order, for example, the natural order for real numbers and lexicographic order for strings." $nl "The output value is one of the following:" { $list @@ -16,23 +16,23 @@ HELP: <=> } ; HELP: +lt+ -{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ; +{ $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ; HELP: +eq+ -{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ; +{ $description "Output by " { $link <=> } " when the first object is equal to the second object." } ; HELP: +gt+ -{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ; +{ $description "Output by " { $link <=> } " when the first object is strictly greater than the second object." } ; HELP: invert-comparison -{ $values { "symbol" symbol } - { "new-symbol" symbol } } -{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." } +{ $values { "<=>" symbol } + { "<=>'" symbol } } +{ $description "Invert the comparison symbol returned by " { $link <=> } "." } { $examples { $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ; HELP: compare -{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } } +{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "<=>" "an ordering specifier" } } { $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." } { $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" } } ; @@ -76,19 +76,24 @@ HELP: [-] { $values { "x" real } { "y" real } { "z" real } } { $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ; -ARTICLE: "math.order" "Ordered objects" +ARTICLE: "order-specifiers" "Ordering specifiers" +"Ordering words such as " { $link <=> } " output one of the following values, indicating that of two objects being compared, the first is less than the second, the two are equal, or that the first is greater than the second:" +{ $subsection +lt+ } +{ $subsection +eq+ } +{ $subsection +gt+ } ; + +ARTICLE: "math.order" "Linear order protocol" "Some classes have an intrinsic order amongst instances:" { $subsection <=> } { $subsection compare } { $subsection invert-comparison } -"The above words return one of the following symbols:" -{ $subsection +lt+ } -{ $subsection +eq+ } -{ $subsection +gt+ } +"The above words output order specifiers." +{ $subsection "order-specifiers" } "Utilities for comparing objects:" { $subsection after? } { $subsection before? } { $subsection after=? } -{ $subsection before=? } ; +{ $subsection before=? } +{ $see-also "sequences-sorting" } ; ABOUT: "math.order" diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 76fe058ffa..aae5841185 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -7,11 +7,11 @@ SYMBOL: +lt+ SYMBOL: +eq+ SYMBOL: +gt+ -: invert-comparison ( symbol -- new-symbol ) +: invert-comparison ( <=> -- <=>' ) #! Can't use case, index or nth here dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ; -GENERIC: <=> ( obj1 obj2 -- symbol ) +GENERIC: <=> ( obj1 obj2 -- <=> ) M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; @@ -38,4 +38,4 @@ M: real after=? ( obj1 obj2 -- ? ) >= ; : [-] ( x y -- z ) - 0 max ; inline -: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline +: compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index df6c9dadc5..555c6eb32c 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -421,8 +421,6 @@ must-fail-with ] unit-test ] times -[ ] [ "parser" reload ] unit-test - [ ] [ [ "this-better-not-exist" forget-vocab ] with-compilation-unit ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index e99f2b850b..129d5ef2ee 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -539,7 +539,7 @@ SYMBOL: interactive-vocabs : reset-removed-classes ( -- ) removed-classes - filter-moved [ class? ] filter [ reset-class ] each ; + filter-moved [ class? ] filter [ forget-class ] each ; : fix-class-words ( -- ) #! If a class word had a compound definition which was diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index bc88e1e810..2f81207ab5 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -3,7 +3,7 @@ USING: arrays generic hashtables io kernel math assocs namespaces sequences strings io.styles vectors words prettyprint.config splitting classes continuations -io.streams.nested accessors ; +io.streams.nested accessors sets ; IN: prettyprint.sections ! State @@ -20,7 +20,7 @@ TUPLE: pprinter last-newline line-count indent ; : ( -- pprinter ) 0 1 0 pprinter boa ; : record-vocab ( word -- ) - word-vocabulary [ dup pprinter-use get set-at ] when* ; + word-vocabulary [ pprinter-use get conjoin ] when* ; ! Utility words : line-limit? ( -- ? ) diff --git a/core/search-dequeues/authors.txt b/core/search-dequeues/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/core/search-dequeues/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/search-dequeues/search-dequeues-docs.factor b/core/search-dequeues/search-dequeues-docs.factor new file mode 100644 index 0000000000..de9e9f0084 --- /dev/null +++ b/core/search-dequeues/search-dequeues-docs.factor @@ -0,0 +1,21 @@ +IN: search-dequeues +USING: help.markup help.syntax kernel dlists hashtables +dequeues assocs ; + +ARTICLE: "search-dequeues" "Search dequeues" +"A search dequeue is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search dequeues implement all dequeue operations in terms of an underlying dequeue, and membership testing with " { $link dequeue-member? } " is implemented with an underlying assoc. Search dequeues are defined in the " { $vocab-link "search-dequeues" } " vocabulary." +$nl +"Creating a search dequeue:" +{ $subsection } +"Default implementation:" +{ $subsection } ; + +ABOUT: "search-dequeues" + +HELP: ( assoc dequeue -- search-dequeue ) +{ $values { "assoc" assoc } { "dequeue" dequeue } { "search-dequeue" search-dequeue } } +{ $description "Creates a new " { $link search-dequeue } "." } ; + +HELP: ( -- search-dequeue ) +{ $values { "search-dequeue" search-dequeue } } +{ $description "Creates a new " { $link search-dequeue } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ; diff --git a/core/search-dequeues/search-dequeues-tests.factor b/core/search-dequeues/search-dequeues-tests.factor new file mode 100644 index 0000000000..acf929de46 --- /dev/null +++ b/core/search-dequeues/search-dequeues-tests.factor @@ -0,0 +1,35 @@ +IN: search-dequeues.tests +USING: search-dequeues tools.test namespaces +kernel sequences words dequeues vocabs ; + + "h" set + +[ t ] [ "h" get dequeue-empty? ] unit-test + +[ ] [ 3 "h" get push-front* "1" set ] unit-test +[ ] [ 1 "h" get push-front ] unit-test +[ ] [ 3 "h" get push-front* "2" set ] unit-test +[ ] [ 3 "h" get push-front* "3" set ] unit-test +[ ] [ 7 "h" get push-front ] unit-test + +[ t ] [ "1" get "2" get eq? ] unit-test +[ t ] [ "2" get "3" get eq? ] unit-test + +[ 3 ] [ "h" get dequeue-length ] unit-test +[ t ] [ 7 "h" get dequeue-member? ] unit-test + +[ 3 ] [ "1" get node-value ] unit-test +[ ] [ "1" get "h" get delete-node ] unit-test + +[ 2 ] [ "h" get dequeue-length ] unit-test +[ 1 ] [ "h" get pop-back ] unit-test +[ 7 ] [ "h" get pop-back ] unit-test + +[ f ] [ 7 "h" get dequeue-member? ] unit-test + +[ ] [ + + [ all-words swap [ push-front ] curry each ] + [ [ drop ] slurp-dequeue ] + bi +] unit-test diff --git a/core/search-dequeues/search-dequeues.factor b/core/search-dequeues/search-dequeues.factor new file mode 100644 index 0000000000..87c997a3ac --- /dev/null +++ b/core/search-dequeues/search-dequeues.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel assocs dequeues dlists hashtables ; +IN: search-dequeues + +TUPLE: search-dequeue assoc dequeue ; + +C: search-dequeue + +: ( -- search-dequeue ) + 0 ; + +M: search-dequeue dequeue-length dequeue>> dequeue-length ; + +M: search-dequeue peek-front dequeue>> peek-front ; + +M: search-dequeue peek-back dequeue>> peek-back ; + +M: search-dequeue push-front* + 2dup assoc>> at* [ 2nip ] [ + drop + [ dequeue>> push-front* ] [ assoc>> ] 2bi + [ 2drop ] [ set-at ] 3bi + ] if ; + +M: search-dequeue push-back* + 2dup assoc>> at* [ 2nip ] [ + drop + [ dequeue>> push-back* ] [ assoc>> ] 2bi + [ 2drop ] [ set-at ] 3bi + ] if ; + +M: search-dequeue pop-front* + [ [ dequeue>> peek-front ] [ assoc>> ] bi delete-at ] + [ dequeue>> pop-front* ] + bi ; + +M: search-dequeue pop-back* + [ [ dequeue>> peek-back ] [ assoc>> ] bi delete-at ] + [ dequeue>> pop-back* ] + bi ; + +M: search-dequeue delete-node + [ dequeue>> delete-node ] + [ [ node-value ] [ assoc>> ] bi* delete-at ] 2bi ; + +M: search-dequeue clear-dequeue + [ dequeue>> clear-dequeue ] [ assoc>> clear-assoc ] bi ; + +M: search-dequeue dequeue-member? + assoc>> key? ; + +INSTANCE: search-dequeue dequeue diff --git a/core/search-dequeues/summary.txt b/core/search-dequeues/summary.txt new file mode 100644 index 0000000000..9102bf2d58 --- /dev/null +++ b/core/search-dequeues/summary.txt @@ -0,0 +1 @@ +Double-ended queues with sub-linear membership testing diff --git a/core/search-dequeues/tags.txt b/core/search-dequeues/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/search-dequeues/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 81384a40c4..60c75a8920 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -243,6 +243,3 @@ unit-test [ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test - -! Hardcore -[ ] [ "sequences" reload ] unit-test diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 5fbec9a7c8..d825faf921 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -16,6 +16,9 @@ IN: sets [ ] [ length ] [ length ] tri [ [ (prune) ] 2curry each ] keep ; +: gather ( seq quot -- newseq ) + map concat prune ; inline + : unique ( seq -- assoc ) [ dup ] H{ } map>assoc ; diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index 5827a711c8..d52ea5e11f 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -3,12 +3,8 @@ sequences math.order ; IN: sorting ARTICLE: "sequences-sorting" "Sorting and binary search" -"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- n )" } " that order the two given elements and output a value whose sign denotes the result:" -{ $list - { "positive - indicates that " { $snippet "elt1" } " follows " { $snippet "elt2" } } - { "zero - indicates that " { $snippet "elt1" } " is ordered equivalently to " { $snippet "elt2" } } - { "negative - indicates that " { $snippet "elt1" } " precedes " { $snippet "elt2" } } -} +"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "." +$nl "Sorting a sequence with a custom comparator:" { $subsection sort } "Sorting a sequence with common comparators:" @@ -19,8 +15,10 @@ ARTICLE: "sequences-sorting" "Sorting and binary search" { $subsection binsearch } { $subsection binsearch* } ; +ABOUT: "sequences-sorting" + HELP: sort -{ $values { "seq" "a sequence" } { "quot" "a comparator quotation" } { "sortedseq" "a new sorted sequence" } } +{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } } { $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ; HELP: sort-keys @@ -52,13 +50,13 @@ HELP: partition { $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ; HELP: binsearch -{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a comparator quotation" } { "i" "the index of the search result" } } +{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "i" "the index of the search result" } } { $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "." $nl "Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ; HELP: binsearch* -{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a comparator quotation" } { "result" "the search result" } } +{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "result" "the search result" } } { $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence." $nl "Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ; diff --git a/core/source-files/source-files-tests.factor b/core/source-files/source-files-tests.factor new file mode 100644 index 0000000000..e5e04c777f --- /dev/null +++ b/core/source-files/source-files-tests.factor @@ -0,0 +1,5 @@ +IN: source-files.tests +USING: source-files tools.test assocs sequences strings +namespaces kernel ; + +[ { } ] [ source-files get keys [ string? not ] filter ] unit-test diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 36a1806e12..454f148974 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -44,6 +44,7 @@ uses definitions ; \ source-file construct ; : source-file ( path -- source-file ) + dup string? [ "Invalid source file path" throw ] unless source-files get [ ] cache ; : reset-checksums ( -- ) diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index a0d601e2ad..91a453408d 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -182,8 +182,8 @@ IN: bootstrap.syntax ] define-syntax "(" [ - ")" parse-effect word - [ swap "declared-effect" set-word-prop ] [ drop ] if* + ")" parse-effect + word dup [ set-stack-effect ] [ 2drop ] if ] define-syntax "((" [ diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index 7d8791d493..944526e05c 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private io threads.private continuations dlists init quotations strings -assocs heaps boxes namespaces ; +assocs heaps boxes namespaces dequeues ; IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" diff --git a/core/threads/threads.factor b/core/threads/threads.factor index c23ced42b9..4fe4c5bcb2 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -4,7 +4,7 @@ USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private dlists assocs system combinators init boxes accessors -math.order ; +math.order dequeues ; IN: threads SYMBOL: initial-thread @@ -86,7 +86,7 @@ PRIVATE> : sleep-time ( -- ms/f ) { - { [ run-queue dlist-empty? not ] [ 0 ] } + { [ run-queue dequeue-empty? not ] [ 0 ] } { [ sleep-queue heap-empty? ] [ f ] } [ sleep-queue heap-peek nip millis [-] ] } cond ; @@ -146,7 +146,7 @@ DEFER: next : next ( -- * ) expire-sleep-loop - run-queue dup dlist-empty? [ + run-queue dup dequeue-empty? [ drop no-runnable-threads ] [ pop-back dup array? [ first2 ] [ f swap ] if (next) diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 2a164ab11d..13be1adb69 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -183,3 +183,16 @@ SYMBOL: quot-uses-b [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test + +[ { } ] +[ + all-words [ + "compiled-uses" word-prop + keys [ "forgotten" word-prop ] contains? + ] filter +] unit-test + +[ { } ] [ + crossref get keys + [ word? ] filter [ "forgotten" word-prop ] filter +] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 22d22d83fb..d17377fdca 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -80,8 +80,7 @@ GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; -M: word (quot-uses) - >r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ; +M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; @@ -103,12 +102,16 @@ compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) [ drop crossref? ] assoc-filter - 2dup "compiled-uses" set-word-prop - compiled-crossref get add-vertex* ; + [ "compiled-uses" set-word-prop ] + [ compiled-crossref get add-vertex* ] + 2bi ; : compiled-unxref ( word -- ) - dup "compiled-uses" word-prop - compiled-crossref get remove-vertex* ; + [ + dup "compiled-uses" word-prop + compiled-crossref get remove-vertex* + ] + [ f "compiled-uses" set-word-prop ] bi ; : delete-compiled-xref ( word -- ) dup compiled-unxref @@ -141,6 +144,18 @@ M: object redefined drop ; dup +inlined+ changed-definition dup crossref? [ dup xref ] when drop ; +: set-stack-effect ( effect word -- ) + 2dup "declared-effect" word-prop = [ 2drop ] [ + swap + [ "declared-effect" set-word-prop ] + [ + drop + dup primitive? [ drop ] [ + [ redefined ] [ +inlined+ changed-definition ] bi + ] if + ] 2bi + ] if ; + : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop define ; @@ -177,9 +192,10 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; : reset-generic ( word -- ) - dup subwords forget-all - dup reset-word - { "methods" "combination" "default-method" } reset-props ; + [ subwords forget-all ] + [ reset-word ] + [ { "methods" "combination" "default-method" } reset-props ] + tri ; : gensym ( -- word ) "( gensym )" f ; @@ -216,12 +232,12 @@ M: word where "loc" word-prop ; M: word set-where swap "loc" set-word-prop ; M: word forget* - dup "forgotten" word-prop [ - dup delete-xref - dup delete-compiled-xref - dup word-name over word-vocabulary vocab-words delete-at - dup t "forgotten" set-word-prop - ] unless drop ; + dup "forgotten" word-prop [ drop ] [ + [ delete-xref ] + [ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ] + [ t "forgotten" set-word-prop ] + tri + ] if ; M: word hashcode* nip 1 slot { fixnum } declare ; diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index c2e80fee9a..701a784ea4 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -7,7 +7,7 @@ kernel io.files bootstrap.image sequences io ; : url "http://factorcode.org/images/latest/" ; : download-checksums ( -- alist ) - url "checksums.txt" append http-get + url "checksums.txt" append http-get nip string-lines [ " " split1 ] { } map>assoc ; : need-new-image? ( image -- ? ) diff --git a/extra/bootstrap/unicode/unicode.factor b/extra/bootstrap/unicode/unicode.factor new file mode 100755 index 0000000000..0476cbf18b --- /dev/null +++ b/extra/bootstrap/unicode/unicode.factor @@ -0,0 +1,12 @@ +USING: parser kernel namespaces ; + +USE: unicode.breaks +USE: unicode.case +USE: unicode.categories +USE: unicode.collation +USE: unicode.data +USE: unicode.normalize +USE: unicode.script + +[ name>char [ "Invalid character" throw ] unless* ] +name>char-hook set-global diff --git a/extra/calendar/model/model.factor b/extra/calendar/model/model.factor index aa295e0f75..60a61c2026 100755 --- a/extra/calendar/model/model.factor +++ b/extra/calendar/model/model.factor @@ -10,7 +10,10 @@ SYMBOL: time 1000 sleep (time-thread) ; : time-thread ( -- ) - [ (time-thread) ] "Time model update" spawn drop ; + [ + init-namespaces + (time-thread) + ] "Time model update" spawn drop ; f time set-global [ time-thread ] "calendar.model" add-init-hook diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor index 90159c1656..e237302744 100755 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien io kernel namespaces core-foundation +USING: alien alien.syntax io kernel namespaces core-foundation core-foundation.run-loop cocoa.messages cocoa cocoa.classes cocoa.runtime sequences threads debugger init inspector kernel.private ; @@ -19,6 +19,8 @@ IN: cocoa.application : NSApp ( -- app ) NSApplication -> sharedApplication ; +FUNCTION: void NSBeep ( ) ; + : with-cocoa ( quot -- ) [ NSApp drop call ] with-autorelease-pool ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index a838b246e4..da13901ab7 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -63,8 +63,8 @@ MACRO: napply ( n -- ) ! short circuiting words ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : short-circuit ( quots quot default -- quot ) -! 1quotation -rot { } map>assoc alist>quot ; +: short-circuit ( quots quot default -- quot ) + 1quotation -rot { } map>assoc alist>quot ; ! MACRO: && ( quots -- ? ) ! [ [ not ] append [ f ] ] t short-circuit ; diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor index b10aded671..72f520dab3 100755 --- a/extra/concurrency/conditions/conditions.factor +++ b/extra/concurrency/conditions/conditions.factor @@ -1,21 +1,20 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: dlists dlists.private threads kernel arrays sequences -alarms ; +USING: dequeues threads kernel arrays sequences alarms ; IN: concurrency.conditions -: notify-1 ( dlist -- ) - dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; +: notify-1 ( dequeue -- ) + dup dequeue-empty? [ drop ] [ pop-back resume-now ] if ; -: notify-all ( dlist -- ) - [ resume-now ] dlist-slurp ; +: notify-all ( dequeue -- ) + [ resume-now ] slurp-dequeue ; : queue-timeout ( queue timeout -- alarm ) #! Add an alarm which removes the current thread from the #! queue, and resumes it, passing it a value of t. - >r self over push-front* [ - tuck delete-node - dlist-node-obj t swap resume-with + >r [ self swap push-front* ] keep [ + [ delete-node ] [ drop node-value ] 2bi + t swap resume-with ] 2curry r> later ; : wait ( queue timeout status -- ) diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index b5ea247420..2ab204e91d 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: dlists kernel threads continuations math +USING: dequeues dlists kernel threads continuations math concurrency.conditions ; IN: concurrency.locks @@ -80,7 +80,7 @@ TUPLE: rw-lock readers writers reader# writer ; : release-write-lock ( lock -- ) f over set-rw-lock-writer - dup rw-lock-readers dlist-empty? + dup rw-lock-readers dequeue-empty? [ notify-writer ] [ rw-lock-readers notify-all ] if ; : reentrant-read-lock-ok? ( lock -- ? ) diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index aa03d3d8ee..86d3297a28 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -1,9 +1,10 @@ ! 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 destructors -namespaces random math quotations words kernel arrays assocs -init system concurrency.conditions accessors debugger ; +USING: dlists dequeues threads sequences continuations +destructors namespaces random math quotations words kernel +arrays assocs init system concurrency.conditions accessors +debugger ; TUPLE: mailbox threads data disposed ; @@ -13,7 +14,7 @@ M: mailbox dispose* threads>> notify-all ; f mailbox boa ; : mailbox-empty? ( mailbox -- bool ) - data>> dlist-empty? ; + data>> dequeue-empty? ; : mailbox-put ( obj mailbox -- ) [ data>> push-front ] diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 00184bac05..929c4d44f4 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -2,12 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel threads vectors arrays sequences -namespaces tools.test continuations dlists strings math words +namespaces tools.test continuations dequeues strings math words match quotations concurrency.messaging concurrency.mailboxes concurrency.count-downs accessors ; IN: concurrency.messaging.tests -[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test +[ ] [ my-mailbox mailbox-data clear-dequeue ] unit-test [ "received" ] [ [ diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor index 90731cec43..6e62513a80 100644 --- a/extra/dns/misc/misc.factor +++ b/extra/dns/misc/misc.factor @@ -1,12 +1,34 @@ -USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ; +USING: kernel combinators sequences splitting math + io.files io.encodings.utf8 random newfx dns.util ; IN: dns.misc +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : resolv-conf-servers ( -- seq ) "/etc/resolv.conf" utf8 file-lines [ " " split ] map [ 1st "nameserver" = ] filter [ 2nd ] map ; -: resolv-conf-server ( -- ip ) resolv-conf-servers random ; \ No newline at end of file +: resolv-conf-server ( -- ip ) resolv-conf-servers random ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: domain-has-name? ( domain name -- ? ) + { + { [ 2dup = ] [ 2drop t ] } + { [ 2dup longer? ] [ 2drop f ] } + { [ t ] [ cdr-name domain-has-name? ] } + } + cond ; + +: name-in-domain? ( name domain -- ? ) swap domain-has-name? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index e1c32af970..1e7d9cb622 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -1,14 +1,9 @@ -USING: kernel - combinators - sequences - math - io.sockets - unicode.case - accessors +USING: kernel combinators sequences sets math + io.sockets unicode.case accessors combinators.cleave combinators.lib newfx - dns dns.util ; + dns dns.util dns.misc ; IN: dns.server @@ -27,6 +22,53 @@ IN: dns.server : matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! zones +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ; +: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ; + +: delegated-zones ( -- names ) zones my-zones diff ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! name->zone +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: name->zone ( name -- zone/f ) + zones sort-largest-first [ name-in-domain? ] with find nip ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! fill-authority +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fill-authority ( message -- message ) + [ ] + [ message-query name>> name->zone NS IN query boa matching-rrs ] + [ answer-section>> ] + tri + diff >>authority-section ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! fill-additional +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rr->rdata-names ( rr -- names/f ) + { + { [ dup type>> NS = ] [ rdata>> {1} ] } + { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] } + { [ t ] [ drop f ] } + } + cond ; + +: fill-additional ( message -- message ) + dup + [ answer-section>> ] [ authority-section>> ] bi append + [ rr->rdata-names ] map concat + [ A IN query boa matching-rrs ] map concat prune + over answer-section>> diff + >>additional-section ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! query->rrs ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -48,9 +90,16 @@ DEFER: query->rrs ! have-answers ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! : have-answers ( message -- message/f ) +! dup message-query query->rrs ! message rrs/f +! [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ; + : have-answers ( message -- message/f ) - dup message-query query->rrs ! message rrs/f - [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ; + dup message-query query->rrs + [ empty? ] + [ 2drop f ] + [ >>answer-section fill-authority fill-additional ] + 1if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! have-delegates? @@ -64,13 +113,13 @@ DEFER: query->rrs NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ; : name->delegates ( name -- rrs-ns ) - { - [ "" = { } and ] - [ is-soa? { } and ] - [ have-ns? ] - [ cdr-name name->delegates ] - } - 1|| ; + { + [ "" = { } and ] + [ is-soa? { } and ] + [ have-ns? ] + [ cdr-name name->delegates ] + } + 1|| ; : have-delegates ( message -- message/f ) dup message-query name>> name->delegates ! message rrs-ns @@ -85,20 +134,49 @@ DEFER: query->rrs ] 1if ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! outsize-zones +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: outside-zones ( message -- message/f ) + dup message-query name>> name->zone f = + [ ] + [ drop f ] + if ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! is-nx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : is-nx ( message -- message/f ) [ message-query name>> records [ name>> = ] with filter empty? ] - [ NAME-ERROR >>rcode ] + [ + NAME-ERROR >>rcode + dup + message-query name>> name->zone SOA IN query boa matching-rrs + >>authority-section + ] [ drop f ] 1if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: none-of-type ( message -- message ) + dup + message-query name>> name->zone SOA IN query boa matching-rrs + >>authority-section ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : find-answer ( message -- message ) - { [ have-answers ] [ have-delegates ] [ is-nx ] [ ] } 1|| ; + { + [ have-answers ] + [ have-delegates ] + [ outside-zones ] + [ is-nx ] + [ none-of-type ] + } + 1|| ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index bee1cc111e..5933216a3c 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -1,5 +1,5 @@ -USING: kernel macros fry ; +USING: kernel sequences sorting math math.order macros fry ; IN: dns.util @@ -8,4 +8,12 @@ IN: dns.util MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ; -! : 1if ( test then else -- ) >r >r >r dup r> call r> r> if ; inline ; \ No newline at end of file +! : 1if ( test then else -- ) >r >r >r dup r> call r> r> if ; inline ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: longer? ( seq seq -- ? ) [ length ] bi@ > ; \ No newline at end of file diff --git a/extra/geo-ip/geo-ip.factor b/extra/geo-ip/geo-ip.factor index 06a84929ba..62cc659394 100644 --- a/extra/geo-ip/geo-ip.factor +++ b/extra/geo-ip/geo-ip.factor @@ -1,7 +1,7 @@ USING: kernel sequences io.files io.launcher io.encodings.ascii io.streams.string http.client sequences.lib combinators math.parser math.vectors math.intervals interval-maps memoize -csv accessors assocs strings math splitting ; +csv accessors assocs strings math splitting grouping arrays ; IN: geo-ip : db-path ( -- path ) "IpToCountry.csv" temp-file ; @@ -32,15 +32,20 @@ MEMO: ip-db ( -- seq ) [ "#" head? not ] filter "\n" join csv [ parse-ip-entry ] map ; +: filter-overlaps ( alist -- alist' ) + 2 clump + [ first2 [ first second ] [ first first ] bi* < ] filter + [ first ] map ; + MEMO: ip-intervals ( -- interval-map ) - ip-db [ [ [ from>> ] [ to>> ] bi [a,b] ] keep ] { } map>assoc - ; + ip-db [ [ [ from>> ] [ to>> ] bi 2array ] keep ] { } map>assoc + filter-overlaps ; GENERIC: lookup-ip ( ip -- ip-entry ) M: string lookup-ip "." split [ string>number ] map - { HEX: 1000000 HEX: 10000 HEX: 100 1 } v. + { HEX: 1000000 HEX: 10000 HEX: 100 HEX: 1 } v. lookup-ip ; M: integer lookup-ip ip-intervals interval-at ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 863a538b47..dfbb7a12b8 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -40,8 +40,8 @@ $nl "Common terminology and abbreviations used throughout Factor and its documentation:" { $table { "Term" "Definition" } - { "alist" { "an association list. See " { $link "alists" } } } - { "assoc" "an associative mapping" } + { "alist" { "an association list; see " { $link "alists" } } } + { "assoc" { "an associative mapping; see " { $link "assocs" } } } { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } } { "boolean" { { $link t } " or " { $link f } } } { "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } } @@ -50,8 +50,9 @@ $nl { "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } } { "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } } { "object" { "any datum which can be identified" } } + { "ordering specifier" { "see " { $link "order-specifiers" } } } { "pathname string" { "an OS-specific pathname which identifies a file" } } - { "sequence" { "an object whose class implements the " { $link "sequence-protocol" } } } + { "sequence" { "a sequence; see " { $link "sequence-protocol" } } } { "slot" { "a component of an object which can store a value" } } { "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } } { "true value" { "any object not equal to " { $link f } } } @@ -157,12 +158,17 @@ ARTICLE: "collections" "Collections" { $subsection "hashtables" } { $subsection "alists" } { $subsection "enums" } +{ $heading "Double-ended queues" } +{ $subsection "dequeues" } +"Implementations:" +{ $subsection "dlists" } +{ $subsection "search-dequeues" } { $heading "Other collections" } { $subsection "boxes" } -{ $subsection "dlists" } { $subsection "heaps" } { $subsection "graphs" } -{ $subsection "buffers" } ; +{ $subsection "buffers" } +"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ; USING: io.sockets io.launcher io.mmap io.monitors io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ; diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 2a8ea03d03..00a8e287e6 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -5,7 +5,7 @@ words strings classes tools.vocabs namespaces io io.streams.string prettyprint definitions arrays vectors combinators splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate -macros combinators.lib sequences.lib math sets ; +macros math sets ; IN: help.lint : check-example ( element -- ) @@ -46,16 +46,15 @@ IN: help.lint : check-values ( word element -- ) { - [ over "declared-effect" word-prop ] - [ dup contains-funky-elements? not ] - [ over macro? not ] + { [ over "declared-effect" word-prop ] [ 2drop ] } + { [ dup contains-funky-elements? not ] [ 2drop ] } + { [ over macro? not ] [ 2drop ] } [ - 2dup extract-values >array - >r effect-values >array - r> assert= - t + [ effect-values >array ] + [ extract-values >array ] + bi* assert= ] - } 0&& 3drop ; + } cond ; : check-see-also ( word element -- ) nip \ $see-also swap elements [ @@ -114,7 +113,10 @@ M: help-error error. vocabs [ dup vocab-docs-path swap ] H{ } map>assoc H{ } clone [ [ - >r >r dup >link where ?first r> at r> [ ?push ] change-at + >r >r dup >link where dup + [ first r> at r> [ ?push ] change-at ] + [ r> r> 2drop 2drop ] + if ] 2curry each ] keep ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 47d352b6b8..f6fccd42ec 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -6,7 +6,7 @@ IN: html.parser.analyzer TUPLE: link attributes clickable ; : scrape-html ( url -- vector ) - http-get parse-html ; + http-get nip parse-html ; : (find-relative) [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 7b48bf93af..56957b021c 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -3,8 +3,13 @@ USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings splitting calendar continuations accessors vectors math.order -io.encodings.8-bit io.encodings.binary io.streams.duplex -fry debugger inspector ascii urls ; +io.encodings +io.encodings.string +io.encodings.ascii +io.encodings.8-bit +io.encodings.binary +io.streams.duplex +fry debugger inspector ascii urls present ; IN: http.client : max-redirects 10 ; @@ -15,7 +20,7 @@ M: too-many-redirects summary drop [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; -DEFER: http-request +DEFER: (http-request) >method http-request + "GET" >>method (http-request) ] [ too-many-redirects ] if @@ -45,15 +50,21 @@ PRIVATE> : read-chunks ( -- ) read-chunk-size dup zero? - [ drop ] [ read % read-crlf "" assert= read-chunks ] if ; + [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ; : read-response-body ( response -- response data ) - dup "transfer-encoding" header "chunked" = - [ [ read-chunks ] "" make ] [ input-stream get contents ] if ; + dup "transfer-encoding" header "chunked" = [ + binary decode-input + [ read-chunks ] B{ } make + over content-charset>> decode + ] [ + dup content-charset>> decode-input + input-stream get contents + ] if ; -: http-request ( request -- response data ) +: (http-request) ( request -- response data ) dup request [ - dup url>> url-addr latin1 [ + dup url>> url-addr ascii [ 1 minutes timeouts write-request read-response @@ -62,14 +73,6 @@ PRIVATE> do-redirect ] with-variable ; -: ( url -- request ) - - "GET" >>method - swap >url ensure-port >>url ; - -: http-get* ( url -- response data ) - http-request ; - : success? ( code -- ? ) 200 = ; ERROR: download-failed response body ; @@ -84,18 +87,28 @@ M: download-failed error. ] [ body>> write ] bi ; -: check-response ( response string -- string ) - over code>> success? [ nip ] [ download-failed ] if ; +: check-response ( response data -- response data ) + over code>> success? [ download-failed ] unless ; -: http-get ( url -- string ) - http-get* check-response ; +: http-request ( request -- response data ) + (http-request) check-response ; + +: ( url -- request ) + + "GET" >>method + swap >url ensure-port >>url ; + +: http-get ( url -- response data ) + http-request ; : download-name ( url -- name ) - file-name "?" split1 drop "/" ?tail drop ; + present file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - [ http-get ] dip latin1 [ write ] with-file-writer ; + swap http-get + [ content-charset>> ] [ '[ , write ] ] bi* + with-file-writer ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index c1d5b46aa4..81ada558f3 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,6 @@ USING: http tools.test multiline tuple-syntax -io.streams.string kernel arrays splitting sequences +io.streams.string io.encodings.utf8 io.encodings.string +kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls hashtables ; IN: http.tests @@ -78,7 +79,7 @@ must-fail-with STRING: read-response-test-1 HTTP/1.1 404 not found -Content-Type: text/html; charset=UTF8 +Content-Type: text/html; charset=UTF-8 blah ; @@ -88,10 +89,10 @@ blah version: "1.1" code: 404 message: "not found" - header: H{ { "content-type" "text/html; charset=UTF8" } } + header: H{ { "content-type" "text/html; charset=UTF-8" } } cookies: { } content-type: "text/html" - content-charset: "UTF8" + content-charset: utf8 } ] [ read-response-test-1 lf>crlf @@ -101,7 +102,7 @@ blah STRING: read-response-test-1' HTTP/1.1 404 not found -content-type: text/html; charset=UTF8 +content-type: text/html; charset=UTF-8 ; @@ -160,14 +161,14 @@ test-db [ [ t ] [ "resource:extra/http/test/foo.html" ascii file-contents - "http://localhost:1237/nested/foo.html" http-get = + "http://localhost:1237/nested/foo.html" http-get nip ascii decode = ] unit-test -[ "http://localhost:1237/redirect-loop" http-get ] +[ "http://localhost:1237/redirect-loop" http-get nip ] [ too-many-redirects? ] must-fail-with [ "Goodbye" ] [ - "http://localhost:1237/quit" http-get + "http://localhost:1237/quit" http-get nip ] unit-test ! Dispatcher bugs @@ -194,12 +195,12 @@ test-db [ : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; ! This should give a 404 not an infinite redirect loop -[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with +[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with ! This should give a 404 not an infinite redirect loop -[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with +[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test [ ] [ [ @@ -218,9 +219,9 @@ test-db [ [ ] [ 100 sleep ] unit-test -[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test +[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test USING: html.components html.elements xml xml.utilities validators furnace furnace.flash ; @@ -253,7 +254,7 @@ SYMBOL: a : test-a string>xml "input" tag-named "value" swap at ; [ "3" ] [ - "http://localhost:1237/" http-get* + "http://localhost:1237/" http-get swap dup cookies>> "cookies" set session-id-key get-cookie value>> "session-id" set test-a ] unit-test @@ -273,4 +274,4 @@ SYMBOL: a [ 4 ] [ a get-global ] unit-test -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 04bebce926..d7fc1b766e 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -7,6 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present io io.server io.sockets.secure +io.encodings.iana io.encodings.binary io.encodings.8-bit unicode.case unicode.categories qualified @@ -28,7 +29,8 @@ IN: http "header" get add-header ] [ - ": " split1 dup [ + ":" split1 dup [ + [ blank? ] left-trim swap >lower dup "last-header" set "header" get add-header ] [ @@ -36,20 +38,20 @@ IN: http ] if ] if ; -: read-lf ( -- string ) +: read-lf ( -- bytes ) "\n" read-until CHAR: \n assert= ; -: read-crlf ( -- string ) +: read-crlf ( -- bytes ) "\r" read-until [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; -: read-header-line ( -- ) +: (read-header) ( -- ) read-crlf dup - empty? [ drop ] [ header-line read-header-line ] if ; + empty? [ drop ] [ header-line (read-header) ] if ; : read-header ( -- assoc ) H{ } clone [ - "header" [ read-header-line ] with-variable + "header" [ (read-header) ] with-variable ] keep ; : header-value>string ( value -- string ) @@ -66,7 +68,8 @@ IN: http : write-header ( assoc -- ) >alist sort-keys [ - swap url-encode write ": " write + swap + check-header-string write ": " write header-value>string check-header-string write crlf ] assoc-each crlf ; @@ -299,6 +302,7 @@ body ; H{ } clone >>header "close" "connection" set-header now timestamp>http-string "date" set-header + latin1 >>content-charset V{ } clone >>cookies ; : read-response-version ( response -- response ) @@ -319,7 +323,9 @@ body ; read-header >>header dup "set-cookie" header parse-cookies >>cookies dup "content-type" header [ - parse-content-type [ >>content-type ] [ >>content-charset ] bi* + parse-content-type + [ >>content-type ] + [ name>encoding binary or >>content-charset ] bi* ] when* ; : read-response ( -- response ) @@ -341,7 +347,8 @@ body ; : unparse-content-type ( request -- content-type ) [ content-type>> "application/octet-stream" or ] - [ content-charset>> ] bi + [ content-charset>> encoding>name ] + bi [ "; charset=" swap 3append ] when* ; : write-response-header ( response -- response ) diff --git a/extra/http/server/responses/responses.factor b/extra/http/server/responses/responses.factor index 277ca392b7..4056f0c7f0 100644 --- a/extra/http/server/responses/responses.factor +++ b/extra/http/server/responses/responses.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: html.elements math.parser http accessors kernel -io io.streams.string ; +io io.streams.string io.encodings.utf8 ; IN: http.server.responses : ( body content-type -- response ) 200 >>code "Document follows" >>message + utf8 >>content-charset swap >>content-type swap >>body ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index fc50432030..792757b182 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,10 +1,21 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting -vocabs.loader http http.server.responses logging calendar -destructors html.elements html.streams io.server -io.encodings.8-bit io.timeouts io assocs debugger continuations -fry tools.vocabs math ; +vocabs.loader destructors assocs debugger continuations +tools.vocabs math +io +io.server +io.encodings +io.encodings.utf8 +io.encodings.ascii +io.encodings.binary +io.streams.limited +io.timeouts +fry logging calendar +http +http.server.responses +html.elements +html.streams ; IN: http.server SYMBOL: responder-nesting @@ -43,19 +54,29 @@ main-responder global [ <404> or ] change-at swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) - dup write-response - request get method>> "HEAD" = [ drop ] [ - '[ , write-response-body ] - [ - development-mode get - [ http-error. ] [ drop "Response error" ] if - ] recover - ] if ; + [ write-response ] + [ + request get method>> "HEAD" = [ drop ] [ + '[ + , + [ content-charset>> encode-output ] + [ write-response-body ] + bi + ] + [ + utf8 [ + development-mode get + [ http-error. ] [ drop "Response error" throw ] if + ] with-encoded-output + ] recover + ] if + ] bi ; LOG: httpd-hit NOTICE : log-request ( request -- ) - [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ; + [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi + 3array httpd-hit ; : split-path ( string -- path ) "/" split harvest ; @@ -79,9 +100,15 @@ LOG: httpd-hit NOTICE development-mode get-global [ global [ refresh-all ] bind ] when ; +: setup-limits ( -- ) + 1 minutes timeouts + 64 1024 * limit-input ; + : handle-client ( -- ) [ - 1 minutes timeouts + setup-limits + ascii decode-input + ascii encode-output ?refresh-all read-request do-request @@ -90,7 +117,7 @@ LOG: httpd-hit NOTICE : httpd ( port -- ) dup integer? [ internet-server ] when - "http.server" latin1 [ handle-client ] with-server ; + "http.server" binary [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 1d86a73cfa..9d76c82e4a 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -29,7 +29,10 @@ TUPLE: file-responder root hook special allow-listings ; H{ } clone >>special ; : (serve-static) ( path mime-type -- response ) - [ [ binary &dispose ] dip ] + [ + [ binary &dispose ] dip + binary >>content-charset + ] [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi [ "content-length" set-header ] [ "last-modified" set-header ] bi* ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 705c2d070b..ef1f575972 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -77,7 +77,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; { [ word? ] [ primitive? not ] [ { "inverse" "math-inverse" "pop-inverse" } [ word-prop ] with contains? not - ] } <-&& ; + ] } 1&& ; : (flatten) ( quot -- ) [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor index a11a7adead..b645f25055 100755 --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax byte-arrays alien ; +USING: help.markup help.syntax byte-arrays alien destructors ; IN: io.buffers ARTICLE: "buffers" "Locked I/O buffers" @@ -7,8 +7,8 @@ $nl "Buffer words are found in the " { $vocab-link "buffers" } " vocabulary." { $subsection buffer } { $subsection } -"Buffers must be manually deallocated:" -{ $subsection buffer-free } +"Buffers must be manually deallocated by calling " { $link dispose } "." +$nl "Buffer operations:" { $subsection buffer-reset } { $subsection buffer-length } @@ -40,11 +40,6 @@ HELP: { $values { "n" "a non-negative integer" } { "buffer" buffer } } { $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ; -HELP: buffer-free -{ $values { "buffer" buffer } } -{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." } -{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ; - HELP: buffer-reset { $values { "n" "a non-negative integer" } { "buffer" buffer } } { $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ; @@ -61,10 +56,6 @@ HELP: buffer-end { $values { "buffer" buffer } { "alien" alien } } { $description "Outputs the memory address of the current fill-pointer." } ; -HELP: (buffer-read) -{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } -{ $description "Outputs a byte array of the first " { $snippet "n" } " bytes at the buffer's current position. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ; - HELP: buffer-read { $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index f66f9ed313..74a1797efc 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,6 +1,7 @@ IN: io.buffers.tests USING: alien alien.c-types io.buffers kernel kernel.private libc -sequences tools.test namespaces byte-arrays strings accessors ; +sequences tools.test namespaces byte-arrays strings accessors +destructors ; : buffer-set ( string buffer -- ) over >byte-array over buffer-ptr byte-array>memory @@ -18,7 +19,7 @@ sequences tools.test namespaces byte-arrays strings accessors ; 65536 dup buffer-read-all over buffer-capacity - rot buffer-free + rot dispose ] unit-test [ "hello world" "" ] [ @@ -26,34 +27,34 @@ sequences tools.test namespaces byte-arrays strings accessors ; dup buffer-read-all >string 0 pick buffer-reset over buffer-read-all >string - rot buffer-free + rot dispose ] unit-test [ "hello" ] [ "hello world" string>buffer - 5 over buffer-read >string swap buffer-free + 5 over buffer-read >string swap dispose ] unit-test [ 11 ] [ "hello world" string>buffer - [ buffer-length ] keep buffer-free + [ buffer-length ] keep dispose ] unit-test [ "hello world" ] [ "hello" 1024 [ buffer-set ] keep " world" >byte-array over >buffer - dup buffer-read-all >string swap buffer-free + dup buffer-read-all >string swap dispose ] unit-test [ CHAR: e ] [ "hello" string>buffer - 1 over buffer-consume [ buffer-pop ] keep buffer-free + 1 over buffer-consume [ buffer-pop ] keep dispose ] unit-test "hello world" string>buffer "b" set [ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test -"b" get buffer-free +"b" get dispose 100 "b" set [ 1000 "b" get n>buffer >string ] must-fail -"b" get buffer-free +"b" get dispose diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index d5b917246a..a65717fb86 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -1,77 +1,101 @@ ! Copyright (C) 2004, 2005 Mackenzie Straight. ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.accessors alien.c-types alien.syntax kernel -kernel.private libc math sequences byte-arrays strings hints -accessors math.order ; +USING: accessors alien alien.accessors alien.c-types +alien.syntax kernel libc math sequences byte-arrays strings +hints accessors math.order destructors combinators ; IN: io.buffers -TUPLE: buffer size ptr fill pos ; +TUPLE: buffer size ptr fill pos disposed ; : ( n -- buffer ) - dup malloc 0 0 buffer boa ; + dup malloc 0 0 f buffer boa ; -: buffer-free ( buffer -- ) - dup buffer-ptr free f swap set-buffer-ptr ; +M: buffer dispose* ptr>> free ; : buffer-reset ( n buffer -- ) - 0 swap { set-buffer-fill set-buffer-pos } set-slots ; - -: buffer-consume ( n buffer -- ) - [ buffer-pos + ] keep - [ buffer-fill min ] keep - [ set-buffer-pos ] keep - dup buffer-pos over buffer-fill >= [ - 0 over set-buffer-pos - 0 over set-buffer-fill - ] when drop ; - -: buffer@ ( buffer -- alien ) - dup buffer-pos swap buffer-ptr ; - -: buffer-end ( buffer -- alien ) - dup buffer-fill swap buffer-ptr ; - -: buffer-peek ( buffer -- byte ) - buffer@ 0 alien-unsigned-1 ; - -: buffer-pop ( buffer -- byte ) - dup buffer-peek 1 rot buffer-consume ; - -: (buffer-read) ( n buffer -- byte-array ) - [ [ fill>> ] [ pos>> ] bi - min ] keep - buffer@ swap memory>byte-array ; - -: buffer-read ( n buffer -- byte-array ) - [ (buffer-read) ] [ buffer-consume ] 2bi ; - -: buffer-length ( buffer -- n ) - [ fill>> ] [ pos>> ] bi - ; + swap >>fill 0 >>pos drop ; : buffer-capacity ( buffer -- n ) - [ size>> ] [ fill>> ] bi - ; + [ size>> ] [ fill>> ] bi - ; inline : buffer-empty? ( buffer -- ? ) fill>> zero? ; +: buffer-consume ( n buffer -- ) + [ + ] change-pos + dup [ pos>> ] [ fill>> ] bi < + [ 0 >>pos 0 >>fill ] unless drop ; inline + +: buffer-peek ( buffer -- byte ) + [ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline + +: buffer-pop ( buffer -- byte ) + [ buffer-peek ] [ 1 swap buffer-consume ] bi ; + +HINTS: buffer-pop buffer ; + +: buffer-length ( buffer -- n ) + [ fill>> ] [ pos>> ] bi - ; inline + +: buffer@ ( buffer -- alien ) + [ pos>> ] [ ptr>> ] bi ; + +: buffer-read ( n buffer -- byte-array ) + [ buffer-length min ] keep + [ buffer@ ] [ buffer-consume ] 2bi + swap memory>byte-array ; + +HINTS: buffer-read fixnum buffer ; + : extend-buffer ( n buffer -- ) - 2dup buffer-ptr swap realloc - over set-buffer-ptr set-buffer-size ; + 2dup ptr>> swap realloc >>ptr swap >>size drop ; + inline : check-overflow ( n buffer -- ) 2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ; + inline -: >buffer ( byte-array buffer -- ) - over length over check-overflow - [ buffer-end byte-array>memory ] 2keep - [ buffer-fill swap length + ] keep set-buffer-fill ; - -: byte>buffer ( byte buffer -- ) - 1 over check-overflow - [ buffer-end 0 set-alien-unsigned-1 ] keep - [ 1+ ] change-fill drop ; +: buffer-end ( buffer -- alien ) + [ fill>> ] [ ptr>> ] bi ; inline : n>buffer ( n buffer -- ) - [ buffer-fill + ] keep - [ buffer-size > [ "Buffer overflow" throw ] when ] 2keep - set-buffer-fill ; + [ + ] change-fill + [ fill>> ] [ size>> ] bi > + [ "Buffer overflow" throw ] when ; inline + +: >buffer ( byte-array buffer -- ) + [ [ length ] dip check-overflow ] + [ buffer-end byte-array>memory ] + [ [ length ] dip n>buffer ] + 2tri ; + +HINTS: >buffer byte-array buffer ; + +: byte>buffer ( byte buffer -- ) + [ 1 swap check-overflow ] + [ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ] + [ 1 swap n>buffer ] + tri ; + +HINTS: byte>buffer fixnum buffer ; + +: search-buffer-until ( pos fill ptr separators -- n ) + [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; + +: finish-buffer-until ( buffer n -- byte-array separator ) + [ + over pos>> - + over buffer-read + swap buffer-pop + ] [ + [ buffer-length ] keep + buffer-read f + ] if* ; + +: buffer-until ( separators buffer -- byte-array separator ) + swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip + search-buffer-until + finish-buffer-until ; + +HINTS: buffer-until { string buffer } ; diff --git a/extra/io/encodings/8-bit/8-bit-tests.factor b/extra/io/encodings/8-bit/8-bit-tests.factor index 24cd4137d4..8b18e2a9af 100644 --- a/extra/io/encodings/8-bit/8-bit-tests.factor +++ b/extra/io/encodings/8-bit/8-bit-tests.factor @@ -1,4 +1,5 @@ -USING: io.encodings.string io.encodings.8-bit tools.test strings arrays ; +USING: io.encodings.string io.encodings.8-bit +io.encodings.8-bit.private tools.test strings arrays ; IN: io.encodings.8-bit.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test @@ -8,3 +9,6 @@ IN: io.encodings.8-bit.tests [ "bar" ] [ "bar" latin1 decode ] unit-test [ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test [ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test + +[ t ] [ \ latin1 8-bit-encoding? ] unit-test +[ "bar" ] [ "bar" \ latin1 decode ] unit-test diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index d4e6122321..71c57ef68c 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -73,6 +73,13 @@ M: 8-bit decode-char : define-8-bit-encoding ( name stream -- ) >r in get create r> parse-file make-8-bit ; +PREDICATE: 8-bit-encoding < word + word-def dup length 1 = [ first 8-bit? ] [ drop f ] if ; + +M: 8-bit-encoding word-def first ; + +M: 8-bit-encoding word-def first ; + PRIVATE> [ diff --git a/extra/io/encodings/iana/iana.factor b/extra/io/encodings/iana/iana.factor index dd429c1670..4368360a4d 100755 --- a/extra/io/encodings/iana/iana.factor +++ b/extra/io/encodings/iana/iana.factor @@ -41,6 +41,13 @@ PRIVATE> [ second ] map { "None" } diff ] map ; +: more-aliases ( -- assoc ) + H{ + { "UTF8" utf8 } + { "utf8" utf8 } + { "utf-8" utf8 } + } ; + : make-n>e ( stream -- n>e ) parse-iana [ [ dup [ @@ -48,7 +55,7 @@ PRIVATE> [ swap [ set ] with each ] [ drop ] if* ] with each - ] each ] H{ } make-assoc ; + ] each ] H{ } make-assoc more-aliases assoc-union ; PRIVATE> "resource:extra/io/encodings/iana/character-sets" diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 171f8122c5..98cf3e5769 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,5 +1,5 @@ USING: io.files kernel sequences accessors -dlists arrays sequences.lib ; +dlists dequeues arrays sequences.lib ; IN: io.paths TUPLE: directory-iterator path bfs queue ; @@ -18,7 +18,7 @@ TUPLE: directory-iterator path bfs queue ; dup path>> over push-directory ; : next-file ( iter -- file/f ) - dup queue>> dlist-empty? [ drop f ] [ + dup queue>> dequeue-empty? [ drop f ] [ dup queue>> pop-back first2 [ over push-directory next-file ] [ nip ] if ] if ; diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 1cbbac7f20..b761ecaf5b 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -71,6 +71,28 @@ M: input-port stream-read ] [ 2nip ] if ] [ 2nip ] if ; +: read-until-step ( separators port -- string/f separator/f ) + dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ; + +: read-until-loop ( seps port buf -- separator/f ) + 2over read-until-step over [ + >r over push-all r> dup [ + >r 3drop r> + ] [ + drop read-until-loop + ] if + ] [ + >r 2drop 2drop r> + ] if ; + +M: input-port stream-read-until ( seps port -- str/f sep/f ) + 2dup read-until-step dup [ >r 2nip r> ] [ + over [ + drop + BV{ } like [ read-until-loop ] keep B{ } like swap + ] [ >r 2nip r> ] if + ] if ; + TUPLE: output-port < buffered-port ; : ( handle -- output-port ) @@ -121,7 +143,7 @@ M: output-port dispose* M: buffered-port dispose* [ call-next-method ] - [ [ [ buffer-free ] when* f ] change-buffer drop ] + [ [ [ dispose ] when* f ] change-buffer drop ] bi ; M: port cancel-operation handle>> cancel-operation ; diff --git a/extra/io/streams/limited/limited-tests.factor b/extra/io/streams/limited/limited-tests.factor new file mode 100644 index 0000000000..d160a3f756 --- /dev/null +++ b/extra/io/streams/limited/limited-tests.factor @@ -0,0 +1,32 @@ +IN: io.streams.limited.tests +USING: io io.streams.limited io.encodings io.encodings.string +io.encodings.ascii io.encodings.binary io.streams.byte-array +namespaces tools.test strings kernel ; + +[ ] [ + "hello world\nhow are you today\nthis is a very long line indeed" + ascii encode binary "data" set +] unit-test + +[ ] [ "data" get 24 "limited" set ] unit-test + +[ CHAR: h ] [ "limited" get stream-read1 ] unit-test + +[ ] [ "limited" get ascii "decoded" set ] unit-test + +[ "ello world" ] [ "decoded" get stream-readln ] unit-test + +[ "how " ] [ 4 "decoded" get stream-read ] unit-test + +[ "decoded" get stream-readln ] [ limit-exceeded? ] must-fail-with + +[ ] [ + "abc\ndef\nghi" + ascii encode binary "data" set +] unit-test + +[ ] [ "data" get 7 "limited" set ] unit-test + +[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test + +[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with diff --git a/extra/io/streams/limited/limited.factor b/extra/io/streams/limited/limited.factor new file mode 100644 index 0000000000..669240d28b --- /dev/null +++ b/extra/io/streams/limited/limited.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math io destructors accessors sequences +namespaces ; +IN: io.streams.limited + +TUPLE: limited-stream stream count limit ; + +: ( stream limit -- stream' ) + limited-stream new + swap >>limit + swap >>stream + 0 >>count ; + +: limit-input ( limit -- ) + input-stream [ swap ] change ; + +ERROR: limit-exceeded ; + +: check-limit ( n stream -- ) + [ + ] change-count + [ count>> ] [ limit>> ] bi >= + [ limit-exceeded ] when ; inline + +M: limited-stream stream-read1 + 1 over check-limit stream>> stream-read1 ; + +M: limited-stream stream-read + 2dup check-limit stream>> stream-read ; + +M: limited-stream stream-read-partial + 2dup check-limit stream>> stream-read-partial ; + +: (read-until) ( stream seps buf -- stream seps buf sep/f ) + 3dup [ [ stream-read1 dup ] dip memq? ] dip + swap [ drop ] [ push (read-until) ] if ; + +M: limited-stream stream-read-until + swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ; + +M: limited-stream dispose + stream>> dispose ; diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor new file mode 100644 index 0000000000..2a66f3a701 --- /dev/null +++ b/extra/irc/client/client-docs.factor @@ -0,0 +1,89 @@ +USING: help.markup help.syntax quotations kernel ; +IN: irc.client + +HELP: irc-client "IRC Client object" +"blah" ; + +HELP: irc-server-listener "Listener for server messages unmanaged by other listeners" +"blah" ; + +HELP: irc-channel-listener "Listener for irc channels" +"blah" ; + +HELP: irc-nick-listener "Listener for irc users" +"blah" ; + +HELP: irc-profile "IRC Client profile object" +"blah" ; + +HELP: connect-irc "Connecting to an irc server" +{ $values { "irc-client" "an irc client object" } } +{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ; + +HELP: add-listener "Listening to irc channels/users/etc" +{ $values { "irc-client" "an irc client object" } { "irc-listener" "an irc listener object" } } +{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ; + +HELP: terminate-irc "Terminates an irc client" +{ $values { "irc-client" "an irc client object" } } +{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ; + +ARTICLE: "irc.client" "IRC Client" +"An IRC Client library" +{ $heading "IRC objects:" } +{ $subsection irc-client } +{ $heading "Listener objects:" } +{ $subsection irc-server-listener } +{ $subsection irc-channel-listener } +{ $subsection irc-nick-listener } +{ $heading "Setup objects:" } +{ $subsection irc-profile } +{ $heading "Words:" } +{ $subsection connect-irc } +{ $subsection terminate-irc } +{ $subsection add-listener } +{ $heading "IRC messages" } +"Some of the RFC defined irc messages as objects:" +{ $table + { { $link irc-message } "base of all irc messages" } + { { $link logged-in } "logged in to server" } + { { $link ping } "ping message" } + { { $link join } "channel join" } + { { $link part } "channel part" } + { { $link quit } "quit from irc" } + { { $link privmsg } "private message (to client or channel)" } + { { $link kick } "kick from channel" } + { { $link roomlist } "list of participants in channel" } + { { $link nick-in-use } "chosen nick is in use by another client" } + { { $link notice } "notice message" } + { { $link mode } "mode change" } + { { $link unhandled } "uninmplemented/unhandled message" } + } +{ $heading "Special messages" } +"Some special messages that are created by the library and not by the irc server." +{ $table + { { $link irc-end } " sent when the client isn't running anymore, listeners should stop after this." } + { { $link irc-disconnected } " sent to notify listeners that connection was lost." } + { { $link irc-connected } " sent to notify listeners that a connection with the irc server was established." } } + +{ $heading "Example:" } +{ $code + "USING: irc.client concurrency.mailboxes ;" + "SYMBOL: bot" + "SYMBOL: mychannel" + "! Create the profile and client objects" + "\"irc.freenode.org\" irc-port \"mybot123\" f bot set" + "! Connect to the server" + "bot get connect-irc" + "! Create a channel listener" + "\"#mychannel123\" mychannel set" + "! Register and start listener (this joins the channel)" + "bot get mychannel get add-listener" + "! Send a message to the channel" + "\"what's up?\" mychannel get out-messages>> mailbox-put" + "! Read a message from the channel" + "mychannel get in-messages>> mailbox-get" +} + ; + +ABOUT: "irc.client" \ No newline at end of file diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor new file mode 100644 index 0000000000..304ab25402 --- /dev/null +++ b/extra/irc/client/client-tests.factor @@ -0,0 +1,79 @@ +USING: kernel tools.test accessors arrays sequences qualified + io.streams.string io.streams.duplex namespaces threads + calendar irc.client.private ; +EXCLUDE: irc.client => join ; +IN: irc.client.tests + +! Utilities +: ( lines -- stream ) + "\n" join ; + +: make-client ( lines -- irc-client ) + "someserver" irc-port "factorbot" f + swap [ 2nip f ] curry >>connect ; + +: set-nick ( irc-client nickname -- ) + [ nick>> ] dip >>name drop ; + +: with-dummy-client ( quot -- ) + rot with-variable ; inline + +! Parsing tests +irc-message new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + string>irc-message f >>timestamp ] unit-test + +privmsg new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing + "#factortest" >>name +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line f >>timestamp ] unit-test + +{ "" } make-client dup "factorbot" set-nick current-irc-client [ + { t } [ irc> nick>> name>> me? ] unit-test + + { "factorbot" } [ irc> nick>> name>> ] unit-test + + { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test + + { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line irc-message-origin ] unit-test + + { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" + parse-irc-line irc-message-origin ] unit-test +] with-variable + +! Test login and nickname set +{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..." + "NOTICE AUTH :*** Checking ident" + "NOTICE AUTH :*** Found your hostname" + "NOTICE AUTH :*** No identd (auth) response" + ":some.where 001 factorbot :Welcome factorbot" + } make-client + [ connect-irc ] keep 1 seconds sleep + nick>> name>> ] unit-test + +! TODO: Channel join messages +! { ":factorbot!n=factorbo@some.where JOIN :#factortest" +! ":ircserver.net MODE #factortest +ns" +! ":ircserver.net 353 factorbot @ #factortest :@factorbot " +! ":ircserver.net 366 factorbot #factortest :End of /NAMES list." +! ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" +! } make-client dup "factorbot" set-nick +! TODO: user join +! ":somedude!n=user@isp.net JOIN :#factortest" +! TODO: channel message +! ":somedude!n=user@isp.net PRIVMSG #factortest :hello" +! TODO: direct private message +! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 19dca48e1d..e633f140fb 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators concurrency.mailboxes concurrency.futures io +USING: arrays combinators concurrency.mailboxes fry io strings io.encodings.8-bit io.sockets kernel namespaces sequences sequences.lib splitting threads calendar classes.tuple - ascii assocs accessors destructors ; + classes ascii assocs accessors destructors continuations ; IN: irc.client ! ====================================== @@ -18,28 +18,42 @@ SYMBOL: current-irc-client TUPLE: irc-profile server port nickname password ; C: irc-profile -TUPLE: irc-channel-profile name password ; -: ( -- irc-channel-profile ) irc-channel-profile new ; - ! "live" objects TUPLE: nick name channels log ; C: nick TUPLE: irc-client profile nick stream in-messages out-messages join-messages - listeners is-running ; + listeners is-running connect reconnect-time ; : ( profile -- irc-client ) f V{ } clone V{ } clone - f H{ } clone f irc-client boa ; + f H{ } clone f + [ latin1 ] 15 seconds irc-client boa ; TUPLE: irc-listener in-messages out-messages ; -: ( -- irc-listener ) - irc-listener boa ; +TUPLE: irc-server-listener < irc-listener ; +TUPLE: irc-channel-listener < irc-listener name password timeout ; +TUPLE: irc-nick-listener < irc-listener name ; +UNION: irc-named-listener irc-nick-listener irc-channel-listener ; + +: ( -- irc-listener ) irc-listener boa ; + +: ( -- irc-server-listener ) + irc-server-listener boa ; + +: ( name -- irc-channel-listener ) + rot f 60 seconds irc-channel-listener boa ; + +: ( name -- irc-nick-listener ) + rot irc-nick-listener boa ; ! ====================================== ! Message objects ! ====================================== -SINGLETON: irc-end ! Message used when the client isn't running anymore +SINGLETON: irc-end ! sent when the client isn't running anymore +SINGLETON: irc-disconnected ! sent when connection is lost +SINGLETON: irc-connected ! sent when connection is established +UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; TUPLE: irc-message line prefix command parameters trailing timestamp ; TUPLE: logged-in < irc-message name ; @@ -55,14 +69,20 @@ TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name channel mode ; TUPLE: unhandled < irc-message ; +: terminate-irc ( irc-client -- ) + [ in-messages>> irc-end swap mailbox-put ] + [ f >>is-running drop ] + [ stream>> dispose ] + tri ; + ( -- irc-client ) current-irc-client get ; -: irc-stream> ( -- stream ) irc-client> stream>> ; +: irc> ( -- irc-client ) current-irc-client get ; +: irc-stream> ( -- stream ) irc> stream>> ; : irc-write ( s -- ) irc-stream> stream-write ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; @@ -79,7 +99,7 @@ TUPLE: unhandled < irc-message ; " hostname servername :irc.factor" irc-print ; : /CONNECT ( server port -- stream ) - latin1 drop ; + irc> connect>> call drop ; : /JOIN ( channel password -- ) "JOIN " irc-write @@ -106,48 +126,12 @@ TUPLE: unhandled < irc-message ; : /PONG ( text -- ) "PONG " irc-write irc-print ; -! ====================================== -! Server message handling -! ====================================== - -USE: prettyprint - -GENERIC: handle-incoming-irc ( irc-message -- ) - -M: irc-message handle-incoming-irc ( irc-message -- ) - . ; - -M: logged-in handle-incoming-irc ( logged-in -- ) - name>> irc-client> nick>> (>>name) ; - -M: ping handle-incoming-irc ( ping -- ) - trailing>> /PONG ; - -M: nick-in-use handle-incoming-irc ( nick-in-use -- ) - name>> "_" append /NICK ; - -M: privmsg handle-incoming-irc ( privmsg -- ) - dup name>> irc-client> listeners>> at - [ in-messages>> mailbox-put ] [ drop ] if* ; - -M: join handle-incoming-irc ( join -- ) - irc-client> join-messages>> mailbox-put ; - -! ====================================== -! Client message handling -! ====================================== - -GENERIC: handle-outgoing-irc ( obj -- ) - -M: privmsg handle-outgoing-irc ( privmsg -- ) - [ name>> ] [ trailing>> ] bi /PRIVMSG ; - ! ====================================== ! Message parsing ! ====================================== : split-at-first ( seq separators -- before after ) - dupd [ member? ] curry find + dupd '[ , member? ] find [ cut 1 tail ] [ swap ] if ; @@ -188,50 +172,115 @@ M: privmsg handle-outgoing-irc ( privmsg -- ) } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ; +! ====================================== +! Server message handling +! ====================================== + +: me? ( string -- ? ) + irc> nick>> name>> = ; + +: irc-message-origin ( irc-message -- name ) + dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; + +: broadcast-message-to-listeners ( message -- ) + irc> listeners>> values [ in-messages>> mailbox-put ] with each ; + +GENERIC: handle-incoming-irc ( irc-message -- ) + +M: irc-message handle-incoming-irc ( irc-message -- ) + f irc> listeners>> at + [ in-messages>> mailbox-put ] [ drop ] if* ; + +M: logged-in handle-incoming-irc ( logged-in -- ) + name>> irc> nick>> (>>name) ; + +M: ping handle-incoming-irc ( ping -- ) + trailing>> /PONG ; + +M: nick-in-use handle-incoming-irc ( nick-in-use -- ) + name>> "_" append /NICK ; + +M: privmsg handle-incoming-irc ( privmsg -- ) + dup irc-message-origin irc> listeners>> [ at ] keep + '[ f , at ] unless* [ in-messages>> mailbox-put ] [ drop ] if* ; + +M: join handle-incoming-irc ( join -- ) + irc> join-messages>> mailbox-put ; + +M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) + broadcast-message-to-listeners ; + +! ====================================== +! Client message handling +! ====================================== + +GENERIC: handle-outgoing-irc ( obj -- ) + +M: privmsg handle-outgoing-irc ( privmsg -- ) + [ name>> ] [ trailing>> ] bi /PRIVMSG ; + ! ====================================== ! Reader/Writer ! ====================================== -: stream-readln-or-close ( stream -- str/f ) - dup stream-readln [ nip ] [ dispose f ] if* ; +: irc-mailbox-get ( mailbox quot -- ) + swap 5 seconds + '[ , , , mailbox-get-timeout swap call ] + [ drop ] recover ; inline : handle-reader-message ( irc-message -- ) - irc-client> in-messages>> mailbox-put ; + irc> in-messages>> mailbox-put ; -: handle-stream-close ( -- ) - irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ; +DEFER: (connect-irc) + +: (handle-disconnect) ( -- ) + irc> + [ in-messages>> irc-disconnected swap mailbox-put ] + [ dup reconnect-time>> sleep (connect-irc) ] + [ profile>> nickname>> /LOGIN ] + tri ; + +: handle-disconnect ( error -- ) + drop irc> is-running>> [ (handle-disconnect) ] when ; + +: (reader-loop) ( -- ) + irc> stream>> [ + |dispose stream-readln [ + parse-irc-line handle-reader-message + ] [ + irc> terminate-irc + ] if* + ] with-destructors ; : reader-loop ( -- ) - irc-client> stream>> stream-readln-or-close [ - parse-irc-line handle-reader-message - ] [ - handle-stream-close - ] if* ; + [ (reader-loop) ] [ handle-disconnect ] recover ; : writer-loop ( -- ) - irc-client> out-messages>> mailbox-get handle-outgoing-irc ; + irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ) - irc-client> in-messages>> mailbox-get handle-incoming-irc ; + irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ; -! FIXME: Hack, this should be handled better -GENERIC: add-name ( name obj -- obj ) -M: object add-name nip ; -M: privmsg add-name swap >>name ; - -: listener-loop ( name -- ) ! FIXME: take different values from the stack? - dup irc-client> listeners>> at [ - out-messages>> mailbox-get add-name - irc-client> out-messages>> - mailbox-put - ] [ drop ] if* ; +: strings>privmsg ( name string -- privmsg ) + privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; + +: maybe-annotate-with-name ( name obj -- obj ) + { + { [ dup string? ] [ strings>privmsg ] } + { [ dup privmsg instance? ] [ swap >>name ] } + } cond ; + +: listener-loop ( name listener -- ) + out-messages>> swap + '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ] + irc-mailbox-get ; : spawn-irc-loop ( quot name -- ) - [ [ irc-client> is-running>> ] compose ] dip + [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip spawn-server drop ; : spawn-irc ( -- ) @@ -243,23 +292,33 @@ M: privmsg add-name swap >>name ; ! Listener join request handling ! ====================================== -: make-registered-listener ( join -- listener ) - swap trailing>> - dup [ listener-loop ] curry "listener" spawn-irc-loop - [ irc-client> listeners>> set-at ] curry keep ; +: set+run-listener ( name irc-listener -- ) + [ '[ , , listener-loop ] "listener" spawn-irc-loop ] + [ swap irc> listeners>> set-at ] + 2bi ; -: make-join-future ( name -- future ) - [ [ swap trailing>> = ] curry ! compare name with channel name - irc-client> join-messages>> 60 seconds rot mailbox-get-timeout? - make-registered-listener ] - curry future ; +GENERIC: (add-listener) ( irc-listener -- ) +M: irc-channel-listener (add-listener) ( irc-channel-listener -- ) + [ [ name>> ] [ password>> ] bi /JOIN ] + [ [ [ drop irc> join-messages>> ] + [ timeout>> ] + [ name>> '[ trailing>> , = ] ] + tri mailbox-get-timeout? trailing>> ] keep set+run-listener + ] bi ; -PRIVATE> +M: irc-nick-listener (add-listener) ( irc-nick-listener -- ) + [ name>> ] keep set+run-listener ; + +M: irc-server-listener (add-listener) ( irc-server-listener -- ) + f swap set+run-listener ; : (connect-irc) ( irc-client -- ) - [ profile>> [ server>> ] keep port>> /CONNECT ] keep - swap >>stream - t >>is-running drop ; + [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep + swap >>stream + t >>is-running + in-messages>> irc-connected swap mailbox-put ; + +PRIVATE> : connect-irc ( irc-client -- ) dup current-irc-client [ @@ -267,9 +326,6 @@ PRIVATE> spawn-irc ] with-variable ; -: listen-to ( irc-client name -- future ) - swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ; - -! shorcut for privmsgs, etc -: sender>> ( obj -- string ) - prefix>> parse-name ; +GENERIC: add-listener ( irc-client irc-listener -- ) +M: irc-listener add-listener ( irc-client irc-listener -- ) + current-irc-client swap '[ , (add-listener) ] with-variable ; diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor index e5155a786e..06c33505ca 100755 --- a/extra/lcs/lcs.factor +++ b/extra/lcs/lcs.factor @@ -56,7 +56,7 @@ TUPLE: trace-state old new table i j ; { [ i>> 0 > ] [ j>> 0 > ] [ [ old-nth ] [ new-nth ] bi = ] - } <-&& ; + } 1&& ; : do-retain ( state -- state ) dup old-nth retain boa , diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 14b91aa58b..8dc3b65ffe 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp lisp.parser tools.test sequences math kernel parser arrays ; +USING: lisp lisp.parser tools.test sequences math kernel parser arrays lists +quotations ; IN: lisp.test @@ -13,33 +14,36 @@ IN: lisp.test "+" "math" "+" define-primitive "-" "math" "-" define-primitive + "cons" "lists" "cons" define-primitive + "car" "lists" "car" define-primitive + "cdr" "lists" "cdr" define-primitive + "append" "lists" "lappend" define-primitive + "nil" "lists" "nil" define-primitive + "nil?" "lists" "nil?" define-primitive + + [ seq>list ] "##list" lisp-define + + "define" "lisp" "defun" define-primitive + + "(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define + { 5 } [ - [ 2 3 ] "+" funcall + ! [ 2 3 ] "+" funcall + "(+ 2 3)" lisp-eval ] unit-test { 8.3 } [ - [ 10.4 2.1 ] "-" funcall + ! [ 10.4 2.1 ] "-" funcall + "(- 10.4 2.1)" lisp-eval ] unit-test { 3 } [ "((lambda (x y) (+ x y)) 1 2)" lisp-eval ] unit-test - { 42 } [ - "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval - ] unit-test - - { T{ lisp-symbol f "if" } } [ - "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval - ] unit-test - - { t } [ - T{ lisp-symbol f "if" } lisp-macro? - ] unit-test - - { 1 } [ - "(if #t 1 2)" lisp-eval - ] unit-test +! { 42 } [ +! "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval +! ] unit-test { "b" } [ "(cond (#f \"a\") (#t \"b\"))" lisp-eval @@ -49,8 +53,28 @@ IN: lisp.test "(begin (+ 1 4))" lisp-eval ] unit-test - { 3 } [ - "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval + { { 1 2 3 4 5 } } [ + "(list 1 2 3 4 5)" lisp-eval list>seq ] unit-test + { { 1 2 { 3 { 4 } 5 } } } [ + "(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq + ] unit-test + + { T{ lisp-symbol f "if" } } [ + "(defmacro if (pred tr fl) (list (quote cond) (list (list pred tr) (list t fl))))" lisp-eval + ] unit-test + + { t } [ + T{ lisp-symbol f "if" } lisp-macro? + ] unit-test + +! { 1 } [ +! "(if #t 1 2)" lisp-eval +! ] unit-test + +! { 3 } [ +! "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval +! ] unit-test + ] with-interactive-vocabs diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 425ee27bb7..e3d942d390 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib -namespaces combinators math locals locals.private accessors +namespaces combinators math locals locals.private locals.backend accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations fry lists inspector ; IN: lisp @@ -11,19 +11,23 @@ DEFER: funcall DEFER: lookup-var DEFER: lookup-macro DEFER: lisp-macro? +DEFER: lisp-var? DEFER: macro-expand DEFER: define-lisp-macro +ERROR: no-such-var variable-name ; +M: no-such-var summary drop "No such variable" ; + ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) [ ] [ convert-form compose ] foldl ; inline : convert-begin ( cons -- quot ) - cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; + cdr [ convert-form ] [ ] lmap-as '[ , [ call ] each ] ; : convert-cond ( cons -- quot ) - cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] + cdr [ 2car [ convert-form ] bi@ [ '[ @ call ] ] dip 2array ] { } lmap-as '[ , cond ] ; : convert-general-form ( cons -- quot ) @@ -32,49 +36,33 @@ DEFER: define-lisp-macro ! words for convert-lambda > , at ] [ ] bi or ] traverse ; + { + { [ dup list? ] [ [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ] } + { [ dup lisp-symbol? ] [ name>> over at ] } + [ ] + } cond ; -: localize-lambda ( body vars -- newbody newvars ) +: localize-lambda ( body vars -- newvars newbody ) make-locals dup push-locals swap [ swap localize-body convert-form swap pop-locals ] dip swap ; -: split-lambda ( cons -- body-cons vars-seq ) - 3car -rot nip [ name>> ] lmap>array ; inline +: split-lambda ( cons -- body-cons vars-seq ) + cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline : rest-lambda ( body vars -- quot ) "&rest" swap [ index ] [ remove ] 2bi - localize-lambda - '[ , cut '[ @ , ] , compose ] ; + swapd localize-lambda + '[ , cut '[ @ , seq>list ] call , call ] ; : normal-lambda ( body vars -- quot ) - localize-lambda '[ , compose ] ; + localize-lambda lambda-rewrite [ compose call ] compose 1quotation ; PRIVATE> : convert-lambda ( cons -- quot ) split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; : convert-quoted ( cons -- quot ) - cdr 1quotation ; - -: convert-unquoted ( cons -- quot ) - "unquote not valid outside of quasiquote!" throw ; - -: convert-unquoted-splicing ( cons -- quot ) - "unquote-splicing not valid outside of quasiquote!" throw ; - -> "unquote" equal? dup ] } && nip ] - [ cadr ] traverse ; - -: quasiquote-unquote-splicing ( cons -- newcons ) - [ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ] - [ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } && nip ] - [ dup cadr cdr >>cdr ] traverse ; -PRIVATE> - -: convert-quasiquoted ( cons -- newcons ) - quasiquote-unquote quasiquote-unquote-splicing ; + cadr 1quotation ; : convert-defmacro ( cons -- quot ) cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; @@ -84,9 +72,6 @@ PRIVATE> { { "lambda" [ convert-lambda ] } { "defmacro" [ convert-defmacro ] } { "quote" [ convert-quoted ] } - { "unquote" [ convert-unquoted ] } - { "unquote-splicing" [ convert-unquoted-splicing ] } - { "quasiquote" [ convert-quasiquoted ] } { "begin" [ convert-begin ] } { "cond" [ convert-cond ] } [ drop convert-general-form ] @@ -102,6 +87,7 @@ PRIVATE> : convert-form ( lisp-form -- quot ) { { [ dup cons? ] [ convert-list-form ] } + { [ dup lisp-var? ] [ lookup-var 1quotation ] } { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } [ 1quotation ] } cond ; @@ -109,11 +95,8 @@ PRIVATE> : compile-form ( lisp-ast -- quot ) convert-form lambda-rewrite call ; inline -: macro-call ( lambda -- cons ) - call ; inline - : macro-expand ( cons -- quot ) - uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* ; + uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ; : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast compile-form ; @@ -125,9 +108,6 @@ PRIVATE> SYMBOL: lisp-env SYMBOL: macro-env - -ERROR: no-such-var variable-name ; -M: no-such-var summary drop "No such variable" ; : init-env ( -- ) H{ } clone lisp-env set @@ -136,17 +116,27 @@ M: no-such-var summary drop "No such variable" ; : lisp-define ( quot name -- ) lisp-env get set-at ; +: defun ( name quot -- name ) + over name>> lisp-define ; + : lisp-get ( name -- word ) dup lisp-env get at [ ] [ no-such-var ] ?if ; : lookup-var ( lisp-symbol -- quot ) name>> lisp-get ; +: lisp-var? ( lisp-symbol -- ? ) + dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ; + +: funcall-arg-list ( args -- newargs ) + [ ] [ dup \ funcall = [ drop 2 cut* [ funcall ] compose call ] when suffix ] reduce ; + : funcall ( quot sym -- * ) - dup lisp-symbol? [ lookup-var ] when call ; inline + [ funcall-arg-list ] dip + dup lisp-symbol? [ lookup-var ] when curry call ; inline : define-primitive ( name vocab word -- ) - swap lookup 1quotation '[ , compose call ] swap lisp-define ; + swap lookup 1quotation '[ , compose call ] swap lisp-define ; ! '[ , compose call ] swap lisp-define ; : lookup-macro ( lisp-symbol -- lambda ) name>> macro-env get at ; diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 1e37193d3a..8fadb00e65 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -34,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]] atom = number | identifier | string -list-item = _ ( atom | s-expression ) _ => [[ second ]] s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]] +list-item = _ ( atom | s-expression ) _ => [[ second ]] ;EBNF \ No newline at end of file diff --git a/extra/lists/lazy/examples/examples-tests.factor b/extra/lists/lazy/examples/examples-tests.factor index c088f1d9a7..04886e2c1c 100644 --- a/extra/lists/lazy/examples/examples-tests.factor +++ b/extra/lists/lazy/examples/examples-tests.factor @@ -1,4 +1,4 @@ -USING: lists.lazy.examples lazy-lists tools.test ; +USING: lists.lazy.examples lists.lazy tools.test ; IN: lists.lazy.examples.tests [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index cdc51b76e8..4a08a4d1e3 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -63,4 +63,8 @@ IN: lists.tests { { 3 4 { 5 6 { 7 } } } } [ { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq +] unit-test + +{ { 1 2 3 4 5 6 } } [ + { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq ] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 13d77f757a..613d75c4ae 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Chris Double & James Cash +! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words locals ; @@ -75,6 +75,9 @@ M: object nil? drop f ; : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; +: lappend ( list1 list2 -- newlist ) + [ lreverse ] dip [ swap cons ] foldl ; + : seq>list ( seq -- list ) nil [ swap cons ] reduce ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 3cedacc2ae..f46fcf6c53 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -4,7 +4,7 @@ USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects arrays.lib parser strings -combinators.lib quotations fry symbols accessors ; +quotations fry symbols accessors ; IN: logging SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; @@ -42,21 +42,18 @@ SYMBOL: log-service message ( obj -- inputs>message ) - dup one-string? [ first ] [ - H{ - { string-limit f } - { line-limit 1 } - { nesting-limit 3 } - { margin 0 } - } clone [ unparse ] bind + dup one-string-array? [ first ] [ + [ + string-limit off + 1 line-limit set + 3 nesting-limit set + 0 margin set + unparse + ] with-scope ] if ; PRIVATE> diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index f4ad8144be..ec30b2f27c 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -93,7 +93,12 @@ SYMBOL: log-files } case log-server-loop ; : log-server ( -- ) - [ [ log-server-loop ] [ error. (close-logs) ] recover t ] + [ + init-namespaces + [ log-server-loop ] + [ error. (close-logs) ] + recover t + ] "Log server" spawn-server "log-server" set-global ; diff --git a/extra/macros/macros-docs.factor b/extra/macros/macros-docs.factor index 44d1f32c8f..022458cc7c 100644 --- a/extra/macros/macros-docs.factor +++ b/extra/macros/macros-docs.factor @@ -21,7 +21,7 @@ HELP: macro-expand { $values { "..." "inputs to a macro" } { "word" macro } { "quot" quotation } } { $description "Expands a macro. Useful for debugging." } { $examples - { $code "{ [ dup integer? ] [ dup 0 > ] [ dup 13 mod zero? ] } \ && macro-expand ." } + { $code "USING: math macros combinators.lib ;" "{ [ integer? ] [ 0 > ] [ 13 mod zero? ] } \ 1&& macro-expand ." } } ; ARTICLE: "macros" "Macros" @@ -31,9 +31,6 @@ $nl { $subsection POSTPONE: MACRO: } "Expanding macros for debugging purposes:" { $subsection macro-expand } -! "Two sample macros which implement short-circuiting boolean operators (as found in C, Java and similar languages):" -! { $subsection && } -! { $subsection || } "Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ; ABOUT: "macros" diff --git a/extra/macros/macros-tests.factor b/extra/macros/macros-tests.factor index d5011b0ecb..91527c2125 100644 --- a/extra/macros/macros-tests.factor +++ b/extra/macros/macros-tests.factor @@ -12,3 +12,6 @@ unit-test "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval [ \ see-test see ] with-string-writer = ] unit-test + +[ ] [ "USING: macros inference kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test + diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index 3030f28d04..500e08f79d 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -26,7 +26,7 @@ IN: math.text.english SYMBOL: and-needed? : set-conjunction ( seq -- ) - first { [ dup 100 < ] [ dup 0 > ] } && and-needed? set drop ; + first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ; : negative-text ( n -- str ) 0 < "Negative " "" ? ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index e2a18e2f78..fe6945d3f7 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -154,7 +154,7 @@ M: method-body stack-effect "multi-method-generic" word-prop stack-effect ; M: method-body crossref? - drop t ; + "forgotten" word-prop not ; : method-word-name ( specializer generic -- string ) [ word-name % "-" % unparse % ] "" make ; diff --git a/extra/opengl/framebuffers/framebuffer-docs.factor b/extra/opengl/framebuffers/framebuffers-docs.factor similarity index 100% rename from extra/opengl/framebuffers/framebuffer-docs.factor rename to extra/opengl/framebuffers/framebuffers-docs.factor diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 5fed709253..9e91119247 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu combinators arrays sequences -splitting words byte-arrays assocs combinators.lib ; +splitting words byte-arrays assocs ; IN: opengl : coordinates ( point1 point2 -- x1 y2 x2 y2 ) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 8a3a06c58d..fc10a65024 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -87,7 +87,7 @@ C: ebnf [ dup CHAR: ? = ] [ dup CHAR: : = ] [ dup CHAR: ~ = ] - } || not nip + } 0|| not nip ] satisfy repeat1 [ >string ] action ; : 'terminal' ( -- parser ) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 784e6c064c..443b9fc61d 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays combinators.lib math.parser + vectors arrays math.parser unicode.categories sequences.deep peg peg.private peg.search math.ranges words memoize ; IN: peg.parsers diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index 32b1aa5549..ef8ef8c0f7 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -59,7 +59,7 @@ PRIVATE> diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor index d8f81717af..e6eadba264 100644 --- a/extra/project-euler/021/021.factor +++ b/extra/project-euler/021/021.factor @@ -27,7 +27,7 @@ IN: project-euler.021 : amicable? ( n -- ? ) dup sum-proper-divisors - { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } && 2nip ; + { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } 0&& 2nip ; : euler021 ( -- answer ) 10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ; diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor index 153901ce6d..fbf6376eb3 100644 --- a/extra/project-euler/036/036.factor +++ b/extra/project-euler/036/036.factor @@ -27,7 +27,7 @@ IN: project-euler.036 : both-bases? ( n -- ? ) { [ dup palindrome? ] - [ dup >bin dup reverse = ] } && nip ; + [ dup >bin dup reverse = ] } 0&& nip ; PRIVATE> diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index 41e378e531..0c51146656 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -47,7 +47,7 @@ IN: project-euler.043 [ 5 4 pick subseq-divisible? ] [ 3 3 pick subseq-divisible? ] [ 2 2 pick subseq-divisible? ] - } && nip ; + } 0&& nip ; PRIVATE> diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor index 3f6487fb3e..6c4b605bd9 100644 --- a/extra/project-euler/052/052.factor +++ b/extra/project-euler/052/052.factor @@ -29,7 +29,7 @@ IN: project-euler.052 [ number>digits natural-sort ] map all-equal? ; : candidate? ( n -- ? ) - { [ dup odd? ] [ dup 3 mod zero? ] } && nip ; + { [ dup odd? ] [ dup 3 mod zero? ] } 0&& nip ; : next-all-same ( x n -- n ) dup candidate? [ diff --git a/extra/sequences/deep/tags.txt b/extra/sequences/deep/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/sequences/deep/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/sequences/modified/tags.txt b/extra/sequences/modified/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/sequences/modified/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/sequences/repeating/tags.txt b/extra/sequences/repeating/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/sequences/repeating/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index c5734b2ae8..638c91553f 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -4,7 +4,7 @@ USING: tools.test kernel serialize io io.streams.byte-array math alien arrays byte-arrays sequences math prettyprint parser classes math.constants io.encodings.binary random -combinators.lib assocs ; +assocs ; IN: serialize.tests : test-serialize-cell @@ -15,12 +15,11 @@ IN: serialize.tests [ t ] [ 100 [ drop - { - [ 40 [ test-serialize-cell ] all? ] - [ 4 [ 40 * test-serialize-cell ] all? ] - [ 4 [ 400 * test-serialize-cell ] all? ] - [ 4 [ 4000 * test-serialize-cell ] all? ] - } && + 40 [ test-serialize-cell ] all? + 4 [ 40 * test-serialize-cell ] all? + 4 [ 400 * test-serialize-cell ] all? + 4 [ 4000 * test-serialize-cell ] all? + and and and ] all? ] unit-test diff --git a/extra/syndication/syndication.factor b/extra/syndication/syndication.factor index 12beaf4cd7..32b3c925f3 100644 --- a/extra/syndication/syndication.factor +++ b/extra/syndication/syndication.factor @@ -107,7 +107,7 @@ TUPLE: entry title url description date ; : download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. - http-get read-feed ; + http-get nip read-feed ; ! Atom generation : simple-tag, ( content name -- ) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index e8675f5891..db0f478709 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -150,6 +150,7 @@ IN: tools.deploy.shaker classes:class-or-cache classes:class<=-cache classes:classes-intersect-cache + classes:implementors-map classes:update-map command-line:main-vocab-hook compiled-crossref diff --git a/extra/tools/deploy/shaker/strip-debugger.factor b/extra/tools/deploy/shaker/strip-debugger.factor index 5caab02e69..2302b61715 100755 --- a/extra/tools/deploy/shaker/strip-debugger.factor +++ b/extra/tools/deploy/shaker/strip-debugger.factor @@ -1,8 +1,8 @@ USING: kernel threads threads.private ; IN: debugger -: print-error die ; +: print-error ( error -- ) die drop ; -: error. die ; +: error. ( error -- ) die drop ; M: thread error-in-thread ( error thread -- ) die 2drop ; diff --git a/extra/tools/deploy/shaker/strip-libc.factor b/extra/tools/deploy/shaker/strip-libc.factor index ba1436fd17..9c2dc4e8ec 100755 --- a/extra/tools/deploy/shaker/strip-libc.factor +++ b/extra/tools/deploy/shaker/strip-libc.factor @@ -1,10 +1,10 @@ USING: libc.private ; IN: libc -: malloc (malloc) check-ptr ; +: malloc ( size -- newalien ) (malloc) check-ptr ; -: realloc (realloc) check-ptr ; +: realloc ( alien size -- newalien ) (realloc) check-ptr ; -: calloc (calloc) check-ptr ; +: calloc ( size count -- newalien ) (calloc) check-ptr ; -: free (free) ; +: free ( alien -- ) (free) ; diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 86035ae1a4..0319434570 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -3,7 +3,7 @@ USING: kernel combinators vocabs vocabs.loader tools.vocabs io io.files io.styles help.markup help.stylesheet sequences assocs help.topics namespaces prettyprint words sorting definitions -arrays inspector ; +arrays inspector sets ; IN: tools.vocabs.browser : vocab-status-string ( vocab -- string ) @@ -105,7 +105,7 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map - [ [ word? ] filter [ word-vocabulary ] map ] map>set + [ [ word? ] filter [ word-vocabulary ] map ] gather natural-sort remove sift [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index effa17c179..63fcff7f6a 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -291,14 +291,11 @@ MEMO: all-vocabs-seq ( -- seq ) [ vocab-dir? ] with filter ] curry map concat ; -: map>set ( seq quot -- ) - map concat prune natural-sort ; inline - MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] map>set ; + all-vocabs-seq [ vocab-tags ] gather natural-sort ; MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] map>set ; + all-vocabs-seq [ vocab-authors ] gather natural-sort ; : reset-cache ( -- ) root-cache get-global clear-assoc diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index 7ca09b89b4..0840d07cbc 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -23,6 +23,8 @@ HOOK: select-gl-context ui-backend ( handle -- ) HOOK: flush-gl-context ui-backend ( handle -- ) +HOOK: beep ui-backend ( -- ) + : with-gl-context ( handle quot -- ) swap [ select-gl-context call ] keep glFlush flush-gl-context gl-error ; inline diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index d1b7f22b41..0db38e5eca 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -101,6 +101,9 @@ M: cocoa-ui-backend select-gl-context ( handle -- ) M: cocoa-ui-backend flush-gl-context ( handle -- ) handle-view -> openGLContext -> flushBuffer ; +M: cocoa-ui-backend beep ( -- ) + NSBeep ; + SYMBOL: cocoa-init-hook M: cocoa-ui-backend ui diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index f88b207603..ff2b4848ea 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test -namespaces models kernel dlists math sets +namespaces models kernel dlists dequeues math sets math.parser ui sequences hashtables assocs io arrays prettyprint io.streams.string ; @@ -130,26 +130,26 @@ M: mock-gadget ungraft* [ \ graft-queue [ [ ] [ dup queue-graft unqueue-graft ] unit-test - [ t ] [ graft-queue dlist-empty? ] unit-test + [ t ] [ graft-queue dequeue-empty? ] unit-test ] with-variable \ graft-queue [ - [ t ] [ graft-queue dlist-empty? ] unit-test + [ t ] [ graft-queue dequeue-empty? ] unit-test "g" set [ ] [ "g" get queue-graft ] unit-test - [ f ] [ graft-queue dlist-empty? ] unit-test + [ f ] [ graft-queue dequeue-empty? ] unit-test [ { f t } ] [ "g" get gadget-graft-state ] unit-test [ ] [ "g" get graft-later ] unit-test [ { f t } ] [ "g" get gadget-graft-state ] unit-test [ ] [ "g" get ungraft-later ] unit-test [ { f f } ] [ "g" get gadget-graft-state ] unit-test - [ t ] [ graft-queue dlist-empty? ] unit-test + [ t ] [ graft-queue dequeue-empty? ] unit-test [ ] [ "g" get ungraft-later ] unit-test [ ] [ "g" get graft-later ] unit-test [ ] [ notify-queued ] unit-test [ { t t } ] [ "g" get gadget-graft-state ] unit-test - [ t ] [ graft-queue dlist-empty? ] unit-test + [ t ] [ graft-queue dequeue-empty? ] unit-test [ ] [ "g" get graft-later ] unit-test [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test [ ] [ "g" get ungraft-later ] unit-test @@ -185,7 +185,7 @@ M: mock-gadget ungraft* [ { f t } ] [ "1" get gadget-graft-state ] unit-test [ { f t } ] [ "2" get gadget-graft-state ] unit-test [ { f t } ] [ "3" get gadget-graft-state ] unit-test - [ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test + [ ] [ graft-queue [ "x" print notify ] slurp-dequeue ] unit-test [ ] [ notify-queued ] unit-test [ V{ { t t } } ] [ status-flags ] unit-test ] with-variable ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index db750d924d..e4f929ed8e 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables kernel models math namespaces sequences -quotations math.vectors combinators sorting vectors dlists -models threads concurrency.flags math.order ; +USING: accessors arrays hashtables kernel models math namespaces +sequences quotations math.vectors combinators sorting vectors +dlists dequeues models threads concurrency.flags math.order ; IN: ui.gadgets SYMBOL: ui-notify-flag @@ -252,13 +252,12 @@ M: gadget layout* drop ; : graft-queue ( -- dlist ) \ graft-queue get ; : unqueue-graft ( gadget -- ) - graft-queue over gadget-graft-node delete-node - dup gadget-graft-state first { t t } { f f } ? - swap set-gadget-graft-state ; + [ graft-node>> graft-queue delete-node ] + [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ; : (queue-graft) ( gadget flags -- ) - over set-gadget-graft-state - dup graft-queue push-front* swap set-gadget-graft-node + >>graft-state + dup graft-queue push-front* >>graft-node drop notify-ui-thread ; : queue-graft ( gadget -- ) diff --git a/extra/ui/tools/browser/browser.factor b/extra/ui/tools/browser/browser.factor index 50a3b61343..ae39b3e116 100755 --- a/extra/ui/tools/browser/browser.factor +++ b/extra/ui/tools/browser/browser.factor @@ -14,7 +14,7 @@ TUPLE: browser-gadget pane history ; >r >link r> history>> set-model ; : ( browser-gadget -- gadget ) - history>> [ [ dup help ] try drop ] ; + history>> [ [ help ] curry try ] ; : init-history ( browser-gadget -- ) "handbook" >link >>history drop ; diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 7aca45a210..d8ba50ddaf 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces -prettyprint dlists sequences threads sequences words +prettyprint dlists dequeues sequences threads sequences words debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators hashtables concurrency.flags sets ; @@ -15,7 +15,7 @@ SYMBOL: stop-after-last-window? : event-loop? ( -- ? ) { { [ stop-after-last-window? get not ] [ t ] } - { [ graft-queue dlist-empty? not ] [ t ] } + { [ graft-queue dequeue-empty? not ] [ t ] } { [ windows get-global empty? not ] [ t ] } [ f ] } cond ; @@ -126,7 +126,7 @@ SYMBOL: ui-hook in-layout? on layout-queue [ dup layout find-world [ , ] when* - ] dlist-slurp + ] slurp-dequeue ] { } make prune ; : redraw-worlds ( seq -- ) @@ -141,7 +141,7 @@ SYMBOL: ui-hook } case ; : notify-queued ( -- ) - graft-queue [ notify ] dlist-slurp ; + graft-queue [ notify ] slurp-dequeue ; : update-ui ( -- ) [ notify-queued layout-queued redraw-worlds ] assert-depth ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 4a9417fc6b..3fc5d4abcd 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -506,6 +506,9 @@ M: windows-ui-backend ui ] [ cleanup-win32-ui ] [ ] cleanup ] ui-running ; +M: windows-ui-backend beep ( -- ) + 0 MessageBeep drop ; + windows-ui-backend ui-backend set-global [ "ui" ] main-vocab-hook set-global diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 50d383e6b8..2cacc4bca2 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -12,7 +12,7 @@ IN: ui.x11 SINGLETON: x11-ui-backend -: XA_NET_WM_NAME "_NET_WM_NAME" x-atom ; +: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ; TUPLE: x11-handle window glx xic ; @@ -257,6 +257,9 @@ M: x11-ui-backend ui ( -- ) ] with-x ] ui-running ; +M: x11-ui-backend beep ( -- ) + dpy get 100 XBell drop ; + x11-ui-backend ui-backend set-global [ "DISPLAY" system:os-env "ui" "listener" ? ] diff --git a/extra/unicode/unicode.factor b/extra/unicode/unicode.factor deleted file mode 100755 index 0c22bfab8f..0000000000 --- a/extra/unicode/unicode.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: unicode.syntax unicode.data unicode.breaks -unicode.normalize unicode.case unicode.categories -parser kernel namespaces ; -IN: unicode - -! For now: convenience to load all Unicode vocabs - -[ name>char [ "Invalid character" throw ] unless* ] -name>char-hook set-global diff --git a/extra/unix/stat/netbsd/32/32.factor b/extra/unix/stat/netbsd/32/32.factor index d4b39a90d1..55f5108c70 100644 --- a/extra/unix/stat/netbsd/32/32.factor +++ b/extra/unix/stat/netbsd/32/32.factor @@ -25,5 +25,5 @@ C-STRUCT: stat FUNCTION: int __stat30 ( char* pathname, stat* buf ) ; FUNCTION: int __lstat30 ( char* pathname, stat* buf ) ; -: stat __stat30 ; -: lstat __lstat30 ; +: stat ( pathname buf -- n ) __stat30 ; inline +: lstat ( pathname buf -- n ) __lstat30 ; inline diff --git a/extra/unix/stat/netbsd/64/64.factor b/extra/unix/stat/netbsd/64/64.factor index 46ab43eeca..163695b524 100644 --- a/extra/unix/stat/netbsd/64/64.factor +++ b/extra/unix/stat/netbsd/64/64.factor @@ -25,5 +25,5 @@ C-STRUCT: stat FUNCTION: int __stat13 ( char* pathname, stat* buf ) ; FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ; -: stat __stat13 ; inline -: lstat __lstat13 ; inline +: stat ( pathname buf -- n ) __stat13 ; inline +: lstat ( pathname buf -- n ) __lstat13 ; inline diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index abba8874d6..c04fd8f544 100755 --- 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 destructors ; +windows.com.wrapper.private destructors effects ; IN: windows.com.tests COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} @@ -21,6 +21,12 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test "{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test +{ (( -- iid )) } [ \ ISimple-iid stack-effect ] unit-test +{ (( this -- HRESULT )) } [ \ ISimple::returnOK stack-effect ] unit-test +{ (( this -- int )) } [ \ IInherited::getX stack-effect ] unit-test +{ (( this newX -- )) } [ \ IInherited::setX stack-effect ] unit-test +{ (( this mul add -- int )) } [ \ IUnrelated::xMulAdd stack-effect ] unit-test + SYMBOL: +test-wrapper+ SYMBOL: +guinea-pig-implementation+ SYMBOL: +orig-wrapped-objects+ @@ -49,7 +55,11 @@ dup +test-wrapper+ set [ S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test E_FAIL *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test - 20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test + 20 1array [ + +guinea-pig-implementation+ get + [ 20 IInherited::setX ] + [ IInherited::getX ] bi + ] unit-test 420 1array [ +guinea-pig-implementation+ get IUnrelated-iid com-query-interface diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index ac2b5122c0..80a4a040c4 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -1,7 +1,7 @@ -USING: alien alien.c-types kernel windows.ole32 combinators.lib +USING: alien alien.c-types effects kernel windows.ole32 combinators.lib parser splitting grouping sequences.lib sequences namespaces assocs quotations shuffle accessors words macros alien.syntax -fry ; +fry arrays ; IN: windows.com.syntax ; @@ -63,14 +63,24 @@ unless dup parent>> [ family-tree-functions ] [ { } ] if* swap functions>> append ; +: (invocation-quot) ( function return parameters -- quot ) + [ first ] map [ com-invoke ] 3curry ; + +: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect ) + swap + [ [ second ] map ] + [ dup "void" = [ drop { } ] [ 1array ] if ] bi* + ; + : (define-word-for-function) ( function interface n -- ) -rot [ (function-word) swap ] 2keep drop { return>> parameters>> } get-slots - [ com-invoke ] 3curry - define ; + [ (invocation-quot) ] 2keep + (stack-effect-from-return-and-parameters) + define-declared ; : define-words-for-com-interface ( definition -- ) - [ [ (iid-word) ] [ iid>> 1quotation ] bi define ] + [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ] [ name>> "com-interface" swap typedef ] [ dup family-tree-functions diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 78073dbdc8..972a75ecb9 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -29,7 +29,7 @@ unless >r find-com-interface-definition family-tree r> 1quotation [ >r iid>> r> 2array ] curry map ] map-index concat - [ f ] suffix , + [ drop f ] suffix , \ case , "void*" heap-size [ * rot com-add-ref 0 rot set-void*-nth S_OK ] @@ -69,13 +69,14 @@ unless : compile-alien-callback ( return parameters abi quot -- alien ) [ alien-callback ] 4 ncurry - [ gensym [ swap define ] keep ] with-compilation-unit + [ gensym [ swap (( -- alien )) define-declared ] keep ] + with-compilation-unit execute ; : (make-vtbl) ( interface-name quots iunknown-methods n -- ) (thunk) (thunked-quots) swap find-com-interface-definition family-tree-functions [ - { return>> parameters>> } get-slots + [ return>> ] [ parameters>> [ first ] map ] bi dup length 1- roll [ first dup empty? [ 2drop [ ] ] diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor index 3c0ae24a70..6fc586106c 100755 --- a/extra/x11/xlib/xlib.factor +++ b/extra/x11/xlib/xlib.factor @@ -1257,8 +1257,8 @@ FUNCTION: Status XSetStandardProperties ( FUNCTION: void XFree ( void* data ) ; FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ; - FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ; +FUNCTION: int XBell ( Display* display, int percent ) ; ! !!! INPUT METHODS diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor index a921e6a022..7d82842327 100755 --- a/extra/xmode/marker/marker.factor +++ b/extra/xmode/marker/marker.factor @@ -19,7 +19,7 @@ strings regexp splitting parser-combinators ascii unicode.case ; dup [ dupd matches? ] [ drop f ] if ] unless* ] - } && nip ; + } 0&& nip ; : mark-number ( keyword -- id ) keyword-number? DIGIT and ; @@ -50,7 +50,7 @@ M: rule match-position drop position get ; [ over matcher-at-line-start? over zero? implies ] [ over matcher-at-whitespace-end? over whitespace-end get = implies ] [ over matcher-at-word-start? over last-offset get = implies ] - } && 2nip ; + } 0&& 2nip ; : rest-of-line ( -- str ) line get position get tail-slice ; @@ -273,7 +273,7 @@ M: mark-previous-rule handle-rule-start [ check-end-delegate ] [ check-every-rule ] [ check-word-break ] - } || drop + } 0|| drop position inc mark-token-loop diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index c47b8be15c..d163c8f1ac 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -59,4 +59,4 @@ format similar-ok language country site subscription license ; swap >>query ; : search-yahoo ( search -- seq ) - query http-get string>xml parse-yahoo ; + query http-get nip string>xml parse-yahoo ; diff --git a/vm/Config.macosx b/vm/Config.macosx index 40eeb91322..54078cfe8d 100644 --- a/vm/Config.macosx +++ b/vm/Config.macosx @@ -6,7 +6,7 @@ PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o DLL_EXTENSION = .dylib ifdef X11 - LIBS = -lm -framework Foundation $(X11_UI_LIBS) + LIBS = -lm -framework Foundation $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib else LIBS = -lm -framework Cocoa -framework AppKit endif diff --git a/vm/types.c b/vm/types.c index adfdea41a5..adf8b1d4a6 100755 --- a/vm/types.c +++ b/vm/types.c @@ -283,19 +283,6 @@ DEFINE_PRIMITIVE(resize_byte_array) dpush(tag_object(reallot_byte_array(array,capacity))); } -F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count) -{ - if(*result_count == byte_array_capacity(result)) - { - result = reallot_byte_array(result,*result_count * 2); - } - - bput(BREF(result,*result_count),elt); - *result_count++; - - return result; -} - F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count) { CELL new_size = *result_count + len; diff --git a/vm/types.h b/vm/types.h index bbf7fb203d..34301964a1 100755 --- a/vm/types.h +++ b/vm/types.h @@ -212,11 +212,6 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun CELL result##_count = 0; \ CELL result = tag_object(allot_byte_array(100)) -F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count); - -#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \ - result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count)) - F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count); #define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \