basis/hints/hints.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs byte-arrays byte-vectors classes
   4 combinators definitions fry generic generic.single
   5 generic.standard hashtables kernel kernel.private math
   6 math.parser parser sbufs sequences splitting strings vectors
   7 words ;
   8 IN: hints
   9
  10 GENERIC: specializer-predicate ( spec -- quot )
  11
  12 M: class specializer-predicate '[ _ instance? ] ;
  13
  14 M: object specializer-predicate '[ _ eq? ] ;
  15
  16 GENERIC: specializer-declaration ( spec -- class )
  17
  18 M: class specializer-declaration ;
  19
  20 M: object specializer-declaration class-of ;
  21
  22 : specializer ( word -- specializer )
  23     "specializer" word-prop ;
  24
  25 : make-specializer ( specs -- quot )
  26     dup length <iota> <reversed>
  27     [ (picker) 2array ] 2map
  28     [ drop object eq? ] assoc-reject
  29     [ [ t ] ] [
  30         [ swap specializer-predicate append ] { } assoc>map
  31         [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
  32     ] if-empty ;
  33
  34 : specializer-cases ( quot specializer -- alist )
  35     dup [ array? ] all? [ 1array ] unless [
  36         [ nip make-specializer ]
  37         [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
  38     ] with { } map>assoc ;
  39
  40 : specialize-quot ( quot specializer -- quot' )
  41     [ drop ] [ specializer-cases ] 2bi alist>quot ;
  42
  43 : method-declaration ( method -- quot )
  44     [ "method-generic" word-prop dispatch# object <array> ]
  45     [ "method-class" word-prop ]
  46     bi prefix [ declare ] curry [ ] like ;
  47
  48 : specialize-method ( quot method -- quot' )
  49     [ method-declaration prepend ]
  50     [ "method-generic" word-prop ] bi
  51     specializer [ specialize-quot ] when* ;
  52
  53 : standard-method? ( method -- ? )
  54     dup method? [
  55         "method-generic" word-prop standard-generic?
  56     ] [ drop f ] if ;
  57
  58 : specialized-def ( word -- quot )
  59     [ def>> ] keep
  60     dup generic? [ drop ] [
  61         [ dup standard-method? [ specialize-method ] [ drop ] if ]
  62         [ specializer [ specialize-quot ] when* ]
  63         bi
  64     ] if ;
  65
  66 : specialized-length ( specializer -- n )
  67     dup [ array? ] all? [ first ] when length ;
  68
  69 ERROR: cannot-specialize word specializer ;
  70
  71 : set-specializer ( word specializer -- )
  72     over inline-recursive? [ cannot-specialize ] when
  73     "specializer" set-word-prop ;
  74
  75 SYNTAX: HINTS:
  76     scan-object dup wrapper? [ wrapped>> ] when
  77     [ changed-definition ]
  78     [ subwords [ changed-definition ] each ]
  79     [ parse-definition { } like set-specializer ] tri ;
  80
  81 ! Default specializers
  82 { pop* pop push last } [
  83     { vector } set-specializer
  84 ] each
  85
  86 \ set-last { { object vector } } set-specializer
  87
  88 \ push-all
  89 { { string sbuf } { array vector } { byte-array byte-vector } }
  90 set-specializer
  91
  92 { append prepend } [
  93     { { string string } { array array } }
  94     set-specializer
  95 ] each
  96
  97 { suffix prefix } [
  98     { { string object } { array object } }
  99     set-specializer
 100 ] each
 101
 102 \ subseq
 103 { { fixnum fixnum string } { fixnum fixnum array } }
 104 set-specializer
 105
 106 \ reverse!
 107 { { string } { array } }
 108 set-specializer
 109
 110 \ mismatch
 111 { string string }
 112 set-specializer
 113
 114 \ >string { sbuf } set-specializer
 115
 116 \ >array { { vector } } set-specializer
 117
 118 \ >vector { { array } { vector } } set-specializer
 119
 120 \ >sbuf { string } set-specializer
 121
 122 \ split { string string } set-specializer
 123
 124 \ member? { { array } { string } } set-specializer
 125
 126 \ member-eq? { { array } { string } } set-specializer
 127
 128 \ assoc-stack { vector } set-specializer
 129
 130 \ base> { string fixnum } set-specializer
 131
 132 M\ hashtable at*
 133 { { fixnum object } { word object } }
 134 set-specializer
 135
 136 M\ hashtable set-at
 137 { { object fixnum object } { object word object } }
 138 set-specializer