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     [ [ flatten-class keys ] keep ] 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 : single-next-method-quot ( class generic -- quot/f )
  83     2dup next-method dup [
  84         [
  85             pick "predicate" word-prop %
  86             1quotation ,
  87             [ inconsistent-next-method ] 2curry ,
  88             \ if ,
  89         ] [ ] make
  90     ] [ 3drop f ] if ;
  91
  92 : single-effective-method ( obj word -- method )
  93     [ [ order [ instance? ] with find-last nip ] keep method ]
  94     [ "default-method" word-prop ]
  95     bi or ;
  96
  97 TUPLE: standard-combination # ;
  98
  99 C: <standard-combination> standard-combination
 100
 101 PREDICATE: standard-generic < generic
 102     "combination" word-prop standard-combination? ;
 103
 104 PREDICATE: simple-generic < standard-generic
 105     "combination" word-prop #>> zero? ;
 106
 107 : define-simple-generic ( word -- )
 108     T{ standard-combination f 0 } define-generic ;
 109
 110 : with-standard ( combination quot -- quot' )
 111     [ #>> (dispatch#) ] dip with-variable ; inline
 112
 113 M: standard-generic extra-values drop 0 ;
 114
 115 M: standard-combination make-default-method
 116     [ error-method ] with-standard ;
 117
 118 M: standard-combination perform-combination
 119     [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
 120
 121 M: standard-combination dispatch# #>> ;
 122
 123 M: standard-combination method-declaration
 124     dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
 125
 126 M: standard-combination next-method-quot*
 127     [
 128         single-next-method-quot
 129         dup [ picker prepend ] when
 130     ] with-standard ;
 131
 132 M: standard-generic effective-method
 133     [ dispatch# (picker) call ] keep single-effective-method ;
 134
 135 TUPLE: hook-combination var ;
 136
 137 C: <hook-combination> hook-combination
 138
 139 PREDICATE: hook-generic < generic
 140     "combination" word-prop hook-combination? ;
 141
 142 : with-hook ( combination quot -- quot' )
 143     0 (dispatch#) [
 144         [ hook-combination ] dip with-variable
 145     ] with-variable ; inline
 146
 147 : prepend-hook-var ( quot -- quot' )
 148     hook-combination get var>> [ get ] curry prepend ;
 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 prepend-hook-var ] with-hook ;
 162
 163 M: hook-combination perform-combination
 164     [ drop ] [
 165         [ single-combination prepend-hook-var ] with-hook
 166     ] 2bi define ;
 167
 168 M: hook-combination next-method-quot*
 169     [
 170         single-next-method-quot
 171         dup [ prepend-hook-var ] when
 172     ] with-hook ;
 173
 174 M: simple-generic definer drop \ GENERIC: f ;
 175
 176 M: standard-generic definer drop \ GENERIC# f ;
 177
 178 M: hook-generic definer drop \ HOOK: f ;