diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 0187a6ce52..64b2cdb550 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -397,7 +397,7 @@ M: quotation ' [ { dictionary source-files builtins - update-map class<=-cache + update-map implementors-map class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache } [ dup get swap bootstrap-word set ] each diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6a3c1c35d5..e4e0db8609 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -37,6 +37,7 @@ H{ } clone forgotten-definitions set H{ } clone root-cache set H{ } clone source-files set H{ } clone update-map set +H{ } clone implementors-map set init-caches ! Vocabulary for slot accessors @@ -492,7 +493,8 @@ tuple "curry" "kernel" lookup [ f "inline" set-word-prop ] [ ] -[ tuple-layout [ ] curry ] tri define +[ tuple-layout [ ] curry ] tri +(( obj quot -- curry )) define-declared "compose" "kernel" create tuple @@ -513,7 +515,8 @@ tuple "compose" "kernel" lookup [ f "inline" set-word-prop ] [ ] -[ tuple-layout [ ] curry ] tri define +[ tuple-layout [ ] curry ] tri +(( quot1 quot2 -- compose )) define-declared ! Primitive words : make-primitive ( word vocab n -- ) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f94cc0ed37..5ee263469e 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -49,7 +49,7 @@ millis >r default-image-name "output-image" set-global -"math compiler help random tools ui ui.tools io handbook" "include" set-global +"math compiler help io random tools ui ui.tools unicode handbook" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 9fc4f6c4e7..1325fa65db 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -68,7 +68,10 @@ HELP: tuple-class { $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; HELP: update-map -{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; +{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; + +! HELP: implementors-map +! { $var-description "Assoc mapping each class to a set of generic words defining methods on this class." } ; HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index a03fed7fcb..7eaa6c0e12 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files -compiler.units kernel.private ; +compiler.units kernel.private sorting vocabs ; IN: classes.tests ! DEFER: bah @@ -169,3 +169,9 @@ M: method-forget-class method-forget-test ; [ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test + +[ t ] [ + all-words [ class? ] filter + implementors-map get keys + [ natural-sort ] bi@ = +] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 9c0398cf61..0fef6de748 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions assocs kernel kernel.private slots.private namespaces sequences strings words vectors math -quotations combinators sorting effects graphs vocabs ; +quotations combinators sorting effects graphs vocabs sets ; IN: classes SYMBOL: class<=-cache @@ -27,24 +27,24 @@ SYMBOL: class-or-cache SYMBOL: update-map +SYMBOL: implementors-map + PREDICATE: class < word "class" word-prop ; PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; -: classes ( -- seq ) all-words [ class? ] filter ; +: classes ( -- seq ) implementors-map get keys ; : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; -: predicate-effect T{ effect f 1 { "?" } } ; - PREDICATE: predicate < word "predicating" word-prop >boolean ; : define-predicate ( class quot -- ) >r "predicate" word-prop first - r> predicate-effect define-declared ; + r> (( object -- ? )) define-declared ; : superclass ( class -- super ) #! Output f for non-classes to work with algebra code @@ -67,6 +67,8 @@ GENERIC: reset-class ( class -- ) M: word reset-class drop ; +GENERIC: implementors ( class/classes -- seq ) + ! update-map : class-uses ( class -- seq ) [ @@ -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 -- ? ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 8bcbe090b1..ca6949366a 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: words kernel sequences namespaces assocs hashtables definitions kernel.private classes classes.private -classes.algebra quotations arrays vocabs effects combinators ; +classes.algebra quotations arrays vocabs effects combinators +sets ; IN: generic ! Method combination protocol @@ -94,8 +95,13 @@ M: method-body crossref? method-word-name f [ set-word-props ] keep ; +: with-implementors ( class generic quot -- ) + [ swap implementors-map get at ] dip call ; inline + : reveal-method ( method class generic -- ) - [ set-at ] with-methods ; + [ [ conjoin ] with-implementors ] + [ [ set-at ] with-methods ] + 2bi ; : create-method ( class generic -- method ) 2dup method dup [ @@ -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 diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index 0ab016b0fa..fd4e11901a 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -95,10 +95,8 @@ SYMBOL: +editable+ : describe ( obj -- ) H{ } describe* ; : namestack. ( seq -- ) - [ - [ global eq? not ] filter - [ keys ] map concat prune - ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ; + [ [ global eq? not ] filter [ keys ] gather ] keep + [ dupd assoc-stack ] curry H{ } map>assoc describe ; : .vars ( -- ) namestack namestack. ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 82f0db1364..a04a698965 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -401,7 +401,7 @@ HELP: clone { $values { "obj" object } { "cloned" "a new object" } } { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ; -HELP: ? ( ? true false -- true/false ) +HELP: ? { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; @@ -409,7 +409,7 @@ HELP: >boolean { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ; -HELP: not ( obj -- ? ) +HELP: not { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "For " { $link f } " outputs " { $link t } " and for anything else outputs " { $link f } "." } { $notes "This word implements boolean not, so applying it to integers will not yield useful results (all integers have a true value). Bitwise not is the " { $link bitnot } " word." } ; @@ -692,26 +692,26 @@ HELP: tri@ } } ; -HELP: if ( cond true false -- ) -{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } } +HELP: if +{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ; HELP: when -{ $values { "cond" "a generalized boolean" } { "true" quotation } } +{ $values { "?" "a generalized boolean" } { "true" quotation } } { $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; HELP: unless -{ $values { "cond" "a generalized boolean" } { "false" quotation } } +{ $values { "?" "a generalized boolean" } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation." $nl "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; HELP: if* -{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } } +{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } } { $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true." $nl "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called." @@ -720,14 +720,14 @@ $nl { $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ; HELP: when* -{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } } +{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } } { $description "Variant of " { $link if* } " with no false quotation." $nl "The following two lines are equivalent:" { $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ; HELP: unless* -{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } } +{ $values { "?" "a generalized boolean" } { "false" "a quotation " } } { $description "Variant of " { $link if* } " with no true quotation." } { $notes "The following two lines are equivalent:" @@ -794,7 +794,7 @@ HELP: most { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } } { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ; -HELP: curry ( obj quot -- curry ) +HELP: curry { $values { "obj" object } { "quot" callable } { "curry" curry } } { $description "Partial application. Outputs a " { $link callable } " which first pushes " { $snippet "obj" } " and then calls " { $snippet "quot" } "." } { $class-description "The class of objects created by " { $link curry } ". These objects print identically to quotations and implement the sequence protocol, however they only use two cells of storage; a reference to the object and a reference to the underlying quotation." } @@ -832,7 +832,7 @@ HELP: with { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } } ; -HELP: compose ( quot1 quot2 -- compose ) +HELP: compose { $values { "quot1" callable } { "quot2" callable } { "compose" compose } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." } { $notes diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 61f687c95a..1a7d1de47c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -28,20 +28,20 @@ DEFER: if : if ( ? true false -- ) ? call ; ! Single branch -: unless ( cond false -- ) +: unless ( ? false -- ) swap [ drop ] [ call ] if ; inline -: when ( cond true -- ) +: when ( ? true -- ) swap [ call ] [ drop ] if ; inline ! Anaphoric -: if* ( cond true false -- ) +: if* ( ? true false -- ) pick [ drop call ] [ 2nip call ] if ; inline -: when* ( cond true -- ) +: when* ( ? true -- ) over [ call ] [ 2drop ] if ; inline -: unless* ( cond false -- ) +: unless* ( ? false -- ) over [ drop ] [ nip call ] if ; inline ! Default diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index cd2a3c20c8..a1ba16c68a 100644 --- a/core/math/floats/floats-docs.factor +++ b/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." } ; diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index 056e19e1de..c75040b6bb 100755 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -23,17 +23,21 @@ ABOUT: "integers" HELP: fixnum { $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ; -HELP: >fixnum ( x -- n ) +HELP: >fixnum { $values { "x" real } { "n" fixnum } } { $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ; HELP: bignum { $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ; -HELP: >bignum ( x -- n ) +HELP: >bignum { $values { "x" real } { "n" bignum } } { $description "Converts a real number to a bignum, with a possible loss of precision." } ; +HELP: >integer +{ $values { "x" real } { "n" bignum } } +{ $description "Converts a real number to an integer, with a possible loss of precision." } ; + HELP: integer { $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 0218ded6ff..1dfbf1fc3e 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -3,9 +3,9 @@ USING: kernel math.private ; IN: math -GENERIC: >fixnum ( x -- y ) foldable -GENERIC: >bignum ( x -- y ) foldable -GENERIC: >integer ( x -- y ) foldable +GENERIC: >fixnum ( x -- n ) foldable +GENERIC: >bignum ( x -- n ) foldable +GENERIC: >integer ( x -- n ) foldable GENERIC: >float ( x -- y ) foldable MATH: number= ( x y -- ? ) foldable diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 5fbec9a7c8..d825faf921 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -16,6 +16,9 @@ IN: sets [ ] [ length ] [ length ] tri [ [ (prune) ] 2curry each ] keep ; +: gather ( seq quot -- newseq ) + map concat prune ; inline + : unique ( seq -- assoc ) [ dup ] H{ } map>assoc ; diff --git a/core/words/words.factor b/core/words/words.factor index 806625aa83..d17377fdca 100755 --- a/core/words/words.factor +++ b/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 -- ) diff --git a/extra/bootstrap/unicode/unicode.factor b/extra/bootstrap/unicode/unicode.factor index f8558fe7ad..0476cbf18b 100755 --- a/extra/bootstrap/unicode/unicode.factor +++ b/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 diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 5fed709253..9e91119247 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu combinators arrays sequences -splitting words byte-arrays assocs combinators.lib ; +splitting words byte-arrays assocs ; IN: opengl : coordinates ( point1 point2 -- x1 y2 x2 y2 ) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 784e6c064c..443b9fc61d 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays combinators.lib math.parser + vectors arrays math.parser unicode.categories sequences.deep peg peg.private peg.search math.ranges words memoize ; IN: peg.parsers diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index e8675f5891..db0f478709 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -150,6 +150,7 @@ IN: tools.deploy.shaker classes:class-or-cache classes:class<=-cache classes:classes-intersect-cache + classes:implementors-map classes:update-map command-line:main-vocab-hook compiled-crossref diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 86035ae1a4..0319434570 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -3,7 +3,7 @@ USING: kernel combinators vocabs vocabs.loader tools.vocabs io io.files io.styles help.markup help.stylesheet sequences assocs help.topics namespaces prettyprint words sorting definitions -arrays inspector ; +arrays inspector sets ; IN: tools.vocabs.browser : vocab-status-string ( vocab -- string ) @@ -105,7 +105,7 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map - [ [ word? ] filter [ word-vocabulary ] map ] map>set + [ [ word? ] filter [ word-vocabulary ] map ] gather natural-sort remove sift [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index effa17c179..63fcff7f6a 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -291,14 +291,11 @@ MEMO: all-vocabs-seq ( -- seq ) [ vocab-dir? ] with filter ] curry map concat ; -: map>set ( seq quot -- ) - map concat prune natural-sort ; inline - MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] map>set ; + all-vocabs-seq [ vocab-tags ] gather natural-sort ; MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] map>set ; + all-vocabs-seq [ vocab-authors ] gather natural-sort ; : reset-cache ( -- ) root-cache get-global clear-assoc