core/generic/math-combination.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: generic
   4 USING: arrays errors generic hashtables kernel kernel-internals
   5 math namespaces sequences words ;
   6
   7 PREDICATE: class math-class ( object -- ? )
   8     dup null bootstrap-word eq? [
   9         drop f
  10     ] [
  11         number bootstrap-word class<
  12     ] if ;
  13
  14 : math-class-compare ( class class -- n )
  15     [
  16         dup math-class?
  17         [ types last/first ] [ drop { 100 100 } ] if
  18     ] 2apply <=> ;
  19
  20 : math-class-max ( class class -- class )
  21     [ math-class-compare 0 > ] 2keep ? ;
  22
  23 : (math-upgrade) ( max class -- quot )
  24     dupd = [
  25         drop [ ]
  26     ] [
  27         "coercer" word-prop [ [ ] ] unless*
  28     ] if ;
  29
  30 : math-upgrade ( class1 class2 -- quot )
  31     [ math-class-max ] 2keep
  32     >r over r> (math-upgrade)
  33     >r (math-upgrade) dup empty? [ 1 make-dip ] unless
  34     r> append ;
  35
  36 TUPLE: no-math-method left right generic ;
  37
  38 : no-math-method ( left right generic -- * )
  39     <no-math-method> throw ;
  40
  41 : applicable-method ( generic class -- quot )
  42     over method method-def
  43     [ ] [ [ no-math-method ] curry ] ?if ;
  44
  45 : object-method ( generic -- quot )
  46     object bootstrap-word applicable-method ;
  47
  48 : math-method ( word class1 class2 -- quot )
  49     2dup and [
  50         2dup math-upgrade >r
  51         math-class-max over order min-class applicable-method
  52         r> swap append
  53     ] [
  54         2drop object-method
  55     ] if ;
  56
  57 : math-vtable* ( picker max quot -- quot )
  58     [
  59         rot , \ tag ,
  60         [ >r [ type>class ] map r> map % ] { } make ,
  61         \ dispatch ,
  62     ] [ ] make ; inline
  63
  64 : math-vtable ( picker quot -- quot )
  65     num-tags swap math-vtable* ; inline
  66
  67 : math-combination ( word -- quot )
  68     \ over [
  69         dup math-class? [
  70             \ dup [ >r 2dup r> math-method ] math-vtable
  71         ] [
  72             over object-method
  73         ] if nip
  74     ] math-vtable nip ;
  75
  76 PREDICATE: generic 2generic ( word -- ? )
  77     "combination" word-prop [ math-combination ] = ;