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