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
9 : word ( -- word ) \ word get-global ;
11 : set-word ( word -- ) \ word set-global ;
13 M: word execute (execute) ;
15 M: word ?execute execute( -- value ) ; inline
18 [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
20 M: word definer drop \ : \ ; ;
22 M: word definition def>> ;
24 : word-prop ( word name -- value ) swap props>> at ;
26 : remove-word-prop ( word name -- ) swap props>> delete-at ;
28 : set-word-prop ( word value name -- )
30 [ pick props>> ?set-at >>props drop ]
31 [ nip remove-word-prop ] if ;
33 : reset-props ( word seq -- ) [ remove-word-prop ] with each ;
37 PREDICATE: deferred < word ( obj -- ? ) def>> [ undefined ] = ;
38 M: deferred definer drop \ DEFER: f ;
39 M: deferred definition drop f ;
41 PREDICATE: primitive < word ( obj -- ? ) "primitive" word-prop ;
42 M: primitive definer drop \ PRIMITIVE: f ;
43 M: primitive definition drop f ;
45 : lookup ( name vocab -- word ) vocab-words at ;
47 : target-word ( word -- target )
48 [ name>> ] [ vocabulary>> ] bi lookup ;
50 SYMBOL: bootstrapping?
52 : if-bootstrapping ( true false -- )
53 [ bootstrapping? get ] 2dip if ; inline
55 : bootstrap-word ( word -- target )
56 [ target-word ] [ ] if-bootstrapping ;
58 GENERIC: crossref? ( word -- ? )
61 dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ;
63 : inline? ( word -- ? ) "inline" word-prop ; inline
65 GENERIC: subwords ( word -- seq )
67 M: word subwords drop f ;
69 : define ( word def -- )
70 over changed-definition [ ] like >>def drop ;
72 : changed-effect ( word -- )
73 [ dup changed-effects get set-in-unit ]
74 [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
76 : set-stack-effect ( effect word -- )
77 2dup "declared-effect" word-prop = [ 2drop ] [
78 [ nip changed-effect ]
79 [ nip subwords [ changed-effect ] each ]
80 [ swap "declared-effect" set-word-prop ]
84 : define-declared ( word def effect -- )
85 [ nip swap set-stack-effect ] [ drop define ] 3bi ;
87 : make-deprecated ( word -- )
88 t "deprecated" set-word-prop ;
90 : make-inline ( word -- )
91 dup inline? [ drop ] [
92 [ t "inline" set-word-prop ]
97 : make-recursive ( word -- )
98 t "recursive" set-word-prop ;
100 : make-flushable ( word -- )
101 t "flushable" set-word-prop ;
103 : make-foldable ( word -- )
104 dup make-flushable t "foldable" set-word-prop ;
106 : define-inline ( word def effect -- )
107 [ define-declared ] [ 2drop make-inline ] 3bi ;
109 GENERIC: reset-word ( word -- )
113 "unannotated-def" "parsing" "inline" "recursive"
114 "foldable" "flushable" "reading" "writing" "reader"
115 "writer" "delimiter" "deprecated"
118 : reset-generic ( word -- )
119 [ subwords forget-all ]
133 : <word> ( name vocab -- word )
134 2dup [ hashcode ] bi@ bitxor >fixnum (word) dup new-word ;
136 : <uninterned-word> ( name -- word )
137 f \ <uninterned-word> counter >fixnum (word) ;
140 "( gensym )" <uninterned-word> ;
142 : define-temp ( quot effect -- word )
143 [ gensym dup ] 2dip define-declared ;
146 dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
150 ERROR: bad-create name vocab ;
152 : check-create ( name vocab -- name vocab )
153 2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and
154 [ bad-create ] unless ;
156 : create ( name vocab -- word )
157 check-create 2dup lookup
162 dup changed-definition
165 : constructor-word ( name vocab -- word )
166 [ "<" ">" surround ] dip create ;
168 PREDICATE: parsing-word < word "parsing" word-prop ;
170 M: parsing-word definer drop \ SYNTAX: \ ; ;
172 : define-syntax ( word quot -- )
173 [ drop ] [ define ] 2bi t "parsing" set-word-prop ;
175 : delimiter? ( obj -- ? )
176 dup word? [ "delimiter" word-prop ] [ drop f ] if ;
178 : deprecated? ( obj -- ? )
179 dup word? [ "deprecated" word-prop ] [ drop f ] if ;
181 ! Definition protocol
182 M: word where "loc" word-prop ;
184 M: word set-where swap "loc" set-word-prop ;
187 dup "forgotten" word-prop [ drop ] [
188 [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
189 [ t "forgotten" set-word-prop ]
194 nip 1 slot { fixnum } declare ; inline foldable
196 M: word literalize <wrapper> ;
198 INSTANCE: word definition