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

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