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 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 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 inline?
  68     "tuple-dispatch-generic" word-prop inline? ;
  69
  70 M: engine-word crossref? "forgotten" word-prop not ;
  71
  72 M: engine-word irrelevant? drop t ;
  73
  74 : remember-engine ( word -- )
  75     generic get "engines" word-prop push ;
  76
  77 : <engine-word> ( -- word )
  78     engine-word-name f <word>
  79     dup generic get "tuple-dispatch-generic" set-word-prop ;
  80
  81 : define-engine-word ( quot -- word )
  82     >r <engine-word> dup r> define ;
  83
  84 : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
  85
  86 : tuple-layout-superclasses% ( -- )
  87     [
  88         { tuple } declare
  89         1 slot { tuple-layout } declare
  90         4 slot { array } declare
  91     ] % ; inline
  92
  93 : tuple-dispatch-engine-body ( engine -- quot )
  94     [
  95         picker %
  96         tuple-layout-superclasses%
  97         [ n>> array-nth% ]
  98         [
  99             methods>> [
 100                 <trivial-tuple-dispatch-engine> engine>quot
 101             ] [
 102                 class-hash-dispatch-quot
 103             ] if-small? %
 104         ] bi
 105     ] [ ] make ;
 106
 107 M: echelon-dispatch-engine engine>quot
 108     dup n>> zero? [
 109         methods>> dup assoc-empty?
 110         [ drop default get ] [ values first engine>quot ] if
 111     ] [
 112         [
 113             picker %
 114             tuple-layout-superclasses%
 115             [ n>> array-nth% ]
 116             [
 117                 methods>> [
 118                     <trivial-tuple-dispatch-engine> engine>quot
 119                 ] [
 120                     class-hash-dispatch-quot
 121                 ] if-small? %
 122             ] bi
 123         ] [ ] make
 124     ] if ;
 125
 126 : >=-case-quot ( alist -- quot )
 127     default get [ drop ] prepend swap
 128     [
 129         [ [ dup ] swap [ fixnum>= ] curry compose ]
 130         [ [ drop ] prepose ]
 131         bi* [ ] like
 132     ] assoc-map
 133     alist>quot ;
 134
 135 : tuple-layout-echelon% ( -- )
 136     [
 137         { tuple } declare
 138         1 slot { tuple-layout } declare
 139         5 slot
 140     ] % ; inline
 141
 142 M: tuple-dispatch-engine engine>quot
 143     [
 144         picker %
 145         tuple-layout-echelon%
 146         [
 147             tuple assumed set
 148             echelons>> dup empty? [
 149                 unclip-last
 150                 [
 151                     [
 152                         engine>quot define-engine-word
 153                         [ remember-engine ] [ 1quotation ] bi
 154                         dup default set
 155                     ] assoc-map
 156                 ]
 157                 [ first2 engine>quot 2array ] bi*
 158                 suffix
 159             ] unless
 160         ] with-scope
 161         >=-case-quot %
 162     ] [ ] make ;