core/words/words.factor

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