The unpac monorepo manager self-hosting as a monorepo using unpac
Merge commit 'b3d2cdcbe663e923e5091a81ceebb8d2e40a942c' into 5.00
+2919
-1888
+16
-12
Changes
+16
-12
Changes
···
15
15
is actually a suffix of `name` and raises Invalid_argument otherwise.
16
16
(Xavier Leroy, report by whitequark, review by David Allsopp)
17
17
18
+
* #10482: mark the Stream and Genlex modules as deprecated, in preparation
19
+
for a future removal. These modules (without deprecation alert)
20
+
are now provided by the camlp-streams library.
21
+
(Xavier Leroy, review by Nicolás Ojeda Bär)
22
+
18
23
### Other libraries:
19
24
20
25
- #10192: Add support for Unix domain sockets on Windows and use them
···
75
80
This allows stacktraces to work in gdb through C and OCaml calls.
76
81
(Edwin Török, review by Nicolás Ojeda Bär and Xavier Leroy)
77
82
78
-
- #10461: `caml_send*` helper functions take derived pointers as arguments.
79
-
Those must be declared with type Addr instead of Val.
80
-
(Vincent Laviron, review by Xavier Leroy)
83
+
- #10461, #10498: `caml_send*` helper functions take derived pointers
84
+
as arguments. Those must be declared with type Addr instead of Val.
85
+
Moreover, poll point insertion must be disabled for `caml_send*`,
86
+
otherwise the derived pointer is live across a poll point.
87
+
(Vincent Laviron and Xavier Leroy, review by Xavier Leroy and Sadiq Jaffer)
81
88
82
89
83
90
OCaml 4.13.0
···
89
96
Add poll points to native generated code. These are effectively
90
97
zero-sized allocations and fix some signal and remembered set
91
98
issues. Also multicore prerequisite.
92
-
(Sadiq Jaffer, Damien Doligez, Mark Shinwell, Anmol Sahoo, Stephen Dolan,
93
-
Xavier Leroy reviewed by ??)
99
+
(Sadiq Jaffer, Stephen Dolan, Damien Doligez, Xavier Leroy,
100
+
Anmol Sahoo, Mark Shinwell, review by Damien Doligez, Xavier Leroy,
101
+
and Mark Shinwell)
94
102
95
103
- #9331: Improve error messages for functor application and functor types.
96
104
(Florian Angeletti and Gabriel Radanne, review by Leo White)
···
110
118
One can now write '(Cstr (type a) (x, y : int * a))' to give a name to
111
119
existentials freshly introduced by GADT constructors.
112
120
(Jacques Garrigue, review by Leo White and Gabriel Scherer)
113
-
114
-
* #9811: remove propagation from previous branches
115
-
Type information inferred from previous branches was propagated in
116
-
non-principal mode. Revert this for better compatibility with
117
-
-principal mode.
118
-
For the time being, infringing code should result in a principality warning.
119
-
(Jacques Garrigue, review by Thomas Refis and Gabriel Scherer)
120
121
121
122
- #10174: Make Tsubst more robust by avoiding strange workarounds
122
123
(Takafumi Saikawa and Jacques Garrigue, review by Gabriel Scherer and
···
442
443
(Leo White, review by Florian Angeletti)
443
444
444
445
### Internal/compiler-libs changes:
446
+
447
+
- #8516: Change representation of class signatures
448
+
(Leo White, review by Thomas Refis)
445
449
446
450
- #9243, simplify parser rules for array indexing operations
447
451
(Florian Angeletti, review by Damien Doligez and Gabriel Scherer)
+34
-19
asmcomp/polling.ml
+34
-19
asmcomp/polling.ml
···
93
93
that does not go through an Ialloc or Ipoll instruction.
94
94
95
95
"Always_polls", therefore, means the function always polls (via Ialloc or
96
-
Ipoll) before doing a PRTC.
96
+
Ipoll) before doing a PRTC. This includes the case where it does not
97
+
perform any PRTC.
98
+
99
+
A note on Potentially Recursive Tail Calls
100
+
------------------------------------------
101
+
102
+
Tail calls can create infinite loops, of course. (Consider a function
103
+
that tail-calls itself.) But not all tail calls need to be flagged
104
+
as potential infinite loops.
105
+
106
+
We optimise by making a partial ordering over Mach functions: in
107
+
definition order within a compilation unit, and dependency
108
+
order between compilation units. This order is acyclic, as
109
+
OCaml does not allow circular dependencies between modules.
110
+
It's also finite, so if there's an infinite sequence of
111
+
function calls then something has to make a forward reference.
112
+
113
+
Also, in such an infinite sequence of function calls, at most finitely
114
+
many of them can be non-tail calls. (If there are infinitely many
115
+
non-tail calls, then the program soon terminates with a stack
116
+
overflow).
117
+
118
+
So, every such infinite sequence must contain many forward-referencing
119
+
tail calls. These tail calls are the Potentially Recursive Tail Calls
120
+
(PTRCs). Polling only on those calls suffices.
121
+
122
+
Several functions below take a parameter [future_funcnames]
123
+
which is the set of functions defined "after" the current function
124
+
in the current compilation unit. The PTRCs are tail calls
125
+
to known functions in [future_funcnames], or tail calls to
126
+
unknown functions.
97
127
*)
98
128
99
129
type polls_before_prtc = Might_not_poll | Always_polls
···
125
155
match i.desc with
126
156
| Iend -> next
127
157
| Iop (Ialloc _ | Ipoll _) -> Always_polls
128
-
| Iop (Itailcall_ind) -> Might_not_poll
158
+
| Iop (Itailcall_ind) -> Might_not_poll (* this is a PTRC *)
129
159
| Iop (Itailcall_imm { func }) ->
130
-
(* We optimise by making a partial ordering over Mach functions: in
131
-
definition order within a compilation unit, and dependency order
132
-
between compilation units. This order is acyclic, as OCaml does not
133
-
allow circular dependencies between modules. It's also finite, so if
134
-
there's an infinite sequence of function calls then something has to
135
-
make a forward reference.
136
-
137
-
Also, in such an infinite sequence of function calls, at most finitely
138
-
many of them can be non-tail calls. (If there are infinitely many
139
-
non-tail calls, then the program soon terminates with a stack
140
-
overflow).
141
-
142
-
So, every such infinite sequence must contain many forward-referencing
143
-
tail calls, so polling only on those suffices. This is checked using
144
-
the set [future_funcnames]. *)
145
160
if String.Set.mem func future_funcnames
146
161
|| function_is_assumed_to_never_poll func
147
-
then Might_not_poll
148
-
else Always_polls
162
+
then Might_not_poll (* this is a PTRC *)
163
+
else Always_polls (* this is not a PTRC *)
149
164
| Iop op ->
150
165
if operation_can_raise op
151
166
then Polls_before_prtc.join next exn
boot/ocamlc
boot/ocamlc
This is a binary file and will not be displayed.
boot/ocamllex
boot/ocamllex
This is a binary file and will not be displayed.
+3
-1
dune
+3
-1
dune
···
156
156
emit emitaux emitenv
157
157
interf interval
158
158
linear linearize linscan
159
-
liveness mach printcmm printlinear printmach proc reg reload reloadgen
159
+
liveness mach
160
+
polling printcmm printlinear printmach proc
161
+
reg reload reloadgen
160
162
schedgen scheduling selectgen selection spill split
161
163
strmatch x86_ast x86_dsl x86_gas x86_masm x86_proc
162
164
+2
-2
lambda/translclass.ml
+2
-2
lambda/translclass.ml
···
354
354
(inh_init, transl_vals cla true StrictOpt vals cl_init)
355
355
| Tcl_constraint (cl, _, vals, meths, concr_meths) ->
356
356
let virt_meths =
357
-
List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
358
-
let concr_meths = Concr.elements concr_meths in
357
+
List.filter (fun lab -> not (MethSet.mem lab concr_meths)) meths in
358
+
let concr_meths = MethSet.elements concr_meths in
359
359
let narrow_args =
360
360
[Lvar cla;
361
361
transl_meth_list vals;
+16
-8
lambda/translcore.ml
+16
-8
lambda/translcore.ml
···
462
462
| Texp_for(param, _, low, high, dir, body) ->
463
463
Lfor(param, transl_exp ~scopes low, transl_exp ~scopes high, dir,
464
464
event_before ~scopes body (transl_exp ~scopes body))
465
-
| Texp_send(_, _, Some exp) -> transl_exp ~scopes exp
466
-
| Texp_send(expr, met, None) ->
467
-
let obj = transl_exp ~scopes expr in
468
-
let loc = of_location ~scopes e.exp_loc in
465
+
| Texp_send(expr, met) ->
469
466
let lam =
467
+
let loc = of_location ~scopes e.exp_loc in
470
468
match met with
471
-
Tmeth_val id -> Lsend (Self, Lvar id, obj, [], loc)
469
+
| Tmeth_val id ->
470
+
let obj = transl_exp ~scopes expr in
471
+
Lsend (Self, Lvar id, obj, [], loc)
472
472
| Tmeth_name nm ->
473
+
let obj = transl_exp ~scopes expr in
473
474
let (tag, cache) = Translobj.meth obj nm in
474
475
let kind = if cache = [] then Public else Cached in
475
476
Lsend (kind, tag, obj, cache, loc)
477
+
| Tmeth_ancestor(meth, path_self) ->
478
+
let self = transl_value_path loc e.exp_env path_self in
479
+
Lapply {ap_loc = loc;
480
+
ap_func = Lvar meth;
481
+
ap_args = [self];
482
+
ap_tailcall = Default_tailcall;
483
+
ap_inlined = Default_inline;
484
+
ap_specialised = Default_specialise}
476
485
in
477
486
event_after ~scopes e lam
478
487
| Texp_new (cl, {Location.loc=loc}, _) ->
···
511
520
ap_specialised=Default_specialise;
512
521
},
513
522
List.fold_right
514
-
(fun (path, _, expr) rem ->
515
-
let var = transl_value_path loc e.exp_env path in
523
+
(fun (id, _, expr) rem ->
516
524
Lsequence(transl_setinstvar ~scopes Loc_unknown
517
-
(Lvar cpy) var expr, rem))
525
+
(Lvar cpy) (Lvar id) expr, rem))
518
526
modifs
519
527
(Lvar cpy))
520
528
| Texp_letmodule(None, loc, Mp_present, modl, body) ->
+1
-1
manual/src/refman/Makefile
+1
-1
manual/src/refman/Makefile
···
16
16
attributes.tex extensionnodes.etex extensiblevariants.tex \
17
17
generativefunctors.tex extensionsyntax.tex inlinerecords.tex \
18
18
doccomments.tex indexops.tex emptyvariants.tex alerts.tex \
19
-
generalizedopens.tex bindingops.tex extensionnodes.tex
19
+
generalizedopens.tex bindingops.tex extensionnodes.tex privatetypes.tex
20
20
21
21
FILES = $(addprefix extensions/,$(EXTENSION_FILES)) \
22
22
refman.tex lex.tex names.tex values.tex const.tex types.tex \
+5
manual/src/refman/exten.etex
+5
manual/src/refman/exten.etex
···
16
16
%HEVEA\cutname{recursivemodules.html}
17
17
\input{recursivemodules.tex}
18
18
19
+
\section{s:private-types}{Private types}
20
+
%HEVEA\cutname{privatetypes.html}
21
+
\ikwd{private\@\texttt{private}}
22
+
\input{privatetypes.tex}
23
+
19
24
\section{s:locally-abstract}{Locally abstract types}
20
25
\ikwd{type\@\texttt{type}}
21
26
\ikwd{fun\@\texttt{fun}}
+166
manual/src/refman/extensions/privatetypes.etex
+166
manual/src/refman/extensions/privatetypes.etex
···
1
+
Private type declarations in module signatures, of the form
2
+
"type t = private ...", enable libraries to
3
+
reveal some, but not all aspects of the implementation of a type to
4
+
clients of the library. In this respect, they strike a middle ground
5
+
between abstract type declarations, where no information is revealed
6
+
on the type implementation, and data type definitions and type
7
+
abbreviations, where all aspects of the type implementation are
8
+
publicized. Private type declarations come in three flavors: for
9
+
variant and record types (section~\ref{ss:private-types-variant}),
10
+
for type abbreviations (section~\ref{ss:private-types-abbrev}),
11
+
and for row types (section~\ref{ss:private-rows}).
12
+
13
+
\subsection{ss:private-types-variant}{Private variant and record types}
14
+
15
+
16
+
(Introduced in Objective Caml 3.07)
17
+
18
+
\begin{syntax}
19
+
type-representation:
20
+
...
21
+
| '=' 'private' [ '|' ] constr-decl { '|' constr-decl }
22
+
| '=' 'private' record-decl
23
+
\end{syntax}
24
+
25
+
Values of a variant or record type declared @"private"@
26
+
can be de-structured normally in pattern-matching or via
27
+
the @expr '.' field@ notation for record accesses. However, values of
28
+
these types cannot be constructed directly by constructor application
29
+
or record construction. Moreover, assignment on a mutable field of a
30
+
private record type is not allowed.
31
+
32
+
The typical use of private types is in the export signature of a
33
+
module, to ensure that construction of values of the private type always
34
+
go through the functions provided by the module, while still allowing
35
+
pattern-matching outside the defining module. For example:
36
+
\begin{caml_example*}{verbatim}
37
+
module M : sig
38
+
type t = private A | B of int
39
+
val a : t
40
+
val b : int -> t
41
+
end = struct
42
+
type t = A | B of int
43
+
let a = A
44
+
let b n = assert (n > 0); B n
45
+
end
46
+
\end{caml_example*}
47
+
Here, the @"private"@ declaration ensures that in any value of type
48
+
"M.t", the argument to the "B" constructor is always a positive integer.
49
+
50
+
With respect to the variance of their parameters, private types are
51
+
handled like abstract types. That is, if a private type has
52
+
parameters, their variance is the one explicitly given by prefixing
53
+
the parameter by a `"+"' or a `"-"', it is invariant otherwise.
54
+
55
+
\subsection{ss:private-types-abbrev}{Private type abbreviations}
56
+
57
+
(Introduced in Objective Caml 3.11)
58
+
59
+
\begin{syntax}
60
+
type-equation:
61
+
...
62
+
| '=' 'private' typexpr
63
+
\end{syntax}
64
+
65
+
Unlike a regular type abbreviation, a private type abbreviation
66
+
declares a type that is distinct from its implementation type @typexpr@.
67
+
However, coercions from the type to @typexpr@ are permitted.
68
+
Moreover, the compiler ``knows'' the implementation type and can take
69
+
advantage of this knowledge to perform type-directed optimizations.
70
+
71
+
The following example uses a private type abbreviation to define a
72
+
module of nonnegative integers:
73
+
\begin{caml_example*}{verbatim}
74
+
module N : sig
75
+
type t = private int
76
+
val of_int: int -> t
77
+
val to_int: t -> int
78
+
end = struct
79
+
type t = int
80
+
let of_int n = assert (n >= 0); n
81
+
let to_int n = n
82
+
end
83
+
\end{caml_example*}
84
+
The type "N.t" is incompatible with "int", ensuring that nonnegative
85
+
integers and regular integers are not confused. However, if "x" has
86
+
type "N.t", the coercion "(x :> int)" is legal and returns the
87
+
underlying integer, just like "N.to_int x". Deep coercions are also
88
+
supported: if "l" has type "N.t list", the coercion "(l :> int list)"
89
+
returns the list of underlying integers, like "List.map N.to_int l"
90
+
but without copying the list "l".
91
+
92
+
Note that the coercion @"(" expr ":>" typexpr ")"@ is actually an abbreviated
93
+
form,
94
+
and will only work in presence of private abbreviations if neither the
95
+
type of @expr@ nor @typexpr@ contain any type variables. If they do,
96
+
you must use the full form @"(" expr ":" typexpr_1 ":>" typexpr_2 ")"@ where
97
+
@typexpr_1@ is the expected type of @expr@. Concretely, this would be "(x :
98
+
N.t :> int)" and "(l : N.t list :> int list)" for the above examples.
99
+
100
+
\subsection{ss:private-rows}{Private row types}
101
+
\ikwd{private\@\texttt{private}}
102
+
103
+
(Introduced in Objective Caml 3.09)
104
+
105
+
\begin{syntax}
106
+
type-equation:
107
+
...
108
+
| '=' 'private' typexpr
109
+
\end{syntax}
110
+
111
+
Private row types are type abbreviations where part of the
112
+
structure of the type is left abstract. Concretely @typexpr@ in the
113
+
above should denote either an object type or a polymorphic variant
114
+
type, with some possibility of refinement left. If the private
115
+
declaration is used in an interface, the corresponding implementation
116
+
may either provide a ground instance, or a refined private type.
117
+
\begin{caml_example*}{verbatim}
118
+
module M : sig type c = private < x : int; .. > val o : c end =
119
+
struct
120
+
class c = object method x = 3 method y = 2 end
121
+
let o = new c
122
+
end
123
+
\end{caml_example*}
124
+
This declaration does more than hiding the "y" method, it also makes
125
+
the type "c" incompatible with any other closed object type, meaning
126
+
that only "o" will be of type "c". In that respect it behaves
127
+
similarly to private record types. But private row types are
128
+
more flexible with respect to incremental refinement. This feature can
129
+
be used in combination with functors.
130
+
\begin{caml_example*}{verbatim}
131
+
module F(X : sig type c = private < x : int; .. > end) =
132
+
struct
133
+
let get_x (o : X.c) = o#x
134
+
end
135
+
module G(X : sig type c = private < x : int; y : int; .. > end) =
136
+
struct
137
+
include F(X)
138
+
let get_y (o : X.c) = o#y
139
+
end
140
+
\end{caml_example*}
141
+
142
+
A polymorphic variant type [t], for example
143
+
\begin{caml_example*}{verbatim}
144
+
type t = [ `A of int | `B of bool ]
145
+
\end{caml_example*}
146
+
can be refined in two ways. A definition [u] may add new field to [t],
147
+
and the declaration
148
+
\begin{caml_example*}{verbatim}
149
+
type u = private [> t]
150
+
\end{caml_example*}
151
+
will keep those new fields abstract. Construction of values of type
152
+
[u] is possible using the known variants of [t], but any
153
+
pattern-matching will require a default case to handle the potential
154
+
extra fields. Dually, a declaration [u] may restrict the fields of [t]
155
+
through abstraction: the declaration
156
+
\begin{caml_example*}{verbatim}
157
+
type v = private [< t > `A]
158
+
\end{caml_example*}
159
+
corresponds to private variant types. One cannot create a value of the
160
+
private type [v], except using the constructors that are explicitly
161
+
listed as present, "(`A n)" in this example; yet, when
162
+
patter-matching on a [v], one should assume that any of the
163
+
constructors of [t] could be present.
164
+
165
+
Similarly to abstract types, the variance of type parameters
166
+
is not inferred, and must be given explicitly.
-171
manual/src/refman/extensions/recursivemodules.etex
-171
manual/src/refman/extensions/recursivemodules.etex
···
78
78
79
79
Note that, in the @specification@ case, the @module-type@s must be
80
80
parenthesized if they use the @'with' mod-constraint@ construct.
81
-
82
-
\section{s:private-types}{Private types}
83
-
%HEVEA\cutname{privatetypes.html}
84
-
\ikwd{private\@\texttt{private}}
85
-
86
-
Private type declarations in module signatures, of the form
87
-
"type t = private ...", enable libraries to
88
-
reveal some, but not all aspects of the implementation of a type to
89
-
clients of the library. In this respect, they strike a middle ground
90
-
between abstract type declarations, where no information is revealed
91
-
on the type implementation, and data type definitions and type
92
-
abbreviations, where all aspects of the type implementation are
93
-
publicized. Private type declarations come in three flavors: for
94
-
variant and record types (section~\ref{ss:private-types-variant}),
95
-
for type abbreviations (section~\ref{ss:private-types-abbrev}),
96
-
and for row types (section~\ref{ss:private-rows}).
97
-
98
-
\subsection{ss:private-types-variant}{Private variant and record types}
99
-
100
-
101
-
(Introduced in Objective Caml 3.07)
102
-
103
-
\begin{syntax}
104
-
type-representation:
105
-
...
106
-
| '=' 'private' [ '|' ] constr-decl { '|' constr-decl }
107
-
| '=' 'private' record-decl
108
-
\end{syntax}
109
-
110
-
Values of a variant or record type declared @"private"@
111
-
can be de-structured normally in pattern-matching or via
112
-
the @expr '.' field@ notation for record accesses. However, values of
113
-
these types cannot be constructed directly by constructor application
114
-
or record construction. Moreover, assignment on a mutable field of a
115
-
private record type is not allowed.
116
-
117
-
The typical use of private types is in the export signature of a
118
-
module, to ensure that construction of values of the private type always
119
-
go through the functions provided by the module, while still allowing
120
-
pattern-matching outside the defining module. For example:
121
-
\begin{caml_example*}{verbatim}
122
-
module M : sig
123
-
type t = private A | B of int
124
-
val a : t
125
-
val b : int -> t
126
-
end = struct
127
-
type t = A | B of int
128
-
let a = A
129
-
let b n = assert (n > 0); B n
130
-
end
131
-
\end{caml_example*}
132
-
Here, the @"private"@ declaration ensures that in any value of type
133
-
"M.t", the argument to the "B" constructor is always a positive integer.
134
-
135
-
With respect to the variance of their parameters, private types are
136
-
handled like abstract types. That is, if a private type has
137
-
parameters, their variance is the one explicitly given by prefixing
138
-
the parameter by a `"+"' or a `"-"', it is invariant otherwise.
139
-
140
-
\subsection{ss:private-types-abbrev}{Private type abbreviations}
141
-
142
-
(Introduced in Objective Caml 3.11)
143
-
144
-
\begin{syntax}
145
-
type-equation:
146
-
...
147
-
| '=' 'private' typexpr
148
-
\end{syntax}
149
-
150
-
Unlike a regular type abbreviation, a private type abbreviation
151
-
declares a type that is distinct from its implementation type @typexpr@.
152
-
However, coercions from the type to @typexpr@ are permitted.
153
-
Moreover, the compiler ``knows'' the implementation type and can take
154
-
advantage of this knowledge to perform type-directed optimizations.
155
-
156
-
The following example uses a private type abbreviation to define a
157
-
module of nonnegative integers:
158
-
\begin{caml_example*}{verbatim}
159
-
module N : sig
160
-
type t = private int
161
-
val of_int: int -> t
162
-
val to_int: t -> int
163
-
end = struct
164
-
type t = int
165
-
let of_int n = assert (n >= 0); n
166
-
let to_int n = n
167
-
end
168
-
\end{caml_example*}
169
-
The type "N.t" is incompatible with "int", ensuring that nonnegative
170
-
integers and regular integers are not confused. However, if "x" has
171
-
type "N.t", the coercion "(x :> int)" is legal and returns the
172
-
underlying integer, just like "N.to_int x". Deep coercions are also
173
-
supported: if "l" has type "N.t list", the coercion "(l :> int list)"
174
-
returns the list of underlying integers, like "List.map N.to_int l"
175
-
but without copying the list "l".
176
-
177
-
Note that the coercion @"(" expr ":>" typexpr ")"@ is actually an abbreviated
178
-
form,
179
-
and will only work in presence of private abbreviations if neither the
180
-
type of @expr@ nor @typexpr@ contain any type variables. If they do,
181
-
you must use the full form @"(" expr ":" typexpr_1 ":>" typexpr_2 ")"@ where
182
-
@typexpr_1@ is the expected type of @expr@. Concretely, this would be "(x :
183
-
N.t :> int)" and "(l : N.t list :> int list)" for the above examples.
184
-
185
-
\subsection{ss:private-rows}{Private row types}
186
-
\ikwd{private\@\texttt{private}}
187
-
188
-
(Introduced in Objective Caml 3.09)
189
-
190
-
\begin{syntax}
191
-
type-equation:
192
-
...
193
-
| '=' 'private' typexpr
194
-
\end{syntax}
195
-
196
-
Private row types are type abbreviations where part of the
197
-
structure of the type is left abstract. Concretely @typexpr@ in the
198
-
above should denote either an object type or a polymorphic variant
199
-
type, with some possibility of refinement left. If the private
200
-
declaration is used in an interface, the corresponding implementation
201
-
may either provide a ground instance, or a refined private type.
202
-
\begin{caml_example*}{verbatim}
203
-
module M : sig type c = private < x : int; .. > val o : c end =
204
-
struct
205
-
class c = object method x = 3 method y = 2 end
206
-
let o = new c
207
-
end
208
-
\end{caml_example*}
209
-
This declaration does more than hiding the "y" method, it also makes
210
-
the type "c" incompatible with any other closed object type, meaning
211
-
that only "o" will be of type "c". In that respect it behaves
212
-
similarly to private record types. But private row types are
213
-
more flexible with respect to incremental refinement. This feature can
214
-
be used in combination with functors.
215
-
\begin{caml_example*}{verbatim}
216
-
module F(X : sig type c = private < x : int; .. > end) =
217
-
struct
218
-
let get_x (o : X.c) = o#x
219
-
end
220
-
module G(X : sig type c = private < x : int; y : int; .. > end) =
221
-
struct
222
-
include F(X)
223
-
let get_y (o : X.c) = o#y
224
-
end
225
-
\end{caml_example*}
226
-
227
-
A polymorphic variant type [t], for example
228
-
\begin{caml_example*}{verbatim}
229
-
type t = [ `A of int | `B of bool ]
230
-
\end{caml_example*}
231
-
can be refined in two ways. A definition [u] may add new field to [t],
232
-
and the declaration
233
-
\begin{caml_example*}{verbatim}
234
-
type u = private [> t]
235
-
\end{caml_example*}
236
-
will keep those new fields abstract. Construction of values of type
237
-
[u] is possible using the known variants of [t], but any
238
-
pattern-matching will require a default case to handle the potential
239
-
extra fields. Dually, a declaration [u] may restrict the fields of [t]
240
-
through abstraction: the declaration
241
-
\begin{caml_example*}{verbatim}
242
-
type v = private [< t > `A]
243
-
\end{caml_example*}
244
-
corresponds to private variant types. One cannot create a value of the
245
-
private type [v], except using the constructors that are explicitly
246
-
listed as present, "(`A n)" in this example; yet, when
247
-
patter-matching on a [v], one should assume that any of the
248
-
constructors of [t] could be present.
249
-
250
-
Similarly to abstract types, the variance of type parameters
251
-
is not inferred, and must be given explicitly.
-4
manual/src/refman/extensions/signaturesubstitution.etex
-4
manual/src/refman/extensions/signaturesubstitution.etex
-2
ocamldoc/.depend
-2
ocamldoc/.depend
···
514
514
odoc_types.cmi \
515
515
odoc_messages.cmo \
516
516
../parsing/longident.cmi \
517
-
../typing/ctype.cmi \
518
517
../typing/btype.cmi \
519
518
odoc_misc.cmi
520
519
odoc_misc.cmx : \
···
524
523
odoc_types.cmx \
525
524
odoc_messages.cmx \
526
525
../parsing/longident.cmx \
527
-
../typing/ctype.cmx \
528
526
../typing/btype.cmx \
529
527
odoc_misc.cmi
530
528
odoc_misc.cmi : \
-16
ocamldoc/odoc_misc.ml
-16
ocamldoc/odoc_misc.ml
···
87
87
| Longident.Lapply(l1, l2) ->
88
88
string_of_longident l1 ^ "(" ^ string_of_longident l2 ^ ")"
89
89
90
-
let get_fields type_expr =
91
-
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields type_expr) in
92
-
List.fold_left
93
-
(fun acc -> fun (label, field_kind, typ) ->
94
-
match field_kind with
95
-
Types.Fabsent ->
96
-
acc
97
-
| _ ->
98
-
if label = "*dummy method*" then
99
-
acc
100
-
else
101
-
acc @ [label, typ]
102
-
)
103
-
[]
104
-
fields
105
-
106
90
let rec string_of_text t =
107
91
let rec iter t_ele =
108
92
match t_ele with
-4
ocamldoc/odoc_misc.mli
-4
ocamldoc/odoc_misc.mli
···
29
29
(** This function creates a string from a Longident.t .*)
30
30
val string_of_longident : Longident.t -> string
31
31
32
-
(** This function returns the list of (label, type_expr) describing
33
-
the methods of a type_expr in a Tobject.*)
34
-
val get_fields : Types.type_expr -> (string * Types.type_expr) list
35
-
36
32
(** get a string from a text *)
37
33
val string_of_text : Odoc_types.text -> string
38
34
+10
-12
ocamldoc/odoc_print.ml
+10
-12
ocamldoc/odoc_print.ml
···
87
87
| Cty_signature cs ->
88
88
(* we delete vals and methods in order to not print them when
89
89
displaying the type *)
90
+
let self_row =
91
+
Transient_expr.create Tnil
92
+
~level:0 ~scope:Btype.lowest_level ~id:0
93
+
in
90
94
let tself =
91
95
let t = cs.csig_self in
92
-
let t' = Transient_expr.create Tnil
93
-
~level:0 ~scope:Btype.lowest_level ~id:0 in
94
-
let desc =
95
-
Tobject (Transient_expr.type_expr t', ref None) in
96
+
let desc = Tobject (Transient_expr.type_expr self_row, ref None) in
96
97
Transient_expr.create desc
97
-
~level:(get_level t)
98
-
~scope:(get_scope t)
99
-
~id:(get_id t)
98
+
~level:(get_level t) ~scope:(get_scope t) ~id:(get_id t)
100
99
in
101
-
Cty_signature { csig_self = Transient_expr.type_expr tself;
100
+
Types.Cty_signature { csig_self = Transient_expr.type_expr tself;
101
+
csig_self_row = Transient_expr.type_expr self_row;
102
102
csig_vars = Vars.empty ;
103
-
csig_concr = Concr.empty ;
104
-
csig_inher = []
105
-
}
106
-
| Cty_arrow (l, texp, ct) ->
103
+
csig_meths = Meths.empty ; }
104
+
| Types.Cty_arrow (l, texp, ct) ->
107
105
let new_ct = iter ct in
108
106
Cty_arrow (l, texp, new_ct)
109
107
in
+2
-2
ocamldoc/odoc_sig.ml
+2
-2
ocamldoc/odoc_sig.ml
···
104
104
type_expr
105
105
106
106
let search_method_type name class_sig =
107
-
let fields = Odoc_misc.get_fields class_sig.Types.csig_self in
108
-
List.assoc name fields
107
+
let (_, _, type_expr) = Types.Meths.find name class_sig.Types.csig_meths in
108
+
type_expr
109
109
end
110
110
111
111
module type Info_retriever =
+2
stdlib/genlex.ml
+2
stdlib/genlex.ml
+2
stdlib/genlex.mli
+2
stdlib/genlex.mli
···
45
45
["-pp"] command-line switch of the compilers.
46
46
*)
47
47
48
+
[@@@ocaml.warning "-3"] (* ignore deprecation warning about module Stream *)
49
+
48
50
(** The type of tokens. The lexical classes are: [Int] and [Float]
49
51
for integer and floating-point numbers; [String] for
50
52
string literals, enclosed in double quotes; [Char] for
+2
stdlib/stdlib.mli
+2
stdlib/stdlib.mli
···
1401
1401
module Fun = Fun
1402
1402
module Gc = Gc
1403
1403
module Genlex = Genlex
1404
+
[@@deprecated "Use the camlp-streams library instead."]
1404
1405
module Hashtbl = Hashtbl
1405
1406
module Int = Int
1406
1407
module Int32 = Int32
···
1435
1436
module Stack = Stack
1436
1437
module StdLabels = StdLabels
1437
1438
module Stream = Stream
1439
+
[@@deprecated "Use the camlp-streams library instead."]
1438
1440
module String = String
1439
1441
module StringLabels = StringLabels
1440
1442
module Sys = Sys
+1
testsuite/tests/lib-stream/count_concat_bug.ml
+1
testsuite/tests/lib-stream/count_concat_bug.ml
+1
testsuite/tests/lib-stream/mpr7769.ml
+1
testsuite/tests/lib-stream/mpr7769.ml
+4
-5
testsuite/tests/typing-gadts/pr7260.ml
+4
-5
testsuite/tests/typing-gadts/pr7260.ml
···
19
19
type bar = < bar : unit >
20
20
type _ ty = Int : int ty
21
21
type dyn = Dyn : 'a ty -> dyn
22
-
Lines 7-12, characters 0-5:
23
-
7 | class foo =
24
-
8 | object (this)
22
+
Lines 8-12, characters 2-5:
23
+
8 | ..object (this)
25
24
9 | method foo (Dyn ty) =
26
25
10 | match ty with
27
26
11 | | Int -> (this :> bar)
28
27
12 | end.................................
29
-
Error: This class should be virtual.
30
-
The following methods are undefined : bar
28
+
Error: This non-virtual class has undeclared virtual methods.
29
+
The following methods were not declared : bar
31
30
|}];;
+5
-5
testsuite/tests/typing-gadts/pr7391.ml
+5
-5
testsuite/tests/typing-gadts/pr7391.ml
···
29
29
object ('a)
30
30
method private virtual parent : < previous : 'a option; .. >
31
31
end
32
-
- : < child : child2; previous : child2 option > = <obj>
32
+
- : < child : child1; previous : child1 option > = <obj>
33
33
|}]
34
34
35
35
(* Worked in 4.03 *)
···
43
43
end
44
44
end;;
45
45
[%%expect{|
46
-
- : < child : unit -> child2; previous : child2 option > = <obj>
46
+
- : < child : unit -> child1; previous : child1 option > = <obj>
47
47
|}]
48
48
49
49
(* Worked in 4.03 *)
···
57
57
end
58
58
end;;
59
59
[%%expect{|
60
-
- : < child : unit -> child2; previous : child2 option > = <obj>
60
+
- : < child : unit -> child1; previous : child1 option > = <obj>
61
61
|}]
62
62
63
63
(* Didn't work in 4.03, but works in 4.07 *)
···
73
73
in o
74
74
end;;
75
75
[%%expect{|
76
-
- : < child : child2; previous : child2 option > = <obj>
76
+
- : < child : child1; previous : child1 option > = <obj>
77
77
|}]
78
78
79
79
(* Also didn't work in 4.03 *)
···
91
91
end;;
92
92
[%%expect{|
93
93
type gadt = Not_really_though : gadt
94
-
- : < child : gadt -> child2; previous : child2 option > = <obj>
94
+
- : < child : gadt -> child1; previous : child1 option > = <obj>
95
95
|}]
-9
testsuite/tests/typing-gadts/test.ml
-9
testsuite/tests/typing-gadts/test.ml
···
628
628
in M.z
629
629
;; (* fails because of aliasing... *)
630
630
[%%expect{|
631
-
Lines 2-4, characters 2-10:
632
-
2 | ..match x with Int ->
633
-
3 | let module M = struct type b = a let z = (y : b) end
634
-
4 | in M.z
635
-
Warning 18 [not-principal]:
636
-
The return type of this pattern-matching is ambiguous.
637
-
Please add a type annotation, as the choice of `a' is not principal.
638
-
val f : 'a t -> 'a -> 'a = <fun>
639
-
|}, Principal{|
640
631
Line 3, characters 46-47:
641
632
3 | let module M = struct type b = a let z = (y : b) end
642
633
^
+2
-2
testsuite/tests/typing-misc/exotic_unifications.ml
+2
-2
testsuite/tests/typing-misc/exotic_unifications.ml
···
9
9
end
10
10
[%%expect {|
11
11
class virtual t : object method virtual x : float end
12
-
Line 4, characters 16-17:
12
+
Line 4, characters 8-17:
13
13
4 | inherit t
14
-
^
14
+
^^^^^^^^^
15
15
Error: The method x has type int but is expected to have type float
16
16
Type int is not compatible with type float
17
17
|}]
+2
-1
testsuite/tests/typing-misc/includeclass_errors.ml
+2
-1
testsuite/tests/typing-misc/includeclass_errors.ml
···
146
146
3 | method foo = "foo"
147
147
4 | method private virtual cast: int
148
148
5 | end
149
-
Error: The class type object method foo : string end
149
+
Error: The class type
150
+
object method private virtual cast : int method foo : string end
150
151
is not matched by the class type foo_t
151
152
The virtual method cast cannot be hidden
152
153
|}]
+1
-1
testsuite/tests/typing-misc/pr6416.ml
+1
-1
testsuite/tests/typing-misc/pr6416.ml
···
219
219
class b : a
220
220
does not match
221
221
class b : a/2
222
-
The first class type has no method m
223
222
The public method c cannot be hidden
223
+
The first class type has no method m
224
224
Line 5, characters 4-74:
225
225
Definition of class type a/1
226
226
Line 2, characters 2-36:
+6
-14
testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference
+6
-14
testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference
···
12
12
Error: The class type
13
13
object
14
14
val l :
15
-
[ `Abs of
16
-
string *
17
-
([> `App of
18
-
[ `Abs of string * 'a | `App of expr * expr ] * exp ]
19
-
as 'a)
20
-
| `App of expr * expr ]
15
+
[ `Abs of string * ([> `App of 'a * exp ] as 'b)
16
+
| `App of expr * expr ] as 'a
21
17
val r : exp
22
-
method eval : (string, exp) Hashtbl.t -> 'a
18
+
method eval : (string, exp) Hashtbl.t -> 'b
23
19
end
24
20
is not matched by the class type exp
25
21
The class type
26
22
object
27
23
val l :
28
-
[ `Abs of
29
-
string *
30
-
([> `App of
31
-
[ `Abs of string * 'a | `App of expr * expr ] * exp ]
32
-
as 'a)
33
-
| `App of expr * expr ]
24
+
[ `Abs of string * ([> `App of 'a * exp ] as 'b)
25
+
| `App of expr * expr ] as 'a
34
26
val r : exp
35
-
method eval : (string, exp) Hashtbl.t -> 'a
27
+
method eval : (string, exp) Hashtbl.t -> 'b
36
28
end
37
29
is not matched by the class type
38
30
object method eval : (string, exp) Hashtbl.t -> expr end
+2
-3
testsuite/tests/typing-objects/Exemples.ml
+2
-3
testsuite/tests/typing-objects/Exemples.ml
···
286
286
Format.print_string ")"
287
287
end;;
288
288
[%%expect{|
289
-
Line 3, characters 10-27:
289
+
Line 3, characters 2-36:
290
290
3 | inherit printable_point y as super
291
-
^^^^^^^^^^^^^^^^^
291
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
292
292
Warning 13 [instance-variable-override]: the following instance variables are overridden by the class printable_point :
293
293
x
294
-
The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
295
294
class printable_color_point :
296
295
int ->
297
296
string ->
+355
-17
testsuite/tests/typing-objects/Tests.ml
+355
-17
testsuite/tests/typing-objects/Tests.ml
···
19
19
end;;
20
20
[%%expect{|
21
21
class ['a] c : unit -> object constraint 'a = int method f : int c end
22
-
and ['a] d : unit -> object constraint 'a = int method f : int c end
22
+
and ['a] d : unit -> object constraint 'a = int method f : 'a c end
23
23
|}];;
24
24
(* class ['a] c : unit -> object constraint 'a = int method f : 'a c end *)
25
25
(* and ['a] d : unit -> object constraint 'a = int method f : 'a c end *)
···
103
103
method virtual f : int
104
104
end;;
105
105
[%%expect{|
106
-
Lines 1-3, characters 0-3:
107
-
1 | class x () = object
106
+
Lines 1-3, characters 13-3:
107
+
1 | .............object
108
108
2 | method virtual f : int
109
109
3 | end..
110
-
Error: This class should be virtual. The following methods are undefined : f
110
+
Error: This non-virtual class has virtual methods.
111
+
The following methods are virtual : f
111
112
|}];;
112
113
(* The class x should be virtual: its methods f is undefined *)
113
114
···
162
163
class ['a, 'b] d :
163
164
unit ->
164
165
object
165
-
constraint 'a = int -> 'c
166
-
constraint 'b = 'a * < x : 'b > * 'c * 'd
167
-
method f : 'a -> 'b -> unit
166
+
constraint 'a = int -> 'd
167
+
constraint 'b = 'a * (< x : 'b > as 'c) * 'd * 'e
168
+
method f : (int -> 'd) -> (int -> 'd) * 'c * 'd * 'e -> unit
168
169
end
169
170
|}];;
170
171
···
322
323
constraint 'a = int -> bool
323
324
val x : float list
324
325
val y : 'b
325
-
method f : 'a -> unit
326
+
method f : (int -> bool) -> unit
326
327
method g : 'b
327
328
end
328
329
|}];;
···
335
336
constraint 'a = int -> bool
336
337
val x : float list
337
338
val y : 'b
338
-
method f : 'a -> unit
339
+
method f : (int -> bool) -> unit
339
340
method g : 'b
340
341
end
341
342
|}];;
···
469
470
method b = b
470
471
end;;
471
472
[%%expect{|
472
-
Line 3, characters 10-13:
473
+
Line 3, characters 2-13:
473
474
3 | inherit c 5
474
-
^^^
475
+
^^^^^^^^^^^
475
476
Warning 13 [instance-variable-override]: the following instance variables are overridden by the class c :
476
477
x
477
-
The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
478
478
Line 4, characters 6-7:
479
479
4 | val y = 3
480
480
^
481
481
Warning 13 [instance-variable-override]: the instance variable y is overridden.
482
-
The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
483
-
Line 6, characters 10-13:
482
+
Line 6, characters 2-13:
484
483
6 | inherit d 7
485
-
^^^
484
+
^^^^^^^^^^^
486
485
Warning 13 [instance-variable-override]: the following instance variables are overridden by the class d :
487
486
t z
488
-
The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
489
487
Line 7, characters 6-7:
490
488
7 | val u = 3
491
489
^
492
490
Warning 13 [instance-variable-override]: the instance variable u is overridden.
493
-
The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
494
491
class e :
495
492
unit ->
496
493
object
···
923
920
Error: The ancestor variable super
924
921
cannot be accessed from the definition of an instance variable
925
922
|}];;
923
+
924
+
(* Some more tests of class idiosyncrasies *)
925
+
926
+
class c = object method private m = 3 end
927
+
and d = object method o = object inherit c end end;;
928
+
[%%expect {|
929
+
class c : object method private m : int end
930
+
and d : object method o : c end
931
+
|}];;
932
+
933
+
class c = object(_ : 'self)
934
+
method o = object(_ : 'self) method o = assert false end
935
+
end;;
936
+
[%%expect {|
937
+
Line 2, characters 13-58:
938
+
2 | method o = object(_ : 'self) method o = assert false end
939
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
940
+
Error: Cannot close type of object literal: < o : '_weak3; _.. >
941
+
it has been unified with the self type of a class that is not yet
942
+
completely defined.
943
+
|}];;
944
+
945
+
class c = object
946
+
method m = 1
947
+
inherit object (self)
948
+
method n = self#m
949
+
end
950
+
end;;
951
+
[%%expect {|
952
+
Line 4, characters 17-23:
953
+
4 | method n = self#m
954
+
^^^^^^
955
+
Warning 17 [undeclared-virtual-method]: the virtual method m is not declared.
956
+
class c : object method m : int method n : int end
957
+
|}];;
958
+
959
+
class [ 'a ] c = object (_ : 'a) end;;
960
+
let o = object
961
+
method m = 1
962
+
inherit [ < m : int > ] c
963
+
end;;
964
+
[%%expect {|
965
+
class ['a] c : object ('a) constraint 'a = < .. > end
966
+
Line 4, characters 14-25:
967
+
4 | inherit [ < m : int > ] c
968
+
^^^^^^^^^^^
969
+
Error: The type parameter < m : int >
970
+
does not meet its constraint: it should be < .. >
971
+
Self type cannot be unified with a closed object type
972
+
|}];;
973
+
974
+
class type [ 'a ] d = object method a : 'a method b : 'a end
975
+
class c : ['a] d = object (self) method a = 1 method b = assert false end;;
976
+
[%%expect {|
977
+
class type ['a] d = object method a : 'a method b : 'a end
978
+
Line 2, characters 19-73:
979
+
2 | class c : ['a] d = object (self) method a = 1 method b = assert false end;;
980
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
981
+
Error: The class type object method a : int method b : 'a end
982
+
is not matched by the class type ['_a] d
983
+
The class type object method a : int method b : 'a end
984
+
is not matched by the class type
985
+
object method a : 'a method b : 'a end
986
+
The method a has type int but is expected to have type 'a
987
+
Type int is not compatible with type 'a
988
+
|}];;
989
+
990
+
class type ['a] ct = object ('a) end
991
+
class c : [ < a : int; ..> ] ct = object method a = 3 end;;
992
+
[%%expect {|
993
+
class type ['a] ct = object ('a) constraint 'a = < .. > end
994
+
Line 2, characters 10-31:
995
+
2 | class c : [ < a : int; ..> ] ct = object method a = 3 end;;
996
+
^^^^^^^^^^^^^^^^^^^^^
997
+
Error: This non-virtual class has undeclared virtual methods.
998
+
The following methods were not declared : a
999
+
|}];;
1000
+
1001
+
class virtual c : [ < a : int; ..> ] ct = object method a = 3 end;;
1002
+
[%%expect {|
1003
+
class virtual c : object method virtual a : int end
1004
+
|}];;
1005
+
1006
+
class c : object
1007
+
method m : < m : 'a > as 'a
1008
+
end = object (self)
1009
+
method m = self
1010
+
end;;
1011
+
[%%expect {|
1012
+
Lines 3-5, characters 8-3:
1013
+
3 | ........object (self)
1014
+
4 | method m = self
1015
+
5 | end..
1016
+
Error: The class type object ('a) method m : 'a end
1017
+
is not matched by the class type
1018
+
object method m : < m : 'a > as 'a end
1019
+
The method m has type < m : 'a; .. > as 'a
1020
+
but is expected to have type < m : 'b > as 'b
1021
+
Type 'a is not compatible with type < > as 'b
1022
+
|}];;
1023
+
1024
+
class c :
1025
+
object
1026
+
method foo : < foo : int; .. > -> < foo : int> -> unit
1027
+
end =
1028
+
object
1029
+
method foo : 'a. (< foo : int; .. > as 'a) -> 'a -> unit = assert false
1030
+
end;;
1031
+
[%%expect {|
1032
+
Lines 5-7, characters 2-5:
1033
+
5 | ..object
1034
+
6 | method foo : 'a. (< foo : int; .. > as 'a) -> 'a -> unit = assert false
1035
+
7 | end..
1036
+
Error: The class type
1037
+
object method foo : (< foo : int; .. > as 'a) -> 'a -> unit end
1038
+
is not matched by the class type
1039
+
object method foo : < foo : int; .. > -> < foo : int > -> unit end
1040
+
The method foo has type 'a. (< foo : int; .. > as 'a) -> 'a -> unit
1041
+
but is expected to have type
1042
+
'b. (< foo : int; .. > as 'b) -> < foo : int > -> unit
1043
+
Type 'c is not compatible with type < >
1044
+
|}];;
1045
+
1046
+
1047
+
class c = (fun x -> object(_:'foo) end) 3;;
1048
+
[%%expect {|
1049
+
class c : object end
1050
+
|}];;
1051
+
1052
+
class virtual c =
1053
+
((fun (x : 'self -> unit) -> object(_:'self) end) (fun (_ : < a : int; .. >) -> ())
1054
+
: object method virtual a : int end)
1055
+
[%%expect {|
1056
+
class virtual c : object method virtual a : int end
1057
+
|}];;
1058
+
1059
+
class c = object
1060
+
val x = 3
1061
+
method o = {< x = 4; y = 5 >}
1062
+
val y = 4
1063
+
end;;
1064
+
[%%expect {|
1065
+
class c : object ('a) val x : int val y : int method o : 'a end
1066
+
|}];;
1067
+
1068
+
class c : object('self) method m : < m : 'a; x : int; ..> -> unit as 'a end =
1069
+
object (_ : 'self) method m (_ : 'self) = () end;;
1070
+
[%%expect {|
1071
+
Line 2, characters 4-52:
1072
+
2 | object (_ : 'self) method m (_ : 'self) = () end;;
1073
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1074
+
Error: The class type object ('a) method m : 'a -> unit end
1075
+
is not matched by the class type
1076
+
object method m : < m : 'a; x : int; .. > -> unit as 'a end
1077
+
The method m has type (< m : 'a -> unit; .. > as 'a) -> unit
1078
+
but is expected to have type
1079
+
'b. (< m : 'c; x : int; .. > as 'b) -> unit as 'c
1080
+
Type 'a is not compatible with type < x : int; .. >
1081
+
|}];;
1082
+
1083
+
let is_empty (x : < >) = ()
1084
+
class c = object (self) method private foo = is_empty self end;;
1085
+
[%%expect {|
1086
+
val is_empty : < > -> unit = <fun>
1087
+
Line 2, characters 54-58:
1088
+
2 | class c = object (self) method private foo = is_empty self end;;
1089
+
^^^^
1090
+
Error: This expression has type < .. > but an expression was expected of type
1091
+
< >
1092
+
Self type cannot be unified with a closed object type
1093
+
|}];;
1094
+
1095
+
(* Warnings about private methods implicitly made public *)
1096
+
let has_foo (x : < foo : 'a; .. >) = ()
1097
+
1098
+
class c = object (self) method private foo = 5 initializer has_foo self end;;
1099
+
[%%expect {|
1100
+
val has_foo : < foo : 'a; .. > -> unit = <fun>
1101
+
Line 3, characters 10-75:
1102
+
3 | class c = object (self) method private foo = 5 initializer has_foo self end;;
1103
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1104
+
Warning 15 [implicit-public-methods]: the following private methods were made public implicitly:
1105
+
foo.
1106
+
class c : object method foo : int end
1107
+
|}];;
1108
+
1109
+
class type c = object(< foo : 'a; ..>) method private foo : int end;;
1110
+
[%%expect {|
1111
+
class type c = object method foo : int end
1112
+
|}];;
1113
+
1114
+
class ['a] p = object (_ : 'a) method private foo = 5 end;;
1115
+
class c = [ < foo : int; .. > ] p;;
1116
+
[%%expect {|
1117
+
class ['a] p :
1118
+
object ('a) constraint 'a = < .. > method private foo : int end
1119
+
class c : object method foo : int end
1120
+
|}];;
1121
+
1122
+
(* Errors for undefined methods *)
1123
+
1124
+
class c = object method virtual foo : int end;;
1125
+
[%%expect {|
1126
+
Line 1, characters 10-45:
1127
+
1 | class c = object method virtual foo : int end;;
1128
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1129
+
Error: This non-virtual class has virtual methods.
1130
+
The following methods are virtual : foo
1131
+
|}];;
1132
+
1133
+
class type ct = object method virtual foo : int end;;
1134
+
[%%expect {|
1135
+
Line 1, characters 16-51:
1136
+
1 | class type ct = object method virtual foo : int end;;
1137
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1138
+
Error: This non-virtual class type has virtual methods.
1139
+
The following methods are virtual : foo
1140
+
|}];;
1141
+
1142
+
let o = object method virtual foo : int end;;
1143
+
[%%expect {|
1144
+
Line 1, characters 8-43:
1145
+
1 | let o = object method virtual foo : int end;;
1146
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1147
+
Error: This object has virtual methods.
1148
+
The following methods are virtual : foo
1149
+
|}];;
1150
+
1151
+
class c = object(self) initializer self#foo end;;
1152
+
[%%expect {|
1153
+
Line 1, characters 35-39:
1154
+
1 | class c = object(self) initializer self#foo end;;
1155
+
^^^^
1156
+
Error: This expression has no method foo
1157
+
|}];;
1158
+
1159
+
let o = object(self) initializer self#foo end;;
1160
+
[%%expect {|
1161
+
Line 1, characters 33-37:
1162
+
1 | let o = object(self) initializer self#foo end;;
1163
+
^^^^
1164
+
Error: This expression has no method foo
1165
+
|}];;
1166
+
1167
+
let has_foo (x : < foo : int; ..>) = ()
1168
+
class c = object(self) initializer has_foo self end;;
1169
+
[%%expect {|
1170
+
val has_foo : < foo : int; .. > -> unit = <fun>
1171
+
Line 2, characters 10-51:
1172
+
2 | class c = object(self) initializer has_foo self end;;
1173
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1174
+
Error: This non-virtual class has undeclared virtual methods.
1175
+
The following methods were not declared : foo
1176
+
|}];;
1177
+
1178
+
let o = object(self) initializer has_foo self end;;
1179
+
[%%expect {|
1180
+
Line 1, characters 41-45:
1181
+
1 | let o = object(self) initializer has_foo self end;;
1182
+
^^^^
1183
+
Error: This expression has type < > but an expression was expected of type
1184
+
< foo : int; .. >
1185
+
The first object type has no method foo
1186
+
|}];;
1187
+
1188
+
class c = object(_ : < foo : int; ..>) end;;
1189
+
[%%expect {|
1190
+
Line 1, characters 10-42:
1191
+
1 | class c = object(_ : < foo : int; ..>) end;;
1192
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1193
+
Error: This non-virtual class has undeclared virtual methods.
1194
+
The following methods were not declared : foo
1195
+
|}];;
1196
+
1197
+
class type ct = object(< foo : int; ..>) end;;
1198
+
[%%expect {|
1199
+
Line 1, characters 16-44:
1200
+
1 | class type ct = object(< foo : int; ..>) end;;
1201
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1202
+
Error: This non-virtual class type has undeclared virtual methods.
1203
+
The following methods were not declared : foo
1204
+
|}];;
1205
+
1206
+
let o = object(_ : < foo : int; ..>) end;;
1207
+
[%%expect {|
1208
+
Line 1, characters 8-40:
1209
+
1 | let o = object(_ : < foo : int; ..>) end;;
1210
+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1211
+
Error: This object has undeclared virtual methods.
1212
+
The following methods were not declared : foo
1213
+
|}];;
1214
+
1215
+
(* Shadowing/overriding methods in class types *)
1216
+
1217
+
class type c = object
1218
+
val x : int
1219
+
val x : float
1220
+
end;;
1221
+
[%%expect {|
1222
+
class type c = object val x : float end
1223
+
|}];;
1224
+
1225
+
class type c = object
1226
+
val x : int
1227
+
val mutable x : int
1228
+
end;;
1229
+
[%%expect {|
1230
+
class type c = object val mutable x : int end
1231
+
|}];;
1232
+
1233
+
class type c = object
1234
+
val mutable x : int
1235
+
val x : int
1236
+
end;;
1237
+
[%%expect {|
1238
+
class type c = object val x : int end
1239
+
|}];;
1240
+
1241
+
class type virtual c = object
1242
+
val virtual x : int
1243
+
val x : int
1244
+
end;;
1245
+
[%%expect {|
1246
+
class type c = object val x : int end
1247
+
|}];;
1248
+
1249
+
class type virtual c = object
1250
+
val x : int
1251
+
val virtual x : int
1252
+
end;;
1253
+
[%%expect {|
1254
+
class type c = object val x : int end
1255
+
|}];;
1256
+
1257
+
class type virtual c = object
1258
+
val x : int
1259
+
val virtual x : float
1260
+
end;;
1261
+
[%%expect {|
1262
+
class type c = object val x : float end
1263
+
|}];;
+151
-10
testsuite/tests/typing-objects/dummy.ml
+151
-10
testsuite/tests/typing-objects/dummy.ml
···
60
60
end
61
61
end;;
62
62
[%%expect{|
63
-
class foo1 : object method child : child2 method previous : child2 option end
63
+
class foo1 : object method child : child1 method previous : child1 option end
64
64
|}]
65
65
66
66
class nested = object
···
76
76
[%%expect{|
77
77
class nested :
78
78
object
79
-
method obj : < child : unit -> child2; previous : child2 option >
79
+
method obj : < child : unit -> child1; previous : child1 option >
80
80
end
81
81
|}]
82
82
···
93
93
end;;
94
94
[%%expect{|
95
95
class just_to_see :
96
-
object method child : child2 method previous : child2 option end
96
+
object method child : child1 method previous : child1 option end
97
97
|}]
98
98
99
99
class just_to_see2 = object
···
111
111
end;;
112
112
[%%expect{|
113
113
class just_to_see2 :
114
-
object method obj : < child : child2; previous : child2 option > end
114
+
object method obj : < child : child1; previous : child1 option > end
115
115
|}]
116
116
117
117
type gadt = Not_really_though : gadt
···
127
127
[%%expect{|
128
128
type gadt = Not_really_though : gadt
129
129
class just_to_see3 :
130
-
object method child : gadt -> child2 method previous : child2 option end
130
+
object method child : gadt -> child1 method previous : child1 option end
131
131
|}]
132
132
133
133
class leading_up_to = object(self : 'a)
···
144
144
5 | inherit child1 self
145
145
6 | inherit child2
146
146
7 | end
147
-
Error: Cannot close type of object literal:
148
-
< child : '_weak1; previous : 'a option; _.. > as 'a
149
-
it has been unified with the self type of a class that is not yet
150
-
completely defined.
147
+
Error: This object has undeclared virtual methods.
148
+
The following methods were not declared : previous child
151
149
|}]
152
150
153
151
class assertion_failure = object(self : 'a)
···
171
169
9 | method child = assert false
172
170
10 | end
173
171
Error: Cannot close type of object literal:
174
-
< child : '_weak2; previous : 'a option; _.. > as 'a
172
+
< child : '_weak1; previous : 'a option; _.. > as 'a
175
173
it has been unified with the self type of a class that is not yet
176
174
completely defined.
177
175
|}]
176
+
177
+
(* MPR#7894 and variations *)
178
+
class parameter_contains_self app = object(self)
179
+
method invalidate : unit =
180
+
app#redrawWidget self
181
+
end;;
182
+
[%%expect{|
183
+
class parameter_contains_self :
184
+
< redrawWidget : 'a -> unit; .. > ->
185
+
object ('a) method invalidate : unit end
186
+
|}]
187
+
188
+
class closes_via_inheritance param =
189
+
let _ = new parameter_contains_self param in object
190
+
inherit parameter_contains_self param
191
+
end;;
192
+
[%%expect{|
193
+
Line 3, characters 36-41:
194
+
3 | inherit parameter_contains_self param
195
+
^^^^^
196
+
Error: This expression has type
197
+
< redrawWidget : parameter_contains_self -> unit; .. >
198
+
but an expression was expected of type
199
+
< redrawWidget : (< invalidate : unit; .. > as 'a) -> unit; .. >
200
+
Type parameter_contains_self = < invalidate : unit >
201
+
is not compatible with type < invalidate : unit; .. > as 'a
202
+
Self type cannot be unified with a closed object type
203
+
|}]
204
+
205
+
class closes_via_application param =
206
+
let _ = new parameter_contains_self param in
207
+
parameter_contains_self param;;
208
+
[%%expect{|
209
+
Line 3, characters 26-31:
210
+
3 | parameter_contains_self param;;
211
+
^^^^^
212
+
Error: This expression has type
213
+
< redrawWidget : parameter_contains_self -> unit; .. >
214
+
but an expression was expected of type
215
+
< redrawWidget : (< invalidate : unit; .. > as 'a) -> unit; .. >
216
+
Type parameter_contains_self = < invalidate : unit >
217
+
is not compatible with type < invalidate : unit; .. > as 'a
218
+
Self type cannot be unified with a closed object type
219
+
|}]
220
+
221
+
let escapes_via_inheritance param =
222
+
let module Local = struct
223
+
class c = object
224
+
inherit parameter_contains_self param
225
+
end
226
+
end in
227
+
();;
228
+
[%%expect{|
229
+
Line 4, characters 38-43:
230
+
4 | inherit parameter_contains_self param
231
+
^^^^^
232
+
Error: This expression has type 'a but an expression was expected of type
233
+
< redrawWidget : < invalidate : unit; .. > -> unit; .. >
234
+
Self type cannot escape its class
235
+
|}]
236
+
237
+
let escapes_via_application param =
238
+
let module Local = struct
239
+
class c = parameter_contains_self param
240
+
end in
241
+
();;
242
+
[%%expect{|
243
+
Line 3, characters 38-43:
244
+
3 | class c = parameter_contains_self param
245
+
^^^^^
246
+
Error: This expression has type 'a but an expression was expected of type
247
+
< redrawWidget : < invalidate : unit; .. > -> unit; .. >
248
+
Self type cannot escape its class
249
+
|}]
250
+
251
+
let can_close_object_via_inheritance param =
252
+
let _ = new parameter_contains_self param in object
253
+
inherit parameter_contains_self param
254
+
end;;
255
+
[%%expect{|
256
+
Line 3, characters 36-41:
257
+
3 | inherit parameter_contains_self param
258
+
^^^^^
259
+
Error: This expression has type
260
+
< redrawWidget : parameter_contains_self -> unit; .. >
261
+
but an expression was expected of type
262
+
< redrawWidget : (< invalidate : unit; .. > as 'a) -> unit; .. >
263
+
Type parameter_contains_self = < invalidate : unit >
264
+
is not compatible with type < invalidate : unit; .. > as 'a
265
+
Self type cannot be unified with a closed object type
266
+
|}]
267
+
268
+
let can_escape_object_via_inheritance param = object
269
+
inherit parameter_contains_self param
270
+
end;;
271
+
[%%expect{|
272
+
val can_escape_object_via_inheritance :
273
+
< redrawWidget : parameter_contains_self -> unit; .. > ->
274
+
parameter_contains_self = <fun>
275
+
|}]
276
+
277
+
let can_close_object_explicitly = object (_ : < i : int >)
278
+
method i = 5
279
+
end;;
280
+
[%%expect{|
281
+
val can_close_object_explicitly : < i : int > = <obj>
282
+
|}]
283
+
284
+
let cannot_close_object_explicitly_with_inheritance = object
285
+
inherit object (_ : < i : int >)
286
+
method i = 5
287
+
end
288
+
end;;
289
+
[%%expect{|
290
+
Line 2, characters 17-34:
291
+
2 | inherit object (_ : < i : int >)
292
+
^^^^^^^^^^^^^^^^^
293
+
Error: This pattern cannot match self: it only matches values of type
294
+
< i : int >
295
+
|}]
296
+
297
+
class closes_after_constraint =
298
+
((fun (x : 'a) -> object (_:'a) end) : 'a -> object('a) end) (object end);;
299
+
[%%expect{|
300
+
Line 2, characters 63-75:
301
+
2 | ((fun (x : 'a) -> object (_:'a) end) : 'a -> object('a) end) (object end);;
302
+
^^^^^^^^^^^^
303
+
Error: This expression has type < > but an expression was expected of type
304
+
< .. >
305
+
Self type cannot be unified with a closed object type
306
+
|}];;
307
+
308
+
class type ['a] ct = object ('a) end
309
+
class type closes_via_application = [ <m : int> ] ct;;
310
+
[%%expect{|
311
+
class type ['a] ct = object ('a) constraint 'a = < .. > end
312
+
Line 2, characters 38-47:
313
+
2 | class type closes_via_application = [ <m : int> ] ct;;
314
+
^^^^^^^^^
315
+
Error: The type parameter < m : int >
316
+
does not meet its constraint: it should be < .. >
317
+
Self type cannot be unified with a closed object type
318
+
|}];;
+1
-2
testsuite/tests/typing-objects/errors.ml
+1
-2
testsuite/tests/typing-objects/errors.ml
+1
-2
testsuite/tests/typing-objects/pr6907_bad.ml
+1
-2
testsuite/tests/typing-objects/pr6907_bad.ml
+4
-5
testsuite/tests/typing-poly/poly.ml
+4
-5
testsuite/tests/typing-poly/poly.ml
···
1106
1106
Warning 15 [implicit-public-methods]: the following private methods were made public implicitly:
1107
1107
n.
1108
1108
val f : unit -> < m : int; n : int > = <fun>
1109
-
Line 5, characters 11-56:
1109
+
Line 5, characters 27-39:
1110
1110
5 | let f () = object (self:c) method n = 1 method m = 2 end;;
1111
-
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1112
-
Error: This object is expected to have type c but actually has type
1113
-
< m : int; n : 'a >
1114
-
The first object type has no method n
1111
+
^^^^^^^^^^^^
1112
+
Error: This object is expected to have type : c
1113
+
This type does not have a method n.
1115
1114
|}];;
1116
1115
1117
1116
+152
testsuite/tests/typing-warnings/disable_warnings_classes.ml
+152
testsuite/tests/typing-warnings/disable_warnings_classes.ml
···
1
+
(* TEST
2
+
flags = " -w +A "
3
+
* expect
4
+
*)
5
+
6
+
class c = object
7
+
8
+
val a =
9
+
let b = 5 in ()
10
+
[@@warning "-26"]
11
+
12
+
val x =
13
+
let y = 5 in ()
14
+
15
+
end;;
16
+
[%%expect {|
17
+
Line 8, characters 8-9:
18
+
8 | let y = 5 in ()
19
+
^
20
+
Warning 26 [unused-var]: unused variable y.
21
+
class c : object val a : unit val x : unit end
22
+
|}];;
23
+
24
+
class c = object
25
+
26
+
method a =
27
+
let b = 5 in ()
28
+
[@@warning "-26"]
29
+
30
+
method x =
31
+
let y = 5 in ()
32
+
33
+
end;;
34
+
[%%expect {|
35
+
Line 8, characters 8-9:
36
+
8 | let y = 5 in ()
37
+
^
38
+
Warning 26 [unused-var]: unused variable y.
39
+
class c : object method a : unit method x : unit end
40
+
|}];;
41
+
42
+
class c = object
43
+
44
+
initializer
45
+
let b = 5 in ()
46
+
[@@warning "-26"]
47
+
48
+
initializer
49
+
let y = 5 in ()
50
+
51
+
end;;
52
+
[%%expect {|
53
+
Line 8, characters 8-9:
54
+
8 | let y = 5 in ()
55
+
^
56
+
Warning 26 [unused-var]: unused variable y.
57
+
class c : object end
58
+
|}];;
59
+
60
+
class c = (object
61
+
62
+
val a =
63
+
let b = 5 in ()
64
+
65
+
end [@warning "-26"])
66
+
[%%expect {|
67
+
class c : object val a : unit end
68
+
|}];;
69
+
70
+
class c = object
71
+
72
+
val a =
73
+
let b = 5 in ()
74
+
75
+
[@@@warning "-26"]
76
+
77
+
val x =
78
+
let y = 5 in ()
79
+
80
+
end;;
81
+
[%%expect {|
82
+
Line 4, characters 8-9:
83
+
4 | let b = 5 in ()
84
+
^
85
+
Warning 26 [unused-var]: unused variable b.
86
+
class c : object val a : unit val x : unit end
87
+
|}];;
88
+
89
+
type dep
90
+
[@@deprecated "deprecated"]
91
+
92
+
class type c = object
93
+
94
+
val a : dep
95
+
[@@warning "-3"]
96
+
97
+
val x : dep
98
+
99
+
end;;
100
+
[%%expect {|
101
+
type dep
102
+
Line 9, characters 10-13:
103
+
9 | val x : dep
104
+
^^^
105
+
Alert deprecated: dep
106
+
deprecated
107
+
class type c = object val a : dep val x : dep end
108
+
|}];;
109
+
110
+
class type c = object
111
+
112
+
method a : dep
113
+
[@@warning "-3"]
114
+
115
+
method x : dep
116
+
117
+
end;;
118
+
[%%expect {|
119
+
Line 6, characters 13-16:
120
+
6 | method x : dep
121
+
^^^
122
+
Alert deprecated: dep
123
+
deprecated
124
+
class type c = object method a : dep method x : dep end
125
+
|}];;
126
+
127
+
class type c = object [@warning "-3"]
128
+
129
+
val a : dep
130
+
131
+
end
132
+
[%%expect {|
133
+
class type c = object val a : dep end
134
+
|}];;
135
+
136
+
class type c = object
137
+
138
+
val a : dep
139
+
140
+
[@@@warning "-3"]
141
+
142
+
val x : dep
143
+
144
+
end;;
145
+
[%%expect {|
146
+
Line 3, characters 10-13:
147
+
3 | val a : dep
148
+
^^^
149
+
Alert deprecated: dep
150
+
deprecated
151
+
class type c = object val a : dep val x : dep end
152
+
|}];;
+3
-1
tools/ci/actions/runner.sh
+3
-1
tools/ci/actions/runner.sh
···
46
46
;;
47
47
i386)
48
48
./configure --build=x86_64-pc-linux-gnu --host=i386-linux \
49
-
CC='gcc -m32' AS='as --32' ASPP='gcc -m32 -c' \
49
+
CC='gcc -m32 -march=x86-64' \
50
+
AS='as --32' \
51
+
ASPP='gcc -m32 -march=x86-64 -c' \
50
52
PARTIALLD='ld -r -melf_i386' \
51
53
$configure_flags
52
54
;;
+14
tools/ci/inria/main
+14
tools/ci/inria/main
···
58
58
}
59
59
60
60
#########################################################################
61
+
# Display environment information
62
+
uname -a
63
+
for i in issue redhat-release ; do
64
+
if test -e /etc/$i ; then
65
+
echo "/etc/$i content:"
66
+
cat /etc/$i | sed -e 's/^/| /'
67
+
fi
68
+
done
69
+
if command -v gcc >/dev/null ; then
70
+
echo "gcc info:"
71
+
gcc --version --verbose 2>&1 | sed -e 's/^/| /'
72
+
fi
73
+
74
+
#########################################################################
61
75
# be verbose
62
76
set -x
63
77
+116
-4
typing/btype.ml
+116
-4
typing/btype.ml
···
411
411
it.it_class_type it cty
412
412
| Cty_signature cs ->
413
413
it.it_type_expr it cs.csig_self;
414
+
it.it_type_expr it cs.csig_self_row;
414
415
Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars;
415
-
List.iter
416
-
(fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl)
417
-
cs.csig_inher
416
+
Meths.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_meths
418
417
| Cty_arrow (_, ty, cty) ->
419
418
it.it_type_expr it ty;
420
419
it.it_class_type it cty
···
639
638
640
639
let extract_label l ls = extract_label_aux [] l ls
641
640
641
+
(*******************************)
642
+
(* Operations on class types *)
643
+
(*******************************)
644
+
645
+
let rec signature_of_class_type =
646
+
function
647
+
Cty_constr (_, _, cty) -> signature_of_class_type cty
648
+
| Cty_signature sign -> sign
649
+
| Cty_arrow (_, _, cty) -> signature_of_class_type cty
650
+
651
+
let rec class_body cty =
652
+
match cty with
653
+
Cty_constr _ ->
654
+
cty (* Only class bodies can be abbreviated *)
655
+
| Cty_signature _ ->
656
+
cty
657
+
| Cty_arrow (_, _, cty) ->
658
+
class_body cty
659
+
660
+
(* Fully expand the head of a class type *)
661
+
let rec scrape_class_type =
662
+
function
663
+
Cty_constr (_, _, cty) -> scrape_class_type cty
664
+
| cty -> cty
665
+
666
+
let rec class_type_arity =
667
+
function
668
+
Cty_constr (_, _, cty) -> class_type_arity cty
669
+
| Cty_signature _ -> 0
670
+
| Cty_arrow (_, _, cty) -> 1 + class_type_arity cty
671
+
672
+
let rec abbreviate_class_type path params cty =
673
+
match cty with
674
+
Cty_constr (_, _, _) | Cty_signature _ ->
675
+
Cty_constr (path, params, cty)
676
+
| Cty_arrow (l, ty, cty) ->
677
+
Cty_arrow (l, ty, abbreviate_class_type path params cty)
678
+
679
+
let self_type cty =
680
+
(signature_of_class_type cty).csig_self
681
+
682
+
let self_type_row cty =
683
+
(signature_of_class_type cty).csig_self_row
684
+
685
+
(* Return the methods of a class signature *)
686
+
let methods sign =
687
+
Meths.fold
688
+
(fun name _ l -> name :: l)
689
+
sign.csig_meths []
690
+
691
+
(* Return the virtual methods of a class signature *)
692
+
let virtual_methods sign =
693
+
Meths.fold
694
+
(fun name (_priv, vr, _ty) l ->
695
+
match vr with
696
+
| Virtual -> name :: l
697
+
| Concrete -> l)
698
+
sign.csig_meths []
699
+
700
+
(* Return the concrete methods of a class signature *)
701
+
let concrete_methods sign =
702
+
Meths.fold
703
+
(fun name (_priv, vr, _ty) s ->
704
+
match vr with
705
+
| Virtual -> s
706
+
| Concrete -> MethSet.add name s)
707
+
sign.csig_meths MethSet.empty
708
+
709
+
(* Return the public methods of a class signature *)
710
+
let public_methods sign =
711
+
Meths.fold
712
+
(fun name (priv, _vr, _ty) l ->
713
+
match priv with
714
+
| Private -> l
715
+
| Public -> name :: l)
716
+
sign.csig_meths []
717
+
718
+
(* Return the instance variables of a class signature *)
719
+
let instance_vars sign =
720
+
Vars.fold
721
+
(fun name _ l -> name :: l)
722
+
sign.csig_vars []
723
+
724
+
(* Return the virtual instance variables of a class signature *)
725
+
let virtual_instance_vars sign =
726
+
Vars.fold
727
+
(fun name (_mut, vr, _ty) l ->
728
+
match vr with
729
+
| Virtual -> name :: l
730
+
| Concrete -> l)
731
+
sign.csig_vars []
732
+
733
+
(* Return the concrete instance variables of a class signature *)
734
+
let concrete_instance_vars sign =
735
+
Vars.fold
736
+
(fun name (_mut, vr, _ty) s ->
737
+
match vr with
738
+
| Virtual -> s
739
+
| Concrete -> VarSet.add name s)
740
+
sign.csig_vars VarSet.empty
741
+
742
+
let method_type label sign =
743
+
match Meths.find label sign.csig_meths with
744
+
| (_, _, ty) -> ty
745
+
| exception Not_found -> assert false
746
+
747
+
let instance_variable_type label sign =
748
+
match Vars.find label sign.csig_vars with
749
+
| (_, _, ty) -> ty
750
+
| exception Not_found -> assert false
751
+
642
752
(**********************************)
643
753
(* Utilities for level-marking *)
644
754
(**********************************)
···
693
803
694
804
let unmark_class_signature sign =
695
805
unmark_type sign.csig_self;
696
-
Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
806
+
unmark_type sign.csig_self_row;
807
+
Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars;
808
+
Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths
697
809
698
810
let unmark_class_type cty =
699
811
unmark_iterators.it_class_type unmark_iterators cty
+53
typing/btype.mli
+53
typing/btype.mli
···
269
269
whether (label, value) was at the head of the list,
270
270
list without the extracted (label, value) *)
271
271
272
+
(**** Utilities for class types ****)
273
+
274
+
(* Get the class signature within a class type *)
275
+
val signature_of_class_type : class_type -> class_signature
276
+
277
+
(* Get the body of a class type (i.e. without parameters) *)
278
+
val class_body : class_type -> class_type
279
+
280
+
(* Fully expand the head of a class type *)
281
+
val scrape_class_type : class_type -> class_type
282
+
283
+
(* Return the number of parameters of a class type *)
284
+
val class_type_arity : class_type -> int
285
+
286
+
(* Given a path and type parameters, add an abbreviation to a class type *)
287
+
val abbreviate_class_type :
288
+
Path.t -> type_expr list -> class_type -> class_type
289
+
290
+
(* Get the self type of a class *)
291
+
val self_type : class_type -> type_expr
292
+
293
+
(* Get the row variable of the self type of a class *)
294
+
val self_type_row : class_type -> type_expr
295
+
296
+
(* Return the methods of a class signature *)
297
+
val methods : class_signature -> string list
298
+
299
+
(* Return the virtual methods of a class signature *)
300
+
val virtual_methods : class_signature -> string list
301
+
302
+
(* Return the concrete methods of a class signature *)
303
+
val concrete_methods : class_signature -> MethSet.t
304
+
305
+
(* Return the public methods of a class signature *)
306
+
val public_methods : class_signature -> string list
307
+
308
+
(* Return the instance variables of a class signature *)
309
+
val instance_vars : class_signature -> string list
310
+
311
+
(* Return the virtual instance variables of a class signature *)
312
+
val virtual_instance_vars : class_signature -> string list
313
+
314
+
(* Return the concrete instance variables of a class signature *)
315
+
val concrete_instance_vars : class_signature -> VarSet.t
316
+
317
+
(* Return the type of a method.
318
+
@raises [Assert_failure] if the class has no such method. *)
319
+
val method_type : label -> class_signature -> type_expr
320
+
321
+
(* Return the type of an instance variable.
322
+
@raises [Assert_failure] if the class has no such method. *)
323
+
val instance_variable_type : label -> class_signature -> type_expr
324
+
272
325
(**** Forward declarations ****)
273
326
val print_raw: (Format.formatter -> type_expr -> unit) ref
274
327
+559
-411
typing/ctype.ml
+559
-411
typing/ctype.ml
···
232
232
(* Re-export generic type creators *)
233
233
234
234
let newty desc = newty2 ~level:!current_level desc
235
+
let new_scoped_ty scope desc = newty3 ~level:!current_level ~scope desc
235
236
236
237
let newvar ?name () = newty2 ~level:!current_level (Tvar name)
237
238
let newvar2 ?name level = newty2 ~level:level (Tvar name)
···
337
338
in
338
339
associate [] [] [] (fields1, fields2)
339
340
340
-
let rec has_dummy_method ty =
341
-
match get_desc ty with
342
-
Tfield (m, _, _, ty2) ->
343
-
m = dummy_method || has_dummy_method ty2
344
-
| _ -> false
345
-
346
-
let is_self_type = function
347
-
| Tobject (ty, _) -> has_dummy_method ty
348
-
| _ -> false
349
-
350
341
(**** Check whether an object is open ****)
351
342
352
343
(* +++ The abbreviation should eventually be expanded *)
···
366
357
| Tvar _ -> false
367
358
| _ -> true
368
359
369
-
(**** Close an object ****)
370
-
371
-
let close_object ty =
372
-
let rec close ty =
373
-
match get_desc ty with
374
-
Tvar _ ->
375
-
link_type ty (newty2 ~level:(get_level ty) Tnil); true
376
-
| Tfield(lab, _, _, _) when lab = dummy_method ->
377
-
false
378
-
| Tfield(_, _, _, ty') -> close ty'
379
-
| _ -> assert false
380
-
in
381
-
match get_desc ty with
382
-
Tobject (ty, _) -> close ty
383
-
| _ -> assert false
384
-
385
360
(**** Row variable of an object type ****)
386
361
387
-
let row_variable ty =
388
-
let rec find ty =
389
-
match get_desc ty with
390
-
Tfield (_, _, _, ty) -> find ty
391
-
| Tvar _ -> ty
392
-
| _ -> assert false
393
-
in
362
+
let rec fields_row_variable ty =
394
363
match get_desc ty with
395
-
Tobject (fi, _) -> find fi
396
-
| _ -> assert false
364
+
| Tfield (_, _, _, ty) -> fields_row_variable ty
365
+
| Tvar _ -> ty
366
+
| _ -> assert false
397
367
398
368
(**** Object name manipulation ****)
399
369
(* +++ Bientot obsolete *)
400
370
401
-
let set_object_name id rv params ty =
371
+
let set_object_name id params ty =
402
372
match get_desc ty with
403
-
Tobject (_fi, nm) ->
373
+
| Tobject (fi, nm) ->
374
+
let rv = fields_row_variable fi in
404
375
set_name nm (Some (Path.Pident id, rv::params))
405
-
| _ ->
406
-
assert false
376
+
| Tconstr (_, _, _) -> ()
377
+
| _ -> fatal_error "Ctype.set_object_name"
407
378
408
379
let remove_object_name ty =
409
380
match get_desc ty with
···
411
382
| Tconstr (_, _, _) -> ()
412
383
| _ -> fatal_error "Ctype.remove_object_name"
413
384
414
-
(**** Hiding of private methods ****)
415
-
416
-
let hide_private_methods ty =
417
-
match get_desc ty with
418
-
Tobject (fi, nm) ->
419
-
nm := None;
420
-
let (fl, _) = flatten_fields fi in
421
-
List.iter
422
-
(function (_, k, _) ->
423
-
match field_kind_repr k with
424
-
Fvar r -> set_kind r Fabsent
425
-
| _ -> ())
426
-
fl
427
-
| _ ->
428
-
assert false
429
-
430
-
431
-
(*******************************)
432
-
(* Operations on class types *)
433
-
(*******************************)
434
-
435
-
436
-
let rec signature_of_class_type =
437
-
function
438
-
Cty_constr (_, _, cty) -> signature_of_class_type cty
439
-
| Cty_signature sign -> sign
440
-
| Cty_arrow (_, _, cty) -> signature_of_class_type cty
441
-
442
-
let self_type cty =
443
-
(signature_of_class_type cty).csig_self
444
-
445
-
let rec class_type_arity =
446
-
function
447
-
Cty_constr (_, _, cty) -> class_type_arity cty
448
-
| Cty_signature _ -> 0
449
-
| Cty_arrow (_, _, cty) -> 1 + class_type_arity cty
450
-
451
-
452
385
(*******************************************)
453
386
(* Miscellaneous operations on row types *)
454
387
(*******************************************)
···
609
542
unmark_extension_constructor ext;
610
543
Some ty
611
544
612
-
type closed_class_failure =
613
-
CC_Method of type_expr * bool * string * type_expr
614
-
| CC_Value of type_expr * bool * string * type_expr
615
-
616
-
exception CCFailure of closed_class_failure
545
+
exception CCFailure of (type_expr * bool * string * type_expr)
617
546
618
547
let closed_class params sign =
619
-
let ty = object_fields sign.csig_self in
620
-
let (fields, rest) = flatten_fields ty in
621
548
List.iter mark_type params;
622
-
mark_type rest;
623
-
List.iter
624
-
(fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
625
-
fields;
549
+
ignore (try_mark_node sign.csig_self_row);
626
550
try
627
-
ignore (try_mark_node sign.csig_self);
628
-
List.iter
629
-
(fun (lab, kind, ty) ->
630
-
if field_kind_repr kind = Fpresent then
631
-
try closed_type ty with Non_closed (ty0, real) ->
632
-
raise (CCFailure (CC_Method (ty0, real, lab, ty))))
633
-
fields;
634
-
mark_type_params sign.csig_self;
551
+
Meths.iter
552
+
(fun lab (priv, _, ty) ->
553
+
if priv = Public then begin
554
+
try closed_type ty with Non_closed (ty0, real) ->
555
+
raise (CCFailure (ty0, real, lab, ty))
556
+
end)
557
+
sign.csig_meths;
635
558
List.iter unmark_type params;
636
559
unmark_class_signature sign;
637
560
None
638
561
with CCFailure reason ->
639
-
mark_type_params sign.csig_self;
640
562
List.iter unmark_type params;
641
563
unmark_class_signature sign;
642
564
Some reason
···
857
779
end;
858
780
set_level ty level;
859
781
iter_type_expr (update_level env level expand) ty
860
-
| Tfield (lab, _, ty1, _)
861
-
when lab = dummy_method && get_level ty1 > level ->
782
+
| Tfield(lab, _, ty1, _)
783
+
when lab = dummy_method && level < get_scope ty1 ->
862
784
raise_escape_exn Self
863
785
| _ ->
864
786
set_level ty level;
···
936
858
simple_abbrevs := Mnil;
937
859
lower_contravariant env !nongen_level (Hashtbl.create 7) false ty
938
860
939
-
(* Generalize a class type *)
940
-
let rec generalize_class_type gen =
861
+
let rec generalize_class_type' gen =
941
862
function
942
863
Cty_constr (_, params, cty) ->
943
864
List.iter gen params;
944
-
generalize_class_type gen cty
945
-
| Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
946
-
gen sty;
947
-
Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
948
-
List.iter (fun (_,tl) -> List.iter gen tl) inher
865
+
generalize_class_type' gen cty
866
+
| Cty_signature csig ->
867
+
gen csig.csig_self;
868
+
gen csig.csig_self_row;
869
+
Vars.iter (fun _ (_, _, ty) -> gen ty) csig.csig_vars;
870
+
Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths
949
871
| Cty_arrow (_, ty, cty) ->
950
872
gen ty;
951
-
generalize_class_type gen cty
873
+
generalize_class_type' gen cty
874
+
875
+
let generalize_class_type cty =
876
+
generalize_class_type' generalize cty
952
877
953
-
let generalize_class_type vars =
954
-
let gen = if vars then generalize else generalize_structure in
955
-
generalize_class_type gen
878
+
let generalize_class_type_structure cty =
879
+
generalize_class_type' generalize_structure cty
956
880
957
881
(* Correct the levels of type [ty]. *)
958
882
let correct_levels ty =
···
1003
927
if get_level ty <> generic_level then set_level ty !current_level)
1004
928
graph
1005
929
930
+
let limited_generalize_class_type rv cty =
931
+
generalize_class_type' (limited_generalize rv) cty
1006
932
1007
933
(* Compute statically the free univars of all nodes in a type *)
1008
934
(* This avoids doing it repeatedly during instantiation *)
···
1355
1281
| Cty_signature sign ->
1356
1282
Cty_signature
1357
1283
{csig_self = copy scope sign.csig_self;
1284
+
csig_self_row = copy scope sign.csig_self_row;
1358
1285
csig_vars =
1359
-
Vars.map (function (m, v, ty) -> (m, v, copy scope ty))
1286
+
Vars.map
1287
+
(function (m, v, ty) -> (m, v, copy scope ty))
1360
1288
sign.csig_vars;
1361
-
csig_concr = sign.csig_concr;
1362
-
csig_inher =
1363
-
List.map (fun (p,tl) -> (p, List.map (copy scope) tl))
1364
-
sign.csig_inher}
1289
+
csig_meths =
1290
+
Meths.map
1291
+
(function (p, v, ty) -> (p, v, copy scope ty))
1292
+
sign.csig_meths}
1365
1293
| Cty_arrow (l, ty, cty) ->
1366
1294
Cty_arrow (l, copy scope ty, copy_class_type scope cty)
1367
1295
in
···
2779
2707
begin match !umode with
2780
2708
| Expression ->
2781
2709
occur_for Unify !env t1' t2';
2782
-
if is_self_type d1 (* PR#7711: do not abbreviate self type *)
2783
-
then link_type t1' t2'
2784
-
else link_type t1' t2
2710
+
link_type t1' t2
2785
2711
| Pattern ->
2786
2712
add_type_equality t1' t2'
2787
2713
end;
···
3316
3242
exception Filter_method_failed of filter_method_failure
3317
3243
3318
3244
(* Used by [filter_method]. *)
3319
-
let rec filter_method_field env name priv ty =
3320
-
let method_type level =
3245
+
let rec filter_method_field env name ty =
3246
+
let method_type ~level =
3321
3247
let ty1 = newvar2 level and ty2 = newvar2 level in
3322
-
let ty' = newty2 ~level (Tfield (name,
3323
-
begin match priv with
3324
-
Private -> Fvar (ref None)
3325
-
| Public -> Fpresent
3326
-
end,
3327
-
ty1, ty2))
3328
-
in
3248
+
let ty' = newty2 ~level (Tfield (name, Fpresent, ty1, ty2)) in
3329
3249
ty', ty1
3330
3250
in
3331
3251
let ty =
3332
3252
try expand_head_trace env ty
3333
3253
with Unify_trace trace ->
3334
-
let ty', _ = method_type (get_level ty) in
3254
+
let level = get_level ty in
3255
+
let ty', _ = method_type ~level in
3335
3256
raise (Filter_method_failed
3336
3257
(Unification_error
3337
3258
(expand_to_unification_error
···
3340
3261
in
3341
3262
match get_desc ty with
3342
3263
| Tvar _ ->
3343
-
let ty', ty1 = method_type (get_level ty) in
3264
+
let level = get_level ty in
3265
+
let ty', ty1 = method_type ~level in
3344
3266
link_type ty ty';
3345
3267
ty1
3346
3268
| Tfield(n, kind, ty1, ty2) ->
3347
3269
let kind = field_kind_repr kind in
3348
3270
if (n = name) && (kind <> Fabsent) then begin
3349
-
if priv = Public then
3350
-
unify_kind kind Fpresent;
3271
+
unify_kind kind Fpresent;
3351
3272
ty1
3352
3273
end else
3353
-
filter_method_field env name priv ty2
3274
+
filter_method_field env name ty2
3354
3275
| _ ->
3355
3276
raise (Filter_method_failed Not_a_method)
3356
3277
3357
3278
(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
3358
-
let filter_method env name priv ty =
3279
+
let filter_method env name ty =
3359
3280
let object_type ~level ~scope =
3360
-
let ty1 = newvar () in
3361
-
let ty' = newobj ty1 in
3362
-
update_level_for Unify env level ty';
3363
-
update_scope_for Unify scope ty';
3364
-
let ty_meth = filter_method_field env name priv ty1 in
3281
+
let ty1 = newvar2 level in
3282
+
let ty' = newty3 ~level ~scope (Tobject (ty1, ref None)) in
3283
+
let ty_meth = filter_method_field env name ty1 in
3365
3284
(ty', ty_meth)
3366
3285
in
3367
3286
let ty =
3368
3287
try expand_head_trace env ty
3369
3288
with Unify_trace trace ->
3370
-
let ty', _ = object_type ~level:(get_level ty) ~scope:(get_scope ty) in
3289
+
let level = get_level ty in
3290
+
let scope = get_scope ty in
3291
+
let ty', _ = object_type ~level ~scope in
3371
3292
raise (Filter_method_failed
3372
3293
(Unification_error
3373
3294
(expand_to_unification_error
···
3376
3297
in
3377
3298
match get_desc ty with
3378
3299
| Tvar _ ->
3379
-
let ty', ty_meth =
3380
-
object_type ~level:(get_level ty) ~scope:(get_scope ty) in
3300
+
let level = get_level ty in
3301
+
let scope = get_scope ty in
3302
+
let ty', ty_meth = object_type ~level ~scope in
3381
3303
link_type ty ty';
3382
3304
ty_meth
3383
3305
| Tobject(f, _) ->
3384
-
filter_method_field env name priv f
3306
+
filter_method_field env name f
3385
3307
| _ ->
3386
3308
raise (Filter_method_failed (Not_an_object ty))
3387
3309
3388
-
let check_filter_method env name priv ty =
3389
-
ignore(filter_method env name priv ty)
3310
+
exception Filter_method_row_failed
3311
+
3312
+
let rec filter_method_row env name priv ty =
3313
+
let ty = expand_head env ty in
3314
+
match get_desc ty with
3315
+
| Tvar _ ->
3316
+
let level = get_level ty in
3317
+
let field = newvar2 level in
3318
+
let row = newvar2 level in
3319
+
let kind =
3320
+
match priv with
3321
+
| Private -> Fvar (ref None)
3322
+
| Public -> Fpresent
3323
+
in
3324
+
let ty' = newty2 ~level (Tfield (name, kind, field, row)) in
3325
+
link_type ty ty';
3326
+
field, row
3327
+
| Tfield(n, kind, ty1, ty2) ->
3328
+
let kind = field_kind_repr kind in
3329
+
if (n = name) && (kind <> Fabsent) then begin
3330
+
if priv = Public then
3331
+
unify_kind kind Fpresent;
3332
+
ty1, ty2
3333
+
end else begin
3334
+
let level = get_level ty in
3335
+
let field, row = filter_method_row env name priv ty2 in
3336
+
let row = newty2 ~level (Tfield (n, kind, ty1, row)) in
3337
+
field, row
3338
+
end
3339
+
| Tnil ->
3340
+
if name = Btype.dummy_method then raise Filter_method_row_failed
3341
+
else begin
3342
+
match priv with
3343
+
| Public -> raise Filter_method_row_failed
3344
+
| Private ->
3345
+
let level = get_level ty in
3346
+
newvar2 level, ty
3347
+
end
3348
+
| _ ->
3349
+
raise Filter_method_row_failed
3350
+
3351
+
(* Operations on class signatures *)
3352
+
3353
+
let new_class_signature () =
3354
+
let row = newvar () in
3355
+
let self = newobj row in
3356
+
{ csig_self = self;
3357
+
csig_self_row = row;
3358
+
csig_vars = Vars.empty;
3359
+
csig_meths = Meths.empty; }
3360
+
3361
+
let add_dummy_method env ~scope sign =
3362
+
let ty, row =
3363
+
filter_method_row env dummy_method Private sign.csig_self_row
3364
+
in
3365
+
unify env ty (new_scoped_ty scope (Ttuple []));
3366
+
sign.csig_self_row <- row
3367
+
3368
+
type add_method_failure =
3369
+
| Unexpected_method
3370
+
| Type_mismatch of Errortrace.unification_error
3371
+
3372
+
exception Add_method_failed of add_method_failure
3373
+
3374
+
let add_method env label priv virt ty sign =
3375
+
let meths = sign.csig_meths in
3376
+
let priv, virt =
3377
+
match Meths.find label meths with
3378
+
| (priv', virt', ty') -> begin
3379
+
let priv =
3380
+
match priv' with
3381
+
| Public -> Public
3382
+
| Private -> priv
3383
+
in
3384
+
let virt =
3385
+
match virt' with
3386
+
| Concrete -> Concrete
3387
+
| Virtual -> virt
3388
+
in
3389
+
match unify env ty ty' with
3390
+
| () -> priv, virt
3391
+
| exception Unify trace ->
3392
+
raise (Add_method_failed (Type_mismatch trace))
3393
+
end
3394
+
| exception Not_found -> begin
3395
+
let ty', row =
3396
+
match filter_method_row env label priv sign.csig_self_row with
3397
+
| ty', row ->
3398
+
ty', row
3399
+
| exception Filter_method_row_failed ->
3400
+
raise (Add_method_failed Unexpected_method)
3401
+
in
3402
+
match unify env ty ty' with
3403
+
| () ->
3404
+
sign.csig_self_row <- row;
3405
+
priv, virt
3406
+
| exception Unify trace ->
3407
+
raise (Add_method_failed (Type_mismatch trace))
3408
+
end
3409
+
in
3410
+
let meths = Meths.add label (priv, virt, ty) meths in
3411
+
sign.csig_meths <- meths
3412
+
3413
+
type add_instance_variable_failure =
3414
+
| Mutability_mismatch of mutable_flag
3415
+
| Type_mismatch of Errortrace.unification_error
3416
+
3417
+
exception Add_instance_variable_failed of add_instance_variable_failure
3418
+
3419
+
let check_mutability mut mut' =
3420
+
match mut, mut' with
3421
+
| Mutable, Mutable -> ()
3422
+
| Immutable, Immutable -> ()
3423
+
| Mutable, Immutable | Immutable, Mutable ->
3424
+
raise (Add_instance_variable_failed (Mutability_mismatch mut))
3390
3425
3391
-
let filter_self_method env lab priv meths ty =
3392
-
let ty' = filter_method env lab priv ty in
3393
-
try
3394
-
Meths.find lab !meths
3395
-
with Not_found ->
3396
-
let pair = (Ident.create_local lab, ty') in
3397
-
meths := Meths.add lab pair !meths;
3398
-
pair
3426
+
let add_instance_variable ~strict env label mut virt ty sign =
3427
+
let vars = sign.csig_vars in
3428
+
let virt =
3429
+
match Vars.find label vars with
3430
+
| (mut', virt', ty') ->
3431
+
let virt =
3432
+
match virt' with
3433
+
| Concrete -> Concrete
3434
+
| Virtual -> virt
3435
+
in
3436
+
if strict then begin
3437
+
check_mutability mut mut';
3438
+
match unify env ty ty' with
3439
+
| () -> ()
3440
+
| exception Unify trace ->
3441
+
raise (Add_instance_variable_failed (Type_mismatch trace))
3442
+
end;
3443
+
virt
3444
+
| exception Not_found -> virt
3445
+
in
3446
+
let vars = Vars.add label (mut, virt, ty) vars in
3447
+
sign.csig_vars <- vars
3448
+
3449
+
type inherit_class_signature_failure =
3450
+
| Self_type_mismatch of Errortrace.unification_error
3451
+
| Method of label * add_method_failure
3452
+
| Instance_variable of label * add_instance_variable_failure
3453
+
3454
+
exception Inherit_class_signature_failed of inherit_class_signature_failure
3399
3455
3456
+
let unify_self_types env sign1 sign2 =
3457
+
let self_type1 = sign1.csig_self in
3458
+
let self_type2 = sign2.csig_self in
3459
+
match unify env self_type1 self_type2 with
3460
+
| () -> ()
3461
+
| exception Unify err -> begin
3462
+
match err.trace with
3463
+
| Errortrace.Diff _ :: Errortrace.Incompatible_fields {name; _} :: rem ->
3464
+
let err = Errortrace.unification_error ~trace:rem in
3465
+
let failure = Method (name, Type_mismatch err) in
3466
+
raise (Inherit_class_signature_failed failure)
3467
+
| _ ->
3468
+
raise (Inherit_class_signature_failed (Self_type_mismatch err))
3469
+
end
3470
+
3471
+
(* Unify components of sign2 into sign1 *)
3472
+
let inherit_class_signature ~strict env sign1 sign2 =
3473
+
unify_self_types env sign1 sign2;
3474
+
Meths.iter
3475
+
(fun label (priv, virt, ty) ->
3476
+
match add_method env label priv virt ty sign1 with
3477
+
| () -> ()
3478
+
| exception Add_method_failed failure ->
3479
+
let failure = Method(label, failure) in
3480
+
raise (Inherit_class_signature_failed failure))
3481
+
sign2.csig_meths;
3482
+
Vars.iter
3483
+
(fun label (mut, virt, ty) ->
3484
+
match add_instance_variable ~strict env label mut virt ty sign1 with
3485
+
| () -> ()
3486
+
| exception Add_instance_variable_failed failure ->
3487
+
let failure = Instance_variable(label, failure) in
3488
+
raise (Inherit_class_signature_failed failure))
3489
+
sign2.csig_vars
3490
+
3491
+
let update_class_signature env sign =
3492
+
let self = expand_head env sign.Types.csig_self in
3493
+
let fields, row = flatten_fields (object_fields self) in
3494
+
let meths, implicitly_public, implicitly_declared =
3495
+
List.fold_left
3496
+
(fun (meths, implicitly_public, implicitly_declared) (lab, k, ty) ->
3497
+
if lab = dummy_method then
3498
+
meths, implicitly_public, implicitly_declared
3499
+
else begin
3500
+
match Meths.find lab meths with
3501
+
| priv, virt, ty' ->
3502
+
let meths, implicitly_public =
3503
+
match priv, field_kind_repr k with
3504
+
| Public, _ -> meths, implicitly_public
3505
+
| Private, Fpresent ->
3506
+
let meths = Meths.add lab (Public, virt, ty') meths in
3507
+
let implicitly_public = lab :: implicitly_public in
3508
+
meths, implicitly_public
3509
+
| Private, _ -> meths, implicitly_public
3510
+
in
3511
+
meths, implicitly_public, implicitly_declared
3512
+
| exception Not_found ->
3513
+
let meths, implicitly_declared =
3514
+
match field_kind_repr k with
3515
+
| Fpresent ->
3516
+
let meths = Meths.add lab (Public, Virtual, ty) meths in
3517
+
let implicitly_declared = lab :: implicitly_declared in
3518
+
meths, implicitly_declared
3519
+
| Fvar _ ->
3520
+
let meths = Meths.add lab (Private, Virtual, ty) meths in
3521
+
let implicitly_declared = lab :: implicitly_declared in
3522
+
meths, implicitly_declared
3523
+
| Fabsent -> meths, implicitly_declared
3524
+
in
3525
+
meths, implicitly_public, implicitly_declared
3526
+
end)
3527
+
(sign.csig_meths, [], []) fields
3528
+
in
3529
+
sign.csig_meths <- meths;
3530
+
sign.csig_self_row <- row;
3531
+
implicitly_public, implicitly_declared
3532
+
3533
+
let hide_private_methods env sign =
3534
+
let self = expand_head env sign.Types.csig_self in
3535
+
let fields, _ = flatten_fields (object_fields self) in
3536
+
List.iter
3537
+
(fun (_, k, _) ->
3538
+
match field_kind_repr k with
3539
+
| Fvar r -> set_kind r Fabsent
3540
+
| _ -> ())
3541
+
fields
3542
+
3543
+
let close_class_signature env sign =
3544
+
let rec close env ty =
3545
+
let ty = expand_head env ty in
3546
+
match get_desc ty with
3547
+
| Tvar _ ->
3548
+
let level = get_level ty in
3549
+
link_type ty (newty2 ~level Tnil); true
3550
+
| Tfield(lab, _, _, _) when lab = dummy_method ->
3551
+
false
3552
+
| Tfield(_, _, _, ty') -> close env ty'
3553
+
| Tnil -> true
3554
+
| _ -> assert false
3555
+
in
3556
+
let self = expand_head env sign.csig_self in
3557
+
close env (object_fields self)
3558
+
3559
+
let generalize_class_signature_spine env sign =
3560
+
(* Generalize the spine of methods *)
3561
+
let meths = sign.csig_meths in
3562
+
Meths.iter (fun _ (_, _, ty) -> generalize_spine ty) meths;
3563
+
let new_meths =
3564
+
Meths.map
3565
+
(fun (priv, virt, ty) -> (priv, virt, generic_instance ty))
3566
+
meths
3567
+
in
3568
+
(* But keep levels correct on the type of self *)
3569
+
Meths.iter
3570
+
(fun _ (_, _, ty) -> unify_var env (newvar ()) ty)
3571
+
meths;
3572
+
sign.csig_meths <- new_meths
3400
3573
3401
3574
(***********************************)
3402
3575
(* Matching between type schemes *)
···
4024
4197
4025
4198
exception Failure of class_match_failure list
4026
4199
4200
+
let match_class_sig_shape ~strict sign1 sign2 =
4201
+
let errors =
4202
+
Meths.fold
4203
+
(fun lab (priv, vr, _) err ->
4204
+
match Meths.find lab sign1.csig_meths with
4205
+
| exception Not_found -> CM_Missing_method lab::err
4206
+
| (priv', vr', _) ->
4207
+
match priv', priv with
4208
+
| Public, Private -> CM_Public_method lab::err
4209
+
| Private, Public when strict -> CM_Private_method lab::err
4210
+
| _, _ ->
4211
+
match vr', vr with
4212
+
| Virtual, Concrete -> CM_Virtual_method lab::err
4213
+
| _, _ -> err)
4214
+
sign2.csig_meths []
4215
+
in
4216
+
let errors =
4217
+
Meths.fold
4218
+
(fun lab (priv, vr, _) err ->
4219
+
if Meths.mem lab sign2.csig_meths then err
4220
+
else begin
4221
+
let err =
4222
+
match priv with
4223
+
| Public -> CM_Hide_public lab :: err
4224
+
| Private -> err
4225
+
in
4226
+
match vr with
4227
+
| Virtual -> CM_Hide_virtual ("method", lab) :: err
4228
+
| Concrete -> err
4229
+
end)
4230
+
sign1.csig_meths errors
4231
+
in
4232
+
let errors =
4233
+
Vars.fold
4234
+
(fun lab (mut, vr, _) err ->
4235
+
match Vars.find lab sign1.csig_vars with
4236
+
| exception Not_found -> CM_Missing_value lab::err
4237
+
| (mut', vr', _) ->
4238
+
match mut', mut with
4239
+
| Immutable, Mutable -> CM_Non_mutable_value lab::err
4240
+
| _, _ ->
4241
+
match vr', vr with
4242
+
| Virtual, Concrete -> CM_Non_concrete_value lab::err
4243
+
| _, _ -> err)
4244
+
sign2.csig_vars errors
4245
+
in
4246
+
Vars.fold
4247
+
(fun lab (_,vr,_) err ->
4248
+
if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
4249
+
CM_Hide_virtual ("instance variable", lab) :: err
4250
+
else err)
4251
+
sign1.csig_vars errors
4252
+
4027
4253
let rec moregen_clty trace type_pairs env cty1 cty2 =
4028
4254
try
4029
4255
match cty1, cty2 with
4030
-
Cty_constr (_, _, cty1), _ ->
4256
+
| Cty_constr (_, _, cty1), _ ->
4031
4257
moregen_clty true type_pairs env cty1 cty2
4032
4258
| _, Cty_constr (_, _, cty2) ->
4033
4259
moregen_clty true type_pairs env cty1 cty2
···
4039
4265
end;
4040
4266
moregen_clty false type_pairs env cty1' cty2'
4041
4267
| Cty_signature sign1, Cty_signature sign2 ->
4042
-
let ty1 = object_fields sign1.csig_self in
4043
-
let ty2 = object_fields sign2.csig_self in
4044
-
let (fields1, _rest1) = flatten_fields ty1
4045
-
and (fields2, _rest2) = flatten_fields ty2 in
4046
-
let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
4047
-
List.iter
4048
-
(fun (lab, _k1, t1, _k2, t2) ->
4049
-
try moregen true type_pairs env t1 t2 with Moregen_trace trace ->
4050
-
raise (Failure [
4051
-
CM_Meth_type_mismatch
4052
-
(lab,
4053
-
env,
4054
-
Moregen_error (expand_to_moregen_error env trace))]))
4055
-
pairs;
4056
-
Vars.iter
4057
-
(fun lab (_mut, _v, ty) ->
4058
-
let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
4059
-
try moregen true type_pairs env ty' ty with Moregen_trace trace ->
4060
-
raise (Failure [
4061
-
CM_Val_type_mismatch
4062
-
(lab, env, Moregen_error(expand_to_moregen_error env trace))]))
4063
-
sign2.csig_vars
4064
-
| _ ->
4065
-
raise (Failure [])
4268
+
Meths.iter
4269
+
(fun lab (_, _, ty) ->
4270
+
match Meths.find lab sign1.csig_meths with
4271
+
| exception Not_found ->
4272
+
(* This function is only called after checking that
4273
+
all methods in sign2 are present in sign1. *)
4274
+
assert false
4275
+
| (_, _, ty') ->
4276
+
match moregen true type_pairs env ty' ty with
4277
+
| () -> ()
4278
+
| exception Moregen_trace trace ->
4279
+
raise (Failure [
4280
+
CM_Meth_type_mismatch
4281
+
(lab,
4282
+
env,
4283
+
Moregen_error
4284
+
(expand_to_moregen_error env trace))]))
4285
+
sign2.csig_meths;
4286
+
Vars.iter
4287
+
(fun lab (_, _, ty) ->
4288
+
match Vars.find lab sign1.csig_vars with
4289
+
| exception Not_found ->
4290
+
(* This function is only called after checking that
4291
+
all instance variables in sign2 are present in sign1. *)
4292
+
assert false
4293
+
| (_, _, ty') ->
4294
+
match moregen true type_pairs env ty' ty with
4295
+
| () -> ()
4296
+
| exception Moregen_trace trace ->
4297
+
raise (Failure [
4298
+
CM_Val_type_mismatch
4299
+
(lab,
4300
+
env,
4301
+
Moregen_error
4302
+
(expand_to_moregen_error env trace))]))
4303
+
sign2.csig_vars
4304
+
| _ ->
4305
+
raise (Failure [])
4066
4306
with
4067
4307
Failure error when trace || error = [] ->
4068
4308
raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
4069
4309
4070
4310
let match_class_types ?(trace=true) env pat_sch subj_sch =
4071
-
let type_pairs = TypePairs.create 53 in
4072
-
let old_level = !current_level in
4073
-
current_level := generic_level - 1;
4074
-
(*
4075
-
Generic variables are first duplicated with [instance]. So,
4076
-
their levels are lowered to [generic_level - 1]. The subject is
4077
-
then copied with [duplicate_type]. That way, its levels won't be
4078
-
changed.
4079
-
*)
4080
-
let (_, subj_inst) = instance_class [] subj_sch in
4081
-
let subj = duplicate_class_type subj_inst in
4082
-
current_level := generic_level;
4083
-
(* Duplicate generic variables *)
4084
-
let (_, patt) = instance_class [] pat_sch in
4085
-
let res =
4086
-
let sign1 = signature_of_class_type patt in
4087
-
let sign2 = signature_of_class_type subj in
4088
-
let t1 = sign1.csig_self in
4089
-
let t2 = sign2.csig_self in
4090
-
TypePairs.add type_pairs (t1, t2) ();
4091
-
let (fields1, rest1) = flatten_fields (object_fields t1)
4092
-
and (fields2, rest2) = flatten_fields (object_fields t2) in
4093
-
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
4094
-
let error =
4095
-
List.fold_right
4096
-
(fun (lab, k, _) err ->
4097
-
let err =
4098
-
let k = field_kind_repr k in
4099
-
begin match k with
4100
-
Fvar r -> set_kind r Fabsent; err
4101
-
| _ -> CM_Hide_public lab::err
4102
-
end
4103
-
in
4104
-
if lab = dummy_method || Concr.mem lab sign1.csig_concr then err
4105
-
else CM_Hide_virtual ("method", lab) :: err)
4106
-
miss1 []
4107
-
in
4108
-
let missing_method = List.map (fun (m, _, _) -> m) miss2 in
4109
-
let error =
4110
-
(List.map (fun m -> CM_Missing_method m) missing_method) @ error
4111
-
in
4112
-
(* Always succeeds *)
4113
-
moregen true type_pairs env rest1 rest2;
4114
-
let error =
4115
-
List.fold_right
4116
-
(fun (lab, k1, _t1, k2, _t2) err ->
4117
-
match moregen_kind k1 k2 with
4118
-
| () -> err
4119
-
| exception Public_method_to_private_method ->
4120
-
CM_Public_method lab :: err)
4121
-
pairs error
4122
-
in
4123
-
let error =
4124
-
Vars.fold
4125
-
(fun lab (mut, vr, _ty) err ->
4126
-
try
4127
-
let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
4128
-
if mut = Mutable && mut' <> Mutable then
4129
-
CM_Non_mutable_value lab::err
4130
-
else if vr = Concrete && vr' <> Concrete then
4131
-
CM_Non_concrete_value lab::err
4132
-
else
4133
-
err
4134
-
with Not_found ->
4135
-
CM_Missing_value lab::err)
4136
-
sign2.csig_vars error
4137
-
in
4138
-
let error =
4139
-
Vars.fold
4140
-
(fun lab (_,vr,_) err ->
4141
-
if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
4142
-
CM_Hide_virtual ("instance variable", lab) :: err
4143
-
else err)
4144
-
sign1.csig_vars error
4145
-
in
4146
-
let error =
4147
-
List.fold_right
4148
-
(fun e l ->
4149
-
if List.mem e missing_method then l else CM_Virtual_method e::l)
4150
-
(Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
4151
-
error
4152
-
in
4153
-
match error with
4154
-
[] ->
4155
-
begin try
4156
-
moregen_clty trace type_pairs env patt subj;
4157
-
[]
4158
-
with
4159
-
Failure r -> r
4160
-
end
4161
-
| error ->
4162
-
CM_Class_type_mismatch (env, patt, subj)::error
4163
-
in
4164
-
begin match res with
4165
-
| [] -> ()
4166
-
| _::_ ->
4167
-
(* If [res] is nonempty, we've found an error. Moregen splits the generic
4168
-
level into two finer levels: [generic_level] and [generic_level - 1]. In
4169
-
order to properly detect and print weak variables when printing this
4170
-
error, we need to merge them back together, by regeneralizing the levels
4171
-
of the types after they were instantiated at [generic_level - 1] above.
4172
-
Because [moregen] does some unification that we need to preserve for more
4173
-
legible error messages, we have to manually perform the regeneralization
4174
-
rather than backtracking. *)
4175
-
current_level := generic_level - 2;
4176
-
generalize_class_type true subj_inst;
4177
-
end;
4178
-
current_level := old_level;
4179
-
res
4311
+
let sign1 = signature_of_class_type pat_sch in
4312
+
let sign2 = signature_of_class_type subj_sch in
4313
+
let errors = match_class_sig_shape ~strict:false sign1 sign2 in
4314
+
match errors with
4315
+
| [] ->
4316
+
let old_level = !current_level in
4317
+
current_level := generic_level - 1;
4318
+
(*
4319
+
Generic variables are first duplicated with [instance]. So,
4320
+
their levels are lowered to [generic_level - 1]. The subject is
4321
+
then copied with [duplicate_type]. That way, its levels won't be
4322
+
changed.
4323
+
*)
4324
+
let (_, subj_inst) = instance_class [] subj_sch in
4325
+
let subj = duplicate_class_type subj_inst in
4326
+
current_level := generic_level;
4327
+
(* Duplicate generic variables *)
4328
+
let (_, patt) = instance_class [] pat_sch in
4329
+
let type_pairs = TypePairs.create 53 in
4330
+
let sign1 = signature_of_class_type patt in
4331
+
let sign2 = signature_of_class_type subj in
4332
+
let self1 = sign1.csig_self in
4333
+
let self2 = sign2.csig_self in
4334
+
let row1 = sign1.csig_self_row in
4335
+
let row2 = sign2.csig_self_row in
4336
+
TypePairs.add type_pairs (self1, self2) ();
4337
+
(* Always succeeds *)
4338
+
moregen true type_pairs env row1 row2;
4339
+
let res =
4340
+
match moregen_clty trace type_pairs env patt subj with
4341
+
| () -> []
4342
+
| exception Failure res ->
4343
+
(* We've found an error. Moregen splits the generic level into two
4344
+
finer levels: [generic_level] and [generic_level - 1]. In order
4345
+
to properly detect and print weak variables when printing this
4346
+
error, we need to merge them back together, by regeneralizing the
4347
+
levels of the types after they were instantiated at
4348
+
[generic_level - 1] above. Because [moregen] does some
4349
+
unification that we need to preserve for more legible error
4350
+
messages, we have to manually perform the regeneralization rather
4351
+
than backtracking. *)
4352
+
current_level := generic_level - 2;
4353
+
generalize_class_type subj_inst;
4354
+
res
4355
+
in
4356
+
current_level := old_level;
4357
+
res
4358
+
| errors ->
4359
+
CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors
4180
4360
4181
4361
let equal_clsig trace type_pairs subst env sign1 sign2 =
4182
4362
try
4183
-
let ty1 = object_fields sign1.csig_self in
4184
-
let ty2 = object_fields sign2.csig_self in
4185
-
let (fields1, _rest1) = flatten_fields ty1
4186
-
and (fields2, _rest2) = flatten_fields ty2 in
4187
-
let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
4188
-
List.iter
4189
-
(fun (lab, _k1, t1, _k2, t2) ->
4190
-
begin try eqtype true type_pairs subst env t1 t2 with
4191
-
Equality_trace trace ->
4192
-
raise (Failure
4193
-
[CM_Meth_type_mismatch
4194
-
(lab,
4195
-
env,
4196
-
Equality_error
4197
-
(expand_to_equality_error env trace !subst))])
4198
-
end)
4199
-
pairs;
4363
+
Meths.iter
4364
+
(fun lab (_, _, ty) ->
4365
+
match Meths.find lab sign1.csig_meths with
4366
+
| exception Not_found ->
4367
+
(* This function is only called after checking that
4368
+
all methods in sign2 are present in sign1. *)
4369
+
assert false
4370
+
| (_, _, ty') ->
4371
+
match eqtype true type_pairs subst env ty' ty with
4372
+
| () -> ()
4373
+
| exception Equality_trace trace ->
4374
+
raise (Failure [
4375
+
CM_Meth_type_mismatch
4376
+
(lab,
4377
+
env,
4378
+
Equality_error
4379
+
(expand_to_equality_error env trace !subst))]))
4380
+
sign2.csig_meths;
4200
4381
Vars.iter
4201
4382
(fun lab (_, _, ty) ->
4202
-
let (_, _, ty') = Vars.find lab sign1.csig_vars in
4203
-
try eqtype true type_pairs subst env ty' ty
4204
-
with Equality_trace trace ->
4205
-
raise (Failure
4206
-
[CM_Val_type_mismatch
4207
-
(lab,
4208
-
env,
4209
-
Equality_error
4210
-
(expand_to_equality_error env trace !subst))]))
4383
+
match Vars.find lab sign1.csig_vars with
4384
+
| exception Not_found ->
4385
+
(* This function is only called after checking that
4386
+
all instance variables in sign2 are present in sign1. *)
4387
+
assert false
4388
+
| (_, _, ty') ->
4389
+
match eqtype true type_pairs subst env ty' ty with
4390
+
| () -> ()
4391
+
| exception Equality_trace trace ->
4392
+
raise (Failure [
4393
+
CM_Val_type_mismatch
4394
+
(lab,
4395
+
env,
4396
+
Equality_error
4397
+
(expand_to_equality_error env trace !subst))]))
4211
4398
sign2.csig_vars
4212
4399
with
4213
4400
Failure error when trace ->
···
4215
4402
(env, Cty_signature sign1, Cty_signature sign2)::error))
4216
4403
4217
4404
let match_class_declarations env patt_params patt_type subj_params subj_type =
4218
-
let type_pairs = TypePairs.create 53 in
4219
-
let subst = ref [] in
4220
4405
let sign1 = signature_of_class_type patt_type in
4221
4406
let sign2 = signature_of_class_type subj_type in
4222
-
let t1 = sign1.csig_self in
4223
-
let t2 = sign2.csig_self in
4224
-
TypePairs.add type_pairs (t1, t2) ();
4225
-
let (fields1, rest1) = flatten_fields (object_fields t1)
4226
-
and (fields2, rest2) = flatten_fields (object_fields t2) in
4227
-
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
4228
-
let error =
4229
-
List.fold_right
4230
-
(fun (lab, k, _) err ->
4231
-
let err =
4232
-
let k = field_kind_repr k in
4233
-
begin match k with
4234
-
Fvar _ -> err
4235
-
| _ -> CM_Hide_public lab::err
4236
-
end
4237
-
in
4238
-
if Concr.mem lab sign1.csig_concr then err
4239
-
else CM_Hide_virtual ("method", lab) :: err)
4240
-
miss1 []
4241
-
in
4242
-
let missing_method = List.map (fun (m, _, _) -> m) miss2 in
4243
-
let error =
4244
-
(List.map (fun m -> CM_Missing_method m) missing_method) @ error
4245
-
in
4246
-
(* Always succeeds *)
4247
-
eqtype true type_pairs subst env rest1 rest2;
4248
-
let error =
4249
-
List.fold_right
4250
-
(fun (lab, k1, _t1, k2, _t2) err ->
4251
-
let k1 = field_kind_repr k1 in
4252
-
let k2 = field_kind_repr k2 in
4253
-
match k1, k2 with
4254
-
(Fvar _, Fvar _)
4255
-
| (Fpresent, Fpresent) -> err
4256
-
| (Fvar _, Fpresent) -> CM_Private_method lab::err
4257
-
| (Fpresent, Fvar _) -> CM_Public_method lab::err
4258
-
| _ -> assert false)
4259
-
pairs error
4260
-
in
4261
-
let error =
4262
-
Vars.fold
4263
-
(fun lab (mut, vr, _ty) err ->
4264
-
try
4265
-
let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
4266
-
if mut = Mutable && mut' <> Mutable then
4267
-
CM_Non_mutable_value lab::err
4268
-
else if vr = Concrete && vr' <> Concrete then
4269
-
CM_Non_concrete_value lab::err
4270
-
else
4271
-
err
4272
-
with Not_found ->
4273
-
CM_Missing_value lab::err)
4274
-
sign2.csig_vars error
4275
-
in
4276
-
let error =
4277
-
Vars.fold
4278
-
(fun lab (_,vr,_) err ->
4279
-
if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then
4280
-
CM_Hide_virtual ("instance variable", lab) :: err
4281
-
else err)
4282
-
sign1.csig_vars error
4283
-
in
4284
-
let error =
4285
-
List.fold_right
4286
-
(fun e l ->
4287
-
if List.mem e missing_method then l else CM_Virtual_method e::l)
4288
-
(Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr))
4289
-
error
4290
-
in
4291
-
match error with
4292
-
[] ->
4293
-
begin try
4407
+
let errors = match_class_sig_shape ~strict:true sign1 sign2 in
4408
+
match errors with
4409
+
| [] -> begin
4410
+
try
4411
+
let subst = ref [] in
4412
+
let type_pairs = TypePairs.create 53 in
4413
+
let self1 = sign1.csig_self in
4414
+
let self2 = sign2.csig_self in
4415
+
let row1 = sign1.csig_self_row in
4416
+
let row2 = sign2.csig_self_row in
4417
+
TypePairs.add type_pairs (self1, self2) ();
4418
+
(* Always succeeds *)
4419
+
eqtype true type_pairs subst env row1 row2;
4294
4420
let lp = List.length patt_params in
4295
4421
let ls = List.length subj_params in
4296
4422
if lp <> ls then
···
4310
4436
match_class_types ~trace:false env
4311
4437
(clty_params patt_params patt_type)
4312
4438
(clty_params subj_params subj_type)
4313
-
with
4314
-
Failure r -> r
4315
-
end
4439
+
with Failure r -> r
4440
+
end
4316
4441
| error ->
4317
4442
error
4318
4443
···
4853
4978
| _ -> 0
4854
4979
4855
4980
(* Check for non-generalizable type variables *)
4856
-
exception Non_closed0
4981
+
exception Nongen
4857
4982
let visited = ref TypeSet.empty
4858
4983
4859
-
let rec closed_schema_rec env ty =
4984
+
let rec nongen_schema_rec env ty =
4860
4985
if TypeSet.mem ty !visited then () else begin
4861
4986
visited := TypeSet.add ty !visited;
4862
4987
match get_desc ty with
4863
4988
Tvar _ when get_level ty <> generic_level ->
4864
-
raise Non_closed0
4989
+
raise Nongen
4865
4990
| Tconstr _ ->
4866
4991
let old = !visited in
4867
-
begin try iter_type_expr (closed_schema_rec env) ty
4868
-
with Non_closed0 -> try
4992
+
begin try iter_type_expr (nongen_schema_rec env) ty
4993
+
with Nongen -> try
4869
4994
visited := old;
4870
-
closed_schema_rec env
4871
-
(try_expand_head try_expand_safe env ty)
4995
+
nongen_schema_rec env (try_expand_head try_expand_safe env ty)
4872
4996
with Cannot_expand ->
4873
-
raise Non_closed0
4997
+
raise Nongen
4874
4998
end
4875
4999
| Tfield(_, kind, t1, t2) ->
4876
5000
if field_kind_repr kind = Fpresent then
4877
-
closed_schema_rec env t1;
4878
-
closed_schema_rec env t2
5001
+
nongen_schema_rec env t1;
5002
+
nongen_schema_rec env t2
4879
5003
| Tvariant row ->
4880
5004
let row = row_repr row in
4881
-
iter_row (closed_schema_rec env) row;
4882
-
if not (static_row row) then closed_schema_rec env row.row_more
5005
+
iter_row (nongen_schema_rec env) row;
5006
+
if not (static_row row) then nongen_schema_rec env row.row_more
4883
5007
| _ ->
4884
-
iter_type_expr (closed_schema_rec env) ty
5008
+
iter_type_expr (nongen_schema_rec env) ty
4885
5009
end
4886
5010
4887
5011
(* Return whether all variables of type [ty] are generic. *)
4888
-
let closed_schema env ty =
5012
+
let nongen_schema env ty =
4889
5013
visited := TypeSet.empty;
4890
5014
try
4891
-
closed_schema_rec env ty;
5015
+
nongen_schema_rec env ty;
5016
+
visited := TypeSet.empty;
5017
+
false
5018
+
with Nongen ->
4892
5019
visited := TypeSet.empty;
4893
5020
true
4894
-
with Non_closed0 ->
4895
-
visited := TypeSet.empty;
4896
-
false
5021
+
5022
+
(* Check that all type variables are generalizable *)
5023
+
(* Use Env.empty to prevent expansion of recursively defined object types;
5024
+
cf. typing-poly/poly.ml *)
5025
+
let rec nongen_class_type = function
5026
+
| Cty_constr (_, params, _) ->
5027
+
List.exists (nongen_schema Env.empty) params
5028
+
| Cty_signature sign ->
5029
+
nongen_schema Env.empty sign.csig_self
5030
+
|| nongen_schema Env.empty sign.csig_self_row
5031
+
|| Meths.exists
5032
+
(fun _ (_, _, ty) -> nongen_schema Env.empty ty)
5033
+
sign.csig_meths
5034
+
|| Vars.exists
5035
+
(fun _ (_, _, ty) -> nongen_schema Env.empty ty)
5036
+
sign.csig_vars
5037
+
| Cty_arrow (_, ty, cty) ->
5038
+
nongen_schema Env.empty ty
5039
+
|| nongen_class_type cty
5040
+
5041
+
let nongen_class_declaration cty =
5042
+
List.exists (nongen_schema Env.empty) cty.cty_params
5043
+
|| nongen_class_type cty.cty_type
5044
+
4897
5045
4898
5046
(* Normalize a type before printing, saving... *)
4899
5047
(* Cannot use mark_type because deep_occur uses it too *)
···
5153
5301
(* Preserve sharing inside class types. *)
5154
5302
let nondep_class_signature env id sign =
5155
5303
{ csig_self = nondep_type_rec env id sign.csig_self;
5304
+
csig_self_row = nondep_type_rec env id sign.csig_self_row;
5156
5305
csig_vars =
5157
5306
Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
5158
5307
sign.csig_vars;
5159
-
csig_concr = sign.csig_concr;
5160
-
csig_inher =
5161
-
List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
5162
-
sign.csig_inher }
5308
+
csig_meths =
5309
+
Meths.map (function (p, v, t) -> (p, v, nondep_type_rec env id t))
5310
+
sign.csig_meths }
5163
5311
5164
5312
let rec nondep_class_type env ids =
5165
5313
function
+59
-26
typing/ctype.mli
+59
-26
typing/ctype.mli
···
55
55
val create_scope : unit -> int
56
56
57
57
val newty: type_desc -> type_expr
58
+
val new_scoped_ty: int -> type_desc -> type_expr
58
59
val newvar: ?name:string -> unit -> type_expr
59
60
val newvar2: ?name:string -> int -> type_expr
60
61
(* Return a fresh variable *)
···
94
95
(string * field_kind * type_expr) list *
95
96
(string * field_kind * type_expr) list
96
97
val opened_object: type_expr -> bool
97
-
val close_object: type_expr -> bool
98
-
val row_variable: type_expr -> type_expr
99
-
(* Return the row variable of an open object type *)
100
98
val set_object_name:
101
-
Ident.t -> type_expr -> type_expr list -> type_expr -> unit
99
+
Ident.t -> type_expr list -> type_expr -> unit
102
100
val remove_object_name: type_expr -> unit
103
-
val hide_private_methods: type_expr -> unit
104
101
val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
105
102
106
103
val sort_row_fields: (label * row_field) list -> (label * row_field) list
···
119
116
val generalize_structure: type_expr -> unit
120
117
(* Generalize the structure of a type, lowering variables
121
118
to !current_level *)
122
-
val generalize_class_type :
123
-
bool -> class_type -> unit
119
+
val generalize_class_type : class_type -> unit
124
120
(* Generalize the components of a class type *)
125
-
val generalize_spine: type_expr -> unit
126
-
(* Special function to generalize a method during inference *)
121
+
val generalize_class_type_structure : class_type -> unit
122
+
(* Generalize the structure of the components of a class type *)
123
+
val generalize_class_signature_spine : Env.t -> class_signature -> unit
124
+
(* Special function to generalize methods during inference *)
127
125
val correct_levels: type_expr -> type_expr
128
126
(* Returns a copy with decreasing levels *)
129
127
val limited_generalize: type_expr -> type_expr -> unit
130
128
(* Only generalize some part of the type
131
129
Make the remaining of the type non-generalizable *)
130
+
val limited_generalize_class_type: type_expr -> class_type -> unit
131
+
(* Same, but for class types *)
132
132
133
133
val fully_generic: type_expr -> bool
134
134
···
165
165
(* Same as instance_declaration, but new nodes at generic_level *)
166
166
val instance_class:
167
167
type_expr list -> class_type -> type_expr list * class_type
168
+
168
169
val instance_poly:
169
170
?keep_names:bool ->
170
171
bool -> type_expr list -> type_expr -> type_expr list * type_expr
···
230
231
val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
231
232
(* A special case of unification with [l:'a -> 'b]. Raises
232
233
[Filter_arrow_failed] instead of [Unify]. *)
233
-
val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
234
+
val filter_method: Env.t -> string -> type_expr -> type_expr
234
235
(* A special case of unification (with {m : 'a; 'b}). Raises
235
236
[Filter_method_failed] instead of [Unify]. *)
236
-
val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
237
-
(* A special case of unification (with {m : 'a; 'b}), returning unit.
238
-
Raises [Filter_method_failed] instead of [Unify]. *)
239
237
val occur_in: Env.t -> type_expr -> type_expr -> bool
240
238
val deep_occur: type_expr -> type_expr -> bool
241
-
val filter_self_method:
242
-
Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
243
-
type_expr -> Ident.t * type_expr
244
-
(* Raises [Filter_method_failed] instead of [Unify], and only if the
245
-
self type is closed at this point. *)
246
239
val moregeneral: Env.t -> bool -> type_expr -> type_expr -> unit
247
240
(* Check if the first type scheme is more general than the second. *)
248
241
val is_moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool
···
327
320
enforce and returns a function that enforces this
328
321
constraints. *)
329
322
323
+
(* Operations on class signatures *)
324
+
325
+
val new_class_signature : unit -> class_signature
326
+
val add_dummy_method : Env.t -> scope:int -> class_signature -> unit
327
+
328
+
type add_method_failure =
329
+
| Unexpected_method
330
+
| Type_mismatch of Errortrace.unification_error
331
+
332
+
exception Add_method_failed of add_method_failure
333
+
334
+
val add_method : Env.t ->
335
+
label -> private_flag -> virtual_flag -> type_expr -> class_signature -> unit
336
+
337
+
type add_instance_variable_failure =
338
+
| Mutability_mismatch of mutable_flag
339
+
| Type_mismatch of Errortrace.unification_error
340
+
341
+
exception Add_instance_variable_failed of add_instance_variable_failure
342
+
343
+
val add_instance_variable : strict:bool -> Env.t ->
344
+
label -> mutable_flag -> virtual_flag -> type_expr -> class_signature -> unit
345
+
346
+
type inherit_class_signature_failure =
347
+
| Self_type_mismatch of Errortrace.unification_error
348
+
| Method of label * add_method_failure
349
+
| Instance_variable of label * add_instance_variable_failure
350
+
351
+
exception Inherit_class_signature_failed of inherit_class_signature_failure
352
+
353
+
val inherit_class_signature : strict:bool -> Env.t ->
354
+
class_signature -> class_signature -> unit
355
+
356
+
val update_class_signature :
357
+
Env.t -> class_signature -> label list * label list
358
+
359
+
val hide_private_methods : Env.t -> class_signature -> unit
360
+
361
+
val close_class_signature : Env.t -> class_signature -> bool
362
+
330
363
exception Nondep_cannot_erase of Ident.t
331
364
332
365
val nondep_type: Env.t -> Ident.t list -> type_expr -> type_expr
···
351
384
val is_contractive: Env.t -> Path.t -> bool
352
385
val normalize_type: type_expr -> unit
353
386
354
-
val closed_schema: Env.t -> type_expr -> bool
387
+
val nongen_schema: Env.t -> type_expr -> bool
355
388
(* Check whether the given type scheme contains no non-generic
356
389
type variables *)
357
390
391
+
val nongen_class_declaration: class_declaration -> bool
392
+
(* Check whether the given class type contains no non-generic
393
+
type variables. Uses the empty environment. *)
394
+
358
395
val free_variables: ?env:Env.t -> type_expr -> type_expr list
359
396
(* If env present, then check for incomplete definitions too *)
360
397
val closed_type_decl: type_declaration -> type_expr option
361
398
val closed_extension_constructor: extension_constructor -> type_expr option
362
-
type closed_class_failure =
363
-
CC_Method of type_expr * bool * string * type_expr
364
-
| CC_Value of type_expr * bool * string * type_expr
365
399
val closed_class:
366
-
type_expr list -> class_signature -> closed_class_failure option
400
+
type_expr list -> class_signature ->
401
+
(type_expr * bool * string * type_expr) option
367
402
(* Check whether all type variables are bound *)
368
403
369
404
val unalias: type_expr -> type_expr
370
-
val signature_of_class_type: class_type -> class_signature
371
-
val self_type: class_type -> type_expr
372
-
val class_type_arity: class_type -> int
405
+
373
406
val arity: type_expr -> int
374
407
(* Return the arity (as for curried functions) of the given type. *)
375
408
+2
-2
typing/env.ml
+2
-2
typing/env.ml
···
1441
1441
1442
1442
let used_persistent () =
1443
1443
Persistent_env.fold !persistent_env
1444
-
(fun s _m r -> Concr.add s r)
1445
-
Concr.empty
1444
+
(fun s _m r -> String.Set.add s r)
1445
+
String.Set.empty
1446
1446
1447
1447
let find_all_comps wrap proj s (p, mda) =
1448
1448
match get_components mda.mda_components with
+1
-1
typing/env.mli
+1
-1
typing/env.mli
···
70
70
t -> iter_cont
71
71
val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
72
72
val same_types: t -> t -> bool
73
-
val used_persistent: unit -> Concr.t
73
+
val used_persistent: unit -> Stdlib.String.Set.t
74
74
val find_shadowed_types: Path.t -> t -> Path.t list
75
75
val without_cmis: ('a -> 'b) -> 'a -> 'b
76
76
(* [without_cmis f arg] applies [f] to [arg], but does not
+55
-54
typing/printtyp.ml
+55
-54
typing/printtyp.ml
···
616
616
cache for short-paths
617
617
*)
618
618
let printing_old = ref Env.empty
619
-
let printing_pers = ref Concr.empty
619
+
let printing_pers = ref String.Set.empty
620
620
(** {!printing_old} and {!printing_pers} are the keys of the one-slot cache *)
621
621
622
622
let printing_depth = ref 0
···
680
680
681
681
let same_printing_env env =
682
682
let used_pers = Env.used_persistent () in
683
-
Env.same_types !printing_old env && Concr.equal !printing_pers used_pers
683
+
Env.same_types !printing_old env && String.Set.equal !printing_pers used_pers
684
684
685
685
let set_printing_env env =
686
686
printing_env := env;
···
941
941
942
942
let proxy ty = Transient_expr.repr (proxy ty)
943
943
944
-
let is_aliased ty = List.memq (proxy ty) !aliased
944
+
let is_aliased_proxy px =
945
+
List.memq px !aliased
945
946
let add_alias_proxy px =
946
947
if not (List.memq px !aliased) then begin
947
948
aliased := px :: !aliased;
···
1162
1163
Otyp_module (tree_of_path Module_type p, fl)
1163
1164
in
1164
1165
if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
1165
-
if is_aliased (Transient_expr.type_expr px) && aliasable ty then begin
1166
+
if is_aliased_proxy px && aliasable ty then begin
1166
1167
Names.check_name_of_type px;
1167
1168
Otyp_alias (pr_typ (), Names.name_of_type Names.new_name px) end
1168
1169
else pr_typ ()
···
1537
1538
1538
1539
(* Print a class type *)
1539
1540
1540
-
let method_type (_, kind, ty) =
1541
-
match field_kind_repr kind, get_desc ty with
1542
-
Fpresent, Tpoly(ty, tyl) -> (ty, tyl)
1543
-
| _ , _ -> (ty, [])
1541
+
let method_type priv ty =
1542
+
match priv, get_desc ty with
1543
+
| Public, Tpoly(ty, tyl) -> (ty, tyl)
1544
+
| _ , _ -> (ty, [])
1544
1545
1545
-
let tree_of_metho mode concrete csil (lab, kind, ty) =
1546
-
if lab <> dummy_method then begin
1547
-
let kind = field_kind_repr kind in
1548
-
let priv = kind <> Fpresent in
1549
-
let virt = not (Concr.mem lab concrete) in
1550
-
let (ty, tyl) = method_type (lab, kind, ty) in
1551
-
let tty = tree_of_typexp mode ty in
1552
-
Names.remove_names (List.map Transient_expr.repr tyl);
1553
-
Ocsg_method (lab, priv, virt, tty) :: csil
1554
-
end
1555
-
else csil
1546
+
let prepare_method _lab (priv, _virt, ty) =
1547
+
let ty, _ = method_type priv ty in
1548
+
mark_loops ty
1549
+
1550
+
let tree_of_method mode (lab, priv, virt, ty) =
1551
+
let (ty, tyl) = method_type priv ty in
1552
+
let tty = tree_of_typexp mode ty in
1553
+
Names.remove_names (List.map Transient_expr.repr tyl);
1554
+
let priv = priv = Private in
1555
+
let virt = virt = Virtual in
1556
+
Ocsg_method (lab, priv, virt, tty)
1556
1557
1557
1558
let rec prepare_class_type params = function
1558
1559
| Cty_constr (_p, tyl, cty) ->
1559
-
let sty = Ctype.self_type cty in
1560
-
if List.memq (proxy sty) !visited_objects
1560
+
let row = Btype.self_type_row cty in
1561
+
if List.memq (proxy row) !visited_objects
1561
1562
|| not (List.for_all is_Tvar params)
1562
-
|| List.exists (deep_occur sty) tyl
1563
+
|| List.exists (deep_occur row) tyl
1563
1564
then prepare_class_type params cty
1564
1565
else List.iter mark_loops tyl
1565
1566
| Cty_signature sign ->
1566
1567
(* Self may have a name *)
1567
-
let px = proxy sign.csig_self in
1568
-
if List.memq px !visited_objects then add_alias sign.csig_self
1568
+
let px = proxy sign.csig_self_row in
1569
+
if List.memq px !visited_objects then add_alias_proxy px
1569
1570
else visited_objects := px :: !visited_objects;
1570
-
let (fields, _) =
1571
-
Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
1572
-
in
1573
-
List.iter (fun met -> mark_loops (fst (method_type met))) fields;
1574
-
Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars
1571
+
Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars;
1572
+
Meths.iter prepare_method sign.csig_meths
1575
1573
| Cty_arrow (_, ty, cty) ->
1576
1574
mark_loops ty;
1577
1575
prepare_class_type params cty
···
1579
1577
let rec tree_of_class_type mode params =
1580
1578
function
1581
1579
| Cty_constr (p', tyl, cty) ->
1582
-
let sty = Ctype.self_type cty in
1583
-
if List.memq (proxy sty) !visited_objects
1580
+
let row = Btype.self_type_row cty in
1581
+
if List.memq (proxy row) !visited_objects
1584
1582
|| not (List.for_all is_Tvar params)
1585
1583
then
1586
1584
tree_of_class_type mode params cty
···
1588
1586
let namespace = Namespace.best_class_namespace p' in
1589
1587
Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl)
1590
1588
| Cty_signature sign ->
1591
-
let sty = sign.csig_self in
1589
+
let px = proxy sign.csig_self_row in
1592
1590
let self_ty =
1593
-
if is_aliased sty then
1594
-
Some (Otyp_var (false, Names.name_of_type Names.new_name (proxy sty)))
1591
+
if is_aliased_proxy px then
1592
+
Some
1593
+
(Otyp_var (false, Names.name_of_type Names.new_name px))
1595
1594
else None
1596
1595
in
1597
-
let (fields, _) =
1598
-
Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
1599
-
in
1600
1596
let csil = [] in
1601
1597
let csil =
1602
1598
List.fold_left
···
1615
1611
:: csil)
1616
1612
csil all_vars
1617
1613
in
1614
+
let all_meths =
1615
+
Meths.fold
1616
+
(fun l (p, v, t) all -> (l, p, v, t) :: all)
1617
+
sign.csig_meths []
1618
+
in
1619
+
let all_meths = List.rev all_meths in
1618
1620
let csil =
1619
-
List.fold_left (tree_of_metho mode sign.csig_concr) csil fields
1621
+
List.fold_left
1622
+
(fun csil meth -> tree_of_method mode meth :: csil)
1623
+
csil all_meths
1620
1624
in
1621
1625
Octy_signature (self_ty, List.rev csil)
1622
1626
| Cty_arrow (l, ty, cty) ->
···
1657
1661
reset_except_context ();
1658
1662
List.iter add_alias params;
1659
1663
prepare_class_type params cl.cty_type;
1660
-
let sty = Ctype.self_type cl.cty_type in
1664
+
let px = proxy (Btype.self_type_row cl.cty_type) in
1661
1665
List.iter mark_loops params;
1662
1666
1663
1667
List.iter Names.check_name_of_type (List.map proxy params);
1664
-
if is_aliased sty then Names.check_name_of_type (proxy sty);
1668
+
if is_aliased_proxy px then Names.check_name_of_type px;
1665
1669
1666
1670
let vir_flag = cl.cty_new = None in
1667
1671
Osig_class
···
1679
1683
reset_except_context ();
1680
1684
List.iter add_alias params;
1681
1685
prepare_class_type params cl.clty_type;
1682
-
let sty = Ctype.self_type cl.clty_type in
1686
+
let px = proxy (Btype.self_type_row cl.clty_type) in
1683
1687
List.iter mark_loops params;
1684
1688
1685
1689
List.iter Names.check_name_of_type (List.map proxy params);
1686
-
if is_aliased sty then Names.check_name_of_type (proxy sty);
1690
+
if is_aliased_proxy px then Names.check_name_of_type px;
1687
1691
1688
-
let sign = Ctype.signature_of_class_type cl.clty_type in
1689
-
1690
-
let virt =
1691
-
let (fields, _) =
1692
-
Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
1693
-
List.exists
1694
-
(fun (lab, _, _) ->
1695
-
not (lab = dummy_method || Concr.mem lab sign.csig_concr))
1696
-
fields
1697
-
|| Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
1692
+
let sign = Btype.signature_of_class_type cl.clty_type in
1693
+
let has_virtual_vars =
1694
+
Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b)
1695
+
sign.csig_vars false
1696
+
in
1697
+
let has_virtual_meths =
1698
+
Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b)
1699
+
sign.csig_meths false
1698
1700
in
1699
-
1700
1701
Osig_class_type
1701
-
(virt, Ident.name id,
1702
+
(has_virtual_vars || has_virtual_meths, Ident.name id,
1702
1703
List.map2 tree_of_class_param params (class_variance cl.clty_variance),
1703
1704
tree_of_class_type Type_scheme params cl.clty_type,
1704
1705
tree_of_rec rs)
+8
-7
typing/printtyped.ml
+8
-7
typing/printtyped.ml
···
396
396
expression i ppf e1;
397
397
expression i ppf e2;
398
398
expression i ppf e3;
399
-
| Texp_send (e, Tmeth_name s, eo) ->
399
+
| Texp_send (e, Tmeth_name s) ->
400
400
line i ppf "Texp_send \"%s\"\n" s;
401
-
expression i ppf e;
402
-
option i expression ppf eo
403
-
| Texp_send (e, Tmeth_val s, eo) ->
401
+
expression i ppf e
402
+
| Texp_send (e, Tmeth_val s) ->
403
+
line i ppf "Texp_send \"%a\"\n" fmt_ident s;
404
+
expression i ppf e
405
+
| Texp_send (e, Tmeth_ancestor(s, _)) ->
404
406
line i ppf "Texp_send \"%a\"\n" fmt_ident s;
405
-
expression i ppf e;
406
-
option i expression ppf eo
407
+
expression i ppf e
407
408
| Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li;
408
409
| Texp_setinstvar (_, s, _, e) ->
409
410
line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s;
···
930
931
expression (i+1) ppf x.vb_expr
931
932
932
933
and string_x_expression i ppf (s, _, e) =
933
-
line i ppf "<override> \"%a\"\n" fmt_path s;
934
+
line i ppf "<override> \"%a\"\n" fmt_ident s;
934
935
expression (i+1) ppf e;
935
936
936
937
and record_field i ppf = function
+2
-3
typing/rec_check.ml
+2
-3
typing/rec_check.ml
···
693
693
expression cond << Dereference;
694
694
expression body << Guard;
695
695
]
696
-
| Texp_send (e1, _, eo) ->
696
+
| Texp_send (e1, _) ->
697
697
(*
698
698
G |- e: m[Dereference]
699
699
---------------------- (plus weird 'eo' option)
700
700
G |- e#x: m
701
701
*)
702
702
join [
703
-
expression e1 << Dereference;
704
-
option expression eo << Dereference;
703
+
expression e1 << Dereference
705
704
]
706
705
| Texp_field (e, _, _) ->
707
706
(*
+7
-6
typing/subst.ml
+7
-6
typing/subst.ml
···
335
335
336
336
let class_signature copy_scope s sign =
337
337
{ csig_self = typexp copy_scope s sign.csig_self;
338
+
csig_self_row = typexp copy_scope s sign.csig_self_row;
338
339
csig_vars =
339
340
Vars.map
340
-
(function (m, v, t) -> (m, v, typexp copy_scope s t)) sign.csig_vars;
341
-
csig_concr = sign.csig_concr;
342
-
csig_inher =
343
-
List.map
344
-
(fun (p, tl) -> (type_path s p, List.map (typexp copy_scope s) tl))
345
-
sign.csig_inher;
341
+
(function (m, v, t) -> (m, v, typexp copy_scope s t))
342
+
sign.csig_vars;
343
+
csig_meths =
344
+
Meths.map
345
+
(function (p, v, t) -> (p, v, typexp copy_scope s t))
346
+
sign.csig_meths;
346
347
}
347
348
348
349
let rec class_type copy_scope s = function
+2
-3
typing/tast_iterator.ml
+2
-3
typing/tast_iterator.ml
···
234
234
sub.expr sub exp1;
235
235
sub.expr sub exp2;
236
236
sub.expr sub exp3
237
-
| Texp_send (exp, _, expo) ->
238
-
sub.expr sub exp;
239
-
Option.iter (sub.expr sub) expo
237
+
| Texp_send (exp, _) ->
238
+
sub.expr sub exp
240
239
| Texp_new _ -> ()
241
240
| Texp_instvar _ -> ()
242
241
| Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp
+2
-3
typing/tast_mapper.ml
+2
-3
typing/tast_mapper.ml
···
320
320
dir,
321
321
sub.expr sub exp3
322
322
)
323
-
| Texp_send (exp, meth, expo) ->
323
+
| Texp_send (exp, meth) ->
324
324
Texp_send
325
325
(
326
326
sub.expr sub exp,
327
-
meth,
328
-
Option.map (sub.expr sub) expo
327
+
meth
329
328
)
330
329
| Texp_new _
331
330
| Texp_instvar _ as d -> d
+859
-776
typing/typeclass.ml
+859
-776
typing/typeclass.ml
···
63
63
req: 'a Typedtree.class_infos;
64
64
}
65
65
66
-
type class_env = { val_env : Env.t; met_env : Env.t; par_env : Env.t }
66
+
type kind =
67
+
| Object
68
+
| Class
69
+
| Class_type
70
+
71
+
type final =
72
+
| Final
73
+
| Not_final
74
+
75
+
let kind_of_final = function
76
+
| Final -> Object
77
+
| Not_final -> Class
67
78
68
79
type error =
69
80
| Unconsistent_constraint of Errortrace.unification_error
70
81
| Field_type_mismatch of string * string * Errortrace.unification_error
82
+
| Unexpected_field of type_expr * string
71
83
| Structure_expected of class_type
72
84
| Cannot_apply of class_type
73
85
| Apply_wrong_label of arg_label
···
77
89
| Unbound_class_type_2 of Longident.t
78
90
| Abbrev_type_clash of type_expr * type_expr * type_expr
79
91
| Constructor_type_mismatch of string * Errortrace.unification_error
80
-
| Virtual_class of bool * bool * string list * string list
92
+
| Virtual_class of kind * string list * string list
93
+
| Undeclared_methods of kind * string list
81
94
| Parameter_arity_mismatch of Longident.t * int * int
82
95
| Parameter_mismatch of Errortrace.unification_error
83
96
| Bad_parameters of Ident.t * type_expr * type_expr
84
97
| Class_match_failure of Ctype.class_match_failure list
85
98
| Unbound_val of string
86
-
| Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
99
+
| Unbound_type_var of
100
+
(formatter -> unit) * (type_expr * bool * string * type_expr)
87
101
| Non_generalizable_class of Ident.t * Types.class_declaration
88
102
| Cannot_coerce_self of type_expr
89
103
| Non_collapsable_conjunction of
90
104
Ident.t * Types.class_declaration * Errortrace.unification_error
91
-
| Final_self_clash of Errortrace.unification_error
105
+
| Self_clash of Errortrace.unification_error
92
106
| Mutability_mismatch of string * mutable_flag
93
107
| No_overriding of string * string
94
108
| Duplicate of string * string
95
-
| Closing_self_type of type_expr
109
+
| Closing_self_type of class_signature
96
110
97
111
exception Error of Location.t * Env.t * error
98
112
exception Error_forward of Location.error
···
108
122
{ ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env;
109
123
ctyp_attributes = [] }
110
124
111
-
(**********************)
112
-
(* Useful constants *)
113
-
(**********************)
114
-
115
-
116
-
(*
117
-
Self type have a dummy private method, thus preventing it to become
118
-
closed.
119
-
*)
120
-
let dummy_method = Btype.dummy_method
121
-
122
125
(*
123
126
Path associated to the temporary class type of a class being typed
124
127
(its constructor is not available).
···
131
134
(* Some operations on class types *)
132
135
(************************************)
133
136
137
+
let extract_constraints cty =
138
+
let sign = Btype.signature_of_class_type cty in
139
+
(Btype.instance_vars sign,
140
+
Btype.methods sign,
141
+
Btype.concrete_methods sign)
134
142
135
-
(* Fully expand the head of a class type *)
136
-
let rec scrape_class_type =
137
-
function
138
-
Cty_constr (_, _, cty) -> scrape_class_type cty
139
-
| cty -> cty
143
+
(* Record a class type *)
144
+
let rc node =
145
+
Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
146
+
node
140
147
141
-
(* Return the virtual methods of a class type *)
142
-
let virtual_methods sign =
143
-
let (fields, _) =
144
-
Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
148
+
let update_class_signature loc env ~warn_implicit_public virt kind sign =
149
+
let implicit_public, implicit_declared =
150
+
Ctype.update_class_signature env sign
145
151
in
146
-
List.fold_left
147
-
(fun virt (lab, _, _) ->
148
-
if lab = dummy_method then virt else
149
-
if Concr.mem lab sign.csig_concr then virt else
150
-
lab::virt)
151
-
[] fields
152
+
if implicit_declared <> [] then begin
153
+
match virt with
154
+
| Virtual -> () (* Should perhaps emit warning 17 here *)
155
+
| Concrete ->
156
+
raise (Error(loc, env, Undeclared_methods(kind, implicit_declared)))
157
+
end;
158
+
if warn_implicit_public && implicit_public <> [] then begin
159
+
Location.prerr_warning
160
+
loc (Warnings.Implicit_public_methods implicit_public)
161
+
end
162
+
163
+
let complete_class_signature loc env virt kind sign =
164
+
update_class_signature loc env ~warn_implicit_public:false virt kind sign;
165
+
Ctype.hide_private_methods env sign
166
+
167
+
let complete_class_type loc env virt kind typ =
168
+
let sign = Btype.signature_of_class_type typ in
169
+
complete_class_signature loc env virt kind sign
170
+
171
+
let check_virtual loc env virt kind sign =
172
+
match virt with
173
+
| Virtual -> ()
174
+
| Concrete ->
175
+
match Btype.virtual_methods sign, Btype.virtual_instance_vars sign with
176
+
| [], [] -> ()
177
+
| meths, vars ->
178
+
raise(Error(loc, env, Virtual_class(kind, meths, vars)))
152
179
153
180
(* Return the constructor type associated to a class type *)
154
181
let rec constructor_type constr cty =
···
160
187
| Cty_arrow (l, ty, cty) ->
161
188
Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
162
189
163
-
let rec class_body cty =
164
-
match cty with
165
-
Cty_constr _ ->
166
-
cty (* Only class bodies can be abbreviated *)
167
-
| Cty_signature _ ->
168
-
cty
169
-
| Cty_arrow (_, _, cty) ->
170
-
class_body cty
171
-
172
-
let extract_constraints cty =
173
-
let sign = Ctype.signature_of_class_type cty in
174
-
(Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
175
-
begin let (fields, _) =
176
-
Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
177
-
in
178
-
List.fold_left
179
-
(fun meths (lab, _, _) ->
180
-
if lab = dummy_method then meths else lab::meths)
181
-
[] fields
182
-
end,
183
-
sign.csig_concr)
184
-
185
-
let rec abbreviate_class_type path params cty =
186
-
match cty with
187
-
Cty_constr (_, _, _) | Cty_signature _ ->
188
-
Cty_constr (path, params, cty)
189
-
| Cty_arrow (l, ty, cty) ->
190
-
Cty_arrow (l, ty, abbreviate_class_type path params cty)
191
-
192
-
(* Check that all type variables are generalizable *)
193
-
(* Use Env.empty to prevent expansion of recursively defined object types;
194
-
cf. typing-poly/poly.ml *)
195
-
let rec closed_class_type =
196
-
function
197
-
Cty_constr (_, params, _) ->
198
-
List.for_all (Ctype.closed_schema Env.empty) params
199
-
| Cty_signature sign ->
200
-
Ctype.closed_schema Env.empty sign.csig_self
201
-
&&
202
-
Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc)
203
-
sign.csig_vars
204
-
true
205
-
| Cty_arrow (_, ty, cty) ->
206
-
Ctype.closed_schema Env.empty ty
207
-
&&
208
-
closed_class_type cty
209
-
210
-
let closed_class cty =
211
-
List.for_all (Ctype.closed_schema Env.empty) cty.cty_params
212
-
&&
213
-
closed_class_type cty.cty_type
214
-
215
-
let rec limited_generalize rv =
216
-
function
217
-
Cty_constr (_path, params, cty) ->
218
-
List.iter (Ctype.limited_generalize rv) params;
219
-
limited_generalize rv cty
220
-
| Cty_signature sign ->
221
-
Ctype.limited_generalize rv sign.csig_self;
222
-
Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
223
-
sign.csig_vars;
224
-
List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
225
-
sign.csig_inher
226
-
| Cty_arrow (_, ty, cty) ->
227
-
Ctype.limited_generalize rv ty;
228
-
limited_generalize rv cty
229
-
230
-
(* Record a class type *)
231
-
let rc node =
232
-
Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
233
-
node
234
-
235
-
236
190
(***********************************)
237
191
(* Primitives for typing classes *)
238
192
(***********************************)
239
193
194
+
let raise_add_method_failure loc env label sign failure =
195
+
match (failure : Ctype.add_method_failure) with
196
+
| Ctype.Unexpected_method ->
197
+
raise(Error(loc, env, Unexpected_field (sign.Types.csig_self, label)))
198
+
| Ctype.Type_mismatch trace ->
199
+
raise(Error(loc, env, Field_type_mismatch ("method", label, trace)))
240
200
241
-
(* Enter a value in the method environment only *)
242
-
let enter_met_env ?check loc lab kind unbound_kind ty class_env =
243
-
let {val_env; met_env; par_env} = class_env in
244
-
let val_env = Env.enter_unbound_value lab unbound_kind val_env in
245
-
let par_env = Env.enter_unbound_value lab unbound_kind par_env in
246
-
let (id, met_env) =
247
-
Env.enter_value ?check lab
248
-
{val_type = ty; val_kind = kind;
249
-
val_attributes = []; Types.val_loc = loc;
250
-
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } met_env
251
-
in
252
-
let class_env = {val_env; met_env; par_env} in
253
-
(id,class_env )
201
+
let raise_add_instance_variable_failure loc env label failure =
202
+
match (failure : Ctype.add_instance_variable_failure) with
203
+
| Ctype.Mutability_mismatch mut ->
204
+
raise (Error(loc, env, Mutability_mismatch(label, mut)))
205
+
| Ctype.Type_mismatch trace ->
206
+
raise (Error(loc, env,
207
+
Field_type_mismatch("instance variable", label, trace)))
254
208
255
-
(* Enter an instance variable in the environment *)
256
-
let enter_val cl_num vars inh lab mut virt ty class_env loc =
257
-
let val_env = class_env.val_env in
258
-
let (id, virt) =
259
-
match Vars.find lab !vars with
260
-
| exception Not_found -> None, virt
261
-
| (id, mut', virt', ty') ->
262
-
if mut' <> mut then
263
-
raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
264
-
match Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty') with
265
-
| () ->
266
-
(if not inh then Some id else None),
267
-
(if virt' = Concrete then virt' else virt)
268
-
| exception Ctype.Unify err ->
269
-
raise (Error(loc, val_env,
270
-
Field_type_mismatch("instance variable", lab, err)))
271
-
in
272
-
let (id, _) as result =
273
-
match id with Some id -> (id, class_env)
274
-
| None ->
275
-
enter_met_env Location.none lab (Val_ivar (mut, cl_num))
276
-
Val_unbound_instance_variable ty class_env
277
-
in
278
-
vars := Vars.add lab (id, mut, virt, ty) !vars;
279
-
result
209
+
let raise_inherit_class_signature_failure loc env sign = function
210
+
| Ctype.Self_type_mismatch trace ->
211
+
raise(Error(loc, env, Self_clash trace))
212
+
| Ctype.Method(label, failure) ->
213
+
raise_add_method_failure loc env label sign failure
214
+
| Ctype.Instance_variable(label, failure) ->
215
+
raise_add_instance_variable_failure loc env label failure
280
216
281
-
let concr_vals vars =
282
-
Vars.fold
283
-
(fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
284
-
vars Concr.empty
285
-
286
-
let inheritance self_type env ovf concr_meths warn_vals loc parent =
287
-
match scrape_class_type parent with
288
-
Cty_signature cl_sig ->
289
-
290
-
(* Methods *)
291
-
begin try
292
-
Ctype.unify env self_type cl_sig.csig_self
293
-
with Ctype.Unify {trace} ->
294
-
match trace with
295
-
| Diff _ :: Incompatible_fields {name = n; _ } :: rem ->
296
-
raise (Error(loc,
297
-
env,
298
-
Field_type_mismatch(
299
-
"method",
300
-
n,
301
-
Errortrace.unification_error ~trace:rem)))
302
-
| _ -> assert false
303
-
end;
304
-
305
-
(* Overriding *)
306
-
let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
307
-
let concr_vals = concr_vals cl_sig.csig_vars in
308
-
let over_vals = Concr.inter concr_vals warn_vals in
309
-
begin match ovf with
310
-
Some Fresh ->
311
-
let cname =
312
-
match parent with
313
-
Cty_constr (p, _, _) -> Path.name p
314
-
| _ -> "inherited"
315
-
in
316
-
if not (Concr.is_empty over_meths) then
317
-
Location.prerr_warning loc
318
-
(Warnings.Method_override (cname :: Concr.elements over_meths));
319
-
if not (Concr.is_empty over_vals) then
320
-
Location.prerr_warning loc
321
-
(Warnings.Instance_variable_override
322
-
(cname :: Concr.elements over_vals));
323
-
| Some Override
324
-
when Concr.is_empty over_meths && Concr.is_empty over_vals ->
325
-
raise (Error(loc, env, No_overriding ("","")))
326
-
| _ -> ()
327
-
end;
217
+
let add_method loc env label priv virt ty sign =
218
+
match Ctype.add_method env label priv virt ty sign with
219
+
| () -> ()
220
+
| exception Ctype.Add_method_failed failure ->
221
+
raise_add_method_failure loc env label sign failure
328
222
329
-
let concr_meths = Concr.union cl_sig.csig_concr concr_meths
330
-
and warn_vals = Concr.union concr_vals warn_vals in
223
+
let add_instance_variable ~strict loc env label mut virt ty sign =
224
+
match Ctype.add_instance_variable ~strict env label mut virt ty sign with
225
+
| () -> ()
226
+
| exception Ctype.Add_instance_variable_failed failure ->
227
+
raise_add_instance_variable_failure loc env label failure
331
228
332
-
(cl_sig, concr_meths, warn_vals)
229
+
let inherit_class_signature ~strict loc env sign1 sign2 =
230
+
match Ctype.inherit_class_signature ~strict env sign1 sign2 with
231
+
| () -> ()
232
+
| exception Ctype.Inherit_class_signature_failed failure ->
233
+
raise_inherit_class_signature_failure loc env sign1 failure
333
234
334
-
| _ ->
335
-
raise(Error(loc, env, Structure_expected parent))
336
-
337
-
let virtual_method val_env meths self_type lab priv sty loc =
338
-
let (_, ty') =
339
-
Ctype.filter_self_method val_env lab priv meths self_type
235
+
let inherit_class_type ~strict loc env sign1 cty2 =
236
+
let sign2 =
237
+
match Btype.scrape_class_type cty2 with
238
+
| Cty_signature sign2 -> sign2
239
+
| _ ->
240
+
raise(Error(loc, env, Structure_expected cty2))
340
241
in
341
-
let sty = Ast_helper.Typ.force_poly sty in
342
-
let cty = transl_simple_type val_env false sty in
343
-
let ty = cty.ctyp_type in
344
-
begin
345
-
try Ctype.unify val_env ty ty' with Ctype.Unify err ->
346
-
raise(Error(loc, val_env, Field_type_mismatch ("method", lab, err)));
347
-
end;
348
-
cty
349
-
350
-
let delayed_meth_specs = ref []
242
+
inherit_class_signature ~strict loc env sign1 sign2
351
243
352
-
let declare_method val_env meths self_type lab priv sty loc =
353
-
let (_, ty') =
354
-
Ctype.filter_self_method val_env lab priv meths self_type
355
-
in
356
-
let unif ty =
357
-
try Ctype.unify val_env ty ty' with Ctype.Unify err ->
358
-
raise(Error(loc, val_env, Field_type_mismatch ("method", lab, err)))
359
-
in
360
-
let sty = Ast_helper.Typ.force_poly sty in
361
-
match sty.ptyp_desc, priv with
362
-
Ptyp_poly ([],sty'), Public ->
363
-
(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
364
-
so that we can get an immediate value. Is that correct ? Ask Jacques. *)
365
-
let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
366
-
delayed_meth_specs :=
367
-
Warnings.mk_lazy (fun () ->
368
-
let cty = transl_simple_type_univars val_env sty' in
369
-
let ty = cty.ctyp_type in
370
-
unif ty;
371
-
returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
372
-
returned_cty.ctyp_type <- ty;
373
-
) ::
374
-
!delayed_meth_specs;
375
-
returned_cty
376
-
| _ ->
377
-
let cty = transl_simple_type val_env false sty in
378
-
let ty = cty.ctyp_type in
379
-
unif ty;
380
-
cty
244
+
let unify_delayed_method_type loc env label ty expected_ty=
245
+
match Ctype.unify env ty expected_ty with
246
+
| () -> ()
247
+
| exception Ctype.Unify trace ->
248
+
raise(Error(loc, env, Field_type_mismatch ("method", label, trace)))
381
249
382
250
let type_constraint val_env sty sty' loc =
383
251
let cty = transl_simple_type val_env false sty in
···
399
267
400
268
(*******************************)
401
269
402
-
let add_val lab (mut, virt, ty) val_sig =
403
-
let virt =
404
-
try
405
-
let (_mut', virt', _ty') = Vars.find lab val_sig in
406
-
if virt' = Concrete then virt' else virt
407
-
with Not_found -> virt
408
-
in
409
-
Vars.add lab (mut, virt, ty) val_sig
410
-
411
-
let rec class_type_field env self_type meths arg ctf =
412
-
Builtin_attributes.warning_scope ctf.pctf_attributes
413
-
(fun () -> class_type_field_aux env self_type meths arg ctf)
414
-
415
-
and class_type_field_aux env self_type meths
416
-
(fields, val_sig, concr_meths, inher) ctf =
270
+
let delayed_meth_specs = ref []
417
271
272
+
let rec class_type_field env sign self_scope ctf =
418
273
let loc = ctf.pctf_loc in
419
274
let mkctf desc =
420
275
{ ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
421
276
in
277
+
let mkctf_with_attrs f =
278
+
Builtin_attributes.warning_scope ctf.pctf_attributes
279
+
(fun () -> mkctf (f ()))
280
+
in
422
281
match ctf.pctf_desc with
423
-
Pctf_inherit sparent ->
424
-
let parent = class_type env sparent in
425
-
let inher =
426
-
match parent.cltyp_type with
427
-
Cty_constr (p, tl, _) -> (p, tl) :: inher
428
-
| _ -> inher
429
-
in
430
-
let (cl_sig, concr_meths, _) =
431
-
inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
432
-
parent.cltyp_type
433
-
in
434
-
let val_sig =
435
-
Vars.fold add_val cl_sig.csig_vars val_sig in
436
-
(mkctf (Tctf_inherit parent) :: fields,
437
-
val_sig, concr_meths, inher)
438
-
282
+
| Pctf_inherit sparent ->
283
+
mkctf_with_attrs
284
+
(fun () ->
285
+
let parent = class_type env Virtual self_scope sparent in
286
+
complete_class_type parent.cltyp_loc
287
+
env Virtual Class_type parent.cltyp_type;
288
+
inherit_class_type ~strict:false loc env sign parent.cltyp_type;
289
+
Tctf_inherit parent)
439
290
| Pctf_val ({txt=lab}, mut, virt, sty) ->
440
-
let cty = transl_simple_type env false sty in
441
-
let ty = cty.ctyp_type in
442
-
(mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
443
-
add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
291
+
mkctf_with_attrs
292
+
(fun () ->
293
+
let cty = transl_simple_type env false sty in
294
+
let ty = cty.ctyp_type in
295
+
add_instance_variable ~strict:false loc env lab mut virt ty sign;
296
+
Tctf_val (lab, mut, virt, cty))
444
297
445
298
| Pctf_method ({txt=lab}, priv, virt, sty) ->
446
-
let cty =
447
-
declare_method env meths self_type lab priv sty ctf.pctf_loc in
448
-
let concr_meths =
449
-
match virt with
450
-
| Concrete -> Concr.add lab concr_meths
451
-
| Virtual -> concr_meths
452
-
in
453
-
(mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
454
-
val_sig, concr_meths, inher)
299
+
mkctf_with_attrs
300
+
(fun () ->
301
+
let sty = Ast_helper.Typ.force_poly sty in
302
+
match sty.ptyp_desc, priv with
303
+
| Ptyp_poly ([],sty'), Public ->
304
+
let expected_ty = Ctype.newvar () in
305
+
add_method loc env lab priv virt expected_ty sign;
306
+
let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) env loc in
307
+
delayed_meth_specs :=
308
+
Warnings.mk_lazy (fun () ->
309
+
let cty = transl_simple_type_univars env sty' in
310
+
let ty = cty.ctyp_type in
311
+
unify_delayed_method_type loc env lab ty expected_ty;
312
+
returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
313
+
returned_cty.ctyp_type <- ty;
314
+
) :: !delayed_meth_specs;
315
+
Tctf_method (lab, priv, virt, returned_cty)
316
+
| _ ->
317
+
let cty = transl_simple_type env false sty in
318
+
let ty = cty.ctyp_type in
319
+
add_method loc env lab priv virt ty sign;
320
+
Tctf_method (lab, priv, virt, cty))
455
321
456
322
| Pctf_constraint (sty, sty') ->
457
-
let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in
458
-
(mkctf (Tctf_constraint (cty, cty')) :: fields,
459
-
val_sig, concr_meths, inher)
323
+
mkctf_with_attrs
324
+
(fun () ->
325
+
let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in
326
+
Tctf_constraint (cty, cty'))
460
327
461
328
| Pctf_attribute x ->
462
329
Builtin_attributes.warning_attribute x;
463
-
(mkctf (Tctf_attribute x) :: fields,
464
-
val_sig, concr_meths, inher)
330
+
mkctf (Tctf_attribute x)
465
331
466
332
| Pctf_extension ext ->
467
333
raise (Error_forward (Builtin_attributes.error_of_extension ext))
468
334
469
-
and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
470
-
let meths = ref Meths.empty in
471
-
let self_cty = transl_simple_type env false sty in
472
-
let self_cty = { self_cty with
473
-
ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
474
-
let self_type = self_cty.ctyp_type in
335
+
and class_signature virt env pcsig self_scope loc =
336
+
let {pcsig_self=sty; pcsig_fields=psign} = pcsig in
337
+
let sign = Ctype.new_class_signature () in
338
+
(* Introduce a dummy method preventing self type from being closed. *)
339
+
Ctype.add_dummy_method env ~scope:self_scope sign;
475
340
476
-
(* Check that the binder is a correct type, and introduce a dummy
477
-
method preventing self type from being closed. *)
478
-
let dummy_obj = Ctype.newvar () in
479
-
Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
480
-
(Ctype.newty (Ttuple []));
341
+
let self_cty = transl_simple_type env false sty in
342
+
let self_type = self_cty.ctyp_type in
481
343
begin try
482
-
Ctype.unify env self_type dummy_obj
344
+
Ctype.unify env self_type sign.csig_self
483
345
with Ctype.Unify _ ->
484
346
raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
485
347
end;
486
348
487
349
(* Class type fields *)
488
-
let (rev_fields, val_sig, concr_meths, inher) =
350
+
let fields =
489
351
Builtin_attributes.warning_scope []
490
-
(fun () ->
491
-
List.fold_left (class_type_field env self_type meths)
492
-
([], Vars.empty, Concr.empty, [])
493
-
sign
494
-
)
352
+
(fun () -> List.map (class_type_field env sign self_scope) psign)
495
353
in
496
-
let cty = {csig_self = self_type;
497
-
csig_vars = val_sig;
498
-
csig_concr = concr_meths;
499
-
csig_inher = inher}
500
-
in
354
+
check_virtual loc env virt Class_type sign;
501
355
{ csig_self = self_cty;
502
-
csig_fields = List.rev rev_fields;
503
-
csig_type = cty;
504
-
}
356
+
csig_fields = fields;
357
+
csig_type = sign; }
505
358
506
-
and class_type env scty =
359
+
and class_type env virt self_scope scty =
507
360
Builtin_attributes.warning_scope scty.pcty_attributes
508
-
(fun () -> class_type_aux env scty)
361
+
(fun () -> class_type_aux env virt self_scope scty)
509
362
510
-
and class_type_aux env scty =
363
+
and class_type_aux env virt self_scope scty =
511
364
let cltyp desc typ =
512
365
{
513
366
cltyp_desc = desc;
···
518
371
}
519
372
in
520
373
match scty.pcty_desc with
521
-
Pcty_constr (lid, styl) ->
374
+
| Pcty_constr (lid, styl) ->
522
375
let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in
523
376
if Path.same decl.clty_path unbound_class then
524
377
raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
525
378
let (params, clty) =
526
379
Ctype.instance_class decl.clty_params decl.clty_type
527
380
in
381
+
(* Adding a dummy method to the self type prevents it from being closed /
382
+
escaping. *)
383
+
Ctype.add_dummy_method env ~scope:self_scope
384
+
(Btype.signature_of_class_type clty);
528
385
if List.length params <> List.length styl then
529
386
raise(Error(scty.pcty_loc, env,
530
387
Parameter_arity_mismatch (lid.txt, List.length params,
···
544
401
cltyp (Tcty_constr ( path, lid , ctys)) typ
545
402
546
403
| Pcty_signature pcsig ->
547
-
let clsig = class_signature env pcsig in
404
+
let clsig = class_signature virt env pcsig self_scope scty.pcty_loc in
548
405
let typ = Cty_signature clsig.csig_type in
549
406
cltyp (Tcty_signature clsig) typ
550
407
···
555
412
if Btype.is_optional l
556
413
then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil))
557
414
else ty in
558
-
let clty = class_type env scty in
415
+
let clty = class_type env virt self_scope scty in
559
416
let typ = Cty_arrow (l, ty, clty.cltyp_type) in
560
417
cltyp (Tcty_arrow (l, cty, clty)) typ
561
418
562
419
| Pcty_open (od, e) ->
563
420
let (od, newenv) = !type_open_descr env od in
564
-
let clty = class_type newenv e in
421
+
let clty = class_type newenv virt self_scope e in
565
422
cltyp (Tcty_open (od, clty)) clty.cltyp_type
566
423
567
424
| Pcty_extension ext ->
568
425
raise (Error_forward (Builtin_attributes.error_of_extension ext))
569
426
570
-
let class_type env scty =
427
+
let class_type env virt self_scope scty =
571
428
delayed_meth_specs := [];
572
-
let cty = class_type env scty in
429
+
let cty = class_type env virt self_scope scty in
573
430
List.iter Lazy.force (List.rev !delayed_meth_specs);
574
431
delayed_meth_specs := [];
575
432
cty
576
433
577
434
(*******************************)
578
435
579
-
let rec class_field self_loc cl_num self_type meths vars arg cf =
580
-
Builtin_attributes.warning_scope cf.pcf_attributes
581
-
(fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf)
436
+
let enter_ancestor_val name val_env =
437
+
Env.enter_unbound_value name Val_unbound_ancestor val_env
438
+
439
+
let enter_self_val name val_env =
440
+
Env.enter_unbound_value name Val_unbound_self val_env
441
+
442
+
let enter_instance_var_val name val_env =
443
+
Env.enter_unbound_value name Val_unbound_instance_variable val_env
444
+
445
+
let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env =
446
+
let check s = Warnings.Unused_ancestor s in
447
+
let kind = Val_anc (sign, meths, cl_num) in
448
+
let desc =
449
+
{ val_type = ty; val_kind = kind;
450
+
val_attributes = attrs;
451
+
Types.val_loc = loc;
452
+
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
453
+
in
454
+
Env.enter_value ~check name desc met_env
582
455
583
-
and class_field_aux self_loc cl_num self_type meths vars
584
-
(class_env, fields, concr_meths, warn_vals, inher,
585
-
local_meths, local_vals) cf =
586
-
let loc = cf.pcf_loc in
587
-
let mkcf desc =
588
-
{ cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
456
+
let add_self_met loc id sign self_var_kind vars cl_num
457
+
as_var ty attrs met_env =
458
+
let check =
459
+
if as_var then (fun s -> Warnings.Unused_var s)
460
+
else (fun s -> Warnings.Unused_var_strict s)
589
461
in
590
-
let {val_env; met_env; par_env} = class_env in
591
-
match cf.pcf_desc with
592
-
Pcf_inherit (ovf, sparent, super) ->
593
-
let parent = class_expr cl_num val_env par_env sparent in
594
-
let inher =
595
-
match parent.cl_type with
596
-
Cty_constr (p, tl, _) -> (p, tl) :: inher
597
-
| _ -> inher
598
-
in
599
-
let (cl_sig, concr_meths, warn_vals) =
600
-
inheritance self_type val_env (Some ovf) concr_meths warn_vals
601
-
sparent.pcl_loc parent.cl_type
602
-
in
603
-
(* Variables *)
604
-
let (class_env, inh_vars) =
605
-
Vars.fold
606
-
(fun lab info (class_env, inh_vars) ->
607
-
let mut, vr, ty = info in
608
-
let (id, class_env) =
609
-
enter_val cl_num vars true lab mut vr ty class_env
610
-
sparent.pcl_loc ;
611
-
in
612
-
(class_env, (lab, id) :: inh_vars))
613
-
cl_sig.csig_vars (class_env, [])
614
-
in
615
-
(* Inherited concrete methods *)
616
-
let inh_meths =
617
-
Concr.fold (fun lab rem -> (lab, Ident.create_local lab)::rem)
618
-
cl_sig.csig_concr []
619
-
in
620
-
(* Super *)
621
-
let (class_env,super) =
622
-
match super with
623
-
None ->
624
-
(class_env,None)
625
-
| Some {txt=name} ->
626
-
let (_id, class_env) =
627
-
enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
628
-
sparent.pcl_loc name (Val_anc (inh_meths, cl_num))
629
-
Val_unbound_ancestor self_type class_env
630
-
in
631
-
(class_env,Some name)
632
-
in
633
-
(class_env,
634
-
lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
635
-
:: fields,
636
-
concr_meths, warn_vals, inher, local_meths, local_vals)
462
+
let kind = Val_self (sign, self_var_kind, vars, cl_num) in
463
+
let desc =
464
+
{ val_type = ty; val_kind = kind;
465
+
val_attributes = attrs;
466
+
Types.val_loc = loc;
467
+
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
468
+
in
469
+
Env.add_value ~check id desc met_env
637
470
638
-
| Pcf_val (lab, mut, Cfk_virtual styp) ->
639
-
if !Clflags.principal then Ctype.begin_def ();
640
-
let cty = Typetexp.transl_simple_type val_env false styp in
641
-
let ty = cty.ctyp_type in
642
-
if !Clflags.principal then begin
643
-
Ctype.end_def ();
644
-
Ctype.generalize_structure ty
645
-
end;
646
-
let (id, class_env') =
647
-
enter_val cl_num vars false lab.txt mut Virtual ty
648
-
class_env loc
649
-
in
650
-
(class_env',
651
-
lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
652
-
met_env == class_env'.met_env)))
653
-
:: fields,
654
-
concr_meths, warn_vals, inher, local_meths, local_vals)
471
+
let add_instance_var_met loc label id sign cl_num attrs met_env =
472
+
let mut, ty =
473
+
match Vars.find label sign.csig_vars with
474
+
| (mut, _, ty) -> mut, ty
475
+
| exception Not_found -> assert false
476
+
in
477
+
let kind = Val_ivar (mut, cl_num) in
478
+
let desc =
479
+
{ val_type = ty; val_kind = kind;
480
+
val_attributes = attrs;
481
+
Types.val_loc = loc;
482
+
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
483
+
in
484
+
Env.add_value id desc met_env
655
485
656
-
| Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
657
-
if Concr.mem lab.txt local_vals then
658
-
raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
659
-
if Concr.mem lab.txt warn_vals then begin
660
-
if ovf = Fresh then
661
-
Location.prerr_warning lab.loc
662
-
(Warnings.Instance_variable_override[lab.txt])
663
-
end else begin
664
-
if ovf = Override then
665
-
raise(Error(loc, val_env,
666
-
No_overriding ("instance variable", lab.txt)))
667
-
end;
668
-
if !Clflags.principal then Ctype.begin_def ();
669
-
let exp = type_exp val_env sexp in
670
-
if !Clflags.principal then begin
671
-
Ctype.end_def ();
672
-
Ctype.generalize_structure exp.exp_type
673
-
end;
674
-
let (id, class_env') =
675
-
enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
676
-
class_env loc
677
-
in
678
-
(class_env',
679
-
lazy (mkcf (Tcf_val (lab, mut, id,
680
-
Tcfk_concrete (ovf, exp), met_env == class_env'.met_env)))
681
-
:: fields,
682
-
concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
683
-
Concr.add lab.txt local_vals)
486
+
let add_instance_vars_met loc vars sign cl_num met_env =
487
+
List.fold_left
488
+
(fun met_env (label, id) ->
489
+
add_instance_var_met loc label id sign cl_num [] met_env)
490
+
met_env vars
684
491
685
-
| Pcf_method (lab, priv, Cfk_virtual sty) ->
686
-
let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
687
-
(class_env,
688
-
lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
689
-
::fields,
690
-
concr_meths, warn_vals, inher, local_meths, local_vals)
492
+
type intermediate_class_field =
493
+
| Inherit of
494
+
{ override : override_flag;
495
+
parent : class_expr;
496
+
super : string option;
497
+
inherited_vars : (string * Ident.t) list;
498
+
super_meths : (string * Ident.t) list;
499
+
loc : Location.t;
500
+
attributes : attribute list; }
501
+
| Virtual_val of
502
+
{ label : string loc;
503
+
mut : mutable_flag;
504
+
id : Ident.t;
505
+
cty : core_type;
506
+
already_declared : bool;
507
+
loc : Location.t;
508
+
attributes : attribute list; }
509
+
| Concrete_val of
510
+
{ label : string loc;
511
+
mut : mutable_flag;
512
+
id : Ident.t;
513
+
override : override_flag;
514
+
definition : expression;
515
+
already_declared : bool;
516
+
loc : Location.t;
517
+
attributes : attribute list; }
518
+
| Virtual_method of
519
+
{ label : string loc;
520
+
priv : private_flag;
521
+
cty : core_type;
522
+
loc : Location.t;
523
+
attributes : attribute list; }
524
+
| Concrete_method of
525
+
{ label : string loc;
526
+
priv : private_flag;
527
+
override : override_flag;
528
+
sdefinition : Parsetree.expression;
529
+
warning_state : Warnings.state;
530
+
loc : Location.t;
531
+
attributes : attribute list; }
532
+
| Constraint of
533
+
{ cty1 : core_type;
534
+
cty2 : core_type;
535
+
loc : Location.t;
536
+
attributes : attribute list; }
537
+
| Initializer of
538
+
{ sexpr : Parsetree.expression;
539
+
warning_state : Warnings.state;
540
+
loc : Location.t;
541
+
attributes : attribute list; }
542
+
| Attribute of
543
+
{ attribute : attribute;
544
+
loc : Location.t;
545
+
attributes : attribute list; }
691
546
692
-
| Pcf_method (lab, priv, Cfk_concrete (ovf, expr)) ->
693
-
let expr =
694
-
match expr.pexp_desc with
695
-
| Pexp_poly _ -> expr
696
-
| _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
697
-
in
698
-
if Concr.mem lab.txt local_meths then
699
-
raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
700
-
if Concr.mem lab.txt concr_meths then begin
701
-
if ovf = Fresh then
702
-
Location.prerr_warning loc (Warnings.Method_override [lab.txt])
703
-
end else begin
704
-
if ovf = Override then
705
-
raise(Error(loc, val_env, No_overriding("method", lab.txt)))
706
-
end;
707
-
let (_, ty) =
708
-
Ctype.filter_self_method val_env lab.txt priv meths self_type
709
-
in
710
-
begin try match expr.pexp_desc with
711
-
Pexp_poly (sbody, sty) ->
712
-
begin match sty with None -> ()
713
-
| Some sty ->
714
-
let sty = Ast_helper.Typ.force_poly sty in
715
-
let cty' = Typetexp.transl_simple_type val_env false sty in
716
-
let ty' = cty'.ctyp_type in
717
-
Ctype.unify val_env ty' ty
718
-
end;
719
-
begin match get_desc ty with
720
-
Tvar _ ->
721
-
let ty' = Ctype.newvar () in
722
-
Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
723
-
Ctype.unify val_env (type_approx val_env sbody) ty'
724
-
| Tpoly (ty1, tl) ->
725
-
let _, ty1' = Ctype.instance_poly false tl ty1 in
726
-
let ty2 = type_approx val_env sbody in
727
-
Ctype.unify val_env ty2 ty1'
728
-
| _ -> assert false
729
-
end
730
-
| _ -> assert false
731
-
with Ctype.Unify err ->
732
-
raise(Error(loc, val_env,
733
-
Field_type_mismatch ("method", lab.txt, err)))
734
-
end;
735
-
let meth_expr = make_method self_loc cl_num expr in
736
-
(* backup variables for Pexp_override *)
737
-
let vars_local = !vars in
547
+
type first_pass_accummulater =
548
+
{ rev_fields : intermediate_class_field list;
549
+
val_env : Env.t;
550
+
par_env : Env.t;
551
+
concrete_meths : MethSet.t;
552
+
concrete_vals : VarSet.t;
553
+
local_meths : MethSet.t;
554
+
local_vals : VarSet.t;
555
+
vars : Ident.t Vars.t;
556
+
meths : Ident.t Meths.t; }
738
557
739
-
let field =
740
-
Warnings.mk_lazy
741
-
(fun () ->
742
-
(* Read the generalized type *)
743
-
let (_, ty) = Meths.find lab.txt !meths in
744
-
let meth_type = mk_expected (
745
-
Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok))
746
-
) in
747
-
Ctype.raise_nongen_level ();
748
-
vars := vars_local;
749
-
let texp = type_expect met_env meth_expr meth_type in
558
+
let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
559
+
let { rev_fields; val_env; par_env; concrete_meths; concrete_vals;
560
+
local_meths; local_vals; vars; meths } = acc
561
+
in
562
+
let loc = cf.pcf_loc in
563
+
let attributes = cf.pcf_attributes in
564
+
let with_attrs f = Builtin_attributes.warning_scope attributes f in
565
+
match cf.pcf_desc with
566
+
| Pcf_inherit (override, sparent, super) ->
567
+
with_attrs
568
+
(fun () ->
569
+
let parent =
570
+
class_expr cl_num val_env par_env
571
+
Virtual self_scope sparent
572
+
in
573
+
complete_class_type parent.cl_loc
574
+
par_env Virtual Class parent.cl_type;
575
+
inherit_class_type ~strict:true loc val_env sign parent.cl_type;
576
+
let parent_sign = Btype.signature_of_class_type parent.cl_type in
577
+
let new_concrete_meths = Btype.concrete_methods parent_sign in
578
+
let new_concrete_vals = Btype.concrete_instance_vars parent_sign in
579
+
let over_meths = MethSet.inter new_concrete_meths concrete_meths in
580
+
let over_vals = VarSet.inter new_concrete_vals concrete_vals in
581
+
begin match override with
582
+
| Fresh ->
583
+
let cname =
584
+
match parent.cl_type with
585
+
| Cty_constr (p, _, _) -> Path.name p
586
+
| _ -> "inherited"
587
+
in
588
+
if not (MethSet.is_empty over_meths) then
589
+
Location.prerr_warning loc
590
+
(Warnings.Method_override
591
+
(cname :: MethSet.elements over_meths));
592
+
if not (VarSet.is_empty over_vals) then
593
+
Location.prerr_warning loc
594
+
(Warnings.Instance_variable_override
595
+
(cname :: VarSet.elements over_vals));
596
+
| Override ->
597
+
if MethSet.is_empty over_meths && VarSet.is_empty over_vals then
598
+
raise (Error(loc, val_env, No_overriding ("","")))
599
+
end;
600
+
let concrete_vals = VarSet.union new_concrete_vals concrete_vals in
601
+
let concrete_meths =
602
+
MethSet.union new_concrete_meths concrete_meths
603
+
in
604
+
let val_env, par_env, inherited_vars, vars =
605
+
Vars.fold
606
+
(fun label _ (val_env, par_env, inherited_vars, vars) ->
607
+
let val_env = enter_instance_var_val label val_env in
608
+
let par_env = enter_instance_var_val label par_env in
609
+
let id = Ident.create_local label in
610
+
let inherited_vars = (label, id) :: inherited_vars in
611
+
let vars = Vars.add label id vars in
612
+
(val_env, par_env, inherited_vars, vars))
613
+
parent_sign.csig_vars (val_env, par_env, [], vars)
614
+
in
615
+
let meths =
616
+
Meths.fold
617
+
(fun label _ meths ->
618
+
if Meths.mem label meths then meths
619
+
else Meths.add label (Ident.create_local label) meths)
620
+
parent_sign.csig_meths meths
621
+
in
622
+
(* Methods available through super *)
623
+
let super_meths =
624
+
MethSet.fold
625
+
(fun label acc -> (label, Ident.create_local label) :: acc)
626
+
new_concrete_meths []
627
+
in
628
+
(* Super *)
629
+
let (val_env, par_env, super) =
630
+
match super with
631
+
| None -> (val_env, par_env, None)
632
+
| Some {txt=name} ->
633
+
let val_env = enter_ancestor_val name val_env in
634
+
let par_env = enter_ancestor_val name par_env in
635
+
(val_env, par_env, Some name)
636
+
in
637
+
let field =
638
+
Inherit
639
+
{ override; parent; super; inherited_vars;
640
+
super_meths; loc; attributes }
641
+
in
642
+
let rev_fields = field :: rev_fields in
643
+
{ acc with rev_fields; val_env; par_env;
644
+
concrete_meths; concrete_vals; vars; meths })
645
+
| Pcf_val (label, mut, Cfk_virtual styp) ->
646
+
with_attrs
647
+
(fun () ->
648
+
if !Clflags.principal then Ctype.begin_def ();
649
+
let cty = Typetexp.transl_simple_type val_env false styp in
650
+
let ty = cty.ctyp_type in
651
+
if !Clflags.principal then begin
652
+
Ctype.end_def ();
653
+
Ctype.generalize_structure ty
654
+
end;
655
+
add_instance_variable ~strict:true loc val_env
656
+
label.txt mut Virtual ty sign;
657
+
let already_declared, val_env, par_env, id, vars =
658
+
match Vars.find label.txt vars with
659
+
| id -> true, val_env, par_env, id, vars
660
+
| exception Not_found ->
661
+
let name = label.txt in
662
+
let val_env = enter_instance_var_val name val_env in
663
+
let par_env = enter_instance_var_val name par_env in
664
+
let id = Ident.create_local name in
665
+
let vars = Vars.add label.txt id vars in
666
+
false, val_env, par_env, id, vars
667
+
in
668
+
let field =
669
+
Virtual_val
670
+
{ label; mut; id; cty; already_declared; loc; attributes }
671
+
in
672
+
let rev_fields = field :: rev_fields in
673
+
{ acc with rev_fields; val_env; par_env; vars })
674
+
| Pcf_val (label, mut, Cfk_concrete (override, sdefinition)) ->
675
+
with_attrs
676
+
(fun () ->
677
+
if VarSet.mem label.txt local_vals then
678
+
raise(Error(loc, val_env,
679
+
Duplicate ("instance variable", label.txt)));
680
+
if VarSet.mem label.txt concrete_vals then begin
681
+
if override = Fresh then
682
+
Location.prerr_warning label.loc
683
+
(Warnings.Instance_variable_override[label.txt])
684
+
end else begin
685
+
if override = Override then
686
+
raise(Error(loc, val_env,
687
+
No_overriding ("instance variable", label.txt)))
688
+
end;
689
+
if !Clflags.principal then Ctype.begin_def ();
690
+
let definition = type_exp val_env sdefinition in
691
+
if !Clflags.principal then begin
750
692
Ctype.end_def ();
751
-
mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
752
-
)
753
-
in
754
-
(class_env, field::fields,
755
-
Concr.add lab.txt concr_meths, warn_vals, inher,
756
-
Concr.add lab.txt local_meths, local_vals)
693
+
Ctype.generalize_structure definition.exp_type
694
+
end;
695
+
add_instance_variable ~strict:true loc val_env
696
+
label.txt mut Concrete definition.exp_type sign;
697
+
let already_declared, val_env, par_env, id, vars =
698
+
match Vars.find label.txt vars with
699
+
| id -> true, val_env, par_env, id, vars
700
+
| exception Not_found ->
701
+
let name = label.txt in
702
+
let val_env = enter_instance_var_val name val_env in
703
+
let par_env = enter_instance_var_val name par_env in
704
+
let id = Ident.create_local name in
705
+
let vars = Vars.add label.txt id vars in
706
+
false, val_env, par_env, id, vars
707
+
in
708
+
let field =
709
+
Concrete_val
710
+
{ label; mut; id; override; definition;
711
+
already_declared; loc; attributes }
712
+
in
713
+
let rev_fields = field :: rev_fields in
714
+
let concrete_vals = VarSet.add label.txt concrete_vals in
715
+
let local_vals = VarSet.add label.txt local_vals in
716
+
{ acc with rev_fields; val_env; par_env;
717
+
concrete_vals; local_vals; vars })
718
+
719
+
| Pcf_method (label, priv, Cfk_virtual sty) ->
720
+
with_attrs
721
+
(fun () ->
722
+
let sty = Ast_helper.Typ.force_poly sty in
723
+
let cty = transl_simple_type val_env false sty in
724
+
let ty = cty.ctyp_type in
725
+
add_method loc val_env label.txt priv Virtual ty sign;
726
+
let meths =
727
+
if Meths.mem label.txt meths then meths
728
+
else Meths.add label.txt (Ident.create_local label.txt) meths
729
+
in
730
+
let field =
731
+
Virtual_method { label; priv; cty; loc; attributes }
732
+
in
733
+
let rev_fields = field :: rev_fields in
734
+
{ acc with rev_fields; meths })
735
+
736
+
| Pcf_method (label, priv, Cfk_concrete (override, expr)) ->
737
+
with_attrs
738
+
(fun () ->
739
+
if MethSet.mem label.txt local_meths then
740
+
raise(Error(loc, val_env, Duplicate ("method", label.txt)));
741
+
if MethSet.mem label.txt concrete_meths then begin
742
+
if override = Fresh then begin
743
+
Location.prerr_warning loc
744
+
(Warnings.Method_override [label.txt])
745
+
end
746
+
end else begin
747
+
if override = Override then begin
748
+
raise(Error(loc, val_env, No_overriding("method", label.txt)))
749
+
end
750
+
end;
751
+
let expr =
752
+
match expr.pexp_desc with
753
+
| Pexp_poly _ -> expr
754
+
| _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
755
+
in
756
+
let sbody, sty =
757
+
match expr.pexp_desc with
758
+
| Pexp_poly (sbody, sty) -> sbody, sty
759
+
| _ -> assert false
760
+
in
761
+
let ty =
762
+
match sty with
763
+
| None -> Ctype.newvar ()
764
+
| Some sty ->
765
+
let sty = Ast_helper.Typ.force_poly sty in
766
+
let cty' =
767
+
Typetexp.transl_simple_type val_env false sty
768
+
in
769
+
cty'.ctyp_type
770
+
in
771
+
add_method loc val_env label.txt priv Concrete ty sign;
772
+
begin
773
+
try
774
+
match get_desc ty with
775
+
| Tvar _ ->
776
+
let ty' = Ctype.newvar () in
777
+
Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
778
+
Ctype.unify val_env (type_approx val_env sbody) ty'
779
+
| Tpoly (ty1, tl) ->
780
+
let _, ty1' = Ctype.instance_poly false tl ty1 in
781
+
let ty2 = type_approx val_env sbody in
782
+
Ctype.unify val_env ty2 ty1'
783
+
| _ -> assert false
784
+
with Ctype.Unify err ->
785
+
raise(Error(loc, val_env,
786
+
Field_type_mismatch ("method", label.txt, err)))
787
+
end;
788
+
let meths =
789
+
if Meths.mem label.txt meths then meths
790
+
else Meths.add label.txt (Ident.create_local label.txt) meths
791
+
in
792
+
let sdefinition = make_method self_loc cl_num expr in
793
+
let warning_state = Warnings.backup () in
794
+
let field =
795
+
Concrete_method
796
+
{ label; priv; override; sdefinition;
797
+
warning_state; loc; attributes }
798
+
in
799
+
let rev_fields = field :: rev_fields in
800
+
let concrete_meths = MethSet.add label.txt concrete_meths in
801
+
let local_meths = MethSet.add label.txt local_meths in
802
+
{ acc with rev_fields; concrete_meths; local_meths; meths })
757
803
758
-
| Pcf_constraint (sty, sty') ->
759
-
let (cty, cty') = type_constraint val_env sty sty' loc in
760
-
(class_env,
761
-
lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
762
-
concr_meths, warn_vals, inher, local_meths, local_vals)
804
+
| Pcf_constraint (sty1, sty2) ->
805
+
with_attrs
806
+
(fun () ->
807
+
let (cty1, cty2) = type_constraint val_env sty1 sty2 loc in
808
+
let field =
809
+
Constraint { cty1; cty2; loc; attributes }
810
+
in
811
+
let rev_fields = field :: rev_fields in
812
+
{ acc with rev_fields })
763
813
764
-
| Pcf_initializer expr ->
765
-
let expr = make_method self_loc cl_num expr in
766
-
let vars_local = !vars in
767
-
let field =
768
-
lazy begin
769
-
Ctype.raise_nongen_level ();
770
-
let meth_type = mk_expected (
771
-
Ctype.newty
772
-
(Tarrow (Nolabel, self_type,
773
-
Ctype.instance Predef.type_unit, Cok))
774
-
) in
775
-
vars := vars_local;
776
-
let texp = type_expect met_env expr meth_type in
777
-
Ctype.end_def ();
778
-
mkcf (Tcf_initializer texp)
779
-
end in
780
-
(class_env, field::fields, concr_meths, warn_vals,
781
-
inher, local_meths, local_vals)
782
-
| Pcf_attribute x ->
783
-
Builtin_attributes.warning_attribute x;
784
-
(class_env,
785
-
lazy (mkcf (Tcf_attribute x)) :: fields,
786
-
concr_meths, warn_vals, inher, local_meths, local_vals)
814
+
| Pcf_initializer sexpr ->
815
+
with_attrs
816
+
(fun () ->
817
+
let sexpr = make_method self_loc cl_num sexpr in
818
+
let warning_state = Warnings.backup () in
819
+
let field =
820
+
Initializer { sexpr; warning_state; loc; attributes }
821
+
in
822
+
let rev_fields = field :: rev_fields in
823
+
{ acc with rev_fields })
824
+
| Pcf_attribute attribute ->
825
+
Builtin_attributes.warning_attribute attribute;
826
+
let field = Attribute { attribute; loc; attributes } in
827
+
let rev_fields = field :: rev_fields in
828
+
{ acc with rev_fields }
787
829
| Pcf_extension ext ->
788
830
raise (Error_forward (Builtin_attributes.error_of_extension ext))
789
831
832
+
and class_fields_first_pass self_loc cl_num sign self_scope
833
+
val_env par_env cfs =
834
+
let rev_fields = [] in
835
+
let concrete_meths = MethSet.empty in
836
+
let concrete_vals = VarSet.empty in
837
+
let local_meths = MethSet.empty in
838
+
let local_vals = VarSet.empty in
839
+
let vars = Vars.empty in
840
+
let meths = Meths.empty in
841
+
let init_acc =
842
+
{ rev_fields; val_env; par_env;
843
+
concrete_meths; concrete_vals;
844
+
local_meths; local_vals; vars; meths }
845
+
in
846
+
let acc =
847
+
Builtin_attributes.warning_scope []
848
+
(fun () ->
849
+
List.fold_left
850
+
(class_field_first_pass self_loc cl_num sign self_scope)
851
+
init_acc cfs)
852
+
in
853
+
List.rev acc.rev_fields, acc.vars, acc.meths
854
+
855
+
and class_field_second_pass cl_num sign met_env field =
856
+
let mkcf desc loc attrs =
857
+
{ cf_desc = desc; cf_loc = loc; cf_attributes = attrs }
858
+
in
859
+
match field with
860
+
| Inherit { override; parent; super;
861
+
inherited_vars; super_meths; loc; attributes } ->
862
+
let met_env =
863
+
add_instance_vars_met loc inherited_vars sign cl_num met_env
864
+
in
865
+
let met_env =
866
+
match super with
867
+
| None -> met_env
868
+
| Some name ->
869
+
let meths =
870
+
List.fold_left
871
+
(fun acc (label, id) -> Meths.add label id acc)
872
+
Meths.empty super_meths
873
+
in
874
+
let ty = Btype.self_type parent.cl_type in
875
+
let attrs = [] in
876
+
let _id, met_env =
877
+
enter_ancestor_met ~loc name ~sign ~meths
878
+
~cl_num ~ty ~attrs met_env
879
+
in
880
+
met_env
881
+
in
882
+
let desc =
883
+
Tcf_inherit(override, parent, super, inherited_vars, super_meths)
884
+
in
885
+
met_env, mkcf desc loc attributes
886
+
| Virtual_val { label; mut; id; cty; already_declared; loc; attributes } ->
887
+
let met_env =
888
+
if already_declared then met_env
889
+
else begin
890
+
add_instance_var_met loc label.txt id sign cl_num attributes met_env
891
+
end
892
+
in
893
+
let kind = Tcfk_virtual cty in
894
+
let desc = Tcf_val(label, mut, id, kind, already_declared) in
895
+
met_env, mkcf desc loc attributes
896
+
| Concrete_val { label; mut; id; override;
897
+
definition; already_declared; loc; attributes } ->
898
+
let met_env =
899
+
if already_declared then met_env
900
+
else begin
901
+
add_instance_var_met loc label.txt id sign cl_num attributes met_env
902
+
end
903
+
in
904
+
let kind = Tcfk_concrete(override, definition) in
905
+
let desc = Tcf_val(label, mut, id, kind, already_declared) in
906
+
met_env, mkcf desc loc attributes
907
+
| Virtual_method { label; priv; cty; loc; attributes } ->
908
+
let kind = Tcfk_virtual cty in
909
+
let desc = Tcf_method(label, priv, kind) in
910
+
met_env, mkcf desc loc attributes
911
+
| Concrete_method { label; priv; override;
912
+
sdefinition; warning_state; loc; attributes } ->
913
+
Warnings.with_state warning_state
914
+
(fun () ->
915
+
let ty = Btype.method_type label.txt sign in
916
+
let self_type = sign.Types.csig_self in
917
+
let meth_type =
918
+
mk_expected
919
+
(Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok)))
920
+
in
921
+
Ctype.raise_nongen_level ();
922
+
let texp = type_expect met_env sdefinition meth_type in
923
+
Ctype.end_def ();
924
+
let kind = Tcfk_concrete (override, texp) in
925
+
let desc = Tcf_method(label, priv, kind) in
926
+
met_env, mkcf desc loc attributes)
927
+
| Constraint { cty1; cty2; loc; attributes } ->
928
+
let desc = Tcf_constraint(cty1, cty2) in
929
+
met_env, mkcf desc loc attributes
930
+
| Initializer { sexpr; warning_state; loc; attributes } ->
931
+
Warnings.with_state warning_state
932
+
(fun () ->
933
+
Ctype.raise_nongen_level ();
934
+
let unit_type = Ctype.instance Predef.type_unit in
935
+
let self_type = sign.Types.csig_self in
936
+
let meth_type =
937
+
mk_expected
938
+
(Ctype.newty (Tarrow (Nolabel, self_type, unit_type, Cok)))
939
+
in
940
+
let texp = type_expect met_env sexpr meth_type in
941
+
Ctype.end_def ();
942
+
let desc = Tcf_initializer texp in
943
+
met_env, mkcf desc loc attributes)
944
+
| Attribute { attribute; loc; attributes; } ->
945
+
let desc = Tcf_attribute attribute in
946
+
met_env, mkcf desc loc attributes
947
+
948
+
and class_fields_second_pass cl_num sign met_env fields =
949
+
let _, rev_cfs =
950
+
List.fold_left
951
+
(fun (met_env, cfs) field ->
952
+
let met_env, cf =
953
+
class_field_second_pass cl_num sign met_env field
954
+
in
955
+
met_env, cf :: cfs)
956
+
(met_env, []) fields
957
+
in
958
+
List.rev rev_cfs
959
+
790
960
(* N.B. the self type of a final object type doesn't contain a dummy method in
791
961
the beginning.
792
962
We only explicitly add a dummy method to class definitions (and class (type)
···
796
966
somehow we've unified the self type of the object with the self type of a not
797
967
yet finished class.
798
968
When this happens, we cannot close the object type and must error. *)
799
-
and class_structure cl_num final val_env met_env loc
969
+
and class_structure cl_num virt self_scope final val_env met_env loc
800
970
{ pcstr_self = spat; pcstr_fields = str } =
801
971
(* Environment for substructures *)
802
972
let par_env = met_env in
···
804
974
(* Location of self. Used for locations of self arguments *)
805
975
let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
806
976
807
-
let self_type = Ctype.newobj (Ctype.newvar ()) in
977
+
let sign = Ctype.new_class_signature () in
808
978
809
-
(* Adding a dummy method to the self type prevents it from being closed /
810
-
escaping.
811
-
That isn't needed for objects though. *)
812
-
if not final then
813
-
Ctype.unify val_env
814
-
(Ctype.filter_method val_env dummy_method Private self_type)
815
-
(Ctype.newty (Ttuple []));
816
-
817
-
(* Private self is used for private method calls *)
818
-
let private_self = if final then Ctype.newvar () else self_type in
979
+
(* Adding a dummy method to the signature prevents it from being closed /
980
+
escaping. That isn't needed for objects though. *)
981
+
begin match final with
982
+
| Not_final -> Ctype.add_dummy_method val_env ~scope:self_scope sign;
983
+
| Final -> ()
984
+
end;
819
985
820
986
(* Self binder *)
821
-
let (pat, meths, vars, val_env, met_env, par_env) =
822
-
type_self_pattern cl_num private_self val_env met_env par_env spat
987
+
let (self_pat, self_pat_vars) = type_self_pattern val_env spat in
988
+
let val_env, par_env =
989
+
List.fold_right
990
+
(fun {pv_id; _} (val_env, par_env) ->
991
+
let name = Ident.name pv_id in
992
+
let val_env = enter_self_val name val_env in
993
+
let par_env = enter_self_val name par_env in
994
+
val_env, par_env)
995
+
self_pat_vars (val_env, par_env)
823
996
in
824
-
let public_self = pat.pat_type in
825
997
826
998
(* Check that the binder has a correct type *)
827
-
let ty =
828
-
if final then Ctype.newobj (Ctype.newvar()) else self_type in
829
-
begin try Ctype.unify val_env public_self ty with
999
+
begin try Ctype.unify val_env self_pat.pat_type sign.csig_self with
830
1000
Ctype.Unify _ ->
831
-
raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
832
-
end;
833
-
let get_methods ty =
834
-
(fst (Ctype.flatten_fields
835
-
(Ctype.object_fields (Ctype.expand_head val_env ty)))) in
836
-
if final then begin
837
-
(* Copy known information to still empty self_type *)
838
-
List.iter
839
-
(fun (lab,kind,ty) ->
840
-
let k =
841
-
if Types.field_kind_repr kind = Fpresent then Public else Private in
842
-
try Ctype.unify val_env ty
843
-
(Ctype.filter_method val_env lab k self_type)
844
-
with _ -> assert false)
845
-
(get_methods public_self)
1001
+
raise(Error(spat.ppat_loc, val_env,
1002
+
Pattern_type_clash self_pat.pat_type))
846
1003
end;
847
1004
848
1005
(* Typing of class fields *)
849
-
let class_env = {val_env; met_env; par_env} in
850
-
let (_, fields, concr_meths, _, inher, _local_meths, _local_vals) =
851
-
Builtin_attributes.warning_scope []
852
-
(fun () ->
853
-
List.fold_left (class_field self_loc cl_num self_type meths vars)
854
-
( class_env,[], Concr.empty, Concr.empty, [],
855
-
Concr.empty, Concr.empty)
856
-
str
857
-
)
1006
+
let (fields, vars, meths) =
1007
+
class_fields_first_pass self_loc cl_num sign self_scope
1008
+
val_env par_env str
858
1009
in
859
-
Ctype.unify val_env self_type (Ctype.newvar ()); (* useless ? *)
860
-
let sign =
861
-
{csig_self = public_self;
862
-
csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
863
-
csig_concr = concr_meths;
864
-
csig_inher = inher} in
865
-
let methods = get_methods self_type in
866
-
let priv_meths =
867
-
List.filter (fun (_,kind,_) -> Types.field_kind_repr kind <> Fpresent)
868
-
methods in
869
-
(* ensure that inherited methods are listed too *)
870
-
List.iter (fun (met, _kind, _ty) ->
871
-
if Meths.mem met !meths then () else
872
-
ignore (Ctype.filter_self_method val_env met Private meths self_type))
873
-
methods;
874
-
if final then begin
875
-
(* Unify private_self and a copy of self_type. self_type will not
876
-
be modified after this point *)
877
-
if not (Ctype.close_object self_type) then
878
-
raise(Error(loc, val_env, Closing_self_type self_type));
879
-
let mets = virtual_methods {sign with csig_self = self_type} in
880
-
let vals =
881
-
Vars.fold
882
-
(fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
883
-
sign.csig_vars [] in
884
-
if mets <> [] || vals <> [] then
885
-
raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
886
-
let self_methods =
887
-
List.fold_right
888
-
(fun (lab,kind,ty) rem ->
889
-
Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
890
-
methods (Ctype.newty Tnil) in
891
-
begin try
892
-
Ctype.unify val_env private_self
893
-
(Ctype.newty (Tobject(self_methods, ref None)));
894
-
Ctype.unify val_env public_self self_type
895
-
with Ctype.Unify err -> raise(Error(loc, val_env, Final_self_clash err))
896
-
end;
897
-
end;
1010
+
let kind = kind_of_final final in
1011
+
1012
+
(* Check for unexpected virtual methods *)
1013
+
check_virtual loc val_env virt kind sign;
1014
+
1015
+
(* Update the class signature *)
1016
+
update_class_signature loc val_env
1017
+
~warn_implicit_public:false virt kind sign;
898
1018
899
-
(* Typing of method bodies *)
900
-
(* if !Clflags.principal then *) begin
901
-
let ms = !meths in
902
-
(* Generalize the spine of methods accessed through self *)
903
-
Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
904
-
meths :=
905
-
Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms;
906
-
(* But keep levels correct on the type of self *)
907
-
Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
1019
+
(* Close the signature if it is final *)
1020
+
begin match final with
1021
+
| Not_final -> ()
1022
+
| Final ->
1023
+
if not (Ctype.close_class_signature val_env sign) then
1024
+
raise(Error(loc, val_env, Closing_self_type sign));
908
1025
end;
909
-
let fields = List.map Lazy.force (List.rev fields) in
910
-
let meths = Meths.map (function (id, _ty) -> id) !meths in
1026
+
(* Typing of method bodies *)
1027
+
Ctype.generalize_class_signature_spine val_env sign;
1028
+
let self_var_kind =
1029
+
match virt with
1030
+
| Virtual -> Self_virtual(ref meths)
1031
+
| Concrete -> Self_concrete meths
1032
+
in
1033
+
let met_env =
1034
+
List.fold_right
1035
+
(fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env ->
1036
+
add_self_met pv_loc pv_id sign self_var_kind vars
1037
+
cl_num pv_as_var pv_type pv_attributes met_env)
1038
+
self_pat_vars met_env
1039
+
in
1040
+
let fields =
1041
+
class_fields_second_pass cl_num sign met_env fields
1042
+
in
1043
+
1044
+
(* Update the class signature and warn about public methods made private *)
1045
+
update_class_signature loc val_env
1046
+
~warn_implicit_public:true virt kind sign;
911
1047
912
-
(* Check for private methods made public *)
913
-
let pub_meths' =
914
-
List.filter (fun (_,kind,_) -> Types.field_kind_repr kind = Fpresent)
915
-
(get_methods public_self) in
916
-
let names = List.map (fun (x,_,_) -> x) in
917
-
let l1 = names priv_meths and l2 = names pub_meths' in
918
-
let added = List.filter (fun x -> List.mem x l1) l2 in
919
-
if added <> [] then
920
-
Location.prerr_warning loc (Warnings.Implicit_public_methods added);
921
-
let sign = if final then sign else
922
-
{sign with Types.csig_self = Ctype.expand_head val_env public_self} in
923
-
{
924
-
cstr_self = pat;
1048
+
let meths =
1049
+
match self_var_kind with
1050
+
| Self_virtual meths_ref -> !meths_ref
1051
+
| Self_concrete meths -> meths
1052
+
in
1053
+
{ cstr_self = self_pat;
925
1054
cstr_fields = fields;
926
1055
cstr_type = sign;
927
-
cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
1056
+
cstr_meths = meths; }
928
1057
929
-
and class_expr cl_num val_env met_env scl =
1058
+
and class_expr cl_num val_env met_env virt self_scope scl =
930
1059
Builtin_attributes.warning_scope scl.pcl_attributes
931
-
(fun () -> class_expr_aux cl_num val_env met_env scl)
1060
+
(fun () -> class_expr_aux cl_num val_env met_env virt self_scope scl)
932
1061
933
-
and class_expr_aux cl_num val_env met_env scl =
1062
+
and class_expr_aux cl_num val_env met_env virt self_scope scl =
934
1063
match scl.pcl_desc with
935
-
Pcl_constr (lid, styl) ->
1064
+
| Pcl_constr (lid, styl) ->
936
1065
let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in
937
1066
if Path.same decl.cty_path unbound_class then
938
1067
raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
···
943
1072
let (params, clty) =
944
1073
Ctype.instance_class decl.cty_params decl.cty_type
945
1074
in
946
-
let clty' = abbreviate_class_type path params clty in
1075
+
let clty' = Btype.abbreviate_class_type path params clty in
1076
+
(* Adding a dummy method to the self type prevents it from being closed /
1077
+
escaping. *)
1078
+
Ctype.add_dummy_method val_env ~scope:self_scope
1079
+
(Btype.signature_of_class_type clty');
947
1080
if List.length params <> List.length tyl then
948
1081
raise(Error(scl.pcl_loc, val_env,
949
1082
Parameter_arity_mismatch (lid.txt, List.length params,
···
970
1103
cl_attributes = []; (* attributes are kept on the inner cl node *)
971
1104
}
972
1105
| Pcl_structure cl_str ->
973
-
let (desc, ty) =
974
-
class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
1106
+
let desc =
1107
+
class_structure cl_num virt self_scope Not_final
1108
+
val_env met_env scl.pcl_loc cl_str
1109
+
in
975
1110
rc {cl_desc = Tcl_structure desc;
976
1111
cl_loc = scl.pcl_loc;
977
-
cl_type = Cty_signature ty;
1112
+
cl_type = Cty_signature desc.cstr_type;
978
1113
cl_env = val_env;
979
1114
cl_attributes = scl.pcl_attributes;
980
1115
}
···
1007
1142
(* Note: we don't put the '#default' attribute, as it
1008
1143
is not detected for class-level let bindings. See #5975.*)
1009
1144
in
1010
-
class_expr cl_num val_env met_env sfun
1145
+
class_expr cl_num val_env met_env virt self_scope sfun
1011
1146
| Pcl_fun (l, None, spat, scl') ->
1012
1147
if !Clflags.principal then Ctype.begin_def ();
1013
1148
let (pat, pv, val_env', met_env) =
···
1045
1180
[{c_lhs = pat; c_guard = None; c_rhs = dummy}]
1046
1181
in
1047
1182
Ctype.raise_nongen_level ();
1048
-
let cl = class_expr cl_num val_env' met_env scl' in
1183
+
let cl = class_expr cl_num val_env' met_env virt self_scope scl' in
1049
1184
Ctype.end_def ();
1050
1185
if Btype.is_optional l && not_nolabel_function cl.cl_type then
1051
1186
Location.prerr_warning pat.pat_loc
···
1060
1195
| Pcl_apply (scl', sargs) ->
1061
1196
assert (sargs <> []);
1062
1197
if !Clflags.principal then Ctype.begin_def ();
1063
-
let cl = class_expr cl_num val_env met_env scl' in
1198
+
let cl = class_expr cl_num val_env met_env virt self_scope scl' in
1064
1199
if !Clflags.principal then begin
1065
1200
Ctype.end_def ();
1066
-
Ctype.generalize_class_type false cl.cl_type;
1201
+
Ctype.generalize_class_type_structure cl.cl_type;
1067
1202
end;
1068
1203
let rec nonopt_labels ls ty_fun =
1069
1204
match ty_fun with
···
1200
1335
(let_bound_idents_full defs)
1201
1336
([], met_env)
1202
1337
in
1203
-
let cl = class_expr cl_num val_env met_env scl' in
1338
+
let cl = class_expr cl_num val_env met_env virt self_scope scl' in
1204
1339
let () = if rec_flag = Recursive then
1205
1340
check_recursive_bindings val_env defs
1206
1341
in
···
1213
1348
| Pcl_constraint (scl', scty) ->
1214
1349
Ctype.begin_class_def ();
1215
1350
let context = Typetexp.narrow () in
1216
-
let cl = class_expr cl_num val_env met_env scl' in
1351
+
let cl = class_expr cl_num val_env met_env virt self_scope scl' in
1352
+
complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type;
1217
1353
Typetexp.widen context;
1218
1354
let context = Typetexp.narrow () in
1219
-
let clty = class_type val_env scty in
1355
+
let clty = class_type val_env virt self_scope scty in
1356
+
complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type;
1220
1357
Typetexp.widen context;
1221
1358
Ctype.end_def ();
1222
1359
1223
-
limited_generalize
1224
-
(Ctype.row_variable (Ctype.self_type cl.cl_type))
1225
-
cl.cl_type;
1226
-
limited_generalize
1227
-
(Ctype.row_variable (Ctype.self_type clty.cltyp_type))
1228
-
clty.cltyp_type;
1360
+
Ctype.limited_generalize_class_type
1361
+
(Btype.self_type_row cl.cl_type) cl.cl_type;
1362
+
Ctype.limited_generalize_class_type
1363
+
(Btype.self_type_row clty.cltyp_type) clty.cltyp_type;
1229
1364
1230
1365
begin match
1231
1366
Includeclass.class_types val_env cl.cl_type clty.cltyp_type
···
1234
1369
| error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
1235
1370
end;
1236
1371
let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
1372
+
let ty = snd (Ctype.instance_class [] clty.cltyp_type) in
1373
+
(* Adding a dummy method to the self type prevents it from being closed /
1374
+
escaping. *)
1375
+
Ctype.add_dummy_method val_env ~scope:self_scope
1376
+
(Btype.signature_of_class_type ty);
1237
1377
rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
1238
1378
cl_loc = scl.pcl_loc;
1239
-
cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
1379
+
cl_type = ty;
1240
1380
cl_env = val_env;
1241
1381
cl_attributes = scl.pcl_attributes;
1242
1382
}
···
1244
1384
let used_slot = ref false in
1245
1385
let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in
1246
1386
let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in
1247
-
let cl = class_expr cl_num new_val_env new_met_env e in
1387
+
let cl = class_expr cl_num new_val_env new_met_env virt self_scope e in
1248
1388
rc {cl_desc = Tcl_open (od, cl);
1249
1389
cl_loc = scl.pcl_loc;
1250
1390
cl_type = cl.cl_type;
···
1320
1460
let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity uid in
1321
1461
1322
1462
(* Temporary type for the class constructor *)
1463
+
if !Clflags.principal then Ctype.begin_def ();
1323
1464
let constr_type = approx cl.pci_expr in
1324
-
if !Clflags.principal then Ctype.generalize_spine constr_type;
1325
-
let dummy_cty =
1326
-
Cty_signature
1327
-
{ csig_self = Ctype.newvar ();
1328
-
csig_vars = Vars.empty;
1329
-
csig_concr = Concr.empty;
1330
-
csig_inher = [] }
1331
-
in
1465
+
if !Clflags.principal then begin
1466
+
Ctype.end_def ();
1467
+
Ctype.generalize_structure constr_type;
1468
+
end;
1469
+
let dummy_cty = Cty_signature (Ctype.new_class_signature ()) in
1332
1470
let dummy_class =
1333
1471
{Types.cty_params = []; (* Dummy value *)
1334
1472
cty_variance = [];
···
1397
1535
try
1398
1536
Typecore.self_coercion :=
1399
1537
(Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
1400
-
let res = kind env cl.pci_expr in
1538
+
let res = kind env cl.pci_virt cl.pci_expr in
1401
1539
Typecore.self_coercion := List.tl !Typecore.self_coercion;
1402
1540
res
1403
1541
with exn ->
1404
1542
Typecore.self_coercion := []; raise exn
1405
1543
in
1544
+
let sign = Btype.signature_of_class_type typ in
1406
1545
1407
1546
Ctype.end_def ();
1408
1547
1409
-
let sty = Ctype.self_type typ in
1410
-
1411
-
(* First generalize the type of the dummy method (cf PR#6123) *)
1412
-
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
1413
-
List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
1414
-
fields;
1415
1548
(* Generalize the row variable *)
1416
-
let rv = Ctype.row_variable sty in
1417
-
List.iter (Ctype.limited_generalize rv) params;
1418
-
limited_generalize rv typ;
1549
+
List.iter (Ctype.limited_generalize sign.csig_self_row) params;
1550
+
Ctype.limited_generalize_class_type sign.csig_self_row typ;
1419
1551
1420
1552
(* Check the abbreviation for the object type *)
1421
1553
let (obj_params', obj_type) = Ctype.instance_class params typ in
1422
1554
let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
1423
1555
begin
1424
-
let ty = Ctype.self_type obj_type in
1425
-
Ctype.hide_private_methods ty;
1426
-
if not (Ctype.close_object ty) then
1427
-
raise(Error(cl.pci_loc, env, Closing_self_type ty));
1556
+
let row = Btype.self_type_row obj_type in
1557
+
Ctype.unify env row (Ctype.newty Tnil);
1428
1558
begin try
1429
1559
List.iter2 (Ctype.unify env) obj_params obj_params'
1430
1560
with Ctype.Unify _ ->
···
1433
1563
Ctype.newconstr (Path.Pident obj_id)
1434
1564
obj_params')))
1435
1565
end;
1566
+
let ty = Btype.self_type obj_type in
1436
1567
begin try
1437
1568
Ctype.unify env ty constr
1438
1569
with Ctype.Unify _ ->
···
1441
1572
end
1442
1573
end;
1443
1574
1575
+
Ctype.set_object_name obj_id params (Btype.self_type typ);
1576
+
1444
1577
(* Check the other temporary abbreviation (#-type) *)
1445
1578
begin
1446
1579
let (cl_params', cl_type) = Ctype.instance_class params typ in
1447
-
let ty = Ctype.self_type cl_type in
1448
-
Ctype.hide_private_methods ty;
1449
-
Ctype.set_object_name
1450
-
obj_id (Ctype.row_variable ty) cl_params ty;
1580
+
let ty = Btype.self_type cl_type in
1451
1581
begin try
1452
1582
List.iter2 (Ctype.unify env) cl_params cl_params'
1453
1583
with Ctype.Unify _ ->
···
1480
1610
let cty_variance =
1481
1611
Variance.unknown_signature ~injective:false ~arity:(List.length params) in
1482
1612
let cltydef =
1483
-
{clty_params = params; clty_type = class_body typ;
1613
+
{clty_params = params; clty_type = Btype.class_body typ;
1484
1614
clty_variance = cty_variance;
1485
1615
clty_path = Path.Pident obj_id;
1486
1616
clty_loc = cl.pci_loc;
···
1507
1637
if define_class then Env.add_class id clty env else env)
1508
1638
in
1509
1639
1510
-
if cl.pci_virt = Concrete then begin
1511
-
let sign = Ctype.signature_of_class_type typ in
1512
-
let mets = virtual_methods sign in
1513
-
let vals =
1514
-
Vars.fold
1515
-
(fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
1516
-
sign.csig_vars [] in
1517
-
if mets <> [] || vals <> [] then
1518
-
raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
1519
-
vals)));
1520
-
end;
1521
-
1522
1640
(* Misc. *)
1523
-
let arity = Ctype.class_type_arity typ in
1524
-
let pub_meths =
1525
-
let (fields, _) =
1526
-
Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty))
1527
-
in
1528
-
List.map (function (lab, _, _) -> lab) fields
1529
-
in
1641
+
let arity = Btype.class_type_arity typ in
1642
+
let pub_meths = Btype.public_methods sign in
1530
1643
1531
1644
(* Final definitions *)
1532
1645
let (params', typ') = Ctype.instance_class params typ in
1533
1646
let cltydef =
1534
-
{clty_params = params'; clty_type = class_body typ';
1647
+
{clty_params = params'; clty_type = Btype.class_body typ';
1535
1648
clty_variance = cty_variance;
1536
1649
clty_path = Path.Pident obj_id;
1537
1650
clty_loc = cl.pci_loc;
···
1572
1685
}
1573
1686
in
1574
1687
let (cl_params, cl_ty) =
1575
-
Ctype.instance_parameterized_type params (Ctype.self_type typ)
1688
+
Ctype.instance_parameterized_type params (Btype.self_type typ)
1576
1689
in
1577
-
Ctype.hide_private_methods cl_ty;
1578
-
Ctype.set_object_name
1579
-
obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
1690
+
Ctype.set_object_name obj_id cl_params cl_ty;
1580
1691
let cl_abbr =
1581
1692
let arity = List.length cl_params in
1582
1693
{
···
1609
1720
raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err)))
1610
1721
end;
1611
1722
1612
-
(* make the dummy method disappear *)
1613
-
begin
1614
-
let self_type = Ctype.self_type clty.cty_type in
1615
-
let methods, _ =
1616
-
Ctype.flatten_fields
1617
-
(Ctype.object_fields (Ctype.expand_head env self_type))
1618
-
in
1619
-
List.iter (fun (lab,kind,_) ->
1620
-
if lab = dummy_method then
1621
-
match Types.field_kind_repr kind with
1622
-
Fvar r -> Types.set_kind r Fabsent
1623
-
| _ -> ()
1624
-
) methods
1625
-
end;
1626
-
1627
1723
List.iter Ctype.generalize clty.cty_params;
1628
-
Ctype.generalize_class_type true clty.cty_type;
1724
+
Ctype.generalize_class_type clty.cty_type;
1629
1725
Option.iter Ctype.generalize clty.cty_new;
1630
1726
List.iter Ctype.generalize obj_abbr.type_params;
1631
1727
Option.iter Ctype.generalize obj_abbr.type_manifest;
1632
1728
List.iter Ctype.generalize cl_abbr.type_params;
1633
1729
Option.iter Ctype.generalize cl_abbr.type_manifest;
1634
1730
1635
-
if not (closed_class clty) then
1731
+
if Ctype.nongen_class_declaration clty then
1636
1732
raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
1637
1733
1638
1734
begin match
1639
1735
Ctype.closed_class clty.cty_params
1640
-
(Ctype.signature_of_class_type clty.cty_type)
1736
+
(Btype.signature_of_class_type clty.cty_type)
1641
1737
with
1642
1738
None -> ()
1643
1739
| Some reason ->
···
1776
1872
(res, env)
1777
1873
1778
1874
let class_num = ref 0
1779
-
let class_declaration env sexpr =
1875
+
let class_declaration env virt sexpr =
1780
1876
incr class_num;
1781
-
let expr = class_expr (Int.to_string !class_num) env env sexpr in
1877
+
let self_scope = Ctype.get_current_level () in
1878
+
let expr =
1879
+
class_expr (Int.to_string !class_num) env env virt self_scope sexpr
1880
+
in
1881
+
complete_class_type expr.cl_loc env virt Class expr.cl_type;
1782
1882
(expr, expr.cl_type)
1783
1883
1784
-
let class_description env sexpr =
1785
-
let expr = class_type env sexpr in
1884
+
let class_description env virt sexpr =
1885
+
let self_scope = Ctype.get_current_level () in
1886
+
let expr = class_type env virt self_scope sexpr in
1887
+
complete_class_type expr.cltyp_loc env virt Class_type expr.cltyp_type;
1786
1888
(expr, expr.cltyp_type)
1787
1889
1788
1890
let class_declarations env cls =
···
1818
1920
decls,
1819
1921
env)
1820
1922
1821
-
let rec unify_parents env ty cl =
1822
-
match cl.cl_desc with
1823
-
Tcl_ident (p, _, _) ->
1824
-
begin try
1825
-
let decl = Env.find_class p env in
1826
-
let _, body = Ctype.find_cltype_for_path env decl.cty_path in
1827
-
Ctype.unify env ty (Ctype.instance body)
1828
-
with
1829
-
Not_found -> ()
1830
-
| _exn -> assert false
1831
-
end
1832
-
| Tcl_structure st -> unify_parents_struct env ty st
1833
-
| Tcl_open (_, cl)
1834
-
| Tcl_fun (_, _, _, cl, _)
1835
-
| Tcl_apply (cl, _)
1836
-
| Tcl_let (_, _, _, cl)
1837
-
| Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
1838
-
and unify_parents_struct env ty st =
1839
-
List.iter
1840
-
(function
1841
-
| {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
1842
-
unify_parents env ty cl
1843
-
| _ -> ())
1844
-
st.cstr_fields
1845
-
1846
1923
let type_object env loc s =
1847
1924
incr class_num;
1848
-
let (desc, sign) =
1849
-
class_structure (Int.to_string !class_num) true env env loc s in
1850
-
let sty = Ctype.expand_head env sign.csig_self in
1851
-
Ctype.hide_private_methods sty;
1852
-
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
1853
-
let meths = List.map (fun (s,_,_) -> s) fields in
1854
-
unify_parents_struct env sign.csig_self desc;
1855
-
(desc, sign, meths)
1925
+
let desc =
1926
+
class_structure (Int.to_string !class_num)
1927
+
Concrete Btype.lowest_level Final env env loc s
1928
+
in
1929
+
complete_class_signature loc env Concrete Object desc.cstr_type;
1930
+
let meths = Btype.public_methods desc.cstr_type in
1931
+
(desc, meths)
1856
1932
1857
1933
let () =
1858
1934
Typecore.type_object := type_object
···
1875
1951
1876
1952
open Format
1877
1953
1954
+
let non_virtual_string_of_kind = function
1955
+
| Object -> "object"
1956
+
| Class -> "non-virtual class"
1957
+
| Class_type -> "non-virtual class type"
1958
+
1878
1959
let report_error env ppf = function
1879
1960
| Repeated_parameter ->
1880
1961
fprintf ppf "A type parameter occurs several times"
···
1890
1971
fprintf ppf "The %s %s@ has type" k m)
1891
1972
(function ppf ->
1892
1973
fprintf ppf "but is expected to have type")
1974
+
| Unexpected_field (ty, lab) ->
1975
+
Printtyp.reset_and_mark_loops ty;
1976
+
fprintf ppf
1977
+
"@[@[<2>This object is expected to have type :@ %a@]\
1978
+
@ This type does not have a method %s."
1979
+
Printtyp.type_expr ty lab
1893
1980
| Structure_expected clty ->
1894
1981
fprintf ppf
1895
1982
"@[This class expression is not a class structure; it has type@ %a@]"
···
1928
2015
fprintf ppf "The expression \"new %s\" has type" c)
1929
2016
(function ppf ->
1930
2017
fprintf ppf "but is used with type")
1931
-
| Virtual_class (cl, imm, mets, vals) ->
1932
-
let print_mets ppf mets =
1933
-
List.iter (function met -> fprintf ppf "@ %s" met) mets in
2018
+
| Virtual_class (kind, mets, vals) ->
2019
+
let kind = non_virtual_string_of_kind kind in
1934
2020
let missings =
1935
2021
match mets, vals with
1936
2022
[], _ -> "variables"
1937
2023
| _, [] -> "methods"
1938
2024
| _ -> "methods and variables"
1939
2025
in
1940
-
let print_msg ppf =
1941
-
if imm then fprintf ppf "This object has virtual %s" missings
1942
-
else if cl then fprintf ppf "This class should be virtual"
1943
-
else fprintf ppf "This class type should be virtual"
1944
-
in
2026
+
fprintf ppf
2027
+
"@[This %s has virtual %s.@ \
2028
+
@[<2>The following %s are virtual : %a@]@]"
2029
+
kind missings missings
2030
+
(pp_print_list ~pp_sep:pp_print_space pp_print_string) (mets @ vals)
2031
+
| Undeclared_methods(kind, mets) ->
2032
+
let kind = non_virtual_string_of_kind kind in
1945
2033
fprintf ppf
1946
-
"@[%t.@ @[<2>The following %s are undefined :%a@]@]"
1947
-
print_msg missings print_mets (mets @ vals)
2034
+
"@[This %s has undeclared virtual methods.@ \
2035
+
@[<2>The following methods were not declared : %a@]@]"
2036
+
kind (pp_print_list ~pp_sep:pp_print_space pp_print_string) mets
1948
2037
| Parameter_arity_mismatch(lid, expected, provided) ->
1949
2038
fprintf ppf
1950
2039
"@[The class constructor %a@ expects %i type argument(s),@ \
···
1969
2058
| Unbound_val lab ->
1970
2059
fprintf ppf "Unbound instance variable %s" lab
1971
2060
| Unbound_type_var (printer, reason) ->
1972
-
let print_common ppf kind ty0 real lab ty =
2061
+
let print_reason ppf (ty0, real, lab, ty) =
1973
2062
let ty1 =
1974
2063
if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
1975
2064
List.iter Printtyp.mark_loops [ty; ty1];
1976
2065
fprintf ppf
1977
-
"The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
1978
-
kind lab
2066
+
"The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
2067
+
lab
1979
2068
!Oprint.out_type (Printtyp.tree_of_typexp Type ty)
1980
2069
!Oprint.out_type (Printtyp.tree_of_typexp Type ty0)
1981
2070
in
1982
-
let print_reason ppf = function
1983
-
| Ctype.CC_Method (ty0, real, lab, ty) ->
1984
-
print_common ppf "method" ty0 real lab ty
1985
-
| Ctype.CC_Value (ty0, real, lab, ty) ->
1986
-
print_common ppf "instance variable" ty0 real lab ty
1987
-
in
1988
2071
Printtyp.reset ();
1989
2072
fprintf ppf
1990
2073
"@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
···
2010
2093
(fun ppf -> fprintf ppf "Type")
2011
2094
(fun ppf -> fprintf ppf "is not compatible with type")
2012
2095
)
2013
-
| Final_self_clash err ->
2096
+
| Self_clash err ->
2014
2097
Printtyp.report_unification_error ppf env err
2015
2098
(function ppf ->
2016
2099
fprintf ppf "This object is expected to have type")
···
2031
2114
| Duplicate (kind, name) ->
2032
2115
fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
2033
2116
kind name
2034
-
| Closing_self_type self ->
2117
+
| Closing_self_type sign ->
2035
2118
fprintf ppf
2036
2119
"@[Cannot close type of object literal:@ %a@,\
2037
2120
it has been unified with the self type of a class that is not yet@ \
2038
2121
completely defined.@]"
2039
-
Printtyp.type_scheme self
2122
+
Printtyp.type_scheme sign.csig_self
2040
2123
2041
2124
let report_error env ppf err =
2042
2125
Printtyp.wrap_printing_env ~error:true
+12
-6
typing/typeclass.mli
+12
-6
typing/typeclass.mli
···
72
72
val approx_class_declarations:
73
73
Env.t -> Parsetree.class_description list -> class_type_info list
74
74
75
-
val virtual_methods: Types.class_signature -> label list
76
-
77
75
(*
78
76
val type_classes :
79
77
bool ->
···
89
87
list * Env.t
90
88
*)
91
89
90
+
type kind =
91
+
| Object
92
+
| Class
93
+
| Class_type
94
+
92
95
type error =
93
96
| Unconsistent_constraint of Errortrace.unification_error
94
97
| Field_type_mismatch of string * string * Errortrace.unification_error
98
+
| Unexpected_field of type_expr * string
95
99
| Structure_expected of class_type
96
100
| Cannot_apply of class_type
97
101
| Apply_wrong_label of arg_label
···
101
105
| Unbound_class_type_2 of Longident.t
102
106
| Abbrev_type_clash of type_expr * type_expr * type_expr
103
107
| Constructor_type_mismatch of string * Errortrace.unification_error
104
-
| Virtual_class of bool * bool * string list * string list
108
+
| Virtual_class of kind * string list * string list
109
+
| Undeclared_methods of kind * string list
105
110
| Parameter_arity_mismatch of Longident.t * int * int
106
111
| Parameter_mismatch of Errortrace.unification_error
107
112
| Bad_parameters of Ident.t * type_expr * type_expr
108
113
| Class_match_failure of Ctype.class_match_failure list
109
114
| Unbound_val of string
110
-
| Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
115
+
| Unbound_type_var of
116
+
(formatter -> unit) * (type_expr * bool * string * type_expr)
111
117
| Non_generalizable_class of Ident.t * Types.class_declaration
112
118
| Cannot_coerce_self of type_expr
113
119
| Non_collapsable_conjunction of
114
120
Ident.t * Types.class_declaration * Errortrace.unification_error
115
-
| Final_self_clash of Errortrace.unification_error
121
+
| Self_clash of Errortrace.unification_error
116
122
| Mutability_mismatch of string * mutable_flag
117
123
| No_overriding of string * string
118
124
| Duplicate of string * string
119
-
| Closing_self_type of type_expr
125
+
| Closing_self_type of class_signature
120
126
121
127
exception Error of Location.t * Env.t * error
122
128
exception Error_forward of Location.error
+121
-168
typing/typecore.ml
+121
-168
typing/typecore.ml
···
115
115
| Invalid_format of string
116
116
| Not_an_object of type_expr * type_forcing_context option
117
117
| Undefined_method of type_expr * string * string list option
118
-
| Undefined_inherited_method of string * string list
118
+
| Undefined_self_method of string * string list
119
119
| Virtual_class of Longident.t
120
120
| Private_type of type_expr
121
121
| Private_label of Longident.t * type_expr
···
200
200
let type_object =
201
201
ref (fun _env _s -> assert false :
202
202
Env.t -> Location.t -> Parsetree.class_structure ->
203
-
Typedtree.class_structure * Types.class_signature * string list)
203
+
Typedtree.class_structure * string list)
204
204
205
205
(*
206
206
Saving and outputting type information.
···
2210
2210
in
2211
2211
(pat, pv, val_env, met_env)
2212
2212
2213
-
let type_self_pattern cl_num privty val_env met_env par_env spat =
2213
+
let type_self_pattern env spat =
2214
2214
let open Ast_helper in
2215
-
let spat =
2216
-
Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
2217
-
mknoloc ("selfpat-" ^ cl_num)))
2218
-
in
2215
+
let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in
2219
2216
reset_pattern false;
2220
2217
let nv = newvar() in
2221
2218
let pat =
2222
-
type_pat Value ~no_existentials:In_self_pattern (ref val_env) spat nv in
2219
+
type_pat Value ~no_existentials:In_self_pattern (ref env) spat nv in
2223
2220
List.iter (fun f -> f()) (get_ref pattern_force);
2224
-
let meths = ref Meths.empty in
2225
-
let vars = ref Vars.empty in
2226
2221
let pv = !pattern_variables in
2227
2222
pattern_variables := [];
2228
-
let (val_env, met_env, par_env) =
2229
-
List.fold_right
2230
-
(fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
2231
-
(val_env, met_env, par_env) ->
2232
-
let name = Ident.name pv_id in
2233
-
(Env.enter_unbound_value name Val_unbound_self val_env,
2234
-
Env.add_value pv_id
2235
-
{val_type = pv_type;
2236
-
val_kind = Val_self (meths, vars, cl_num, privty);
2237
-
val_attributes = pv_attributes;
2238
-
val_loc = pv_loc;
2239
-
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
2240
-
}
2241
-
~check:(fun s -> if pv_as_var then Warnings.Unused_var s
2242
-
else Warnings.Unused_var_strict s)
2243
-
met_env,
2244
-
Env.enter_unbound_value name Val_unbound_self par_env))
2245
-
pv (val_env, met_env, par_env)
2246
-
in
2247
-
(pat, meths, vars, val_env, met_env, par_env)
2223
+
pat, pv
2248
2224
2249
2225
let delayed_checks = ref []
2250
2226
let reset_delayed_checks () = delayed_checks := []
···
2323
2299
| Texp_ifthenelse(_cond, ifso, ifnot) ->
2324
2300
is_nonexpansive ifso && is_nonexpansive_opt ifnot
2325
2301
| Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *)
2326
-
| Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0
2302
+
| Texp_new (_, _, cl_decl) -> Btype.class_type_arity cl_decl.cty_type > 0
2327
2303
(* Note: nonexpansive only means no _observable_ side effects *)
2328
2304
| Texp_lazy e -> is_nonexpansive e
2329
2305
| Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
···
2826
2802
match lid.txt with
2827
2803
Longident.Lident txt -> { txt; loc = lid.loc }
2828
2804
| _ -> assert false)
2829
-
| Val_self (_, _, cl_num, _) ->
2805
+
| Val_self (_, _, _, cl_num) ->
2830
2806
let (path, _) =
2831
2807
Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
2832
2808
in
···
3435
3411
| Pexp_send (e, {txt=met}) ->
3436
3412
if !Clflags.principal then begin_def ();
3437
3413
let obj = type_exp env e in
3438
-
let obj_meths = ref None in
3439
-
begin try
3440
-
let (meth, exp, typ) =
3441
-
match obj.exp_desc with
3442
-
Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
3443
-
obj_meths := Some meths;
3444
-
let (id, typ) =
3445
-
filter_self_method env met Private meths privty
3446
-
in
3447
-
if is_Tvar typ then
3448
-
Location.prerr_warning loc
3449
-
(Warnings.Undeclared_virtual_method met);
3450
-
(Tmeth_val id, None, typ)
3451
-
| Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
3452
-
let method_id =
3453
-
begin try List.assoc met methods with Not_found ->
3454
-
let valid_methods = List.map fst methods in
3455
-
raise(Error(e.pexp_loc, env,
3456
-
Undefined_inherited_method (met, valid_methods)))
3414
+
let (meth, typ) =
3415
+
match obj.exp_desc with
3416
+
| Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}) ->
3417
+
let id, typ =
3418
+
match meths with
3419
+
| Self_concrete meths ->
3420
+
let id =
3421
+
match Meths.find met meths with
3422
+
| id -> id
3423
+
| exception Not_found ->
3424
+
let valid_methods =
3425
+
Meths.fold (fun lab _ acc -> lab :: acc) meths []
3426
+
in
3427
+
raise (Error(e.pexp_loc, env,
3428
+
Undefined_self_method (met, valid_methods)))
3429
+
in
3430
+
let typ = Btype.method_type met sign in
3431
+
id, typ
3432
+
| Self_virtual meths_ref -> begin
3433
+
match Meths.find met !meths_ref with
3434
+
| id -> id, Btype.method_type met sign
3435
+
| exception Not_found ->
3436
+
let id = Ident.create_local met in
3437
+
let ty = newvar () in
3438
+
meths_ref := Meths.add met id !meths_ref;
3439
+
add_method env met Private Virtual ty sign;
3440
+
Location.prerr_warning loc
3441
+
(Warnings.Undeclared_virtual_method met);
3442
+
id, ty
3457
3443
end
3458
-
in
3459
-
begin match
3460
-
Env.find_value_by_name
3461
-
(Longident.Lident ("selfpat-" ^ cl_num)) env,
3462
-
Env.find_value_by_name
3463
-
(Longident.Lident ("self-" ^cl_num)) env
3464
-
with
3465
-
| (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
3466
-
(path, _) ->
3467
-
obj_meths := Some meths;
3468
-
let (_, typ) =
3469
-
filter_self_method env met Private meths privty
3444
+
in
3445
+
Tmeth_val id, typ
3446
+
| Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}) ->
3447
+
let id =
3448
+
match Meths.find met meths with
3449
+
| id -> id
3450
+
| exception Not_found ->
3451
+
let valid_methods =
3452
+
Meths.fold (fun lab _ acc -> lab :: acc) meths []
3470
3453
in
3471
-
let method_type = newvar () in
3472
-
let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
3473
-
unify env obj_ty desc.val_type;
3474
-
unify env res_ty (instance typ);
3475
-
let method_desc =
3476
-
{val_type = method_type;
3477
-
val_kind = Val_reg;
3478
-
val_attributes = [];
3479
-
val_loc = Location.none;
3480
-
val_uid = Uid.internal_not_actually_unique;
3481
-
}
3482
-
in
3483
-
let exp_env = Env.add_value method_id method_desc env in
3484
-
let exp =
3485
-
Texp_apply({exp_desc =
3486
-
Texp_ident(Path.Pident method_id,
3487
-
lid, method_desc);
3488
-
exp_loc = loc; exp_extra = [];
3489
-
exp_type = method_type;
3490
-
exp_attributes = []; (* check *)
3491
-
exp_env = exp_env},
3492
-
[ Nolabel,
3493
-
Some {exp_desc = Texp_ident(path, lid, desc);
3494
-
exp_loc = obj.exp_loc; exp_extra = [];
3495
-
exp_type = desc.val_type;
3496
-
exp_attributes = []; (* check *)
3497
-
exp_env = exp_env}
3498
-
])
3499
-
in
3500
-
(Tmeth_name met, Some (re {exp_desc = exp;
3501
-
exp_loc = loc; exp_extra = [];
3502
-
exp_type = typ;
3503
-
exp_attributes = []; (* check *)
3504
-
exp_env = exp_env}), typ)
3505
-
| _ ->
3506
-
assert false
3507
-
end
3508
-
| _ ->
3509
-
(Tmeth_name met, None,
3510
-
filter_method env met Public obj.exp_type)
3511
-
in
3512
-
if !Clflags.principal then begin
3513
-
end_def ();
3514
-
generalize_structure typ;
3515
-
end;
3516
-
let typ =
3517
-
match get_desc typ with
3518
-
Tpoly (ty, []) ->
3519
-
instance ty
3520
-
| Tpoly (ty, tl) ->
3521
-
if !Clflags.principal && get_level typ <> generic_level then
3522
-
Location.prerr_warning loc
3523
-
(Warnings.Not_principal "this use of a polymorphic method");
3524
-
snd (instance_poly false tl ty)
3525
-
| Tvar _ ->
3526
-
let ty' = newvar () in
3527
-
unify env (instance typ) (newty(Tpoly(ty',[])));
3528
-
(* if not !Clflags.nolabels then
3529
-
Location.prerr_warning loc (Warnings.Unknown_method met); *)
3530
-
ty'
3531
-
| _ ->
3532
-
assert false
3533
-
in
3534
-
rue {
3535
-
exp_desc = Texp_send(obj, meth, exp);
3536
-
exp_loc = loc; exp_extra = [];
3537
-
exp_type = typ;
3538
-
exp_attributes = sexp.pexp_attributes;
3539
-
exp_env = env }
3540
-
with Filter_method_failed err ->
3541
-
let error =
3542
-
match err with
3543
-
| Unification_error err ->
3544
-
Expr_type_clash(err, explanation, None)
3545
-
| Not_an_object ty ->
3546
-
Not_an_object(ty, explanation)
3547
-
| Not_a_method ->
3548
-
let valid_methods =
3549
-
match !obj_meths with
3550
-
| Some meths ->
3551
-
Some
3552
-
(Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])
3553
-
| None ->
3554
-
match get_desc (expand_head env obj.exp_type) with
3555
-
| Tobject (fields, _) ->
3556
-
let (fields, _) = Ctype.flatten_fields fields in
3557
-
let collect_fields li (meth, meth_kind, _meth_ty) =
3558
-
if meth_kind = Fpresent then meth::li else li in
3559
-
Some (List.fold_left collect_fields [] fields)
3560
-
| _ -> None
3561
-
in
3562
-
Undefined_method(obj.exp_type, met, valid_methods)
3563
-
in
3564
-
raise (Error(e.pexp_loc, env, error))
3565
-
end
3454
+
raise (Error(e.pexp_loc, env,
3455
+
Undefined_self_method (met, valid_methods)))
3456
+
in
3457
+
let typ = Btype.method_type met sign in
3458
+
let (self_path, _) =
3459
+
Env.find_value_by_name
3460
+
(Longident.Lident ("self-" ^ cl_num)) env
3461
+
in
3462
+
Tmeth_ancestor(id, self_path), typ
3463
+
| _ ->
3464
+
let ty =
3465
+
match filter_method env met obj.exp_type with
3466
+
| ty -> ty
3467
+
| exception Filter_method_failed err ->
3468
+
let error =
3469
+
match err with
3470
+
| Unification_error err ->
3471
+
Expr_type_clash(err, explanation, None)
3472
+
| Not_an_object ty ->
3473
+
Not_an_object(ty, explanation)
3474
+
| Not_a_method ->
3475
+
let valid_methods =
3476
+
match get_desc (expand_head env obj.exp_type) with
3477
+
| Tobject (fields, _) ->
3478
+
let (fields, _) = Ctype.flatten_fields fields in
3479
+
let collect_fields li (meth, meth_kind, _meth_ty) =
3480
+
if meth_kind = Fpresent then meth::li else li
3481
+
in
3482
+
Some (List.fold_left collect_fields [] fields)
3483
+
| _ -> None
3484
+
in
3485
+
Undefined_method(obj.exp_type, met, valid_methods)
3486
+
in
3487
+
raise (Error(e.pexp_loc, env, error))
3488
+
in
3489
+
Tmeth_name met, ty
3490
+
in
3491
+
if !Clflags.principal then begin
3492
+
end_def ();
3493
+
generalize_structure typ;
3494
+
end;
3495
+
let typ =
3496
+
match get_desc typ with
3497
+
| Tpoly (ty, []) ->
3498
+
instance ty
3499
+
| Tpoly (ty, tl) ->
3500
+
if !Clflags.principal && get_level typ <> generic_level then
3501
+
Location.prerr_warning loc
3502
+
(Warnings.Not_principal "this use of a polymorphic method");
3503
+
snd (instance_poly false tl ty)
3504
+
| Tvar _ ->
3505
+
let ty' = newvar () in
3506
+
unify env (instance typ) (newty(Tpoly(ty',[])));
3507
+
(* if not !Clflags.nolabels then
3508
+
Location.prerr_warning loc (Warnings.Unknown_method met); *)
3509
+
ty'
3510
+
| _ ->
3511
+
assert false
3512
+
in
3513
+
rue {
3514
+
exp_desc = Texp_send(obj, meth);
3515
+
exp_loc = loc; exp_extra = [];
3516
+
exp_type = typ;
3517
+
exp_attributes = sexp.pexp_attributes;
3518
+
exp_env = env }
3566
3519
| Pexp_new cl ->
3567
3520
let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in
3568
3521
begin match cl_decl.cty_new with
···
3614
3567
with Not_found ->
3615
3568
raise(Error(loc, env, Outside_class))
3616
3569
with
3617
-
(_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
3570
+
(_, {val_type = self_ty; val_kind = Val_self (sign, _, vars, _)}),
3618
3571
(path_self, _) ->
3619
3572
let type_override (lab, snewval) =
3620
3573
begin try
3621
-
let (id, _, _, ty) = Vars.find lab.txt !vars in
3622
-
(Path.Pident id, lab,
3623
-
type_expect env snewval (mk_expected (instance ty)))
3574
+
let id = Vars.find lab.txt vars in
3575
+
let ty = Btype.instance_variable_type lab.txt sign in
3576
+
(id, lab, type_expect env snewval (mk_expected (instance ty)))
3624
3577
with
3625
3578
Not_found ->
3626
-
let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
3579
+
let vars = Vars.fold (fun var _ li -> var::li) vars [] in
3627
3580
raise(Error(loc, env,
3628
3581
Unbound_instance_variable (lab.txt, vars)))
3629
3582
end
···
3718
3671
exp_env = env;
3719
3672
}
3720
3673
| Pexp_object s ->
3721
-
let desc, sign, meths = !type_object env loc s in
3674
+
let desc, meths = !type_object env loc s in
3722
3675
rue {
3723
-
exp_desc = Texp_object (desc, (*sign,*) meths);
3676
+
exp_desc = Texp_object (desc, meths);
3724
3677
exp_loc = loc; exp_extra = [];
3725
-
exp_type = sign.csig_self;
3678
+
exp_type = desc.cstr_type.csig_self;
3726
3679
exp_attributes = sexp.pexp_attributes;
3727
3680
exp_env = env;
3728
3681
}
···
3972
3925
match desc.val_kind with
3973
3926
| Val_ivar _ ->
3974
3927
fatal_error "Illegal name for instance variable"
3975
-
| Val_self (_, _, cl_num, _) ->
3928
+
| Val_self (_, _, _, cl_num) ->
3976
3929
let path, _ =
3977
3930
Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
3978
3931
in
···
5656
5609
| Some valid_methods -> spellcheck ppf me valid_methods
5657
5610
end
5658
5611
)) ()
5659
-
| Undefined_inherited_method (me, valid_methods) ->
5612
+
| Undefined_self_method (me, valid_methods) ->
5660
5613
Location.error_of_printer ~loc (fun ppf () ->
5661
5614
fprintf ppf "This expression has no method %s" me;
5662
5615
spellcheck ppf me valid_methods;
+14
-8
typing/typecore.mli
+14
-8
typing/typecore.mli
···
48
48
explanation: type_forcing_context option;
49
49
}
50
50
51
+
(* Variables in patterns *)
52
+
type pattern_variable =
53
+
{
54
+
pv_id: Ident.t;
55
+
pv_type: type_expr;
56
+
pv_loc: Location.t;
57
+
pv_as_var: bool;
58
+
pv_attributes: Typedtree.attributes;
59
+
}
60
+
51
61
val mk_expected:
52
62
?explanation:type_forcing_context ->
53
63
type_expr ->
···
104
114
(Ident.t * Ident.t * type_expr) list *
105
115
Env.t * Env.t
106
116
val type_self_pattern:
107
-
string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
108
-
Typedtree.pattern *
109
-
(Ident.t * type_expr) Meths.t ref *
110
-
(Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
111
-
Vars.t ref *
112
-
Env.t * Env.t * Env.t
117
+
Env.t -> Parsetree.pattern ->
118
+
Typedtree.pattern * pattern_variable list
113
119
val check_partial:
114
120
?lev:int -> Env.t -> type_expr ->
115
121
Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial
···
159
165
| Invalid_format of string
160
166
| Not_an_object of type_expr * type_forcing_context option
161
167
| Undefined_method of type_expr * string * string list option
162
-
| Undefined_inherited_method of string * string list
168
+
| Undefined_self_method of string * string list
163
169
| Virtual_class of Longident.t
164
170
| Private_type of type_expr
165
171
| Private_label of Longident.t * type_expr
···
233
239
(* Forward declaration, to be filled in by Typeclass.class_structure *)
234
240
val type_object:
235
241
(Env.t -> Location.t -> Parsetree.class_structure ->
236
-
Typedtree.class_structure * Types.class_signature * string list) ref
242
+
Typedtree.class_structure * string list) ref
237
243
val type_package:
238
244
(Env.t -> Parsetree.module_expr -> Path.t -> (Longident.t * type_expr) list ->
239
245
Typedtree.module_expr * (Longident.t * type_expr) list) ref
+5
-4
typing/typedtree.ml
+5
-4
typing/typedtree.ml
···
124
124
| Texp_for of
125
125
Ident.t * Parsetree.pattern * expression * expression * direction_flag *
126
126
expression
127
-
| Texp_send of expression * meth * expression option
127
+
| Texp_send of expression * meth
128
128
| Texp_new of Path.t * Longident.t loc * Types.class_declaration
129
129
| Texp_instvar of Path.t * Path.t * string loc
130
130
| Texp_setinstvar of Path.t * Path.t * string loc * expression
131
-
| Texp_override of Path.t * (Path.t * string loc * expression) list
131
+
| Texp_override of Path.t * (Ident.t * string loc * expression) list
132
132
| Texp_letmodule of
133
133
Ident.t option * string option loc * Types.module_presence * module_expr *
134
134
expression
···
149
149
| Texp_open of open_declaration * expression
150
150
151
151
and meth =
152
-
Tmeth_name of string
152
+
| Tmeth_name of string
153
153
| Tmeth_val of Ident.t
154
+
| Tmeth_ancestor of Ident.t * Path.t
154
155
155
156
and 'k case =
156
157
{
···
194
195
| Tcl_let of rec_flag * value_binding list *
195
196
(Ident.t * expression) list * class_expr
196
197
| Tcl_constraint of
197
-
class_expr * class_type option * string list * string list * Concr.t
198
+
class_expr * class_type option * string list * string list * MethSet.t
198
199
(* Visible instance variables, methods and concrete methods *)
199
200
| Tcl_open of open_description * class_expr
200
201
+5
-3
typing/typedtree.mli
+5
-3
typing/typedtree.mli
···
255
255
| Texp_for of
256
256
Ident.t * Parsetree.pattern * expression * expression * direction_flag *
257
257
expression
258
-
| Texp_send of expression * meth * expression option
258
+
| Texp_send of expression * meth
259
259
| Texp_new of Path.t * Longident.t loc * Types.class_declaration
260
260
| Texp_instvar of Path.t * Path.t * string loc
261
261
| Texp_setinstvar of Path.t * Path.t * string loc * expression
262
-
| Texp_override of Path.t * (Path.t * string loc * expression) list
262
+
| Texp_override of Path.t * (Ident.t * string loc * expression) list
263
263
| Texp_letmodule of
264
264
Ident.t option * string option loc * Types.module_presence * module_expr *
265
265
expression
···
283
283
and meth =
284
284
Tmeth_name of string
285
285
| Tmeth_val of Ident.t
286
+
| Tmeth_ancestor of Ident.t * Path.t
286
287
287
288
and 'k case =
288
289
{
···
328
329
| Tcl_let of rec_flag * value_binding list *
329
330
(Ident.t * expression) list * class_expr
330
331
| Tcl_constraint of
331
-
class_expr * class_type option * string list * string list * Types.Concr.t
332
+
class_expr * class_type option * string list * string list
333
+
* Types.MethSet.t
332
334
(* Visible instance variables, methods and concrete methods *)
333
335
| Tcl_open of open_description * class_expr
334
336
+18
-23
typing/typemod.ml
+18
-23
typing/typemod.ml
···
89
89
| With_cannot_remove_constrained_type
90
90
| Repeated_name of Sig_component_kind.t * string
91
91
| Non_generalizable of type_expr
92
-
| Non_generalizable_class of Ident.t * class_declaration
93
92
| Non_generalizable_module of module_type
94
93
| Implementation_is_required of string
95
94
| Interface_not_compiled of string
···
1824
1823
let path_of_module mexp =
1825
1824
try Some (path_of_module mexp) with Not_a_path -> None
1826
1825
1827
-
(* Check that all core type schemes in a structure are closed *)
1826
+
(* Check that all core type schemes in a structure
1827
+
do not contain non-generalized type variable *)
1828
1828
1829
-
let rec closed_modtype env = function
1830
-
Mty_ident _ -> true
1831
-
| Mty_alias _ -> true
1829
+
let rec nongen_modtype env = function
1830
+
Mty_ident _ -> false
1831
+
| Mty_alias _ -> false
1832
1832
| Mty_signature sg ->
1833
1833
let env = Env.add_signature sg env in
1834
-
List.for_all (closed_signature_item env) sg
1834
+
List.exists (nongen_signature_item env) sg
1835
1835
| Mty_functor(arg_opt, body) ->
1836
1836
let env =
1837
1837
match arg_opt with
···
1840
1840
| Named (Some id, param) ->
1841
1841
Env.add_module ~arg:true id Mp_present param env
1842
1842
in
1843
-
closed_modtype env body
1843
+
nongen_modtype env body
1844
1844
1845
-
and closed_signature_item env = function
1846
-
Sig_value(_id, desc, _) -> Ctype.closed_schema env desc.val_type
1847
-
| Sig_module(_id, _, md, _, _) -> closed_modtype env md.md_type
1848
-
| _ -> true
1845
+
and nongen_signature_item env = function
1846
+
Sig_value(_id, desc, _) -> Ctype.nongen_schema env desc.val_type
1847
+
| Sig_module(_id, _, md, _, _) -> nongen_modtype env md.md_type
1848
+
| _ -> false
1849
1849
1850
-
let check_nongen_scheme env sig_item =
1850
+
let check_nongen_signature_item env sig_item =
1851
1851
match sig_item with
1852
1852
Sig_value(_id, vd, _) ->
1853
-
if not (Ctype.closed_schema env vd.val_type) then
1853
+
if Ctype.nongen_schema env vd.val_type then
1854
1854
raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
1855
1855
| Sig_module (_id, _, md, _, _) ->
1856
-
if not (closed_modtype env md.md_type) then
1856
+
if nongen_modtype env md.md_type then
1857
1857
raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
1858
1858
| _ -> ()
1859
1859
1860
-
let check_nongen_schemes env sg =
1861
-
List.iter (check_nongen_scheme env) sg
1860
+
let check_nongen_signature env sg =
1861
+
List.iter (check_nongen_signature_item env) sg
1862
1862
1863
1863
(* Helpers for typing recursive modules *)
1864
1864
···
2727
2727
in
2728
2728
let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in
2729
2729
(* PR#5036: must not contain non-generalized type variables *)
2730
-
if not (closed_modtype env mty) then
2730
+
if nongen_modtype env mty then
2731
2731
raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
2732
2732
tmty, mty
2733
2733
···
2913
2913
Includemod.compunit initial_env ~mark:Mark_positive
2914
2914
sourcefile sg "(inferred signature)" simple_sg
2915
2915
in
2916
-
check_nongen_schemes finalenv simple_sg;
2916
+
check_nongen_signature finalenv simple_sg;
2917
2917
normalize_signature simple_sg;
2918
2918
Typecore.force_delayed_checks ();
2919
2919
(* See comment above. Here the target signature contains all
···
3107
3107
Location.errorf ~loc
3108
3108
"@[The type of this expression,@ %a,@ \
3109
3109
contains type variables that cannot be generalized@]" type_scheme typ
3110
-
| Non_generalizable_class (id, desc) ->
3111
-
Location.errorf ~loc
3112
-
"@[The type of this class,@ %a,@ \
3113
-
contains type variables that cannot be generalized@]"
3114
-
(class_declaration id) desc
3115
3110
| Non_generalizable_module mty ->
3116
3111
Location.errorf ~loc
3117
3112
"@[The type of this module,@ %a,@ \
+1
-2
typing/typemod.mli
+1
-2
typing/typemod.mli
···
43
43
Env.t -> Parsetree.signature -> Typedtree.signature
44
44
val transl_signature:
45
45
Env.t -> Parsetree.signature -> Typedtree.signature
46
-
val check_nongen_schemes:
46
+
val check_nongen_signature:
47
47
Env.t -> Types.signature -> unit
48
48
(*
49
49
val type_open_:
···
115
115
| With_cannot_remove_constrained_type
116
116
| Repeated_name of Sig_component_kind.t * string
117
117
| Non_generalizable of type_expr
118
-
| Non_generalizable_class of Ident.t * class_declaration
119
118
| Non_generalizable_module of module_type
120
119
| Implementation_is_required of string
121
120
| Interface_not_compiled of string
+18
-15
typing/types.ml
+18
-15
typing/types.ml
···
135
135
136
136
(* Maps of methods and instance variables *)
137
137
138
+
module MethSet = Misc.Stdlib.String.Set
139
+
module VarSet = Misc.Stdlib.String.Set
140
+
138
141
module Meths = Misc.Stdlib.String.Map
139
-
module Vars = Meths
142
+
module Vars = Misc.Stdlib.String.Map
143
+
140
144
141
145
(* Value descriptions *)
142
146
···
152
156
Val_reg (* Regular value *)
153
157
| Val_prim of Primitive.description (* Primitive *)
154
158
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
155
-
| Val_self of (Ident.t * type_expr) Meths.t ref *
156
-
(Ident.t * Asttypes.mutable_flag *
157
-
Asttypes.virtual_flag * type_expr) Vars.t ref *
158
-
string * type_expr
159
+
| Val_self of
160
+
class_signature * self_meths * Ident.t Vars.t * string
159
161
(* Self *)
160
-
| Val_anc of (string * Ident.t) list * string
162
+
| Val_anc of class_signature * Ident.t Meths.t * string
161
163
(* Ancestor *)
164
+
165
+
and self_meths =
166
+
| Self_concrete of Ident.t Meths.t
167
+
| Self_virtual of Ident.t Meths.t ref
168
+
169
+
and class_signature =
170
+
{ csig_self: type_expr;
171
+
mutable csig_self_row: type_expr;
172
+
mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t;
173
+
mutable csig_meths: (private_flag * virtual_flag * type_expr) Meths.t; }
162
174
163
175
(* Variance *)
164
176
···
301
313
302
314
(* Type expressions for the class language *)
303
315
304
-
module Concr = Misc.Stdlib.String.Set
305
-
306
316
type class_type =
307
317
Cty_constr of Path.t * type_expr list * class_type
308
318
| Cty_signature of class_signature
309
319
| Cty_arrow of arg_label * type_expr * class_type
310
-
311
-
and class_signature =
312
-
{ csig_self: type_expr;
313
-
csig_vars:
314
-
(Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
315
-
csig_concr: Concr.t;
316
-
csig_inher: (Path.t * type_expr list) list }
317
320
318
321
type class_declaration =
319
322
{ cty_params: type_expr list;
+16
-14
typing/types.mli
+16
-14
typing/types.mli
···
308
308
include Identifiable.S with type t := t
309
309
end
310
310
311
-
(* Maps of methods and instance variables *)
311
+
(* Sets and maps of methods and instance variables *)
312
+
313
+
module MethSet : Set.S with type elt = string
314
+
module VarSet : Set.S with type elt = string
312
315
313
316
module Meths : Map.S with type key = string
314
317
module Vars : Map.S with type key = string
···
327
330
Val_reg (* Regular value *)
328
331
| Val_prim of Primitive.description (* Primitive *)
329
332
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
330
-
| Val_self of (Ident.t * type_expr) Meths.t ref *
331
-
(Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref *
332
-
string * type_expr
333
+
| Val_self of class_signature * self_meths * Ident.t Vars.t * string
333
334
(* Self *)
334
-
| Val_anc of (string * Ident.t) list * string
335
+
| Val_anc of class_signature * Ident.t Meths.t * string
335
336
(* Ancestor *)
337
+
338
+
and self_meths =
339
+
| Self_concrete of Ident.t Meths.t
340
+
| Self_virtual of Ident.t Meths.t ref
341
+
342
+
and class_signature =
343
+
{ csig_self: type_expr;
344
+
mutable csig_self_row: type_expr;
345
+
mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t;
346
+
mutable csig_meths: (private_flag * virtual_flag * type_expr) Meths.t; }
336
347
337
348
(* Variance *)
338
349
···
479
490
480
491
(* Type expressions for the class language *)
481
492
482
-
module Concr : Set.S with type elt = string
483
-
484
493
type class_type =
485
494
Cty_constr of Path.t * type_expr list * class_type
486
495
| Cty_signature of class_signature
487
496
| Cty_arrow of arg_label * type_expr * class_type
488
-
489
-
and class_signature =
490
-
{ csig_self: type_expr;
491
-
csig_vars:
492
-
(Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
493
-
csig_concr: Concr.t;
494
-
csig_inher: (Path.t * type_expr list) list }
495
497
496
498
type class_declaration =
497
499
{ cty_params: type_expr list;
+3
-2
typing/untypeast.ml
+3
-2
typing/untypeast.ml
···
470
470
Pexp_for (name,
471
471
sub.expr sub exp1, sub.expr sub exp2,
472
472
dir, sub.expr sub exp3)
473
-
| Texp_send (exp, meth, _) ->
473
+
| Texp_send (exp, meth) ->
474
474
Pexp_send (sub.expr sub exp, match meth with
475
475
Tmeth_name name -> mkloc name loc
476
-
| Tmeth_val id -> mkloc (Ident.name id) loc)
476
+
| Tmeth_val id -> mkloc (Ident.name id) loc
477
+
| Tmeth_ancestor(id, _) -> mkloc (Ident.name id) loc)
477
478
| Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
478
479
| Texp_instvar (_, path, name) ->
479
480
Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
+14
-16
utils/warnings.ml
+14
-16
utils/warnings.ml
···
437
437
let (set, pos) = (!current).alert_errors in
438
438
Misc.Stdlib.String.Set.mem kind set = pos
439
439
440
+
let with_state state f =
441
+
let prev = backup () in
442
+
restore state;
443
+
try
444
+
let r = f () in
445
+
restore prev;
446
+
r
447
+
with exn ->
448
+
restore prev;
449
+
raise exn
450
+
440
451
let mk_lazy f =
441
452
let state = backup () in
442
-
lazy
443
-
(
444
-
let prev = backup () in
445
-
restore state;
446
-
try
447
-
let r = f () in
448
-
restore prev;
449
-
r
450
-
with exn ->
451
-
restore prev;
452
-
raise exn
453
-
)
453
+
lazy (with_state state f)
454
454
455
455
let set_alert ~error ~enable s =
456
456
let upd =
···
730
730
| Redundant_case -> "this match case is unused."
731
731
| Redundant_subpat -> "this sub-pattern is unused."
732
732
| Instance_variable_override [lab] ->
733
-
"the instance variable " ^ lab ^ " is overridden.\n" ^
734
-
"The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
733
+
"the instance variable " ^ lab ^ " is overridden."
735
734
| Instance_variable_override (cname :: slist) ->
736
735
String.concat " "
737
736
("the following instance variables are overridden by the class"
738
-
:: cname :: ":\n " :: slist) ^
739
-
"\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
737
+
:: cname :: ":\n " :: slist)
740
738
| Instance_variable_override [] -> assert false
741
739
| Illegal_backslash -> "illegal backslash escape in string."
742
740
| Implicit_public_methods l ->
+1
utils/warnings.mli
+1
utils/warnings.mli
···
148
148
type state
149
149
val backup: unit -> state
150
150
val restore: state -> unit
151
+
val with_state : state -> (unit -> 'a) -> 'a
151
152
val mk_lazy: (unit -> 'a) -> 'a Lazy.t
152
153
(** Like [Lazy.of_fun], but the function is applied with
153
154
the warning/alert settings at the time [mk_lazy] is called. *)