← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to typing/typemod.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stefano Zacchiroli
  • Date: 2009-02-22 08:49:13 UTC
  • mfrom: (12.1.1 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090222084913-3i0uw2bhd0lgw0ok
* Uploading to unstable
* debian/control: bump dh-ocaml to (>= 0.4) to avoid buggy ocamlinit.mk

Show diffs side-by-side

added added

removed removed

Lines of Context:
typing/typemod.ml
10
10
(*                                                                     *)
11
11
(***********************************************************************)
12
12
 
13
 
(* $Id: typemod.ml,v 1.78.2.4 2007/12/26 16:00:41 xleroy Exp $ *)
 
13
(* $Id: typemod.ml,v 1.86.2.1 2008/10/08 13:07:14 doligez Exp $ *)
14
14
 
15
15
(* Type-checking of the module language *)
16
16
 
87
87
      ([], _, _) ->
88
88
        raise(Error(loc, With_no_component lid))
89
89
    | (Tsig_type(id, decl, rs) :: rem, [s],
90
 
       Pwith_type ({ptype_kind = Ptype_private} as sdecl))
91
 
      when Ident.name id = s ->
 
90
       Pwith_type ({ptype_kind = Ptype_abstract} as sdecl))
 
91
      when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
92
92
        let decl_row =
93
93
          { type_params =
94
94
              List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
95
95
            type_arity = List.length sdecl.ptype_params;
96
96
            type_kind = Type_abstract;
 
97
            type_private = Private;
97
98
            type_manifest = None;
98
99
            type_variance =
99
100
              List.map (fun (c,n) -> (not n, not c, not c))
152
153
   components of signatures.  For types, retain only their arity,
153
154
   making them abstract otherwise. *)
154
155
 
155
 
let approx_modtype transl_mty init_env smty =
156
 
 
157
 
  let rec approx_mty env smty =
158
 
    match smty.pmty_desc with
159
 
      Pmty_ident lid ->
160
 
        begin try
161
 
          let (path, info) = Env.lookup_modtype lid env in
162
 
          Tmty_ident path
163
 
        with Not_found ->
164
 
          raise(Error(smty.pmty_loc, Unbound_modtype lid))
165
 
        end
166
 
    | Pmty_signature ssg ->
167
 
        Tmty_signature(approx_sig env ssg)
168
 
    | Pmty_functor(param, sarg, sres) ->
169
 
        let arg = approx_mty env sarg in
170
 
        let (id, newenv) = Env.enter_module param arg env in
171
 
        let res = approx_mty newenv sres in
172
 
        Tmty_functor(id, arg, res)
173
 
    | Pmty_with(sbody, constraints) ->
174
 
        approx_mty env sbody
175
 
 
176
 
  and approx_sig env ssg =
177
 
    match ssg with
178
 
      [] -> []
179
 
    | item :: srem ->
180
 
        match item.psig_desc with
181
 
        | Psig_type sdecls ->
182
 
            let decls = Typedecl.approx_type_decl env sdecls in
183
 
            let rem = approx_sig env srem in
184
 
            map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
185
 
        | Psig_module(name, smty) ->
186
 
            let mty = approx_mty env smty in
187
 
            let (id, newenv) = Env.enter_module name mty env in
188
 
            Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem
189
 
        | Psig_recmodule sdecls ->
190
 
            let decls =
191
 
              List.map
192
 
                (fun (name, smty) ->
193
 
                  (Ident.create name, approx_mty env smty))
194
 
                sdecls in
195
 
            let newenv =
196
 
              List.fold_left (fun env (id, mty) -> Env.add_module id mty env)
197
 
              env decls in
198
 
            map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls
199
 
                    (approx_sig newenv srem)
200
 
        | Psig_modtype(name, sinfo) ->
201
 
            let info = approx_mty_info env sinfo in
202
 
            let (id, newenv) = Env.enter_modtype name info env in
203
 
            Tsig_modtype(id, info) :: approx_sig newenv srem
204
 
        | Psig_open lid ->
205
 
            let (path, mty) = type_module_path env item.psig_loc lid in
206
 
            let sg = extract_sig_open env item.psig_loc mty in
207
 
            let newenv = Env.open_signature path sg env in
208
 
            approx_sig newenv srem
209
 
        | Psig_include smty ->
210
 
            let mty = transl_mty init_env smty in
211
 
            let sg = Subst.signature Subst.identity
212
 
                       (extract_sig env smty.pmty_loc mty) in
213
 
            let newenv = Env.add_signature sg env in
214
 
            sg @ approx_sig newenv srem
215
 
        | Psig_class sdecls | Psig_class_type sdecls ->
216
 
            let decls = Typeclass.approx_class_declarations env sdecls in
217
 
            let rem = approx_sig env srem in
218
 
            List.flatten
219
 
              (map_rec
220
 
                (fun rs (i1, d1, i2, d2, i3, d3) ->
221
 
                  [Tsig_cltype(i1, d1, rs);
222
 
                   Tsig_type(i2, d2, rs);
223
 
                   Tsig_type(i3, d3, rs)])
224
 
                decls [rem])
225
 
        | _ ->
226
 
            approx_sig env srem
227
 
 
228
 
  and approx_mty_info env sinfo =
229
 
    match sinfo with
230
 
      Pmodtype_abstract ->
231
 
        Tmodtype_abstract
232
 
    | Pmodtype_manifest smty ->
233
 
        Tmodtype_manifest(approx_mty env smty)
234
 
 
235
 
  in approx_mty init_env smty
 
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)
236
233
 
237
234
(* Additional validity checks on type definitions arising from
238
235
   recursive modules *)
408
405
  let init =
409
406
    List.map
410
407
      (fun (name, smty) ->
411
 
        (Ident.create name, approx_modtype transl_modtype env smty))
 
408
        (Ident.create name, approx_modtype env smty))
412
409
      sdecls in
413
410
  let env0 = make_env init in
414
411
  let dcl1 = transition env0 init in
415
412
  let env1 = make_env dcl1 in
 
413
  check_recmod_typedecls env1 sdecls dcl1;
416
414
  let dcl2 = transition env1 dcl1 in
417
 
  let env2 = make_env dcl2 in
418
 
  check_recmod_typedecls env2 sdecls dcl2;
419
415
(*
420
416
  List.iter
421
417
    (fun (id, mty) ->
422
418
      Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty)
423
419
    dcl2;
424
420
*)
 
421
  let env2 = make_env dcl2 in
 
422
  check_recmod_typedecls env2 sdecls dcl2;
425
423
  (dcl2, env2)
426
424
 
427
425
(* Try to convert a module expression to a module path. *)
584
582
           mod_env = env;
585
583
           mod_loc = smod.pmod_loc }
586
584
  | Pmod_structure sstr ->
587
 
      let (str, sg, finalenv) = type_structure anchor env sstr in
 
585
      let (str, sg, finalenv) = type_structure anchor env sstr smod.pmod_loc in
588
586
      rm { mod_desc = Tmod_structure str;
589
587
           mod_type = Tmty_signature sg;
590
588
           mod_env = env;
639
637
           mod_env = env;
640
638
           mod_loc = smod.pmod_loc }
641
639
 
642
 
and type_structure anchor env sstr =
 
640
and type_structure anchor env sstr scope =
643
641
  let type_names = ref StringSet.empty
644
642
  and module_names = ref StringSet.empty
645
643
  and modtype_names = ref StringSet.empty in
652
650
        let expr = Typecore.type_expression env sexpr in
653
651
        let (str_rem, sig_rem, final_env) = type_struct env srem in
654
652
        (Tstr_eval expr :: str_rem, sig_rem, final_env)
655
 
    | {pstr_desc = Pstr_value(rec_flag, sdefs)} :: srem ->
 
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
656
665
        let (defs, newenv) =
657
 
          Typecore.type_binding env rec_flag sdefs in
 
666
          Typecore.type_binding env rec_flag sdefs scope in
658
667
        let (str_rem, sig_rem, final_env) = type_struct newenv srem in
659
668
        let bound_idents = let_bound_idents defs in
660
669
        let make_sig_value id =
798
807
         sg @ sig_rem,
799
808
         final_env)
800
809
  in
801
 
  if !Clflags.save_types
 
810
  if !Clflags.annotations
802
811
  then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
803
812
  type_struct env sstr
804
813
 
859
868
 
860
869
let type_implementation sourcefile outputprefix modulename initial_env ast =
861
870
  Typecore.reset_delayed_checks ();
862
 
  let (str, sg, finalenv) =
863
 
    Misc.try_finally (fun () -> type_structure initial_env ast)
864
 
                     (fun () -> Stypes.dump (outputprefix ^ ".annot"))
865
 
  in
 
871
  let (str, sg, finalenv) = type_structure initial_env ast Location.none in
866
872
  let simple_sg = simplify_signature sg in
867
873
  Typecore.force_delayed_checks ();
868
874
  if !Clflags.print_types then begin
882
888
      (str, coercion)
883
889
    end else begin
884
890
      check_nongen_schemes finalenv str;
885
 
      normalize_signature finalenv sg;
 
891
      normalize_signature finalenv simple_sg;
886
892
      let coercion =
887
893
        Includemod.compunit sourcefile sg
888
894
                            "(inferred signature)" simple_sg in