core/generic/standard/engines/engines.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs kernel kernel.private namespaces quotations
   4 generic math sequences combinators words classes.algebra arrays
   5 ;
   6 IN: generic.standard.engines
   7
   8 SYMBOL: default
   9 SYMBOL: assumed
  10 SYMBOL: (dispatch#)
  11
  12 GENERIC: engine>quot ( engine -- quot )
  13
  14 : engines>quots ( assoc -- assoc' )
  15     [ engine>quot ] assoc-map ;
  16
  17 : engines>quots* ( assoc -- assoc' )
  18     [ over assumed [ engine>quot ] with-variable ] assoc-map ;
  19
  20 : if-small? ( assoc true false -- )
  21     [ dup assoc-size 4 <= ] 2dip if ; inline
  22
  23 : linear-dispatch-quot ( alist -- quot )
  24     default get [ drop ] prepend swap
  25     [
  26         [ [ dup ] swap [ eq? ] curry compose ]
  27         [ [ drop ] prepose ]
  28         bi* [ ] like
  29     ] assoc-map
  30     alist>quot ;
  31
  32 : split-methods ( assoc class -- first second )
  33     [ [ nip class<= not ] curry assoc-filter ]
  34     [ [ nip class<=     ] curry assoc-filter ] 2bi ;
  35
  36 : convert-methods ( assoc class word -- assoc' )
  37     over [ split-methods ] 2dip pick assoc-empty? [
  38         3drop
  39     ] [
  40         [ execute ] dip pick set-at
  41     ] if ; inline
  42
  43 : (picker) ( n -- quot )
  44     {
  45         { 0 [ [ dup ] ] }
  46         { 1 [ [ over ] ] }
  47         { 2 [ [ pick ] ] }
  48         [ 1- (picker) [ dip swap ] curry ]
  49     } case ;
  50
  51 : picker ( -- quot ) \ (dispatch#) get (picker) ;
  52
  53 GENERIC: extra-values ( generic -- n )