1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays definitions graphs assocs kernel
4 kernel.private slots.private math namespaces sequences strings
5 vectors sbufs quotations assocs hashtables sorting words.private
6 vocabs math.order sets ;
9 : word ( -- word ) \ word get-global ;
11 : set-word ( word -- ) \ word set-global ;
13 GENERIC: execute ( word -- )
15 M: word execute (execute) ;
18 [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
20 M: word definer drop \ : \ ; ;
22 M: word definition def>> ;
26 PREDICATE: deferred < word ( obj -- ? )
27 def>> [ undefined ] = ;
28 M: deferred definer drop \ DEFER: f ;
29 M: deferred definition drop f ;
31 PREDICATE: symbol < word ( obj -- ? )
32 [ def>> ] [ [ ] curry ] bi sequence= ;
33 M: symbol definer drop \ SYMBOL: f ;
34 M: symbol definition drop f ;
36 PREDICATE: primitive < word ( obj -- ? )
37 [ def>> [ do-primitive ] tail? ]
38 [ sub-primitive>> >boolean ]
40 M: primitive definer drop \ PRIMITIVE: f ;
41 M: primitive definition drop f ;
43 : word-prop ( word name -- value ) swap props>> at ;
45 : remove-word-prop ( word name -- ) swap props>> delete-at ;
47 : set-word-prop ( word value name -- )
49 [ pick props>> ?set-at >>props drop ]
50 [ nip remove-word-prop ] if ;
52 : reset-props ( word seq -- ) [ remove-word-prop ] with each ;
54 : lookup ( name vocab -- word ) vocab-words at ;
56 : target-word ( word -- target )
57 [ name>> ] [ vocabulary>> ] bi lookup ;
59 SYMBOL: bootstrapping?
61 : if-bootstrapping ( true false -- )
62 bootstrapping? get -rot if ; inline
64 : bootstrap-word ( word -- target )
65 [ target-word ] [ ] if-bootstrapping ;
67 GENERIC: crossref? ( word -- ? )
70 dup "forgotten" word-prop [
76 GENERIC: compiled-crossref? ( word -- ? )
78 M: word compiled-crossref? crossref? ;
80 GENERIC# (quot-uses) 1 ( obj assoc -- )
82 M: object (quot-uses) 2drop ;
84 M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
86 : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
88 M: array (quot-uses) seq-uses ;
90 M: hashtable (quot-uses) >r >alist r> seq-uses ;
92 M: callable (quot-uses) seq-uses ;
94 M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ;
96 : quot-uses ( quot -- assoc )
97 global [ H{ } clone [ (quot-uses) ] keep ] bind ;
99 M: word uses ( word -- seq )
100 def>> quot-uses keys ;
102 SYMBOL: compiled-crossref
104 compiled-crossref global [ H{ } assoc-like ] change-at
106 SYMBOL: compiled-generic-crossref
108 compiled-generic-crossref global [ H{ } assoc-like ] change-at
110 : (compiled-xref) ( word dependencies word-prop variable -- )
111 [ [ set-word-prop ] curry ]
112 [ [ get add-vertex* ] curry ]
115 : compiled-xref ( word dependencies generic-dependencies -- )
116 [ [ drop crossref? ] assoc-filter ] bi@
118 [ "compiled-uses" compiled-crossref (compiled-xref) ]
119 [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
122 : (compiled-unxref) ( word word-prop variable -- )
123 [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
124 [ drop [ f swap set-word-prop ] curry ]
127 : compiled-unxref ( word -- )
128 [ "compiled-uses" compiled-crossref (compiled-unxref) ]
129 [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
132 : delete-compiled-xref ( word -- )
134 [ compiled-crossref get delete-at ]
135 [ compiled-generic-crossref get delete-at ]
138 GENERIC: inline? ( word -- ? )
140 M: word inline? "inline" word-prop ;
144 : reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
146 : (redefined) ( word -- )
147 dup visited get key? [ drop ] [
148 [ reset-on-redefine reset-props ]
149 [ visited get conjoin ]
154 [ reset-on-redefine [ word-prop ] with contains? ]
162 : redefined ( word -- )
163 [ H{ } clone visited [ (redefined) ] with-variable ]
164 [ changed-definition ]
167 : define ( word def -- )
172 dup crossref? [ dup xref ] when drop ;
174 : set-stack-effect ( effect word -- )
175 2dup "declared-effect" word-prop = [ 2drop ] [
177 [ "declared-effect" set-word-prop ]
178 [ drop dup primitive? [ dup redefined ] unless drop ] 2bi
181 : define-declared ( word def effect -- )
182 pick swap "declared-effect" set-word-prop
185 : make-inline ( word -- )
186 t "inline" set-word-prop ;
188 : make-recursive ( word -- )
189 t "recursive" set-word-prop ;
191 : make-flushable ( word -- )
192 t "flushable" set-word-prop ;
194 : make-foldable ( word -- )
195 dup make-flushable t "foldable" set-word-prop ;
197 : define-inline ( word quot -- )
198 dupd define make-inline ;
200 : define-symbol ( word -- )
201 dup [ ] curry define-inline ;
203 GENERIC: reset-word ( word -- )
208 "parsing" "inline" "recursive" "foldable" "flushable"
213 "declared-effect" "constructor-quot" "delimiter"
216 GENERIC: subwords ( word -- seq )
218 M: word subwords drop f ;
220 : reset-generic ( word -- )
221 [ subwords forget-all ]
223 [ { "methods" "combination" "default-method" } reset-props ]
227 "( gensym )" f <word> ;
229 : define-temp ( quot -- word )
230 gensym dup rot define ;
233 dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
237 ERROR: bad-create name vocab ;
239 : check-create ( name vocab -- name vocab )
240 2dup [ string? ] both?
241 [ bad-create ] unless ;
243 : create ( name vocab -- word )
244 check-create 2dup lookup
245 dup [ 2nip ] [ drop <word> dup reveal ] if ;
247 : constructor-word ( name vocab -- word )
248 >r "<" swap ">" 3append r> create ;
250 PREDICATE: parsing-word < word "parsing" word-prop ;
252 : delimiter? ( obj -- ? )
253 dup word? [ "delimiter" word-prop ] [ drop f ] if ;
255 ! Definition protocol
256 M: word where "loc" word-prop ;
258 M: word set-where swap "loc" set-word-prop ;
261 dup "forgotten" word-prop [ drop ] [
263 [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
264 [ t "forgotten" set-word-prop ]
269 nip 1 slot { fixnum } declare ;
271 M: word literalize <wrapper> ;
273 : ?word-name ( word -- name ) dup word? [ name>> ] when ;
275 : xref-words ( -- ) all-words [ xref ] each ;