core/generic/standard/engines/tuple/tuple.factor

   1 ! Copyright (c) 2008 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel classes.tuple.private hashtables assocs sorting
   4 accessors combinators sequences slots.private math.parser words
   5 effects namespaces generic generic.standard.engines
   6 classes.algebra math math.private kernel.private
   7 quotations arrays definitions ;
   8 IN: generic.standard.engines.tuple
   9
  10 TUPLE: echelon-dispatch-engine n methods ;
  11
  12 C: <echelon-dispatch-engine> echelon-dispatch-engine
  13
  14 TUPLE: trivial-tuple-dispatch-engine methods ;
  15
  16 C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
  17
  18 TUPLE: tuple-dispatch-engine echelons ;
  19
  20 : push-echelon ( class method assoc -- )
  21     >r swap dup "layout" word-prop layout-echelon r>
  22     [ ?set-at ] change-at ;
  23
  24 : echelon-sort ( assoc -- assoc' )
  25     V{ } clone [
  26         [
  27             push-echelon
  28         ] curry assoc-each
  29     ] keep sort-keys ;
  30
  31 : <tuple-dispatch-engine> ( methods -- engine )
  32     echelon-sort
  33     [ dupd <echelon-dispatch-engine> ] assoc-map
  34     \ tuple-dispatch-engine boa ;
  35
  36 : convert-tuple-methods ( assoc -- assoc' )
  37     tuple bootstrap-word
  38     \ <tuple-dispatch-engine> convert-methods ;
  39
  40 M: trivial-tuple-dispatch-engine engine>quot
  41     methods>> engines>quots* linear-dispatch-quot ;
  42
  43 : hash-methods ( methods -- buckets )
  44     >alist V{ } clone [ hashcode 1array ] distribute-buckets
  45     [ <trivial-tuple-dispatch-engine> ] map ;
  46
  47 : word-hashcode% ( -- ) [ 1 slot ] % ;
  48
  49 : class-hash-dispatch-quot ( methods -- quot )
  50     [
  51         \ dup ,
  52         word-hashcode%
  53         hash-methods [ engine>quot ] map hash-dispatch-quot %
  54     ] [ ] make ;
  55
  56 : engine-word-name ( -- string )
  57     generic get word-name "/tuple-dispatch-engine" append ;
  58
  59 PREDICATE: engine-word < word
  60     "tuple-dispatch-generic" word-prop generic? ;
  61
  62 M: engine-word stack-effect
  63     "tuple-dispatch-generic" word-prop
  64     [ extra-values ] [ stack-effect ] bi
  65     dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
  66
  67 M: engine-word crossref? "forgotten" word-prop not ;
  68
  69 M: engine-word irrelevant? drop t ;
  70
  71 : remember-engine ( word -- )
  72     generic get "engines" word-prop push ;
  73
  74 : <engine-word> ( -- word )
  75     engine-word-name f <word>
  76     dup generic get "tuple-dispatch-generic" set-word-prop ;
  77
  78 : define-engine-word ( quot -- word )
  79     >r <engine-word> dup r> define ;
  80
  81 : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
  82
  83 : tuple-layout-superclasses ( obj -- array )
  84     { tuple } declare
  85     1 slot { tuple-layout } declare
  86     4 slot { array } declare ; inline
  87
  88 : tuple-dispatch-engine-body ( engine -- quot )
  89     [
  90         picker %
  91         [ tuple-layout-superclasses ] %
  92         [ n>> array-nth% ]
  93         [
  94             methods>> [
  95                 <trivial-tuple-dispatch-engine> engine>quot
  96             ] [
  97                 class-hash-dispatch-quot
  98             ] if-small? %
  99         ] bi
 100     ] [ ] make ;
 101
 102 M: echelon-dispatch-engine engine>quot
 103     dup n>> zero? [
 104         methods>> dup assoc-empty?
 105         [ drop default get ] [ values first engine>quot ] if
 106     ] [
 107         [
 108             picker %
 109             [ tuple-layout-superclasses ] %
 110             [ n>> array-nth% ]
 111             [
 112                 methods>> [
 113                     <trivial-tuple-dispatch-engine> engine>quot
 114                 ] [
 115                     class-hash-dispatch-quot
 116                 ] if-small? %
 117             ] bi
 118         ] [ ] make
 119     ] if ;
 120
 121 : >=-case-quot ( alist -- quot )
 122     default get [ drop ] prepend swap
 123     [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
 124     alist>quot ;
 125
 126 : tuple-layout-echelon ( obj -- array )
 127     { tuple } declare
 128     1 slot { tuple-layout } declare
 129     5 slot ; inline
 130
 131 M: tuple-dispatch-engine engine>quot
 132     [
 133         picker %
 134         [ tuple-layout-echelon ] %
 135         [
 136             tuple assumed set
 137             echelons>> dup empty? [
 138                 unclip-last
 139                 [
 140                     [
 141                         engine>quot define-engine-word
 142                         [ remember-engine ] [ 1quotation ] bi
 143                         dup default set
 144                     ] assoc-map
 145                 ]
 146                 [ first2 engine>quot 2array ] bi*
 147                 suffix
 148             ] unless
 149         ] with-scope
 150         >=-case-quot %
 151     ] [ ] make ;