core/words/words.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs definitions hashtables kernel
   4 kernel.private math math.order namespaces quotations sequences
   5 slots.private strings vocabs ;
   6 FROM: assocs => change-at ;
   7 IN: words
   8
   9 BUILTIN: word
  10 { hashcode fixnum initial: 0 } name vocabulary
  11 { def quotation initial: [ ] } props pic-def pic-tail-def
  12 { sub-primitive read-only } ;
  13
  14 ! Need a dummy word here because BUILTIN: word is not a real word
  15 ! and parse-datum looks for things that are actually words instead of
  16 ! also looking for classes
  17 : word ( -- * ) "dummy word" throw ;
  18
  19 : last-word ( -- word ) \ last-word get-global ;
  20
  21 : set-last-word ( word -- ) \ last-word set-global ;
  22
  23 M: word execute (execute) ;
  24
  25 M: word <=>
  26     [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
  27
  28 M: word definer drop \ : \ ; ;
  29
  30 M: word definition def>> ;
  31
  32 : word-prop ( word name -- value ) swap props>> at ;
  33
  34 : remove-word-prop ( word name -- ) swap props>> delete-at ;
  35
  36 : set-word-prop ( word value name -- )
  37     over
  38     [ pick props>> ?set-at >>props drop ]
  39     [ nip remove-word-prop ] if ;
  40
  41 : change-word-prop ( ..a word prop quot: ( ..a value -- ..b newvalue ) -- ..b )
  42     [ swap props>> ] dip change-at ; inline
  43
  44 : reset-props ( word seq -- ) [ remove-word-prop ] with each ;
  45
  46 <PRIVATE
  47
  48 : caller ( callstack -- word ) callstack>array <reversed> third ;
  49
  50 PRIVATE>
  51
  52 TUPLE: undefined-word word ;
  53
  54 : undefined ( -- * ) callstack caller undefined-word boa throw ;
  55
  56 : undefined-def ( -- quot )
  57     #! 'f' inhibits tail call optimization in non-optimizing
  58     #! compiler, ensuring that we can pull out the caller word
  59     #! above.
  60     [ undefined f ] ;
  61
  62 PREDICATE: deferred < word def>> undefined-def = ;
  63 M: deferred definer drop \ DEFER: f ;
  64 M: deferred definition drop f ;
  65
  66 PREDICATE: primitive < word "primitive" word-prop ;
  67 M: primitive definer drop \ PRIMITIVE: f ;
  68 M: primitive definition drop f ;
  69
  70 : lookup-word ( name vocab -- word ) vocab-words at ;
  71
  72 : target-word ( word -- target )
  73     [ name>> ] [ vocabulary>> ] bi lookup-word ;
  74
  75 SYMBOL: bootstrapping?
  76
  77 : if-bootstrapping ( true false -- )
  78     [ bootstrapping? get ] 2dip if ; inline
  79
  80 : bootstrap-word ( word -- target )
  81     [ target-word ] [ ] if-bootstrapping ;
  82
  83 GENERIC: crossref? ( word -- ? )
  84
  85 M: word crossref?
  86     dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ;
  87
  88 GENERIC: subwords ( word -- seq )
  89
  90 M: word subwords drop f ;
  91
  92 GENERIC: parent-word ( word -- word/f )
  93
  94 M: word parent-word drop f ;
  95
  96 : define ( word def -- )
  97     over changed-definition [ ] like >>def drop ;
  98
  99 : changed-effect ( word -- )
 100     [ changed-effects get add-to-unit ]
 101     [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
 102
 103 : set-stack-effect ( effect word -- )
 104     2dup "declared-effect" word-prop = [ 2drop ] [
 105         [ nip changed-effect ]
 106         [ nip subwords [ changed-effect ] each ]
 107         [ swap "declared-effect" set-word-prop ]
 108         2tri
 109     ] if ;
 110
 111 : define-declared ( word def effect -- )
 112     [ nip swap set-stack-effect ] [ drop define ] 3bi ;
 113
 114 : make-deprecated ( word -- )
 115     t "deprecated" set-word-prop ;
 116
 117 : inline? ( obj -- ? )
 118     dup word? [ "inline" word-prop ] [ drop f ] if ; inline
 119
 120 : recursive? ( obj -- ? )
 121     dup word? [ "recursive" word-prop ] [ drop f ] if ; inline
 122
 123 : inline-recursive? ( obj -- ? )
 124     dup word? [
 125         dup "inline" word-prop
 126         [ "recursive" word-prop ] [ drop f ] if
 127     ] [ drop f ] if ; inline
 128
 129 ERROR: cannot-be-inline word ;
 130
 131 GENERIC: make-inline ( word -- )
 132
 133 M: word make-inline
 134     dup inline? [ drop ] [
 135         [ t "inline" set-word-prop ]
 136         [ changed-effect ]
 137         bi
 138     ] if ;
 139
 140 : define-inline ( word def effect -- )
 141     [ define-declared ] [ 2drop make-inline ] 3bi ;
 142
 143 : make-recursive ( word -- )
 144     t "recursive" set-word-prop ;
 145
 146 GENERIC: flushable? ( word -- ? )
 147
 148 M: word flushable?
 149     [ "flushable" word-prop ]
 150     [ parent-word dup [ flushable? ] when ] bi or ;
 151
 152 : make-flushable ( word -- )
 153     t "flushable" set-word-prop ;
 154
 155 GENERIC: foldable? ( word -- ? )
 156
 157 M: word foldable?
 158     [ "foldable" word-prop ]
 159     [ parent-word dup [ foldable? ] when ] bi or ;
 160
 161 : make-foldable ( word -- )
 162     dup make-flushable t "foldable" set-word-prop ;
 163
 164 GENERIC: reset-word ( word -- )
 165
 166 M: word reset-word
 167     dup flushable? [ dup changed-conditionally ] when
 168     {
 169         "unannotated-def" "parsing" "inline" "recursive"
 170         "foldable" "flushable" "reading" "writing" "reader"
 171         "writer" "delimiter" "deprecated"
 172     } reset-props ;
 173
 174 : reset-generic ( word -- )
 175     [ subwords forget-all ]
 176     [ reset-word ]
 177     [
 178         f >>pic-def
 179         f >>pic-tail-def
 180         {
 181             "methods"
 182             "combination"
 183             "default-method"
 184             "engines"
 185             "decision-tree"
 186         } reset-props
 187     ] tri ;
 188
 189 : <word> ( name vocab -- word )
 190     2dup 0 hash-combine hash-combine >fixnum (word) dup new-word ;
 191
 192 : <uninterned-word> ( name -- word )
 193     f \ <uninterned-word> counter >fixnum (word)
 194     new-words get [ dup new-word ] when ;
 195
 196 : gensym ( -- word )
 197     "( gensym )" <uninterned-word> ;
 198
 199 : define-temp ( quot effect -- word )
 200     [ gensym dup ] 2dip define-declared ;
 201
 202 : reveal ( word -- )
 203     dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
 204     [ ] [ no-vocab ] ?if
 205     set-at ;
 206
 207 ERROR: bad-create name vocab ;
 208
 209 : check-create ( name vocab -- name vocab )
 210     2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and
 211     [ bad-create ] unless ;
 212
 213 : create ( name vocab -- word )
 214     check-create 2dup lookup-word
 215     dup [ 2nip ] [
 216         drop
 217         vocab-name <word>
 218         dup reveal
 219         dup changed-definition
 220     ] if ;
 221
 222 : constructor-word ( name vocab -- word )
 223     [ "<" ">" surround ] dip create ;
 224
 225 PREDICATE: parsing-word < word "parsing" word-prop ;
 226
 227 M: parsing-word definer drop \ SYNTAX: \ ; ;
 228
 229 : define-syntax ( word quot -- )
 230     [ drop ] [ define ] 2bi t "parsing" set-word-prop ;
 231
 232 : delimiter? ( obj -- ? )
 233     dup word? [ "delimiter" word-prop ] [ drop f ] if ;
 234
 235 : deprecated? ( obj -- ? )
 236     dup word? [ "deprecated" word-prop ] [ drop f ] if ;
 237
 238 ! Definition protocol
 239 M: word where "loc" word-prop ;
 240
 241 M: word set-where swap "loc" set-word-prop ;
 242
 243 M: word forget*
 244     dup "forgotten" word-prop [ drop ] [
 245         [ subwords forget-all ]
 246         [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
 247         [ t "forgotten" set-word-prop ]
 248         tri
 249     ] if ;
 250
 251 M: word hashcode*
 252     nip 1 slot { fixnum } declare ; inline foldable
 253
 254 M: word literalize <wrapper> ;
 255
 256 INSTANCE: word definition-mixin