1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays definitions graphs assocs kernel kernel.private
4 slots.private math namespaces sequences strings vectors sbufs
5 quotations assocs hashtables sorting words.private vocabs
9 : word ( -- word ) \ word get-global ;
11 : set-word ( word -- ) \ word set-global ;
13 GENERIC: execute ( word -- )
15 M: word execute (execute) ;
18 [ dup word-name swap word-vocabulary 2array ] compare ;
20 M: word definer drop \ : \ ; ;
22 M: word definition word-def ;
26 PREDICATE: deferred < word ( obj -- ? )
27 word-def [ undefined ] = ;
28 M: deferred definer drop \ DEFER: f ;
29 M: deferred definition drop f ;
31 PREDICATE: symbol < word ( obj -- ? )
32 dup <wrapper> 1array swap word-def sequence= ;
33 M: symbol definer drop \ SYMBOL: f ;
34 M: symbol definition drop f ;
36 PREDICATE: primitive < word ( obj -- ? )
37 word-def [ do-primitive ] tail? ;
38 M: primitive definer drop \ PRIMITIVE: f ;
39 M: primitive definition drop f ;
41 : word-prop ( word name -- value ) swap word-props at ;
43 : remove-word-prop ( word name -- )
44 swap word-props delete-at ;
46 : set-word-prop ( word value name -- )
48 [ pick word-props ?set-at swap set-word-props ]
49 [ nip remove-word-prop ] if ;
51 : reset-props ( word seq -- ) [ remove-word-prop ] with each ;
53 : lookup ( name vocab -- word ) vocab-words at ;
55 : target-word ( word -- target )
56 dup word-name swap word-vocabulary lookup ;
58 SYMBOL: bootstrapping?
60 : if-bootstrapping ( true false -- )
61 bootstrapping? get -rot if ; inline
63 : bootstrap-word ( word -- target )
64 [ target-word ] [ ] if-bootstrapping ;
66 GENERIC: crossref? ( word -- ? )
69 dup "forgotten" word-prop [
72 word-vocabulary >boolean
75 GENERIC: compiled-crossref? ( word -- ? )
77 M: word compiled-crossref? crossref? ;
79 GENERIC# (quot-uses) 1 ( obj assoc -- )
81 M: object (quot-uses) 2drop ;
84 >r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ;
86 : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
88 M: array (quot-uses) seq-uses ;
90 M: callable (quot-uses) seq-uses ;
92 M: wrapper (quot-uses) >r wrapped r> (quot-uses) ;
94 : quot-uses ( quot -- assoc )
95 global [ H{ } clone [ (quot-uses) ] keep ] bind ;
97 M: word uses ( word -- seq )
98 word-def quot-uses keys ;
100 SYMBOL: compiled-crossref
102 compiled-crossref global [ H{ } assoc-like ] change-at
104 : compiled-xref ( word dependencies -- )
105 [ drop crossref? ] assoc-filter
106 2dup "compiled-uses" set-word-prop
107 compiled-crossref get add-vertex* ;
109 : compiled-unxref ( word -- )
110 dup "compiled-uses" word-prop
111 compiled-crossref get remove-vertex* ;
113 : delete-compiled-xref ( word -- )
115 compiled-crossref get delete-at ;
117 : compiled-usage ( word -- assoc )
118 compiled-crossref get at ;
120 : compiled-usages ( assoc -- seq )
124 [ compiled-usage ] dip
126 [ nip +inlined+ eq? ] assoc-filter
132 GENERIC: redefined ( word -- )
134 M: object redefined drop ;
136 : define ( word def -- )
141 dup +inlined+ changed-definition
142 dup crossref? [ dup xref ] when drop ;
144 : define-declared ( word def effect -- )
145 pick swap "declared-effect" set-word-prop
148 : make-inline ( word -- )
149 t "inline" set-word-prop ;
151 : make-flushable ( word -- )
152 t "flushable" set-word-prop ;
154 : make-foldable ( word -- )
155 dup make-flushable t "foldable" set-word-prop ;
157 : define-inline ( word quot -- )
158 dupd define make-inline ;
160 : define-symbol ( word -- )
161 dup [ ] curry define-inline ;
163 GENERIC: reset-word ( word -- )
168 "parsing" "inline" "foldable" "flushable"
172 "declared-effect" "constructor-quot" "delimiter"
175 GENERIC: subwords ( word -- seq )
177 M: word subwords drop f ;
179 : reset-generic ( word -- )
180 dup subwords forget-all
182 { "methods" "combination" "default-method" } reset-props ;
185 "( gensym )" f <word> ;
187 : define-temp ( quot -- word )
188 gensym dup rot define ;
191 dup word-name over word-vocabulary dup vocab-words
195 ERROR: bad-create name vocab ;
197 : check-create ( name vocab -- name vocab )
198 2dup [ string? ] both?
199 [ bad-create ] unless ;
201 : create ( name vocab -- word )
202 check-create 2dup lookup
203 dup [ 2nip ] [ drop <word> dup reveal ] if ;
205 : constructor-word ( name vocab -- word )
206 >r "<" swap ">" 3append r> create ;
208 PREDICATE: parsing-word < word "parsing" word-prop ;
210 : delimiter? ( obj -- ? )
211 dup word? [ "delimiter" word-prop ] [ drop f ] if ;
213 ! Definition protocol
214 M: word where "loc" word-prop ;
216 M: word set-where swap "loc" set-word-prop ;
219 dup "forgotten" word-prop [
221 dup delete-compiled-xref
222 dup word-name over word-vocabulary vocab-words delete-at
223 dup t "forgotten" set-word-prop
227 nip 1 slot { fixnum } declare ;
229 M: word literalize <wrapper> ;
231 : ?word-name ( word -- name ) dup word? [ word-name ] when ;
233 : xref-words ( -- ) all-words [ xref ] each ;