basis/hints/hints.factor

   1 ! Copyright (C) 2008, 2009 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 effects fry generic generic.single
   5 generic.standard hashtables io.binary io.streams.string kernel
   6 kernel.private math math.parser math.parser.private namespaces
   7 parser sbufs sequences splitting splitting.private strings
   8 vectors words ;
   9 IN: hints
  10
  11 GENERIC: specializer-predicate ( spec -- quot )
  12
  13 M: class specializer-predicate "predicate" word-prop ;
  14
  15 M: object specializer-predicate '[ _ eq? ] ;
  16
  17 GENERIC: specializer-declaration ( spec -- class )
  18
  19 M: class specializer-declaration ;
  20
  21 M: object specializer-declaration class ;
  22
  23 : specializer ( word -- specializer )
  24     "specializer" word-prop ;
  25
  26 : make-specializer ( specs -- quot )
  27     dup length <reversed>
  28     [ (picker) 2array ] 2map
  29     [ drop object eq? not ] assoc-filter
  30     [ [ t ] ] [
  31         [ swap specializer-predicate append ] { } assoc>map
  32         [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
  33     ] if-empty ;
  34
  35 : specializer-cases ( quot specializer -- alist )
  36     dup [ array? ] all? [ 1array ] unless [
  37         [ nip make-specializer ]
  38         [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
  39     ] with { } map>assoc ;
  40
  41 : specialize-quot ( quot specializer -- quot' )
  42     [ drop ] [ specializer-cases ] 2bi alist>quot ;
  43
  44 ! compiler.tree.propagation.inlining sets this to f
  45 SYMBOL: specialize-method?
  46
  47 t specialize-method? set-global
  48
  49 : method-declaration ( method -- quot )
  50     [ "method-generic" word-prop dispatch# object <array> ]
  51     [ "method-class" word-prop ]
  52     bi prefix [ declare ] curry [ ] like ;
  53
  54 : specialize-method ( quot method -- quot' )
  55     [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
  56     [ "method-generic" word-prop ] bi
  57     specializer [ specialize-quot ] when* ;
  58
  59 : standard-method? ( method -- ? )
  60     dup method-body? [
  61         "method-generic" word-prop standard-generic?
  62     ] [ drop f ] if ;
  63
  64 : specialized-def ( word -- quot )
  65     [ def>> ] keep
  66     dup generic? [ drop ] [
  67         [ dup standard-method? [ specialize-method ] [ drop ] if ]
  68         [ specializer [ specialize-quot ] when* ]
  69         bi
  70     ] if ;
  71
  72 : specialized-length ( specializer -- n )
  73     dup [ array? ] all? [ first ] when length ;
  74
  75 SYNTAX: HINTS:
  76     scan-object dup wrapper? [ wrapped>> ] when
  77     [ changed-definition ]
  78     [ subwords [ changed-definition ] each ]
  79     [ parse-definition { } like "specializer" set-word-prop ] tri ;
  80
  81 ! Default specializers
  82 { last pop* pop } [
  83     { vector } "specializer" set-word-prop
  84 ] each
  85
  86 \ push { { vector } { sbuf } } "specializer" set-word-prop
  87
  88 \ last { { vector } } "specializer" set-word-prop
  89
  90 \ set-last { { object vector } } "specializer" set-word-prop
  91
  92 \ push-all
  93 { { string sbuf } { array vector } { byte-array byte-vector } }
  94 "specializer" set-word-prop
  95
  96 \ append
  97 { { string string } { array array } }
  98 "specializer" set-word-prop
  99
 100 \ subseq
 101 { { fixnum fixnum string } { fixnum fixnum array } }
 102 "specializer" set-word-prop
 103
 104 \ reverse!
 105 { { string } { array } }
 106 "specializer" set-word-prop
 107
 108 \ mismatch
 109 { string string }
 110 "specializer" set-word-prop
 111
 112 \ >string { sbuf } "specializer" set-word-prop
 113
 114 \ >array { { vector } } "specializer" set-word-prop
 115
 116 \ >vector { { array } { vector } } "specializer" set-word-prop
 117
 118 \ >sbuf { string } "specializer" set-word-prop
 119
 120 \ split, { string string } "specializer" set-word-prop
 121
 122 \ memq? { array } "specializer" set-word-prop
 123
 124 \ member? { array } "specializer" set-word-prop
 125
 126 \ assoc-stack { vector } "specializer" set-word-prop
 127
 128 \ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
 129
 130 \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
 131
 132 \ base> { string fixnum } "specializer" set-word-prop
 133
 134 M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
 135
 136 M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
 137
 138 \ dec>float { string } "specializer" set-word-prop
 139
 140 \ hex>float { string } "specializer" set-word-prop
 141
 142 \ string>integer { string fixnum } "specializer" set-word-prop
 143