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