Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 313 lines (258 sloc) 9.631 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 Authors:
20 2010, Rudy Sicard
21 *)
22
23 (* depends *)
24 module List = Base.List
25
26 (* shorthands *)
27 module P = Passes
28 module Q = QmlAst
29
30
31 let (|>) = InfixOperator.(|>)
32
33 exception Partial_application
34
35 type 'a macro = {
36 name : Ident.t;
37 arity : int;
38 def : 'a;
39 }
40
41 let macro =
42 WarningClass.create
43 ~public:true
44 ~name:"macro"
45 ~doc:"All the macro expansion related warnings"
46 ~err:false
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
47 ~enable:true
fccc685 Initial open-source release
MLstate authored
48 ()
49
50 let macro_call =
51 WarningClass.create
52 ~parent:macro
53 ~public:true
54 ~name:"call"
55 ~doc:"Call with a number of argument inconsistant with its definition, will use function call semantics instead"
56 ~err:false
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
57 ~enable:true
58 ()
59
60 let macro_second_order =
61 WarningClass.create
62 ~parent:macro
63 ~public:true
64 ~name:"second-order"
65 ~doc:"Second order use of a macro, will use function call semantics instead"
66 ~err:false
fccc685 Initial open-source release
MLstate authored
67 ~enable:false
68 ()
69
70 let warning_set =
71 WarningClass.Set.create_from_list [
72 macro;
73 macro_call;
74 ]
75
76 type env = Q.expr macro IdentMap.t
77
78 let werror ~wclass e fmt =
79 QmlError.warning ~wclass (QmlError.Context.expr e) fmt
80
81
82
83 (*** collecting macro definition ***)
84 let rec make_macro name def =
85 match def with
86 (* going through coercions does weaken the typing :/ not sure what to do
87 * (same reason as the one explained below) *)
88 | Q.Coerce (_, e, _) -> make_macro name e
89 | Q.Directive (_, #Q.slicer_directive, [e], _) -> make_macro name e
90 | Q.Lambda (_, args, _) ->
91 { arity = List.length args ; def = def ; name = name }
92 | _ ->
93 OManager.error "@[<v>%a@]@\n Trying to define a non lambda macro."
94 FilePos.pp_pos (Q.Pos.expr def)
95
96
97 let check_no_expand e =
98 QmlAstWalk.Expr.iter
99 (function
100 | Q.Directive (label, `expand _, _, _) ->
101 let context = QmlError.Context.label label in
102 QmlError.serror context
103 "Illegal @@expand: it can only appear on toplevel bindings."
104 | _ -> ()) e
105
106 (* give the definition of a potential macro *)
107 let rec get_directive_macro name e =
108 match e with
109 | Q.Directive (_, `expand i,[def],_) ->
110 (* discarding the directive *)
111 check_no_expand def;
112 let macro = make_macro name def in
113 def, macro, i
114 | Q.Directive (_, `expand _, _, _) ->
115 OManager.i_error "Macro Expansion, empty expand directive"
116
117 | Q.Coerce (label, expr, ty) ->
118 let expr, macro, i = get_directive_macro name expr in
119 Q.Coerce (label, expr, ty), macro, i
120 (* going through coercions on purpose but not quite as we should
121 * if we say @expand f : t = x -> x
122 * then we would need to go and look at the type of t to propagate
123 * the type constraint on the body and on the parameters
124 * (otoh f(x:truc) : machin = ... works ok) *)
125 | Q.Directive (label, d, [expr], t) ->
126 let expr, macro, i = get_directive_macro name expr in
127 Q.Directive (label, d, [expr], t), macro, i
128
129 | _ ->
130 check_no_expand e;
131 raise Exit
132
133
134
135 (* on expression, add the definition of a potential macro *)
136 let collect_1_macro macro_map ((name, e) as bnd) =
137 try
138 let def, macro, _i = get_directive_macro name e in
139 let macro_map = IdentMap.add name macro macro_map in
140 macro_map, (name, def)
141 with Exit ->
142 macro_map, bnd
143
144
145
146 (* on code, same *)
147 let collect_macro code =
148 (* we don't need to go through db default values, because these
149 * are only identifiers at this stage *)
150 QmlAstWalk.CodeExpr.fold_map_name_expr
151 collect_1_macro IdentMap.empty code
152
153
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
154 exception Bad_application
fccc685 Initial open-source release
MLstate authored
155 (*** expanding macro call ***)
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
156
157 let error_2nd_order ident e =
158 werror ~wclass:macro_second_order e
159 "Second order on macro-function '%s', the result will have non lazy semantic" (Ident.original_name ident)
160
fccc685 Initial open-source release
MLstate authored
161 let error_call ident e =
162 werror ~wclass:macro_call e
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
163 "Bad application of a macro-function '%s', the result will have non lazy semantic" (Ident.original_name ident)
fccc685 Initial open-source release
MLstate authored
164
165 (* collect substituation associated to applying args on the lambda expression *)
166 (* What if the returned type is a lambda ? seems to be buggy *)
167 let get_subst e args subs =
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
168 let fail () = raise Bad_application in
fccc685 Initial open-source release
MLstate authored
169 match e, args with
170 | Q.Lambda (_, pars, e), args ->
171 if List.length pars <> List.length args then fail () else
172 let subs =
173 List.fold_left2
174 (fun subs par arg -> IdentMap.add par arg subs) subs pars args in
175 (subs, e)
176 | _ -> fail ()
177
178
179 type 'a refresh_kind =
180 | NoRefresh
181 | RefreshWith of FilePos.pos
182 | RefreshSamePos
183
184
185
186 let refresh_annot annoto e =
187 match annoto with
188 | NoRefresh -> e
189 | RefreshSamePos ->
190 let label = Annot.next_label (Q.Pos.expr e) in
191 Q.Label.New.expr e label
192 | RefreshWith pos ->
193 let label = Annot.next_label pos in
194 Q.Label.New.expr e label
195
196 let refresh_pat_annot_deep annoto p =
197 match annoto with
198 | NoRefresh -> p
199 | RefreshSamePos ->
200 let pos = Q.Pos.pat p in
201 QmlAstWalk.Pattern.map_down (fun p ->
202 let label = Annot.next_label pos in
203 Q.Label.New.pat p label
204 ) p
205 | RefreshWith pos ->
206 QmlAstWalk.Pattern.map_down (fun p ->
207 let label = Annot.next_label pos in
208 Q.Label.New.pat p label
209 ) p
210
211
212
213 (* same on code
214 * the positions in the expanded body of the macro is the position of the call to the macro
215 * except for the arguments of the macro that keep their positions
216 *)
217 let expand_code map_to_expand code =
218 QmlAstWalk.CodeExpr.map
219 (fun e ->
220 QmlAstWalk.Expr.self_traverse_map_context_down
221 (fun self tra (subst, stack, annoto) e ->
222 match e with
223 | Q.Apply (label, (Q.Ident (_, i)), args)
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
224 when IdentMap.mem i map_to_expand -> (
225 try
fccc685 Initial open-source release
MLstate authored
226 let macro = IdentMap.find i map_to_expand in
227 let count = Option.default 0 (IdentMap.find_opt i stack) in
228 if count == 0 then
229 let stack = IdentMap.add i (count+1) stack in
230 let def = QmlAlphaConv.expr QmlAlphaConv.empty macro.def in
231 let (subst, body) = get_subst def args subst in
232 self (subst, stack, RefreshWith (Annot.pos label)) body
233 else
234 let e = refresh_annot annoto e in
235 tra (subst, stack, annoto) e
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
236 with Bad_application ->
237 error_call i e;
238 let e = refresh_annot annoto e in
239 tra (subst, stack, annoto) e
240 )
fccc685 Initial open-source release
MLstate authored
241
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
242 | Q.Ident (_, i) -> (
fccc685 Initial open-source release
MLstate authored
243 try
244 let e = IdentMap.find i subst in
245 let e = QmlAlphaConv.expr QmlAlphaConv.empty e in
246 let e = QmlAstCons.UntypedExpr.copy e in
247 self (subst, stack, RefreshSamePos (* really need to refresh? *)) e
248 with Not_found ->
829f8f5 @OpaOnWindowsNow [fix] passMacroExpansion: i_error => warning, because it can be publi…
OpaOnWindowsNow authored
249 if IdentMap.mem i map_to_expand then error_2nd_order i e;
fccc685 Initial open-source release
MLstate authored
250 let e = refresh_annot annoto e in
251 tra (subst, stack, annoto) e
252 )
253 | Q.Match (label, e, pel) ->
254 let pel =
255 List.map
256 (fun (p, e) -> (refresh_pat_annot_deep annoto p, e))
257 pel in
258 let e = Q.Match (label, e, pel) in
259 let e = refresh_annot annoto e in
260 tra (subst, stack, annoto) e
261 | _ ->
262 let e = refresh_annot annoto e in
263 tra (subst, stack, annoto) e)
264 (IdentMap.empty,IdentMap.empty, NoRefresh) e)
265 code
266
267
268
269 (* Utils for separate compilation *)
270 module S =
271 struct
272 type t = env (* the annotmap only contains the annotations
273 * of the expressions contained in the environment
274 * so it is very small *)
275 let pass = "pass_MacroExpansion"
276 let pp f _ = Format.pp_print_string f "<dummy>"
277 end
278
279 module R = ObjectFiles.Make(S)
280
281 (* you cannot have collisions between the names of different packages *)
282 let refresh package env : _ macro IdentMap.t =
283 IdentMap.map
284 (fun (macro: _ macro) ->
285 let def =
286 QmlRefresh.refresh_expr_no_annotmap package macro.def in
287 { macro with def = def })
288 env
289
290 let merge package env1 env2 =
291 let env2 = refresh package env2 in
292 IdentMap.merge (fun _ _ -> assert false) env1 env2
293
294 let save = R.save
295
296 (*
297 collect macro expansion definition and apply them on code
298 *)
299 let process_code code =
300 let map_to_expand,code = collect_macro code in
301 save map_to_expand; (* saving the macros defined here *)
302 let map_to_expand = R.fold_with_name merge map_to_expand in
303 (* gathering all the macros
304 * don't need to fold on deep dependencies since macro bodies cannot contain macros
305 * (they would have been rewritten) *)
306 expand_code map_to_expand code
307
308 (* the pass version of the previous function *)
309 let process ~options:(_:OpaEnv.opa_options) (env:'tmp_env P.env_Gen) : 'tmp_env P.env_Gen =
310 let code = env.P.qmlAst in
311 let code = process_code code in
312 { env with P.qmlAst = code }
Something went wrong with that request. Please try again.