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