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