core/generic/standard/standard.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs kernel kernel.private slots.private math
   4 namespaces sequences vectors words quotations definitions
   5 hashtables layouts combinators sequences.private generic
   6 classes classes.algebra classes.private generic.standard.engines
   7 generic.standard.engines.tag generic.standard.engines.predicate
   8 generic.standard.engines.tuple accessors ;
   9 IN: generic.standard
  10
  11 GENERIC: dispatch# ( word -- n )
  12
  13 M: word dispatch# "combination" word-prop dispatch# ;
  14
  15 : unpickers
  16     {
  17         [ nip ]
  18         [ >r nip r> swap ]
  19         [ >r >r nip r> r> -rot ]
  20     } ; inline
  21
  22 : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
  23
  24 ERROR: no-method object generic ;
  25
  26 : error-method ( word -- quot )
  27     picker swap [ no-method ] curry append ;
  28
  29 : empty-method ( word -- quot )
  30     [
  31         picker % [ delegate dup ] %
  32         unpicker over suffix ,
  33         error-method \ drop prefix , \ if ,
  34     ] [ ] make ;
  35
  36 : default-method ( word -- pair )
  37     "default-method" word-prop
  38     object bootstrap-word swap 2array ;
  39
  40 : push-method ( method specializer atomic assoc -- )
  41     [
  42         [ H{ } clone <predicate-dispatch-engine> ] unless*
  43         [ methods>> set-at ] keep
  44     ] change-at ;
  45
  46 : flatten-method ( class method assoc -- )
  47     >r >r dup flatten-class keys swap r> r> [
  48         >r spin r> push-method
  49     ] 3curry each ;
  50
  51 : flatten-methods ( assoc -- assoc' )
  52     H{ } clone [
  53         [
  54             flatten-method
  55         ] curry assoc-each
  56     ] keep ;
  57
  58 : <big-dispatch-engine> ( assoc -- engine )
  59     flatten-methods
  60     convert-tuple-methods
  61     convert-hi-tag-methods
  62     <lo-tag-dispatch-engine> ;
  63
  64 : find-default ( methods -- quot )
  65     #! Side-effects methods.
  66     object bootstrap-word swap delete-at* [
  67         drop generic get "default-method" word-prop 1quotation
  68     ] unless ;
  69
  70 : mangle-method ( method generic -- quot )
  71     [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
  72     prepend [ ] like ;
  73
  74 : single-combination ( word -- quot )
  75     [
  76         object bootstrap-word assumed set {
  77             [ generic set ]
  78             [ "engines" word-prop forget-all ]
  79             [ V{ } clone "engines" set-word-prop ]
  80             [
  81                 "methods" word-prop
  82                 [ generic get mangle-method ] assoc-map
  83                 [ find-default default set ]
  84                 [ <big-dispatch-engine> ]
  85                 bi engine>quot
  86             ]
  87         } cleave
  88     ] with-scope ;
  89
  90 ERROR: inconsistent-next-method class generic ;
  91
  92 ERROR: no-next-method class generic ;
  93
  94 : single-next-method-quot ( class generic -- quot )
  95     [
  96         [ drop [ instance? ] curry % ]
  97         [
  98             2dup next-method
  99             [ 2nip 1quotation ]
 100             [ [ no-next-method ] 2curry [ ] like ] if* ,
 101         ]
 102         [ [ inconsistent-next-method ] 2curry , ]
 103         2tri
 104         \ if ,
 105     ] [ ] make ;
 106
 107 : single-effective-method ( obj word -- method )
 108     [ order [ instance? ] with find-last nip ] keep method ;
 109
 110 TUPLE: standard-combination # ;
 111
 112 C: <standard-combination> standard-combination
 113
 114 PREDICATE: standard-generic < generic
 115     "combination" word-prop standard-combination? ;
 116
 117 PREDICATE: simple-generic < standard-generic
 118     "combination" word-prop #>> zero? ;
 119
 120 : define-simple-generic ( word -- )
 121     T{ standard-combination f 0 } define-generic ;
 122
 123 : with-standard ( combination quot -- quot' )
 124     >r #>> (dispatch#) r> with-variable ; inline
 125
 126 M: standard-generic extra-values drop 0 ;
 127
 128 M: standard-combination make-default-method
 129     [ empty-method ] with-standard ;
 130
 131 M: standard-combination perform-combination
 132     [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
 133
 134 M: standard-combination dispatch# #>> ;
 135
 136 M: standard-combination next-method-quot*
 137     [
 138         single-next-method-quot picker prepend
 139     ] with-standard ;
 140
 141 M: standard-generic effective-method
 142     [ dispatch# (picker) call ] keep single-effective-method ;
 143
 144 TUPLE: hook-combination var ;
 145
 146 C: <hook-combination> hook-combination
 147
 148 PREDICATE: hook-generic < generic
 149     "combination" word-prop hook-combination? ;
 150
 151 : with-hook ( combination quot -- quot' )
 152     0 (dispatch#) [
 153         dip var>> [ get ] curry prepend
 154     ] with-variable ; inline
 155
 156 M: hook-combination dispatch# drop 0 ;
 157
 158 M: hook-generic extra-values drop 1 ;
 159
 160 M: hook-generic effective-method
 161     [ "combination" word-prop var>> get ] keep
 162     single-effective-method ;
 163
 164 M: hook-combination make-default-method
 165     [ error-method ] with-hook ;
 166
 167 M: hook-combination perform-combination
 168     [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
 169
 170 M: hook-combination next-method-quot*
 171     [ single-next-method-quot ] with-hook ;
 172
 173 M: simple-generic definer drop \ GENERIC: f ;
 174
 175 M: standard-generic definer drop \ GENERIC# f ;
 176
 177 M: hook-generic definer drop \ HOOK: f ;