https://github.com/charguer/ocaml
Tip revision: 4548f1e68f99a1eead460251a20ebfe2b3e736f4 authored by Alain Frisch on 14 December 2010, 08:38:03 UTC
Allow implicit coercion on type with free variables (if subtyping does not unify variables).
Allow implicit coercion on type with free variables (if subtyping does not unify variables).
Tip revision: 4548f1e
depend.ml
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open Format
open Location
open Longident
open Parsetree
module StringSet = Set.Make(struct type t = string let compare = compare end)
(* Collect free module identifiers in the a.s.t. *)
let free_structure_names = ref StringSet.empty
let rec addmodule bv lid =
match lid with
Lident s ->
if not (StringSet.mem s bv)
then free_structure_names := StringSet.add s !free_structure_names
| Ldot(l, s) -> addmodule bv l
| Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2
let add bv lid =
match lid with
Ldot(l, s) -> addmodule bv l
| _ -> ()
let rec add_type bv ty =
match ty.ptyp_desc with
Ptyp_any -> ()
| Ptyp_var v -> ()
| Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
| Ptyp_tuple tl -> List.iter (add_type bv) tl
| Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
| Ptyp_object fl -> List.iter (add_field_type bv) fl
| Ptyp_class(c, tl, _) -> add bv c; List.iter (add_type bv) tl
| Ptyp_alias(t, s) -> add_type bv t
| Ptyp_variant(fl, _, _) ->
List.iter
(function Rtag(_,_,stl) -> List.iter (add_type bv) stl
| Rinherit sty -> add_type bv sty)
fl
| Ptyp_poly(_, t) -> add_type bv t
| Ptyp_package pt -> add_package_type bv pt
and add_package_type bv (lid, l) =
add bv lid;
List.iter (add_type bv) (List.map snd l)
and add_field_type bv ft =
match ft.pfield_desc with
Pfield(name, ty) -> add_type bv ty
| Pfield_var -> ()
let add_opt add_fn bv = function
None -> ()
| Some x -> add_fn bv x
let add_type_declaration bv td =
List.iter
(fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
td.ptype_cstrs;
add_opt add_type bv td.ptype_manifest;
let rec add_tkind = function
Ptype_abstract -> ()
| Ptype_variant cstrs ->
List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs
| Ptype_record lbls ->
List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
add_tkind td.ptype_kind
let rec add_class_type bv cty =
match cty.pcty_desc with
Pcty_constr(l, tyl) ->
add bv l; List.iter (add_type bv) tyl
| Pcty_signature (ty, fieldl) ->
add_type bv ty;
List.iter (add_class_type_field bv) fieldl
| Pcty_fun(_, ty1, cty2) ->
add_type bv ty1; add_class_type bv cty2
and add_class_type_field bv = function
Pctf_inher cty -> add_class_type bv cty
| Pctf_val(_, _, _, ty, _) -> add_type bv ty
| Pctf_virt(_, _, ty, _) -> add_type bv ty
| Pctf_meth(_, _, ty, _) -> add_type bv ty
| Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
let add_class_description bv infos =
add_class_type bv infos.pci_expr
let add_class_type_declaration = add_class_description
let rec add_pattern bv pat =
match pat.ppat_desc with
Ppat_any -> ()
| Ppat_var _ -> ()
| Ppat_alias(p, _) -> add_pattern bv p
| Ppat_constant _ -> ()
| Ppat_tuple pl -> List.iter (add_pattern bv) pl
| Ppat_construct(c, op, _) -> add bv c; add_opt add_pattern bv op
| Ppat_record(pl, _) ->
List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
| Ppat_array pl -> List.iter (add_pattern bv) pl
| Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
| Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
| Ppat_variant(_, op) -> add_opt add_pattern bv op
| Ppat_type (li) -> add bv li
| Ppat_lazy p -> add_pattern bv p
let rec add_expr bv exp =
match exp.pexp_desc with
Pexp_ident l -> add bv l
| Pexp_constant _ -> ()
| Pexp_let(_, pel, e) -> add_pat_expr_list bv pel; add_expr bv e
| Pexp_function (_, opte, pel) ->
add_opt add_expr bv opte; add_pat_expr_list bv pel
| Pexp_apply(e, el) ->
add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
| Pexp_match(e, pel) -> add_expr bv e; add_pat_expr_list bv pel
| Pexp_try(e, pel) -> add_expr bv e; add_pat_expr_list bv pel
| Pexp_tuple el -> List.iter (add_expr bv) el
| Pexp_construct(c, opte, _) -> add bv c; add_opt add_expr bv opte
| Pexp_variant(_, opte) -> add_opt add_expr bv opte
| Pexp_record(lblel, opte) ->
List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
add_opt add_expr bv opte
| Pexp_field(e, fld) -> add_expr bv e; add bv fld
| Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
| Pexp_array el -> List.iter (add_expr bv) el
| Pexp_ifthenelse(e1, e2, opte3) ->
add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
| Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
| Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
| Pexp_for(_, e1, e2, _, e3) ->
add_expr bv e1; add_expr bv e2; add_expr bv e3
| Pexp_constraint(e1, oty2, oty3) ->
add_expr bv e1;
add_opt add_type bv oty2;
add_opt add_type bv oty3
| Pexp_when(e1, e2) -> add_expr bv e1; add_expr bv e2
| Pexp_send(e, m) -> add_expr bv e
| Pexp_new l -> add bv l
| Pexp_setinstvar(v, e) -> add_expr bv e
| Pexp_override sel -> List.iter (fun (s, e) -> add_expr bv e) sel
| Pexp_letmodule(id, m, e) ->
add_module bv m; add_expr (StringSet.add id bv) e
| Pexp_assert (e) -> add_expr bv e
| Pexp_assertfalse -> ()
| Pexp_lazy (e) -> add_expr bv e
| Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
| Pexp_object (pat, fieldl) ->
add_pattern bv pat; List.iter (add_class_field bv) fieldl
| Pexp_newtype (_, e) -> add_expr bv e
| Pexp_pack (m, pt) -> add_package_type bv pt; add_module bv m
| Pexp_open (m, e) -> addmodule bv m; add_expr bv e
and add_pat_expr_list bv pel =
List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
and add_modtype bv mty =
match mty.pmty_desc with
Pmty_ident l -> add bv l
| Pmty_signature s -> add_signature bv s
| Pmty_functor(id, mty1, mty2) ->
add_modtype bv mty1; add_modtype (StringSet.add id bv) mty2
| Pmty_with(mty, cstrl) ->
add_modtype bv mty;
List.iter
(function (_, Pwith_type td) -> add_type_declaration bv td
| (_, Pwith_module lid) -> addmodule bv lid
| (_, Pwith_typesubst td) -> add_type_declaration bv td
| (_, Pwith_modsubst lid) -> addmodule bv lid)
cstrl
| Pmty_typeof m -> add_module bv m
and add_signature bv = function
[] -> ()
| item :: rem -> add_signature (add_sig_item bv item) rem
and add_sig_item bv item =
match item.psig_desc with
Psig_value(id, vd) ->
add_type bv vd.pval_type; bv
| Psig_type dcls ->
List.iter (fun (id, td) -> add_type_declaration bv td) dcls; bv
| Psig_exception(id, args) ->
List.iter (add_type bv) args; bv
| Psig_module(id, mty) ->
add_modtype bv mty; StringSet.add id bv
| Psig_recmodule decls ->
let bv' = List.fold_right StringSet.add (List.map fst decls) bv in
List.iter (fun (id, mty) -> add_modtype bv' mty) decls;
bv'
| Psig_modtype(id, mtyd) ->
begin match mtyd with
Pmodtype_abstract -> ()
| Pmodtype_manifest mty -> add_modtype bv mty
end;
bv
| Psig_open lid ->
addmodule bv lid; bv
| Psig_include mty ->
add_modtype bv mty; bv
| Psig_class cdl ->
List.iter (add_class_description bv) cdl; bv
| Psig_class_type cdtl ->
List.iter (add_class_type_declaration bv) cdtl; bv
and add_module bv modl =
match modl.pmod_desc with
Pmod_ident l -> addmodule bv l
| Pmod_structure s -> ignore (add_structure bv s)
| Pmod_functor(id, mty, modl) ->
add_modtype bv mty;
add_module (StringSet.add id bv) modl
| Pmod_apply(mod1, mod2) ->
add_module bv mod1; add_module bv mod2
| Pmod_constraint(modl, mty) ->
add_module bv modl; add_modtype bv mty
| Pmod_unpack(e, pt) ->
add_package_type bv pt;
add_expr bv e
and add_structure bv item_list =
List.fold_left add_struct_item bv item_list
and add_struct_item bv item =
match item.pstr_desc with
Pstr_eval e ->
add_expr bv e; bv
| Pstr_value(id, pel) ->
add_pat_expr_list bv pel; bv
| Pstr_primitive(id, vd) ->
add_type bv vd.pval_type; bv
| Pstr_type dcls ->
List.iter (fun (id, td) -> add_type_declaration bv td) dcls; bv
| Pstr_exception(id, args) ->
List.iter (add_type bv) args; bv
| Pstr_exn_rebind(id, l) ->
add bv l; bv
| Pstr_module(id, modl) ->
add_module bv modl; StringSet.add id bv
| Pstr_recmodule bindings ->
let bv' =
List.fold_right StringSet.add
(List.map (fun (id,_,_) -> id) bindings) bv in
List.iter
(fun (id, mty, modl) -> add_modtype bv' mty; add_module bv' modl)
bindings;
bv'
| Pstr_modtype(id, mty) ->
add_modtype bv mty; bv
| Pstr_open l ->
addmodule bv l; bv
| Pstr_class cdl ->
List.iter (add_class_declaration bv) cdl; bv
| Pstr_class_type cdtl ->
List.iter (add_class_type_declaration bv) cdtl; bv
| Pstr_include modl ->
add_module bv modl; bv
and add_use_file bv top_phrs =
ignore (List.fold_left add_top_phrase bv top_phrs)
and add_top_phrase bv = function
| Ptop_def str -> add_structure bv str
| Ptop_dir (_, _) -> bv
and add_class_expr bv ce =
match ce.pcl_desc with
Pcl_constr(l, tyl) ->
add bv l; List.iter (add_type bv) tyl
| Pcl_structure(pat, fieldl) ->
add_pattern bv pat; List.iter (add_class_field bv) fieldl
| Pcl_fun(_, opte, pat, ce) ->
add_opt add_expr bv opte; add_pattern bv pat; add_class_expr bv ce
| Pcl_apply(ce, exprl) ->
add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
| Pcl_let(_, pel, ce) ->
add_pat_expr_list bv pel; add_class_expr bv ce
| Pcl_constraint(ce, ct) ->
add_class_expr bv ce; add_class_type bv ct
and add_class_field bv = function
Pcf_inher(_, ce, _) -> add_class_expr bv ce
| Pcf_val(_, _, _, e, _) -> add_expr bv e
| Pcf_valvirt(_, _, ty, _)
| Pcf_virt(_, _, ty, _) -> add_type bv ty
| Pcf_meth(_, _, _, e, _) -> add_expr bv e
| Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
| Pcf_let(_, pel, _) -> add_pat_expr_list bv pel
| Pcf_init e -> add_expr bv e
and add_class_declaration bv decl =
add_class_expr bv decl.pci_expr