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 sorting sequences ;
   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 : sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
  26
  27 M: lo-tag-dispatch-engine engine>quot
  28     methods>> engines>quots*
  29     [ >r lo-tag-number r> ] assoc-map
  30     [
  31         picker % [ tag ] % [
  32             sort-tags linear-dispatch-quot
  33         ] [
  34             num-tags get direct-dispatch-quot
  35         ] if-small? %
  36     ] [ ] make ;
  37
  38 TUPLE: hi-tag-dispatch-engine methods ;
  39
  40 C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
  41
  42 : convert-hi-tag-methods ( assoc -- assoc' )
  43     \ hi-tag bootstrap-word
  44     \ <hi-tag-dispatch-engine> convert-methods ;
  45
  46 : num-hi-tags ( -- n ) num-types get num-tags get - ;
  47
  48 : hi-tag-number ( class -- n )
  49     "type" word-prop ;
  50
  51 : hi-tag-quot ( -- quot )
  52     \ hi-tag def>> ;
  53
  54 M: hi-tag-dispatch-engine engine>quot
  55     methods>> engines>quots*
  56     [ >r hi-tag-number r> ] assoc-map
  57     [
  58         picker % hi-tag-quot % [
  59             sort-tags linear-dispatch-quot
  60         ] [
  61             num-tags get , \ fixnum-fast ,
  62             [ >r num-tags get - r> ] assoc-map
  63             num-hi-tags direct-dispatch-quot
  64         ] if-small? %
  65     ] [ ] make ;