core/words/words.factor

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