library/words.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: help
   4 DEFER: remove-word-help
   5
   6 IN: words
   7 USING: arrays definitions errors generic graphs hashtables
   8 kernel kernel-internals math namespaces sequences strings
   9 vectors ;
  10
  11 ! Used by the compiler
  12 SYMBOL: changed-words
  13
  14 : word-changed? ( word -- ? )
  15     changed-words get [ hash-member? ] [ drop f ] if* ;
  16
  17 : changed-word ( word -- )
  18     dup changed-words get [ set-hash ] [ 2drop ] if* ;
  19
  20 : unchanged-word ( word -- )
  21     changed-words get [ remove-hash ] [ drop ] if* ;
  22
  23 M: word <=>
  24     [ dup word-name swap word-vocabulary 2array ] 2apply <=> ;
  25
  26 GENERIC: definer ( word -- definer )
  27
  28 PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
  29 M: undefined definer drop \ DEFER: ;
  30
  31 PREDICATE: word compound  ( obj -- ? ) word-primitive 1 = ;
  32 M: compound definer drop \ : ;
  33
  34 PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;
  35 M: primitive definer drop \ PRIMITIVE: ;
  36
  37 PREDICATE: word symbol    ( obj -- ? ) word-primitive 2 = ;
  38 M: symbol definer drop \ SYMBOL: ;
  39
  40 : init-word ( word -- ) H{ } clone swap set-word-props ;
  41
  42 : word-prop ( word name -- value ) swap word-props hash ;
  43
  44 : remove-word-prop ( word name -- )
  45     swap word-props remove-hash ;
  46
  47 : set-word-prop ( word value name -- )
  48     over
  49     [ rot word-props set-hash ]
  50     [ nip remove-word-prop ] if ;
  51
  52 GENERIC: word-xt ( word -- xt )
  53 M: word word-xt 8 integer-slot ;
  54
  55 SYMBOL: vocabularies
  56
  57 : vocab ( name -- vocab ) vocabularies get hash ;
  58
  59 : lookup ( name vocab -- word ) vocab ?hash ;
  60
  61 : target-word ( word -- target )
  62     dup word-name swap word-vocabulary lookup ;
  63
  64 : interned? ( word -- ? ) dup target-word eq? ;
  65
  66 : uses ( word -- seq )
  67     word-def flatten
  68     [ word? ] subset
  69     [ global [ interned? ] bind ] subset
  70     prune ;
  71
  72 SYMBOL: crossref
  73
  74 : xref-word ( word -- )
  75     dup word-vocabulary [
  76         [ uses ] crossref get add-vertex
  77     ] [
  78         drop
  79     ] if ;
  80
  81 : usage ( word -- seq ) crossref get in-edges ;
  82
  83 : reset-props ( word seq -- ) [ remove-word-prop ] each-with ;
  84
  85 : unxref-word* ( word -- )
  86     {
  87         { [ dup compound? not ] [ drop ] }
  88         { [ dup "infer" word-prop ] [ drop ] }
  89         { [ t ] [
  90             dup changed-word
  91             { "infer-effect" "base-case" "no-effect" }
  92             reset-props
  93         ] }
  94     } cond ;
  95
  96 : unxref-word ( word -- )
  97     dup [ usage ] closure [ unxref-word* ] each
  98     [ uses ] crossref get remove-vertex ;
  99
 100 : define ( word def primitive -- )
 101     pick changed-word
 102     pick unxref-word
 103     pick set-word-primitive
 104     over set-word-def
 105     dup update-xt
 106     xref-word ;
 107
 108 : define-symbol ( word -- )
 109     dup symbol? [ drop ] [ dup 2 define ] if ;
 110
 111 : intern-symbol ( word -- )
 112     dup undefined? [ define-symbol ] [ drop ] if ;
 113
 114 : define-compound ( word def -- ) 1 define ;
 115
 116 : reset-word ( word -- )
 117     {
 118         "parsing" "inline" "foldable"
 119         "predicating" "declared-effect"
 120     } reset-props ;
 121
 122 : reset-generic ( word -- )
 123     dup reset-word { "methods" "combination" } reset-props ;
 124
 125 : <word> ( name vocab -- word ) (word) dup init-word ;
 126
 127 : gensym ( -- word )
 128     "G:" \ gensym counter number>string append f <word> ;
 129
 130 : define-temp ( quot -- word )
 131     gensym [ swap define-compound ] keep ;
 132
 133 SYMBOL: bootstrapping?
 134
 135 : word ( -- word ) \ word get-global ;
 136
 137 : set-word ( word -- ) \ word set-global ;
 138
 139 : vocabs ( -- seq ) vocabularies get hash-keys natural-sort ;
 140
 141 : ensure-vocab ( name -- ) vocabularies get [ nest drop ] bind ;
 142
 143 : words ( vocab -- seq ) vocab dup [ hash-values ] when ;
 144
 145 : all-words ( -- seq ) vocabs [ words ] map concat ;
 146
 147 : word-subset ( quot -- seq )
 148     all-words swap subset ; inline
 149
 150 : word-subset-with ( obj quot -- seq )
 151     all-words swap subset-with ; inline
 152
 153 : xref-words ( -- )
 154     all-words [ uses ] crossref get build-graph ;
 155
 156 : create-vocab ( name -- vocab )
 157     vocabularies get [ nest ] bind ;
 158
 159 : reveal ( word -- )
 160     dup word-name over word-vocabulary create-vocab set-hash ;
 161
 162 TUPLE: check-create name vocab ;
 163 : check-create ( name vocab -- name vocab )
 164     dup string? [ <check-create> throw ] unless
 165     over string? [ <check-create> throw ] unless ;
 166
 167 : create ( name vocab -- word )
 168     check-create 2dup lookup dup
 169     [ 2nip ] [ drop <word> dup reveal ] if ;
 170
 171 : constructor-word ( name vocab -- word )
 172     >r "<" swap ">" append3 r> create ;
 173
 174 : forget-vocab ( vocab -- )
 175     words [ forget ] each ;
 176
 177 : bootstrap-word ( word -- target )
 178     bootstrapping? get [
 179         dup word-name swap word-vocabulary
 180         dup "syntax" = [
 181             drop "!syntax" >r "!" swap append r>
 182         ] when lookup
 183     ] when ;
 184
 185 : words-named ( str -- seq )
 186     all-words [ word-name = ] subset-with ;
 187
 188 ! Definition protocol
 189 M: word where* "loc" word-prop ;
 190
 191 M: word subdefs drop f ;
 192
 193 : forget-word ( word -- )
 194     dup unxref-word
 195     dup remove-word-help
 196     dup unchanged-word
 197     crossref get [ dupd remove-hash ] when*
 198     dup word-name swap word-vocabulary vocab remove-hash ;
 199
 200 M: word forget forget-word ;