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 assocs quotations arrays locals
   5 generic generic.math hashtables effects compiler.units ;
   6 IN: math.partial-dispatch
   7
   8 ! Partial dispatch.
   9
  10 ! This code will be overhauled and generalized when
  11 ! multi-methods go into the core.
  12 PREDICATE: math-partial < word
  13     "derived-from" word-prop >boolean ;
  14
  15 :: fixnum-integer-op ( a b fix-word big-word -- c )
  16     b tag 0 eq? [
  17         a b fix-word execute
  18     ] [
  19        a fixnum>bignum b big-word execute
  20     ] if ; inline
  21
  22 :: integer-fixnum-op ( a b fix-word big-word -- c )
  23     a tag 0 eq? [
  24         a b fix-word execute
  25     ] [
  26         a b fixnum>bignum big-word execute
  27     ] if ; inline
  28
  29 :: integer-integer-op ( a b fix-word big-word -- c )
  30     b tag 0 eq? [
  31         a b fix-word big-word integer-fixnum-op
  32     ] [
  33         a dup tag 0 eq? [ fixnum>bignum ] when
  34         b big-word execute
  35     ] if ; inline
  36
  37 : integer-op-combinator ( triple -- word )
  38     [
  39         [ second name>> % "-" % ]
  40         [ third name>> % "-op" % ]
  41         bi
  42     ] "" make "math.partial-dispatch" lookup ;
  43
  44 : integer-op-word ( triple -- word )
  45     [ name>> ] map "-" join "math.partial-dispatch" create ;
  46
  47 : integer-op-quot ( triple fix-word big-word -- quot )
  48     rot integer-op-combinator 1quotation 2curry ;
  49
  50 : define-integer-op-word ( triple fix-word big-word -- )
  51     [
  52         [ 2drop integer-op-word ] [ integer-op-quot ] 3bi
  53         (( x y -- z )) define-declared
  54     ] [
  55         2drop
  56         [ integer-op-word ] keep
  57         "derived-from" set-word-prop
  58     ] 3bi ;
  59
  60 : define-integer-op-words ( triples fix-word big-word -- )
  61     [ define-integer-op-word ] 2curry each ;
  62
  63 : integer-op-triples ( word -- triples )
  64     {
  65         { fixnum integer }
  66         { integer fixnum }
  67         { integer integer }
  68     } swap [ prefix ] curry map ;
  69
  70 : define-integer-ops ( word fix-word big-word -- )
  71     >r >r integer-op-triples r> r>
  72     [ define-integer-op-words ]
  73     [ 2drop [ dup integer-op-word ] { } map>assoc % ]
  74     3bi ;
  75
  76 : define-math-ops ( op -- )
  77     { fixnum bignum float }
  78     [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
  79     [ nip ] assoc-filter
  80     [ def>> peek ] assoc-map % ;
  81
  82 SYMBOL: math-ops
  83
  84 SYMBOL: fast-math-ops
  85
  86 : math-op ( word left right -- word' ? )
  87     3array math-ops get at* ;
  88
  89 : math-method* ( word left right -- quot )
  90     3dup math-op
  91     [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
  92
  93 : math-both-known? ( word left right -- ? )
  94     3dup math-op
  95     [ 2drop 2drop t ]
  96     [ drop math-class-max swap specific-method >boolean ] if ;
  97
  98 : (derived-ops) ( word assoc -- words )
  99     swap [ rot first eq? nip ] curry assoc-filter values ;
 100
 101 : derived-ops ( word -- words )
 102     [ 1array ]
 103     [ math-ops get (derived-ops) ]
 104     bi append ;
 105
 106 : fast-derived-ops ( word -- words )
 107     fast-math-ops get (derived-ops) ;
 108
 109 : all-derived-ops ( word -- words )
 110     [ derived-ops ] [ fast-derived-ops ] bi append ;
 111
 112 : each-derived-op ( word quot -- )
 113     >r derived-ops r> each ; inline
 114
 115 : each-fast-derived-op ( word quot -- )
 116     >r fast-derived-ops r> each ; inline
 117
 118 [
 119     [
 120         \ +       define-math-ops
 121         \ -       define-math-ops
 122         \ *       define-math-ops
 123         \ shift   define-math-ops
 124         \ mod     define-math-ops
 125         \ /i      define-math-ops
 126
 127         \ bitand  define-math-ops
 128         \ bitor   define-math-ops
 129         \ bitxor  define-math-ops
 130
 131         \ <       define-math-ops
 132         \ <=      define-math-ops
 133         \ >       define-math-ops
 134         \ >=      define-math-ops
 135         \ number= define-math-ops
 136
 137         \ + \ fixnum+ \ bignum+ define-integer-ops
 138         \ - \ fixnum- \ bignum- define-integer-ops
 139         \ * \ fixnum* \ bignum* define-integer-ops
 140         \ shift \ fixnum-shift \ bignum-shift define-integer-ops
 141         \ mod \ fixnum-mod \ bignum-mod define-integer-ops
 142         \ /i \ fixnum/i \ bignum/i define-integer-ops
 143
 144         \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
 145         \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
 146         \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
 147
 148         \ < \ fixnum< \ bignum< define-integer-ops
 149         \ <= \ fixnum<= \ bignum<= define-integer-ops
 150         \ > \ fixnum> \ bignum> define-integer-ops
 151         \ >= \ fixnum>= \ bignum>= define-integer-ops
 152         \ number= \ eq? \ bignum= define-integer-ops
 153     ] { } make >hashtable math-ops set-global
 154
 155     H{
 156         { { + fixnum fixnum } fixnum+fast }
 157         { { - fixnum fixnum } fixnum-fast }
 158         { { * fixnum fixnum } fixnum*fast }
 159         { { shift fixnum fixnum } fixnum-shift-fast }
 160     } fast-math-ops set-global
 161 ] with-compilation-unit