core/classes/union/union.factor

   1 ! Copyright (C) 2004, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs classes classes.algebra
   4 classes.algebra.private classes.builtin classes.private
   5 combinators definitions kernel kernel.private math math.private
   6 quotations sequences sets words ;
   7 IN: classes.union
   8
   9 PREDICATE: union-class < class
  10     "metaclass" word-prop union-class eq? ;
  11
  12 <PRIVATE
  13
  14 GENERIC: union-of-builtins? ( class -- ? )
  15
  16 M: builtin-class union-of-builtins? drop t ;
  17
  18 M: union-class union-of-builtins?
  19     class-members [ union-of-builtins? ] all? ;
  20
  21 M: class union-of-builtins?
  22     drop f ;
  23
  24 : fast-union-mask ( class -- n )
  25     [ 0 ] dip flatten-class
  26     [ drop class>type 2^ bitor ] assoc-each ;
  27
  28 : empty-union-predicate-quot ( class -- quot )
  29     drop [ drop f ] ;
  30
  31 : fast-union-predicate-quot ( class -- quot )
  32     fast-union-mask 1quotation
  33     [ tag 1 swap fixnum-shift-fast ]
  34     [ fixnum-bitand 0 eq? not ]
  35     surround ;
  36
  37 : slow-union-predicate-quot ( class -- quot )
  38     class-members [ predicate-def ] map unclip swap
  39     [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
  40
  41 : union-predicate-quot ( class -- quot )
  42     {
  43         { [ dup class-members empty? ] [ empty-union-predicate-quot ] }
  44         { [ dup union-of-builtins? ] [ fast-union-predicate-quot ] }
  45         [ slow-union-predicate-quot ]
  46     } cond ;
  47
  48 : define-union-predicate ( class -- )
  49     dup union-predicate-quot define-predicate ;
  50
  51 M: union-class update-class define-union-predicate ;
  52
  53 : (define-union-class) ( class members -- )
  54     f swap f union-class make-class-props (define-class) ;
  55
  56 ERROR: cannot-reference-self class members ;
  57
  58 GENERIC: classes-contained-by ( obj -- members )
  59
  60 M: union-class classes-contained-by ( union -- members )
  61     "members" word-prop [ f ] when-empty ;
  62
  63 M: object classes-contained-by
  64     "members" word-prop [ f ] when-empty ;
  65
  66 : check-self-reference ( class members -- class members )
  67     2dup [
  68         dup dup [ classes-contained-by ] map concat sift append
  69         2dup set= [ 2drop f ] [ nip ] if
  70     ] follow concat
  71     member-eq? [ cannot-reference-self ] when ;
  72
  73 PRIVATE>
  74
  75 : define-union-class ( class members -- )
  76     [ check-self-reference (define-union-class) ]
  77     [ drop changed-conditionally ]
  78     [ drop update-classes ]
  79     2tri ;
  80
  81 M: union-class rank-class drop 7 ;
  82
  83 M: union-class instance?
  84     "members" word-prop [ instance? ] with any? ;
  85
  86 M: anonymous-union instance?
  87     members>> [ instance? ] with any? ;
  88
  89 M: anonymous-union class-name
  90     members>> [ class-name ] map " " join ;
  91
  92 M: union-class normalize-class
  93     class-members <anonymous-union> normalize-class ;
  94
  95 M: union-class (flatten-class)
  96     class-members <anonymous-union> (flatten-class) ;