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