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