-
-
Notifications
You must be signed in to change notification settings - Fork 648
/
typer.ml
2718 lines (2658 loc) · 95.7 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
(*
The Haxe Compiler
Copyright (C) 2005-2019 Haxe Foundation
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*)
open Ast
open DisplayTypes.DisplayMode
open DisplayException
open DisplayTypes.CompletionResultKind
open CompletionItem.ClassFieldOrigin
open Common
open Type
open Typecore
open Error
open Globals
open TyperBase
open Fields
open Calls
(* ---------------------------------------------------------------------- *)
(* TOOLS *)
let check_assign ctx e =
match e.eexpr with
| TLocal {v_final = true} ->
error "Cannot assign to final" e.epos
| TLocal {v_extra = None} | TArray _ | TField _ | TIdent _ ->
()
| TConst TThis | TTypeExpr _ when ctx.untyped ->
()
| _ ->
invalid_assign e.epos
type type_class =
| KInt
| KFloat
| KString
| KUnk
| KDyn
| KOther
| KParam of t
| KAbstract of tabstract * t list
let rec classify t =
match follow t with
| TInst ({ cl_path = ([],"String") },[]) -> KString
| TAbstract({a_impl = Some _} as a,tl) -> KAbstract (a,tl)
| 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 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
let maybe_type_against_enum ctx f with_type iscall p =
try
begin match with_type with
| WithType.WithType(t,_) ->
let rec loop stack t = match follow t with
| TEnum (en,_) ->
true,en.e_path,en.e_names,TEnumDecl en
| TAbstract ({a_impl = Some c} as a,_) when has_meta Meta.Enum a.a_meta ->
let fields = ExtList.List.filter_map (fun cf ->
if Meta.has Meta.Enum cf.cf_meta then Some cf.cf_name else None
) c.cl_ordered_statics in
false,a.a_path,fields,TAbstractDecl a
| TAbstract (a,pl) when not (Meta.has Meta.CoreType a.a_meta) ->
begin match get_abstract_froms a pl with
| [t2] ->
if (List.exists (fast_eq_anon t) stack) then raise Exit;
loop (t :: stack) t2
| _ -> raise Exit
end
| _ ->
raise Exit
in
let is_enum,path,fields,mt = loop [] t in
let old = ctx.m.curmod.m_types in
let restore () = ctx.m.curmod.m_types <- old in
ctx.m.curmod.m_types <- ctx.m.curmod.m_types @ [mt];
let e = try
f()
with
| Error (Unknown_ident n,_) ->
restore();
raise_or_display_message ctx (StringError.string_error n fields ("Identifier '" ^ n ^ "' is not part of " ^ s_type_path path)) p;
AKExpr (mk (TConst TNull) (mk_mono()) p)
| exc ->
restore();
raise exc;
in
restore();
begin match e with
| AKExpr e ->
begin match follow e.etype with
| TFun(_,t') when is_enum ->
(* TODO: this is a dodge for #7603 *)
(try Type.unify t' t with Unify_error _ -> ());
AKExpr e
| _ ->
if iscall then
AKExpr e
else begin
AKExpr (AbstractCast.cast_or_unify ctx t e e.epos)
end
end
| _ -> e (* ??? *)
end
| _ ->
raise Exit
end
with Exit ->
f()
let check_error ctx err p = match err with
| Module_not_found ([],name) when Diagnostics.is_diagnostics_run p ->
DisplayToplevel.handle_unresolved_identifier ctx name p true
| _ ->
display_error ctx (error_msg err) p
(* ---------------------------------------------------------------------- *)
(* PASS 3 : type expression & check structure *)
let rec unify_min_raise basic (el:texpr list) : t =
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_params 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_params params (TInst (csup,pl)) in
loop t);
tl := t :: !tl;
| TType (td,pl) ->
loop (apply_params td.t_params pl td.t_type);
(* prioritize the most generic definition *)
tl := t :: !tl;
| TLazy f -> loop (lazy_type f)
| TMono r -> (match !r with None -> () | Some t -> loop t)
| _ -> tl := t :: !tl)
in
loop t;
!tl
in
match el with
| [] -> mk_mono()
| [e] -> e.etype
| _ ->
let rec chk_null e = is_null e.etype || is_explicit_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 basic.tnull t else t in
try
Type.unify e.etype t;
loop t el
with Unify_error _ -> try
Type.unify t e.etype;
loop (if is_null t then basic.tnull e.etype else e.etype) el
with Unify_error _ ->
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 ->
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 basic el with Unify_error _ -> raise Not_found in
PMap.add n (mk_field n t (List.hd el).epos null_pos) 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 Type.unify e.etype t; true
with Unify_error l -> if !first_error = None then first_error := Some(Unify l,e.epos); false)
in
common_types := List.filter filter !common_types;
match !common_types, !first_error with
| [], Some(err,p) -> raise_error err p
| _ -> ()
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.com.basic el
with Error (Unify l,p) ->
if not ctx.untyped then display_error ctx (error_msg (Unify l)) p;
(List.hd el).etype
let unify_min_for_type_source ctx el src =
match src with
| Some WithType.ImplicitReturn when List.exists (fun e -> ExtType.is_void (follow e.etype)) el ->
ctx.com.basic.tvoid
| _ ->
unify_min ctx el
let rec type_ident_raise ctx i p mode =
match i with
| "true" ->
if mode = MGet then
AKExpr (mk (TConst (TBool true)) ctx.t.tbool p)
else
AKNo i
| "false" ->
if mode = MGet then
AKExpr (mk (TConst (TBool false)) ctx.t.tbool p)
else
AKNo i
| "this" ->
if mode = MSet then add_class_field_flag ctx.curfield CfModifiesThis;
(match mode, ctx.curclass.cl_kind with
| MSet, KAbstractImpl _ ->
if not (assign_to_this_is_allowed ctx) then
error "Abstract 'this' value can only be modified inside an inline function" p;
AKExpr (get_this ctx p)
| (MCall, KAbstractImpl _) | (MGet, _)-> AKExpr(get_this ctx p)
| _ -> AKNo i)
| "super" ->
let t = (match ctx.curclass.cl_super with
| None -> error "Current class does not have a superclass" p
| Some (c,params) -> TInst(c,params)
) in
(match ctx.curfun with
| FunMember | FunConstructor -> ()
| FunMemberAbstract -> error "Cannot access super inside an abstract function" p
| FunStatic -> error "Cannot access super inside a static function" p;
| FunMemberClassLocal | FunMemberAbstractLocal -> error "Cannot access super inside a local function" p);
AKExpr (mk (TConst TSuper) t p)
| "null" ->
if mode = MGet then
AKExpr (null (mk_mono()) p)
else
AKNo i
| _ ->
try
let v = PMap.find i ctx.locals in
(match v.v_extra with
| Some (params,e) ->
let t = monomorphs params v.v_type in
(match e with
| Some ({ eexpr = TFunction f } as e) when ctx.com.display.dms_inline ->
begin match mode with
| MSet -> error "Cannot set inline closure" p
| MGet -> error "Cannot create closure on inline closure" p
| MCall ->
(* create a fake class with a fake field to emulate inlining *)
let c = mk_class ctx.m.curmod (["local"],v.v_name) e.epos null_pos in
let cf = { (mk_field v.v_name v.v_type e.epos null_pos) with cf_params = params; cf_expr = Some e; cf_kind = Method MethInline } in
c.cl_extern <- true;
c.cl_fields <- PMap.add cf.cf_name cf PMap.empty;
AKInline (mk (TConst TNull) (TInst (c,[])) p, cf, FInstance(c,[],cf), t)
end
| _ ->
AKExpr (mk (TLocal v) t p))
| _ ->
AKExpr (mk (TLocal v) v.v_type p))
with Not_found -> try
(* member variable lookup *)
if ctx.curfun = FunStatic then raise Not_found;
let c , t , f = class_field ctx ctx.curclass (List.map snd ctx.curclass.cl_params) i p in
field_access ctx mode f (match c with None -> FAnon f | Some (c,tl) -> FInstance (c,tl,f)) t (get_this ctx p) p
with Not_found -> try
(* static variable lookup *)
let f = PMap.find i ctx.curclass.cl_statics in
if Meta.has Meta.Impl f.cf_meta && not (Meta.has Meta.Impl ctx.curfield.cf_meta) && not (Meta.has Meta.Enum f.cf_meta) then
error (Printf.sprintf "Cannot access non-static field %s from static method" f.cf_name) p;
let e = type_type ctx ctx.curclass.cl_path p in
(* check_locals_masking already done in type_type *)
field_access ctx mode f (FStatic (ctx.curclass,f)) (field_type ctx ctx.curclass [] f p) e p
with Not_found -> try
let wrap e = if mode = MSet then
AKNo i
else
AKExpr e
in
(* lookup imported enums *)
let rec loop l =
match l with
| [] -> raise Not_found
| (t,pt) :: l ->
match t with
| TAbstractDecl ({a_impl = Some c} as a) when Meta.has Meta.Enum a.a_meta ->
begin try
let cf = PMap.find i c.cl_statics in
if not (Meta.has Meta.Enum cf.cf_meta) then
loop l
else begin
let et = type_module_type ctx (TClassDecl c) None p in
let fa = FStatic(c,cf) in
let t = monomorphs cf.cf_params cf.cf_type in
ImportHandling.maybe_mark_import_position ctx pt;
begin match cf.cf_kind with
| Var {v_read = AccInline} -> AKInline(et,cf,fa,t)
| _ -> AKExpr (mk (TField(et,fa)) t p)
end
end
with Not_found ->
loop l
end
| TClassDecl _ | TAbstractDecl _ ->
loop l
| TTypeDecl t ->
(match follow t.t_type with
| TEnum (e,_) -> loop ((TEnumDecl e,pt) :: l)
| TAbstract (a,_) when Meta.has Meta.Enum a.a_meta -> loop ((TAbstractDecl a,pt) :: l)
| _ -> loop l)
| TEnumDecl e ->
try
let ef = PMap.find i e.e_constrs in
let et = type_module_type ctx t None p in
let monos = List.map (fun _ -> mk_mono()) e.e_params in
let monos2 = List.map (fun _ -> mk_mono()) ef.ef_params in
ImportHandling.maybe_mark_import_position ctx pt;
wrap (mk (TField (et,FEnum (e,ef))) (enum_field_type ctx e ef monos monos2 p) p)
with
Not_found -> loop l
in
(try loop (List.rev_map (fun t -> t,null_pos) ctx.m.curmod.m_types) with Not_found -> loop ctx.m.module_types)
with Not_found ->
(* lookup imported globals *)
let t, name, pi = PMap.find i ctx.m.module_globals in
ImportHandling.maybe_mark_import_position ctx pi;
let e = type_module_type ctx t None p in
type_field_default_cfg ctx e name p mode
(*
We want to try unifying as an integer and apply side effects.
However, in case the value is not a normal Monomorph but one issued
from a Dynamic relaxation, we will instead unify with float since
we don't want to accidentaly truncate the value
*)
let unify_int ctx e k =
let is_dynamic t =
match follow t with
| TDynamic _ -> true
| _ -> false
in
let is_dynamic_array t =
match follow t with
| TInst (_,[p]) -> is_dynamic p
| _ -> true
in
let is_dynamic_field t f =
match follow t with
| TAnon a ->
(try is_dynamic (PMap.find f a.a_fields).cf_type with Not_found -> false)
| TInst (c,tl) ->
(try is_dynamic (apply_params c.cl_params tl ((let _,t,_ = Type.class_field c tl f in t))) with Not_found -> false)
| _ ->
true
in
let is_dynamic_return t =
match follow t with
| TFun (_,r) -> is_dynamic r
| _ -> true
in
(*
This is some quick analysis that matches the most common cases of dynamic-to-mono convertions
*)
let rec maybe_dynamic_mono e =
match e.eexpr with
| TLocal _ -> is_dynamic e.etype
| TArray({ etype = t } as e,_) -> is_dynamic_array t || maybe_dynamic_rec e t
| TField({ etype = t } as e,f) -> is_dynamic_field t (field_name f) || maybe_dynamic_rec e t
| TCall({ etype = t } as e,_) -> is_dynamic_return t || maybe_dynamic_rec e t
| TParenthesis e | TMeta(_,e) -> maybe_dynamic_mono e
| TIf (_,a,Some b) -> maybe_dynamic_mono a || maybe_dynamic_mono b
| _ -> false
and maybe_dynamic_rec e t =
match follow t with
| TMono _ | TDynamic _ -> maybe_dynamic_mono e
(* we might have inferenced a tmono into a single field *)
| TAnon a when !(a.a_status) = Opened -> maybe_dynamic_mono e
| _ -> false
in
match k with
| KUnk | KDyn when maybe_dynamic_mono e ->
unify ctx e.etype ctx.t.tfloat e.epos;
false
| _ ->
unify ctx e.etype ctx.t.tint e.epos;
true
let rec type_binop ctx op e1 e2 is_assign_op with_type p =
let type_non_assign_op abstract_overload_only =
(* If the with_type is an abstract which has exactly one applicable @:op method, we can promote it
to the individual arguments (issue #2786). *)
let wt = match with_type with
| WithType.WithType(t,_) ->
begin match follow t with
| TAbstract(a,_) ->
begin match List.filter (fun (o,_) -> o = OpAssignOp(op) || o == op) a.a_ops with
| [_] -> with_type
| _ -> WithType.value
end
| _ ->
WithType.value
end
| _ ->
WithType.value
in
let e1 = type_expr ctx e1 wt in
type_binop2 ~abstract_overload_only ctx op e1 e2 is_assign_op wt p
in
match op with
| OpAssign ->
let e1 = type_access ctx (fst e1) (snd e1) MSet in
let e2 with_type = type_expr ctx e2 with_type in
(match e1 with
| AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p
| AKExpr { eexpr = TLocal { v_kind = VUser TVOLocalFunction; v_name = name } } ->
error ("Cannot access function " ^ name ^ " for writing") p
| AKExpr e1 ->
let e2 = e2 (WithType.with_type e1.etype) in
let e2 = AbstractCast.cast_or_unify ctx e1.etype e2 p in
check_assign ctx e1;
(match e1.eexpr , e2.eexpr with
| TLocal i1 , TLocal i2 when i1 == i2 -> error "Assigning a value to itself" p
| TField ({ eexpr = TConst TThis },FInstance (_,_,f1)) , TField ({ eexpr = TConst TThis },FInstance (_,_,f2)) when f1 == f2 ->
error "Assigning a value to itself" p
| _ , _ -> ());
mk (TBinop (op,e1,e2)) e1.etype p
| AKSet (e,t,cf) ->
let e2 = e2 (WithType.with_type t) in
let e2 = AbstractCast.cast_or_unify ctx t e2 p in
make_call ctx (mk (TField (e,quick_field_dynamic e.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [e2] t p
| AKAccess(a,tl,c,ebase,ekey) ->
let e2 = e2 WithType.value in
mk_array_set_call ctx (AbstractCast.find_array_access ctx a tl ekey (Some e2) p) c ebase p
| AKFieldSet(ethis,e1,fname,t) ->
let e2 = e2 (WithType.with_type t) in
begin match follow e1.etype with
| TFun([_;_;(_,_,t)],_) -> unify ctx e2.etype t e2.epos;
| _ -> assert false
end;
make_call ctx e1 [ethis;Texpr.Builder.make_string ctx.t fname null_pos;e2] t p
| AKUsing(ef,_,_,et,_) ->
(* this must be an abstract setter *)
let e2,ret = match follow ef.etype with
| TFun([_;(_,_,t)],ret) ->
let e2 = e2 (WithType.with_type t) in
AbstractCast.cast_or_unify ctx t e2 p,ret
| _ -> error "Invalid field type for abstract setter" p
in
make_call ctx ef [et;e2] ret p
| AKInline _ | AKMacro _ ->
assert false)
| OpAssignOp (OpBoolAnd | OpBoolOr) ->
error "The operators ||= and &&= are not supported" p
| OpAssignOp op ->
(match type_access ctx (fst e1) (snd e1) MSet with
| AKNo s ->
(* try abstract operator overloading *)
(try type_non_assign_op true
with Not_found -> error ("Cannot access field or identifier " ^ s ^ " for writing") p
)
| AKExpr e ->
let save = save_locals ctx in
let v = gen_local ctx e.etype e.epos in
let has_side_effect = OptimizerTexpr.has_side_effect e in
let e1 = if has_side_effect then (EConst(Ident v.v_name),e.epos) else e1 in
let eop = type_binop ctx op e1 e2 true with_type p in
save();
(match eop.eexpr with
| TBinop (_,_,e2) ->
unify ctx eop.etype e.etype p;
check_assign ctx e;
mk (TBinop (OpAssignOp op,e,e2)) e.etype p;
| TMeta((Meta.RequiresAssign,_,_),e2) ->
unify ctx e2.etype e.etype p;
check_assign ctx e;
begin match e.eexpr with
| TArray(ea1,ea2) when has_side_effect ->
let v1 = gen_local ctx ea1.etype ea1.epos in
let ev1 = mk (TLocal v1) v1.v_type p in
let v2 = gen_local ctx ea2.etype ea2.epos in
let ev2 = mk (TLocal v2) v2.v_type p in
let e = {e with eexpr = TArray(ev1,ev2)} in
mk (TBlock [
mk (TVar(v1,Some ea1)) ctx.t.tvoid p;
mk (TVar(v2,Some ea2)) ctx.t.tvoid p;
mk (TVar(v,Some e)) ctx.t.tvoid p;
mk (TBinop (OpAssign,e,e2)) e.etype p;
]) e.etype p
| TField(ea1,fa) when has_side_effect ->
let v1 = gen_local ctx ea1.etype ea1.epos in
let ev1 = mk (TLocal v1) v1.v_type p in
let e = {e with eexpr = TField(ev1,fa)} in
mk (TBlock [
mk (TVar(v1,Some ea1)) ctx.t.tvoid p;
mk (TVar(v,Some e)) ctx.t.tvoid p;
mk (TBinop (OpAssign,e,e2)) e.etype p;
]) e.etype p
| _ ->
mk (TBinop (OpAssign,e,e2)) e.etype p;
end
| _ ->
(* this must be an abstract cast *)
check_assign ctx e;
if has_side_effect then
mk (TBlock [
mk (TVar(v,Some e)) ctx.t.tvoid eop.epos;
eop
]) eop.etype eop.epos
else
eop)
| AKSet (e,t,cf) ->
let l = save_locals ctx in
let v = gen_local ctx e.etype e.epos in
let ev = mk (TLocal v) e.etype p in
let get = type_binop ctx op (EField ((EConst (Ident v.v_name),p),cf.cf_name),p) e2 true with_type p in
let e' = match get.eexpr with
| TBinop _ | TMeta((Meta.RequiresAssign,_,_),_) ->
unify ctx get.etype t p;
make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [get] t p
| _ ->
(* abstract setter *)
get
in
l();
mk (TBlock [
mk (TVar (v,Some e)) ctx.t.tvoid p;
e'
]) t p
| AKUsing(ef,c,cf,et,_) ->
(* abstract setter + getter *)
let ta = match c.cl_kind with KAbstractImpl a -> TAbstract(a, List.map (fun _ -> mk_mono()) a.a_params) | _ -> assert false in
let ret = match follow ef.etype with
| TFun([_;_],ret) -> ret
| _ -> error "Invalid field type for abstract setter" p
in
let l = save_locals ctx in
let v,is_temp = match et.eexpr with
| TLocal v when not (v.v_name = "this") -> v,false
| _ -> gen_local ctx ta ef.epos,true
in
let ev = mk (TLocal v) ta p in
(* this relies on the fact that cf_name is set_name *)
let getter_name = String.sub cf.cf_name 4 (String.length cf.cf_name - 4) in
let get = type_binop ctx op (EField ((EConst (Ident v.v_name),p),getter_name),p) e2 true with_type p in
unify ctx get.etype ret p;
l();
let e_call = make_call ctx ef [ev;get] ret p in
if is_temp then
mk (TBlock [
mk (TVar (v,Some et)) ctx.t.tvoid p;
e_call
]) ret p
else
e_call
| AKAccess(a,tl,c,ebase,ekey) ->
let cf_get,tf_get,r_get,ekey,_ = AbstractCast.find_array_access ctx a tl ekey None p in
(* bind complex keys to a variable so they do not make it into the output twice *)
let save = save_locals ctx in
let maybe_bind_to_temp e = match Optimizer.make_constant_expression ctx e with
| Some e -> e,None
| None ->
let v = gen_local ctx e.etype p in
let e' = mk (TLocal v) e.etype p in
e', Some (mk (TVar (v,Some e)) ctx.t.tvoid p)
in
let ekey,ekey' = maybe_bind_to_temp ekey in
let ebase,ebase' = maybe_bind_to_temp ebase in
let eget = mk_array_get_call ctx (cf_get,tf_get,r_get,ekey,None) c ebase p in
let eget = type_binop2 ctx op eget e2 true (WithType.with_type eget.etype) p in
unify ctx eget.etype r_get p;
let cf_set,tf_set,r_set,ekey,eget = AbstractCast.find_array_access ctx a tl ekey (Some eget) p in
let eget = match eget with None -> assert false | Some e -> e in
let et = type_module_type ctx (TClassDecl c) None p in
let e = match cf_set.cf_expr,cf_get.cf_expr with
| None,None ->
let ea = mk (TArray(ebase,ekey)) r_get p in
mk (TBinop(OpAssignOp op,ea,type_expr ctx e2 (WithType.with_type r_get))) r_set p
| Some _,Some _ ->
let ef_set = mk (TField(et,(FStatic(c,cf_set)))) tf_set p in
let el = [make_call ctx ef_set [ebase;ekey;eget] r_set p] in
let el = match ebase' with None -> el | Some ebase -> ebase :: el in
let el = match ekey' with None -> el | Some ekey -> ekey :: el in
begin match el with
| [e] -> e
| el -> mk (TBlock el) r_set p
end
| _ ->
error "Invalid array access getter/setter combination" p
in
save();
e
| AKFieldSet _ ->
error "Invalid operation" p
| AKInline _ | AKMacro _ ->
assert false)
| _ ->
type_non_assign_op false
and type_binop2 ?(abstract_overload_only=false) ctx op (e1 : texpr) (e2 : Ast.expr) is_assign_op wt p =
let with_type = match op with
| OpEq | OpNotEq | OpLt | OpLte | OpGt | OpGte -> WithType.with_type e1.etype
| _ -> wt
in
let e2 = type_expr ctx e2 with_type in
let tint = ctx.t.tint in
let tfloat = ctx.t.tfloat in
let tstring = ctx.t.tstring in
let to_string e =
let rec loop t = match classify t with
| KAbstract ({a_impl = Some c},_) when PMap.mem "toString" c.cl_statics ->
call_to_string ctx e
| KInt | KFloat | KString -> e
| KUnk | KDyn | KParam _ | KOther ->
let std = type_type ctx ([],"Std") e.epos in
let acc = acc_get ctx (type_field_default_cfg ctx std "string" e.epos MCall) e.epos in
ignore(follow acc.etype);
let acc = (match acc.eexpr with TField (e,FClosure (Some (c,tl),f)) -> { acc with eexpr = TField (e,FInstance (c,tl,f)) } | _ -> acc) in
make_call ctx acc [e] ctx.t.tstring e.epos
| KAbstract (a,tl) ->
try
AbstractCast.cast_or_unify_raise ctx tstring e p
with Error (Unify _,_) ->
loop (Abstract.get_underlying_type a tl)
in
loop e.etype
in
let mk_op e1 e2 t =
if op = OpAdd && (classify t) = KString then
let e1 = to_string e1 in
let e2 = to_string e2 in
mk (TBinop (op,e1,e2)) t p
else
mk (TBinop (op,e1,e2)) t p
in
let make e1 e2 = match op with
| OpAdd ->
mk_op e1 e2 (match classify e1.etype, classify e2.etype with
| KInt , KInt ->
tint
| KFloat , KInt
| KInt, KFloat
| KFloat, KFloat ->
tfloat
| KUnk , KInt ->
if unify_int ctx e1 KUnk then tint else tfloat
| KUnk , KFloat
| KUnk , KString ->
unify ctx e1.etype e2.etype e1.epos;
e1.etype
| KInt , KUnk ->
if unify_int ctx e2 KUnk then tint else tfloat
| KFloat , KUnk
| KString , KUnk ->
unify ctx e2.etype e1.etype e2.epos;
e2.etype
| _ , KString
| KString , _ ->
tstring
| _ , KDyn ->
e2.etype
| KDyn , _ ->
e1.etype
| KUnk , KUnk ->
let ok1 = unify_int ctx e1 KUnk in
let ok2 = unify_int ctx e2 KUnk in
if ok1 && ok2 then tint else tfloat
| KParam t1, KParam t2 when Type.type_iseq t1 t2 ->
t1
| KParam t, KInt | KInt, KParam t ->
t
| KParam _, KFloat | KFloat, KParam _ | KParam _, KParam _ ->
tfloat
| KParam t, KUnk ->
unify ctx e2.etype tfloat e2.epos;
tfloat
| KUnk, KParam t ->
unify ctx e1.etype tfloat e1.epos;
tfloat
| KAbstract _,KFloat ->
unify ctx e1.etype tfloat e1.epos;
tfloat
| KFloat, KAbstract _ ->
unify ctx e2.etype tfloat e2.epos;
tfloat
| KAbstract _,KInt ->
unify ctx e1.etype ctx.t.tint e1.epos;
ctx.t.tint
| KInt, KAbstract _ ->
unify ctx e2.etype ctx.t.tint e2.epos;
ctx.t.tint
| KAbstract _,_
| _,KAbstract _
| KParam _, _
| _, KParam _
| KOther, _
| _ , KOther ->
let pr = print_context() in
error ("Cannot add " ^ s_type pr e1.etype ^ " and " ^ s_type pr e2.etype) p
)
| OpAnd
| OpOr
| OpXor
| OpShl
| OpShr
| OpUShr ->
let i = tint in
unify ctx e1.etype i e1.epos;
unify ctx e2.etype i e2.epos;
mk_op e1 e2 i
| OpMod
| OpMult
| OpDiv
| OpSub ->
let result = ref (if op = OpDiv then tfloat else tint) in
(match classify e1.etype, classify e2.etype with
| KFloat, KFloat ->
result := tfloat
| KParam t1, KParam t2 when Type.type_iseq t1 t2 ->
if op <> OpDiv then result := t1
| KParam _, KParam _ ->
result := tfloat
| KParam t, KInt | KInt, KParam t ->
if op <> OpDiv then result := t
| KParam _, KFloat | KFloat, KParam _ ->
result := tfloat
| KFloat, k ->
ignore(unify_int ctx e2 k);
result := tfloat
| k, KFloat ->
ignore(unify_int ctx e1 k);
result := tfloat
| k1 , k2 ->
let ok1 = unify_int ctx e1 k1 in
let ok2 = unify_int ctx e2 k2 in
if not ok1 || not ok2 then result := tfloat;
);
mk_op e1 e2 !result
| OpEq
| OpNotEq ->
let e1,e2 = try
(* we only have to check one type here, because unification fails if one is Void and the other is not *)
(match follow e2.etype with TAbstract({a_path=[],"Void"},_) -> error "Cannot compare Void" p | _ -> ());
AbstractCast.cast_or_unify_raise ctx e2.etype e1 p,e2
with Error (Unify _,_) ->
e1,AbstractCast.cast_or_unify ctx e1.etype e2 p
in
if not ctx.com.config.pf_supports_function_equality then begin match e1.eexpr, e2.eexpr with
| TConst TNull , _ | _ , TConst TNull -> ()
| _ ->
match follow e1.etype, follow e2.etype with
| TFun _ , _ | _, TFun _ -> ctx.com.warning "Comparison of function values is unspecified on this target, use Reflect.compareMethods instead" p
| _ -> ()
end;
mk_op e1 e2 ctx.t.tbool
| OpGt
| OpGte
| OpLt
| OpLte ->
(match classify e1.etype, classify e2.etype with
| KInt , KInt | KInt , KFloat | KFloat , KInt | KFloat , KFloat | KString , KString -> ()
| KInt , KUnk -> ignore(unify_int ctx e2 KUnk)
| KFloat , KUnk | KString , KUnk -> unify ctx e2.etype e1.etype e2.epos
| KUnk , KInt -> ignore(unify_int ctx e1 KUnk)
| KUnk , KFloat | KUnk , KString -> unify ctx e1.etype e2.etype e1.epos
| KUnk , KUnk ->
ignore(unify_int ctx e1 KUnk);
ignore(unify_int ctx e2 KUnk);
| KDyn , KInt | KDyn , KFloat | KDyn , KString -> ()
| KInt , KDyn | KFloat , KDyn | KString , KDyn -> ()
| KDyn , KDyn -> ()
| KParam _ , x when x <> KString && x <> KOther -> ()
| x , KParam _ when x <> KString && x <> KOther -> ()
| KAbstract _,_
| _,KAbstract _
| KDyn , KUnk
| KUnk , KDyn
| KString , KInt
| KString , KFloat
| KInt , KString
| KFloat , KString
| KParam _ , _
| _ , KParam _
| KOther , _
| _ , KOther ->
let pr = print_context() in
error ("Cannot compare " ^ s_type pr e1.etype ^ " and " ^ s_type pr e2.etype) p
);
mk_op e1 e2 ctx.t.tbool
| OpBoolAnd
| OpBoolOr ->
let b = ctx.t.tbool in
unify ctx e1.etype b p;
unify ctx e2.etype b p;
mk_op e1 e2 b
| OpInterval ->
let t = Typeload.load_core_type ctx "IntIterator" in
unify ctx e1.etype tint e1.epos;
unify ctx e2.etype tint e2.epos;
mk (TNew ((match t with TInst (c,[]) -> c | _ -> assert false),[],[e1;e2])) t p
| OpArrow ->
error "Unexpected =>" p
| OpIn ->
error "Unexpected in" p
| OpAssign
| OpAssignOp _ ->
assert false
in
let find_overload a c tl left =
let map = apply_params a.a_params tl in
let make op_cf cf e1 e2 tret =
if cf.cf_expr = None then begin
if not (Meta.has Meta.NoExpr cf.cf_meta) then display_error ctx "Recursive operator method" p;
if not (Meta.has Meta.CoreType a.a_meta) then begin
(* for non core-types we require that the return type is compatible to the native result type *)
let e' = make {e1 with etype = Abstract.follow_with_abstracts e1.etype} {e1 with etype = Abstract.follow_with_abstracts e2.etype} in
let t_expected = e'.etype in
begin try
unify_raise ctx tret t_expected p
with Error (Unify _,_) ->
match follow tret with
| TAbstract(a,tl) when type_iseq (Abstract.get_underlying_type a tl) t_expected ->
()
| _ ->
let st = s_type (print_context()) in
error (Printf.sprintf "The result of this operation (%s) is not compatible with declared return type %s" (st t_expected) (st tret)) p
end;
end;
let e = Texpr.Builder.binop op e1 e2 tret p in
mk_cast e tret p
end else begin
let e = make_static_call ctx c cf map [e1;e2] tret p in
e
end
in
(* special case for == and !=: if the second type is a monomorph, assume that we want to unify
it with the first type to preserve comparison semantics. *)
let is_eq_op = match op with OpEq | OpNotEq -> true | _ -> false in
if is_eq_op then begin match follow e1.etype,follow e2.etype with
| TMono _,_ | _,TMono _ ->
Type.unify e1.etype e2.etype
| _ ->
()
end;
let rec loop ol = match ol with
| (op_cf,cf) :: ol when op_cf <> op && (not is_assign_op || op_cf <> OpAssignOp(op)) ->
loop ol
| (op_cf,cf) :: ol ->
let is_impl = Meta.has Meta.Impl cf.cf_meta in
begin match follow cf.cf_type with
| TFun([(_,_,t1);(_,_,t2)],tret) ->
let check e1 e2 swapped =
let map_arguments () =
let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
let map t = map (apply_params cf.cf_params monos t) in
let t1 = map t1 in
let t2 = map t2 in
let tret = map tret in
monos,t1,t2,tret
in
let monos,t1,t2,tret = map_arguments() in
let make e1 e2 = make op_cf cf e1 e2 tret in
let t1 = if is_impl then Abstract.follow_with_abstracts t1 else t1 in
let e1,e2 = if left || not left && swapped then begin
Type.type_eq EqStrict (if is_impl then Abstract.follow_with_abstracts e1.etype else e1.etype) t1;
e1,AbstractCast.cast_or_unify_raise ctx t2 e2 p
end else begin
Type.type_eq EqStrict e2.etype t2;
AbstractCast.cast_or_unify_raise ctx t1 e1 p,e2
end in
check_constraints ctx "" cf.cf_params monos (apply_params a.a_params tl) false cf.cf_pos;
let check_null e t = if is_eq_op then match e.eexpr with
| TConst TNull when not (is_explicit_null t) -> raise (Unify_error [])
| _ -> ()
in
(* If either expression is `null` we only allow operator resolving if the argument type
is explicitly Null<T> (issue #3376) *)
if is_eq_op then begin
check_null e2 t2;
check_null e1 t1;
end;
let e = if not swapped then
make e1 e2
else if not (OptimizerTexpr.has_side_effect e1) && not (OptimizerTexpr.has_side_effect e2) then
make e1 e2
else
let v1,v2 = gen_local ctx t1 e1.epos, gen_local ctx t2 e2.epos in
let ev1,ev2 = mk (TVar(v1,Some e1)) ctx.t.tvoid p,mk (TVar(v2,Some e2)) ctx.t.tvoid p in
let eloc1,eloc2 = mk (TLocal v1) v1.v_type p,mk (TLocal v2) v2.v_type p in
let e = make eloc1 eloc2 in
let e = mk (TBlock [
ev2;
ev1;
e
]) e.etype e.epos in
e
in
if is_assign_op && op_cf = op then (mk (TMeta((Meta.RequiresAssign,[],p),e)) e.etype e.epos)
else e
in
begin try
check e1 e2 false
with Error (Unify _,_) | Unify_error _ -> try
if not (Meta.has Meta.Commutative cf.cf_meta) then raise Not_found;
check e2 e1 true
with Not_found | Error (Unify _,_) | Unify_error _ ->
loop ol
end
| _ ->