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 : integer-fixnum-op-quot ( fix-word big-word -- quot )
  49     [
  50         [ over fixnum? ] %
  51         [ '[ _ execute ] , ]
  52         [ '[ fixnum>bignum _ execute ] , ] bi*
  53         \ if ,
  54     ] [ ] make ;
  55
  56 : fixnum-integer-op-quot ( fix-word big-word -- quot )
  57     [
  58         [ dup fixnum? ] %
  59         [ '[ _ execute ] , ]
  60         [ '[ [ fixnum>bignum ] dip _ execute ] , ] bi*
  61         \ if ,
  62     ] [ ] make ;
  63
  64 : integer-integer-op-quot ( fix-word big-word -- quot )
  65     [
  66         [ dup fixnum? ] %
  67         2dup integer-fixnum-op-quot ,
  68         [
  69             [ over fixnum? [ [ fixnum>bignum ] dip ] when ] %
  70             nip ,
  71         ] [ ] make ,
  72         \ if ,
  73     ] [ ] make ;
  74
  75 : integer-op-word ( triple -- word )
  76     [ name>> ] map "-" join "math.partial-dispatch" create ;
  77
  78 : integer-op-quot ( fix-word big-word triple -- quot )
  79     [ second ] [ third ] bi 2array {
  80         { { fixnum integer } [ fixnum-integer-op-quot ] }
  81         { { integer fixnum } [ integer-fixnum-op-quot ] }
  82         { { integer integer } [ integer-integer-op-quot ] }
  83     } case ;
  84
  85 : define-integer-op-word ( fix-word big-word triple -- )
  86     [
  87         [ 2nip integer-op-word ] [ integer-op-quot ] 3bi
  88         (( x y -- z )) define-declared
  89     ] [
  90         2nip
  91         [ integer-op-word ] keep
  92         "derived-from" set-word-prop
  93     ] 3bi ;
  94
  95 : define-integer-op-words ( triples fix-word big-word -- )
  96     '[ [ _ _ ] dip define-integer-op-word ] each ;
  97
  98 : integer-op-triples ( word -- triples )
  99     {
 100         { fixnum integer }
 101         { integer fixnum }
 102         { integer integer }
 103     } swap '[ _ prefix ] map ;
 104
 105 : define-integer-ops ( word fix-word big-word -- )
 106     [
 107         rot
 108         [ fixnum fixnum 3array "derived-from" set-word-prop ]
 109         [ bignum bignum 3array "derived-from" set-word-prop ]
 110         bi-curry bi*
 111     ] [
 112         [ integer-op-triples ] 2dip
 113         [ define-integer-op-words ]
 114         [ 2drop [ dup integer-op-word ] { } map>assoc % ]
 115         3bi
 116     ] 3bi ;
 117
 118 : define-math-ops ( op -- )
 119     { fixnum bignum float }
 120     [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
 121     [ nip ] assoc-filter
 122     [ def>> ] assoc-map
 123     [ nip length 1 = ] assoc-filter
 124     [ first ] assoc-map % ;
 125
 126 SYMBOL: math-ops
 127
 128 SYMBOL: fast-math-ops
 129
 130 : math-op ( word left right -- word' ? )
 131     3array math-ops get at* ;
 132
 133 : math-method* ( word left right -- quot )
 134     3dup math-op
 135     [ [ 3drop ] dip 1quotation ] [ drop math-method ] if ;
 136
 137 : math-both-known? ( word left right -- ? )
 138     3dup math-op
 139     [ 2drop 2drop t ]
 140     [ drop math-class-max swap specific-method >boolean ] if ;
 141
 142 : (derived-ops) ( word assoc -- words )
 143     swap '[ swap first _ eq? nip ] assoc-filter ;
 144
 145 : derived-ops ( word -- words )
 146     [ 1array ] [ math-ops get (derived-ops) values ] bi append ;
 147
 148 : fast-derived-ops ( word -- words )
 149     fast-math-ops get (derived-ops) values ;
 150
 151 : all-derived-ops ( word -- words )
 152     [ derived-ops ] [ fast-derived-ops ] bi append ;
 153
 154 : integer-derived-ops ( word -- words )
 155     [ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi
 156     [
 157         [
 158             drop
 159             [ second integer class<= ]
 160             [ third integer class<= ]
 161             bi and
 162         ] assoc-filter values
 163     ] bi@ append ;
 164
 165 : each-derived-op ( word quot -- )
 166     [ derived-ops ] dip each ; inline
 167
 168 : each-fast-derived-op ( word quot -- )
 169     [ fast-derived-ops ] dip each ; inline
 170
 171 : each-integer-derived-op ( word quot -- )
 172     [ integer-derived-ops ] dip each ; inline
 173
 174 [
 175     [
 176         \ +       define-math-ops
 177         \ -       define-math-ops
 178         \ *       define-math-ops
 179         \ mod     define-math-ops
 180         \ /i      define-math-ops
 181
 182         \ bitand  define-math-ops
 183         \ bitor   define-math-ops
 184         \ bitxor  define-math-ops
 185
 186         \ <       define-math-ops
 187         \ <=      define-math-ops
 188         \ >       define-math-ops
 189         \ >=      define-math-ops
 190         \ number= define-math-ops
 191
 192         { { shift bignum bignum } bignum-shift } ,
 193         { { shift fixnum fixnum } fixnum-shift } ,
 194
 195         \ + \ fixnum+ \ bignum+ define-integer-ops
 196         \ - \ fixnum- \ bignum- define-integer-ops
 197         \ * \ fixnum* \ bignum* define-integer-ops
 198         \ shift \ fixnum-shift \ bignum-shift define-integer-ops
 199         \ mod \ fixnum-mod \ bignum-mod define-integer-ops
 200         \ /i \ fixnum/i \ bignum/i define-integer-ops
 201
 202         \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
 203         \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
 204         \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
 205
 206         \ < \ fixnum< \ bignum< define-integer-ops
 207         \ <= \ fixnum<= \ bignum<= define-integer-ops
 208         \ > \ fixnum> \ bignum> define-integer-ops
 209         \ >= \ fixnum>= \ bignum>= define-integer-ops
 210         \ number= \ eq? \ bignum= define-integer-ops
 211     ] { } make >hashtable math-ops set-global
 212
 213     H{
 214         { { + fixnum fixnum } fixnum+fast }
 215         { { - fixnum fixnum } fixnum-fast }
 216         { { * fixnum fixnum } fixnum*fast }
 217         { { shift fixnum fixnum } fixnum-shift-fast }
 218     } fast-math-ops set-global
 219 ] with-compilation-unit