1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 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$ *)
(* Inclusion checks for the core language *)
open Misc
open Path
open Types
open Typedtree
(* Inclusion between value descriptions *)
exception Dont_match
let value_descriptions env vd1 vd2 =
if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin
match (vd1.val_kind, vd2.val_kind) with
(Val_prim p1, Val_prim p2) ->
if p1 = p2 then Tcoerce_none else raise Dont_match
| (Val_prim p, _) -> Tcoerce_primitive p
| (_, Val_prim p) -> raise Dont_match
| (_, _) -> Tcoerce_none
end else
raise Dont_match
(* Inclusion between type declarations *)
let type_declarations env id decl1 decl2 =
decl1.type_arity = decl2.type_arity &&
let rec incl_tkinds = function
(_, Type_abstract) -> true
| (Type_variant cstrs1, Type_variant cstrs2) ->
Misc.for_all2
(fun (cstr1, arg1) (cstr2, arg2) ->
cstr1 = cstr2 &&
Misc.for_all2
(fun ty1 ty2 ->
Ctype.equal env true (ty1::decl1.type_params)
(ty2::decl2.type_params))
arg1 arg2)
cstrs1 cstrs2
| (Type_record(labels1, rep1), Type_record(labels2, rep2)) ->
rep1 = rep2 &&
Misc.for_all2
(fun (lbl1, mut1, ty1) (lbl2, mut2, ty2) ->
lbl1 = lbl2 && mut1 = mut2 &&
Ctype.equal env true (ty1::decl1.type_params)
(ty2::decl2.type_params))
labels1 labels2
| (Type_private tkind1, Type_private tkind2) -> incl_tkinds (tkind1, tkind2)
| (tkind1, Type_private tkind2) -> incl_tkinds (tkind1, tkind2)
| (_, _) -> false in
incl_tkinds (decl1.type_kind, decl2.type_kind)
&&
begin match (decl1.type_manifest, decl2.type_manifest) with
(_, None) ->
Ctype.equal env true decl1.type_params decl2.type_params
| (Some ty1, Some ty2) ->
Ctype.equal env true (ty1::decl1.type_params)
(ty2::decl2.type_params)
| (None, Some ty2) ->
let ty1 =
Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
in
Ctype.equal env true decl1.type_params decl2.type_params &&
Ctype.equal env false [ty1] [ty2]
end &&
begin decl2.type_kind <> Type_abstract || decl2.type_manifest <> None ||
List.for_all2
(fun (co1,cn1) (co2,cn2) -> (not co1 || co2) && (not cn1 || cn2))
decl1.type_variance decl2.type_variance
end
(* Inclusion between exception declarations *)
let exception_declarations env ed1 ed2 =
Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1 ed2
(* Inclusion between class types *)
let encode_val (mut, ty) rem =
begin match mut with
Asttypes.Mutable -> Predef.type_unit
| Asttypes.Immutable -> Btype.newgenty Tvar
end
::ty::rem
let meths meths1 meths2 =
Meths.fold
(fun nam t2 (ml1, ml2) ->
(begin try
Meths.find nam meths1 :: ml1
with Not_found ->
ml1
end,
t2 :: ml2))
meths2 ([], [])
let vars vars1 vars2 =
Vars.fold
(fun lab v2 (vl1, vl2) ->
(begin try
encode_val (Vars.find lab vars1) vl1
with Not_found ->
vl1
end,
encode_val v2 vl2))
vars2 ([], [])
|
