l4/pkg/ocaml/ocaml/contrib/typing/typemod.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: typemod.ml 9079 2008-10-08 13:09:39Z doligez $ *)
  14
  15 (* Type-checking of the module language *)
  16
  17 open Misc
  18 open Longident
  19 open Path
  20 open Asttypes
  21 open Parsetree
  22 open Types
  23 open Typedtree
  24 open Format
  25
  26 type error =
  27     Unbound_module of Longident.t
  28   | Unbound_modtype of Longident.t
  29   | Cannot_apply of module_type
  30   | Not_included of Includemod.error list
  31   | Cannot_eliminate_dependency of module_type
  32   | Signature_expected
  33   | Structure_expected of module_type
  34   | With_no_component of Longident.t
  35   | With_mismatch of Longident.t * Includemod.error list
  36   | Repeated_name of string * string
  37   | Non_generalizable of type_expr
  38   | Non_generalizable_class of Ident.t * class_declaration
  39   | Non_generalizable_module of module_type
  40   | Implementation_is_required of string
  41   | Interface_not_compiled of string
  42
  43 exception Error of Location.t * error
  44
  45 (* Extract a signature from a module type *)
  46
  47 let extract_sig env loc mty =
  48   match Mtype.scrape env mty with
  49     Tmty_signature sg -> sg
  50   | _ -> raise(Error(loc, Signature_expected))
  51
  52 let extract_sig_open env loc mty =
  53   match Mtype.scrape env mty with
  54     Tmty_signature sg -> sg
  55   | _ -> raise(Error(loc, Structure_expected mty))
  56
  57 (* Lookup the type of a module path *)
  58
  59 let type_module_path env loc lid =
  60   try
  61     Env.lookup_module lid env
  62   with Not_found ->
  63     raise(Error(loc, Unbound_module lid))
  64
  65 (* Record a module type *)
  66 let rm node =
  67   Stypes.record (Stypes.Ti_mod node);
  68   node
  69
  70 (* Merge one "with" constraint in a signature *)
  71
  72 let rec add_rec_types env = function
  73     Tsig_type(id, decl, Trec_next) :: rem ->
  74       add_rec_types (Env.add_type id decl env) rem
  75   | _ -> env
  76
  77 let check_type_decl env id row_id newdecl decl rs rem =
  78   let env = Env.add_type id newdecl env in
  79   let env =
  80     match row_id with None -> env | Some id -> Env.add_type id newdecl env in
  81   let env = if rs = Trec_not then env else add_rec_types env rem in
  82   Includemod.type_declarations env id newdecl decl
  83
  84 let merge_constraint initial_env loc sg lid constr =
  85   let rec merge env sg namelist row_id =
  86     match (sg, namelist, constr) with
  87       ([], _, _) ->
  88         raise(Error(loc, With_no_component lid))
  89     | (Tsig_type(id, decl, rs) :: rem, [s],
  90        Pwith_type ({ptype_kind = Ptype_abstract} as sdecl))
  91       when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
  92         let decl_row =
  93           { type_params =
  94               List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
  95             type_arity = List.length sdecl.ptype_params;
  96             type_kind = Type_abstract;
  97             type_private = Private;
  98             type_manifest = None;
  99             type_variance =
 100               List.map (fun (c,n) -> (not n, not c, not c))
 101               sdecl.ptype_variance }
 102         and id_row = Ident.create (s^"#row") in
 103         let initial_env = Env.add_type id_row decl_row initial_env in
 104         let newdecl = Typedecl.transl_with_constraint
 105                         initial_env id (Some(Pident id_row)) sdecl in
 106         check_type_decl env id row_id newdecl decl rs rem;
 107         let decl_row = {decl_row with type_params = newdecl.type_params} in
 108         let rs' = if rs = Trec_first then Trec_not else rs in
 109         Tsig_type(id_row, decl_row, rs') :: Tsig_type(id, newdecl, rs) :: rem
 110     | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
 111       when Ident.name id = s ->
 112         let newdecl =
 113           Typedecl.transl_with_constraint initial_env id None sdecl in
 114         check_type_decl env id row_id newdecl decl rs rem;
 115         Tsig_type(id, newdecl, rs) :: rem
 116     | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
 117       when Ident.name id = s ^ "#row" ->
 118         merge env rem namelist (Some id)
 119     | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid)
 120       when Ident.name id = s ->
 121         let (path, mty') = type_module_path initial_env loc lid in
 122         let newmty = Mtype.strengthen env mty' path in
 123         ignore(Includemod.modtypes env newmty mty);
 124         Tsig_module(id, newmty, rs) :: rem
 125     | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
 126       when Ident.name id = s ->
 127         let newsg = merge env (extract_sig env loc mty) namelist None in
 128         Tsig_module(id, Tmty_signature newsg, rs) :: rem
 129     | (item :: rem, _, _) ->
 130         item :: merge (Env.add_item item env) rem namelist row_id in
 131   try
 132     merge initial_env sg (Longident.flatten lid) None
 133   with Includemod.Error explanation ->
 134     raise(Error(loc, With_mismatch(lid, explanation)))
 135
 136 (* Add recursion flags on declarations arising from a mutually recursive
 137    block. *)
 138
 139 let map_rec fn decls rem =
 140   match decls with
 141   | [] -> rem
 142   | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
 143
 144 let rec map_rec' fn decls rem =
 145   match decls with
 146   | (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) ->
 147       fn Trec_not d1 :: map_rec' fn dl rem
 148   | _ -> map_rec fn decls rem
 149
 150 (* Auxiliary for translating recursively-defined module types.
 151    Return a module type that approximates the shape of the given module
 152    type AST.  Retain only module, type, and module type
 153    components of signatures.  For types, retain only their arity,
 154    making them abstract otherwise. *)
 155
 156 let rec approx_modtype env smty =
 157   match smty.pmty_desc with
 158     Pmty_ident lid ->
 159       begin try
 160         let (path, info) = Env.lookup_modtype lid env in
 161         Tmty_ident path
 162       with Not_found ->
 163         raise(Error(smty.pmty_loc, Unbound_modtype lid))
 164       end
 165   | Pmty_signature ssg ->
 166       Tmty_signature(approx_sig env ssg)
 167   | Pmty_functor(param, sarg, sres) ->
 168       let arg = approx_modtype env sarg in
 169       let (id, newenv) = Env.enter_module param arg env in
 170       let res = approx_modtype newenv sres in
 171       Tmty_functor(id, arg, res)
 172   | Pmty_with(sbody, constraints) ->
 173       approx_modtype env sbody
 174
 175 and approx_sig env ssg =
 176   match ssg with
 177     [] -> []
 178   | item :: srem ->
 179       match item.psig_desc with
 180       | Psig_type sdecls ->
 181           let decls = Typedecl.approx_type_decl env sdecls in
 182           let rem = approx_sig env srem in
 183           map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
 184       | Psig_module(name, smty) ->
 185           let mty = approx_modtype env smty in
 186           let (id, newenv) = Env.enter_module name mty env in
 187           Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem
 188       | Psig_recmodule sdecls ->
 189           let decls =
 190             List.map
 191               (fun (name, smty) ->
 192                 (Ident.create name, approx_modtype env smty))
 193               sdecls in
 194           let newenv =
 195             List.fold_left (fun env (id, mty) -> Env.add_module id mty env)
 196             env decls in
 197           map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls
 198                   (approx_sig newenv srem)
 199       | Psig_modtype(name, sinfo) ->
 200           let info = approx_modtype_info env sinfo in
 201           let (id, newenv) = Env.enter_modtype name info env in
 202           Tsig_modtype(id, info) :: approx_sig newenv srem
 203       | Psig_open lid ->
 204           let (path, mty) = type_module_path env item.psig_loc lid in
 205           let sg = extract_sig_open env item.psig_loc mty in
 206           let newenv = Env.open_signature path sg env in
 207           approx_sig newenv srem
 208       | Psig_include smty ->
 209           let mty = approx_modtype env smty in
 210           let sg = Subst.signature Subst.identity
 211                      (extract_sig env smty.pmty_loc mty) in
 212           let newenv = Env.add_signature sg env in
 213           sg @ approx_sig newenv srem
 214       | Psig_class sdecls | Psig_class_type sdecls ->
 215           let decls = Typeclass.approx_class_declarations env sdecls in
 216           let rem = approx_sig env srem in
 217           List.flatten
 218             (map_rec
 219               (fun rs (i1, d1, i2, d2, i3, d3) ->
 220                 [Tsig_cltype(i1, d1, rs);
 221                  Tsig_type(i2, d2, rs);
 222                  Tsig_type(i3, d3, rs)])
 223               decls [rem])
 224       | _ ->
 225           approx_sig env srem
 226
 227 and approx_modtype_info env sinfo =
 228   match sinfo with
 229     Pmodtype_abstract ->
 230       Tmodtype_abstract
 231   | Pmodtype_manifest smty ->
 232       Tmodtype_manifest(approx_modtype env smty)
 233
 234 (* Additional validity checks on type definitions arising from
 235    recursive modules *)
 236
 237 let check_recmod_typedecls env sdecls decls =
 238   let recmod_ids = List.map fst decls in
 239   List.iter2
 240     (fun (_, smty) (id, mty) ->
 241       List.iter
 242         (fun path ->
 243           Typedecl.check_recmod_typedecl env smty.pmty_loc recmod_ids
 244                                          path (Env.find_type path env))
 245         (Mtype.type_paths env (Pident id) mty))
 246     sdecls decls
 247
 248 (* Auxiliaries for checking uniqueness of names in signatures and structures *)
 249
 250 module StringSet = Set.Make(struct type t = string let compare = compare end)
 251
 252 let check cl loc set_ref name =
 253   if StringSet.mem name !set_ref
 254   then raise(Error(loc, Repeated_name(cl, name)))
 255   else set_ref := StringSet.add name !set_ref
 256
 257 let check_sig_item type_names module_names modtype_names loc = function
 258     Tsig_type(id, _, _) ->
 259       check "type" loc type_names (Ident.name id)
 260   | Tsig_module(id, _, _) ->
 261       check "module" loc module_names (Ident.name id)
 262   | Tsig_modtype(id, _) ->
 263       check "module type" loc modtype_names (Ident.name id)
 264   | _ -> ()
 265
 266 (* Check and translate a module type expression *)
 267
 268 let rec transl_modtype env smty =
 269   match smty.pmty_desc with
 270     Pmty_ident lid ->
 271       begin try
 272         let (path, info) = Env.lookup_modtype lid env in
 273         Tmty_ident path
 274       with Not_found ->
 275         raise(Error(smty.pmty_loc, Unbound_modtype lid))
 276       end
 277   | Pmty_signature ssg ->
 278       Tmty_signature(transl_signature env ssg)
 279   | Pmty_functor(param, sarg, sres) ->
 280       let arg = transl_modtype env sarg in
 281       let (id, newenv) = Env.enter_module param arg env in
 282       let res = transl_modtype newenv sres in
 283       Tmty_functor(id, arg, res)
 284   | Pmty_with(sbody, constraints) ->
 285       let body = transl_modtype env sbody in
 286       let init_sg = extract_sig env sbody.pmty_loc body in
 287       let final_sg =
 288         List.fold_left
 289           (fun sg (lid, sdecl) ->
 290             merge_constraint env smty.pmty_loc sg lid sdecl)
 291           init_sg constraints in
 292       Mtype.freshen (Tmty_signature final_sg)
 293
 294 and transl_signature env sg =
 295   let type_names = ref StringSet.empty
 296   and module_names = ref StringSet.empty
 297   and modtype_names = ref StringSet.empty in
 298   let rec transl_sig env sg =
 299     Ctype.init_def(Ident.current_time());
 300     match sg with
 301       [] -> []
 302     | item :: srem ->
 303         match item.psig_desc with
 304         | Psig_value(name, sdesc) ->
 305             let desc = Typedecl.transl_value_decl env sdesc in
 306             let (id, newenv) = Env.enter_value name desc env in
 307             let rem = transl_sig newenv srem in
 308             Tsig_value(id, desc) :: rem
 309         | Psig_type sdecls ->
 310             List.iter
 311               (fun (name, decl) -> check "type" item.psig_loc type_names name)
 312               sdecls;
 313             let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
 314             let rem = transl_sig newenv srem in
 315             map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
 316         | Psig_exception(name, sarg) ->
 317             let arg = Typedecl.transl_exception env sarg in
 318             let (id, newenv) = Env.enter_exception name arg env in
 319             let rem = transl_sig newenv srem in
 320             Tsig_exception(id, arg) :: rem
 321         | Psig_module(name, smty) ->
 322             check "module" item.psig_loc module_names name;
 323             let mty = transl_modtype env smty in
 324             let (id, newenv) = Env.enter_module name mty env in
 325             let rem = transl_sig newenv srem in
 326             Tsig_module(id, mty, Trec_not) :: rem
 327         | Psig_recmodule sdecls ->
 328             List.iter
 329               (fun (name, smty) ->
 330                  check "module" item.psig_loc module_names name)
 331               sdecls;
 332             let (decls, newenv) =
 333               transl_recmodule_modtypes item.psig_loc env sdecls in
 334             let rem = transl_sig newenv srem in
 335             map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls rem
 336         | Psig_modtype(name, sinfo) ->
 337             check "module type" item.psig_loc modtype_names name;
 338             let info = transl_modtype_info env sinfo in
 339             let (id, newenv) = Env.enter_modtype name info env in
 340             let rem = transl_sig newenv srem in
 341             Tsig_modtype(id, info) :: rem
 342         | Psig_open lid ->
 343             let (path, mty) = type_module_path env item.psig_loc lid in
 344             let sg = extract_sig_open env item.psig_loc mty in
 345             let newenv = Env.open_signature path sg env in
 346             transl_sig newenv srem
 347         | Psig_include smty ->
 348             let mty = transl_modtype env smty in
 349             let sg = Subst.signature Subst.identity
 350                        (extract_sig env smty.pmty_loc mty) in
 351             List.iter
 352               (check_sig_item type_names module_names modtype_names
 353                               item.psig_loc)
 354               sg;
 355             let newenv = Env.add_signature sg env in
 356             let rem = transl_sig newenv srem in
 357             sg @ rem
 358         | Psig_class cl ->
 359             List.iter
 360               (fun {pci_name = name} ->
 361                  check "type" item.psig_loc type_names name)
 362               cl;
 363             let (classes, newenv) = Typeclass.class_descriptions env cl in
 364             let rem = transl_sig newenv srem in
 365             List.flatten
 366               (map_rec
 367                  (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
 368                     [Tsig_class(i, d, rs);
 369                      Tsig_cltype(i', d', rs);
 370                      Tsig_type(i'', d'', rs);
 371                      Tsig_type(i''', d''', rs)])
 372                  classes [rem])
 373         | Psig_class_type cl ->
 374             List.iter
 375               (fun {pci_name = name} ->
 376                  check "type" item.psig_loc type_names name)
 377               cl;
 378             let (classes, newenv) = Typeclass.class_type_declarations env cl in
 379             let rem = transl_sig newenv srem in
 380             List.flatten
 381               (map_rec
 382                  (fun rs (i, d, i', d', i'', d'') ->
 383                     [Tsig_cltype(i, d, rs);
 384                      Tsig_type(i', d', rs);
 385                      Tsig_type(i'', d'', rs)])
 386                  classes [rem])
 387     in transl_sig env sg
 388
 389 and transl_modtype_info env sinfo =
 390   match sinfo with
 391     Pmodtype_abstract ->
 392       Tmodtype_abstract
 393   | Pmodtype_manifest smty ->
 394       Tmodtype_manifest(transl_modtype env smty)
 395
 396 and transl_recmodule_modtypes loc env sdecls =
 397   let make_env curr =
 398     List.fold_left
 399       (fun env (id, mty) -> Env.add_module id mty env)
 400       env curr in
 401   let transition env_c curr =
 402     List.map2
 403       (fun (_, smty) (id, mty) -> (id, transl_modtype env_c smty))
 404       sdecls curr in
 405   let init =
 406     List.map
 407       (fun (name, smty) ->
 408         (Ident.create name, approx_modtype env smty))
 409       sdecls in
 410   let env0 = make_env init in
 411   let dcl1 = transition env0 init in
 412   let env1 = make_env dcl1 in
 413   check_recmod_typedecls env1 sdecls dcl1;
 414   let dcl2 = transition env1 dcl1 in
 415 (*
 416   List.iter
 417     (fun (id, mty) ->
 418       Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty)
 419     dcl2;
 420 *)
 421   let env2 = make_env dcl2 in
 422   check_recmod_typedecls env2 sdecls dcl2;
 423   (dcl2, env2)
 424
 425 (* Try to convert a module expression to a module path. *)
 426
 427 exception Not_a_path
 428
 429 let rec path_of_module mexp =
 430   match mexp.mod_desc with
 431     Tmod_ident p -> p
 432   | Tmod_apply(funct, arg, coercion) ->
 433       Papply(path_of_module funct, path_of_module arg)
 434   | _ -> raise Not_a_path
 435
 436 (* Check that all core type schemes in a structure are closed *)
 437
 438 let rec closed_modtype = function
 439     Tmty_ident p -> true
 440   | Tmty_signature sg -> List.for_all closed_signature_item sg
 441   | Tmty_functor(id, param, body) -> closed_modtype body
 442
 443 and closed_signature_item = function
 444     Tsig_value(id, desc) -> Ctype.closed_schema desc.val_type
 445   | Tsig_module(id, mty, _) -> closed_modtype mty
 446   | _ -> true
 447
 448 let check_nongen_scheme env = function
 449     Tstr_value(rec_flag, pat_exp_list) ->
 450       List.iter
 451         (fun (pat, exp) ->
 452           if not (Ctype.closed_schema exp.exp_type) then
 453             raise(Error(exp.exp_loc, Non_generalizable exp.exp_type)))
 454         pat_exp_list
 455   | Tstr_module(id, md) ->
 456       if not (closed_modtype md.mod_type) then
 457         raise(Error(md.mod_loc, Non_generalizable_module md.mod_type))
 458   | _ -> ()
 459
 460 let check_nongen_schemes env str =
 461   List.iter (check_nongen_scheme env) str
 462
 463 (* Extract the list of "value" identifiers bound by a signature.
 464    "Value" identifiers are identifiers for signature components that
 465    correspond to a run-time value: values, exceptions, modules, classes.
 466    Note: manifest primitives do not correspond to a run-time value! *)
 467
 468 let rec bound_value_identifiers = function
 469     [] -> []
 470   | Tsig_value(id, {val_kind = Val_reg}) :: rem ->
 471       id :: bound_value_identifiers rem
 472   | Tsig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
 473   | Tsig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
 474   | Tsig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
 475   | _ :: rem -> bound_value_identifiers rem
 476
 477 (* Helpers for typing recursive modules *)
 478
 479 let anchor_submodule name anchor =
 480   match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos))
 481 let anchor_recmodule id anchor =
 482   Some (Pident id)
 483
 484 let enrich_type_decls anchor decls oldenv newenv =
 485   match anchor with
 486     None -> newenv
 487   | Some p ->
 488       List.fold_left
 489         (fun e (id, info) ->
 490           let info' =
 491             Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) info
 492           in
 493             Env.add_type id info' e)
 494         oldenv decls
 495
 496 let enrich_module_type anchor name mty env =
 497   match anchor with
 498     None -> mty
 499   | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty
 500
 501 let check_recmodule_inclusion env bindings =
 502   (* PR#4450, PR#4470: consider
 503         module rec X : DECL = MOD  where MOD has inferred type ACTUAL
 504      The "natural" typing condition
 505         E, X: ACTUAL |- ACTUAL <: DECL
 506      leads to circularities through manifest types.
 507      Instead, we "unroll away" the potential circularities a finite number
 508      of times.  The (weaker) condition we implement is:
 509         E, X: DECL,
 510            X1: ACTUAL,
 511            X2: ACTUAL{X <- X1}/X1
 512            ...
 513            Xn: ACTUAL{X <- X(n-1)}/X(n-1)
 514         |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn}
 515      so that manifest types rooted at X(n+1) are expanded in terms of X(n),
 516      avoiding circularities.  The strengthenings ensure that
 517      Xn.t = X(n-1).t = ... = X2.t = X1.t.
 518      N can be chosen arbitrarily; larger values of N result in more
 519      recursive definitions being accepted.  A good choice appears to be
 520      the number of mutually recursive declarations. *)
 521
 522   let subst_and_strengthen env s id mty =
 523     Mtype.strengthen env (Subst.modtype s mty)
 524                          (Subst.module_path s (Pident id)) in
 525
 526   let rec check_incl first_time n env s =
 527     if n > 0 then begin
 528       (* Generate fresh names Y_i for the rec. bound module idents X_i *)
 529       let bindings1 =
 530         List.map
 531           (fun (id, mty_decl, modl, mty_actual) ->
 532              (id, Ident.rename id, mty_actual))
 533           bindings in
 534       (* Enter the Y_i in the environment with their actual types substituted
 535          by the input substitution s *)
 536       let env' =
 537         List.fold_left
 538           (fun env (id, id', mty_actual) ->
 539              let mty_actual' =
 540                if first_time
 541                then mty_actual
 542                else subst_and_strengthen env s id mty_actual in
 543              Env.add_module id' mty_actual' env)
 544           env bindings1 in
 545       (* Build the output substitution Y_i <- X_i *)
 546       let s' =
 547         List.fold_left
 548           (fun s (id, id', mty_actual) ->
 549              Subst.add_module id (Pident id') s)
 550           Subst.identity bindings1 in
 551       (* Recurse with env' and s' *)
 552       check_incl false (n-1) env' s'
 553     end else begin
 554       (* Base case: check inclusion of s(mty_actual) in s(mty_decl)
 555          and insert coercion if needed *)
 556       let check_inclusion (id, mty_decl, modl, mty_actual) =
 557         let mty_decl' = Subst.modtype s mty_decl
 558         and mty_actual' = subst_and_strengthen env s id mty_actual in
 559         let coercion =
 560           try
 561             Includemod.modtypes env mty_actual' mty_decl'
 562           with Includemod.Error msg ->
 563             raise(Error(modl.mod_loc, Not_included msg)) in
 564         let modl' =
 565           { mod_desc = Tmod_constraint(modl, mty_decl, coercion);
 566             mod_type = mty_decl;
 567             mod_env = env;
 568             mod_loc = modl.mod_loc } in
 569         (id, modl') in
 570       List.map check_inclusion bindings
 571     end
 572   in check_incl true (List.length bindings) env Subst.identity
 573
 574 (* Type a module value expression *)
 575
 576 let rec type_module anchor env smod =
 577   match smod.pmod_desc with
 578     Pmod_ident lid ->
 579       let (path, mty) = type_module_path env smod.pmod_loc lid in
 580       rm { mod_desc = Tmod_ident path;
 581            mod_type = Mtype.strengthen env mty path;
 582            mod_env = env;
 583            mod_loc = smod.pmod_loc }
 584   | Pmod_structure sstr ->
 585       let (str, sg, finalenv) = type_structure anchor env sstr smod.pmod_loc in
 586       rm { mod_desc = Tmod_structure str;
 587            mod_type = Tmty_signature sg;
 588            mod_env = env;
 589            mod_loc = smod.pmod_loc }
 590   | Pmod_functor(name, smty, sbody) ->
 591       let mty = transl_modtype env smty in
 592       let (id, newenv) = Env.enter_module name mty env in
 593       let body = type_module None newenv sbody in
 594       rm { mod_desc = Tmod_functor(id, mty, body);
 595            mod_type = Tmty_functor(id, mty, body.mod_type);
 596            mod_env = env;
 597            mod_loc = smod.pmod_loc }
 598   | Pmod_apply(sfunct, sarg) ->
 599       let funct = type_module None env sfunct in
 600       let arg = type_module None env sarg in
 601       begin match Mtype.scrape env funct.mod_type with
 602         Tmty_functor(param, mty_param, mty_res) as mty_functor ->
 603           let coercion =
 604             try
 605               Includemod.modtypes env arg.mod_type mty_param
 606             with Includemod.Error msg ->
 607               raise(Error(sarg.pmod_loc, Not_included msg)) in
 608           let mty_appl =
 609             try
 610               let path = path_of_module arg in
 611               Subst.modtype (Subst.add_module param path Subst.identity)
 612                             mty_res
 613             with Not_a_path ->
 614               try
 615                 Mtype.nondep_supertype
 616                   (Env.add_module param arg.mod_type env) param mty_res
 617               with Not_found ->
 618                 raise(Error(smod.pmod_loc,
 619                             Cannot_eliminate_dependency mty_functor)) in
 620           rm { mod_desc = Tmod_apply(funct, arg, coercion);
 621                mod_type = mty_appl;
 622                mod_env = env;
 623                mod_loc = smod.pmod_loc }
 624       | _ ->
 625           raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type))
 626       end
 627   | Pmod_constraint(sarg, smty) ->
 628       let arg = type_module anchor env sarg in
 629       let mty = transl_modtype env smty in
 630       let coercion =
 631         try
 632           Includemod.modtypes env arg.mod_type mty
 633         with Includemod.Error msg ->
 634           raise(Error(sarg.pmod_loc, Not_included msg)) in
 635       rm { mod_desc = Tmod_constraint(arg, mty, coercion);
 636            mod_type = mty;
 637            mod_env = env;
 638            mod_loc = smod.pmod_loc }
 639
 640 and type_structure anchor env sstr scope =
 641   let type_names = ref StringSet.empty
 642   and module_names = ref StringSet.empty
 643   and modtype_names = ref StringSet.empty in
 644   let rec type_struct env sstr =
 645     Ctype.init_def(Ident.current_time());
 646     match sstr with
 647       [] ->
 648         ([], [], env)
 649     | {pstr_desc = Pstr_eval sexpr} :: srem ->
 650         let expr = Typecore.type_expression env sexpr in
 651         let (str_rem, sig_rem, final_env) = type_struct env srem in
 652         (Tstr_eval expr :: str_rem, sig_rem, final_env)
 653     | {pstr_desc = Pstr_value(rec_flag, sdefs); pstr_loc = loc} :: srem ->
 654         let scope =
 655           match rec_flag with
 656           | Recursive -> Some (Annot.Idef {scope with
 657                                  Location.loc_start = loc.Location.loc_start})
 658           | Nonrecursive ->
 659               let start = match srem with
 660                 | [] -> loc.Location.loc_end
 661                 | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
 662               in Some (Annot.Idef {scope with Location.loc_start = start})
 663           | Default -> None
 664         in
 665         let (defs, newenv) =
 666           Typecore.type_binding env rec_flag sdefs scope in
 667         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
 668         let bound_idents = let_bound_idents defs in
 669         let make_sig_value id =
 670           Tsig_value(id, Env.find_value (Pident id) newenv) in
 671         (Tstr_value(rec_flag, defs) :: str_rem,
 672          map_end make_sig_value bound_idents sig_rem,
 673          final_env)
 674     | {pstr_desc = Pstr_primitive(name, sdesc)} :: srem ->
 675         let desc = Typedecl.transl_value_decl env sdesc in
 676         let (id, newenv) = Env.enter_value name desc env in
 677         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
 678         (Tstr_primitive(id, desc) :: str_rem,
 679          Tsig_value(id, desc) :: sig_rem,
 680          final_env)
 681     | {pstr_desc = Pstr_type sdecls; pstr_loc = loc} :: srem ->
 682         List.iter
 683           (fun (name, decl) -> check "type" loc type_names name)
 684           sdecls;
 685         let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
 686         let newenv' =
 687           enrich_type_decls anchor decls env newenv in
 688         let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
 689         (Tstr_type decls :: str_rem,
 690          map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
 691          final_env)
 692     | {pstr_desc = Pstr_exception(name, sarg)} :: srem ->
 693         let arg = Typedecl.transl_exception env sarg in
 694         let (id, newenv) = Env.enter_exception name arg env in
 695         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
 696         (Tstr_exception(id, arg) :: str_rem,
 697          Tsig_exception(id, arg) :: sig_rem,
 698          final_env)
 699     | {pstr_desc = Pstr_exn_rebind(name, longid); pstr_loc = loc} :: srem ->
 700         let (path, arg) = Typedecl.transl_exn_rebind env loc longid in
 701         let (id, newenv) = Env.enter_exception name arg env in
 702         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
 703         (Tstr_exn_rebind(id, path) :: str_rem,
 704          Tsig_exception(id, arg) :: sig_rem,
 705          final_env)
 706     | {pstr_desc = Pstr_module(name, smodl); pstr_loc = loc} :: srem ->
 707         check "module" loc module_names name;
 708         let modl = type_module  (anchor_submodule name anchor) env smodl in
 709         let mty = enrich_module_type anchor name modl.mod_type env in
 710         let (id, newenv) = Env.enter_module name mty env in
 711         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
 712         (Tstr_module(id, modl) :: str_rem,
 713          Tsig_module(id, modl.mod_type, Trec_not) :: sig_rem,
 714          final_env)
 715     | {pstr_desc = Pstr_recmodule sbind; pstr_loc = loc} :: srem ->
 716         List.iter
 717           (fun (name, _, _) -> check "module" loc module_names name)
 718           sbind;
 719         let (decls, newenv) =
 720           transl_recmodule_modtypes loc env
 721             (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in
 722         let bindings1 =
 723           List.map2
 724             (fun (id, mty) (name, smty, smodl) ->
 725               let modl =
 726                 type_module (anchor_recmodule id anchor) newenv smodl in
 727               let mty' =
 728                 enrich_module_type anchor (Ident.name id) modl.mod_type newenv in
 729               (id, mty, modl, mty'))
 730            decls sbind in
 731         let bindings2 =
 732           check_recmodule_inclusion newenv bindings1 in
 733         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
 734         (Tstr_recmodule bindings2 :: str_rem,
 735          map_rec (fun rs (id, modl) -> Tsig_module(id, modl.mod_type, rs))
 736                  bindings2 sig_rem,
 737          final_env)
 738     | {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem ->
 739         check "module type" loc modtype_names name;
 740         let mty = transl_modtype env smty in
 741         let (id, newenv) = Env.enter_modtype name (Tmodtype_manifest mty) env in
 742         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
 743         (Tstr_modtype(id, mty) :: str_rem,
 744          Tsig_modtype(id, Tmodtype_manifest mty) :: sig_rem,
 745          final_env)
 746     | {pstr_desc = Pstr_open lid; pstr_loc = loc} :: srem ->
 747         let (path, mty) = type_module_path env loc lid in
 748         let sg = extract_sig_open env loc mty in
 749         type_struct (Env.open_signature path sg env) srem
 750     | {pstr_desc = Pstr_class cl; pstr_loc = loc} :: srem ->
 751          List.iter
 752            (fun {pci_name = name} -> check "type" loc type_names name)
 753            cl;
 754         let (classes, new_env) = Typeclass.class_declarations env cl in
 755         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
 756         (Tstr_class
 757            (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) ->
 758               let vf = if d.cty_new = None then Virtual else Concrete in
 759               (i, s, m, c, vf)) classes) ::
 760          Tstr_cltype
 761            (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) ::
 762          Tstr_type
 763            (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) ::
 764          Tstr_type
 765            (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
 766          str_rem,
 767          List.flatten
 768            (map_rec
 769               (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
 770                  [Tsig_class(i, d, rs);
 771                   Tsig_cltype(i', d', rs);
 772                   Tsig_type(i'', d'', rs);
 773                   Tsig_type(i''', d''', rs)])
 774               classes [sig_rem]),
 775          final_env)
 776     | {pstr_desc = Pstr_class_type cl; pstr_loc = loc} :: srem ->
 777         List.iter
 778           (fun {pci_name = name} -> check "type" loc type_names name)
 779           cl;
 780         let (classes, new_env) = Typeclass.class_type_declarations env cl in
 781         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
 782         (Tstr_cltype
 783            (List.map (fun (i, d, _, _, _, _) -> (i, d)) classes) ::
 784          Tstr_type
 785            (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
 786          Tstr_type
 787            (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) ::
 788          str_rem,
 789          List.flatten
 790            (map_rec
 791               (fun rs (i, d, i', d', i'', d'') ->
 792                  [Tsig_cltype(i, d, rs);
 793                   Tsig_type(i', d', rs);
 794                   Tsig_type(i'', d'', rs)])
 795               classes [sig_rem]),
 796          final_env)
 797     | {pstr_desc = Pstr_include smodl; pstr_loc = loc} :: srem ->
 798         let modl = type_module None env smodl in
 799         (* Rename all identifiers bound by this signature to avoid clashes *)
 800         let sg = Subst.signature Subst.identity
 801                    (extract_sig_open env smodl.pmod_loc modl.mod_type) in
 802         List.iter
 803           (check_sig_item type_names module_names modtype_names loc) sg;
 804         let new_env = Env.add_signature sg env in
 805         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
 806         (Tstr_include (modl, bound_value_identifiers sg) :: str_rem,
 807          sg @ sig_rem,
 808          final_env)
 809   in
 810   if !Clflags.annotations
 811   then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
 812   type_struct env sstr
 813
 814 let type_module = type_module None
 815 let type_structure = type_structure None
 816
 817 (* Fill in the forward declaration *)
 818 let _ =
 819   Typecore.type_module := type_module
 820
 821 (* Normalize types in a signature *)
 822
 823 let rec normalize_modtype env = function
 824     Tmty_ident p -> ()
 825   | Tmty_signature sg -> normalize_signature env sg
 826   | Tmty_functor(id, param, body) -> normalize_modtype env body
 827
 828 and normalize_signature env = List.iter (normalize_signature_item env)
 829
 830 and normalize_signature_item env = function
 831     Tsig_value(id, desc) -> Ctype.normalize_type env desc.val_type
 832   | Tsig_module(id, mty, _) -> normalize_modtype env mty
 833   | _ -> ()
 834
 835 (* Simplify multiple specifications of a value or an exception in a signature.
 836    (Other signature components, e.g. types, modules, etc, are checked for
 837    name uniqueness.)  If multiple specifications with the same name,
 838    keep only the last (rightmost) one. *)
 839
 840 let rec simplify_modtype mty =
 841   match mty with
 842     Tmty_ident path -> mty
 843   | Tmty_functor(id, arg, res) -> Tmty_functor(id, arg, simplify_modtype res)
 844   | Tmty_signature sg -> Tmty_signature(simplify_signature sg)
 845
 846 and simplify_signature sg =
 847   let rec simplif val_names exn_names res = function
 848     [] -> res
 849   | (Tsig_value(id, descr) as component) :: sg ->
 850       let name = Ident.name id in
 851       simplif (StringSet.add name val_names) exn_names
 852               (if StringSet.mem name val_names then res else component :: res)
 853               sg
 854   | (Tsig_exception(id, decl) as component) :: sg ->
 855       let name = Ident.name id in
 856       simplif val_names (StringSet.add name exn_names)
 857               (if StringSet.mem name exn_names then res else component :: res)
 858               sg
 859   | Tsig_module(id, mty, rs) :: sg ->
 860       simplif val_names exn_names
 861               (Tsig_module(id, simplify_modtype mty, rs) :: res) sg
 862   | component :: sg ->
 863       simplif val_names exn_names (component :: res) sg
 864   in
 865     simplif StringSet.empty StringSet.empty [] (List.rev sg)
 866
 867 (* Typecheck an implementation file *)
 868
 869 let type_implementation sourcefile outputprefix modulename initial_env ast =
 870   Typecore.reset_delayed_checks ();
 871   let (str, sg, finalenv) = type_structure initial_env ast Location.none in
 872   let simple_sg = simplify_signature sg in
 873   Typecore.force_delayed_checks ();
 874   if !Clflags.print_types then begin
 875     fprintf std_formatter "%a@." Printtyp.signature simple_sg;
 876     (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
 877   end else begin
 878     let sourceintf =
 879       Misc.chop_extension_if_any sourcefile ^ !Config.interface_suffix in
 880     if Sys.file_exists sourceintf then begin
 881       let intf_file =
 882         try
 883           find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
 884         with Not_found ->
 885           raise(Error(Location.none, Interface_not_compiled sourceintf)) in
 886       let dclsig = Env.read_signature modulename intf_file in
 887       let coercion = Includemod.compunit sourcefile sg intf_file dclsig in
 888       (str, coercion)
 889     end else begin
 890       check_nongen_schemes finalenv str;
 891       normalize_signature finalenv simple_sg;
 892       let coercion =
 893         Includemod.compunit sourcefile sg
 894                             "(inferred signature)" simple_sg in
 895       if not !Clflags.dont_write_files then
 896         Env.save_signature simple_sg modulename (outputprefix ^ ".cmi");
 897       (str, coercion)
 898     end
 899   end
 900
 901 (* "Packaging" of several compilation units into one unit
 902    having them as sub-modules.  *)
 903
 904 let rec package_signatures subst = function
 905     [] -> []
 906   | (name, sg) :: rem ->
 907       let sg' = Subst.signature subst sg in
 908       let oldid = Ident.create_persistent name
 909       and newid = Ident.create name in
 910       Tsig_module(newid, Tmty_signature sg', Trec_not) ::
 911       package_signatures (Subst.add_module oldid (Pident newid) subst) rem
 912
 913 let package_units objfiles cmifile modulename =
 914   (* Read the signatures of the units *)
 915   let units =
 916     List.map
 917       (fun f ->
 918          let pref = chop_extensions f in
 919          let modname = String.capitalize(Filename.basename pref) in
 920          let sg = Env.read_signature modname (pref ^ ".cmi") in
 921          if Filename.check_suffix f ".cmi" &&
 922             not(Mtype.no_code_needed_sig Env.initial sg)
 923          then raise(Error(Location.none, Implementation_is_required f));
 924          (modname, Env.read_signature modname (pref ^ ".cmi")))
 925       objfiles in
 926   (* Compute signature of packaged unit *)
 927   Ident.reinit();
 928   let sg = package_signatures Subst.identity units in
 929   (* See if explicit interface is provided *)
 930   let mlifile =
 931     chop_extension_if_any cmifile ^ !Config.interface_suffix in
 932   if Sys.file_exists mlifile then begin
 933     if not (Sys.file_exists cmifile) then begin
 934       raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile))
 935     end;
 936     let dclsig = Env.read_signature modulename cmifile in
 937     Includemod.compunit "(obtained by packing)" sg mlifile dclsig
 938   end else begin
 939     (* Determine imports *)
 940     let unit_names = List.map fst units in
 941     let imports =
 942       List.filter
 943         (fun (name, crc) -> not (List.mem name unit_names))
 944         (Env.imported_units()) in
 945     (* Write packaged signature *)
 946     Env.save_signature_with_imports sg modulename cmifile imports;
 947     Tcoerce_none
 948   end
 949
 950 (* Error report *)
 951
 952 open Printtyp
 953
 954 let report_error ppf = function
 955   | Unbound_module lid -> fprintf ppf "Unbound module %a" longident lid
 956   | Unbound_modtype lid -> fprintf ppf "Unbound module type %a" longident lid
 957   | Cannot_apply mty ->
 958       fprintf ppf
 959         "@[This module is not a functor; it has type@ %a@]" modtype mty
 960   | Not_included errs ->
 961       fprintf ppf
 962         "@[<v>Signature mismatch:@ %a@]" Includemod.report_error errs
 963   | Cannot_eliminate_dependency mty ->
 964       fprintf ppf
 965         "@[This functor has type@ %a@ \
 966            The parameter cannot be eliminated in the result type.@  \
 967            Please bind the argument to a module identifier.@]" modtype mty
 968   | Signature_expected -> fprintf ppf "This module type is not a signature"
 969   | Structure_expected mty ->
 970       fprintf ppf
 971         "@[This module is not a structure; it has type@ %a" modtype mty
 972   | With_no_component lid ->
 973       fprintf ppf
 974         "@[The signature constrained by `with' has no component named %a@]"
 975         longident lid
 976   | With_mismatch(lid, explanation) ->
 977       fprintf ppf
 978         "@[<v>\
 979            @[In this `with' constraint, the new definition of %a@ \
 980              does not match its original definition@ \
 981              in the constrained signature:@]@ \
 982            %a@]"
 983         longident lid Includemod.report_error explanation
 984   | Repeated_name(kind, name) ->
 985       fprintf ppf
 986         "@[Multiple definition of the %s name %s.@ \
 987            Names must be unique in a given structure or signature.@]" kind name
 988   | Non_generalizable typ ->
 989       fprintf ppf
 990         "@[The type of this expression,@ %a,@ \
 991            contains type variables that cannot be generalized@]" type_scheme typ
 992   | Non_generalizable_class (id, desc) ->
 993       fprintf ppf
 994         "@[The type of this class,@ %a,@ \
 995            contains type variables that cannot be generalized@]"
 996         (class_declaration id) desc
 997   | Non_generalizable_module mty ->
 998       fprintf ppf
 999         "@[The type of this module,@ %a,@ \
1000            contains type variables that cannot be generalized@]" modtype mty
1001   | Implementation_is_required intf_name ->
1002       fprintf ppf
1003         "@[The interface %s@ declares values, not just types.@ \
1004            An implementation must be provided.@]" intf_name
1005   | Interface_not_compiled intf_name ->
1006       fprintf ppf
1007         "@[Could not find the .cmi file for interface@ %s.@]" intf_name