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