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