library/generic/standard-combination.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays errors hashtables kernel kernel-internals
   4 math namespaces sequences vectors words ;
   5 IN: generic
   6
   7 : picker ( dispatch# -- quot )
   8     { [ dup ] [ over ] [ pick ] } nth ;
   9
  10 : unpicker ( dispatch# -- quot )
  11     { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } nth ;
  12
  13 TUPLE: no-method object generic ;
  14
  15 : no-method ( object generic -- * ) <no-method> throw ;
  16
  17 : error-method ( dispatch# word -- method )
  18     >r picker r> [ no-method ] curry append ;
  19
  20 : empty-method ( dispatch# word -- method )
  21     [
  22         over picker % [ delegate dup ] %
  23         over unpicker over add ,
  24         [ drop ] -rot error-method append , \ if ,
  25     ] [ ] make ;
  26
  27 : class-predicates ( picker assoc -- assoc )
  28     [
  29         first2 >r >r picker r> "predicate" word-prop append
  30         r> 2array
  31     ] map-with ;
  32
  33 : sort-methods ( assoc n -- vtable )
  34     #! Input is a predicate -> method association.
  35     #! n is vtable size (either num-types or num-tags).
  36     [
  37         type>class [ object bootstrap-word ] unless*
  38         swap [ first classes-intersect? ] subset-with
  39     ] map-with ;
  40
  41 : (simplify-alist) ( class i assoc -- default assoc )
  42     2dup length 1- = [
  43         nth second [ ] rot drop
  44     ] [
  45         3dup >r 1+ r> nth first class< [
  46             >r 1+ r> (simplify-alist)
  47         ] [
  48             [ nth second ] 2keep swap 1+ tail rot drop
  49         ] if
  50     ] if ;
  51
  52 : simplify-alist ( class assoc -- default assoc )
  53     0 swap (simplify-alist) ;
  54
  55 : default-method ( dispatch# word -- pair )
  56     empty-method object bootstrap-word swap 2array ;
  57
  58 : methods* ( dispatch# word -- assoc )
  59     #! Make a class->method association, together with a
  60     #! default delegating method at the end.
  61     dup methods -rot default-method add* ;
  62
  63 : method-alist>quot ( dispatch# word base-class -- quot )
  64     bootstrap-word swap simplify-alist
  65     swapd class-predicates alist>quot ;
  66
  67 : small-generic ( dispatch# word -- def )
  68     dupd methods* object method-alist>quot ;
  69
  70 : build-type-vtable ( dispatch# alist-seq -- alist-seq )
  71     dup length [
  72         type>class
  73         [ swap simplify-alist ] [ first second [ ] ] if*
  74         >r over r> class-predicates alist>quot
  75     ] 2map nip ;
  76
  77 : <type-vtable> ( dispatch# word n -- vtable )
  78     #! n is vtable size; either num-types or num-tags.
  79     >r dupd methods* r> sort-methods build-type-vtable ;
  80
  81 : type-generic ( dispatch# word n dispatcher -- quot )
  82     [
  83         >r pick picker % r> , <type-vtable> , \ dispatch ,
  84     ] [ ] make ;
  85
  86 : tag-generic? ( word -- ? )
  87     #! If all the types we dispatch upon can be identified
  88     #! based on tag alone, we change the dispatcher primitive
  89     #! from 'type' to 'tag'.
  90     generic-tags [ tag-mask < ] all? ;
  91
  92 : small-generic? ( word -- ? ) generic-tags length 3 <= ;
  93
  94 : build-class-vtable ( vtable pair -- )
  95     dup first hashcode pick length rem rot nth push ;
  96
  97 : <class-vtable> ( dispatch# word assoc -- table )
  98     >r dupd default-method r>
  99     [ length 3 + [ drop 1array >vector ] map-with ] keep
 100     [ dupd build-class-vtable ] each
 101     [ object method-alist>quot ] map-with ;
 102
 103 : class-generic ( dispatch# word -- quot )
 104     dup methods dup empty? [
 105         drop default-method
 106     ] [
 107         [
 108             pick picker % [ class hashcode ] %
 109             <class-vtable> dup length , \ rem , , \ dispatch ,
 110         ] [ ] make
 111     ] if ;
 112
 113 : standard-combination ( word dispatch# -- quot )
 114     swap {
 115         { [ dup tag-generic? ] [ num-tags \ tag type-generic ] }
 116         { [ dup small-generic? ] [ small-generic ] }
 117         { [ t ] [ class-generic ] }
 118         { [ t ] [ num-types \ type type-generic ] }
 119     } cond ;
 120
 121 : define-generic ( word -- )
 122     [ 0 standard-combination ] define-generic* ;
 123
 124 PREDICATE: generic standard-generic
 125     "combination" word-prop [ standard-combination ] tail? ;