core/words/words.factor

   1 ! Copyright (C) 2004, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: words
   4 USING: arrays definitions graphs assocs kernel kernel.private
   5 slots.private math namespaces sequences strings vectors sbufs
   6 quotations assocs hashtables sorting math.parser words.private
   7 vocabs ;
   8
   9 GENERIC: execute ( word -- )
  10
  11 M: word execute (execute) ;
  12
  13 : word ( -- word ) \ word get-global ;
  14
  15 : set-word ( word -- ) \ word set-global ;
  16
  17 ! Used by the compiler
  18 SYMBOL: changed-words
  19
  20 : word-changed? ( word -- ? )
  21     changed-words get [ key? ] [ drop f ] if* ;
  22
  23 : changed-word ( word -- )
  24     dup changed-words get [ set-at ] [ 2drop ] if* ;
  25
  26 : unchanged-word ( word -- )
  27     changed-words get [ delete-at ] [ drop ] if* ;
  28
  29 M: word <=>
  30     [ dup word-name swap word-vocabulary 2array ] compare ;
  31
  32 M: word definition drop f ;
  33
  34 PREDICATE: word undefined ( obj -- ? ) word-def not ;
  35 M: undefined definer drop \ DEFER: f ;
  36
  37 PREDICATE: word compound  ( obj -- ? ) word-def quotation? ;
  38
  39 M: compound definer drop \ : \ ; ;
  40
  41 M: compound definition word-def ;
  42
  43 PREDICATE: word primitive ( obj -- ? ) word-def fixnum? ;
  44 M: primitive definer drop \ PRIMITIVE: f ;
  45
  46 PREDICATE: word symbol    ( obj -- ? ) word-def t eq? ;
  47 M: symbol definer drop \ SYMBOL: f ;
  48
  49 : word-prop ( word name -- value ) swap word-props at ;
  50
  51 : remove-word-prop ( word name -- )
  52     swap word-props delete-at ;
  53
  54 : set-word-prop ( word value name -- )
  55     over
  56     [ pick word-props ?set-at swap set-word-props ]
  57     [ nip remove-word-prop ] if ;
  58
  59 : reset-props ( word seq -- ) [ remove-word-prop ] curry* each ;
  60
  61 : lookup ( name vocab -- word ) vocab-words at ;
  62
  63 : target-word ( word -- target )
  64     dup word-name swap word-vocabulary lookup ;
  65
  66 SYMBOL: bootstrapping?
  67
  68 : if-bootstrapping ( true false -- )
  69     bootstrapping? get -rot if ; inline
  70
  71 : bootstrap-word ( word -- target )
  72     [ target-word ] [ ] if-bootstrapping ;
  73
  74 PREDICATE: word interned dup target-word eq? ;
  75
  76 GENERIC# (quot-uses) 1 ( obj assoc -- )
  77
  78 M: object (quot-uses) 2drop ;
  79
  80 M: interned (quot-uses) dupd set-at ;
  81
  82 : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
  83
  84 M: array (quot-uses) seq-uses ;
  85
  86 M: callable (quot-uses) seq-uses ;
  87
  88 M: wrapper (quot-uses) >r wrapped r> (quot-uses) ;
  89
  90 : quot-uses ( quot -- assoc )
  91     global [ H{ } clone [ (quot-uses) ] keep ] bind ;
  92
  93 M: word uses ( word -- seq )
  94     word-def quot-uses keys ;
  95
  96 M: compound redefined* ( word -- )
  97     dup changed-word
  98     { "inferred-effect" "base-case" "no-effect" } reset-props ;
  99
 100 <PRIVATE
 101
 102 : definition-changed? ( word def -- ? )
 103     swap word-def = not ;
 104
 105 : define ( word def -- )
 106     2dup definition-changed? [
 107         over redefined
 108         over unxref
 109         over set-word-def
 110         dup update-xt
 111         dup word-vocabulary [
 112             dup changed-word dup xref
 113         ] when drop
 114     ] [
 115         2drop
 116     ] if ;
 117
 118 PRIVATE>
 119
 120 : define-symbol ( word -- ) t define ;
 121
 122 : intern-symbol ( word -- )
 123     dup undefined? [ define-symbol ] [ drop ] if ;
 124
 125 : define-compound ( word def -- ) [ ] like define ;
 126
 127 : define-declared ( word def effect -- )
 128     pick swap "declared-effect" set-word-prop
 129     define-compound ;
 130
 131 : make-inline ( word -- )
 132     t "inline" set-word-prop ;
 133
 134 : make-flushable ( word -- )
 135     t "flushable" set-word-prop ;
 136
 137 : make-foldable ( word -- )
 138     dup make-flushable t "foldable" set-word-prop ;
 139
 140 : define-inline ( word quot -- )
 141     dupd define-compound make-inline ;
 142
 143 : reset-word ( word -- )
 144     {
 145         "parsing" "inline" "foldable"
 146         "predicating"
 147         "reading" "writing"
 148         "constructing"
 149         "declared-effect" "constructor-quot" "delimiter"
 150     } reset-props ;
 151
 152 : reset-generic ( word -- )
 153     dup reset-word { "methods" "combination" } reset-props ;
 154
 155 : gensym ( -- word )
 156     "G:" \ gensym counter number>string append f <word> ;
 157
 158 : define-temp ( quot -- word )
 159     gensym [ swap define-compound ] keep ;
 160
 161 : reveal ( word -- )
 162     dup word-name over word-vocabulary vocab-words set-at ;
 163
 164 TUPLE: check-create name vocab ;
 165
 166 : check-create ( name vocab -- name vocab )
 167     2dup [ string? ] both? [
 168         \ check-create construct-boa throw
 169     ] unless ;
 170
 171 : create ( name vocab -- word )
 172     check-create 2dup lookup
 173     dup [ 2nip ] [ drop <word> dup reveal ] if ;
 174
 175 : constructor-word ( name vocab -- word )
 176     >r "<" swap ">" 3append r> create ;
 177
 178 : parsing? ( obj -- ? )
 179     dup word? [ "parsing" word-prop ] [ drop f ] if ;
 180
 181 : delimiter? ( obj -- ? )
 182     dup word? [ "delimiter" word-prop ] [ drop f ] if ;
 183
 184 ! Definition protocol
 185 M: word where "loc" word-prop ;
 186
 187 M: word set-where swap "loc" set-word-prop ;
 188
 189 GENERIC: (forget-word) ( word -- )
 190
 191 M: interned (forget-word)
 192     dup word-name swap word-vocabulary vocab-words delete-at ;
 193
 194 M: word (forget-word)
 195     drop ;
 196
 197 : rename-word ( word newname newvocab -- )
 198     pick (forget-word)
 199     pick set-word-vocabulary
 200     over set-word-name
 201     reveal ;
 202
 203 : forget-word ( word -- )
 204     dup f "methods" set-word-prop
 205     dup delete-xref
 206     dup unchanged-word
 207     (forget-word) ;
 208
 209 M: word forget forget-word ;
 210
 211 M: word hashcode*
 212     nip 1 slot { fixnum } declare ;
 213
 214 M: word literalize <wrapper> ;
 215
 216 : ?word-name dup word? [ word-name ] when ;
 217
 218 : xref-words ( -- ) all-words [ xref ] each ;