307 lines
11 KiB
OCaml
307 lines
11 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* 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, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) 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
|
|
| Ppat_unpack _ -> ()
|
|
|
|
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 -> 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) ->
|
|
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
|