classes: more robust code for detecting circular inheritance, move it out of classes.tuple since predicate classes need the same check too

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

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

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

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

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 [ parse-tuple-slots ] { } make ] }
-            scan-word check-inheritance [ parse-tuple-slots ] { } make
-        ] }
         [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
     } case
     dup check-duplicate-slots