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