1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays definitions generic assocs kernel math namespaces
4 prettyprint sequences strings vectors words quotations summary
5 io.styles io combinators sorting splitting math.parser effects
6 continuations debugger io.files io.streams.string vocabs
7 io.encodings.utf8 source-files classes hashtables
8 compiler.errors compiler.units accessors sets lexer ;
12 file get lexer get line>> 2dup and
13 [ >r path>> r> 2array ] [ 2drop f ] if ;
15 : save-location ( definition -- )
16 location remember-definition ;
20 t parser-notes set-global
22 : parser-notes? ( -- ? )
23 parser-notes get "quiet" get not and ;
27 file get [ file. ] when*
28 lexer get line>> number>string write ": " write
29 "Note: " write dup print
36 vocab-words use get push ;
41 : add-use ( seq -- ) [ use+ ] each ;
44 [ vocab-words ] V{ } map-as sift use set ;
46 : check-vocab-string ( name -- name )
48 [ "Vocabulary name must be a string" throw ] unless ;
51 check-vocab-string dup in set create-vocab (use+) ;
53 M: parsing-word stack-effect drop (( parsed -- parsed )) ;
55 ERROR: no-current-vocab ;
57 M: no-current-vocab summary ( obj -- )
58 drop "Not in a vocabulary; IN: form required" ;
60 : current-vocab ( -- str )
61 in get [ no-current-vocab ] unless* ;
63 : create-in ( str -- word )
64 current-vocab create dup set-word dup save-location ;
66 : CREATE ( -- word ) scan create-in ;
68 : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
70 : word-restarts ( possibilities -- restarts )
72 [ "Use the word " swap summary append ] keep
75 TUPLE: no-word-error name ;
77 M: no-word-error summary
78 drop "Word not found in current vocabulary search path" ;
80 : no-word ( name -- newword )
82 swap words-named [ forward-reference? not ] filter
83 word-restarts throw-restarts
84 dup vocabulary>> (use+) ;
86 : check-forward ( str word -- word/f )
87 dup forward-reference? [
91 [ forward-reference? not ] find nip
96 : search ( str -- word/f )
97 dup use get assoc-stack check-forward ;
99 : scan-word ( -- word/number/f )
102 dup string>number [ ] [ no-word ] ?if
106 ERROR: staging-violation word ;
108 M: staging-violation summary
110 "A parsing word cannot be used in the same file it is defined in." ;
112 : execute-parsing ( word -- )
113 dup changed-definitions get key? [ staging-violation ] when
116 : scan-object ( -- object )
117 scan-word dup parsing-word?
118 [ V{ } clone swap execute-parsing first ] when ;
120 : parse-step ( accum end -- accum ? )
122 { [ 2dup eq? ] [ 2drop f ] }
123 { [ dup not ] [ drop unexpected-eof t ] }
124 { [ dup delimiter? ] [ unexpected t ] }
125 { [ dup parsing-word? ] [ nip execute-parsing t ] }
129 : (parse-until) ( accum end -- accum )
130 dup >r parse-step [ r> (parse-until) ] [ r> drop ] if ;
132 : parse-until ( end -- vec )
133 100 <vector> swap (parse-until) ;
135 : parsed ( accum obj -- accum ) over push ;
137 : (parse-lines) ( lexer -- quot )
138 [ f parse-until >quotation ] with-lexer ;
140 : parse-lines ( lines -- quot )
141 lexer-factory get call (parse-lines) ;
143 : parse-literal ( accum end quot -- accum )
144 >r parse-until r> call parsed ; inline
146 : parse-definition ( -- quot )
147 \ ; parse-until >quotation ;
149 : (:) ( -- word def ) CREATE-WORD parse-definition ;
153 M: bad-number summary
154 drop "Bad number literal" ;
156 : parse-base ( parsed base -- parsed )
157 scan swap base> [ bad-number ] unless* parsed ;
159 SYMBOL: bootstrap-syntax
161 : with-file-vocabs ( quot -- )
163 f in set { "syntax" } set-use
164 bootstrap-syntax get [ use get push ] when*
166 ] with-scope ; inline
168 SYMBOL: interactive-vocabs
208 } interactive-vocabs set-global
210 : with-interactive-vocabs ( quot -- )
213 interactive-vocabs get set-use
215 ] with-scope ; inline
217 : parse-fresh ( lines -- quot )
218 [ parse-lines ] with-file-vocabs ;
220 : parsing-file ( file -- )
224 "Loading " write <pathname> . flush
227 : filter-moved ( assoc1 assoc2 -- seq )
229 drop where dup [ first ] when
230 file get source-file-path =
231 ] assoc-filter keys ;
233 : removed-definitions ( -- assoc1 assoc2 )
234 new-definitions old-definitions
235 [ get first2 assoc-union ] bi@ ;
237 : removed-classes ( -- assoc1 assoc2 )
238 new-definitions old-definitions
241 : forget-removed-definitions ( -- )
242 removed-definitions filter-moved forget-all ;
244 : reset-removed-classes ( -- )
246 filter-moved [ class? ] filter [ forget-class ] each ;
248 : fix-class-words ( -- )
249 #! If a class word had a compound definition which was
250 #! removed, it must go back to being a symbol.
251 new-definitions get first2
252 filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
254 : forget-smudged ( -- )
255 forget-removed-definitions
256 reset-removed-classes
259 : finish-parsing ( lines quot -- )
262 [ record-definitions ]
266 : parse-stream ( stream name -- quot )
269 lines dup parse-fresh
273 ] with-compilation-unit ;
275 : parse-file-restarts ( file -- restarts )
276 "Load " swap " again" 3append t 2array 1array ;
278 : parse-file ( file -- quot )
281 [ parsing-file ] keep
282 [ utf8 <file-reader> ] keep
284 ] with-compiler-errors
286 over parse-file-restarts rethrow-restarts
290 : run-file ( file -- )
291 [ dup parse-file call ] assert-depth drop ;
293 : ?run-file ( path -- )
294 dup exists? [ run-file ] [ drop ] if ;
296 : bootstrap-file ( path -- )
297 [ parse-file % ] [ run-file ] if-bootstrapping ;
300 [ string-lines parse-fresh ] with-compilation-unit call ;
302 : eval>string ( str -- output )
305 [ [ eval ] keep ] try drop
306 ] with-string-writer ;