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 ERROR: cannot-reference-self class members ;
  54
  55 : check-self-reference ( class members -- class members )
  56     2dup all-contained-classes member-eq? [ cannot-reference-self ] when ;
  57
  58 : (define-union-class) ( class members -- )
  59     check-self-reference f swap f union-class make-class-props (define-class) ;
  60
  61 PRIVATE>
  62
  63 : define-union-class ( class members -- )
  64     [ (define-union-class) ]
  65     [ drop changed-conditionally ]
  66     [ drop update-classes ]
  67     2tri ;
  68
  69 M: union-class rank-class drop 7 ;
  70
  71 M: union-class instance?
  72     "members" word-prop [ instance? ] with any? ;
  73
  74 M: anonymous-union instance?
  75     members>> [ instance? ] with any? ;
  76
  77 M: anonymous-union class-name
  78     members>> [ class-name ] map " " join ;
  79
  80 M: union-class normalize-class
  81     class-members <anonymous-union> normalize-class ;
  82
  83 M: union-class (flatten-class)
  84     class-members <anonymous-union> (flatten-class) ;