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