classes: more robust code for detecting circular inheritance, move it out of classes...

diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index be450f74798b28a0aa9254a76099bdddbbdf61b5..d5284133b25f7cb8088adc97487fea92c0812ad9 100644 (file)
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -293,6 +293,9 @@ M: duplicate-slot-names summary
 M: invalid-slot-name summary
     drop "Invalid slot name" ;
 
+M: bad-inheritance summary
+    drop "Circularity in inheritance chain" ;
+
 M: not-in-a-method-error summary
     drop "call-next-method can only be called in a method definition" ;
 

diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 34e65e54db23ad0cdf6fe0ff3870b660d1981968..8bf1648f8ff6164f56b0c119388da63d5b0d5f0f 100644 (file)
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -6,6 +6,8 @@ vectors math quotations combinators sorting effects graphs
 vocabs sets ;
 IN: classes
 
+ERROR: bad-inheritance class superclass ;
+
 SYMBOL: class<=-cache
 SYMBOL: class-not-cache
 SYMBOL: classes-intersect-cache
@@ -169,7 +171,11 @@ GENERIC: update-methods ( class seq -- )
     dup class-usages
     [ nip [ update-class ] each ] [ update-methods ] 2bi ;
 
+: check-inheritance ( subclass superclass -- )
+    2dup superclasses member-eq? [ bad-inheritance ] [ 2drop ] if ;
+
 : define-class ( word superclass members participants metaclass -- )
+    [ 2dup check-inheritance ] 3dip
     make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
 
 : forget-predicate ( class -- )

diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor
index dadfa5991734f4d7ce8e626cfc5f3811a4f0b4a5..a37b674b3b9b01ed32142b1d8dd617ec4081ce6c 100644 (file)
--- a/core/classes/predicate/predicate-tests.factor
+++ b/core/classes/predicate/predicate-tests.factor
@@ -1,5 +1,5 @@
 USING: math tools.test classes.algebra words kernel sequences assocs
-accessors eval definitions compiler.units generic ;
+accessors eval definitions compiler.units generic strings classes ;
 IN: classes.predicate.tests
 
 PREDICATE: negative < integer 0 < ;
@@ -42,3 +42,20 @@ M: tuple-d ptest' drop tuple-d ;
 
 [ tuple-a ] [ tuple-b new ptest' ] unit-test
 [ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test
+
+PREDICATE: bad-inheritance-predicate < string ;
+[
+    "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate < bad-inheritance-predicate ;" eval( -- )
+] [ error>> bad-inheritance? ] must-fail-with
+
+PREDICATE: bad-inheritance-predicate2 < string ;
+PREDICATE: bad-inheritance-predicate3 < bad-inheritance-predicate2 ;
+[
+    "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate2 < bad-inheritance-predicate3 ;" eval( -- )
+] [ error>> bad-inheritance? ] must-fail-with
+
+! This must not fail
+PREDICATE: tup < string ;
+UNION: u tup ;
+
+[ ] [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test

diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index 2b9fd7b89bc7c67b8266eb77f025b9e15b86767f..12a4226b2c57b22cf02f525d6dbc8539a70831c8 100644 (file)
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -153,3 +153,11 @@ TUPLE: bad-inheritance-tuple3 < bad-inheritance-tuple2 ;
 [
     "IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple2 < bad-inheritance-tuple3 ;" eval( -- )
 ] [ error>> bad-inheritance? ] must-fail-with
+
+! This must not fail
+TUPLE: tup ;
+UNION: u tup ;
+
+[ ] [ "IN: classes.tuple.parser.tests TUPLE: u < tup ;" eval( -- ) ] unit-test
+
+[ t ] [ u new tup? ] unit-test

diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
index 626cbd63dfbd2bd05f24e5ca3788942ed999ff9e..812f75a5918e72dd14df16cb6aaba86c9c5774a7 100644 (file)
--- a/core/classes/tuple/parser/parser.factor
+++ b/core/classes/tuple/parser/parser.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sets namespaces make sequences parser
 lexer combinators words classes.parser classes.tuple arrays
-slots math assocs parser.notes classes.algebra ;
+slots math assocs parser.notes classes classes.algebra ;
 IN: classes.tuple.parser
 
 : slot-names ( slots -- seq )
@@ -56,18 +56,11 @@ ERROR: invalid-slot-name name ;
 : parse-tuple-slots ( -- )
     ";" parse-tuple-slots-delim ;
 
-ERROR: bad-inheritance class superclass ;
-
-: check-inheritance ( class1 class2 -- class1 class2 )
-    2dup swap class<= [ bad-inheritance ] when ;
-
 : parse-tuple-definition ( -- class superclass slots )
     CREATE-CLASS
-    scan 2dup = [ ] when {
+    scan {
         { ";" [ tuple f ] }
-        { "<" [
-            scan-word check-inheritance [ parse-tuple-slots ] { } make
-        ] }
+        { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
         [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
     } case
     dup check-duplicate-slots