-USING: arrays assocs classes classes.algebra classes.mixin
-classes.mixin.private compiler.units continuations definitions eval
-hashtables kernel math parser sequences source-files strings
+USING: accessors arrays assocs classes classes.algebra classes.mixin
+classes.mixin.private classes.union.private compiler.units definitions
+eval hashtables kernel math parser sequences source-files strings
tools.test vectors words ;
IN: classes.mixin.tests
{ t } [ metaclass-change-mixin class-members empty? ] unit-test
+! Don't allow mixins to reference themselves
+[
+ "IN: issue-1652 MIXIN: bmix INSTANCE: bmix bmix" eval( -- )
+] [ error>> cannot-reference-self? ] must-fail-with
+
+[
+ "IN: issue-1652 MIXIN: a MIXIN: b INSTANCE: a b INSTANCE: b a" eval( -- )
+] [ error>> cannot-reference-self? ] must-fail-with
+
! redefine-mixin-class
{ t } [
[
-USING: generic help.markup help.syntax kernel kernel.private
-namespaces sequences words arrays help effects math
-classes.private classes compiler.units ;
+USING: classes classes.builtin classes.union.private compiler.units
+help.markup help.syntax kernel ;
IN: classes.union
ARTICLE: "unions" "Union classes"
ABOUT: "unions"
+HELP: (define-union-class)
+{ $values { "class" class } { "members" "a sequence of classes" } }
+{ $description "Defines a union class." }
+{ $errors "Throws " { $link cannot-reference-self } " if the definition references itself." } ;
+
HELP: define-union-class
{ $values { "class" class } { "members" "a sequence of classes" } }
{ $description "Defines a union class with specified members. This is the run time equivalent of " { $link POSTPONE: UNION: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
-{ $side-effects "class" } ;
+{ $side-effects "class"
+} ;
{ union-class define-union-class POSTPONE: UNION: } related-words
HELP: union-class
{ $class-description "The class of union classes." } ;
+
+HELP: union-of-builtins?
+{ $values { "class" class } { "?" boolean } }
+{ $description { $link t } " if the class either is a " { $link builtin-class } " or only contains builtin classes." } ;
M: union-class update-class define-union-predicate ;
-: (define-union-class) ( class members -- )
- f swap f union-class make-class-props (define-class) ;
-
ERROR: cannot-reference-self class members ;
: check-self-reference ( class members -- class members )
2dup all-contained-classes member-eq? [ cannot-reference-self ] when ;
+: (define-union-class) ( class members -- )
+ check-self-reference f swap f union-class make-class-props (define-class) ;
+
PRIVATE>
: define-union-class ( class members -- )
- [ check-self-reference (define-union-class) ]
+ [ (define-union-class) ]
[ drop changed-conditionally ]
[ drop update-classes ]
2tri ;