1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes combinators compiler.units
4 continuations definitions effects io io.encodings.utf8 io.files
5 kernel lexer math.parser namespaces parser.notes quotations
6 sequences sets slots source-files vectors vocabs vocabs.parser
11 current-source-file get lexer get line>> 2dup and
12 [ [ path>> ] dip 2array ] [ 2drop f ] if ;
14 : save-location ( definition -- )
15 location remember-definition ;
17 M: parsing-word stack-effect drop ( parsed -- parsed ) ;
19 : create-word-in ( str -- word )
20 current-vocab create-word dup set-last-word dup save-location ;
24 : auto-use ( -- ) auto-use? on ;
26 : no-word-restarted ( restart-value -- word )
30 [ "Added \"" "\" vocabulary to search path" surround note. ] bi
31 ] [ create-word-in ] if ;
33 : ignore-forwards ( seq -- seq' )
34 [ forward-reference? ] reject ;
36 : private? ( word -- ? ) vocabulary>> ".private" tail? ;
38 : use-first-word? ( words -- ? )
39 [ length 1 = ] [ ?first dup [ private? not ] [ ] ?if ] bi and
42 ! True branch is a singleton public word with no name conflicts
43 ! False branch, singleton private words need confirmation regardless
45 : no-word ( name -- newword )
46 dup words-named ignore-forwards
47 dup use-first-word? [ nip first ] [ <no-word-error> throw-restarts ] if
50 : parse-word ( string -- word )
51 dup search [ ] [ no-word ] ?if ;
53 ERROR: number-expected ;
55 : parse-number ( string -- number )
56 string>number [ number-expected ] unless* ;
58 : parse-datum ( string -- word/number )
60 dup string>number [ ] [ no-word ] ?if
63 : ?scan-datum ( -- word/number/f )
64 ?scan-token dup [ parse-datum ] when ;
66 : scan-datum ( -- word/number )
67 ?scan-datum [ \ word throw-unexpected-eof ] unless* ;
69 : scan-word ( -- word )
70 ?scan-token parse-word ;
72 : scan-number ( -- number )
73 ?scan-token parse-number ;
75 ERROR: invalid-word-name string ;
77 : check-word-name ( string -- string )
78 dup "\"" = [ t ] [ dup string>number ] if
79 [ invalid-word-name ] when ;
81 : scan-word-name ( -- string )
82 scan-token check-word-name ;
84 : scan-new ( -- word )
85 scan-word-name create-word-in ;
87 : scan-new-word ( -- word )
88 scan-new dup reset-generic ;
90 ERROR: staging-violation word ;
92 : (execute-parsing) ( accum word -- accum )
94 execute( accum -- accum )
95 pop-parsing-word ; inline
97 : execute-parsing ( accum word -- accum )
98 dup changed-definitions get in? [ staging-violation ] when
101 : ?execute-parsing ( word/number -- seq )
103 [ V{ } clone swap execute-parsing ] [ 1array ] if ;
105 : scan-object ( -- object )
108 V{ } clone swap execute-parsing first
111 ERROR: classoid-expected object ;
113 : scan-class ( -- class )
115 dup classoid? [ classoid-expected ] unless ;
117 : parse-until-step ( accum end -- accum ? )
119 { [ 2dup eq? ] [ 2drop f ] }
120 { [ dup not ] [ drop throw-unexpected-eof t ] }
121 { [ dup delimiter? ] [ unexpected t ] }
122 { [ dup parsing-word? ] [ nip execute-parsing t ] }
126 : (parse-until) ( accum end -- accum )
127 [ parse-until-step ] keep swap [ (parse-until) ] [ drop ] if ;
129 : parse-until ( end -- vec )
130 100 <vector> swap (parse-until) ;
132 SYMBOL: quotation-parser
134 HOOK: parse-quotation quotation-parser ( -- quot )
136 M: f parse-quotation \ ] parse-until >quotation ;
138 : (parse-lines) ( lexer -- quot )
139 [ f parse-until >quotation ] with-lexer ;
141 : parse-lines ( lines -- quot )
142 >array <lexer> (parse-lines) ;
144 : parse-literal ( accum end quot -- accum )
145 [ parse-until ] dip call suffix! ; inline
147 : parse-definition ( -- quot )
148 \ ; parse-until >quotation ;
150 : parse-array-def ( -- array )
151 \ ; parse-until >array ;
155 : scan-base ( base -- n )
156 scan-token swap base> [ bad-number ] unless* ;
158 SYMBOL: bootstrap-syntax
160 : with-file-vocabs ( quot -- )
163 bootstrap-syntax get [ use-words ] when*
165 ] with-manifest ; inline
167 SYMBOL: print-use-hook
169 print-use-hook [ [ ] ] initialize
171 : parse-fresh ( lines -- quot )
174 auto-used? [ print-use-hook get call( -- ) ] when
177 : parsing-file ( path -- )
178 parser-quiet? get [ drop ] [ "Loading " write print flush ] if ;
180 : filter-moved ( set1 set2 -- seq )
183 { [ dup where ?first current-source-file get path>> = not ] [ f ] }
184 { [ dup reader-method? ] [ f ] }
185 { [ dup writer-method? ] [ f ] }
190 : removed-definitions ( -- set1 set2 )
191 new-definitions old-definitions
192 [ get first2 union ] bi@ ;
194 : removed-classes ( -- set1 set2 )
195 new-definitions old-definitions
198 : forget-removed-definitions ( -- )
199 removed-definitions filter-moved forget-all ;
201 : reset-removed-classes ( -- )
203 filter-moved [ class? ] filter [ forget-class ] each ;
205 : fix-class-words ( -- )
206 ! If a class word had a compound definition which was
207 ! removed, it must go back to being a symbol.
208 new-definitions get first2
209 filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
211 : forget-smudged ( -- )
212 forget-removed-definitions
213 reset-removed-classes
216 : finish-parsing ( lines quot -- )
217 current-source-file get
218 [ record-top-level-form ]
219 [ record-definitions ]
223 : parse-stream ( stream name -- quot )
226 stream-lines dup parse-fresh
227 [ nip ] [ finish-parsing ] 2bi
230 ] with-compilation-unit ;
232 : parse-file-restarts ( path -- restarts )
233 "Load " " again" surround t 2array 1array ;
235 : parse-file ( path -- quot )
237 [ parsing-file ] keep
238 [ utf8 <file-reader> ] keep
241 over parse-file-restarts rethrow-restarts
245 : run-file ( path -- )
246 parse-file call( -- ) ;
248 : ?run-file ( path -- )
249 dup file-exists? [ run-file ] [ drop ] if ;
251 ERROR: version-control-merge-conflict ;