Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Cleanup. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/constructors_with_record4@15374 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2014-09-30 09:32:55 +00:00
parent 26f6d39bb5
commit 4c378dc444
19 changed files with 62 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.depend
View File

@ -93,7 +93,7 @@ typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \
typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \
parsing/asttypes.cmi
typing/btype.cmi parsing/asttypes.cmi
typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
typing/path.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi
@ -228,10 +228,10 @@ typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \
utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/mtype.cmi
typing/oprint.cmo : typing/outcometree.cmi typing/btype.cmi \
parsing/asttypes.cmi typing/oprint.cmi
typing/oprint.cmx : typing/outcometree.cmi typing/btype.cmx \
parsing/asttypes.cmi typing/oprint.cmi
typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \
typing/oprint.cmi
typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \
typing/oprint.cmi
typing/parmatch.cmo : utils/warnings.cmi typing/types.cmi \
typing/typedtree.cmi typing/subst.cmi typing/predef.cmi typing/path.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \

10
testsuite/tests/typing-recordarg/recordarg.ml
View File

@ -6,13 +6,13 @@ M.f;;
module A : sig
type t = A of {x:int}
val f: t -> t.A
val f: t -> !t.A
end = struct
type t = A of {x:int}
let f (A r) = r
end;;
module type S = sig type t = A of {x:int} val f: t -> t.A end;;
module type S = sig type t = A of {x:int} val f: t -> !t.A end;;
module N : S with type t = M.t = M;;
@ -24,7 +24,7 @@ module M = struct
| A of {x : 'a}
| B: {u : 'b} -> unit t
exception Foo of {x : int}
(* exception Foo of {x : int} *)
end;;
module N : sig
@ -32,13 +32,13 @@ module N : sig
| A of {x : 'b}
| B: {u : 'bla} -> unit t
exception Foo of {x : int}
(* exception Foo of {x : int} *)
end = struct
type 'b t = 'b M.t =
| A of {x : 'b}
| B: {u : 'z} -> unit t
exception Foo = M.Foo
(* exception Foo = M.Foo *)
end;;

2
toplevel/genprintval.ml
View File

@ -303,7 +303,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
tree_of_constr_with_args (tree_of_constr env path)
(Ident.name cd_id) false 0 depth obj
ty_args
| Cstr_record (_, lbls) ->
| Cstr_record lbls ->
let r =
tree_of_record_fields depth
env path type_params ty_list

17
typing/btype.ml
View File

@ -255,12 +255,12 @@ type type_iterators =
let iter_type_expr_cstr_args f = function
| Cstr_tuple tl -> List.iter f tl
| Cstr_record (_, lbls) -> List.iter (fun d -> f d.ld_type) lbls
| Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls
let map_type_expr_cstr_args f = function
| Cstr_tuple tl -> Cstr_tuple (List.map f tl)
| Cstr_record (r, lbls) ->
Cstr_record (r, List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)
| Cstr_record lbls ->
Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)
let iter_type_expr_kind f = function
| Type_abstract -> ()
@ -686,14 +686,3 @@ let backtrack (changes, old) =
changes := Unchanged;
last_snapshot := old;
Weak.set trail 0 (Some changes)
let inlined_record_name typ cstr =
Printf.sprintf "!%s.%s" typ cstr
let uninlined_record_name s =
if s.[0] = '!' then
let i = String.index s '.' in
Some (String.sub s 1 (i - 1), String.sub s (i + 1) (String.length s - i - 1))
else
None

4
typing/btype.mli
View File

@ -209,7 +209,3 @@ val iter_type_expr_cstr_args: (type_expr -> unit) ->
(constructor_arguments -> unit)
val map_type_expr_cstr_args: (type_expr -> type_expr) ->
(constructor_arguments -> constructor_arguments)
val inlined_record_name: string -> string -> string
val uninlined_record_name: string -> (string * string) option

9
typing/ctype.ml
View File

@ -564,8 +564,7 @@ let closed_type_decl decl =
| None ->
match cd_args with
| Cstr_tuple l -> List.iter closed_type l
| Cstr_record (_, l) ->
List.iter (fun l -> closed_type l.ld_type) l
| Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
)
v
| Type_record(r, rep) ->
@ -1201,9 +1200,9 @@ let map_kind f = function
cd_args =
begin match c.cd_args with
| Cstr_tuple l-> Cstr_tuple (List.map f l)
| Cstr_record (id, l) ->
| Cstr_record l ->
let field l = {l with ld_type = f l.ld_type} in
Cstr_record (id, List.map field l)
Cstr_record (List.map field l)
end;
cd_res=may_map f c.cd_res
})
@ -2191,7 +2190,7 @@ and mcomp_variant_description type_pairs env xs ys =
mcomp_type_option type_pairs env c1.cd_res c2.cd_res;
begin match c1.cd_args, c2.cd_args with
| Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2
| Cstr_record (_, l1), Cstr_record (_, l2) ->
| Cstr_record l1, Cstr_record l2 ->
mcomp_record_description type_pairs env l1 l2
| _ -> raise (Unify [])
end;

6
typing/datarepr.ml
View File

@ -50,7 +50,7 @@ let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
let constructor_args name ty_path type_manifest arg_vars rep =
function
| Cstr_tuple l -> l, None
| Cstr_record (_, lbls) ->
| Cstr_record lbls ->
let path = Path.Pdot(ty_path, name, Path.nopos) in
let type_manifest =
match type_manifest with
@ -98,7 +98,7 @@ let constructor_descrs ty_path decl cstrs =
let tyl =
match cd_args with
| Cstr_tuple l -> l
| Cstr_record (_, l) -> List.map (fun l -> l.ld_type) l
| Cstr_record l -> List.map (fun l -> l.ld_type) l
in
(* Note: variables bound by Tpoly are Tvar, not Tunivar,
and thus they are not considered as free, which is
@ -152,7 +152,7 @@ let extension_descr ?rebind path_ext ext =
let tyl =
match ext.ext_args with
| Cstr_tuple l -> l
| Cstr_record (_, l) -> List.map (fun l -> l.ld_type) l
| Cstr_record l -> List.map (fun l -> l.ld_type) l
in
let arg_vars_set, arg_vars = free_vars (newgenty (Ttuple tyl)) in
let existentials =

29
typing/env.ml
View File

@ -475,29 +475,13 @@ and find_class =
and find_cltype =
find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
let is_uident s =
match s.[0] with
| 'A'..'Z' -> true
| _ -> false
let labels_of_type_fwd = ref (fun _ _ -> assert false)
let find_type_full path env =
match path with
| Pdot (Pdot(mod_path, "*ext*", _), s, _) ->
let _constr_path = Pdot(mod_path, s, Path.nopos) in
(* this is how extension constructor paths are encoded *)
(* We should lookup all constructors with constr_path,
and keep the only one (if any) that is an extension constructor. *)
(* Pb: we don't have access to its extension_constructor anymore... *)
(* We should also have an encoding for local extension constructors *)
assert false
| Pdot (ty_path, s, _) when is_uident s ->
print_endline "XXXX";
(* perhaps we should pre-compute the inner type_declaration
in Datarepr in keep it as part of the constructor_description
(instead of recreating it here)? *)
let (decl, (cstrs, _, _)) =
match Path.constructor_typath path with
| None -> find_type_full path env
| Some (ty_path, s) ->
let (_, (cstrs, _, _)) =
try find_type_full ty_path env
with Not_found -> assert false
in
@ -512,9 +496,6 @@ let find_type_full path env =
in
let labels = !labels_of_type_fwd path tdecl in
(tdecl, ([], List.map snd labels, true))
| _ -> find_type_full path env
let find_type p env =
fst (find_type_full p env)
@ -1154,13 +1135,11 @@ let rec prefix_idents root pos sub = function
(p::pl, final_sub)
| Sig_type(id, decl, _) :: rem ->
let p = Pdot(root, Ident.name id, nopos) in
let sub = Subst.add_prefixes root (Subst.sub_ids decl) sub in
let (pl, final_sub) =
prefix_idents root pos (Subst.add_type id p sub) rem in
(p::pl, final_sub)
| Sig_typext(id, ext, _) :: rem ->
let p = Pdot(root, Ident.name id, pos) in
let sub = Subst.add_prefixes root (Subst.sub_ids_ext ext) sub in
let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
(p::pl, final_sub)
| Sig_module(id, mty, _) :: rem ->

2
typing/includecore.ml
View File

@ -168,7 +168,7 @@ let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 =
(fun ty1 ty2 -> Ctype.equal env true (ty1::params1) (ty2::params2))
(arg1) (arg2)
then [] else [Field_type cstr]
| Types.Cstr_record (_, l1), Types.Cstr_record (_, l2) ->
| Types.Cstr_record l1, Types.Cstr_record l2 ->
compare_records env params1 params2 0 l1 l2
| _ ->
(* TODO: better report? *)

34
typing/includemod.ml
View File

@ -334,44 +334,18 @@ and signatures env cxt subst sig1 sig2 =
Field_type (String.sub s 0 (String.length s - 4)), false
| _ -> name2, true
in
let equate_subtypes ids1 ids2 subst =
if List.length ids1 = List.length ids2 then
List.fold_left2
(fun sub id1 id2 ->
if Ident.name id1 = Ident.name id2 then
Subst.add_type id2 (Pident id1) sub
else
sub
) subst ids1 ids2
else
subst
in
begin try
let (id1, item1, pos1) = Tbl.find name2 comps1 in
let new_subst =
match item2 with
Sig_type (id2', decl2, _) ->
let subst = Subst.add_type id2 (Pident id1) subst in
begin match item1 with
| Sig_type (id1', decl1, _) ->
let ids1 = Subst.sub_ids decl1 in
let ids2 = Subst.sub_ids decl2 in
equate_subtypes ids1 ids2 subst
| _ -> assert false
end
Sig_type _ ->
Subst.add_type id2 (Pident id1) subst
| Sig_module _ ->
Subst.add_module id2 (Pident id1) subst
| Sig_modtype _ ->
Subst.add_modtype id2 (Mty_ident (Pident id1)) subst
| Sig_typext (id2', decl2, _) ->
begin match item1 with
| Sig_typext (id1', decl1, _) ->
let ids1 = Subst.sub_ids_ext decl1 in
let ids2 = Subst.sub_ids_ext decl2 in
equate_subtypes ids1 ids2 subst
| _ -> assert false
end
| Sig_value _ | Sig_class _ | Sig_class_type _ ->
| Sig_value _ | Sig_typext _
| Sig_class _ | Sig_class_type _ ->
subst
in
pair_components new_subst

19
typing/oprint.ml
View File

@ -27,23 +27,6 @@ let rec print_ident ppf =
| Oide_apply (id1, id2) ->
fprintf ppf "%a(%a)" print_ident id1 print_ident id2
let print_type_ident ppf = function
| Oide_ident s ->
begin match Btype.uninlined_record_name s with
| None -> pp_print_string ppf s
| Some (_typ, cstr) ->
fprintf ppf "!%s" cstr
end
| Oide_dot (m, s) as id ->
begin match Btype.uninlined_record_name s with
| None -> print_ident ppf id
| Some (_typ, cstr) ->
fprintf ppf "!%a.%s" print_ident m cstr
end
| Oide_apply _ as id ->
print_ident ppf id
let parenthesized_ident name =
(List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
||
@ -209,7 +192,7 @@ and print_simple_out_type ppf =
| Otyp_constr (id, tyl) ->
pp_open_box ppf 0;
print_typargs ppf tyl;
print_type_ident ppf id;
print_ident ppf id;
pp_close_box ppf ()
| Otyp_object (fields, rest) ->
fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields

9
typing/path.ml
View File

@ -52,3 +52,12 @@ let rec last = function
| Pident id -> Ident.name id
| Pdot(_, s, _) -> s
| Papply(_, p) -> last p
let is_uident s =
match s.[0] with
| 'A'..'Z' -> true
| _ -> false
let constructor_typath = function
| Pdot(ty_path, s, _) when is_uident s -> Some (ty_path, s)
| _ -> None

2
typing/path.mli
View File

@ -28,3 +28,5 @@ val name: ?paren:(string -> bool) -> t -> string
val head: t -> Ident.t
val last: t -> string
val constructor_typath: t -> (t * string) option

22
typing/printtyp.ml
View File

@ -69,22 +69,12 @@ let rec path ppf = function
| Papply(p1, p2) ->
fprintf ppf "%a(%a)" path p1 path p2
(* Note: this logic is duplicated in Oprint.print_type_ident *)
let rec string_of_out_ident = function
| Oide_ident s ->
begin match Btype.uninlined_record_name s with
| None -> s
| Some (_typ, cstr) -> Printf.sprintf "!%s" cstr
end
| Oide_dot (m, s) ->
begin match Btype.uninlined_record_name s with
| None -> Printf.sprintf "%s.%s" (string_of_out_ident m) s
| Some (_typ, cstr) ->
Printf.sprintf "!%s.%s" (string_of_out_ident m) cstr
end
| Oide_ident s -> s
| Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s]
| Oide_apply (id1, id2) ->
Printf.sprintf "%s(%s)" (string_of_out_ident id1)
(string_of_out_ident id2)
String.concat ""
[string_of_out_ident id1; "("; string_of_out_ident id2; ")"]
let string_of_path p = string_of_out_ident (tree_of_path p)
@ -752,7 +742,7 @@ let string_of_mutable = function
let mark_loops_constructor_arguments = function
| Cstr_tuple l -> List.iter mark_loops l
| Cstr_record (_, l) -> List.iter (fun l -> mark_loops l.ld_type) l
| Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l
let rec tree_of_type_decl id decl =
@ -865,7 +855,7 @@ let rec tree_of_type_decl id decl =
and tree_of_constructor_arguments = function
| Cstr_tuple l -> tree_of_typlist false l
| Cstr_record (_, l) -> [ Otyp_record (List.map tree_of_label l) ]
| Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]
and tree_of_constructor cd =
let name = Ident.name cd.cd_id in

50
typing/subst.ml
View File

@ -21,12 +21,10 @@ type t =
{ types: (Ident.t, Path.t) Tbl.t;
modules: (Ident.t, Path.t) Tbl.t;
modtypes: (Ident.t, module_type) Tbl.t;
typids: (Ident.t, Ident.t) Tbl.t; (* only for Cstr_record ids *)
for_saving: bool }
let identity =
{ types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
typids = Tbl.empty;
for_saving = false }
let add_type id p s = { s with types = Tbl.add id p s.types }
@ -37,38 +35,6 @@ let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }
let for_saving s = { s with for_saving = true }
let sub_ids_args = function
| Cstr_record (id, _) -> [id]
| Cstr_tuple _ -> []
let sub_ids decl =
match decl.type_kind with
| Type_variant cstrs ->
List.fold_left (fun l c -> sub_ids_args c.cd_args @ l) [] cstrs
| _ -> []
let sub_ids_ext ext = sub_ids_args ext.ext_args
let add_prefixes root ids sub =
List.fold_left
(fun sub id -> add_type id (Pdot(root, Ident.name id, nopos)) sub)
sub ids
let rename_types ids sub =
List.fold_left
(fun s id ->
assert(not (Tbl.mem id s.types));
let id' = Ident.rename id in
{s with typids = Tbl.add id id' s.typids;
types = Tbl.add id (Pident id') s.types
}
)
sub ids
let loc s x =
if s.for_saving && not !Clflags.keep_locs then Location.none else x
@ -110,6 +76,11 @@ let type_path s = function
| Papply(p1, p2) ->
fatal_error "Subst.type_path"
let type_path s p =
match Path.constructor_typath p with
| None -> type_path s p
| Some (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos)
(* Special type ids for saved signatures *)
let new_id = ref (-1)
@ -230,9 +201,8 @@ let label_declaration s l =
let constructor_arguments s = function
| Cstr_tuple l ->
Cstr_tuple (List.map (typexp s) l)
| Cstr_record (id, l) ->
let id = try Tbl.find id s.typids with Not_found -> id in
Cstr_record (id, List.map (label_declaration s) l)
| Cstr_record l ->
Cstr_record (List.map (label_declaration s) l)
let type_declaration s decl =
let decl =
@ -354,7 +324,6 @@ let extension_constructor s ext =
let rec rename_bound_idents s idents = function
[] -> (List.rev idents, s)
| Sig_type(id, d, _) :: sg ->
let s = rename_types (sub_ids d) s in
let id' = Ident.rename id in
rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
| Sig_module(id, mty, _) :: sg ->
@ -365,7 +334,6 @@ let rec rename_bound_idents s idents = function
rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s)
(id' :: idents) sg
| Sig_typext(id, d, _) :: sg ->
let s = rename_types (sub_ids_ext d) s in
let id' = Ident.rename id in
rename_bound_idents s (id' :: idents) sg
| (Sig_value(id, _) | Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg ->
@ -392,12 +360,11 @@ let rec modtype s = function
Mty_alias(module_path s p)
and signature s sg =
(* TODO: rename the Ident.t in Cstr_record *)
(* Components of signature may be mutually recursive (e.g. type declarations
or class and type declarations), so first build global renaming
substitution... *)
let (new_idents, s') =
rename_bound_idents {s with typids = Tbl.empty} [] sg
rename_bound_idents s [] sg
in
(* ... then apply it to each signature component in turn *)
List.map2 (signature_component s') sg new_idents
@ -446,5 +413,4 @@ let compose s1 s2 =
{ types = merge_tbls (type_path s2) s1.types s2.types;
modules = merge_tbls (module_path s2) s1.modules s2.modules;
modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
typids = Tbl.empty;
for_saving = false }

7
typing/subst.mli
View File

@ -55,10 +55,3 @@ val module_declaration: t -> module_declaration -> module_declaration
(* Composition of substitutions:
apply (compose s1 s2) x = apply s2 (apply s1 x) *)
val compose: t -> t -> t
val sub_ids: type_declaration -> Ident.t list
val sub_ids_ext: extension_constructor -> Ident.t list
val add_prefixes: Path.t -> Ident.t list -> t -> t

9
typing/typedecl.ml
View File

@ -185,8 +185,7 @@ let transl_constructor_arguments loc env closed ty_name c_name = function
Cstr_tuple l
| Pcstr_record l ->
let lbls, lbls' = transl_labels loc env closed l in
let id = Ident.create (Btype.inlined_record_name ty_name c_name) in
Types.Cstr_record (id, lbls'),
Types.Cstr_record lbls',
Cstr_record lbls
let make_constructor loc env type_path type_params c_name sargs sret_type =
@ -415,7 +414,7 @@ let check_constraints env sdecl (_, decl) =
(fun sty ty ->
check_constraints_rec env sty.ptyp_loc visited ty)
styl tyl
| Cstr_record (_, tyl), Pcstr_record styl ->
| Cstr_record tyl, Pcstr_record styl ->
check_constraints_labels env visited tyl styl
| _ -> assert false (* todo *)
end;
@ -795,7 +794,7 @@ let constrained env vars ty =
let for_constr = function
| Types.Cstr_tuple l -> add_false l
| Types.Cstr_record (_, l) ->
| Types.Cstr_record l ->
List.map
(fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type))
l
@ -1556,7 +1555,7 @@ let explain_unbound_single ppf tv ty =
let tys_of_constr_args = function
| Types.Cstr_tuple tl -> tl
| Types.Cstr_record (_, lbls) -> List.map (fun l -> l.Types.ld_type) lbls
| Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls
let report_error ppf = function
| Repeated_parameter ->

2
typing/types.ml
View File

@ -219,7 +219,7 @@ and constructor_declaration =
and constructor_arguments =
| Cstr_tuple of type_expr list
| Cstr_record of Ident.t * label_declaration list
| Cstr_record of label_declaration list
type extension_constructor =
{ ext_type_path: Path.t;

2
typing/types.mli
View File

@ -207,7 +207,7 @@ and constructor_declaration =
and constructor_arguments =
| Cstr_tuple of type_expr list
| Cstr_record of Ident.t * label_declaration list
| Cstr_record of label_declaration list
type extension_constructor =
{