1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: sequences.parser io io.encodings.utf8 io.files
4 io.streams.string kernel combinators accessors io.pathnames
5 fry sequences arrays locals namespaces io.directories
6 assocs math splitting make unicode combinators.short-circuit
10 : initial-library-paths ( -- seq )
11 V{ "/usr/include" } clone ;
13 : initial-symbol-table ( -- hashtable )
20 TUPLE: preprocessor-state library-paths symbol-table
21 include-nesting include-nesting-max processing-disabled?
22 ifdef-nesting warnings errors
27 : <preprocessor-state> ( -- preprocessor-state )
28 preprocessor-state new
29 initial-library-paths >>library-paths
30 initial-symbol-table >>symbol-table
32 200 >>include-nesting-max
37 V{ } clone >>include-nexts
42 DEFER: preprocess-file
44 ERROR: unknown-c-preprocessor sequence-parser name ;
46 ERROR: bad-include-line line ;
48 ERROR: header-file-missing path ;
50 :: read-standard-include ( preprocessor-state path -- )
51 preprocessor-state dup library-paths>>
52 [ path append-path file-exists? ] find nip
59 ! path header-file-missing
63 : read-local-include ( preprocessor-state path -- )
64 dup file-exists? [ preprocess-file ] [ 2drop ] if ;
66 : skip-whitespace/comments ( sequence-parser -- sequence-parser )
69 { [ dup take-c-comment ] [ skip-whitespace/comments ] }
70 { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
74 : handle-include ( preprocessor-state sequence-parser -- )
75 skip-whitespace/comments advance dup previous {
76 { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
77 { CHAR: \" [ CHAR: \" take-until-object read-local-include ] }
82 readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
84 : readlns ( -- string ) [ (readlns) ] { } make concat ;
86 : take-define-identifier ( sequence-parser -- string )
87 skip-whitespace/comments
88 [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
90 :: handle-define ( preprocessor-state sequence-parser -- )
91 sequence-parser take-define-identifier :> ident
92 sequence-parser skip-whitespace/comments take-rest :> def
93 def "\\" ?tail [ readlns append ] when :> def
94 def ident preprocessor-state symbol-table>> set-at ;
96 : handle-undef ( preprocessor-state sequence-parser -- )
97 take-token swap symbol-table>> delete-at ;
99 : handle-ifdef ( preprocessor-state sequence-parser -- )
100 [ [ 1 + ] change-ifdef-nesting ] dip
101 take-token over symbol-table>> key?
102 [ drop ] [ t >>processing-disabled? drop ] if ;
104 : handle-ifndef ( preprocessor-state sequence-parser -- )
105 [ [ 1 + ] change-ifdef-nesting ] dip
106 take-token over symbol-table>> key?
107 [ t >>processing-disabled? drop ]
110 : handle-endif ( preprocessor-state sequence-parser -- )
111 drop [ 1 - ] change-ifdef-nesting drop ;
113 : handle-if ( preprocessor-state sequence-parser -- )
114 [ [ 1 + ] change-ifdef-nesting ] dip
115 skip-whitespace/comments take-rest swap ifs>> push ;
117 : handle-elif ( preprocessor-state sequence-parser -- )
118 skip-whitespace/comments take-rest swap elifs>> push ;
120 : handle-else ( preprocessor-state sequence-parser -- )
121 skip-whitespace/comments take-rest swap elses>> push ;
123 : handle-pragma ( preprocessor-state sequence-parser -- )
124 skip-whitespace/comments take-rest swap pragmas>> push ;
126 : handle-include-next ( preprocessor-state sequence-parser -- )
127 skip-whitespace/comments take-rest swap include-nexts>> push ;
129 : handle-error ( preprocessor-state sequence-parser -- )
130 skip-whitespace/comments take-rest swap errors>> push ;
131 ! nip take-rest throw ;
133 : handle-warning ( preprocessor-state sequence-parser -- )
134 skip-whitespace/comments
135 take-rest swap warnings>> push ;
137 : parse-directive ( preprocessor-state sequence-parser string -- )
139 { "warning" [ handle-warning ] }
140 { "error" [ handle-error ] }
141 { "include" [ handle-include ] }
142 { "define" [ handle-define ] }
143 { "undef" [ handle-undef ] }
144 { "ifdef" [ handle-ifdef ] }
145 { "ifndef" [ handle-ifndef ] }
146 { "endif" [ handle-endif ] }
147 { "if" [ handle-if ] }
148 { "elif" [ handle-elif ] }
149 { "else" [ handle-else ] }
150 { "pragma" [ handle-pragma ] }
151 { "include_next" [ handle-include-next ] }
152 [ unknown-c-preprocessor ]
155 : parse-directive-line ( preprocessor-state sequence-parser -- )
156 advance dup take-token
157 pick processing-disabled?>> [
159 drop f >>processing-disabled?
160 [ 1 - ] change-ifdef-nesting
167 : preprocess-line ( preprocessor-state sequence-parser -- )
168 skip-whitespace/comments dup current CHAR: # =
169 [ parse-directive-line ]
170 [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
172 : preprocess-lines ( preprocessor-state -- )
174 [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
177 ERROR: include-nested-too-deeply ;
179 : check-nesting ( preprocessor-state -- preprocessor-state )
180 [ 1 + ] change-include-nesting
181 dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
182 include-nested-too-deeply
185 : preprocess-file ( preprocessor-state path -- )
186 [ check-nesting ] dip
187 [ utf8 [ preprocess-lines ] with-file-reader ]
188 [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
190 : start-preprocess-file ( path -- preprocessor-state string )
191 dup parent-directory [
193 [ <preprocessor-state> dup ] dip preprocess-file