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/classes/classes.factor b/core/classes/classes.factor index 593213c5c6..ba5b43dc80 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -76,8 +76,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 reset-class dup class? [ dup new-class ] unless + dup reset-class dup deferred? [ dup define-symbol ] when dup word-props r> assoc-union over set-word-props @@ -116,13 +116,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. 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..7bc4c2bb54 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -58,18 +58,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 +80,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 ) [ @@ -106,8 +105,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,13 +136,15 @@ 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 [ call-next-method ] [ + dup + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + 3dup method eq? [ + [ delete-at ] with-methods + call-next-method + ] [ 3drop ] if + ] if ] [ t "forgotten" set-word-prop ] bi ] if ; @@ -156,29 +157,32 @@ GENERIC: implementors ( class/classes -- seq ) M: class implementors all-words [ "methods" word-prop key? ] with filter ; -M: assoc implementors +M: sequence implementors all-words [ "methods" word-prop keys - swap [ key? ] curry contains? + swap [ memq? ] curry contains? ] with filter ; : forget-methods ( class -- ) [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; -M: class forget* ( class -- ) - [ - class-usages [ - drop +: forget-class ( class -- ) + class-usages [ + { + [ "predicate" word-prop [ forget ] each ] [ forget-methods ] [ update-map- ] [ reset-class ] - tri - ] assoc-each - ] - [ call-next-method ] bi ; + } cleave + ] each ; -M: assoc update-methods ( class assoc -- ) - implementors [ update-generic ] with each ; +M: class forget* ( class -- ) + [ forget-class ] [ call-next-method ] bi ; + +M: sequence update-methods ( class seq -- ) + implementors [ + [ update-generic ] [ make-generic drop ] 2bi + ] with each ; : define-generic ( word combination -- ) over "combination" word-prop over = [ 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/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/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 -{ $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/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/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..806625aa83 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,14 @@ 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 [ redefined ] [ +inlined+ changed-definition ] bi ] + 2bi + ] if ; + : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop define ; @@ -177,9 +188,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 +228,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/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/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/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/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/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/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/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/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/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/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/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