From ce91d0cc1d35b8da1d96a494570ccad79ef61e39 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 22 Mar 2013 15:58:20 -0700
Subject: [PATCH] classes: Add a check that arguments to classoids are
 themselves classoids. Introduce a new word-prop that makes tuple-class words
 classoids at parse-time so that self-referential tuple definitions with
 maybe{} work, e.g. TUPLE: node { next maybe{ node } } ; Add unit test. Fixes
 #766.

---
 core/classes/algebra/algebra.factor   | 21 ++++++++++++++++++---
 core/classes/classes.factor           |  4 ++++
 core/classes/maybe/maybe-tests.factor |  6 +++++-
 core/classes/parser/parser.factor     |  1 +
 core/classes/tuple/tuple.factor       | 10 ++++++----
 5 files changed, 34 insertions(+), 8 deletions(-)

diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 7979cf08dc..eb142165a0 100644
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -15,7 +15,19 @@ TUPLE: anonymous-union { members read-only } ;
 
 INSTANCE: anonymous-union classoid
 
-: <anonymous-union> ( members -- class )
+ERROR: not-classoids sequence ;
+
+: check-classoids ( members -- members )
+    dup [ classoid? ] all?
+    [ [ classoid? not ] filter not-classoids ] unless ;
+
+ERROR: not-a-classoid object ;
+
+: check-classoid ( object -- object )
+    dup classoid? [ not-a-classoid ] unless ;
+
+: <anonymous-union> ( members -- classoid )
+    check-classoids
     [ null eq? not ] filter set-members
     dup length 1 = [ first ] [ sort-classes f like anonymous-union boa ] if ;
 
@@ -25,7 +37,8 @@ TUPLE: anonymous-intersection { participants read-only } ;
 
 INSTANCE: anonymous-intersection classoid
 
-: <anonymous-intersection> ( participants -- class )
+: <anonymous-intersection> ( participants -- classoid )
+    check-classoids
     set-members dup length 1 =
     [ first ] [ sort-classes f like anonymous-intersection boa ] if ;
 
@@ -35,7 +48,9 @@ TUPLE: anonymous-complement { class read-only } ;
 
 INSTANCE: anonymous-complement classoid
 
-C: <anonymous-complement> anonymous-complement
+: <anonymous-complement> ( object -- classoid )
+    dup classoid? [ 1array not-classoids ] unless
+    anonymous-complement boa ;
 
 M: anonymous-complement rank-class drop 3 ;
 
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 71a889bd8b..eb5270864f 100644
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -10,8 +10,11 @@ ERROR: bad-inheritance class superclass ;
 
 PREDICATE: class < word "class" word-prop ;
 
+PREDICATE: defining-class < word "defining-class" word-prop ;
+
 MIXIN: classoid
 INSTANCE: class classoid
+INSTANCE: defining-class classoid
 
 <PRIVATE
 
@@ -52,6 +55,7 @@ GENERIC: reset-class ( class -- )
 
 M: class reset-class
     {
+        "defining-class"
         "class"
         "metaclass"
         "superclass"
diff --git a/core/classes/maybe/maybe-tests.factor b/core/classes/maybe/maybe-tests.factor
index b8c7374ccb..f2e2d281c6 100644
--- a/core/classes/maybe/maybe-tests.factor
+++ b/core/classes/maybe/maybe-tests.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2011 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes.maybe eval generic.single kernel tools.test
-math classes accessors slots classes.algebra ;
+math classes accessors slots classes.algebra
+classes.algebra.private ;
 IN: classes.maybe.tests
 
 [ t ] [ 3 maybe{ integer } instance? ] unit-test
@@ -64,3 +65,6 @@ M: f lol2 drop "lol22" ;
 
 [ t ] [ \ + <maybe> classoid? ] unit-test
 [ f ] [ \ + <maybe> valid-classoid? ] unit-test
+
+[ "IN: classes-tests maybe{ 1 2 3 }" eval( -- ) ]
+[ error>> not-classoids? ] must-fail-with
diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor
index fe5265e8bf..dc69b64268 100644
--- a/core/classes/parser/parser.factor
+++ b/core/classes/parser/parser.factor
@@ -8,6 +8,7 @@ IN: classes.parser
 
 : create-class-in ( string -- word )
     current-vocab create
+    dup t "defining-class" set-word-prop
     dup set-word
     dup save-class-location
     dup create-predicate-word save-location ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 895302eaa3..ebd3e407cd 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -238,10 +238,12 @@ M: tuple-class update-class
     } cleave ;
 
 : define-new-tuple-class ( class superclass slots -- )
-    [ drop f f tuple-class define-class ]
-    [ nip "slots" set-word-prop ]
-    [ 2drop update-classes ]
-    3tri ;
+    {
+        [ drop f f tuple-class define-class ]
+        [ nip "slots" set-word-prop ]
+        [ 2drop update-classes ]
+        [ 2drop f "defining-class" set-word-prop ]
+    } 3cleave ;
 
 : subclasses ( class -- classes )
     class-usages [ tuple-class? ] filter ;