Bug fixes and cleanups

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

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

core/classes/mixin/mixin.factor

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

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 ;
@@ -178,7 +179,10 @@ M: class forget* ( class -- )
     [ call-next-method ] bi ;
 
 M: assoc update-methods ( class assoc -- )
-    implementors [ update-generic ] with each ;
+    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

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

@@ -10,6 +10,8 @@ $nl
 "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 } "." } ;

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/syntax/syntax.factor

@@ -182,8 +182,14 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "(" [
-        ")" parse-effect word
+        ")" parse-effect
-        [ swap "declared-effect" set-word-prop ] [ drop ] if*
+        word dup [
+            swap
+            [ "declared-effect" set-word-prop ]
+            [ drop redefined ]
+            [ drop +inlined+ changed-definition ]
+            2tri
+        ] [ 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
@@ -177,9 +180,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 +220,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/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/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/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/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/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/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/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 ;