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.categories
7 combinators.short-circuit c.lexer ;
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 exists? ] find nip
59 ! path header-file-missing
63 :: read-local-include ( preprocessor-state path -- )
64 current-directory get path append-path dup :> full-path
66 [ preprocessor-state ] dip preprocess-file
68 ! full-path header-file-missing
72 : skip-whitespace/comments ( sequence-parser -- sequence-parser )
75 { [ dup take-c-comment ] [ skip-whitespace/comments ] }
76 { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
80 : handle-include ( preprocessor-state sequence-parser -- )
81 skip-whitespace/comments advance dup previous {
82 { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
83 { CHAR: " [ CHAR: " take-until-object read-local-include ] }
88 readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
90 : readlns ( -- string ) [ (readlns) ] { } make concat ;
92 : take-define-identifier ( sequence-parser -- string )
93 skip-whitespace/comments
94 [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
96 :: handle-define ( preprocessor-state sequence-parser -- )
97 sequence-parser take-define-identifier :> ident
98 sequence-parser skip-whitespace/comments take-rest :> def
99 def "\\" ?tail [ readlns append ] when :> def
100 def ident preprocessor-state symbol-table>> set-at ;
102 : handle-undef ( preprocessor-state sequence-parser -- )
103 take-token swap symbol-table>> delete-at ;
105 : handle-ifdef ( preprocessor-state sequence-parser -- )
106 [ [ 1 + ] change-ifdef-nesting ] dip
107 take-token over symbol-table>> key?
108 [ drop ] [ t >>processing-disabled? drop ] if ;
110 : handle-ifndef ( preprocessor-state sequence-parser -- )
111 [ [ 1 + ] change-ifdef-nesting ] dip
112 take-token over symbol-table>> key?
113 [ t >>processing-disabled? drop ]
116 : handle-endif ( preprocessor-state sequence-parser -- )
117 drop [ 1 - ] change-ifdef-nesting drop ;
119 : handle-if ( preprocessor-state sequence-parser -- )
120 [ [ 1 + ] change-ifdef-nesting ] dip
121 skip-whitespace/comments take-rest swap ifs>> push ;
123 : handle-elif ( preprocessor-state sequence-parser -- )
124 skip-whitespace/comments take-rest swap elifs>> push ;
126 : handle-else ( preprocessor-state sequence-parser -- )
127 skip-whitespace/comments take-rest swap elses>> push ;
129 : handle-pragma ( preprocessor-state sequence-parser -- )
130 skip-whitespace/comments take-rest swap pragmas>> push ;
132 : handle-include-next ( preprocessor-state sequence-parser -- )
133 skip-whitespace/comments take-rest swap include-nexts>> push ;
135 : handle-error ( preprocessor-state sequence-parser -- )
136 skip-whitespace/comments take-rest swap errors>> push ;
137 ! nip take-rest throw ;
139 : handle-warning ( preprocessor-state sequence-parser -- )
140 skip-whitespace/comments
141 take-rest swap warnings>> push ;
143 : parse-directive ( preprocessor-state sequence-parser string -- )
145 { "warning" [ handle-warning ] }
146 { "error" [ handle-error ] }
147 { "include" [ handle-include ] }
148 { "define" [ handle-define ] }
149 { "undef" [ handle-undef ] }
150 { "ifdef" [ handle-ifdef ] }
151 { "ifndef" [ handle-ifndef ] }
152 { "endif" [ handle-endif ] }
153 { "if" [ handle-if ] }
154 { "elif" [ handle-elif ] }
155 { "else" [ handle-else ] }
156 { "pragma" [ handle-pragma ] }
157 { "include_next" [ handle-include-next ] }
158 [ unknown-c-preprocessor ]
161 : parse-directive-line ( preprocessor-state sequence-parser -- )
162 advance dup take-token
163 pick processing-disabled?>> [
165 drop f >>processing-disabled?
166 [ 1 - ] change-ifdef-nesting
173 : preprocess-line ( preprocessor-state sequence-parser -- )
174 skip-whitespace/comments dup current CHAR: # =
175 [ parse-directive-line ]
176 [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
178 : preprocess-lines ( preprocessor-state -- )
180 [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
183 ERROR: include-nested-too-deeply ;
185 : check-nesting ( preprocessor-state -- preprocessor-state )
186 [ 1 + ] change-include-nesting
187 dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
188 include-nested-too-deeply
191 : preprocess-file ( preprocessor-state path -- )
192 [ check-nesting ] dip
193 [ utf8 [ preprocess-lines ] with-file-reader ]
194 [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
196 : start-preprocess-file ( path -- preprocessor-state string )
197 dup parent-directory [
199 [ <preprocessor-state> dup ] dip preprocess-file