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 make 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     [ dup flatten-class keys swap ] 2dip [
  37         [ spin ] dip 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 : <standard-engine> ( word -- engine )
  64     object bootstrap-word assumed set {
  65         [ generic set ]
  66         [ "engines" word-prop forget-all ]
  67         [ V{ } clone "engines" set-word-prop ]
  68         [
  69             "methods" word-prop
  70             [ generic get mangle-method ] assoc-map
  71             [ find-default default set ]
  72             [ <big-dispatch-engine> ]
  73             bi
  74         ]
  75     } cleave ;
  76
  77 : single-combination ( word -- quot )
  78     [ <standard-engine> engine>quot ] with-scope ;
  79
  80 ERROR: inconsistent-next-method class generic ;
  81
  82 ERROR: no-next-method class generic ;
  83
  84 : single-next-method-quot ( class generic -- quot )
  85     [
  86         [ drop "predicate" word-prop % ]
  87         [
  88             2dup next-method
  89             [ 2nip 1quotation ]
  90             [ [ no-next-method ] 2curry [ ] like ] if* ,
  91         ]
  92         [ [ inconsistent-next-method ] 2curry , ]
  93         2tri
  94         \ if ,
  95     ] [ ] make ;
  96
  97 : single-effective-method ( obj word -- method )
  98     [ [ order [ instance? ] with find-last nip ] keep method ]
  99     [ "default-method" word-prop ]
 100     bi or ;
 101
 102 TUPLE: standard-combination # ;
 103
 104 C: <standard-combination> standard-combination
 105
 106 PREDICATE: standard-generic < generic
 107     "combination" word-prop standard-combination? ;
 108
 109 PREDICATE: simple-generic < standard-generic
 110     "combination" word-prop #>> zero? ;
 111
 112 : define-simple-generic ( word -- )
 113     T{ standard-combination f 0 } define-generic ;
 114
 115 : with-standard ( combination quot -- quot' )
 116     [ #>> (dispatch#) ] dip with-variable ; inline
 117
 118 M: standard-generic extra-values drop 0 ;
 119
 120 M: standard-combination make-default-method
 121     [ error-method ] with-standard ;
 122
 123 M: standard-combination perform-combination
 124     [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
 125
 126 M: standard-combination dispatch# #>> ;
 127
 128 M: standard-combination method-declaration
 129     dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
 130
 131 M: standard-combination next-method-quot*
 132     [
 133         single-next-method-quot picker prepend
 134     ] with-standard ;
 135
 136 M: standard-generic effective-method
 137     [ dispatch# (picker) call ] keep single-effective-method ;
 138
 139 TUPLE: hook-combination var ;
 140
 141 C: <hook-combination> hook-combination
 142
 143 PREDICATE: hook-generic < generic
 144     "combination" word-prop hook-combination? ;
 145
 146 : with-hook ( combination quot -- quot' )
 147     0 (dispatch#) [
 148         dip var>> [ get ] curry prepend
 149     ] with-variable ; inline
 150
 151 M: hook-combination dispatch# drop 0 ;
 152
 153 M: hook-combination method-declaration 2drop [ ] ;
 154
 155 M: hook-generic extra-values drop 1 ;
 156
 157 M: hook-generic effective-method
 158     [ "combination" word-prop var>> get ] keep
 159     single-effective-method ;
 160
 161 M: hook-combination make-default-method
 162     [ error-method ] with-hook ;
 163
 164 M: hook-combination perform-combination
 165     [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
 166
 167 M: hook-combination next-method-quot*
 168     [ single-next-method-quot ] with-hook ;
 169
 170 M: simple-generic definer drop \ GENERIC: f ;
 171
 172 M: standard-generic definer drop \ GENERIC# f ;
 173
 174 M: hook-generic definer drop \ HOOK: f ;