Commit 7fd45176 authored by Leon Gondelman's avatar Leon Gondelman

Coercions

Now adding the very same coercion is accepted (useful for multiple/transitive use imports)
parent 739155b1
......@@ -27,18 +27,10 @@ let mem ts1 ts2 crcmap =
try let m = Mts.find ts1 crcmap in Mts.mem ts2 m
with Not_found -> false
let decide c_old _c_new _m1 _m =
raise (CoercionAlreadyDefined (c_old.crc_src, c_old.crc_tar))
(* let c_m1 = Mts.find c.crc_tar m1 in
if c.crc_len < c_m1.crc_len then
begin
Warning.emit
"Some coercion hides a previous coercion from %s to %s"
c.crc_src.ts_name.id_string c.crc_tar.ts_name.id_string;
put c m1 m (*maybe also redo closure with shorter paths *)
end
else m *)
let decide c_old c_new _m1 m =
match c_old.crc_lsl, c_new.crc_lsl with
| [ls_old], [ls_new] when ls_equal ls_old ls_new -> m
| _ -> raise (CoercionAlreadyDefined (c_old.crc_src, c_old.crc_tar))
let insert c m =
let put c m1 m2 = Mts.add c.crc_src (Mts.add c.crc_tar c m1) m2 in
......@@ -48,8 +40,8 @@ let insert c m =
| _ -> assert false (* there is always at least one coercion *)
end;
let m1 = Mts.find_def empty c.crc_src m in
if Mts.mem c.crc_tar m1 then decide (Mts.find c.crc_tar m1) c m1 m;
put c m1 m
if Mts.mem c.crc_tar m1 then decide (Mts.find c.crc_tar m1) c m1 m
else put c m1 m
let join crc1 crc2 =
{ crc_lsl = crc1.crc_lsl @ crc2.crc_lsl;
......@@ -57,33 +49,31 @@ let join crc1 crc2 =
crc_tar = crc2.crc_tar;
crc_len = crc1.crc_len + crc2.crc_len }
let rec add_crc crcmap crc trans =
let add_crc crcmap crc =
let close_right c1 _ty c2 macc =
add_crc macc (join c1 c2) false in
insert (join c1 c2) macc in
(* add_crc macc (join c1 c2) false in *)
let close_left_right _ty1 m1 macc =
if Mts.mem crc.crc_src m1
then
let c1 = Mts.find crc.crc_src m1 in
let m2 = Mts.find_def empty crc.crc_src macc in
Mts.fold (close_right c1) m2 macc
else macc in
if not trans then insert crc crcmap else
let crcmap_uc1 = insert crc crcmap in
let crcmap_uc2 =
let m1 = Mts.find_def empty crc.crc_tar crcmap_uc1 in
Mts.fold (close_right crc) m1 crcmap_uc1 in
Mts.fold (close_left_right) crcmap_uc2 crcmap_uc2
let add crcmap ls =
let c = create_crc ls in
add_crc crcmap c true
if Mts.mem crc.crc_src m1
then
let c1 = Mts.find crc.crc_src m1 in
let m2 = Mts.find_def empty crc.crc_tar macc in
Mts.fold (close_right c1) (Mts.add crc.crc_tar crc m2) macc
else macc in
let crcmap_uc1 = insert crc crcmap in
let crcmap_uc2 =
let m1 = Mts.find_def empty crc.crc_tar crcmap_uc1 in
Mts.fold (close_right crc) m1 crcmap_uc1 in
Mts.fold (close_left_right) crcmap_uc2 crcmap_uc2
let find crcmap ts1 ts2 =
Mts.find ts2 (Mts.find ts1 crcmap)
let add crcmap ls =
add_crc crcmap (create_crc ls)
let union s1 s2 =
Mts.fold (fun _ m1 s -> Mts.fold (fun _ c s -> add_crc s c true) m1 s) s2 s1
Mts.fold (fun _ m1 s -> Mts.fold (fun _ c s -> add_crc s c) m1 s) s2 s1
let () = Exn_printer.register
begin fun fmt exn -> match exn with
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment