core/optimizer/specializers/specializers.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors arrays generic hashtables kernel kernel.private\r
   4 math namespaces sequences vectors words strings layouts\r
   5 combinators sequences.private classes generic.standard\r
   6 generic.standard.engines assocs ;\r
   7 IN: optimizer.specializers\r
   8 \r
   9 : (make-specializer) ( class picker -- quot )\r
  10     swap "predicate" word-prop append ;\r
  11 \r
  12 : make-specializer ( classes -- quot )\r
  13     dup length <reversed>\r
  14     [ (picker) 2array ] 2map\r
  15     [ drop object eq? not ] assoc-filter\r
  16     dup empty? [ drop [ t ] ] [\r
  17         [ (make-specializer) ] { } assoc>map\r
  18         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce\r
  19     ] if ;\r
  20 \r
  21 : specializer-cases ( quot word -- default alist )\r
  22     dup [ array? ] all? [ 1array ] unless [\r
  23         [ make-specializer ] keep\r
  24         [ declare ] curry pick append\r
  25     ] { } map>assoc ;\r
  26 \r
  27 : method-declaration ( method -- quot )\r
  28     dup "method-generic" word-prop dispatch# object <array>\r
  29     swap "method-class" word-prop prefix ;\r
  30 \r
  31 : specialize-method ( quot method -- quot' )\r
  32     method-declaration [ declare ] curry prepend ;\r
  33 \r
  34 : specialize-quot ( quot specializer -- quot' )\r
  35     specializer-cases alist>quot ;\r
  36 \r
  37 : standard-method? ( method -- ? )\r
  38     dup method-body? [\r
  39         "method-generic" word-prop standard-generic?\r
  40     ] [ drop f ] if ;\r
  41 \r
  42 : specialized-def ( word -- quot )\r
  43     dup def>> swap {\r
  44         { [ dup standard-method? ] [ specialize-method ] }\r
  45         {\r
  46             [ dup "specializer" word-prop ]\r
  47             [ "specializer" word-prop specialize-quot ]\r
  48         }\r
  49         [ drop ]\r
  50     } cond ;\r
  51 \r
  52 : specialized-length ( specializer -- n )\r
  53     dup [ array? ] all? [ first ] when length ;\r