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