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 empty-method object bootstrap-word
  62     swap 2array add* ;
  63
  64 : method-alist>quot ( dispatch# word base-class -- quot )
  65     bootstrap-word swap simplify-alist
  66     swapd class-predicates alist>quot ;
  67
  68 : small-generic ( dispatch# word -- def )
  69     dupd methods* object method-alist>quot ;
  70
  71 : build-type-vtable ( dispatch# alist-seq -- alist-seq )
  72     dup length [
  73         type>class
  74         [ swap simplify-alist ] [ first second [ ] ] if*
  75         >r over r> class-predicates alist>quot
  76     ] 2map nip ;
  77
  78 : <type-vtable> ( dispatch# word n -- vtable )
  79     #! n is vtable size; either num-types or num-tags.
  80     >r dupd methods* r> sort-methods build-type-vtable ;
  81
  82 : type-generic ( dispatch# word n dispatcher -- quot )
  83     [
  84         >r pick picker % r> , <type-vtable> , \ dispatch ,
  85     ] [ ] make ;
  86
  87 : tag-generic? ( word -- ? )
  88     #! If all the types we dispatch upon can be identified
  89     #! based on tag alone, we change the dispatcher primitive
  90     #! from 'type' to 'tag'.
  91     generic-tags [ tag-mask < ] all? ;
  92
  93 : small-generic? ( word -- ? ) generic-tags length 3 <= ;
  94
  95 : standard-combination ( word dispatch# -- quot )
  96     swap {
  97         { [ dup tag-generic? ] [ num-tags \ tag type-generic ] }
  98         { [ dup small-generic? ] [ small-generic ] }
  99         { [ t ] [ num-types \ type type-generic ] }
 100     } cond ;
 101
 102 : define-generic ( word -- )
 103     [ 0 standard-combination ] define-generic* ;
 104
 105 PREDICATE: generic standard-generic
 106     "combination" word-prop [ standard-combination ] tail? ;