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