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
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1997 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Inclusion checks for the class language *)
open Types
let class_types env cty1 cty2 =
Ctype.match_class_types env cty1 cty2
let class_type_declarations ~loc env cty1 cty2 =
Builtin_attributes.check_alerts_inclusion
~def:cty1.clty_loc
~use:cty2.clty_loc
loc
cty1.clty_attributes cty2.clty_attributes
(Path.last cty1.clty_path);
Ctype.match_class_declarations env
cty1.clty_params cty1.clty_type
cty2.clty_params cty2.clty_type
let class_declarations env cty1 cty2 =
match cty1.cty_new, cty2.cty_new with
None, Some _ ->
[Ctype.CM_Virtual_class]
| _ ->
Ctype.match_class_declarations env
cty1.cty_params cty1.cty_type
cty2.cty_params cty2.cty_type
open Format_doc
open Ctype
module Printtyp=Printtyp.Doc
(*
let rec hide_params = function
Tcty_arrow ("*", _, cty) -> hide_params cty
| cty -> cty
*)
let include_err mode ppf =
let msg fmt = Format_doc.Doc.msg fmt in
function
| CM_Virtual_class ->
fprintf ppf "A class cannot be changed from virtual to concrete"
| CM_Parameter_arity_mismatch _ ->
fprintf ppf
"The classes do not have the same number of type parameters"
| CM_Type_parameter_mismatch (n, env, err) ->
Errortrace_report.equality ppf mode env err
(msg "The %d%s type parameter has type"
n (Misc.ordinal_suffix n))
(msg "but is expected to have type")
| CM_Class_type_mismatch (env, cty1, cty2) ->
Printtyp.wrap_printing_env ~error:true env (fun () ->
fprintf ppf
"@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
Printtyp.class_type cty1
"is not matched by the class type"
Printtyp.class_type cty2)
| CM_Parameter_mismatch (n, env, err) ->
Errortrace_report.moregen ppf mode env err
(msg "The %d%s parameter has type"
n (Misc.ordinal_suffix n))
(msg "but is expected to have type")
| CM_Val_type_mismatch (lab, env, err) ->
Errortrace_report.comparison ppf mode env err
(msg "The instance variable %s@ has type" lab)
(msg "but is expected to have type")
| CM_Meth_type_mismatch (lab, env, err) ->
Errortrace_report.comparison ppf mode env err
(msg "The method %s@ has type" lab)
(msg "but is expected to have type")
| CM_Non_mutable_value lab ->
fprintf ppf
"@[The non-mutable instance variable %s cannot become mutable@]" lab
| CM_Non_concrete_value lab ->
fprintf ppf
"@[The virtual instance variable %s cannot become concrete@]" lab
| CM_Missing_value lab ->
fprintf ppf "@[The first class type has no instance variable %s@]" lab
| CM_Missing_method lab ->
fprintf ppf "@[The first class type has no method %s@]" lab
| CM_Hide_public lab ->
fprintf ppf "@[The public method %s cannot be hidden@]" lab
| CM_Hide_virtual (k, lab) ->
fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
| CM_Public_method lab ->
fprintf ppf "@[The public method %s cannot become private@]" lab
| CM_Virtual_method lab ->
fprintf ppf "@[The virtual method %s cannot become concrete@]" lab
| CM_Private_method lab ->
fprintf ppf "@[The private method %s cannot become public@]" lab
let report_error_doc mode ppf = function
| [] -> ()
| err :: errs ->
let print_errs ppf errs =
List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in
fprintf ppf "@[<v>%a%a@]" (include_err mode) err print_errs errs
let report_error = Format_doc.compat1 report_error_doc
|
