/
type.ml
497 lines (461 loc) · 12.7 KB
/
type.ml
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
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
(*
* Haxe Compiler
* Copyright (c)2005 Nicolas Cannasse
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
type module_path = string list * string
type t =
| TMono of t option ref
| TEnum of tenum * t list
| TInst of tclass * t list
| TFun of (string * t) list * t
| TAnon of (string, tclass_field) PMap.t * string option
| TDynamic of t
| TLazy of (unit -> t) ref
and tconstant =
| TInt of string
| TFloat of string
| TString of string
| TBool of bool
| TNull
| TThis
| TSuper
and tfunc = {
tf_args : (string * t) list;
tf_type : t;
tf_expr : texpr;
}
and texpr_expr =
| TConst of tconstant
| TLocal of string
| TMember of string
| TEnumField of tenum * string
| TArray of texpr * texpr
| TBinop of Ast.binop * texpr * texpr
| TField of texpr * string
| TType of module_type
| TParenthesis of texpr
| TObjectDecl of (string * texpr) list
| TArrayDecl of texpr list
| TCall of texpr * texpr list
| TNew of tclass * t list * texpr list
| TUnop of Ast.unop * Ast.unop_flag * texpr
| TFunction of tfunc
| TVars of (string * t * texpr option) list
| TBlock of texpr list
| TFor of string * texpr * texpr
| TIf of texpr * texpr * texpr option
| TWhile of texpr * texpr * Ast.while_flag
| TSwitch of texpr * (texpr * texpr) list * texpr option
| TMatch of texpr * (tenum * t list) * (string * (string * t) list option * texpr) list * texpr option
| TTry of texpr * (string * t * texpr) list
| TReturn of texpr option
| TBreak
| TContinue
| TThrow of texpr
and texpr = {
eexpr : texpr_expr;
etype : t;
epos : Ast.pos;
}
and tclass_field = {
cf_name : string;
mutable cf_type : t;
cf_public : bool;
cf_doc : Ast.documentation;
mutable cf_expr : texpr option;
}
and tclass = {
cl_path : module_path;
cl_pos : Ast.pos;
cl_doc : Ast.documentation;
cl_private : bool;
mutable cl_extern : bool;
mutable cl_interface : bool;
mutable cl_locked : bool;
mutable cl_types : (string * t) list;
mutable cl_super : (tclass * t list) option;
mutable cl_implements : (tclass * t list) list;
mutable cl_fields : (string , tclass_field) PMap.t;
mutable cl_statics : (string, tclass_field) PMap.t;
mutable cl_ordered_statics : tclass_field list;
mutable cl_dynamic : t option;
mutable cl_constructor : tclass_field option;
}
and tenum_field = {
ef_name : string;
ef_type : t;
ef_pos : Ast.pos;
ef_doc : Ast.documentation;
}
and tenum = {
e_path : module_path;
e_pos : Ast.pos;
e_doc : Ast.documentation;
e_private : bool;
mutable e_types : (string * t) list;
mutable e_constrs : (string , tenum_field) PMap.t;
}
and module_type =
| TClassDecl of tclass
| TEnumDecl of tenum
type module_def = {
mpath : module_path;
mtypes : module_type list;
}
let mk e t p = { eexpr = e; etype = t; epos = p }
let mk_mono() = TMono (ref None)
let rec t_dynamic = TDynamic t_dynamic
let mk_class path pos doc priv =
{
cl_path = path;
cl_pos = pos;
cl_doc = doc;
cl_private = priv;
cl_extern = false;
cl_interface = false;
cl_locked = false;
cl_types = [];
cl_super = None;
cl_implements = [];
cl_fields = PMap.empty;
cl_ordered_statics = [];
cl_statics = PMap.empty;
cl_dynamic = None;
cl_constructor = None;
}
let null_class = mk_class ([],"") Ast.null_pos None true
let t_private = function
| TClassDecl c -> c.cl_private
| TEnumDecl e -> e.e_private
let t_path = function
| TClassDecl c -> c.cl_path
| TEnumDecl e -> e.e_path
let print_context() = ref []
let rec s_type ctx t =
match t with
| TMono r ->
(match !r with
| None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
| Some t -> s_type ctx t)
| TEnum (e,tl) ->
Ast.s_type_path e.e_path ^ s_type_params ctx tl
| TInst (c,tl) ->
Ast.s_type_path c.cl_path ^ s_type_params ctx tl
| TFun ([],t) ->
"Void -> " ^ s_type ctx t
| TFun (l,t) ->
String.concat " -> " (List.map (fun (s,t) -> (if s = "" then "" else s ^ " : ") ^ match t with TFun _ -> "(" ^ s_type ctx t ^ ")" | _ -> s_type ctx t) l) ^ " -> " ^ s_type ctx t
| TAnon (fl,name) ->
(match name with
| Some s -> s
| None ->
let fl = PMap.fold (fun f acc -> (" " ^ f.cf_name ^ " : " ^ s_type ctx f.cf_type) :: acc) fl [] in
"{" ^ String.concat "," fl ^ " }");
| TDynamic t2 ->
"Dynamic" ^ s_type_params ctx (if t == t2 then [] else [t2])
| TLazy f ->
s_type ctx (!f())
and s_type_params ctx = function
| [] -> ""
| l -> "<" ^ String.concat ", " (List.map (s_type ctx) l) ^ ">"
let type_path t =
match t with
| TClassDecl c -> c.cl_path
| TEnumDecl e -> e.e_path
let rec follow t =
match t with
| TMono r ->
(match !r with
| Some t -> follow t
| _ -> t)
| TLazy f ->
follow (!f())
| _ -> t
let rec is_parent csup c =
if c == csup then
true
else match c.cl_super with
| None -> false
| Some (c,_) -> is_parent csup c
let rec link e a b =
let rec loop t =
if t == a then
true
else match t with
| TMono t -> (match !t with None -> false | Some t -> loop t)
| TEnum (_,tl) -> List.exists loop tl
| TInst (_,tl) -> List.exists loop tl
| TFun (tl,t) -> List.exists (fun (_,t) -> loop t) tl || loop t
| TDynamic t2 ->
if t == t2 then
false
else
loop t2
| TLazy f ->
loop (!f())
| TAnon (fl,_) ->
try
PMap.iter (fun _ f -> if loop f.cf_type then raise Exit) fl;
false
with
Exit -> true
in
if loop b then
false
else begin
e := Some b;
true
end
(* substitute parameters with other types *)
let apply_params cparams params t =
let rec loop l1 l2 =
match l1, l2 with
| [] , [] -> []
| (_,t1) :: l1 , t2 :: l2 -> (t1,t2) :: loop l1 l2
| _ -> assert false
in
let subst = loop cparams params in
let rec loop t =
try
List.assq t subst
with Not_found ->
match t with
| TMono r ->
(match !r with
| None -> t
| Some t -> loop t)
| TEnum (e,tl) ->
TEnum (e,List.map loop tl)
| TInst (c,tl) ->
(match tl with
| [TMono r] ->
(match !r with
| Some tt when t == tt ->
(* for dynamic *)
let pt = mk_mono() in
let t = TInst (c,[pt]) in
(match pt with TMono r -> r := Some t | _ -> assert false);
t
| _ -> TInst (c,List.map loop tl))
| _ ->
TInst (c,List.map loop tl))
| TFun (tl,r) ->
TFun (List.map (fun (s,t) -> s, loop t) tl,loop r)
| TAnon (fl,name) ->
TAnon (PMap.map (fun f -> { f with cf_type = loop f.cf_type }) fl,name)
| TLazy f ->
loop (!f())
| TDynamic t2 ->
if t == t2 then
t
else
TDynamic (loop t2)
in
loop t
let monomorphs eparams t =
apply_params eparams (List.map (fun _ -> mk_mono()) eparams) t
let rec type_eq param a b =
if a == b || (param && b == t_dynamic) then
true
else match a , b with
| TLazy f , _ -> type_eq param (!f()) b
| _ , TLazy f -> type_eq param a (!f())
| TMono t , _ -> (match !t with None -> link t a b | Some t -> type_eq param t b)
| _ , TMono t -> (match !t with None -> link t b a | Some t -> type_eq param a t)
| TEnum (a,tl1) , TEnum (b,tl2) -> a == b && List.for_all2 (type_eq param) tl1 tl2
| TInst (c1,tl1) , TInst (c2,tl2) ->
c1 == c2 && List.for_all2 (type_eq param) tl1 tl2
| TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
type_eq param r1 r2 && List.for_all2 (fun (_,t1) (_,t2) -> type_eq param t1 t2) l1 l2
| TDynamic a , TDynamic b ->
type_eq param a b
| TAnon (fl1,_), TAnon (fl2,_) ->
let keys1 = PMap.fold (fun f acc -> f :: acc) fl1 [] in
let keys2 = PMap.fold (fun f acc -> f :: acc) fl2 [] in
(try
List.iter2 (fun f1 f2 ->
if f1.cf_name <> f2.cf_name || not (type_eq param f1.cf_type f2.cf_type) then raise Not_found
) keys1 keys2;
true
with
_ -> false)
| _ , _ ->
false
(* perform unification with subtyping.
the first type is always the most down in the class hierarchy
it's also the one that is pointed by the position.
It's actually a typecheck of A :> B where some mutations can happen *)
type unify_error =
| Cannot_unify of t * t
| Invalid_field_type of string
| Has_no_field of t * string
exception Unify_error of unify_error list
let cannot_unify a b = Cannot_unify (a,b)
let invalid_field n = Invalid_field_type n
let has_no_field t n = Has_no_field (t,n)
let error l = raise (Unify_error l)
let unify_types a b tl1 tl2 =
List.iter2 (fun ta tb ->
if not (type_eq true ta tb) then error [cannot_unify a b; cannot_unify ta tb]
) tl1 tl2
let rec unify a b =
if a == b then
()
else match a, b with
| TLazy f , _ -> unify (!f()) b
| _ , TLazy f -> unify a (!f())
| TMono t , _ ->
(match !t with
| None -> if not (link t a b) then error [cannot_unify a b]
| Some t -> unify t b)
| _ , TMono t ->
(match !t with
| None -> if not (link t b a) then error [cannot_unify a b]
| Some t -> unify a t)
| TEnum (ea,tl1) , TEnum (eb,tl2) ->
if ea != eb then error [cannot_unify a b];
unify_types a b tl1 tl2
| TInst (c1,tl1) , TInst (c2,tl2) ->
let rec loop c tl =
if c == c2 then begin
unify_types a b tl tl2;
true
end else (match c.cl_super with
| None -> false
| Some (cs,tls) ->
loop cs (List.map (apply_params c.cl_types tl) tls)
) || List.exists (fun (cs,tls) ->
loop cs (List.map (apply_params c.cl_types tl) tls)
) c.cl_implements
in
if not (loop c1 tl1) then error [cannot_unify a b]
| TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
(try
unify r1 r2;
List.iter2 (fun (_,t1) (_,t2) -> unify t1 t2) l2 l1 (* contravariance *)
with
Unify_error l -> error (cannot_unify a b :: l))
| TInst (c,tl) , TAnon (fl,_) ->
(try
PMap.iter (fun n f2 ->
let f1 = (try PMap.find n c.cl_fields with Not_found -> error [has_no_field a n]) in
try
unify (apply_params c.cl_types tl f1.cf_type) f2.cf_type
with
Unify_error l -> error (invalid_field n :: l)
) fl
with
Unify_error l -> error (cannot_unify a b :: l))
| TAnon (fl,_) , TInst (c,tl) ->
let rec loop c tl =
PMap.iter (fun n f2 ->
let f1 = (try PMap.find n fl with Not_found -> error [has_no_field a n]) in
try
unify f1.cf_type (apply_params c.cl_types tl f2.cf_type)
with
Unify_error l -> error (invalid_field n :: l)
) c.cl_fields;
List.iter (fun (c,t) -> loop c t) c.cl_implements;
match c.cl_super with
| None -> ()
| Some (c,tl) -> loop c tl
in
if c.cl_locked then error [cannot_unify a b];
(try
loop c tl;
with
Unify_error l -> error (cannot_unify a b :: l))
| TAnon (fl1,_) , TAnon (fl2,_) ->
(try
PMap.iter (fun n f2 ->
let f1 = (try PMap.find n fl1 with Not_found -> error [has_no_field a n]) in
try
unify f1.cf_type f2.cf_type
with
Unify_error l -> error (invalid_field n :: l)
) fl2;
with
Unify_error l -> error (cannot_unify a b :: l))
| TDynamic t , _ ->
if t == a then
()
else (match b with
| TDynamic t2 ->
if t2 != b && not (type_eq true t t2) then error [cannot_unify a b; cannot_unify t t2];
| _ ->
error [cannot_unify a b])
| _ , TDynamic t ->
if t == b then
()
else (match a with
| TDynamic t2 ->
if t2 != a && not (type_eq true t t2) then error [cannot_unify a b; cannot_unify t t2]
| _ ->
error [cannot_unify a b])
| _ , _ ->
error [cannot_unify a b]
let rec iter f e =
match e.eexpr with
| TConst _
| TLocal _
| TMember _
| TEnumField _
| TBreak
| TContinue
| TType _ ->
()
| TArray (e1,e2)
| TBinop (_,e1,e2)
| TFor (_,e1,e2)
| TWhile (e1,e2,_) ->
f e1;
f e2;
| TThrow e
| TField (e,_)
| TParenthesis e
| TUnop (_,_,e) ->
f e
| TArrayDecl el
| TNew (_,_,el)
| TBlock el ->
List.iter f el
| TObjectDecl fl ->
List.iter (fun (_,e) -> f e) fl
| TCall (e,el) ->
f e;
List.iter f el
| TVars vl ->
List.iter (fun (_,_,e) -> match e with None -> () | Some e -> f e) vl
| TFunction fu ->
f fu.tf_expr
| TIf (e,e1,e2) ->
f e;
f e1;
(match e2 with None -> () | Some e -> f e)
| TSwitch (e,cases,def) ->
f e;
List.iter (fun (e1,e2) -> f e1; f e2) cases;
(match def with None -> () | Some e -> f e)
| TMatch (e,_,cases,def) ->
f e;
List.iter (fun (_,_,e) -> f e) cases;
(match def with None -> () | Some e -> f e)
| TTry (e,catches) ->
f e;
List.iter (fun (_,_,e) -> f e) catches
| TReturn eo ->
(match eo with None -> () | Some e -> f e)