core/generic/standard/engines/tag/tag.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: classes.private generic.standard.engines namespaces make
   4 arrays assocs sequences.private quotations kernel.private
   5 math slots.private math.private kernel accessors words
   6 layouts ;
   7 IN: generic.standard.engines.tag
   8
   9 TUPLE: lo-tag-dispatch-engine methods ;
  10
  11 C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
  12
  13 : direct-dispatch-quot ( alist n -- quot )
  14     default get <array>
  15     [ <enum> swap update ] keep
  16     [ dispatch ] curry >quotation ;
  17
  18 : lo-tag-number ( class -- n )
  19      dup \ hi-tag bootstrap-word eq? [
  20         drop \ hi-tag tag-number
  21     ] [
  22         "type" word-prop
  23     ] if ;
  24
  25 M: lo-tag-dispatch-engine engine>quot
  26     methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
  27     [
  28         picker % [ tag ] % [
  29             linear-dispatch-quot
  30         ] [
  31             num-tags get direct-dispatch-quot
  32         ] if-small? %
  33     ] [ ] make ;
  34
  35 TUPLE: hi-tag-dispatch-engine methods ;
  36
  37 C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
  38
  39 : convert-hi-tag-methods ( assoc -- assoc' )
  40     \ hi-tag bootstrap-word
  41     \ <hi-tag-dispatch-engine> convert-methods ;
  42
  43 : num-hi-tags ( -- n ) num-types get num-tags get - ;
  44
  45 : hi-tag-number ( class -- n )
  46     "type" word-prop num-tags get - ;
  47
  48 : hi-tag-quot ( -- quot )
  49     [ 0 slot ] num-tags get [ fixnum-fast ] curry compose ;
  50
  51 M: hi-tag-dispatch-engine engine>quot
  52     methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
  53     [
  54         picker % hi-tag-quot % [
  55             linear-dispatch-quot
  56         ] [
  57             num-hi-tags direct-dispatch-quot
  58         ] if-small? %
  59     ] [ ] make ;