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 classes.tuple classes.tuple.private combinators definitions
   6 kernel kernel.private math math.private quotations sequences
   7 slots.private sorting splitting words ;
   8 IN: classes.union
   9
  10 PREDICATE: union-class < class
  11     "metaclass" word-prop union-class eq? ;
  12
  13 <PRIVATE
  14
  15 GENERIC: union-of-builtins? ( class -- ? )
  16
  17 M: builtin-class union-of-builtins? drop t ;
  18
  19 M: union-class union-of-builtins?
  20     class-members [ union-of-builtins? ] all? ;
  21
  22 M: class union-of-builtins?
  23     drop f ;
  24
  25 : empty-union-predicate-quot ( class-members -- quot )
  26     drop [ drop f ] ;
  27
  28 : flatten-builtins ( builtin-classes -- seq )
  29     [ flatten-class ] map concat ;
  30
  31 : builtin-union-mask ( builtin-classes -- n )
  32     0 [ class>type 2^ bitor ] reduce ;
  33
  34 : builtin-union-predicate-quot ( builtin-classes -- quot )
  35     flatten-builtins dup length 1 = [
  36         first class>type [ eq? ] curry [ tag ] prepose
  37     ] [
  38         builtin-union-mask 1quotation
  39         [ tag 1 swap fixnum-shift-fast ]
  40         [ fixnum-bitand 0 eq? not ]
  41         surround
  42     ] if ;
  43
  44 : predicate-quot ( predicates -- quot )
  45     unclip swap
  46     [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
  47
  48 ! this replicates logic in classes.tuple, keep in sync
  49 : tuple-union-predicate-quot/1 ( tuple-classes -- quot )
  50     [ [ eq? ] curry ] map predicate-quot
  51     [ 7 slot ] prepose ;
  52
  53 : tuple-union-predicate-quot/n ( echelon tuple-classes -- quot )
  54     [ layout-class-offset ] dip
  55     [ [ eq? ] curry ] map predicate-quot
  56     over [ slot ] curry prepose [ drop f ] [ if ] 2curry
  57     swap [ fixnum>= ] curry [ dup 1 slot ] prepose prepose ;
  58
  59 : tuple-union-predicate-quot ( tuple-classes -- quot )
  60     [ echelon-of 1 = ] partition
  61     [ [ f ] [ tuple-union-predicate-quot/1 ] if-empty ] dip
  62     [ echelon-of ] collect-by sort-keys
  63     [ tuple-union-predicate-quot/n ] { } assoc>map
  64     swap [ suffix ] when* predicate-quot
  65     [ layout-of ] prepose [ drop f ] [ if ] 2curry
  66     [ dup tuple? ] prepose ;
  67
  68 : full-union-predicate-quot ( class-members -- quot )
  69     [ union-of-builtins? ] partition
  70     [ [ f ] [ builtin-union-predicate-quot ] if-empty ] dip
  71     [ [ tuple-class? ] [ tuple-layout ] bi and ] partition
  72     [ [ f ] [ tuple-union-predicate-quot ] if-empty ] dip
  73     [ predicate-def ] map
  74     swap [ suffix ] when*
  75     swap [ suffix ] when*
  76     predicate-quot ;
  77
  78 : union-predicate-quot ( class-members -- quot )
  79     {
  80         { [ dup empty? ] [ empty-union-predicate-quot ] }
  81         { [ dup [ union-of-builtins? ] all? ] [ builtin-union-predicate-quot ] }
  82         [ full-union-predicate-quot ]
  83     } cond ;
  84
  85 : define-union-predicate ( class -- )
  86     dup class-members union-predicate-quot define-predicate ;
  87
  88 M: union-class update-class define-union-predicate ;
  89
  90 ERROR: cannot-reference-self class members ;
  91
  92 : check-self-reference ( class members -- class members )
  93     2dup all-contained-classes member-eq? [ cannot-reference-self ] when ;
  94
  95 : (define-union-class) ( class members -- )
  96     check-self-reference f swap f union-class make-class-props (define-class) ;
  97
  98 PRIVATE>
  99
 100 : define-union-class ( class members -- )
 101     [ (define-union-class) ]
 102     [ drop changed-conditionally ]
 103     [ drop update-classes ]
 104     2tri ;
 105
 106 M: union-class rank-class drop 7 ;
 107
 108 M: union-class instance?
 109     "members" word-prop [ instance? ] with any? ;
 110
 111 M: anonymous-union predicate-def
 112     members>> union-predicate-quot ;
 113
 114 M: anonymous-union instance?
 115     members>> [ instance? ] with any? ;
 116
 117 M: anonymous-union class-name
 118     members>> [ class-name ] map join-words ;
 119
 120 M: union-class normalize-class
 121     class-members <anonymous-union> normalize-class ;
 122
 123 M: union-class (flatten-class)
 124     class-members <anonymous-union> (flatten-class) ;