core/words/words.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays definitions graphs kernel
   4 kernel.private slots.private math namespaces sequences
   5 strings vectors sbufs quotations assocs hashtables sorting vocabs
   6 math.order sets words.private ;
   7 IN: words
   8
   9 : word ( -- word ) \ word get-global ;
  10
  11 : set-word ( word -- ) \ word set-global ;
  12
  13 M: word execute (execute) ;
  14
  15 M: word ?execute execute( -- value ) ; inline
  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 [ drop f ] [ vocabulary>> >boolean ] if ;
  66
  67 SYMBOL: compiled-crossref
  68
  69 compiled-crossref [ H{ } clone ] initialize
  70
  71 SYMBOL: compiled-generic-crossref
  72
  73 compiled-generic-crossref [ H{ } clone ] initialize
  74
  75 : (compiled-xref) ( word dependencies word-prop variable -- )
  76     [ [ set-word-prop ] curry ]
  77     [ [ get add-vertex* ] curry ]
  78     bi* 2bi ;
  79
  80 : compiled-xref ( word dependencies generic-dependencies -- )
  81     [ [ drop crossref? ] { } assoc-filter-as f like ] bi@
  82     [ "compiled-uses" compiled-crossref (compiled-xref) ]
  83     [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
  84     bi-curry* bi ;
  85
  86 : (compiled-unxref) ( word word-prop variable -- )
  87     [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
  88     [ drop [ remove-word-prop ] curry ]
  89     2bi bi ;
  90
  91 : compiled-unxref ( word -- )
  92     [ "compiled-uses" compiled-crossref (compiled-unxref) ]
  93     [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
  94     bi ;
  95
  96 : delete-compiled-xref ( word -- )
  97     [ compiled-unxref ]
  98     [ compiled-crossref get delete-at ]
  99     [ compiled-generic-crossref get delete-at ]
 100     tri ;
 101
 102 : inline? ( word -- ? ) "inline" word-prop ; inline
 103
 104 GENERIC: subwords ( word -- seq )
 105
 106 M: word subwords drop f ;
 107
 108 : define ( word def -- )
 109     over changed-definition [ ] like >>def drop ;
 110
 111 : changed-effect ( word -- )
 112     [ dup changed-effects get set-in-unit ]
 113     [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
 114
 115 : set-stack-effect ( effect word -- )
 116     2dup "declared-effect" word-prop = [ 2drop ] [
 117         [ nip changed-effect ]
 118         [ nip subwords [ changed-effect ] each ]
 119         [ swap "declared-effect" set-word-prop ]
 120         2tri
 121     ] if ;
 122
 123 : define-declared ( word def effect -- )
 124     [ nip swap set-stack-effect ] [ drop define ] 3bi ;
 125
 126 : make-deprecated ( word -- )
 127     t "deprecated" set-word-prop ;
 128
 129 : make-inline ( word -- )
 130     dup inline? [ drop ] [
 131         [ t "inline" set-word-prop ]
 132         [ changed-effect ]
 133         bi
 134     ] if ;
 135
 136 : make-recursive ( word -- )
 137     t "recursive" set-word-prop ;
 138
 139 : make-flushable ( word -- )
 140     t "flushable" set-word-prop ;
 141
 142 : make-foldable ( word -- )
 143     dup make-flushable t "foldable" set-word-prop ;
 144
 145 : define-inline ( word def effect -- )
 146     [ define-declared ] [ 2drop make-inline ] 3bi ;
 147
 148 GENERIC: reset-word ( word -- )
 149
 150 M: word reset-word
 151     {
 152         "unannotated-def" "parsing" "inline" "recursive"
 153         "foldable" "flushable" "reading" "writing" "reader"
 154         "writer" "delimiter" "deprecated"
 155     } reset-props ;
 156
 157 : reset-generic ( word -- )
 158     [ subwords forget-all ]
 159     [ reset-word ]
 160     [
 161         f >>pic-def
 162         f >>pic-tail-def
 163         {
 164             "methods"
 165             "combination"
 166             "default-method"
 167             "engines"
 168             "decision-tree"
 169         } reset-props
 170     ] tri ;
 171
 172 : <word> ( name vocab -- word )
 173     2dup [ hashcode ] bi@ bitxor >fixnum (word) ;
 174
 175 : gensym ( -- word )
 176     "( gensym )" f \ gensym counter >fixnum (word) ;
 177
 178 : define-temp ( quot effect -- word )
 179     [ gensym dup ] 2dip define-declared ;
 180
 181 : reveal ( word -- )
 182     dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
 183     [ ] [ no-vocab ] ?if
 184     set-at ;
 185
 186 ERROR: bad-create name vocab ;
 187
 188 : check-create ( name vocab -- name vocab )
 189     2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and
 190     [ bad-create ] unless ;
 191
 192 : create ( name vocab -- word )
 193     check-create 2dup lookup
 194     dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
 195
 196 : constructor-word ( name vocab -- word )
 197     [ "<" ">" surround ] dip create ;
 198
 199 PREDICATE: parsing-word < word "parsing" word-prop ;
 200
 201 M: parsing-word definer drop \ SYNTAX: \ ; ;
 202
 203 : define-syntax ( word quot -- )
 204     [ drop ] [ define ] 2bi t "parsing" set-word-prop ;
 205
 206 : delimiter? ( obj -- ? )
 207     dup word? [ "delimiter" word-prop ] [ drop f ] if ;
 208
 209 : deprecated? ( obj -- ? )
 210     dup word? [ "deprecated" word-prop ] [ drop f ] if ;
 211
 212 ! Definition protocol
 213 M: word where "loc" word-prop ;
 214
 215 M: word set-where swap "loc" set-word-prop ;
 216
 217 M: word forget*
 218     dup "forgotten" word-prop [ drop ] [
 219         [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
 220         [ t "forgotten" set-word-prop ]
 221         bi
 222     ] if ;
 223
 224 M: word hashcode*
 225     nip 1 slot { fixnum } declare ; inline foldable
 226
 227 M: word literalize <wrapper> ;
 228
 229 INSTANCE: word definition