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 effects fry generic generic.single
   5 generic.standard hashtables io.binary io.encodings
   6 io.streams.string kernel kernel.private math math.parser
   7 namespaces parser sbufs sequences sequences.private splitting
   8 splitting.private strings vectors words ;
   9 IN: hints
  10
  11 GENERIC: specializer-predicate ( spec -- quot )
  12
  13 M: class specializer-predicate predicate-def ;
  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-of ;
  22
  23 : specializer ( word -- specializer )
  24     "specializer" word-prop ;
  25
  26 : make-specializer ( specs -- quot )
  27     dup length iota <reversed>
  28     [ (picker) 2array ] 2map
  29     [ drop object eq? ] assoc-reject
  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 : method-declaration ( method -- quot )
  45     [ "method-generic" word-prop dispatch# object <array> ]
  46     [ "method-class" word-prop ]
  47     bi prefix [ declare ] curry [ ] like ;
  48
  49 : specialize-method ( quot method -- quot' )
  50     [ method-declaration prepend ]
  51     [ "method-generic" word-prop ] bi
  52     specializer [ specialize-quot ] when* ;
  53
  54 : standard-method? ( method -- ? )
  55     dup method? [
  56         "method-generic" word-prop standard-generic?
  57     ] [ drop f ] if ;
  58
  59 : specialized-def ( word -- quot )
  60     [ def>> ] keep
  61     dup generic? [ drop ] [
  62         [ dup standard-method? [ specialize-method ] [ drop ] if ]
  63         [ specializer [ specialize-quot ] when* ]
  64         bi
  65     ] if ;
  66
  67 : specialized-length ( specializer -- n )
  68     dup [ array? ] all? [ first ] when length ;
  69
  70 ERROR: cannot-specialize word specializer ;
  71
  72 : set-specializer ( word specializer -- )
  73     over inline-recursive? [ throw-cannot-specialize ] when
  74     "specializer" set-word-prop ;
  75
  76 SYNTAX: HINTS:
  77     scan-object dup wrapper? [ wrapped>> ] when
  78     [ changed-definition ]
  79     [ subwords [ changed-definition ] each ]
  80     [ parse-definition { } like set-specializer ] tri ;
  81
  82 ! Default specializers
  83 { pop* pop push last } [
  84     { vector } set-specializer
  85 ] each
  86
  87 \ set-last { { object vector } } set-specializer
  88
  89 \ push-all
  90 { { string sbuf } { array vector } { byte-array byte-vector } }
  91 set-specializer
  92
  93 { append prepend } [
  94     { { string string } { array array } }
  95     set-specializer
  96 ] each
  97
  98 { subseq subseq-unsafe } [
  99     { { fixnum fixnum string } { fixnum fixnum array } }
 100     set-specializer
 101 ] each
 102
 103 \ reverse!
 104 { { string } { array } }
 105 set-specializer
 106
 107 \ mismatch
 108 { string string }
 109 set-specializer
 110
 111 \ >string { sbuf } set-specializer
 112
 113 \ >array { { vector } } set-specializer
 114
 115 \ >vector { { array } { vector } } set-specializer
 116
 117 \ >sbuf { string } set-specializer
 118
 119 \ split { string string } set-specializer
 120
 121 \ member? { { array } { string } } set-specializer
 122
 123 \ member-eq? { { array } { string } } set-specializer
 124
 125 \ assoc-stack { vector } set-specializer
 126
 127 { >le >be } [
 128     { { fixnum fixnum } { bignum fixnum } }
 129     set-specializer
 130 ] each
 131
 132 { le> be> } [
 133     { byte-array } set-specializer
 134 ] each
 135
 136 \ base> { string fixnum } set-specializer
 137
 138 M\ hashtable at*
 139 { { fixnum object } { word object } }
 140 set-specializer
 141
 142 M\ hashtable set-at
 143 { { object fixnum object } { object word object } }
 144 set-specializer