1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
|
? objvariants-3.09.1.diffs
? objvariants.diffs
Index: btype.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
retrieving revision 1.37.4.1
diff -u -r1.37.4.1 btype.ml
--- btype.ml 5 Dec 2005 13:18:42 -0000 1.37.4.1
+++ btype.ml 16 Jan 2006 02:23:14 -0000
@@ -177,7 +177,8 @@
Tvariant row -> iter_row f row
| Tvar | Tunivar | Tsubst _ | Tconstr _ ->
Misc.may (fun (_,l) -> List.iter f l) row.row_name;
- List.iter f row.row_bound
+ List.iter f row.row_bound;
+ List.iter (fun (s,k,t) -> f t) row.row_object
| _ -> assert false
let iter_type_expr f ty =
@@ -224,7 +225,9 @@
| Some (path, tl) -> Some (path, List.map f tl) in
{ row_fields = fields; row_more = more;
row_bound = !bound; row_fixed = row.row_fixed && fixed;
- row_closed = row.row_closed; row_name = name; }
+ row_closed = row.row_closed; row_name = name;
+ row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object;
+ }
let rec copy_kind = function
Fvar{contents = Some k} -> copy_kind k
Index: ctype.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
retrieving revision 1.197.2.6
diff -u -r1.197.2.6 ctype.ml
--- ctype.ml 15 Dec 2005 02:28:38 -0000 1.197.2.6
+++ ctype.ml 16 Jan 2006 02:23:15 -0000
@@ -1421,7 +1421,7 @@
newgenty
(Tvariant
{row_fields = fields; row_closed = closed; row_more = newvar();
- row_bound = []; row_fixed = false; row_name = None })
+ row_bound = []; row_fixed = false; row_name = None; row_object=[]})
(**** Unification ****)
@@ -1724,8 +1724,11 @@
else None
in
let bound = row1.row_bound @ row2.row_bound in
+ let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in
+ let row_object = row1.row_object @ miss2 in
let row0 = {row_fields = []; row_more = more; row_bound = bound;
- row_closed = closed; row_fixed = fixed; row_name = name} in
+ row_closed = closed; row_fixed = fixed; row_name = name;
+ row_object = row_object } in
let set_more row rest =
let rest =
if closed then
@@ -1758,6 +1761,18 @@
raise (Unify ((mkvariant [l,f1] true,
mkvariant [l,f2] true) :: trace)))
pairs;
+ List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs;
+ if row_object <> [] then begin
+ List.iter
+ (fun (l,f) ->
+ match row_field_repr f with
+ Rpresent (Some ty) ->
+ let fi = build_fields generic_level row_object (newgenvar()) in
+ unify env (newgenty (Tobject (fi, ref None))) ty
+ | Rpresent None -> raise (Unify [])
+ | _ -> ())
+ (row_repr row1).row_fields
+ end;
with exn ->
log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
end
@@ -2789,7 +2804,8 @@
let row =
{ row_fields = List.map fst fields; row_more = newvar();
row_bound = !bound; row_closed = posi; row_fixed = false;
- row_name = if c > Unchanged then None else row.row_name }
+ row_name = if c > Unchanged then None else row.row_name;
+ row_object = [] }
in
(newty (Tvariant row), Changed)
| Tobject (t1, _) ->
Index: oprint.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
retrieving revision 1.22
diff -u -r1.22 oprint.ml
--- oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
+++ oprint.ml 16 Jan 2006 02:23:15 -0000
@@ -185,7 +185,7 @@
fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
| Otyp_stuff s -> fprintf ppf "%s" s
| Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
- | Otyp_variant (non_gen, row_fields, closed, tags) ->
+ | Otyp_variant (non_gen, row_fields, closed, tags, obj) ->
let print_present ppf =
function
None | Some [] -> ()
@@ -198,12 +198,17 @@
ppf fields
| Ovar_name (id, tyl) ->
fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
+ and print_object ppf obj =
+ if obj <> [] then
+ fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj
in
- fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
+ fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a%a ]@]"
+ (if non_gen then "_" else "")
(if closed then if tags = None then " " else "< "
else if tags = None then "> " else "? ")
print_fields row_fields
print_present tags
+ print_object obj
| Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
fprintf ppf "@[<1>(%a)@]" print_out_type ty
| Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
Index: outcometree.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
retrieving revision 1.14
diff -u -r1.14 outcometree.mli
--- outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
+++ outcometree.mli 16 Jan 2006 02:23:15 -0000
@@ -59,6 +59,7 @@
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
+ * (string * out_type) list
| Otyp_poly of string list * out_type
and out_variant =
| Ovar_fields of (string * bool * out_type list) list
Index: printtyp.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
retrieving revision 1.139.2.2
diff -u -r1.139.2.2 printtyp.ml
--- printtyp.ml 7 Dec 2005 23:37:27 -0000 1.139.2.2
+++ printtyp.ml 16 Jan 2006 02:23:15 -0000
@@ -244,7 +244,10 @@
visited_objects := px :: !visited_objects;
match row.row_name with
| Some(p, tyl) when namable_row row ->
- List.iter (mark_loops_rec visited) tyl
+ List.iter (mark_loops_rec visited) tyl;
+ if not (static_row row) then
+ List.iter (fun (s,k,t) -> mark_loops_rec visited t)
+ row.row_object
| _ ->
iter_row (mark_loops_rec visited) {row with row_bound = []}
end
@@ -343,25 +346,27 @@
| _ -> false)
fields in
let all_present = List.length present = List.length fields in
+ let static = row.row_closed && all_present in
+ let obj =
+ if static then [] else
+ List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object
+ in
+ let tags = if all_present then None else Some (List.map fst present) in
begin match row.row_name with
| Some(p, tyl) when namable_row row ->
let id = tree_of_path p in
let args = tree_of_typlist sch tyl in
- if row.row_closed && all_present then
+ if static then
Otyp_constr (id, args)
else
let non_gen = is_non_gen sch px in
- let tags =
- if all_present then None else Some (List.map fst present) in
Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
- row.row_closed, tags)
+ row.row_closed, tags, obj)
| _ ->
- let non_gen =
- not (row.row_closed && all_present) && is_non_gen sch px in
+ let non_gen = not static && is_non_gen sch px in
let fields = List.map (tree_of_row_field sch) fields in
- let tags =
- if all_present then None else Some (List.map fst present) in
- Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
+ Otyp_variant (non_gen, Ovar_fields fields, row.row_closed,
+ tags, obj)
end
| Tobject (fi, nm) ->
tree_of_typobject sch fi nm
Index: typecore.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
retrieving revision 1.176.2.2
diff -u -r1.176.2.2 typecore.ml
--- typecore.ml 11 Dec 2005 09:56:33 -0000 1.176.2.2
+++ typecore.ml 16 Jan 2006 02:23:15 -0000
@@ -170,7 +170,8 @@
(* Force check of well-formedness *)
unify_pat pat.pat_env pat
(newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
- row_bound=[]; row_fixed=false; row_name=None}));
+ row_bound=[]; row_fixed=false; row_name=None;
+ row_object=[]}));
| _ -> ()
let rec iter_pattern f p =
@@ -251,7 +252,7 @@
let ty = may_map (build_as_type env) p' in
newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
row_bound=[]; row_name=None;
- row_fixed=false; row_closed=false})
+ row_fixed=false; row_closed=false; row_object=[]})
| Tpat_record lpl ->
let lbl = fst(List.hd lpl) in
if lbl.lbl_private = Private then p.pat_type else
@@ -318,7 +319,8 @@
([],[]) fields in
let row =
{ row_fields = List.rev fields; row_more = newvar(); row_bound = !bound;
- row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
+ row_closed = false; row_fixed = false; row_name = Some (path, tyl);
+ row_object = [] }
in
let ty = newty (Tvariant row) in
let gloc = {loc with Location.loc_ghost=true} in
@@ -428,7 +430,8 @@
row_closed = false;
row_more = newvar ();
row_fixed = false;
- row_name = None } in
+ row_name = None;
+ row_object = [] } in
rp {
pat_desc = Tpat_variant(l, arg, row);
pat_loc = sp.ppat_loc;
@@ -976,7 +979,8 @@
row_bound = [];
row_closed = false;
row_fixed = false;
- row_name = None});
+ row_name = None;
+ row_object = []});
exp_env = env }
| Pexp_record(lid_sexp_list, opt_sexp) ->
let ty = newvar() in
@@ -1261,8 +1265,30 @@
assert false
end
| _ ->
- (Texp_send(obj, Tmeth_name met),
- filter_method env met Public obj.exp_type)
+ let obj, met_ty =
+ match expand_head env obj.exp_type with
+ {desc = Tvariant _} ->
+ let exp_ty = newvar () in
+ let met_ty = filter_method env met Public exp_ty in
+ let row =
+ {row_fields=[]; row_more=newvar();
+ row_bound=[]; row_closed=false;
+ row_fixed=false; row_name=None;
+ row_object=[met, Fpresent, met_ty]} in
+ unify_exp env obj (newty (Tvariant row));
+ let prim = Primitive.parse_declaration 1 ["%field1"] in
+ let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in
+ let vd = {val_type = ty; val_kind = Val_prim prim} in
+ let esnd =
+ {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd);
+ exp_loc = Location.none; exp_type = ty; exp_env = env}
+ in
+ ({obj with exp_type = exp_ty;
+ exp_desc = Texp_apply(esnd,[Some obj, Required])},
+ met_ty)
+ | _ -> (obj, filter_method env met Public obj.exp_type)
+ in
+ (Texp_send(obj, Tmeth_name met), met_ty)
in
if !Clflags.principal then begin
end_def ();
Index: types.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
retrieving revision 1.25
diff -u -r1.25 types.ml
--- types.ml 9 Dec 2004 12:40:53 -0000 1.25
+++ types.ml 16 Jan 2006 02:23:15 -0000
@@ -44,7 +44,9 @@
row_bound: type_expr list;
row_closed: bool;
row_fixed: bool;
- row_name: (Path.t * type_expr list) option }
+ row_name: (Path.t * type_expr list) option;
+ row_object: (string * field_kind * type_expr) list;
+ }
and row_field =
Rpresent of type_expr option
Index: types.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
retrieving revision 1.25
diff -u -r1.25 types.mli
--- types.mli 9 Dec 2004 12:40:53 -0000 1.25
+++ types.mli 16 Jan 2006 02:23:15 -0000
@@ -43,7 +43,9 @@
row_bound: type_expr list;
row_closed: bool;
row_fixed: bool;
- row_name: (Path.t * type_expr list) option }
+ row_name: (Path.t * type_expr list) option;
+ row_object: (string * field_kind * type_expr) list;
+ }
and row_field =
Rpresent of type_expr option
Index: typetexp.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
retrieving revision 1.54
diff -u -r1.54 typetexp.ml
--- typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54
+++ typetexp.ml 16 Jan 2006 02:23:15 -0000
@@ -215,7 +215,8 @@
in
let row = { row_closed = true; row_fields = fields;
row_bound = !bound; row_name = Some (path, args);
- row_fixed = false; row_more = newvar () } in
+ row_fixed = false; row_more = newvar ();
+ row_object = [] } in
let static = Btype.static_row row in
let row =
if static then row else
@@ -262,7 +263,7 @@
let mkfield l f =
newty (Tvariant {row_fields=[l,f]; row_more=newvar();
row_bound=[]; row_closed=true;
- row_fixed=false; row_name=None}) in
+ row_fixed=false; row_name=None; row_object=[]}) in
let add_typed_field loc l f fields =
try
let f' = List.assoc l fields in
@@ -345,7 +346,7 @@
let row =
{ row_fields = List.rev fields; row_more = newvar ();
row_bound = !bound; row_closed = closed;
- row_fixed = false; row_name = !name } in
+ row_fixed = false; row_name = !name; row_object = [] } in
let static = Btype.static_row row in
let row =
if static then row else
|
