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

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
+USING: kernel classes combinators accessors sequences arrays
-sequences arrays vectors assocs namespaces words sorting layouts
+vectors assocs namespaces words sorting layouts math hashtables
-math hashtables kernel.private sets math.order ;
+kernel.private sets math.order ;
 IN: classes.algebra
 
+TUPLE: anonymous-union members ;
+
+C: <anonymous-union> anonymous-union
+
+TUPLE: anonymous-intersection participants ;
+
+C: <anonymous-intersection> anonymous-intersection
+
+TUPLE: anonymous-complement class ;
+
+C: <anonymous-complement> 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 <anonymous-union> ] }
+        { [ dup participants ] [ participants <anonymous-intersection> ] }
+        [ ]
+    } 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> anonymous-union
-
-TUPLE: anonymous-intersection participants ;
-
-C: <anonymous-intersection> anonymous-intersection
-
-TUPLE: anonymous-complement class ;
-
-C: <anonymous-complement> anonymous-complement
-
 : superclass<= ( first second -- ? )
     >r superclass r> class<= ;
 
@@ -63,13 +72,6 @@ C: <anonymous-complement> anonymous-complement
 : anonymous-complement<= ( first second -- ? )
     [ class>> ] bi@ swap class<= ;
 
-: normalize-class ( class -- class' )
-    {
-        { [ dup members ] [ members <anonymous-union> ] }
-        { [ dup participants ] [ participants <anonymous-intersection> ] }
-        [ ]
-    } 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 <anonymous-union> ;
 
@@ -225,26 +202,13 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
         tuck [ class<= ] with all? [ peek ] [ drop f ] if
     ] if ;
 
-DEFER: (flatten-class)
+GENERIC: (flatten-class) ( class -- )
-DEFER: flatten-builtin-class
 
-: flatten-intersection-class ( class -- )
+M: anonymous-union (flatten-class)
-    participants [ flatten-builtin-class ] map
+    members>> [ (flatten-class) ] each ;
-    dup empty? [
-        drop builtins get [ (flatten-class) ] each
-    ] [
-        unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
-    ] if ;
 
-: (flatten-class) ( class -- )
+M: word (flatten-class)
-    {
+    normalize-class (flatten-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 ;
 
 : 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

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
+USING: accessors classes classes.algebra words kernel
-sequences math math.private ;
+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 ;

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

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 )

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

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
+USING: classes classes.algebra kernel namespaces words sequences
-arrays kernel.private assocs combinators ;
+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? ;

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

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
+classes.builtin classes.private slots.deprecated slots.private
-compiler.units math.private accessors assocs effects ;
+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 ;
 

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

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

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

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

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"

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
+USING: accessors parser generic kernel classes classes.tuple
-sequences arrays vectors definitions prettyprint
+words slots assocs sequences arrays vectors definitions
-math hashtables sets macros namespaces ;
+prettyprint math hashtables sets macros namespaces ;
 IN: delegate
 
 : protocol-words ( protocol -- words )

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

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
 
 {