diff options
Diffstat (limited to 'bytecomp/translmod.ml')
| -rw-r--r-- | bytecomp/translmod.ml | 59 |
1 files changed, 38 insertions, 21 deletions
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 1f475565f9..89be6f5da1 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -83,21 +83,12 @@ let rec apply_coercion strict restr arg = arg | Tcoerce_structure(pos_cc_list, id_pos_list) -> name_lambda strict arg (fun id -> + let get_field pos = Lprim(Pfield pos,[Lvar id]) in let lam = Lprim(Pmakeblock(0, Immutable), - List.map (apply_coercion_field id) pos_cc_list) in - let fv = free_variables lam in - let (lam,s) = - List.fold_left (fun (lam,s) (id',pos,c) -> - if IdentSet.mem id' fv then - let id'' = Ident.create (Ident.name id') in - (Llet(Alias,id'', - apply_coercion Alias c (Lprim(Pfield pos,[Lvar id])),lam), - Ident.add id' (Lvar id'') s) - else (lam,s)) - (lam, Ident.empty) id_pos_list + List.map (apply_coercion_field get_field) pos_cc_list) in - if s == Ident.empty then lam else subst_lambda s lam) + wrap_id_pos_list id_pos_list get_field lam) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in name_lambda strict arg (fun id -> @@ -111,8 +102,26 @@ let rec apply_coercion strict restr arg = name_lambda strict arg (fun id -> apply_coercion Alias cc (transl_normal_path path)) -and apply_coercion_field id (pos, cc) = - apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id])) +and apply_coercion_field get_field (pos, cc) = + apply_coercion Alias cc (get_field pos) + +and wrap_id_pos_list id_pos_list get_field lam = + let fv = free_variables lam in + (*Format.eprintf "%a@." Printlambda.lambda lam; + IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; + Format.eprintf "@.";*) + let (lam,s) = + List.fold_left (fun (lam,s) (id',pos,c) -> + if IdentSet.mem id' fv then + let id'' = Ident.create (Ident.name id') in + (Llet(Alias,id'', + apply_coercion Alias c (get_field pos),lam), + Ident.add id' (Lvar id'') s) + else (lam,s)) + (lam, Ident.empty) id_pos_list + in + if s == Ident.empty then lam else subst_lambda s lam + (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like @@ -154,7 +163,7 @@ let compose_coercions c1 c2 = let c3 = compose_coercions c1 c2 in let open Includemod in Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." - print_coercion c1 print_coercion c2 print_coercion c2; + print_coercion c1 print_coercion c2 print_coercion c3; c3 *) @@ -322,7 +331,7 @@ let rec transl_module cc rootpath mexp = | _ -> match mexp.mod_desc with Tmod_ident (path,_) -> - apply_coercion StrictOpt cc + apply_coercion Strict cc (transl_path ~loc:mexp.mod_loc mexp.mod_env path) | Tmod_structure str -> transl_struct [] cc rootpath str @@ -362,18 +371,26 @@ and transl_structure fields cc rootpath = function Lprim(Pmakeblock(0, Immutable), List.map (fun id -> Lvar id) (List.rev fields)) | Tcoerce_structure(pos_cc_list, id_pos_list) -> - (* ignore id_pos_list as the ids are already bound *) + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) let v = Array.of_list (List.rev fields) in - (*List.fold_left - (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*) + let get_field pos = Lvar v.(pos) + and ids = List.fold_right IdentSet.add fields IdentSet.empty in + let lam = (Lprim(Pmakeblock(0, Immutable), List.map (fun (pos, cc) -> match cc with Tcoerce_primitive p -> transl_primitive Location.none p - | _ -> apply_coercion Strict cc (Lvar v.(pos))) + | _ -> apply_coercion Strict cc (get_field pos)) pos_cc_list)) - (*id_pos_list*) + and id_pos_list = + List.filter (fun (id,_,_) -> not (IdentSet.mem id ids)) id_pos_list + in + wrap_id_pos_list id_pos_list get_field lam | _ -> fatal_error "Translmod.transl_structure" end |