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 : remove-word-props ( word seq -- )
  37     swap props>> [ delete-at ] curry each ;
  38
  39 : set-word-prop ( word value name -- )
  40     over
  41     [ pick props>> ?set-at >>props drop ]
  42     [ nip remove-word-prop ] if ;
  43
  44 : change-word-prop ( ..a word prop quot: ( ..a value -- ..b newvalue ) -- ..b )
  45     [ swap props>> ] dip change-at ; inline
  46
  47 <PRIVATE
  48
  49 : caller ( callstack -- word ) callstack>array <reversed> third ;
  50
  51 PRIVATE>
  52
  53 TUPLE: undefined-word word ;
  54
  55 : undefined ( -- * ) callstack caller undefined-word boa throw ;
  56
  57 : undefined-def ( -- quot )
  58     #! 'f' inhibits tail call optimization in non-optimizing
  59     #! compiler, ensuring that we can pull out the caller word
  60     #! above.
  61     [ undefined f ] ;
  62
  63 PREDICATE: deferred < word def>> undefined-def = ;
  64 M: deferred definer drop \ DEFER: f ;
  65 M: deferred definition drop f ;
  66
  67 PREDICATE: primitive < word "primitive" word-prop ;
  68 M: primitive definer drop \ PRIMITIVE: f ;
  69 M: primitive definition drop f ;
  70
  71 : lookup-word ( name vocab -- word ) vocab-words-assoc at ;
  72
  73 : target-word ( word -- target )
  74     [ name>> ] [ vocabulary>> ] bi lookup-word ;
  75
  76 SYMBOL: bootstrapping?
  77
  78 : if-bootstrapping ( true false -- )
  79     [ bootstrapping? get ] 2dip if ; inline
  80
  81 : bootstrap-word ( word -- target )
  82     [ target-word ] [ ] if-bootstrapping ;
  83
  84 GENERIC: crossref? ( word -- ? )
  85
  86 M: word crossref?
  87     dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ;
  88
  89 GENERIC: subwords ( word -- seq )
  90
  91 M: word subwords drop f ;
  92
  93 GENERIC: parent-word ( word -- word/f )
  94
  95 M: word parent-word drop f ;
  96
  97 : define ( word def -- )
  98     over changed-definition [ ] like >>def drop ;
  99
 100 : changed-effect ( word -- )
 101     [ changed-effects get add-to-unit ]
 102     [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
 103
 104 : set-stack-effect ( effect word -- )
 105     2dup "declared-effect" word-prop = [ 2drop ] [
 106         [ nip changed-effect ]
 107         [ nip subwords [ changed-effect ] each ]
 108         [ swap "declared-effect" set-word-prop ]
 109         2tri
 110     ] if ;
 111
 112 : define-declared ( word def effect -- )
 113     [ nip swap set-stack-effect ] [ drop define ] 3bi ;
 114
 115 : make-deprecated ( word -- )
 116     t "deprecated" set-word-prop ;
 117
 118 : inline? ( obj -- ? )
 119     dup word? [ "inline" word-prop ] [ drop f ] if ; inline
 120
 121 : recursive? ( obj -- ? )
 122     dup word? [ "recursive" word-prop ] [ drop f ] if ; inline
 123
 124 : inline-recursive? ( obj -- ? )
 125     dup word? [
 126         dup "inline" word-prop
 127         [ "recursive" word-prop ] [ drop f ] if
 128     ] [ drop f ] if ; inline
 129
 130 ERROR: cannot-be-inline word ;
 131
 132 GENERIC: make-inline ( word -- )
 133
 134 M: word make-inline
 135     dup inline? [ drop ] [
 136         [ t "inline" set-word-prop ]
 137         [ changed-effect ]
 138         bi
 139     ] if ;
 140
 141 : define-inline ( word def effect -- )
 142     [ define-declared ] [ 2drop make-inline ] 3bi ;
 143
 144 : make-recursive ( word -- )
 145     t "recursive" set-word-prop ;
 146
 147 GENERIC: flushable? ( word -- ? )
 148
 149 M: word flushable?
 150     [ "flushable" word-prop ]
 151     [ parent-word dup [ flushable? ] when ] bi or ;
 152
 153 : make-flushable ( word -- )
 154     t "flushable" set-word-prop ;
 155
 156 GENERIC: foldable? ( word -- ? )
 157
 158 M: word foldable?
 159     [ "foldable" word-prop ]
 160     [ parent-word dup [ foldable? ] when ] bi or ;
 161
 162 : make-foldable ( word -- )
 163     dup make-flushable t "foldable" set-word-prop ;
 164
 165 GENERIC: reset-word ( word -- )
 166
 167 M: word reset-word
 168     dup flushable? [ dup changed-conditionally ] when
 169     {
 170         "unannotated-def" "parsing" "inline" "recursive"
 171         "foldable" "flushable" "reading" "writing" "reader"
 172         "writer" "delimiter" "deprecated"
 173     } remove-word-props ;
 174
 175 : reset-generic ( word -- )
 176     [ subwords forget-all ]
 177     [ reset-word ]
 178     [
 179         f >>pic-def
 180         f >>pic-tail-def
 181         {
 182             "methods"
 183             "combination"
 184             "default-method"
 185             "engines"
 186             "decision-tree"
 187         } remove-word-props
 188     ] tri ;
 189
 190 : <word> ( name vocab -- word )
 191     2dup [ hashcode ] bi@ hash-combine >fixnum (word) dup new-word ;
 192
 193 : <uninterned-word> ( name -- word )
 194     f \ <uninterned-word> counter >fixnum (word)
 195     new-words get [ dup new-word ] when ;
 196
 197 : gensym ( -- word )
 198     "( gensym )" <uninterned-word> ;
 199
 200 : define-temp ( quot effect -- word )
 201     [ gensym dup ] 2dip define-declared ;
 202
 203 : reveal ( word -- )
 204     dup [ name>> ] [ vocabulary>> ] bi dup vocab-words-assoc
 205     [ ] [ no-vocab ] ?if 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-word ( name vocab -- word )
 214     check-create 2dup lookup-word
 215     [ 2nip ] [
 216         vocab-name <word>
 217         dup reveal
 218         dup changed-definition
 219     ] if* ;
 220
 221 : constructor-word ( name vocab -- word )
 222     [ "<" ">" surround ] dip create-word ;
 223
 224 PREDICATE: parsing-word < word "parsing" word-prop ;
 225
 226 M: parsing-word definer drop \ SYNTAX: \ ; ;
 227
 228 : define-syntax ( word quot -- )
 229     [ drop ] [ define ] 2bi t "parsing" set-word-prop ;
 230
 231 : delimiter? ( obj -- ? )
 232     dup word? [ "delimiter" word-prop ] [ drop f ] if ;
 233
 234 : deprecated? ( obj -- ? )
 235     dup word? [ "deprecated" word-prop ] [ drop f ] if ;
 236
 237 ! Definition protocol
 238 M: word where "loc" word-prop ;
 239
 240 M: word set-where swap "loc" set-word-prop ;
 241
 242 M: word forget*
 243     dup "forgotten" word-prop [ drop ] [
 244         [ subwords forget-all ]
 245         [ [ name>> ] [ vocabulary>> vocab-words-assoc ] bi delete-at ]
 246         [ t "forgotten" set-word-prop ]
 247         tri
 248     ] if ;
 249
 250 M: word hashcode*
 251     nip 1 slot { fixnum } declare ; inline foldable
 252
 253 M: word literalize <wrapper> ;
 254
 255 INSTANCE: word definition-mixin