Merge branch 'master' of git://factorcode.org/git/factor

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." ;

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" } "." }

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? ;
 

core/classes/classes.factor

@@ -76,8 +76,8 @@ M: word reset-class drop ;
         tri
     ] { } make ;
 
-: class-usages ( class -- assoc )
+: class-usages ( class -- seq )
-    [ update-map get at ] closure ;
+    [ update-map get at ] closure keys ;
 
 <PRIVATE
 
@@ -99,8 +99,8 @@ M: word reset-class drop ;
 
 : (define-class) ( word props -- )
     >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 ]
+    [ nip [ update-class ] each ] [ update-methods ] 2bi ;
-    [ update-methods ]
-    2bi ;
 
 : define-class ( word superclass members participants metaclass -- )
     #! If it was already a class, update methods after.

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
+        [ [ suffix ] change-mixin-class ] 2keep
-        dup new-class? [ update-classes/new ] [ update-classes ] if
+        tuck [ new-class? ] either? [
+            update-classes/new
+        ] [
+            update-classes
+        ] if
     ] if-mixin-member? ;
 
 : remove-mixin-instance ( class mixin -- )

core/classes/tuple/tuple-tests.factor

@@ -109,6 +109,7 @@ TUPLE: yo-momma ;
 [
     [ t ] [ \ yo-momma class? ] unit-test
     [ ] [ \ yo-momma forget ] unit-test
+    [ ] [ \ <yo-momma> 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 ;" <string-reader> "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 ;" <string-reader> "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

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

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 -- )
+SYMBOL: +failed+
-    compiled-usage [ drop queue-compile ] assoc-each ;
+
+: 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 -- )
-    [
+    [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
-        over "compiled-effect" word-prop = [
+    [ "compiled-effect" set-word-prop ]
-            dup "compiled-uses" word-prop
+    2bi ;
-            [ dup ripple-up ] when
-        ] unless drop
-    ]
-    [ "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 ]
+        [ +failed+ save-effect ]
-        bi
+        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 -- )
+: compile-loop ( dequeue -- )
-    dup assoc-empty? [ drop ] [
+    [ (compile) yield ] slurp-dequeue ;
-        dup delete-any drop (compile)
-        yield
-        compile-loop
-    ] if ;
 
 : decompile ( word -- )
     f 2array 1array t modify-code-heap ;
 
 : optimized-recompile-hook ( words -- alist )
     [
-        H{ } clone compile-queue set
+        <hashed-dlist> compile-queue set
         H{ } clone compiled set
         [ queue-compile ] each
         compile-queue get compile-loop

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

core/compiler/tests/redefine.factor

@@ -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

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

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

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

core/compiler/tests/reload.factor

@@ -0,0 +1,6 @@
+IN: compiler.tests
+USE: vocabs.loader
+
+"parser" reload
+"sequences" reload
+"kernel" reload

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 -- )

core/cpu/x86/32/bootstrap.factor

@@ -6,13 +6,13 @@ IN: bootstrap.x86
 
 4 \ cell set
 
-: arg0 EAX ;
+: arg0 ( -- reg ) EAX ;
-: arg1 EDX ;
+: arg1 ( -- reg ) EDX ;
-: temp-reg EBX ;
+: temp-reg ( -- reg ) EBX ;
-: stack-reg ESP ;
+: stack-reg ( -- reg ) ESP ;
-: ds-reg ESI ;
+: ds-reg ( -- reg ) ESI ;
-: fixnum>slot@ arg0 1 SAR ;
+: fixnum>slot@ ( -- ) arg0 1 SAR ;
-: rex-length 0 ;
+: rex-length ( -- n ) 0 ;
 
 << "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >>
 call

core/cpu/x86/64/bootstrap.factor

@@ -6,13 +6,13 @@ IN: bootstrap.x86
 
 8 \ cell set
 
-: arg0 RDI ;
+: arg0 ( -- reg ) RDI ;
-: arg1 RSI ;
+: arg1 ( -- reg ) RSI ;
-: temp-reg RBX ;
+: temp-reg ( -- reg ) RBX ;
-: stack-reg RSP ;
+: stack-reg ( -- reg ) RSP ;
-: ds-reg R14 ;
+: ds-reg ( -- reg ) R14 ;
-: fixnum>slot@ ;
+: fixnum>slot@ ( -- ) ;
-: rex-length 1 ;
+: rex-length ( -- n ) 1 ;
 
 << "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >>
 call

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

core/dequeues/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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)." } ;

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

core/dequeues/summary.txt

@@ -0,0 +1 @@
+Double-ended queue protocol and common operations

core/dequeues/tags.txt

@@ -0,0 +1 @@
+collections

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"
+ARTICLE: "dlists" "Double-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."
+"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."
+"Double-linked lists form a class:"
-$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:"
 { $subsection dlist }
 { $subsection dlist? }
-"Constructing a dlist:"
+"Constructing a double-linked list:"
 { $subsection <dlist> }
-"Working with the front of the list:"
+"Double-linked lists support all the operations of the dequeue protocol (" { $link "dequeues" } ") as well as the following."
-{ $subsection push-front }
+$nl
-{ $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 }
 "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 }
+{ $subsection delete-node-if } ;
-"Consuming all nodes:"
-{ $subsection dlist-slurp } ;
 
 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." }

core/dlists/dlists-tests.factor

@@ -1,17 +1,17 @@
-USING: dlists dlists.private kernel tools.test random assocs
+USING: dequeues dlists dlists.private kernel tools.test random
-sets sequences namespaces sorting debugger io prettyprint
+assocs sets sequences namespaces sorting debugger io prettyprint
 math accessors classes ;
 IN: dlists.tests
 
-[ t ] [ <dlist> dlist-empty? ] unit-test
+[ t ] [ <dlist> dequeue-empty? ] unit-test
 
 [ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ]
 [ <dlist> 1 over push-front ] unit-test
 
 ! Make sure empty lists are empty
-[ t ] [ <dlist> dlist-empty? ] unit-test
+[ t ] [ <dlist> dequeue-empty? ] unit-test
-[ f ] [ <dlist> 1 over push-front dlist-empty? ] unit-test
+[ f ] [ <dlist> 1 over push-front dequeue-empty? ] unit-test
-[ f ] [ <dlist> 1 over push-back dlist-empty? ] unit-test
+[ f ] [ <dlist> 1 over push-back dequeue-empty? ] unit-test
 
 [ 1 ] [ <dlist> 1 over push-front pop-front ] unit-test
 [ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test
@@ -25,22 +25,22 @@ IN: dlists.tests
 ! Test the prev,next links for two nodes
 [ f ] [
     <dlist> 1 over push-back 2 over push-back
-    dlist-front dlist-node-prev
+    front>> prev>>
 ] unit-test
 
 [ 2 ] [
     <dlist> 1 over push-back 2 over push-back
-    dlist-front dlist-node-next dlist-node-obj
+    front>> next>> obj>>
 ] unit-test
 
 [ 1 ] [
     <dlist> 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 ] [
     <dlist> 1 over push-back 2 over push-back
-    dlist-front dlist-node-next dlist-node-next
+    front>> next>> next>>
 ] unit-test
 
 [ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
@@ -50,55 +50,24 @@ IN: dlists.tests
 [ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
 
 [ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
-[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-empty? ] unit-test
-[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dequeue-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dequeue-length ] unit-test
 
-[ 0 ] [ <dlist> dlist-length ] unit-test
+[ 0 ] [ <dlist> dequeue-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-front dequeue-length ] unit-test
-[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
+[ 0 ] [ <dlist> 1 over push-front dup pop-front* dequeue-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 [
-        <dlist>
-        [ push-all-front ]
-        [ dlist-delete-all ]
-        [ dlist>array ] tri
-    ] 2keep swap diff assert-same-elements
-] unit-test
-
-[ ] [
-    <dlist> "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
 
 [ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
 [ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
 [ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
 [ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
 
-[ <dlist> peek-front ] must-fail
+[ <dlist> peek-front ] [ empty-dlist? ] must-fail-with
-[ <dlist> peek-back ] must-fail
+[ <dlist> peek-back ] [ empty-dlist? ] must-fail-with
 [ <dlist> pop-front ] [ empty-dlist? ] must-fail-with
 [ <dlist> pop-back ] [ empty-dlist? ] must-fail-with

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 ;
 
 : <dlist> ( -- obj )
     dlist new
-    0 >>length ;
+        0 >>length ;
 
-: dlist-empty? ( dlist -- ? ) front>> not ;
+M: dlist dequeue-length length>> ;
 
 <PRIVATE
 
@@ -18,6 +19,8 @@ TUPLE: dlist-node obj prev next ;
 
 C: <dlist-node> dlist-node
 
+M: dlist-node node-value obj>> ;
+
 : inc-length ( dlist -- )
     [ 1+ ] change-length drop ; inline
 
@@ -57,69 +60,59 @@ C: <dlist-node> 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 <dlist-node> dup dup set-next-prev ] keep
     [ (>>front) ] keep
     [ set-back-to-front ] keep
     inc-length ;
 
-: push-front ( obj dlist -- )
+M: dlist push-back* ( obj dlist -- dlist-node )
-    push-front* drop ;
-
-: push-all-front ( seq dlist -- )
-    [ push-front ] curry each ;
-
-: push-back* ( obj dlist -- dlist-node )
     [ back>> f <dlist-node> ] 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 )
+M: dlist peek-front ( dlist -- obj )
-    front>> [ empty-dlist ] unless* obj>> ;
+    front>> [ obj>> ] [ empty-dlist ] if* ;
 
-: pop-front ( dlist -- obj )
+M: dlist pop-front* ( dlist -- )
-    dup front>> [ empty-dlist ] unless*
+    dup front>> [ empty-dlist ] unless
     [
+        dup front>>
         dup next>>
         f rot (>>next)
         f over set-prev-when
         swap (>>front)
-    ] 2keep obj>>
+    ] keep
-    swap [ normalize-back ] keep dec-length ;
+    [ normalize-back ] keep
+    dec-length ;
 
-: pop-front* ( dlist -- )
+M: dlist peek-back ( dlist -- obj )
-    pop-front drop ;
+    back>> [ obj>> ] [ empty-dlist ] if* ;
 
-: peek-back ( dlist -- obj )
+M: dlist pop-back* ( dlist -- )
-    back>> [ empty-dlist ] unless* obj>> ;
+    dup back>> [ empty-dlist ] unless
-
-: pop-back ( dlist -- obj )
-    dup back>> [ empty-dlist ] unless*
     [
+        dup back>>
         dup prev>>
         f rot (>>prev)
         f over set-next-when
         swap (>>back)
-    ] 2keep obj>>
+    ] keep
-    swap [ normalize-front ] keep dec-length ;
+    [ normalize-front ] keep
-
+    dec-length ;
-: pop-back* ( dlist -- )
-    pop-back drop ;
 
 : 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 -- )
+M: dlist dequeue-member? ( value dlist -- ? )
-    dup prev>> over next>> set-prev-when
+    [ = ] curry dlist-contains? ;
-    dup next>> swap prev>> set-next-when ;
 
-: delete-node ( dlist dlist-node -- )
+M: dlist delete-node ( dlist-node dlist -- )
     {
-        { [ over front>> over eq? ] [ drop pop-front* ] }
+        { [ 2dup front>> eq? ] [ nip pop-front* ] }
-        { [ over back>> over eq? ] [ drop pop-back* ] }
+        { [ 2dup back>> eq? ] [ nip pop-back* ] }
-        [ unlink-node dec-length ]
+        [ 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
+    [ obj>> ] prepose delete-node-if* drop ; inline
-    delete-node-if* drop ; inline
 
-: dlist-delete ( obj dlist -- obj/f )
+M: dlist clear-dequeue ( dlist -- )
-    swap [ eq? ] curry delete-node-if ;
-
-: dlist-delete-all ( 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 ) <dlist> [ push-front ] keep ;
+
+INSTANCE: dlist dequeue

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" }

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 "cannot-infer" word-prop [ cannot-infer-effect ] when
-        dup specialized-def over dup 2array 1array infer-quot
+            dup "no-compile" word-prop [ cannot-infer-effect ] when
-        finish-word
+            dup specialized-def over dup 2array 1array infer-quot
+            finish-word
+        ] maybe-cannot-infer
     ] with-infer ;
 
 : intrinsics ( #call -- quot )

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 ]
+    affected-methods [ +called+ changed-definition ] each ;
-    [ make-generic ]
-    bi ;
 
 : with-methods ( class generic quot -- )
+    [ drop update-generic ]
     [ [ "methods" word-prop ] dip call ]
-    [ drop update-generic ] 3bi ;
+    [ drop make-generic drop ]
-    inline
+    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 ;
 
 : <default-method> ( generic combination -- method )
-    object bootstrap-word pick <method>
+    [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
-    [ -rot make-default-method define ] keep ;
+    [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
 
 : define-default-method ( generic combination -- )
     dupd <default-method> "default-method" set-word-prop ;
@@ -137,13 +136,15 @@ M: method-body definer
 M: method-body forget*
     dup "forgotten" word-prop [ drop ] [
         [
-            [ ]
+            dup "default" word-prop [ call-next-method ] [
-            [ "method-class" word-prop ]
+                dup
-            [ "method-generic" word-prop ] tri
+                [ "method-class" word-prop ]
-            3dup method eq? [
+                [ "method-generic" word-prop ] bi
-                [ delete-at ] with-methods
+                3dup method eq? [
-                call-next-method
+                    [ delete-at ] with-methods
-            ] [ 3drop ] if
+                    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 -- )
+: forget-class ( class -- )
-    [
+    class-usages [
-        class-usages [
+        {
-            drop
+            [ "predicate" word-prop [ forget ] each ]
             [ forget-methods ]
             [ update-map- ]
             [ reset-class ]
-            tri
+        } cleave
-        ] assoc-each
+    ] each ;
-    ]
-    [ call-next-method ] bi ;
 
-M: assoc update-methods ( class assoc -- )
+M: class forget* ( class -- )
-    implementors [ update-generic ] with each ;
+    [ 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 = [

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 ;
 

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

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

core/inference/inference-tests.factor

@@ -546,26 +546,26 @@ ERROR: custom-error ;
 
 [ [ erg's-inference-bug ] infer ] must-fail
 
-! : inference-invalidation-a ( -- );
+: inference-invalidation-a ( -- ) ;
-! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
+: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
-! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ;
+: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
-! 
+
-! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
-! 
+
-! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
+{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
-! 
+
-! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
+[ ] [ "IN: inference.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
-! 
+
-! [ 3 ] [ inference-invalidation-c ] unit-test
+[ 3 ] [ inference-invalidation-c ] unit-test
-! 
+
-! { 0 1 } [ inference-invalidation-c ] must-infer-as
+{ 0 1 } [ inference-invalidation-c ] must-infer-as
-! 
+
-! GENERIC: inference-invalidation-d ( obj -- )
+GENERIC: inference-invalidation-d ( obj -- )
-! 
+
-! M: object inference-invalidation-d inference-invalidation-c 2drop ;
+M: object inference-invalidation-d inference-invalidation-c 2drop ;
-! 
+
-! \ inference-invalidation-d must-infer
+\ inference-invalidation-d must-infer
-! 
+
-! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
+[ ] [ "IN: inference.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
-! 
+
-! [ [ inference-invalidation-d ] infer ] must-fail
+[ [ inference-invalidation-d ] infer ] must-fail

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

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
 
 <PRIVATE
@@ -38,7 +38,7 @@ ERROR: realloc-error ptr size ;
 [ H{ } clone mallocs set-global ] "libc" add-init-hook
 
 : add-malloc ( alien -- )
-    dup mallocs get-global set-at ;
+    mallocs get-global conjoin ;
 
 : delete-malloc ( alien -- )
     [

core/math/order/order-docs.factor

@@ -3,9 +3,9 @@ math.private words ;
 IN: math.order
 
 HELP: <=>
-{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } }
+{ $values { "obj1" object } { "obj2" object } { "<=>" "an ordering specifier" } }
 { $contract
-    "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
+    "Compares two objects using an intrinsic linear order, for example, the natural order for real numbers and lexicographic order for strings."
     $nl
     "The output value is one of the following:"
     { $list
@@ -16,23 +16,23 @@ HELP: <=>
 } ;
 
 HELP: +lt+
-{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ;
+{ $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ;
 
 HELP: +eq+
-{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ;
+{ $description "Output by " { $link <=> } " when the first object is equal to the second object." } ;
 
 HELP: +gt+
-{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
+{ $description "Output by " { $link <=> } " when the first object is strictly greater than the second object." } ;
 
 HELP: invert-comparison
-{ $values { "symbol" symbol }
+{ $values { "<=>" symbol }
-          { "new-symbol" symbol } }
+          { "<=>'" symbol } }
-{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
+{ $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:"
+"The above words output order specifiers."
-{ $subsection +lt+ }
+{ $subsection "order-specifiers" }
-{ $subsection +eq+ }
-{ $subsection +gt+ }
 "Utilities for comparing objects:"
 { $subsection after? }
 { $subsection before? }
 { $subsection after=? }
-{ $subsection before=? } ;
+{ $subsection before=? }
+{ $see-also "sequences-sorting" } ;
 
 ABOUT: "math.order"

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

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

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

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> ( -- 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? ( -- ? )

core/search-dequeues/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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 <search-dequeue> }
+"Default implementation:"
+{ $subsection <hashed-dlist> } ;
+
+ABOUT: "search-dequeues"
+
+HELP: <search-dequeue> ( assoc dequeue -- search-dequeue )
+{ $values { "assoc" assoc } { "dequeue" dequeue } { "search-dequeue" search-dequeue } }
+{ $description "Creates a new " { $link search-dequeue } "." } ;
+
+HELP: <hashed-dlist> ( -- 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." } ;

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 ;
+
+<hashed-dlist> "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
+
+[ ] [
+    <hashed-dlist>
+    [ all-words swap [ push-front ] curry each ]
+    [ [ drop ] slurp-dequeue ]
+    bi
+] unit-test

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
+
+: <hashed-dlist> ( -- search-dequeue )
+    0 <hashtable> <dlist> <search-dequeue> ;
+
+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

core/search-dequeues/summary.txt

@@ -0,0 +1 @@
+Double-ended queues with sub-linear membership testing

core/search-dequeues/tags.txt

@@ -0,0 +1 @@
+collections

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

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:"
+"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" } "."
-{ $list
+$nl
-    { "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 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." } ;

core/syntax/syntax.factor

@@ -182,8 +182,8 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "(" [
-        ")" parse-effect word
+        ")" parse-effect
-        [ swap "declared-effect" set-word-prop ] [ drop ] if*
+        word dup [ set-stack-effect ] [ 2drop ] if
     ] define-syntax
 
     "((" [

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"

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)

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

core/words/words.factor

@@ -80,8 +80,7 @@ GENERIC# (quot-uses) 1 ( obj assoc -- )
 
 M: object (quot-uses) 2drop ;
 
-M: word (quot-uses)
+M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
-    >r dup crossref? [ dup r> set-at ] [ r> 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-uses" set-word-prop ]
-    compiled-crossref get add-vertex* ;
+    [ 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
+    [ subwords forget-all ]
-    dup reset-word
+    [ reset-word ]
-    { "methods" "combination" "default-method" } reset-props ;
+    [ { "methods" "combination" "default-method" } reset-props ]
+    tri ;
 
 : gensym ( -- word )
     "( gensym )" f <word> ;
@@ -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 "forgotten" word-prop [ drop ] [
-        dup delete-xref
+        [ delete-xref ]
-        dup delete-compiled-xref
+        [ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ]
-        dup word-name over word-vocabulary vocab-words delete-at
+        [ t "forgotten" set-word-prop ]
-        dup t "forgotten" set-word-prop
+        tri
-    ] unless drop ;
+    ] if ;
 
 M: word hashcode*
     nip 1 slot { fixnum } declare ;

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 <model> time set-global
 [ time-thread ] "calendar.model" add-init-hook

extra/combinators/lib/lib.factor

@@ -63,8 +63,8 @@ MACRO: napply ( n -- )
 ! short circuiting words
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! : short-circuit ( quots quot default -- quot )
+: short-circuit ( quots quot default -- quot )
-!   1quotation -rot { } map>assoc <reversed> alist>quot ;
+    1quotation -rot { } map>assoc <reversed> alist>quot ;
 
 ! MACRO: && ( quots -- ? )
 !     [ [ not ] append [ f ] ] t short-circuit ;

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
+USING: dequeues threads kernel arrays sequences alarms ;
-alarms ;
 IN: concurrency.conditions
 
-: notify-1 ( dlist -- )
+: notify-1 ( dequeue -- )
-    dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
+    dup dequeue-empty? [ drop ] [ pop-back resume-now ] if ;
 
-: notify-all ( dlist -- )
+: notify-all ( dequeue -- )
-    [ resume-now ] dlist-slurp ;
+    [ 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* [
+    >r [ self swap push-front* ] keep [
-        tuck delete-node
+        [ delete-node ] [ drop node-value ] 2bi
-        dlist-node-obj t swap resume-with
+        t swap resume-with
     ] 2curry r> later ;
 
 : wait ( queue timeout status -- )

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 -- ? )

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
+USING: dlists dequeues threads sequences continuations
-namespaces random math quotations words kernel arrays assocs
+destructors namespaces random math quotations words kernel
-init system concurrency.conditions accessors debugger ;
+arrays assocs init system concurrency.conditions accessors
+debugger ;
 
 TUPLE: mailbox threads data disposed ;
 
@@ -13,7 +14,7 @@ M: mailbox dispose* threads>> notify-all ;
     <dlist> <dlist> f mailbox boa ;
 
 : mailbox-empty? ( mailbox -- bool )
-    data>> dlist-empty? ;
+    data>> dequeue-empty? ;
 
 : mailbox-put ( obj mailbox -- )
     [ data>> push-front ]

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" ] [ 
     [

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 <string-reader> 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
-    <interval-map> ;
+    filter-overlaps <interval-map> ;
 
 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 ;

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" } } }
+    { "alist" { "an association list; see " { $link "alists" } } }
-    { "assoc" "an associative mapping" }
+    { "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 ;

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 ]
+        { [ over "declared-effect" word-prop ] [ 2drop ] }
-        [ dup contains-funky-elements? not ]
+        { [ dup contains-funky-elements? not ] [ 2drop ] }
-        [ over macro? not ]
+        { [ over macro? not ] [ 2drop ] }
         [
-            2dup extract-values >array
+            [ effect-values >array ]
-            >r effect-values >array
+            [ extract-values >array ]
-            r> assert=
+            bi* assert=
-            t
         ]
-    } 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 ;
 

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 ;

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 ;

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 <irc-profile> <irc-client> bot set"
+  "! Connect to the server"
+  "bot get connect-irc"
+  "! Create a channel listener"
+  "\"#mychannel123\" <irc-channel-listener> 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"

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
+: <test-stream> ( lines -- stream )
+  "\n" join <string-reader> <string-writer> <duplex-stream> ;
+
+: make-client ( lines -- irc-client )
+   "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+   swap [ 2nip <test-stream> 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"

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> irc-profile
 
-TUPLE: irc-channel-profile name password ;
-: <irc-channel-profile> ( -- irc-channel-profile ) irc-channel-profile new ;
-
 ! "live" objects
 TUPLE: nick name channels log ;
 C: <nick> nick
 
 TUPLE: irc-client profile nick stream in-messages out-messages join-messages
-       listeners is-running ;
+       listeners is-running connect reconnect-time ;
 : <irc-client> ( profile -- irc-client )
     f V{ } clone V{ } clone <nick>
-    f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
+    f <mailbox> <mailbox> <mailbox> H{ } clone f
+    [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
 
 TUPLE: irc-listener in-messages out-messages ;
-: <irc-listener> ( -- irc-listener )
+TUPLE: irc-server-listener < irc-listener ;
-    <mailbox> <mailbox> irc-listener boa ;
+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 ) <mailbox> <mailbox> irc-listener boa ;
+
+: <irc-server-listener> ( -- irc-server-listener )
+     <mailbox> <mailbox> irc-server-listener boa ;
+
+: <irc-channel-listener> ( name -- irc-channel-listener )
+     <mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
+
+: <irc-nick-listener> ( name -- irc-nick-listener )
+     <mailbox> <mailbox> 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 ;
+
 <PRIVATE
 
 ! ======================================
 ! Shortcuts
 ! ======================================
 
-: irc-client> ( -- irc-client ) current-irc-client get ;
+: irc> ( -- irc-client ) current-irc-client get ;
-: irc-stream> ( -- stream ) irc-client> stream>> ;
+: 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 )
-    <inet> latin1 <client> 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 )
+: irc-mailbox-get ( mailbox quot -- )
-    dup stream-readln [ nip ] [ dispose f ] if* ;
+    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 ( -- )
+DEFER: (connect-irc)
-    irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ;
+
+: (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 [
+    [ (reader-loop) ] [ handle-disconnect ] recover ;
-        parse-irc-line handle-reader-message
-    ] [
-        handle-stream-close
-    ] if* ;
 
 : 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
+: strings>privmsg ( name string -- privmsg )
-GENERIC: add-name ( name obj -- obj )
+    privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
-M: object add-name nip ;
+
-M: privmsg add-name swap >>name ;
+: maybe-annotate-with-name ( name obj -- obj )
-    
+    {
-: listener-loop ( name -- ) ! FIXME: take different values from the stack?
+        { [ dup string? ] [ strings>privmsg ] }
-    dup irc-client> listeners>> at [
+        { [ dup privmsg instance? ] [ swap >>name ] }
-        out-messages>> mailbox-get add-name
+    } cond ;
-        irc-client> out-messages>>
+
-        mailbox-put
+: listener-loop ( name listener -- )
-    ] [ drop ] if* ;
+    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 )
+: set+run-listener ( name irc-listener -- )
-    <irc-listener> swap trailing>>
+    [ '[ , , listener-loop ] "listener" spawn-irc-loop ]
-    dup [ listener-loop ] curry "listener" spawn-irc-loop
+    [ swap irc> listeners>> set-at ]
-    [ irc-client> listeners>> set-at ] curry keep ;
+    2bi ;
 
-: make-join-future ( name -- future )
+GENERIC: (add-listener) ( irc-listener -- )
-    [ [ swap trailing>> = ] curry ! compare name with channel name
+M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
-      irc-client> join-messages>> 60 seconds rot mailbox-get-timeout?
+    [ [ name>> ] [ password>> ] bi /JOIN ]
-      make-registered-listener ]
+    [ [ [ drop irc> join-messages>> ]
-    curry future ;
+        [ 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
+    [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
-    swap >>stream
+        swap >>stream
-    t >>is-running drop ;
+        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 )
+GENERIC: add-listener ( irc-client irc-listener -- )
-    swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ;
+M: irc-listener add-listener ( irc-client irc-listener -- )
-
+    current-irc-client swap '[ , (add-listener) ] with-variable ;
-! shorcut for privmsgs, etc
-: sender>> ( obj -- string )
-    prefix>> parse-name ;

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 ,

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 ] "+" <lisp-symbol> funcall
+      ! [ 2 3 ] "+" <lisp-symbol> funcall
+      "(+ 2 3)" lisp-eval
     ] unit-test
     
     { 8.3 } [
-     [ 10.4 2.1 ] "-" <lisp-symbol> funcall
+     ! [ 10.4 2.1 ] "-" <lisp-symbol> funcall
+     "(- 10.4 2.1)" lisp-eval
     ] unit-test
     
     { 3 } [
       "((lambda (x y) (+ x y)) 1 2)" lisp-eval
     ] unit-test
     
-    { 42 } [
+!     { 42 } [
-      "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
+!       "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
-    ] unit-test
+!     ] 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
     
     { "b" } [
       "(cond (#f \"a\") (#t \"b\"))" lisp-eval
@@ -49,8 +53,28 @@ IN: lisp.test
       "(begin (+ 1 4))" lisp-eval
     ] unit-test
     
-    { 3 } [
+    { { 1 2 3 4 5 } } [
-       "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
+        "(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

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  
 <PRIVATE  
 : localize-body ( assoc body -- assoc newbody )  
-    [ lisp-symbol? ] pick '[ [ name>> , 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 )                   
+: split-lambda ( cons -- body-cons vars-seq )
-    3car -rot nip [ name>> ] lmap>array ; inline
+    cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline
     
 : rest-lambda ( body vars -- quot )
     "&rest" swap [ index ] [ remove ] 2bi
-    localize-lambda <lambda>
+    swapd localize-lambda <lambda>
-    '[ , cut '[ @ , ] , compose ] ;
+    '[ , cut '[ @ , seq>list ] call , call ] ;
     
 : normal-lambda ( body vars -- quot )
-    localize-lambda <lambda> '[ , compose ] ;
+    localize-lambda <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 ;
+    cadr 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 ;
-    
-<PRIVATE    
-: quasiquote-unquote ( cons -- newcons )
-    [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "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 ;
     
 : 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 ;

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

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

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

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 )    
     <reversed> nil [ swap cons ] reduce ;
     

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
 
 <PRIVATE
 
-: one-string? ( obj -- ? )
+PREDICATE: one-string-array < array
-    {
+    [ length 1 = ] [ [ string? ] all? ] bi and ;
-        [ dup array? ]
-        [ dup length 1 = ]
-        [ dup first string? ]
-    } 0&& nip ;
 
 : stack>message ( obj -- inputs>message )
-    dup one-string? [ first ] [
+    dup one-string-array? [ first ] [
-        H{
+        [
-            { string-limit f }
+            string-limit off
-            { line-limit 1 }
+            1 line-limit set
-            { nesting-limit 3 }
+            3 nesting-limit set
-            { margin 0 }
+            0 margin set
-        } clone [ unparse ] bind
+            unparse
+        ] with-scope
     ] if ;
 
 PRIVATE>

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 ;
 

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"

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
+

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 " "" ? ;

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 ;

extra/peg/ebnf/ebnf.factor

@@ -87,7 +87,7 @@ C: <ebnf> ebnf
       [ dup CHAR: ? = ]
       [ dup CHAR: : = ]
       [ dup CHAR: ~ = ]
-    } || not nip    
+    } 0|| not nip    
   ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
 
 : 'terminal' ( -- parser )

extra/project-euler/014/014.factor

@@ -59,7 +59,7 @@ PRIVATE>
 <PRIVATE
 
 : worth-calculating? ( n -- ? )
-    { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } && nip ;
+    { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } 0&& nip ;
 
 PRIVATE>
 

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 ;

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>
 

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>
 

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? [

extra/sequences/deep/tags.txt

@@ -0,0 +1 @@
+collections

extra/sequences/modified/tags.txt

@@ -0,0 +1 @@
+collections

extra/sequences/repeating/tags.txt

@@ -0,0 +1 @@
+collections

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?
-            [ 40 [        test-serialize-cell ] all? ]
+         4 [ 40 *   test-serialize-cell ] all?
-            [  4 [ 40 *   test-serialize-cell ] all? ]
+         4 [ 400 *  test-serialize-cell ] all?
-            [  4 [ 400 *  test-serialize-cell ] all? ]
+         4 [ 4000 * test-serialize-cell ] all?
-            [  4 [ 4000 * test-serialize-cell ] all? ]
+        and and and
-        } &&
     ] all?
 ] unit-test
 

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 ;

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) ;

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*
 [
     <dlist> \ graft-queue [
         [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
-        [ t ] [ graft-queue dlist-empty? ] unit-test
+        [ t ] [ graft-queue dequeue-empty? ] unit-test
     ] with-variable
 
     <dlist> \ graft-queue [
-        [ t ] [ graft-queue dlist-empty? ] unit-test
+        [ t ] [ graft-queue dequeue-empty? ] unit-test
 
         <mock-gadget> "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 ;

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
+USING: accessors arrays hashtables kernel models math namespaces
-quotations math.vectors combinators sorting vectors dlists
+sequences quotations math.vectors combinators sorting vectors
-models threads concurrency.flags math.order ;
+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
+    [ graft-node>> graft-queue delete-node ]
-    dup gadget-graft-state first { t t } { f f } ?
+    [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
-    swap set-gadget-graft-state ;
 
 : (queue-graft) ( gadget flags -- )
-    over set-gadget-graft-state
+    >>graft-state
-    dup graft-queue push-front* swap set-gadget-graft-node
+    dup graft-queue push-front* >>graft-node drop
     notify-ui-thread ;
 
 : queue-graft ( gadget -- )

extra/ui/tools/browser/browser.factor

@@ -14,7 +14,7 @@ TUPLE: browser-gadget pane history ;
     >r >link r> history>> set-model ;
 
 : <help-pane> ( browser-gadget -- gadget )
-    history>> [ [ dup help ] try drop ] <pane-control> ;
+    history>> [ [ help ] curry try ] <pane-control> ;
 
 : init-history ( browser-gadget -- )
     "handbook" >link <history> >>history drop ;

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 ;

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