core/words/words.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays definitions graphs assocs kernel
   4 kernel.private slots.private math namespaces sequences strings
   5 vectors sbufs quotations assocs hashtables sorting words.private
   6 vocabs math.order sets ;
   7 IN: words
   8
   9 : word ( -- word ) \ word get-global ;
  10
  11 : set-word ( word -- ) \ word set-global ;
  12
  13 GENERIC: execute ( word -- )
  14
  15 M: word execute (execute) ;
  16
  17 M: word <=>
  18     [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
  19
  20 M: word definer drop \ : \ ; ;
  21
  22 M: word definition def>> ;
  23
  24 ERROR: undefined ;
  25
  26 PREDICATE: deferred < word ( obj -- ? )
  27     def>> [ undefined ] = ;
  28 M: deferred definer drop \ DEFER: f ;
  29 M: deferred definition drop f ;
  30
  31 PREDICATE: symbol < word ( obj -- ? )
  32     [ def>> ] [ [ ] curry ] bi sequence= ;
  33 M: symbol definer drop \ SYMBOL: f ;
  34 M: symbol definition drop f ;
  35
  36 PREDICATE: primitive < word ( obj -- ? )
  37     def>> [ do-primitive ] tail? ;
  38 M: primitive definer drop \ PRIMITIVE: f ;
  39 M: primitive definition drop f ;
  40
  41 : word-prop ( word name -- value ) swap props>> at ;
  42
  43 : remove-word-prop ( word name -- ) swap props>> delete-at ;
  44
  45 : set-word-prop ( word value name -- )
  46     over
  47     [ pick props>> ?set-at >>props drop ]
  48     [ nip remove-word-prop ] if ;
  49
  50 : reset-props ( word seq -- ) [ remove-word-prop ] with each ;
  51
  52 : lookup ( name vocab -- word ) vocab-words at ;
  53
  54 : target-word ( word -- target )
  55     [ name>> ] [ vocabulary>> ] bi lookup ;
  56
  57 SYMBOL: bootstrapping?
  58
  59 : if-bootstrapping ( true false -- )
  60     bootstrapping? get -rot if ; inline
  61
  62 : bootstrap-word ( word -- target )
  63     [ target-word ] [ ] if-bootstrapping ;
  64
  65 GENERIC: crossref? ( word -- ? )
  66
  67 M: word crossref?
  68     dup "forgotten" word-prop [
  69         drop f
  70     ] [
  71         vocabulary>> >boolean
  72     ] if ;
  73
  74 GENERIC: compiled-crossref? ( word -- ? )
  75
  76 M: word compiled-crossref? crossref? ;
  77
  78 GENERIC# (quot-uses) 1 ( obj assoc -- )
  79
  80 M: object (quot-uses) 2drop ;
  81
  82 M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
  83
  84 : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
  85
  86 M: array (quot-uses) seq-uses ;
  87
  88 M: callable (quot-uses) seq-uses ;
  89
  90 M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ;
  91
  92 : quot-uses ( quot -- assoc )
  93     global [ H{ } clone [ (quot-uses) ] keep ] bind ;
  94
  95 M: word uses ( word -- seq )
  96     def>> quot-uses keys ;
  97
  98 SYMBOL: compiled-crossref
  99
 100 compiled-crossref global [ H{ } assoc-like ] change-at
 101
 102 : compiled-xref ( word dependencies -- )
 103     [ drop crossref? ] assoc-filter
 104     [ "compiled-uses" set-word-prop ]
 105     [ compiled-crossref get add-vertex* ]
 106     2bi ;
 107
 108 : compiled-unxref ( word -- )
 109     [
 110         dup "compiled-uses" word-prop
 111         compiled-crossref get remove-vertex*
 112     ]
 113     [ f "compiled-uses" set-word-prop ] bi ;
 114
 115 : delete-compiled-xref ( word -- )
 116     dup compiled-unxref
 117     compiled-crossref get delete-at ;
 118
 119 : compiled-usage ( word -- assoc )
 120     compiled-crossref get at ;
 121
 122 : compiled-usages ( assoc -- seq )
 123     clone [
 124         dup [
 125             [
 126                 [ compiled-usage ] dip
 127                 +inlined+ eq? [
 128                     [ nip +inlined+ eq? ] assoc-filter
 129                 ] when
 130             ] dip swap update
 131         ] curry assoc-each
 132     ] keep keys ;
 133
 134 GENERIC: redefined ( word -- )
 135
 136 M: object redefined drop ;
 137
 138 : define ( word def -- )
 139     [ ] like
 140     over unxref
 141     over redefined
 142     >>def
 143     dup +inlined+ changed-definition
 144     dup crossref? [ dup xref ] when drop ;
 145
 146 : set-stack-effect ( effect word -- )
 147     2dup "declared-effect" word-prop = [ 2drop ] [
 148         swap
 149         [ "declared-effect" set-word-prop ]
 150         [
 151             drop
 152             dup primitive? [ drop ] [
 153                 [ redefined ] [ +inlined+ changed-definition ] bi
 154             ] if
 155         ] 2bi
 156     ] if ;
 157
 158 : define-declared ( word def effect -- )
 159     pick swap "declared-effect" set-word-prop
 160     define ;
 161
 162 : make-inline ( word -- )
 163     t "inline" set-word-prop ;
 164
 165 : make-flushable ( word -- )
 166     t "flushable" set-word-prop ;
 167
 168 : make-foldable ( word -- )
 169     dup make-flushable t "foldable" set-word-prop ;
 170
 171 : define-inline ( word quot -- )
 172     dupd define make-inline ;
 173
 174 : define-symbol ( word -- )
 175     dup [ ] curry define-inline ;
 176
 177 GENERIC: reset-word ( word -- )
 178
 179 M: word reset-word
 180     {
 181         "unannotated-def"
 182         "parsing" "inline" "foldable" "flushable"
 183         "predicating"
 184         "reading" "writing"
 185         "constructing"
 186         "declared-effect" "constructor-quot" "delimiter"
 187     } reset-props ;
 188
 189 GENERIC: subwords ( word -- seq )
 190
 191 M: word subwords drop f ;
 192
 193 : reset-generic ( word -- )
 194     [ subwords forget-all ]
 195     [ reset-word ]
 196     [ { "methods" "combination" "default-method" } reset-props ]
 197     tri ;
 198
 199 : gensym ( -- word )
 200     "( gensym )" f <word> ;
 201
 202 : define-temp ( quot -- word )
 203     gensym dup rot define ;
 204
 205 : reveal ( word -- )
 206     dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
 207     [ ] [ no-vocab ] ?if
 208     set-at ;
 209
 210 ERROR: bad-create name vocab ;
 211
 212 : check-create ( name vocab -- name vocab )
 213     2dup [ string? ] both?
 214     [ bad-create ] unless ;
 215
 216 : create ( name vocab -- word )
 217     check-create 2dup lookup
 218     dup [ 2nip ] [ drop <word> dup reveal ] if ;
 219
 220 : constructor-word ( name vocab -- word )
 221     >r "<" swap ">" 3append r> create ;
 222
 223 PREDICATE: parsing-word < word "parsing" word-prop ;
 224
 225 : delimiter? ( obj -- ? )
 226     dup word? [ "delimiter" word-prop ] [ drop f ] if ;
 227
 228 ! Definition protocol
 229 M: word where "loc" word-prop ;
 230
 231 M: word set-where swap "loc" set-word-prop ;
 232
 233 M: word forget*
 234     dup "forgotten" word-prop [ drop ] [
 235         [ delete-xref ]
 236         [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
 237         [ t "forgotten" set-word-prop ]
 238         tri
 239     ] if ;
 240
 241 M: word hashcode*
 242     nip 1 slot { fixnum } declare ;
 243
 244 M: word literalize <wrapper> ;
 245
 246 : ?word-name ( word -- name ) dup word? [ name>> ] when ;
 247
 248 : xref-words ( -- ) all-words [ xref ] each ;