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 -rot 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 global [ H{ } assoc-like ] change-at
 100
 101 SYMBOL: compiled-generic-crossref
 102
 103 compiled-generic-crossref global [ H{ } assoc-like ] change-at
 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     [ over ] dip
 113     [ "compiled-uses" compiled-crossref (compiled-xref) ]
 114     [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
 115     2bi* ;
 116
 117 : (compiled-unxref) ( word word-prop variable -- )
 118     [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
 119     [ drop [ remove-word-prop ] curry ]
 120     2bi bi ;
 121
 122 : compiled-unxref ( word -- )
 123     [ "compiled-uses" compiled-crossref (compiled-unxref) ]
 124     [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
 125     bi ;
 126
 127 : delete-compiled-xref ( word -- )
 128     [ compiled-unxref ]
 129     [ compiled-crossref get delete-at ]
 130     [ compiled-generic-crossref get delete-at ]
 131     tri ;
 132
 133 : inline? ( word -- ? ) "inline" word-prop ; inline
 134
 135 SYMBOL: visited
 136
 137 : reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
 138
 139 : (redefined) ( word -- )
 140     dup visited get key? [ drop ] [
 141         [ reset-on-redefine reset-props ]
 142         [ visited get conjoin ]
 143         [
 144             crossref get at keys
 145             [ word? ] filter
 146             [
 147                 [ reset-on-redefine [ word-prop ] with contains? ]
 148                 [ inline? ]
 149                 bi or
 150             ] filter
 151             [ (redefined) ] each
 152         ] tri
 153     ] if ;
 154
 155 : redefined ( word -- )
 156     [ H{ } clone visited [ (redefined) ] with-variable ]
 157     [ changed-definition ]
 158     bi ;
 159
 160 : define ( word def -- )
 161     [ ] like
 162     over unxref
 163     over redefined
 164     >>def
 165     dup crossref? [ dup xref ] when drop ;
 166
 167 : set-stack-effect ( effect word -- )
 168     2dup "declared-effect" word-prop = [ 2drop ] [
 169         swap
 170         [ "declared-effect" set-word-prop ]
 171         [ drop dup primitive? [ dup redefined ] unless drop ] 2bi
 172     ] if ;
 173
 174 : define-declared ( word def effect -- )
 175     pick swap "declared-effect" set-word-prop
 176     define ;
 177
 178 : make-inline ( word -- )
 179     t "inline" set-word-prop ;
 180
 181 : make-recursive ( word -- )
 182     t "recursive" set-word-prop ;
 183
 184 : make-flushable ( word -- )
 185     t "flushable" set-word-prop ;
 186
 187 : make-foldable ( word -- )
 188     dup make-flushable t "foldable" set-word-prop ;
 189
 190 : define-inline ( word def effect -- )
 191     [ define-declared ] [ 2drop make-inline ] 3bi ;
 192
 193 GENERIC: reset-word ( word -- )
 194
 195 M: word reset-word
 196     {
 197         "unannotated-def" "parsing" "inline" "recursive"
 198         "foldable" "flushable" "reading" "writing" "reader"
 199         "writer" "declared-effect" "delimiter"
 200     } reset-props ;
 201
 202 GENERIC: subwords ( word -- seq )
 203
 204 M: word subwords drop f ;
 205
 206 : reset-generic ( word -- )
 207     [ subwords forget-all ]
 208     [ reset-word ]
 209     [ { "methods" "combination" "default-method" } reset-props ]
 210     tri ;
 211
 212 : gensym ( -- word )
 213     "( gensym )" f <word> ;
 214
 215 : define-temp ( quot -- word )
 216     [ gensym dup ] dip define ;
 217
 218 : reveal ( word -- )
 219     dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
 220     [ ] [ no-vocab ] ?if
 221     set-at ;
 222
 223 ERROR: bad-create name vocab ;
 224
 225 : check-create ( name vocab -- name vocab )
 226     2dup [ string? ] both?
 227     [ bad-create ] unless ;
 228
 229 : create ( name vocab -- word )
 230     check-create 2dup lookup
 231     dup [ 2nip ] [ drop <word> dup reveal ] if ;
 232
 233 : constructor-word ( name vocab -- word )
 234     [ "<" ">" surround ] dip create ;
 235
 236 PREDICATE: parsing-word < word "parsing" word-prop ;
 237
 238 : make-parsing ( word -- ) t "parsing" set-word-prop ;
 239
 240 : delimiter? ( obj -- ? )
 241     dup word? [ "delimiter" word-prop ] [ drop f ] if ;
 242
 243 ! Definition protocol
 244 M: word where "loc" word-prop ;
 245
 246 M: word set-where swap "loc" set-word-prop ;
 247
 248 M: word forget*
 249     dup "forgotten" word-prop [ drop ] [
 250         [ delete-xref ]
 251         [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
 252         [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
 253         tri
 254     ] if ;
 255
 256 M: word hashcode*
 257     nip 1 slot { fixnum } declare ; foldable
 258
 259 M: word literalize <wrapper> ;
 260
 261 : ?word-name ( word -- name ) dup word? [ name>> ] when ;
 262
 263 : xref-words ( -- ) all-words [ xref ] each ;