basis/math/partial-dispatch/partial-dispatch.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel kernel.private math math.private words
   4 sequences parser namespaces make assocs quotations arrays
   5 generic generic.math hashtables effects compiler.units
   6 classes.algebra fry combinators ;
   7 IN: math.partial-dispatch
   8
   9 PREDICATE: math-partial < word
  10     "derived-from" word-prop >boolean ;
  11
  12 GENERIC: integer-op-input-classes ( word -- classes )
  13
  14 M: math-partial integer-op-input-classes
  15     "derived-from" word-prop rest ;
  16
  17 ERROR: bad-integer-op word ;
  18
  19 M: word integer-op-input-classes
  20     dup "input-classes" word-prop
  21     [ ] [ bad-integer-op ] ?if ;
  22
  23 : generic-variant ( op -- generic-op/f )
  24     dup "derived-from" word-prop [ first ] [ ] ?if ;
  25
  26 : no-overflow-variant ( op -- fast-op )
  27     H{
  28         { fixnum+ fixnum+fast }
  29         { fixnum- fixnum-fast }
  30         { fixnum* fixnum*fast }
  31         { fixnum-shift fixnum-shift-fast }
  32         { fixnum/i fixnum/i-fast }
  33         { fixnum/mod fixnum/mod-fast }
  34     } at ;
  35
  36 : modular-variant ( op -- fast-op )
  37     generic-variant dup H{
  38         { + fixnum+fast }
  39         { - fixnum-fast }
  40         { * fixnum*fast }
  41         { shift fixnum-shift-fast }
  42         { bitand fixnum-bitand }
  43         { bitor fixnum-bitor }
  44         { bitxor fixnum-bitxor }
  45         { bitnot fixnum-bitnot }
  46     } at swap or ;
  47
  48 : bignum-fixnum-op-quot ( big-word -- quot )
  49     '[ fixnum>bignum _ execute ] ;
  50
  51 : fixnum-bignum-op-quot ( big-word -- quot )
  52     '[ [ fixnum>bignum ] dip _ execute ] ;
  53
  54 : integer-fixnum-op-quot ( fix-word big-word -- quot )
  55     [
  56         [ over fixnum? ] %
  57         [ '[ _ execute ] , ] [ bignum-fixnum-op-quot , ] bi* \ if ,
  58     ] [ ] make ;
  59
  60 : fixnum-integer-op-quot ( fix-word big-word -- quot )
  61     [
  62         [ dup fixnum? ] %
  63         [ '[ _ execute ] , ] [ fixnum-bignum-op-quot , ] bi* \ if ,
  64     ] [ ] make ;
  65
  66 : integer-bignum-op-quot ( big-word -- quot )
  67     [
  68         [ over fixnum? ] %
  69         [ fixnum-bignum-op-quot , ] [ '[ _ execute ] , ] bi \ if ,
  70     ] [ ] make ;
  71
  72 : integer-integer-op-quot ( fix-word big-word -- quot )
  73     [
  74         [ 2dup both-fixnums? ] %
  75         [ '[ _ execute ] , ]
  76         [
  77             [
  78                 [ dup fixnum? ] %
  79                 [ bignum-fixnum-op-quot , ]
  80                 [ integer-bignum-op-quot , ] bi \ if ,
  81             ] [ ] make ,
  82         ] bi* \ if ,
  83     ] [ ] make ;
  84
  85 : integer-op-word ( triple -- word )
  86     [ name>> ] map "-" join "math.partial-dispatch" create ;
  87
  88 : integer-op-quot ( fix-word big-word triple -- quot )
  89     [ second ] [ third ] bi 2array {
  90         { { fixnum integer } [ fixnum-integer-op-quot ] }
  91         { { integer fixnum } [ integer-fixnum-op-quot ] }
  92         { { integer integer } [ integer-integer-op-quot ] }
  93     } case ;
  94
  95 : define-integer-op-word ( fix-word big-word triple -- )
  96     [
  97         [ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi
  98         ( x y -- z ) define-declared
  99     ] [
 100         2nip
 101         [ integer-op-word ] keep
 102         "derived-from" set-word-prop
 103     ] 3bi ;
 104
 105 : define-integer-op-words ( triples fix-word big-word -- )
 106     '[ [ _ _ ] dip define-integer-op-word ] each ;
 107
 108 : integer-op-triples ( word -- triples )
 109     {
 110         { fixnum integer }
 111         { integer fixnum }
 112         { integer integer }
 113     } swap '[ _ prefix ] map ;
 114
 115 : define-integer-ops ( word fix-word big-word -- )
 116     [
 117         rot
 118         [ fixnum fixnum 3array "derived-from" set-word-prop ]
 119         [ bignum bignum 3array "derived-from" set-word-prop ]
 120         bi-curry bi*
 121     ] [
 122         [ integer-op-triples ] 2dip
 123         [ define-integer-op-words ]
 124         [ 2drop [ dup integer-op-word ] { } map>assoc % ]
 125         3bi
 126     ] 3bi ;
 127
 128 : define-math-ops ( op -- )
 129     { fixnum bignum float }
 130     [ [ dup 3array ] [ swap ?lookup-method ] 2bi ] with { } map>assoc
 131     [ nip ] assoc-filter
 132     [ def>> ] assoc-map
 133     [ nip length 1 = ] assoc-filter
 134     [ first ] assoc-map % ;
 135
 136 SYMBOL: math-ops
 137
 138 SYMBOL: fast-math-ops
 139
 140 : math-op ( word left right -- word' ? )
 141     3array math-ops get at* ;
 142
 143 : math-method* ( word left right -- quot )
 144     3dup math-op
 145     [ [ 3drop ] dip 1quotation ] [ drop math-method ] if ;
 146
 147 : math-both-known? ( word left right -- ? )
 148     3dup math-op
 149     [ 2drop 2drop t ]
 150     [ drop math-class-max swap method-for-class >boolean ] if ;
 151
 152 : (derived-ops) ( word assoc -- words )
 153     swap '[ swap first _ eq? nip ] assoc-filter ;
 154
 155 : derived-ops ( word -- words )
 156     [ 1array ] [ math-ops get (derived-ops) values ] bi append ;
 157
 158 : fast-derived-ops ( word -- words )
 159     fast-math-ops get (derived-ops) values ;
 160
 161 : all-derived-ops ( word -- words )
 162     [ derived-ops ] [ fast-derived-ops ] bi append ;
 163
 164 : integer-derived-ops ( word -- words )
 165     [ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi
 166     [
 167         [
 168             drop
 169             [ second integer class<= ]
 170             [ third integer class<= ]
 171             bi and
 172         ] assoc-filter values
 173     ] bi@ append ;
 174
 175 : each-derived-op ( word quot -- )
 176     [ derived-ops ] dip each ; inline
 177
 178 : each-fast-derived-op ( word quot -- )
 179     [ fast-derived-ops ] dip each ; inline
 180
 181 : each-integer-derived-op ( word quot -- )
 182     [ integer-derived-ops ] dip each ; inline
 183
 184 [
 185     [
 186         \ +       define-math-ops
 187         \ -       define-math-ops
 188         \ *       define-math-ops
 189         \ mod     define-math-ops
 190         \ /i      define-math-ops
 191
 192         \ bitand  define-math-ops
 193         \ bitor   define-math-ops
 194         \ bitxor  define-math-ops
 195
 196         \ <       define-math-ops
 197         \ <=      define-math-ops
 198         \ >       define-math-ops
 199         \ >=      define-math-ops
 200
 201         \ u<      define-math-ops
 202         \ u<=     define-math-ops
 203         \ u>      define-math-ops
 204         \ u>=     define-math-ops
 205
 206         \ number= define-math-ops
 207
 208         { { shift bignum bignum } bignum-shift } ,
 209         { { shift fixnum fixnum } fixnum-shift } ,
 210
 211         \ + \ fixnum+ \ bignum+ define-integer-ops
 212         \ - \ fixnum- \ bignum- define-integer-ops
 213         \ * \ fixnum* \ bignum* define-integer-ops
 214         \ shift \ fixnum-shift \ bignum-shift define-integer-ops
 215         \ mod \ fixnum-mod \ bignum-mod define-integer-ops
 216         \ /i \ fixnum/i \ bignum/i define-integer-ops
 217
 218         \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
 219         \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
 220         \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
 221
 222         \ < \ fixnum< \ bignum< define-integer-ops
 223         \ <= \ fixnum<= \ bignum<= define-integer-ops
 224         \ > \ fixnum> \ bignum> define-integer-ops
 225         \ >= \ fixnum>= \ bignum>= define-integer-ops
 226         \ number= \ eq? \ bignum= define-integer-ops
 227     ] { } make >hashtable math-ops set-global
 228
 229     H{
 230         { { + fixnum fixnum } fixnum+fast }
 231         { { - fixnum fixnum } fixnum-fast }
 232         { { * fixnum fixnum } fixnum*fast }
 233         { { shift fixnum fixnum } fixnum-shift-fast }
 234     } fast-math-ops set-global
 235 ] with-compilation-unit