1 ! Copyright (C) 2005, 2007 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays definitions generic assocs kernel math
4 namespaces prettyprint sequences strings vectors words
5 quotations inspector io.styles io combinators sorting
6 splitting math.parser effects continuations debugger
7 io.files io.streams.string io.streams.lines vocabs
8 source-files classes hashtables compiler.errors compiler.units
12 TUPLE: lexer text line column ;
14 : <lexer> ( text -- lexer ) 1 0 lexer construct-boa ;
16 : line-text ( lexer -- str )
17 dup lexer-line 1- swap lexer-text ?nth ;
20 file get lexer get lexer-line 2dup and
21 [ >r source-file-path r> 2array ] [ 2drop f ] if ;
23 : save-location ( definition -- )
24 location remember-definition ;
26 : save-class-location ( class -- )
27 location remember-class ;
31 t parser-notes set-global
33 : parser-notes? ( -- ? )
34 parser-notes get "quiet" get not and ;
38 source-file-path <pathname> pprint
47 lexer-line number>string print
51 "Note: " write dup print
54 : next-line ( lexer -- )
55 0 over set-lexer-column
56 dup lexer-line 1+ swap set-lexer-line ;
58 : skip ( i seq quot -- n )
60 [ r> drop ] [ r> length ] if* ; inline
62 : change-column ( lexer quot -- )
64 [ dup lexer-column swap line-text rot call ] keep
65 set-lexer-column ; inline
67 GENERIC: skip-blank ( lexer -- )
69 M: lexer skip-blank ( lexer -- )
70 [ [ blank? not ] skip ] change-column ;
72 GENERIC: skip-word ( lexer -- )
74 M: lexer skip-word ( lexer -- )
77 [ drop 1+ ] [ [ blank? ] skip ] if
80 : still-parsing? ( lexer -- ? )
81 dup lexer-line swap lexer-text length <= ;
83 : still-parsing-line? ( lexer -- ? )
84 dup lexer-column swap line-text length < ;
86 : (parse-token) ( lexer -- str )
92 : parse-token ( lexer -- str/f )
95 dup still-parsing-line?
96 [ (parse-token) ] [ dup next-line parse-token ] if
99 : scan ( -- str/f ) lexer get parse-token ;
103 : bad-escape ( -- * )
104 \ bad-escape construct-empty throw ;
106 M: bad-escape summary drop "Bad escape code" ;
108 : escape ( escape -- ch )
115 { CHAR: \s CHAR: \s }
117 { CHAR: \\ CHAR: \\ }
118 { CHAR: \" CHAR: \" }
119 } at [ bad-escape ] unless* ;
121 : next-escape ( m str -- n ch )
123 [ >r 1+ dup 6 + tuck r> subseq hex> ]
124 [ over 1+ -rot nth escape ] if ;
126 : next-char ( m str -- n ch )
128 [ >r 1+ r> next-escape ] [ over 1+ -rot nth ] if ;
130 : (parse-string) ( m str -- n )
132 [ drop 1+ ] [ [ next-char , ] keep (parse-string) ] if ;
134 : parse-string ( -- str )
136 [ (parse-string) ] "" make swap
139 TUPLE: parse-error file line col text ;
141 : <parse-error> ( msg -- error )
144 lexer get lexer-column
146 parse-error construct-boa
147 [ set-delegate ] keep ;
149 : parse-dump ( error -- )
150 dup parse-error-file file.
151 dup parse-error-line number>string print
152 dup parse-error-text dup string? [ print ] [ drop ] if
153 parse-error-col 0 or CHAR: \s <string> write
156 M: parse-error error.
157 dup parse-dump delegate error. ;
162 : word/vocab% ( word -- )
163 "(" % dup word-vocabulary % " " % word-name % ")" % ;
165 : shadow-warning ( new old -- )
169 [ word/vocab% " shadowed by " % word/vocab% ] "" make
173 : shadow-warnings ( vocab vocabs -- )
175 swapd assoc-stack dup
176 [ shadow-warning ] [ 2drop ] if
179 : (use+) ( vocab -- )
180 vocab-words use get 2dup shadow-warnings push ;
185 : add-use ( seq -- ) [ use+ ] each ;
188 [ vocab-words ] map [ ] subset >vector use set ;
190 : check-vocab-string ( name -- name )
192 [ "Vocabulary name must be a string" throw ] unless ;
195 check-vocab-string dup in set create-vocab (use+) ;
197 : create-in ( string -- word )
198 in get create dup set-word dup save-location ;
200 TUPLE: unexpected want got ;
202 : unexpected ( want got -- * )
203 \ unexpected construct-boa throw ;
205 PREDICATE: unexpected unexpected-eof
208 : unexpected-eof ( word -- * ) f unexpected ;
210 : (parse-tokens) ( accum end -- accum )
214 [ pick push (parse-tokens) ] [ unexpected-eof ] if*
217 : parse-tokens ( end -- seq )
218 100 <vector> swap (parse-tokens) >array ;
220 : CREATE ( -- word ) scan create-in ;
222 : CREATE-CLASS ( -- word )
224 dup save-class-location
225 dup predicate-word dup set-word save-location ;
227 : word-restarts ( possibilities -- restarts )
229 [ "Use the word " swap summary append ] keep
232 TUPLE: no-word name ;
235 drop "Word not found in current vocabulary search path" ;
237 : no-word ( name -- newword )
238 dup \ no-word construct-boa
239 swap words-named word-restarts throw-restarts
240 dup word-vocabulary (use+) ;
242 : check-forward ( str word -- word )
243 dup forward-reference? [
246 [ at ] with map [ ] subset
247 [ forward-reference? not ] find nip
248 [ ] [ forward-error ] ?if
253 : search ( str -- word )
254 dup use get assoc-stack [ check-forward ] [ no-word ] if* ;
256 : scan-word ( -- word/number/f )
257 scan dup [ dup string>number [ ] [ search ] ?if ] when ;
259 TUPLE: staging-violation word ;
261 : staging-violation ( word -- * )
262 \ staging-violation construct-boa throw ;
264 M: staging-violation summary
266 "A parsing word cannot be used in the same file it is defined in." ;
268 : execute-parsing ( word -- )
269 new-definitions get [
270 dupd first key? [ staging-violation ] when
274 : parse-step ( accum end -- accum ? )
276 { [ 2dup eq? ] [ 2drop f ] }
277 { [ dup not ] [ drop unexpected-eof t ] }
278 { [ dup delimiter? ] [ unexpected t ] }
279 { [ dup parsing? ] [ nip execute-parsing t ] }
280 { [ t ] [ pick push drop t ] }
283 : (parse-until) ( accum end -- accum )
284 dup >r parse-step [ r> (parse-until) ] [ r> drop ] if ;
286 : parse-until ( end -- vec )
287 100 <vector> swap (parse-until) ;
289 : parsed ( accum obj -- accum ) over push ;
291 : with-parser ( lexer quot -- newquot )
293 [ call >quotation ] [ <parse-error> rethrow ] recover ;
295 : (parse-lines) ( lexer -- quot )
296 [ f parse-until ] with-parser ;
298 SYMBOL: lexer-factory
300 [ <lexer> ] lexer-factory set-global
302 : parse-lines ( lines -- quot )
303 lexer-factory get call (parse-lines) ;
305 ! Parsing word utilities
306 : parse-effect ( -- effect )
307 ")" parse-tokens { "--" } split1 dup [
310 "Stack effect declaration must contain --" throw
315 : bad-number ( -- * ) \ bad-number construct-boa throw ;
317 : parse-base ( parsed base -- parsed )
318 scan swap base> [ bad-number ] unless* parsed ;
320 : parse-literal ( accum end quot -- accum )
321 >r parse-until r> call parsed ; inline
323 : parse-definition ( -- quot )
324 \ ; parse-until >quotation ;
326 GENERIC: expected>string ( obj -- str )
328 M: f expected>string drop "end of input" ;
329 M: word expected>string word-name ;
330 M: string expected>string ;
334 dup unexpected-want expected>string write
336 unexpected-got expected>string print ;
338 M: bad-number summary
339 drop "Bad number literal" ;
341 SYMBOL: bootstrap-syntax
343 : with-file-vocabs ( quot -- )
346 { "syntax" "scratchpad" } set-use
347 bootstrap-syntax get [ use get push ] when*
349 ] with-scope ; inline
351 : with-interactive-vocabs ( quot -- )
391 ] with-scope ; inline
393 : parse-fresh ( lines -- quot )
394 [ parse-lines ] with-file-vocabs ;
396 : parsing-file ( file -- )
400 "Loading " write <pathname> . flush
403 : smudged-usage-warning ( usages removed -- )
405 "Warning: the following definitions were removed from sources," print
406 "but are still referenced from other definitions:" print
410 "The following definitions need to be updated:" print
415 : outside-usages ( seq -- usages )
417 over usage [ pathname? not ] subset seq-diff
418 ] curry { } map>assoc ;
420 : filter-moved ( assoc -- newassoc )
422 drop where dup [ first ] when
423 file get source-file-path =
426 : removed-definitions ( -- definitions )
427 new-definitions old-definitions
428 [ get first2 union ] 2apply diff ;
430 : smudged-usage ( -- usages referenced removed )
431 removed-definitions filter-moved keys [
433 [ empty? swap pathname? or not ] assoc-subset
434 dup values concat prune swap keys
437 : forget-smudged ( -- )
438 smudged-usage forget-all
439 over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
441 : finish-parsing ( lines quot -- )
444 [ record-modified ] keep
445 [ record-definitions ] keep
448 : parse-stream ( stream name -- quot )
451 lines dup parse-fresh
455 ] with-compilation-unit ;
457 : parse-file-restarts ( file -- restarts )
458 "Load " swap " again" 3append t 2array 1array ;
460 : parse-file ( file -- quot )
463 [ parsing-file ] keep
464 [ ?resource-path <file-reader> ] keep
466 ] with-compiler-errors
468 over parse-file-restarts rethrow-restarts
472 : run-file ( file -- )
473 [ [ parse-file call ] keep ] assert-depth drop ;
475 : ?run-file ( path -- )
476 dup ?resource-path exists? [ run-file ] [ drop ] if ;
478 : bootstrap-file ( path -- )
479 [ parse-file % ] [ run-file ] if-bootstrapping ;
482 [ string-lines parse-fresh ] with-compilation-unit call ;
484 : eval>string ( str -- output )
487 [ [ eval ] keep ] try drop