Add gather word; faster 'implementors' using inverted index

core/bootstrap/image/image.factor

@@ -397,7 +397,7 @@ M: quotation '
     [
         {
             dictionary source-files builtins
-            update-map class<=-cache
+            update-map implementors-map class<=-cache
             class-not-cache classes-intersect-cache class-and-cache
             class-or-cache
         } [ dup get swap bootstrap-word set ] each

core/bootstrap/primitives.factor

@@ -37,6 +37,7 @@ H{ } clone forgotten-definitions set
 H{ } clone root-cache set
 H{ } clone source-files set
 H{ } clone update-map set
+H{ } clone implementors-map set
 init-caches
 
 ! Vocabulary for slot accessors
@@ -492,7 +493,8 @@ tuple
 "curry" "kernel" lookup
 [ f "inline" set-word-prop ]
 [ ]
-[ tuple-layout [ <tuple-boa> ] curry ] tri define
+[ tuple-layout [ <tuple-boa> ] curry ] tri
+(( obj quot -- curry )) define-declared
 
 "compose" "kernel" create
 tuple
@@ -513,7 +515,8 @@ tuple
 "compose" "kernel" lookup
 [ f "inline" set-word-prop ]
 [ ]
-[ tuple-layout [ <tuple-boa> ] curry ] tri define
+[ tuple-layout [ <tuple-boa> ] curry ] tri
+(( quot1 quot2 -- compose )) define-declared
 
 ! Primitive words
 : make-primitive ( word vocab n -- )

core/bootstrap/stage2.factor

@@ -49,7 +49,7 @@ millis >r
 
 default-image-name "output-image" set-global
 
-"math compiler help random tools ui ui.tools io handbook" "include" set-global
+"math compiler help io random tools ui ui.tools unicode handbook" "include" set-global
 "" "exclude" set-global
 
 parse-command-line

core/classes/classes-docs.factor

@@ -68,7 +68,10 @@ HELP: tuple-class
 { $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
 
 HELP: update-map
-{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
+{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
+
+! HELP: implementors-map
+! { $var-description "Assoc mapping each class to a set of generic words defining methods on this class." } ;
 
 HELP: predicate-word
 { $values { "word" "a word" } { "predicate" "a predicate word" } }

core/classes/classes-tests.factor

@@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
 classes.algebra vectors definitions source-files
-compiler.units kernel.private ;
+compiler.units kernel.private sorting vocabs ;
 IN: classes.tests
 
 ! DEFER: bah
@@ -169,3 +169,9 @@ M: method-forget-class method-forget-test ;
 [ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
 [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
 [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
+
+[ t ] [
+    all-words [ class? ] filter
+    implementors-map get keys
+    [ natural-sort ] bi@ =
+] unit-test

core/classes/classes.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions assocs kernel kernel.private
 slots.private namespaces sequences strings words vectors math
-quotations combinators sorting effects graphs vocabs ;
+quotations combinators sorting effects graphs vocabs sets ;
 IN: classes
 
 SYMBOL: class<=-cache
@@ -27,24 +27,24 @@ SYMBOL: class-or-cache
 
 SYMBOL: update-map
 
+SYMBOL: implementors-map
+
 PREDICATE: class < word
     "class" word-prop ;
 
 PREDICATE: tuple-class < class
     "metaclass" word-prop tuple-class eq? ;
 
-: classes ( -- seq ) all-words [ class? ] filter ;
+: classes ( -- seq ) implementors-map get keys ;
 
 : predicate-word ( word -- predicate )
     [ word-name "?" append ] keep word-vocabulary create ;
 
-: predicate-effect T{ effect f 1 { "?" } } ;
-
 PREDICATE: predicate < word "predicating" word-prop >boolean ;
 
 : define-predicate ( class quot -- )
     >r "predicate" word-prop first
-    r> predicate-effect define-declared ;
+    r> (( object -- ? )) define-declared ;
 
 : superclass ( class -- super )
     #! Output f for non-classes to work with algebra code
@@ -67,6 +67,8 @@ GENERIC: reset-class ( class -- )
 
 M: word reset-class drop ;
 
+GENERIC: implementors ( class/classes -- seq )
+
 ! update-map
 : class-uses ( class -- seq )
     [
@@ -87,6 +89,16 @@ M: word reset-class drop ;
 : update-map- ( class -- )
     dup class-uses update-map get remove-vertex ;
 
+M: class implementors implementors-map get at keys ;
+
+M: sequence implementors [ implementors ] gather ;
+
+: implementors-map+ ( class -- )
+    H{ } clone swap implementors-map get set-at ;
+
+: implementors-map- ( class -- )
+    implementors-map get delete-at ;
+
 : make-class-props ( superclass members participants metaclass -- assoc )
     [
         {
@@ -99,7 +111,7 @@ M: word reset-class drop ;
 
 : (define-class) ( word props -- )
     >r
-    dup class? [ dup new-class ] unless
+    dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
     dup reset-class
     dup deferred? [ dup define-symbol ] when
     dup word-props
@@ -139,6 +151,23 @@ GENERIC: update-methods ( class seq -- )
         [ forget ] [ drop ] if
     ] [ 2drop ] if ;
 
+: forget-methods ( class -- )
+    [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
+
+: forget-class ( class -- )
+    class-usages [
+        {
+            [ forget-predicate ]
+            [ forget-methods ]
+            [ implementors-map- ]
+            [ update-map- ]
+            [ reset-class ]
+        } cleave
+    ] each ;
+
+M: class forget* ( class -- )
+    [ forget-class ] [ call-next-method ] bi ;
+
 GENERIC: class ( object -- class )
 
 : instance? ( obj class -- ? )

core/generic/generic.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words kernel sequences namespaces assocs hashtables
 definitions kernel.private classes classes.private
-classes.algebra quotations arrays vocabs effects combinators ;
+classes.algebra quotations arrays vocabs effects combinators
+sets ;
 IN: generic
 
 ! Method combination protocol
@@ -94,8 +95,13 @@ M: method-body crossref?
     method-word-name f <word>
     [ set-word-props ] keep ;
 
+: with-implementors ( class generic quot -- )
+    [ swap implementors-map get at ] dip call ; inline
+
 : reveal-method ( method class generic -- )
-    [ set-at ] with-methods ;
+    [ [ conjoin ] with-implementors ]
+    [ [ set-at ] with-methods ]
+    2bi ;
 
 : create-method ( class generic -- method )
     2dup method dup [
@@ -142,7 +148,11 @@ M: method-body forget*
                     [ "method-generic" word-prop ] bi
                     2dup method
                 ] keep eq?
-                [ [ delete-at ] with-methods ] [ 2drop ] if
+                [
+                    [ [ delete-at ] with-methods ]
+                    [ [ delete-at ] with-implementors ]
+                    2bi
+                ] [ 2drop ] if
             ] if
         ]
         [ call-next-method ] bi
@@ -151,33 +161,6 @@ M: method-body forget*
 M: method-body smart-usage
     "method-generic" word-prop smart-usage ;
 
-GENERIC: implementors ( class/classes -- seq )
-
-M: class implementors
-    all-words [ "methods" word-prop key? ] with filter ;
-
-M: sequence implementors
-    all-words [
-         "methods" word-prop keys
-        swap [ memq? ] curry contains?
-    ] with filter ;
-
-: forget-methods ( class -- )
-    [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
-
-: forget-class ( class -- )
-    class-usages [
-        {
-            [ forget-predicate ]
-            [ forget-methods ]
-            [ update-map- ]
-            [ reset-class ]
-        } cleave
-    ] each ;
-
-M: class forget* ( class -- )
-    [ forget-class ] [ call-next-method ] bi ;
-
 M: sequence update-methods ( class seq -- )
     implementors [
         [ update-generic ] [ make-generic drop ] 2bi
@@ -188,6 +171,7 @@ M: sequence update-methods ( class seq -- )
         2drop
     ] [
         2dup "combination" set-word-prop
+        over "methods" word-prop values forget-all
         over H{ } clone "methods" set-word-prop
         dupd define-default-method
         make-generic

core/inspector/inspector.factor

@@ -95,10 +95,8 @@ SYMBOL: +editable+
 : describe ( obj -- ) H{ } describe* ;
 
 : namestack. ( seq -- )
-    [
+    [ [ global eq? not ] filter [ keys ] gather ] keep
-        [ global eq? not ] filter
+    [ dupd assoc-stack ] curry H{ } map>assoc describe ;
-        [ keys ] map concat prune
-    ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
 
 : .vars ( -- )
     namestack namestack. ;

core/kernel/kernel-docs.factor

@@ -401,7 +401,7 @@ HELP: clone
 { $values { "obj" object } { "cloned" "a new object" } }
 { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
 
-HELP: ? ( ? true false -- true/false )
+HELP: ?
 { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
 { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
 
@@ -409,7 +409,7 @@ HELP: >boolean
 { $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
 { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ;
 
-HELP: not ( obj -- ? )
+HELP: not
 { $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
 { $description "For " { $link f } " outputs " { $link t } " and for anything else outputs " { $link f } "." }
 { $notes "This word implements boolean not, so applying it to integers will not yield useful results (all integers have a true value). Bitwise not is the " { $link bitnot } " word." } ;
@@ -692,26 +692,26 @@ HELP: tri@
     }
 } ;
 
-HELP: if ( cond true false -- )
+HELP: if
-{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } }
+{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
 { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
 $nl
 "The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ;
 
 HELP: when
-{ $values { "cond" "a generalized boolean" } { "true" quotation } }
+{ $values { "?" "a generalized boolean" } { "true" quotation } }
 { $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation."
 $nl
 "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
 
 HELP: unless
-{ $values { "cond" "a generalized boolean" } { "false" quotation } }
+{ $values { "?" "a generalized boolean" } { "false" quotation } }
 { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation."
 $nl
 "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
 
 HELP: if*
-{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
+{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
 { $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
 $nl
 "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
@@ -720,14 +720,14 @@ $nl
 { $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
 
 HELP: when*
-{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
+{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
 { $description "Variant of " { $link if* } " with no false quotation."
 $nl
 "The following two lines are equivalent:"
 { $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ;
 
 HELP: unless*
-{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } }
+{ $values { "?" "a generalized boolean" } { "false" "a quotation " } }
 { $description "Variant of " { $link if* } " with no true quotation." }
 { $notes
 "The following two lines are equivalent:"
@@ -794,7 +794,7 @@ HELP: most
 { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
 { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
 
-HELP: curry ( obj quot -- curry )
+HELP: curry
 { $values { "obj" object } { "quot" callable } { "curry" curry } }
 { $description "Partial application. Outputs a " { $link callable } " which first pushes " { $snippet "obj" } " and then calls " { $snippet "quot" } "." }
 { $class-description "The class of objects created by " { $link curry } ". These objects print identically to quotations and implement the sequence protocol, however they only use two cells of storage; a reference to the object and a reference to the underlying quotation." }
@@ -832,7 +832,7 @@ HELP: with
     { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
 } ;
 
-HELP: compose ( quot1 quot2 -- compose )
+HELP: compose
 { $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
 { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
 { $notes

core/kernel/kernel.factor

@@ -28,20 +28,20 @@ DEFER: if
 : if ( ? true false -- ) ? call ;
 
 ! Single branch
-: unless ( cond false -- )
+: unless ( ? false -- )
     swap [ drop ] [ call ] if ; inline
 
-: when ( cond true -- )
+: when ( ? true -- )
     swap [ call ] [ drop ] if ; inline
 
 ! Anaphoric
-: if* ( cond true false -- )
+: if* ( ? true false -- )
     pick [ drop call ] [ 2nip call ] if ; inline
 
-: when* ( cond true -- )
+: when* ( ? true -- )
     over [ call ] [ 2drop ] if ; inline
 
-: unless* ( cond false -- )
+: unless* ( ? false -- )
     over [ drop ] [ nip call ] if ; inline
 
 ! Default

core/math/floats/floats-docs.factor

@@ -24,7 +24,7 @@ ABOUT: "floats"
 HELP: float
 { $class-description "The class of double-precision floating point numbers." } ;
 
-HELP: >float ( x -- y )
+HELP: >float
 { $values { "x" real } { "y" float } }
 { $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ;
 

core/math/integers/integers-docs.factor

@@ -23,17 +23,21 @@ ABOUT: "integers"
 HELP: fixnum
 { $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ;
 
-HELP: >fixnum ( x -- n )
+HELP: >fixnum
 { $values { "x" real } { "n" fixnum } }
 { $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ;
 
 HELP: bignum
 { $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ;
 
-HELP: >bignum ( x -- n )
+HELP: >bignum
 { $values { "x" real } { "n" bignum } }
 { $description "Converts a real number to a bignum, with a possible loss of precision." } ;
 
+HELP: >integer
+{ $values { "x" real } { "n" bignum } }
+{ $description "Converts a real number to an integer, with a possible loss of precision." } ;
+
 HELP: integer
 { $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ;
 

core/math/math.factor

@@ -3,9 +3,9 @@
 USING: kernel math.private ;
 IN: math
 
-GENERIC: >fixnum ( x -- y ) foldable
+GENERIC: >fixnum ( x -- n ) foldable
-GENERIC: >bignum ( x -- y ) foldable
+GENERIC: >bignum ( x -- n ) foldable
-GENERIC: >integer ( x -- y ) foldable
+GENERIC: >integer ( x -- n ) foldable
 GENERIC: >float ( x -- y ) foldable
 
 MATH: number= ( x y -- ? ) foldable

core/sets/sets.factor

@@ -16,6 +16,9 @@ IN: sets
     [ ] [ length <hashtable> ] [ length <vector> ] tri
     [ [ (prune) ] 2curry each ] keep ;
 
+: gather ( seq quot -- newseq )
+    map concat prune ; inline
+
 : unique ( seq -- assoc )
     [ dup ] H{ } map>assoc ;
 

core/words/words.factor

@@ -148,8 +148,12 @@ M: object redefined drop ;
     2dup "declared-effect" word-prop = [ 2drop ] [
         swap
         [ "declared-effect" set-word-prop ]
-        [ drop [ redefined ] [ +inlined+ changed-definition ] bi ]
+        [
-        2bi
+            drop
+            dup primitive? [ drop ] [
+                [ redefined ] [ +inlined+ changed-definition ] bi
+            ] if
+        ] 2bi
     ] if ;
 
 : define-declared ( word def effect -- )

extra/bootstrap/unicode/unicode.factor

@@ -4,6 +4,7 @@ USE: unicode.breaks
 USE: unicode.case
 USE: unicode.categories
 USE: unicode.collation
+USE: unicode.data
 USE: unicode.normalize
 USE: unicode.script
 

extra/opengl/opengl.factor

@@ -5,7 +5,7 @@
 USING: alien alien.c-types continuations kernel libc math macros
 namespaces math.vectors math.constants math.functions
 math.parser opengl.gl opengl.glu combinators arrays sequences
-splitting words byte-arrays assocs combinators.lib ;
+splitting words byte-arrays assocs ;
 IN: opengl
 
 : coordinates ( point1 point2 -- x1 y2 x2 y2 )

extra/peg/parsers/parsers.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences strings namespaces math assocs shuffle 
-     vectors arrays combinators.lib math.parser 
+     vectors arrays math.parser 
      unicode.categories sequences.deep peg peg.private 
      peg.search math.ranges words memoize ;
 IN: peg.parsers

extra/tools/deploy/shaker/shaker.factor

@@ -150,6 +150,7 @@ IN: tools.deploy.shaker
                 classes:class-or-cache
                 classes:class<=-cache
                 classes:classes-intersect-cache
+                classes:implementors-map
                 classes:update-map
                 command-line:main-vocab-hook
                 compiled-crossref

extra/tools/vocabs/browser/browser.factor

@@ -3,7 +3,7 @@
 USING: kernel combinators vocabs vocabs.loader tools.vocabs io
 io.files io.styles help.markup help.stylesheet sequences assocs
 help.topics namespaces prettyprint words sorting definitions
-arrays inspector ;
+arrays inspector sets ;
 IN: tools.vocabs.browser
 
 : vocab-status-string ( vocab -- string )
@@ -105,7 +105,7 @@ C: <vocab-author> vocab-author
 
 : vocab-xref ( vocab quot -- vocabs )
     >r dup vocab-name swap words r> map
-    [ [ word? ] filter [ word-vocabulary ] map ] map>set
+    [ [ word? ] filter [ word-vocabulary ] map ] gather natural-sort
     remove sift [ vocab ] map ; inline
 
 : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;

extra/tools/vocabs/vocabs.factor

@@ -291,14 +291,11 @@ MEMO: all-vocabs-seq ( -- seq )
         [ vocab-dir? ] with filter
     ] curry map concat ;
 
-: map>set ( seq quot -- )
-    map concat prune natural-sort ; inline
-
 MEMO: all-tags ( -- seq )
-    all-vocabs-seq [ vocab-tags ] map>set ;
+    all-vocabs-seq [ vocab-tags ] gather natural-sort ;
 
 MEMO: all-authors ( -- seq )
-    all-vocabs-seq [ vocab-authors ] map>set ;
+    all-vocabs-seq [ vocab-authors ] gather natural-sort ;
 
 : reset-cache ( -- )
     root-cache get-global clear-assoc