diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index b7e4bebe15..9dbe72d9cb 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -1,10 +1,22 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes classes.builtin combinators accessors -sequences arrays vectors assocs namespaces words sorting layouts -math hashtables kernel.private sets math.order ; +USING: kernel classes combinators accessors sequences arrays +vectors assocs namespaces words sorting layouts math hashtables +kernel.private sets math.order ; IN: classes.algebra +TUPLE: anonymous-union members ; + +C: anonymous-union + +TUPLE: anonymous-intersection participants ; + +C: anonymous-intersection + +TUPLE: anonymous-complement class ; + +C: anonymous-complement + : 2cache ( key1 key2 assoc quot -- value ) >r >r 2array r> [ first2 ] r> compose cache ; inline @@ -18,10 +30,19 @@ DEFER: (class-not) : class-not ( class -- complement ) class-not-cache get [ (class-not) ] cache ; -DEFER: (classes-intersect?) ( first second -- ? ) +GENERIC: (classes-intersect?) ( first second -- ? ) + +: normalize-class ( class -- class' ) + { + { [ dup members ] [ members ] } + { [ dup participants ] [ participants ] } + [ ] + } cond ; : classes-intersect? ( first second -- ? ) - classes-intersect-cache get [ (classes-intersect?) ] 2cache ; + classes-intersect-cache get [ + normalize-class (classes-intersect?) + ] 2cache ; DEFER: (class-and) @@ -33,18 +54,6 @@ DEFER: (class-or) : class-or ( first second -- class ) class-or-cache get [ (class-or) ] 2cache ; -TUPLE: anonymous-union members ; - -C: anonymous-union - -TUPLE: anonymous-intersection participants ; - -C: anonymous-intersection - -TUPLE: anonymous-complement class ; - -C: anonymous-complement - : superclass<= ( first second -- ? ) >r superclass r> class<= ; @@ -63,13 +72,6 @@ C: anonymous-complement : anonymous-complement<= ( first second -- ? ) [ class>> ] bi@ swap class<= ; -: normalize-class ( class -- class' ) - { - { [ dup members ] [ members ] } - { [ dup participants ] [ participants ] } - [ ] - } cond ; - : normalize-complement ( class -- class' ) class>> normalize-class { { [ dup anonymous-union? ] [ @@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; } cond ] if ; -: anonymous-union-intersect? ( first second -- ? ) +M: anonymous-union (classes-intersect?) members>> [ classes-intersect? ] with contains? ; -: anonymous-intersection-intersect? ( first second -- ? ) +M: anonymous-intersection (classes-intersect?) participants>> [ classes-intersect? ] with all? ; -: anonymous-complement-intersect? ( first second -- ? ) +M: anonymous-complement (classes-intersect?) class>> class<= not ; -: tuple-class-intersect? ( first second -- ? ) - { - { [ over tuple eq? ] [ 2drop t ] } - { [ over builtin-class? ] [ 2drop f ] } - { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] } - [ swap classes-intersect? ] - } cond ; - -: builtin-class-intersect? ( first second -- ? ) - { - { [ 2dup eq? ] [ 2drop t ] } - { [ over builtin-class? ] [ 2drop f ] } - [ swap classes-intersect? ] - } cond ; - -: (classes-intersect?) ( first second -- ? ) - normalize-class { - { [ dup anonymous-union? ] [ anonymous-union-intersect? ] } - { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] } - { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] } - { [ dup tuple-class? ] [ tuple-class-intersect? ] } - { [ dup builtin-class? ] [ builtin-class-intersect? ] } - { [ dup superclass ] [ superclass classes-intersect? ] } - } cond ; - : anonymous-union-and ( first second -- class ) members>> [ class-and ] with map ; @@ -225,26 +202,13 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; tuck [ class<= ] with all? [ peek ] [ drop f ] if ] if ; -DEFER: (flatten-class) -DEFER: flatten-builtin-class +GENERIC: (flatten-class) ( class -- ) -: flatten-intersection-class ( class -- ) - participants [ flatten-builtin-class ] map - dup empty? [ - drop builtins get [ (flatten-class) ] each - ] [ - unclip [ assoc-intersect ] reduce [ swap set ] assoc-each - ] if ; +M: anonymous-union (flatten-class) + members>> [ (flatten-class) ] each ; -: (flatten-class) ( class -- ) - { - { [ dup tuple-class? ] [ dup set ] } - { [ dup builtin-class? ] [ dup set ] } - { [ dup members ] [ members [ (flatten-class) ] each ] } - { [ dup participants ] [ flatten-intersection-class ] } - { [ dup superclass ] [ superclass (flatten-class) ] } - [ drop ] - } cond ; +M: word (flatten-class) + normalize-class (flatten-class) ; : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; @@ -258,7 +222,7 @@ DEFER: flatten-builtin-class flatten-builtin-class keys [ "type" word-prop ] map natural-sort ; -: class-tags ( class -- tag/f ) +: class-tags ( class -- seq ) class-types [ dup num-tags get >= [ drop \ hi-tag tag-number ] when diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index acbbc5e841..f349d0a126 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes words kernel kernel.private namespaces -sequences math math.private ; +USING: accessors classes classes.algebra words kernel +kernel.private namespaces sequences math math.private +combinators assocs ; IN: classes.builtin SYMBOL: builtins @@ -31,3 +32,24 @@ M: builtin-class rank-class drop 0 ; M: builtin-class instance? class>type builtin-instance? ; + +M: builtin-class (flatten-class) dup set ; + +M: builtin-class (classes-intersect?) + { + { [ 2dup eq? ] [ 2drop t ] } + { [ over builtin-class? ] [ 2drop f ] } + [ swap classes-intersect? ] + } cond ; + +M: anonymous-intersection (flatten-class) + participants>> + participants [ flatten-builtin-class ] map + dup empty? [ + drop builtins get sift [ (flatten-class) ] each + ] [ + unclip [ assoc-intersect ] reduce [ swap set ] assoc-each + ] if ; + +M: anonymous-complement (flatten-class) + drop builtins get sift [ (flatten-class) ] each ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 5f02212bad..fcad00bb18 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -65,10 +65,6 @@ HELP: classes { $values { "seq" "a sequence of class words" } } { $description "Finds all class words in the dictionary." } ; -HELP: tuple-class -{ $class-description "The class of tuple class words." } -{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; - HELP: update-map { $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." } ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 56c3b0a0ab..34f2fcf196 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -32,9 +32,6 @@ SYMBOL: implementors-map PREDICATE: class < word "class" word-prop ; -PREDICATE: tuple-class < class - "metaclass" word-prop tuple-class eq? ; - : classes ( -- seq ) implementors-map get keys ; : predicate-word ( word -- predicate ) diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 0eae1b62d3..5df580d82f 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -namespaces arrays math quotations ; +classes.algebra classes.builtin namespaces arrays math quotations ; IN: classes.intersection PREDICATE: intersection-class < class diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 3067b7d9dd..e6d6b5a0d4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes kernel namespaces words sequences quotations -arrays kernel.private assocs combinators ; +USING: classes classes.algebra kernel namespaces words sequences +quotations arrays kernel.private assocs combinators ; IN: classes.predicate PREDICATE: predicate-class < class @@ -51,3 +51,9 @@ M: predicate-class rank-class drop 1 ; M: predicate-class instance? 2dup superclass instance? [ predicate-instance? ] [ 2drop f ] if ; + +M: predicate-class (flatten-class) + superclass (flatten-class) ; + +M: predicate-class (classes-intersect?) + superclass classes-intersect? ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 8c2525731e..fd8b450eed 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -332,6 +332,10 @@ $nl ABOUT: "tuples" +HELP: tuple-class +{ $class-description "The class of tuple class words." } +{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; + HELP: tuple= { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index b77fa3ecbd..66a75387f1 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -3,10 +3,13 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic classes classes.algebra -classes.private slots.deprecated slots.private slots -compiler.units math.private accessors assocs effects ; +classes.builtin classes.private slots.deprecated slots.private +slots compiler.units math.private accessors assocs effects ; IN: classes.tuple +PREDICATE: tuple-class < class + "metaclass" word-prop tuple-class eq? ; + M: tuple class 1 slot 2 slot { word } declare ; ERROR: not-a-tuple object ; @@ -290,6 +293,16 @@ M: tuple-class rank-class drop 0 ; M: tuple-class instance? dup tuple-layout echelon>> tuple-instance? ; +M: tuple-class (flatten-class) dup set ; + +M: tuple-class (classes-intersect?) + { + { [ over tuple eq? ] [ 2drop t ] } + { [ over builtin-class? ] [ 2drop f ] } + { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] } + [ swap classes-intersect? ] + } cond ; + M: tuple clone (clone) dup delegate clone over set-delegate ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 6ae4e1bdc3..e3deb25e7a 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -namespaces arrays math quotations ; +classes.algebra namespaces arrays math quotations ; IN: classes.union PREDICATE: union-class < class diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 61e2b82f4f..550bab72f4 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -563,7 +563,7 @@ M: loc lazy-store ] if ; : class-tag ( class -- tag/f ) - class-tags dup length 1 = [ first ] [ drop f ] if ; + dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ; : class-matches? ( actual expected -- ? ) { diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 9cee497d6d..54fc3c8ca3 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ; \ xref-test \ xref-tuple-2 \ xref-test method [ usage unique ] closure key? ] unit-test + +[ t ] [ + { } \ nth effective-method nip \ sequence \ nth method eq? +] unit-test + +[ t ] [ + \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and +] unit-test diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 89c2a2a396..f8b3c00c31 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -105,7 +105,9 @@ ERROR: no-next-method class generic ; ] [ ] make ; : single-effective-method ( obj word -- method ) - [ order [ instance? ] with find-last nip ] keep method ; + [ [ order [ instance? ] with find-last nip ] keep method ] + [ "default-method" word-prop ] + bi or ; TUPLE: standard-combination # ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index b11d656b03..39a501c7f8 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax generic kernel.private parser words kernel quotations namespaces sequences words arrays effects generic.standard classes.builtin slots.private classes strings math assocs byte-arrays alien -math ; +math classes.tuple ; IN: slots ARTICLE: "accessors" "Slot accessors" diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 915ad0c648..6cea58058e 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: accessors parser generic kernel classes words slots assocs -sequences arrays vectors definitions prettyprint -math hashtables sets macros namespaces ; +USING: accessors parser generic kernel classes classes.tuple +words slots assocs sequences arrays vectors definitions +prettyprint math hashtables sets macros namespaces ; IN: delegate : protocol-words ( protocol -- words ) diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor index 2d4a6c3396..7f154a4dbf 100755 --- a/extra/tools/walker/walker-tests.factor +++ b/extra/tools/walker/walker-tests.factor @@ -1,6 +1,7 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test -continuations math.parser threads arrays tools.walker.debug ; +continuations math.parser threads arrays tools.walker.debug +generic.standard ; IN: tools.walker.tests [ { } ] [ @@ -97,6 +98,9 @@ IN: tools.walker.tests [ { 6 } ] [ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test +[ { T{ no-method f + nth } } ] +[ [ [ 0 \ + nth ] [ ] recover ] test-walker ] unit-test + [ { } ] [ [ "a" "b" set "c" "d" set [ ] test-walker ] with-scope ] unit-test diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 07a5759af2..3d7ee035dc 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -83,6 +83,9 @@ M: object add-breakpoint ; : (step-into-continuation) ( -- ) continuation callstack >>call break ; +: (step-into-call-next-method) ( class generic -- ) + next-method-quot (step-into-quot) ; + ! Messages sent to walker thread SYMBOL: step SYMBOL: step-out @@ -132,6 +135,7 @@ SYMBOL: +stopped+ { if [ (step-into-if) ] } { dispatch [ (step-into-dispatch) ] } { continuation [ (step-into-continuation) ] } + { (call-next-method) [ (step-into-call-next-method) ] } } [ "step-into" set-word-prop ] assoc-each {