basis/hints/hints.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: parser words definitions kernel sequences assocs arrays
   4 kernel.private fry combinators accessors vectors strings sbufs
   5 byte-arrays byte-vectors io.binary io.streams.string splitting
   6 math generic generic.standard generic.standard.engines classes
   7 hashtables ;
   8 IN: hints
   9
  10 GENERIC: specializer-predicate ( spec -- quot )
  11
  12 M: class specializer-predicate "predicate" word-prop ;
  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 ;
  21
  22 : make-specializer ( specs -- quot )
  23     dup length <reversed>
  24     [ (picker) 2array ] 2map
  25     [ drop object eq? not ] assoc-filter
  26     [ [ t ] ] [
  27         [ swap specializer-predicate append ] { } assoc>map
  28         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
  29     ] if-empty ;
  30
  31 : specializer-cases ( quot word -- default alist )
  32     dup [ array? ] all? [ 1array ] unless [
  33         [ make-specializer ] keep
  34         [ specializer-declaration ] map '[ _ declare ] pick append
  35     ] { } map>assoc ;
  36
  37 : method-declaration ( method -- quot )
  38     [ "method-generic" word-prop dispatch# object <array> ]
  39     [ "method-class" word-prop ]
  40     bi prefix ;
  41
  42 : specialize-method ( quot method -- quot' )
  43     method-declaration '[ _ declare ] prepend ;
  44
  45 : specialize-quot ( quot specializer -- quot' )
  46     specializer-cases alist>quot ;
  47
  48 : standard-method? ( method -- ? )
  49     dup method-body? [
  50         "method-generic" word-prop standard-generic?
  51     ] [ drop f ] if ;
  52
  53 : specialized-def ( word -- quot )
  54     [ def>> ] keep
  55     [ dup standard-method? [ specialize-method ] [ drop ] if ]
  56     [ "specializer" word-prop [ specialize-quot ] when* ]
  57     bi ;
  58
  59 : specialized-length ( specializer -- n )
  60     dup [ array? ] all? [ first ] when length ;
  61
  62 : HINTS:
  63     scan-object
  64     dup method-spec? [ first2 method ] when
  65     [ redefined ]
  66     [ parse-definition "specializer" set-word-prop ] bi ;
  67     parsing
  68
  69 ! Default specializers
  70 { first first2 first3 first4 }
  71 [ { array } "specializer" set-word-prop ] each
  72
  73 { peek pop* pop } [
  74     { vector } "specializer" set-word-prop
  75 ] each
  76
  77 \ push { { vector } { sbuf } } "specializer" set-word-prop
  78
  79 \ push-all
  80 { { string sbuf } { array vector } { byte-array byte-vector } }
  81 "specializer" set-word-prop
  82
  83 \ append
  84 { { string string } { array array } }
  85 "specializer" set-word-prop
  86
  87 \ subseq
  88 { { fixnum fixnum string } { fixnum fixnum array } }
  89 "specializer" set-word-prop
  90
  91 \ reverse-here
  92 { { string } { array } }
  93 "specializer" set-word-prop
  94
  95 \ mismatch
  96 { string string }
  97 "specializer" set-word-prop
  98
  99 \ find-last-sep { string sbuf } "specializer" set-word-prop
 100
 101 \ >string { sbuf } "specializer" set-word-prop
 102
 103 \ >array { { vector } } "specializer" set-word-prop
 104
 105 \ >vector { { array } { vector } } "specializer" set-word-prop
 106
 107 \ >sbuf { string } "specializer" set-word-prop
 108
 109 \ split, { string string } "specializer" set-word-prop
 110
 111 \ memq? { array } "specializer" set-word-prop
 112
 113 \ member? { array } "specializer" set-word-prop
 114
 115 \ assoc-stack { vector } "specializer" set-word-prop
 116
 117 \ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
 118
 119 \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
 120
 121 \ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop
 122
 123 \ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop