1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays definitions generic assocs kernel math namespaces
4 sequences strings vectors words words.symbol quotations io
5 combinators sorting splitting math.parser effects continuations
6 io.files vocabs io.encodings.utf8 source-files classes
7 hashtables compiler.units accessors sets lexer vocabs.parser
8 effects.parser slots parser.notes ;
12 file get lexer get line>> 2dup and
13 [ [ path>> ] dip 2array ] [ 2drop f ] if ;
15 : save-location ( definition -- )
16 location remember-definition ;
18 M: parsing-word stack-effect drop (( parsed -- parsed )) ;
20 : create-in ( str -- word )
21 current-vocab create dup set-word dup save-location ;
23 : CREATE ( -- word ) scan create-in ;
25 : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
29 : no-word-restarted ( restart-value -- word )
33 [ "Added \"" "\" vocabulary to search path" surround note. ] bi
36 : no-word ( name -- newword )
37 dup words-named [ forward-reference? not ] filter
38 dup length 1 = auto-use? get and
39 [ nip first no-word-restarted ]
40 [ <no-word-error> throw-restarts no-word-restarted ]
43 : parse-word ( string -- word/number )
45 dup string>number [ ] [ no-word ] ?if
48 : scan-word ( -- word/number/f )
49 scan dup [ parse-word ] when ;
51 ERROR: staging-violation word ;
53 : execute-parsing ( accum word -- accum )
54 dup changed-definitions get key? [ staging-violation ] when
55 execute( accum -- accum ) ;
57 : scan-object ( -- object )
59 { [ dup not ] [ unexpected-eof ] }
60 { [ dup parsing-word? ] [ V{ } clone swap execute-parsing first ] }
64 : parse-step ( accum end -- accum ? )
66 { [ 2dup eq? ] [ 2drop f ] }
67 { [ dup not ] [ drop unexpected-eof t ] }
68 { [ dup delimiter? ] [ unexpected t ] }
69 { [ dup parsing-word? ] [ nip execute-parsing t ] }
73 : (parse-until) ( accum end -- accum )
74 [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
76 : parse-until ( end -- vec )
77 100 <vector> swap (parse-until) ;
79 SYMBOL: quotation-parser
81 HOOK: parse-quotation quotation-parser ( -- quot )
83 M: f parse-quotation \ ] parse-until >quotation ;
85 : (parse-lines) ( lexer -- quot )
86 [ f parse-until >quotation ] with-lexer ;
88 : parse-lines ( lines -- quot )
89 lexer-factory get call( lines -- lexer ) (parse-lines) ;
91 : parse-literal ( accum end quot -- accum )
92 [ parse-until ] dip call suffix! ; inline
94 : parse-definition ( -- quot )
95 \ ; parse-until >quotation ;
97 : (:) ( -- word def effect )
100 parse-definition swap ;
104 : scan-base ( base -- n )
105 scan swap base> [ bad-number ] unless* ;
107 : parse-base ( parsed base -- parsed )
110 SYMBOL: bootstrap-syntax
112 : with-file-vocabs ( quot -- )
115 bootstrap-syntax get [ use-words ] when*
117 ] with-manifest ; inline
119 SYMBOL: print-use-hook
121 print-use-hook [ [ ] ] initialize
123 : parse-fresh ( lines -- quot )
126 auto-used? [ print-use-hook get call( -- ) ] when
129 : parsing-file ( file -- )
130 "quiet" get [ drop ] [ "Loading " write print flush ] if ;
132 : filter-moved ( assoc1 assoc2 -- seq )
133 swap assoc-diff keys [
135 { [ dup where dup [ first ] when file get path>> = not ] [ f ] }
136 { [ dup reader-method? ] [ f ] }
137 { [ dup writer-method? ] [ f ] }
142 : removed-definitions ( -- assoc1 assoc2 )
143 new-definitions old-definitions
144 [ get first2 assoc-union ] bi@ ;
146 : removed-classes ( -- assoc1 assoc2 )
147 new-definitions old-definitions
150 : forget-removed-definitions ( -- )
151 removed-definitions filter-moved forget-all ;
153 : reset-removed-classes ( -- )
155 filter-moved [ class? ] filter [ forget-class ] each ;
157 : fix-class-words ( -- )
158 #! If a class word had a compound definition which was
159 #! removed, it must go back to being a symbol.
160 new-definitions get first2
161 filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
163 : forget-smudged ( -- )
164 forget-removed-definitions
165 reset-removed-classes
168 : finish-parsing ( lines quot -- )
170 [ record-top-level-form ]
171 [ record-definitions ]
175 : parse-stream ( stream name -- quot )
178 stream-lines dup parse-fresh
179 [ nip ] [ finish-parsing ] 2bi
182 ] with-compilation-unit ;
184 : parse-file-restarts ( file -- restarts )
185 "Load " " again" surround t 2array 1array ;
187 : parse-file ( file -- quot )
189 [ parsing-file ] keep
190 [ utf8 <file-reader> ] keep
193 over parse-file-restarts rethrow-restarts
197 : run-file ( file -- )
198 parse-file call( -- ) ;
200 : ?run-file ( path -- )
201 dup exists? [ run-file ] [ drop ] if ;