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