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