Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 293 lines (240 sloc) 9.045 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
47 ~enable:false
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
57 ~enable:false
58 ()
59
60 let warning_set =
61 WarningClass.Set.create_from_list [
62 macro;
63 macro_call;
64 ]
65
66 type env = Q.expr macro IdentMap.t
67
68 let werror ~wclass e fmt =
69 QmlError.warning ~wclass (QmlError.Context.expr e) fmt
70
71
72
73 (*** collecting macro definition ***)
74 let rec make_macro name def =
75 match def with
76 (* going through coercions does weaken the typing :/ not sure what to do
77 * (same reason as the one explained below) *)
78 | Q.Coerce (_, e, _) -> make_macro name e
79 | Q.Directive (_, #Q.slicer_directive, [e], _) -> make_macro name e
80 | Q.Lambda (_, args, _) ->
81 { arity = List.length args ; def = def ; name = name }
82 | _ ->
83 OManager.error "@[<v>%a@]@\n Trying to define a non lambda macro."
84 FilePos.pp_pos (Q.Pos.expr def)
85
86
87 let check_no_expand e =
88 QmlAstWalk.Expr.iter
89 (function
90 | Q.Directive (label, `expand _, _, _) ->
91 let context = QmlError.Context.label label in
92 QmlError.serror context
93 "Illegal @@expand: it can only appear on toplevel bindings."
94 | _ -> ()) e
95
96 (* give the definition of a potential macro *)
97 let rec get_directive_macro name e =
98 match e with
99 | Q.Directive (_, `expand i,[def],_) ->
100 (* discarding the directive *)
101 check_no_expand def;
102 let macro = make_macro name def in
103 def, macro, i
104 | Q.Directive (_, `expand _, _, _) ->
105 OManager.i_error "Macro Expansion, empty expand directive"
106
107 | Q.Coerce (label, expr, ty) ->
108 let expr, macro, i = get_directive_macro name expr in
109 Q.Coerce (label, expr, ty), macro, i
110 (* going through coercions on purpose but not quite as we should
111 * if we say @expand f : t = x -> x
112 * then we would need to go and look at the type of t to propagate
113 * the type constraint on the body and on the parameters
114 * (otoh f(x:truc) : machin = ... works ok) *)
115 | Q.Directive (label, d, [expr], t) ->
116 let expr, macro, i = get_directive_macro name expr in
117 Q.Directive (label, d, [expr], t), macro, i
118
119 | _ ->
120 check_no_expand e;
121 raise Exit
122
123
124
125 (* on expression, add the definition of a potential macro *)
126 let collect_1_macro macro_map ((name, e) as bnd) =
127 try
128 let def, macro, _i = get_directive_macro name e in
129 let macro_map = IdentMap.add name macro macro_map in
130 macro_map, (name, def)
131 with Exit ->
132 macro_map, bnd
133
134
135
136 (* on code, same *)
137 let collect_macro code =
138 (* we don't need to go through db default values, because these
139 * are only identifiers at this stage *)
140 QmlAstWalk.CodeExpr.fold_map_name_expr
141 collect_1_macro IdentMap.empty code
142
143
144
145 (*** expanding macro call ***)
146 let error_call ident e =
147 werror ~wclass:macro_call e
148 "Partial application of a macro-function '%s', the result will have non lazy semantic" (Ident.original_name ident)
149
150 (* collect substituation associated to applying args on the lambda expression *)
151 (* What if the returned type is a lambda ? seems to be buggy *)
152 let get_subst e args subs =
153 let fail () =
154 OManager.i_error "Macro Expansion, get_subst, with invalid arity" in
155 match e, args with
156 | Q.Lambda (_, pars, e), args ->
157 if List.length pars <> List.length args then fail () else
158 let subs =
159 List.fold_left2
160 (fun subs par arg -> IdentMap.add par arg subs) subs pars args in
161 (subs, e)
162 | _ -> fail ()
163
164
165 type 'a refresh_kind =
166 | NoRefresh
167 | RefreshWith of FilePos.pos
168 | RefreshSamePos
169
170
171
172 let refresh_annot annoto e =
173 match annoto with
174 | NoRefresh -> e
175 | RefreshSamePos ->
176 let label = Annot.next_label (Q.Pos.expr e) in
177 Q.Label.New.expr e label
178 | RefreshWith pos ->
179 let label = Annot.next_label pos in
180 Q.Label.New.expr e label
181
182 let refresh_pat_annot_deep annoto p =
183 match annoto with
184 | NoRefresh -> p
185 | RefreshSamePos ->
186 let pos = Q.Pos.pat p in
187 QmlAstWalk.Pattern.map_down (fun p ->
188 let label = Annot.next_label pos in
189 Q.Label.New.pat p label
190 ) p
191 | RefreshWith pos ->
192 QmlAstWalk.Pattern.map_down (fun p ->
193 let label = Annot.next_label pos in
194 Q.Label.New.pat p label
195 ) p
196
197
198
199 (* same on code
200 * the positions in the expanded body of the macro is the position of the call to the macro
201 * except for the arguments of the macro that keep their positions
202 *)
203 let expand_code map_to_expand code =
204 QmlAstWalk.CodeExpr.map
205 (fun e ->
206 QmlAstWalk.Expr.self_traverse_map_context_down
207 (fun self tra (subst, stack, annoto) e ->
208 match e with
209 | Q.Apply (label, (Q.Ident (_, i)), args)
210 when IdentMap.mem i map_to_expand ->
211 let macro = IdentMap.find i map_to_expand in
212 let count = Option.default 0 (IdentMap.find_opt i stack) in
213 if count == 0 then
214 let stack = IdentMap.add i (count+1) stack in
215 let def = QmlAlphaConv.expr QmlAlphaConv.empty macro.def in
216 let (subst, body) = get_subst def args subst in
217 self (subst, stack, RefreshWith (Annot.pos label)) body
218 else
219 let e = refresh_annot annoto e in
220 tra (subst, stack, annoto) e
221
222 | Q.Ident (_, i) -> (
223 try
224 let e = IdentMap.find i subst in
225 let e = QmlAlphaConv.expr QmlAlphaConv.empty e in
226 let e = QmlAstCons.UntypedExpr.copy e in
227 self (subst, stack, RefreshSamePos (* really need to refresh? *)) e
228 with Not_found ->
229 if IdentMap.mem i map_to_expand then error_call i e;
230 let e = refresh_annot annoto e in
231 tra (subst, stack, annoto) e
232 )
233 | Q.Match (label, e, pel) ->
234 let pel =
235 List.map
236 (fun (p, e) -> (refresh_pat_annot_deep annoto p, e))
237 pel in
238 let e = Q.Match (label, e, pel) in
239 let e = refresh_annot annoto e in
240 tra (subst, stack, annoto) e
241 | _ ->
242 let e = refresh_annot annoto e in
243 tra (subst, stack, annoto) e)
244 (IdentMap.empty,IdentMap.empty, NoRefresh) e)
245 code
246
247
248
249 (* Utils for separate compilation *)
250 module S =
251 struct
252 type t = env (* the annotmap only contains the annotations
253 * of the expressions contained in the environment
254 * so it is very small *)
255 let pass = "pass_MacroExpansion"
256 let pp f _ = Format.pp_print_string f "<dummy>"
257 end
258
259 module R = ObjectFiles.Make(S)
260
261 (* you cannot have collisions between the names of different packages *)
262 let refresh package env : _ macro IdentMap.t =
263 IdentMap.map
264 (fun (macro: _ macro) ->
265 let def =
266 QmlRefresh.refresh_expr_no_annotmap package macro.def in
267 { macro with def = def })
268 env
269
270 let merge package env1 env2 =
271 let env2 = refresh package env2 in
272 IdentMap.merge (fun _ _ -> assert false) env1 env2
273
274 let save = R.save
275
276 (*
277 collect macro expansion definition and apply them on code
278 *)
279 let process_code code =
280 let map_to_expand,code = collect_macro code in
281 save map_to_expand; (* saving the macros defined here *)
282 let map_to_expand = R.fold_with_name merge map_to_expand in
283 (* gathering all the macros
284 * don't need to fold on deep dependencies since macro bodies cannot contain macros
285 * (they would have been rewritten) *)
286 expand_code map_to_expand code
287
288 (* the pass version of the previous function *)
289 let process ~options:(_:OpaEnv.opa_options) (env:'tmp_env P.env_Gen) : 'tmp_env P.env_Gen =
290 let code = env.P.qmlAst in
291 let code = process_code code in
292 { env with P.qmlAst = code }
Something went wrong with that request. Please try again.