Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 537 lines (478 sloc) 16.859 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 (* cf mli *)
19
20 (* URGENT : THIS MODULE SHOULD BE REWRITTEN USING A WALKER ON EXPR *)
21 (* IT WOULD SIMPLIFY ITS MAINTENABILITY (Nary would have had no fix to do) *)
22
23 (* refactoring in progress *)
24
25 (* depends *)
26 module List = BaseList
27
28 (* shorthands *)
29 module Q = QmlAst
30 module QC = QmlAstCons.UntypedExpr
31
32 (* go *)
33
34 module HacksForPositions =
35 struct
36 let annotmap = ref ( QmlAnnotMap.empty : Q.annotmap )
37 let set_annotmap map = annotmap := map
38 let free_annotmap () = annotmap := QmlAnnotMap.empty
39 (*
40 Map the context, and add the current annotmap.
41 Should be used each time a context is created.
42 *)
43 let map context =
44 let c = QmlError.Context.annotmap !annotmap in
45 QmlError.Context.merge2 context c
46 end
47
48 type t =
49 {
50 map : Ident.t IdentMap.t ; (* current -> alpha *)
51 rev : Ident.t IdentMap.t ; (* we keep alpha -> org *)
52 (* this map is the smallest and contain first level alpah ident actually used *)
53 weak : Ident.t -> bool ;
54 (* used for the check unbound (TODO(K1) document this) *)
55 val_ : (string -> Ident.t) option ;
56 }
57
58 let to_string t =
59 let tmp1 = IdentMap.fold (
60 fun org neww acc ->
61 Printf.sprintf "%s%s --> %s\n" acc (Ident.to_string org) (Ident.to_string neww)
62 ) t.map "" in
63 let tmp2 = IdentMap.fold (
64 fun org neww acc ->
65 Printf.sprintf "%s[%s] = {%s}\n" acc (Ident.to_string org) (Ident.to_string neww)
66 ) t.rev "" in
67 Printf.sprintf "keys = %d\n%s\n-----------------------------------------------\nkeys = %d\n%s"
68 (IdentMap.size t.map) tmp1 (IdentMap.size t.rev) tmp2
69
70 let create_from_maps ~map ~revmap =
71 {
72 map = map ;
73 rev = revmap ;
74 weak = (fun _ -> false) ;
75 val_ = None ;
76 }
77
78
79 let next ?(weak=fun _ -> false) () =
80 {
81 map = IdentMap.empty ;
82 rev = IdentMap.empty ;
83 weak = weak ;
84 val_ = None ;
85 }
86
87 let empty = next ~weak:(fun _ -> true) ()
88
89 let env_weak ~weak t = { t with weak = weak }
90
91 (* Fresh : don't allow any anonymous conv *)
92 let conv t s =
93 let id = Ident.refresh s in
94 let map, rev = match IdentMap.find_opt s t.rev with
95 | None ->
96 t.map,
97 (* this key is not in rev so we add it *)
98 IdentMap.add id s t.rev
99 | Some u ->
100 (* we update the relation org name -> alpha *)
101 IdentMap.add u id t.map,
102 (* we update new alpha -> org, and we delete the old one *)
103 IdentMap.remove s (IdentMap.add id u t.rev)
104 in
105 { t with map = IdentMap.add s id map; rev = rev }, id
106
107 module Error =
108 struct
109 (*
110 This module is used for Checking (check_fail) and for public errors.
111 We use an internal reference for knowing the current mode.
112 *)
113 let check_fail = ref None
114 let serror context fmt =
115 match !check_fail with
116 | Some cond_id ->
117 QmlError.scheck_fail cond_id context fmt
118 | None ->
119 QmlError.serror context fmt
120
121 let unbound_ident context ident =
122 serror context
123 "Unbound value @{<bright>%s@}"
124 (Ident.to_string ident)
125
126 let several_bound context ident =
127 serror context
128 "the ident @{<bright>%s@} is bound several time"
129 (Ident.to_string ident)
130
131 let several_bound_pattern context ident =
132 serror context
133 "the ident @{<bright>%s@} is bound several time in this pattern"
134 (Ident.to_string ident)
135
136 (* | NotAlphaRenamed of QmlError.context IdentMap.t *)
137
138 end
139
140 (*
141 | NotAlphaRenamed map ->
142 let buffer =
143 IdentMap.fold
144 (fun id nodes buffer ->
145 FBuffer.addln buffer
146 (locates expr_pat_or_newval (List.map (fun (_,b) -> b) nodes)
147 (Printf.sprintf "ident %S is defined multiple times"
148 (Ident.to_string id))))
149 map (FBuffer.create 10)
150 in
151 FBuffer.contents buffer
152 *)
153
154 let pat t p =
155 let rec aux check t p =
156 let conv t id =
157 let check id =
158 if IdentSet.mem id check then
159 let context =
160 let c = QmlError.Context.pat p in
161 let c = HacksForPositions.map c in
162 c
163 in
164 Error.several_bound_pattern context id;
165 check
166 else IdentSet.add id check in
167 let check = check id in check, conv t id in
168 let (!!) p0 =
169 let annot = Q.QAnnot.pat p in
170 Q.QAnnot.New.pat p0 annot in
171 match p with
172 | Q.PatRecord (label, fields, rowvar) ->
173 let foldmap (check, t) (field, pat_) =
174 let check, (t, pat_) = aux check t pat_ in
175 (check, t), (field, pat_)
176 in
177 let (check, t), fields = List.fold_left_map foldmap (check, t) fields in
178 check, (t, !! (Q.PatRecord (label, fields, rowvar)))
179
180 | Q.PatConst _ -> check, (t, p)
181 | Q.PatVar (label, id) ->
182 let check, (t, id) = conv t id in
183 check, (t, !! (Q.PatVar (label, id)))
184 | Q.PatAny _ -> check, (t, p)
185 | Q.PatCoerce (label, pat, ty) ->
186 let check, (t, pat) = aux check t pat in
187 check, (t, !! (Q.PatCoerce (label, pat, ty)))
188 | Q.PatAs (label, pat, id) ->
189 let check, (t, id) = conv t id in
190 let check, (t, pat) = aux check t pat in
191 check, (t, !! (Q.PatAs (label, pat, id)))
192 in
193 snd (aux IdentSet.empty t p)
194
195 let several_bound_check check id expr =
196 let check =
197 if IdentSet.mem id check
198 then (
199 let context =
200 let c = QmlError.Context.expr expr in
201 let c = HacksForPositions.map c in
202 c
203 in
204 Error.several_bound context id ;
205 check
206 )
207 else
208 IdentSet.add id check
209 in
210 check
211
212 let rec expr t e =
213 let (!!) e0 =
214 let annot = Q.QAnnot.expr e in
215 Q.QAnnot.New.expr e0 annot in
216 let c =
217 match e with
218 | (Q.Const _) as c -> c
219 | Q.Ident (label, id) as ident -> (
220 match IdentMap.find_opt id t.map with
221 | None ->
222 if t.weak id
223 then
224 ident
225 else (
226 let context =
227 let c = QmlError.Context.expr e in
228 let c = HacksForPositions.map c in
229 c
230 in
231 Error.unbound_ident context id ;
232 ident
233 )
234 | Some id -> Q.Ident (label, id)
235 )
236
237 | Q.LetIn (label, let_, in_) ->
238 let fold_map (check, ft) (id, expr_) =
239 let check = several_bound_check check id expr_ in
240 let ft, id = conv ft id in
241 (* beware in [expr t expr_], it is really t not ft :(thing about it) *)
242 (check, ft), (id, expr t expr_)
243 in
244 let (_, t), let_ = List.fold_left_map fold_map (IdentSet.empty, t) let_ in
245 Q.LetIn (label, let_, expr t in_)
246
247 | Q.LetRecIn (label, let_, in_) ->
248 let (_, t) = List.fold_left (fun (check, t) (id, expr_) ->
249 let check = several_bound_check check id expr_ in
250 check, fst (conv t id))
251 (IdentSet.empty, t) let_ in
252 let fmap (id, exp) =
253 match IdentMap.find_opt id t.map with
254 | None -> assert false (* we've just put it into *)
255 | Some id -> (id, expr t exp) in
256 Q.LetRecIn (label, List.map fmap let_, expr t in_)
257
258 | Q.Lambda (label, fl, x) ->
259 let t, fl = List.fold_left_map_stable conv t fl in
260 Q.Lambda (label, fl, expr t x)
261
262 | Q.Apply (label, f, args) ->
263 let f = expr t f in
264 let args = List.map_stable (expr t) args in
265 Q.Apply (label, f, args)
266
267 | Q.Match (label, e2, pat_expr) ->
268 let map (pat_, expr_) =
269 let t, pat_ = pat t pat_ in
270 let expr_ = expr t expr_ in
271 (pat_, expr_) in
272 Q.Match (label, expr t e2, List.map map pat_expr)
273
274 | Q.Record (label, fields) -> Q.Record (label, (List.map (fun (f, e) -> (f, expr t e)) fields))
275
276 | Q.Dot (label, e, f) -> Q.Dot (label, expr t e, f)
277 | Q.ExtendRecord (label, f, e, n) -> Q.ExtendRecord (label, f, expr t e, expr t n)
278 | (Q.Bypass _) as by -> by
279 | Q.Coerce (label, e, ty) -> Q.Coerce (label, expr t e, ty)
28521d4 @BourgerieQuentin [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
BourgerieQuentin authored
280 | Q.Path (label, p,h) -> Q.Path (label, List.map (function Q.Db.ExprKey e -> Q.Db.ExprKey (expr t e) | k -> k) p, h)
fccc685 Initial open-source release
MLstate authored
281
282 | Q.Directive (_, `backend_ident _,_,_) as e ->
283 (* not going inside `backend_ident, because it does contain
284 * an unbound ident, but this in on purpose *)
285 e
286
287 | Q.Directive (_, (#QmlDependencies.directive_dep as dir), _, _) as expr0 ->
288 let _ =
289 match t.val_ with
290 | Some val_ ->
291 QmlDependencies.fold_directive_deps (fun x -> x) val_ dir
292 (fun id _ ->
293 if not (IdentMap.mem id t.map) && not (t.weak id)
294 then
295 let context =
296 let c = QmlError.Context.expr e in
297 let c = HacksForPositions.map c in
298 c
299 in
300 Error.unbound_ident context id
301 )
302 ()
303 | None -> ()
304 in
305 expr0
306
307 | Q.Directive (label, d, e, ty) -> Q.Directive (label, d, List.map (expr t) e, ty)
308 in !! c
309
310 (* wait for a next commit with unification of NewVal and NewValRec, with a flag `valrec | `valand *)
311 let code_elt t = function
312 | Q.NewVal (label, val_) ->
313 let fold_map (check, ft) (id, expr_) =
314 let check = several_bound_check check id expr_ in
315 let ft, id = conv ft id in
316 (check, ft), (id, expr t expr_) in
317 let (_, t), val_ = List.fold_left_map fold_map (IdentSet.empty, t) val_ in
318 t, Q.NewVal (label, val_)
319
320 | Q.NewValRec (label, val_) ->
321 let (_, t) = List.fold_left (
322 fun (check, t) (id, expr_) ->
323 let check = several_bound_check check id expr_ in
324 check, fst (conv t id)
325 )
326 (IdentSet.empty, t) val_
327 in
328 let map (id, exp) =
329 match IdentMap.find_opt id t.map with
330 | None -> assert false (* same thing *)
331 | Some id -> (id, expr t exp) in
332 let val_ = List.map map val_ in
333 t, Q.NewValRec (label, val_)
334
335 | Q.Database (_, db_id, _, _) as elt ->
336 (* a hack: register the id from db, but don't alpha-convert it;
337 TODO: complain early (here?) if 2 db have the same prefix *)
338 { t with weak = fun id -> Ident.equal id db_id || t.weak id }, elt
339
340 | elt -> t, elt
341
342 let code t code =
343 List.fold_left_map code_elt t code
344
345 let ident t id = IdentMap.find_opt id t.map
346 let rev_ident t id = IdentMap.find_opt id t.rev
347
348 let next_code ?(weak=fun _ -> false) code_ =
349 let next = next ~weak () in
350 snd (code next code_)
351
352 let clean t =
353 let tmp = next () in
354 let map = IdentMap.fold (
355 fun neww org map ->
356 IdentMap.add org neww map
357 ) t.rev tmp.map
358 in
359 { tmp with rev = t.rev; map = map }
360
361 (* this function update the qmlAlphaConv acc to be able to make external first level renaming
362 without losing the succession org -> alpha -> alpha -> ... -> last alpha
363 An alpha convversion must be launched after this
364 *)
365 let update t m =
366 let t = clean t in
367 let tmp = IdentMap.fold (
368 fun neww org acc ->
369 match IdentMap.find_opt neww m with
370 | None -> acc
371 | Some i -> IdentMap.add i org (IdentMap.remove neww acc)
372 ) t.rev t.rev
373 in
374 { t with rev = tmp }
375
376 module Check =
377 struct
378 type ('env, 'a) checker = ('env -> 'a) -> 'env PassHandler.cond
379
380 let cond_ident =
381 let doc = "Idents checks" in
382 WarningClass.create
383 ~parent:WarningClass.cond
384 ~name:"ident"
385 ~doc
386 ~err:true
387 ~enable:true
388 ()
389 let cond_ident_alpha =
390 WarningClass.create
391 ~parent:cond_ident
392 ~name:"alpha"
393 ~doc:"Alpha-conversion preconditions"
394 ~err:true
395 ~enable:true
396 ()
397 let cond_ident_unbound =
398 WarningClass.create
399 ~parent:cond_ident
400 ~name:"unbound"
401 ~doc:"Checking existence of unbound idents"
402 ~err:true
403 ~enable:true
404 ()
405 let cond_ident_unicity =
406 WarningClass.create
407 ~parent:cond_ident
408 ~name:"unicity"
409 ~doc:"Checking unicity of idents"
410 ~err:true
411 ~enable:true
412 ()
413
414 let id = PassHandler.define_cond cond_ident
415 let alpha_id = PassHandler.define_cond cond_ident_alpha
416 let unicity_id = PassHandler.define_cond cond_ident_unicity
417 let unbound_id = PassHandler.define_cond cond_ident_unbound
418
419 (* always accept that identifiers from other packages are unbound
420 * (in the current package of course) *)
421 let default_weak ident =
422 match Ident.safe_get_package_name ident with
423 | Some p -> ObjectFiles.get_current_package_name () <> p
424 | None -> false
425
426 (* Checks that alpha-conversion preconditions are satisfied. *)
427 let alpha extract =
428 PassHandler.make_condition unicity_id
429 (fun env ->
430 let annotmap, code_ = extract env in
431 HacksForPositions.set_annotmap annotmap ;
432 Error.check_fail := Some alpha_id ;
433 ignore (code (next ~weak:default_weak ()) code_) ;
434 HacksForPositions.free_annotmap () ;
435 Error.check_fail := None ;
436 ()
437 )
438
439 let unbound ?(weak=fun _ -> false) val_ extract =
440 let weak ident = weak ident || default_weak ident in
441 PassHandler.make_condition unbound_id
442 (fun env ->
443 let annotmap, code_ = extract env in
444 HacksForPositions.set_annotmap annotmap ;
445 Error.check_fail := Some alpha_id ;
446 let t = next ~weak () in
447 let t = { t with val_ = Some val_ } in
448 ignore (code t code_) ;
449 HacksForPositions.free_annotmap () ;
450 Error.check_fail := None ;
451 ()
452 )
453
454 (* unicity *)
455
456 let map_add k v m =
457 IdentMap.add
458 k (v :: (try IdentMap.find k m with Not_found -> [])) m
459
460 (*
461 Compute a map of id, in which each id is associated to the list of its binding.
462 At the end, any id with an non singleton binding list means a duplication of identifier.
463 *)
464 let identmap code =
465 let fold_expr identmap e =
466 QmlAstWalk.ExprPatt.fold
467 (fun identmap e ->
468 match e with
469 | Q.LetIn (_, ds, _)
470 | Q.LetRecIn (_, ds, _) ->
471 List.fold_left
472 (fun identmap (id,_) -> map_add id (`expr e) identmap)
473 identmap ds
474 | Q.Lambda (_, args, _) ->
475 List.fold_left
476 (fun identmap id -> map_add id (`expr e) identmap)
477 identmap args
478 | _ -> identmap)
479 (fun identmap p ->
480 match p with
481 | Q.PatVar (_, id) | Q.PatAs (_, _, id) ->
482 map_add id (`pat p) identmap
483 | _ -> identmap)
484 identmap e
485 in
486 let check_elt identmap = function
487 | Q.NewVal (_, ds)
488 | Q.NewValRec (_, ds) ->
489 List.fold_left
490 (fun identmap (id, e) ->
491 let identmap = map_add id (`expr e) identmap in
492 fold_expr identmap e)
493 identmap ds
494 | Q.Database (_, id, _, _) ->
495 let dummy_expr = QC.ident id in
496 map_add id (`expr dummy_expr) identmap
497 | Q.NewDbValue (_, dbval) ->
498 fst (Q.Db.foldmap_expr (fun m e -> fold_expr m e, e) identmap dbval)
499 | _ -> identmap
500 in
501 List.fold_left check_elt IdentMap.empty code
502
503 let unicity extract =
504 PassHandler.make_condition unicity_id
505 (fun env ->
506 let annotmap, code = extract env in
507 HacksForPositions.set_annotmap annotmap ;
508 let identmap = identmap code in
509 let iter id = function
510 | [] -> assert false
511 | [_] -> ()
512 | hd::tl ->
513 let make_context = function
514 | `expr e ->
515 QmlError.Context.expr e
516 | `pat p ->
517 QmlError.Context.pat p
518 in
519 let context =
520 let fold acc bind =
521 let context = make_context bind in
522 QmlError.Context.merge2 acc context
523 in
524 List.fold_left fold (make_context hd) tl
525 in
526 let context = HacksForPositions.map context in
527 QmlError.scheck_fail unicity_id context (
528 "The ident @{<bright>%s@} is not uniq"
529 )
530 (Ident.to_string id)
531 in
532 let () = IdentMap.iter iter identmap in
533 HacksForPositions.free_annotmap ();
534 ()
535 )
536 end
Something went wrong with that request. Please try again.