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

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