forked from HaxeFoundation/haxe
-
Notifications
You must be signed in to change notification settings - Fork 1
/
typer.ml
4271 lines (4179 loc) · 150 KB
/
typer.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
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
* Copyright (C)2005-2013 Haxe Foundation
*
* Permission is hereby granted, free of charge, to any person obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense,
* and/or sell copies of the Software, and to permit persons to whom the
* Software is furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
* DEALINGS IN THE SOFTWARE.
*)
open Ast
open Type
open Common
open Typecore
(* ---------------------------------------------------------------------- *)
(* TOOLS *)
type switch_mode =
| CMatch of (tenum_field * (string * t) option list option * pos)
| CExpr of texpr
type access_mode =
| MGet
| MSet
| MCall
exception DisplayFields of (string * t * documentation) list
exception DisplayMetadata of metadata_entry list
exception WithTypeError of unify_error list * pos
type access_kind =
| AKNo of string
| AKExpr of texpr
| AKSet of texpr * t * tclass_field
| AKInline of texpr * tclass_field * tfield_access * t
| AKMacro of texpr * tclass_field
| AKUsing of texpr * tclass * tclass_field * texpr
| AKAccess of texpr * texpr
let mk_infos ctx p params =
let file = if ctx.in_macro then p.pfile else if Common.defined ctx.com Define.AbsolutePath then Common.get_full_path p.pfile else Filename.basename p.pfile in
(EObjectDecl (
("fileName" , (EConst (String file) , p)) ::
("lineNumber" , (EConst (Int (string_of_int (Lexer.get_error_line p))),p)) ::
("className" , (EConst (String (s_type_path ctx.curclass.cl_path)),p)) ::
if ctx.curfield.cf_name = "" then
params
else
("methodName", (EConst (String ctx.curfield.cf_name),p)) :: params
) ,p)
let check_assign ctx e =
match e.eexpr with
| TLocal _ | TArray _ | TField _ ->
()
| TConst TThis | TTypeExpr _ when ctx.untyped ->
()
| _ ->
error "Invalid assign" e.epos
type type_class =
| KInt
| KFloat
| KString
| KUnk
| KDyn
| KOther
| KParam of t
| KAbstract of tabstract
let rec classify t =
match follow t with
| TInst ({ cl_path = ([],"String") },[]) -> KString
| TAbstract({a_impl = Some _} as a,_) -> KAbstract a
| TAbstract ({ a_path = [],"Int" },[]) -> KInt
| TAbstract ({ a_path = [],"Float" },[]) -> KFloat
| TAbstract (a,[]) when List.exists (fun (t,_) -> match classify t with KInt | KFloat -> true | _ -> false) a.a_to -> KParam t
| TInst ({ cl_kind = KTypeParameter ctl },_) when List.exists (fun t -> match classify t with KInt | KFloat -> true | _ -> false) ctl -> KParam t
| TMono r when !r = None -> KUnk
| TDynamic _ -> KDyn
| _ -> KOther
let object_field f =
let pf = Parser.quoted_ident_prefix in
let pflen = String.length pf in
if String.length f >= pflen && String.sub f 0 pflen = pf then String.sub f pflen (String.length f - pflen), false else f, true
let get_iterator_param t =
match follow t with
| TAnon a ->
if !(a.a_status) <> Closed then raise Not_found;
(match follow (PMap.find "hasNext" a.a_fields).cf_type, follow (PMap.find "next" a.a_fields).cf_type with
| TFun ([],tb), TFun([],t) when (match follow tb with TAbstract ({ a_path = [],"Bool" },[]) -> true | _ -> false) ->
if PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 <> 2 then raise Not_found;
t
| _ ->
raise Not_found)
| _ ->
raise Not_found
let get_iterable_param t =
match follow t with
| TAnon a ->
if !(a.a_status) <> Closed then raise Not_found;
(match follow (PMap.find "iterator" a.a_fields).cf_type with
| TFun ([],it) ->
let t = get_iterator_param it in
if PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 <> 1 then raise Not_found;
t
| _ ->
raise Not_found)
| _ -> raise Not_found
(*
temporally remove the constant flag from structures to allow larger unification
*)
let remove_constant_flag t callb =
let tmp = ref [] in
let rec loop t =
match follow t with
| TAnon a ->
if !(a.a_status) = Const then begin
a.a_status := Closed;
tmp := a :: !tmp;
end;
PMap.iter (fun _ f -> loop f.cf_type) a.a_fields;
| _ ->
()
in
let restore() =
List.iter (fun a -> a.a_status := Const) (!tmp)
in
try
loop t;
let ret = callb (!tmp <> []) in
restore();
ret
with e ->
restore();
raise e
let rec is_pos_infos = function
| TMono r ->
(match !r with
| Some t -> is_pos_infos t
| _ -> false)
| TLazy f ->
is_pos_infos (!f())
| TType ({ t_path = ["haxe"] , "PosInfos" },[]) ->
true
| TType (t,tl) ->
is_pos_infos (apply_params t.t_types tl t.t_type)
| _ ->
false
let check_constraints ctx tname tpl tl map p =
List.iter2 (fun m (name,t) ->
match follow t with
| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
delay ctx PCheckConstraint (fun() ->
List.iter (fun ct ->
try
Type.unify (map m) (map ct)
with Unify_error l ->
display_error ctx (error_msg (Unify (Constraint_failure (tname ^ "." ^ name) :: l))) p;
) constr
);
| _ ->
()
) tl tpl
let enum_field_type ctx en ef tl_en tl_ef p =
let map t = apply_params en.e_types tl_en (apply_params ef.ef_params tl_ef t) in
check_constraints ctx (s_type_path en.e_path) en.e_types tl_en map p;
check_constraints ctx ef.ef_name ef.ef_params tl_ef map p;
map ef.ef_type
let add_constraint_checks ctx ctypes pl f tl p =
List.iter2 (fun m (name,t) ->
match follow t with
| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
let constr = List.map (fun t ->
let t = apply_params f.cf_params tl t in
(* only apply params if not static : in that case no param is passed *)
let t = (if pl = [] then t else apply_params ctypes pl t) in
t
) constr in
delay ctx PCheckConstraint (fun() ->
List.iter (fun ct ->
try
(* if has_mono m then raise (Unify_error [Unify_custom "Could not resolve full type for constraint checks"; Unify_custom ("Type was " ^ (s_type (print_context()) m))]); *)
Type.unify m ct
with Unify_error l ->
display_error ctx (error_msg (Unify (Constraint_failure (f.cf_name ^ "." ^ name) :: l))) p;
) constr
);
| _ -> ()
) tl f.cf_params
let field_type ctx c pl f p =
match f.cf_params with
| [] -> f.cf_type
| l ->
let monos = List.map (fun _ -> mk_mono()) l in
if not (Meta.has Meta.Generic f.cf_meta) then add_constraint_checks ctx c.cl_types pl f monos p;
apply_params l monos f.cf_type
let class_field ctx c pl name p =
raw_class_field (fun f -> field_type ctx c pl f p) c name
(* checks if we can access to a given class field using current context *)
let rec can_access ctx ?(in_overload=false) c cf stat =
if cf.cf_public then
true
else if not in_overload && ctx.com.config.pf_overload && Meta.has Meta.Overload cf.cf_meta then
true
else
(* TODO: should we add a c == ctx.curclass short check here? *)
(* has metadata path *)
let make_path c f = match c.cl_kind with
| KAbstractImpl a -> fst a.a_path @ [snd a.a_path; f.cf_name]
| _ -> fst c.cl_path @ [snd c.cl_path; f.cf_name]
in
let rec expr_path acc e =
match fst e with
| EField (e,f) -> expr_path (f :: acc) e
| EConst (Ident n) -> n :: acc
| _ -> []
in
let rec chk_path psub pfull =
match psub, pfull with
| [], _ -> true
| a :: l1, b :: l2 when a = b -> chk_path l1 l2
| _ -> false
in
let has m c f path =
let rec loop = function
| (m2,[e],_) :: l when m = m2 ->
let p = expr_path [] e in
(p <> [] && chk_path p path) || loop l
| _ :: l -> loop l
| [] -> false
in
loop c.cl_meta || loop f.cf_meta
in
let cur_paths = ref [] in
let rec loop c =
cur_paths := make_path c ctx.curfield :: !cur_paths;
begin match c.cl_super with
| Some (csup,_) -> loop csup
| None -> ()
end;
List.iter (fun (c,_) -> loop c) c.cl_implements;
in
loop ctx.curclass;
let is_constr = cf.cf_name = "new" in
let rec loop c =
(try
(* if our common ancestor declare/override the field, then we can access it *)
let f = if is_constr then (match c.cl_constructor with None -> raise Not_found | Some c -> c) else PMap.find cf.cf_name (if stat then c.cl_statics else c.cl_fields) in
is_parent c ctx.curclass || (List.exists (has Meta.Allow c f) !cur_paths)
with Not_found ->
false
)
|| (match c.cl_super with
| Some (csup,_) -> loop csup
| None -> false)
|| has Meta.Access ctx.curclass ctx.curfield (make_path c cf)
in
let b = loop c
(* access is also allowed of we access a type parameter which is constrained to our (base) class *)
|| (match c.cl_kind with
| KTypeParameter tl ->
List.exists (fun t -> match follow t with TInst(c,_) -> loop c | _ -> false) tl
| _ -> false)
|| (Meta.has Meta.PrivateAccess ctx.meta) in
(* TODO: find out what this does and move it to genas3 *)
if b && Common.defined ctx.com Common.Define.As3 && not (Meta.has Meta.Public cf.cf_meta) then cf.cf_meta <- (Meta.Public,[],cf.cf_pos) :: cf.cf_meta;
b
(* removes the first argument of the class field's function type and all its overloads *)
let prepare_using_field cf = match cf.cf_type with
| TFun((_,_,tf) :: args,ret) ->
let rec loop acc overloads = match overloads with
| ({cf_type = TFun((_,_,tfo) :: args,ret)} as cfo) :: l ->
let tfo = apply_params cfo.cf_params (List.map snd cfo.cf_params) tfo in
(* ignore overloads which have a different first argument *)
if Type.type_iseq tf tfo then loop ({cfo with cf_type = TFun(args,ret)} :: acc) l else loop acc l
| _ :: l ->
loop acc l
| [] ->
acc
in
{cf with cf_overloads = loop [] cf.cf_overloads; cf_type = TFun(args,ret)}
| _ -> cf
let find_array_access a pl c t1 t2 is_set =
let ta = apply_params a.a_types pl a.a_this in
let rec loop cfl = match cfl with
| [] -> raise Not_found
| cf :: cfl when not (Meta.has Meta.ArrayAccess cf.cf_meta) ->
loop cfl
| cf :: cfl ->
match follow (apply_params a.a_types pl (monomorphs cf.cf_params cf.cf_type)) with
| TFun([(_,_,tab);(_,_,ta1);(_,_,ta2)],r) as tf when is_set ->
begin try
Type.unify tab ta;
Type.unify t1 ta1;
Type.unify t2 ta2;
cf,tf,r
with Unify_error _ ->
loop cfl
end
| TFun([(_,_,tab);(_,_,ta1)],r) as tf when not is_set ->
begin try
Type.unify tab ta;
Type.unify t1 ta1;
cf,tf,r
with Unify_error _ ->
loop cfl
end
| _ -> loop cfl
in
loop a.a_array
let parse_string ctx s p inlined =
let old = Lexer.save() in
let old_file = (try Some (Hashtbl.find Lexer.all_files p.pfile) with Not_found -> None) in
let old_display = !Parser.resume_display in
let old_de = !Parser.display_error in
let restore() =
(match old_file with
| None -> ()
| Some f -> Hashtbl.replace Lexer.all_files p.pfile f);
if not inlined then Parser.resume_display := old_display;
Lexer.restore old;
Parser.display_error := old_de
in
Lexer.init p.pfile;
Parser.display_error := (fun e p -> raise (Parser.Error (e,p)));
if not inlined then Parser.resume_display := null_pos;
let _, decls = try
Parser.parse ctx.com (Lexing.from_string s)
with Parser.Error (e,pe) ->
restore();
error (Parser.error_msg e) (if inlined then pe else p)
| Lexer.Error (e,pe) ->
restore();
error (Lexer.error_msg e) (if inlined then pe else p)
in
restore();
match decls with
| [(d,_)] -> d
| _ -> assert false
let parse_expr_string ctx s p inl =
let head = "class X{static function main() " in
let head = (if p.pmin > String.length head then head ^ String.make (p.pmin - String.length head) ' ' else head) in
let rec loop e = let e = Ast.map_expr loop e in (fst e,p) in
match parse_string ctx (head ^ s ^ ";}") p inl with
| EClass { d_data = [{ cff_name = "main"; cff_kind = FFun { f_expr = Some e } }]} -> if inl then e else loop e
| _ -> assert false
(* ---------------------------------------------------------------------- *)
(* PASS 3 : type expression & check structure *)
let rec base_types t =
let tl = ref [] in
let rec loop t = (match t with
| TInst(cl, params) ->
(match cl.cl_kind with
| KTypeParameter tl -> List.iter loop tl
| _ -> ());
List.iter (fun (ic, ip) ->
let t = apply_params cl.cl_types params (TInst (ic,ip)) in
loop t
) cl.cl_implements;
(match cl.cl_super with None -> () | Some (csup, pl) ->
let t = apply_params cl.cl_types params (TInst (csup,pl)) in
loop t);
tl := t :: !tl;
| TEnum(en,(_ :: _ as tl2)) ->
tl := (TEnum(en,List.map (fun _ -> t_dynamic) tl2)) :: !tl;
tl := t :: !tl;
| TType (td,pl) ->
loop (apply_params td.t_types pl td.t_type);
(* prioritize the most generic definition *)
tl := t :: !tl;
| TLazy f -> loop (!f())
| TMono r -> (match !r with None -> () | Some t -> loop t)
| _ -> tl := t :: !tl)
in
loop t;
!tl
let rec unify_min_raise ctx (el:texpr list) : t =
match el with
| [] -> mk_mono()
| [e] -> e.etype
| _ ->
let rec chk_null e = is_null e.etype ||
match e.eexpr with
| TConst TNull -> true
| TBlock el ->
(match List.rev el with
| [] -> false
| e :: _ -> chk_null e)
| TParenthesis e | TMeta(_,e) -> chk_null e
| _ -> false
in
(* First pass: Try normal unification and find out if null is involved. *)
let rec loop t = function
| [] ->
false, t
| e :: el ->
let t = if chk_null e then ctx.t.tnull t else t in
try
unify_raise ctx e.etype t e.epos;
loop t el
with Error (Unify _,_) -> try
unify_raise ctx t e.etype e.epos;
loop (if is_null t then ctx.t.tnull e.etype else e.etype) el
with Error (Unify _,_) ->
true, t
in
let has_error, t = loop (mk_mono()) el in
if not has_error then
t
else try
(* specific case for const anon : we don't want to hide fields but restrict their common type *)
let fcount = ref (-1) in
let field_count a =
PMap.fold (fun _ acc -> acc + 1) a.a_fields 0
in
let expr f = match f.cf_expr with None -> mk (TBlock []) f.cf_type f.cf_pos | Some e -> e in
let fields = List.fold_left (fun acc e ->
match follow e.etype with
| TAnon a when !(a.a_status) = Const ->
a.a_status := Closed;
if !fcount = -1 then begin
fcount := field_count a;
PMap.map (fun f -> [expr f]) a.a_fields
end else begin
if !fcount <> field_count a then raise Not_found;
PMap.mapi (fun n el -> expr (PMap.find n a.a_fields) :: el) acc
end
| _ ->
raise Not_found
) PMap.empty el in
let fields = PMap.foldi (fun n el acc ->
let t = try unify_min_raise ctx el with Error (Unify _, _) -> raise Not_found in
PMap.add n (mk_field n t (List.hd el).epos) acc
) fields PMap.empty in
TAnon { a_fields = fields; a_status = ref Closed }
with Not_found ->
(* Second pass: Get all base types (interfaces, super classes and their interfaces) of most general type.
Then for each additional type filter all types that do not unify. *)
let common_types = base_types t in
let dyn_types = List.fold_left (fun acc t ->
let rec loop c =
Meta.has Meta.UnifyMinDynamic c.cl_meta || (match c.cl_super with None -> false | Some (c,_) -> loop c)
in
match t with
| TInst (c,params) when params <> [] && loop c ->
TInst (c,List.map (fun _ -> t_dynamic) params) :: acc
| _ -> acc
) [] common_types in
let common_types = ref (match List.rev dyn_types with [] -> common_types | l -> common_types @ l) in
let loop e =
let first_error = ref None in
let filter t = (try unify_raise ctx e.etype t e.epos; true
with Error (Unify l, p) as err -> if !first_error = None then first_error := Some(err); false)
in
common_types := List.filter filter !common_types;
match !common_types, !first_error with
| [], Some err -> raise err
| _ -> ()
in
match !common_types with
| [] ->
error "No common base type found" (punion (List.hd el).epos (List.hd (List.rev el)).epos)
| _ ->
List.iter loop (List.tl el);
List.hd !common_types
let unify_min ctx el =
try unify_min_raise ctx el
with Error (Unify l,p) ->
if not ctx.untyped then display_error ctx (error_msg (Unify l)) p;
(List.hd el).etype
let rec unify_call_params ctx ?(overloads=None) cf el args r p inline =
(* 'overloads' will carry a ( return_result ) list, called 'compatible' *)
(* it's used to correctly support an overload selection algorithm *)
let overloads, compatible, legacy = match cf, overloads with
| Some(TInst(c,pl),f), None when ctx.com.config.pf_overload && Meta.has Meta.Overload f.cf_meta ->
let overloads = List.filter (fun (_,f2) ->
not (f == f2) && (f2.cf_public || can_access ctx ~in_overload:true c f2 false)
) (Typeload.get_overloads c f.cf_name) in
if overloads = [] then (* is static function *)
let overloads = List.map (fun f -> f.cf_type, f) f.cf_overloads in
let is_static = f.cf_name <> "new" in
List.filter (fun (_,f) -> can_access ctx ~in_overload:true c f is_static) overloads, [], false
else
overloads, [], false
| Some(_,f), None ->
List.map (fun f -> f.cf_type, f) f.cf_overloads, [], true
| _, Some s ->
s
| _ -> [], [], true
in
let next ?retval () =
let compatible = Option.map_default (fun r -> r :: compatible) compatible retval in
match cf, overloads with
| Some (TInst(c,pl),_), (ft,o) :: l ->
let o = { o with cf_type = ft } in
let args, ret = (match follow (apply_params c.cl_types pl (field_type ctx c pl o p)) with (* I'm getting non-followed types here. Should it happen? *)
| TFun (tl,t) -> tl, t
| _ -> assert false
) in
Some (unify_call_params ctx ~overloads:(Some (l,compatible,legacy)) (Some (TInst(c,pl),o)) el args ret p inline)
| Some (t,_), (ft,o) :: l ->
let o = { o with cf_type = ft } in
let args, ret = (match Type.field_type o with
| TFun (tl,t) -> tl, t
| _ -> assert false
) in
Some (unify_call_params ctx ~overloads:(Some (l,compatible,legacy)) (Some (t, o)) el args ret p inline)
| _ ->
match compatible with
| [] -> None
| [acc,t] -> Some (List.map fst acc, t)
| comp ->
match Codegen.Overloads.reduce_compatible compatible with
| [acc,t] -> Some (List.map fst acc, t)
| (acc,t) :: _ -> (* ambiguous overload *)
let name = match cf with | Some(_,f) -> "'" ^ f.cf_name ^ "' " | _ -> "" in
let format_amb = String.concat "\n" (List.map (fun (_,t) ->
"Function " ^ name ^ "with type " ^ (s_type (print_context()) t)
) compatible) in
display_error ctx ("This call is ambiguous between the following methods:\n" ^ format_amb) p;
Some (List.map fst acc,t)
| [] -> None
in
let fun_details() =
let format_arg = (fun (name,opt,_) -> (if opt then "?" else "") ^ name) in
"Function " ^ (match cf with None -> "" | Some (_,f) -> "'" ^ f.cf_name ^ "' ") ^ "requires " ^ (if args = [] then "no arguments" else "arguments : " ^ String.concat ", " (List.map format_arg args))
in
let invalid_skips = ref [] in
let error acc txt =
match next() with
| Some l -> l
| None ->
display_error ctx (txt ^ " arguments\n" ^ (fun_details())) p;
List.rev (List.map fst acc), (TFun(args,r))
in
let arg_error ul name opt p =
match next() with
| Some l -> l
| None -> raise (Error (Stack (Unify ul,Custom ("For " ^ (if opt then "optional " else "") ^ "function argument '" ^ name ^ "'")), p))
in
let rec no_opt = function
| [] -> []
| ({ eexpr = TConst TNull },true) :: l -> no_opt l
| l -> l
in
let rec default_value t po =
if is_pos_infos t then
let infos = mk_infos ctx p [] in
let e = type_expr ctx infos (WithType t) in
(e, true)
else begin
if not ctx.com.config.pf_can_skip_non_nullable_argument then begin match po with
| Some (name,p) when not (is_nullable t) -> invalid_skips := (name,p) :: !invalid_skips;
| _ -> ()
end;
(null (ctx.t.tnull t) p, true)
end
in
let rec loop acc l l2 skip =
match l , l2 with
| [] , [] ->
begin match !invalid_skips with
| [] -> ()
| skips -> List.iter (fun (name,p) -> display_error ctx ("Cannot skip non-nullable argument " ^ name) p) skips
end;
let args,tf = if not (inline && ctx.g.doinline) && not ctx.com.config.pf_pad_nulls then
List.rev (no_opt acc), (TFun(args,r))
else
List.rev (acc), (TFun(args,r))
in
if not legacy && ctx.com.config.pf_overload then
match next ~retval:(args,tf) () with
| Some l -> l
| None ->
display_error ctx ("No overloaded function matches the arguments. Are the arguments correctly typed?") p;
List.map fst args, tf
else
List.map fst args, tf
| [] , (_,false,_) :: _ ->
error (List.fold_left (fun acc (_,_,t) -> default_value t None :: acc) acc l2) "Not enough"
| [] , (name,true,t) :: l ->
loop (default_value t None :: acc) [] l skip
| _ , [] ->
(match List.rev skip with
| [] -> error acc "Too many"
| [name,ul] -> arg_error ul name true p
| (name,ul) :: _ -> arg_error (Unify_custom ("Invalid arguments\n" ^ fun_details()) :: ul) name true p)
| ee :: l, (name,opt,t) :: l2 ->
try
let e = type_expr ctx ee (WithTypeResume t) in
(try unify_raise ctx e.etype t e.epos with Error (Unify l,p) -> raise (WithTypeError (l,p)));
loop ((Codegen.Abstract.check_cast ctx t e p,false) :: acc) l l2 skip
with
WithTypeError (ul,p) ->
if opt then
loop (default_value t (Some (name,p)) :: acc) (ee :: l) l2 ((name,ul) :: skip)
else
arg_error ul name false p
in
loop [] el args []
let fast_enum_field e ef p =
let et = mk (TTypeExpr (TEnumDecl e)) (TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics e) }) p in
TField (et,FEnum (e,ef))
let rec type_module_type ctx t tparams p =
match t with
| TClassDecl c ->
let t_tmp = {
t_path = fst c.cl_path, "#" ^ snd c.cl_path;
t_module = c.cl_module;
t_doc = None;
t_pos = c.cl_pos;
t_type = TAnon {
a_fields = c.cl_statics;
a_status = ref (Statics c);
};
t_private = true;
t_types = [];
t_meta = no_meta;
} in
mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p
| TEnumDecl e ->
let types = (match tparams with None -> List.map (fun _ -> mk_mono()) e.e_types | Some l -> l) in
mk (TTypeExpr (TEnumDecl e)) (TType (e.e_type,types)) p
| TTypeDecl s ->
let t = apply_params s.t_types (List.map (fun _ -> mk_mono()) s.t_types) s.t_type in
(match follow t with
| TEnum (e,params) ->
type_module_type ctx (TEnumDecl e) (Some params) p
| TInst (c,params) ->
type_module_type ctx (TClassDecl c) (Some params) p
| TAbstract (a,params) ->
type_module_type ctx (TAbstractDecl a) (Some params) p
| _ ->
error (s_type_path s.t_path ^ " is not a value") p)
| TAbstractDecl { a_impl = Some c } ->
type_module_type ctx (TClassDecl c) tparams p
| TAbstractDecl a ->
if not (Meta.has Meta.RuntimeValue a.a_meta) then error (s_type_path a.a_path ^ " is not a value") p;
let t_tmp = {
t_path = fst a.a_path, "#" ^ snd a.a_path;
t_module = a.a_module;
t_doc = None;
t_pos = a.a_pos;
t_type = TAnon {
a_fields = PMap.empty;
a_status = ref (AbstractStatics a);
};
t_private = true;
t_types = [];
t_meta = no_meta;
} in
mk (TTypeExpr (TAbstractDecl a)) (TType (t_tmp,[])) p
let type_type ctx tpath p =
type_module_type ctx (Typeload.load_type_def ctx p { tpackage = fst tpath; tname = snd tpath; tparams = []; tsub = None }) None p
let get_constructor ctx c params p =
match c.cl_kind with
| KAbstractImpl a ->
let f = (try PMap.find "_new" c.cl_statics with Not_found -> error (s_type_path a.a_path ^ " does not have a constructor") p) in
let ct = field_type ctx c params f p in
apply_params a.a_types params ct, f
| _ ->
let ct, f = (try Type.get_constructor (fun f -> field_type ctx c params f p) c with Not_found -> error (s_type_path c.cl_path ^ " does not have a constructor") p) in
apply_params c.cl_types params ct, f
let make_call ctx e params t p =
try
let ethis, fname = (match e.eexpr with TField (ethis,f) -> ethis, field_name f | _ -> raise Exit) in
let f, cl = (match follow ethis.etype with
| TInst (c,params) -> (try let _,_,f = Type.class_field c fname in f with Not_found -> raise Exit), Some c
| TAnon a -> (try PMap.find fname a.a_fields with Not_found -> raise Exit), (match !(a.a_status) with Statics c -> Some c | _ -> None)
| _ -> raise Exit
) in
if f.cf_kind <> Method MethInline then raise Exit;
let is_extern = (match cl with
| Some { cl_extern = true } -> true
| Some { cl_kind = KAbstractImpl _ } -> true
| _ when Meta.has Meta.Extern f.cf_meta -> true
| _ -> false
) in
let config = match cl with
| Some ({cl_kind = KAbstractImpl _}) when Meta.has Meta.Impl f.cf_meta ->
let t = if fname = "_new" then
t
else if params = [] then
error "Invalid abstract implementation function" f.cf_pos
else
follow (List.hd params).etype
in
begin match t with
| TAbstract(a,pl) ->
let has_params = a.a_types <> [] || f.cf_params <> [] in
let map_type = fun t -> apply_params a.a_types pl (monomorphs f.cf_params t) in
Some (has_params,map_type)
| _ ->
None
end
| _ ->
None
in
ignore(follow f.cf_type); (* force evaluation *)
let params = List.map (ctx.g.do_optimize ctx) params in
(match f.cf_expr with
| Some { eexpr = TFunction fd } ->
(match Optimizer.type_inline ctx f fd ethis params t config p is_extern with
| None ->
if is_extern then error "Inline could not be done" p;
raise Exit;
| Some e -> e)
| _ ->
(*
we can't inline because there is most likely a loop in the typing.
this can be caused by mutually recursive vars/functions, some of them
being inlined or not. In that case simply ignore inlining.
*)
raise Exit)
with Exit ->
mk (TCall (e,params)) t p
let rec acc_get ctx g p =
match g with
| AKNo f -> error ("Field " ^ f ^ " cannot be accessed for reading") p
| AKExpr e -> e
| AKSet _ | AKAccess _ -> assert false
| AKUsing (et,_,_,e) ->
(* build a closure with first parameter applied *)
(match follow et.etype with
| TFun (_ :: args,ret) ->
let tcallb = TFun (args,ret) in
let twrap = TFun ([("_e",false,e.etype)],tcallb) in
(* arguments might not have names in case of variable fields of function types, so we generate one (issue #2495) *)
let args = List.map (fun (n,_,t) -> if n = "" then gen_local ctx t else alloc_var n t) args in
let ve = alloc_var "_e" e.etype in
let ecall = make_call ctx et (List.map (fun v -> mk (TLocal v) v.v_type p) (ve :: args)) ret p in
let ecallb = mk (TFunction {
tf_args = List.map (fun v -> v,None) args;
tf_type = ret;
tf_expr = mk (TReturn (Some ecall)) t_dynamic p;
}) tcallb p in
let ewrap = mk (TFunction {
tf_args = [ve,None];
tf_type = tcallb;
tf_expr = mk (TReturn (Some ecallb)) t_dynamic p;
}) twrap p in
make_call ctx ewrap [e] tcallb p
| _ -> assert false)
| AKInline (e,f,fmode,t) ->
(* do not create a closure for static calls *)
let cmode = (match fmode with FStatic _ -> fmode | FInstance (c,f) -> FClosure (Some c,f) | _ -> assert false) in
ignore(follow f.cf_type); (* force computing *)
(match f.cf_expr with
| None ->
if ctx.com.display <> DMNone then
mk (TField (e,cmode)) t p
else
error "Recursive inline is not supported" p
| Some { eexpr = TFunction _ } ->
let chk_class c = if (c.cl_extern || Meta.has Meta.Extern f.cf_meta) && not (Meta.has Meta.Runtime f.cf_meta) then display_error ctx "Can't create closure on an inline extern method" p in
(match follow e.etype with
| TInst (c,_) -> chk_class c
| TAnon a -> (match !(a.a_status) with Statics c -> chk_class c | _ -> ())
| _ -> ());
mk (TField (e,cmode)) t p
| Some e ->
let rec loop e = Type.map_expr loop { e with epos = p } in
loop e)
| AKMacro _ ->
assert false
let error_require r p =
if r = "" then
error "This field is not available with the current compilation flags" p
else
let r = if r = "sys" then
"a system platform (php,neko,cpp,etc.)"
else try
if String.sub r 0 5 <> "flash" then raise Exit;
let _, v = ExtString.String.replace (String.sub r 5 (String.length r - 5)) "_" "." in
"flash version " ^ v ^ " (use -swf-version " ^ v ^ ")"
with _ ->
"'" ^ r ^ "' to be enabled"
in
error ("Accessing this field requires " ^ r) p
let get_this ctx p =
match ctx.curfun with
| FunStatic ->
error "Cannot access this from a static function" p
| FunMemberLocal ->
let v = (match ctx.vthis with
| None ->
(* we might be in a closure of an abstract member, so check for local "this" first *)
let v = try PMap.find "this" ctx.locals with Not_found -> gen_local ctx ctx.tthis in
ctx.vthis <- Some v;
v
| Some v ->
ctx.locals <- PMap.add v.v_name v ctx.locals;
v
) in
mk (TLocal v) ctx.tthis p
| FunMemberAbstract ->
let v = (try PMap.find "this" ctx.locals with Not_found -> assert false) in
mk (TLocal v) v.v_type p
| FunConstructor | FunMember ->
mk (TConst TThis) ctx.tthis p
let field_access ctx mode f fmode t e p =
let fnormal() = AKExpr (mk (TField (e,fmode)) t p) in
let normal() =
match follow e.etype with
| TAnon a ->
(match !(a.a_status) with
| EnumStatics en ->
let c = (try PMap.find f.cf_name en.e_constrs with Not_found -> assert false) in
let fmode = FEnum (en,c) in
AKExpr (mk (TField (e,fmode)) t p)
| _ -> fnormal())
| _ -> fnormal()
in
match f.cf_kind with
| Method m ->
if mode = MSet && m <> MethDynamic && not ctx.untyped then error "Cannot rebind this method : please use 'dynamic' before method declaration" p;
begin match e.eexpr with
| TTypeExpr(TClassDecl ({cl_kind = KAbstractImpl a} as c)) when c == ctx.curclass && ctx.curfun = FunMemberAbstract && Meta.has Meta.Impl f.cf_meta ->
let e = mk (TField(e,fmode)) t p in
let ethis = get_this ctx p in
let ethis = {ethis with etype = TAbstract(a,List.map (fun _ -> mk_mono()) a.a_types)} in
AKUsing(e,ctx.curclass,f,ethis)
| _ ->
(match m, mode with
| MethInline, _ -> AKInline (e,f,fmode,t)
| MethMacro, MGet -> display_error ctx "Macro functions must be called immediately" p; normal()
| MethMacro, MCall -> AKMacro (e,f)
| _ , MGet ->
let cmode = (match fmode with
| FInstance (c,cf) -> FClosure (Some c,cf)
| FStatic _ | FEnum _ -> fmode
| FAnon f -> FClosure (None, f)
| FDynamic _ | FClosure _ -> assert false
) in
AKExpr (mk (TField (e,cmode)) t p)
| _ -> normal())
end
| Var v ->
match (match mode with MGet | MCall -> v.v_read | MSet -> v.v_write) with
| AccNo ->
(match follow e.etype with
| TInst (c,_) when is_parent c ctx.curclass || can_access ctx c { f with cf_public = false } false -> normal()
| TAnon a ->
(match !(a.a_status) with
| Opened when mode = MSet ->
f.cf_kind <- Var { v with v_write = AccNormal };
normal()
| Statics c2 when ctx.curclass == c2 || can_access ctx c2 { f with cf_public = false } true -> normal()
| _ -> if ctx.untyped then normal() else AKNo f.cf_name)
| _ ->
if ctx.untyped then normal() else AKNo f.cf_name)
| AccNormal ->
(*
if we are reading from a read-only variable on an anonymous object, it might actually be a method, so make sure to create a closure
*)
let is_maybe_method() =
match v.v_write, follow t, follow e.etype with
| (AccNo | AccNever), TFun _, TAnon a ->
(match !(a.a_status) with
| Statics _ | EnumStatics _ -> false
| _ -> true)
| _ -> false
in
if mode = MGet && is_maybe_method() then
AKExpr (mk (TField (e,FClosure (None,f))) t p)
else
normal()
| AccCall ->
let m = (match mode with MSet -> "set_" | _ -> "get_") ^ f.cf_name in
if m = ctx.curfield.cf_name && (match e.eexpr with TConst TThis -> true | TTypeExpr (TClassDecl c) when c == ctx.curclass -> true | _ -> false) then
let prefix = (match ctx.com.platform with Flash when Common.defined ctx.com Define.As3 -> "$" | _ -> "") in
if is_extern_field f then begin
display_error ctx "This field cannot be accessed because it is not a real variable" p;
display_error ctx "Add @:isVar here to enable it" f.cf_pos;
end;
AKExpr (mk (TField (e,if prefix = "" then fmode else FDynamic (prefix ^ f.cf_name))) t p)
else if (match e.eexpr with TTypeExpr (TClassDecl ({cl_kind = KAbstractImpl _} as c)) when c == ctx.curclass -> true | _ -> false) then begin
let this = get_this ctx p in
if mode = MSet then begin
let c,a = match ctx.curclass with {cl_kind = KAbstractImpl a} as c -> c,a | _ -> assert false in
let f = PMap.find m c.cl_statics in
(* we don't have access to the type parameters here, right? *)
(* let t = apply_params a.a_types pl (field_type ctx c [] f p) in *)
let t = (field_type ctx c [] f p) in
let ef = mk (TField (e,FStatic (c,f))) t p in
AKUsing (ef,c,f,this)
end else
AKExpr (make_call ctx (mk (TField (e,quick_field_dynamic e.etype m)) (tfun [this.etype] t) p) [this] t p)
end else if mode = MSet then
AKSet (e,t,f)
else
AKExpr (make_call ctx (mk (TField (e,quick_field_dynamic e.etype m)) (tfun [] t) p) [] t p)
| AccResolve ->
let fstring = mk (TConst (TString f.cf_name)) ctx.t.tstring p in
let tresolve = tfun [ctx.t.tstring] t in
AKExpr (make_call ctx (mk (TField (e,FDynamic "resolve")) tresolve p) [fstring] t p)
| AccNever ->
if ctx.untyped then normal() else AKNo f.cf_name
| AccInline ->
AKInline (e,f,fmode,t)
| AccRequire (r,msg) ->
match msg with
| None -> error_require r p
| Some msg -> error msg p
let rec using_field ctx mode e i p =
if mode = MSet then raise Not_found;
(* do not try to find using fields if the type is a monomorph, which could lead to side-effects *)
let is_dynamic = match follow e.etype with
| TMono _ -> raise Not_found
| t -> t == t_dynamic
in
let check_constant_struct = ref false in
let rec loop = function
| [] ->
raise Not_found
| c :: l ->
try
let cf = PMap.find i c.cl_statics in
if Meta.has Meta.NoUsing cf.cf_meta then raise Not_found;
let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
let map = apply_params cf.cf_params monos in
let t = map cf.cf_type in
begin match follow t with
| TFun((_,_,(TType({t_path = ["haxe";"macro"],"ExprOf"},[t0]) | t0)) :: args,r) ->
if is_dynamic && follow t0 != t_dynamic then raise Not_found;
Type.unify e.etype t0;
(* early constraints check is possible because e.etype has no monomorphs *)
List.iter2 (fun m (name,t) -> match follow t with
| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] && not (has_mono m) ->
List.iter (fun tc -> Type.unify m (map tc)) constr
| _ -> ()
) monos cf.cf_params;
let et = type_module_type ctx (TClassDecl c) None p in
AKUsing (mk (TField (et,FStatic (c,cf))) t p,c,cf,e)
| _ ->
raise Not_found
end
with Not_found ->
loop l
| Unify_error el ->
if List.exists (function Has_extra_field _ -> true | _ -> false) el then check_constant_struct := true;
loop l
in
try loop ctx.m.module_using with Not_found ->
try
let acc = loop ctx.g.global_using in
(match acc with
| AKUsing (_,c,_,_) -> add_dependency ctx.m.curmod c.cl_module
| _ -> assert false);
acc
with Not_found ->
if not !check_constant_struct then raise Not_found;
remove_constant_flag e.etype (fun ok -> if ok then using_field ctx mode e i p else raise Not_found)
let rec type_ident_raise ?(imported_enums=true) ctx i p mode =