|
@@ -30,46 +30,11 @@ open Globals
|
|
|
open TyperBase
|
|
|
open Fields
|
|
|
open Calls
|
|
|
+open Operators
|
|
|
|
|
|
(* ---------------------------------------------------------------------- *)
|
|
|
(* TOOLS *)
|
|
|
|
|
|
-let check_assign ctx e =
|
|
|
- match e.eexpr with
|
|
|
- | TLocal v when has_var_flag v VFinal ->
|
|
|
- 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
|
|
|
- | KNumParam of t
|
|
|
- | KStrParam 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 -> KNumParam t
|
|
|
- | TInst ({ cl_kind = KTypeParameter ctl },_) when List.exists (fun t -> match classify t with KInt | KFloat -> true | _ -> false) ctl -> KNumParam t
|
|
|
- | TAbstract (a,[]) when List.exists (fun t -> match classify t with KString -> true | _ -> false) a.a_to -> KStrParam t
|
|
|
- | TInst ({ cl_kind = KTypeParameter ctl },_) when List.exists (fun t -> match classify t with KString -> true | _ -> false) ctl -> KStrParam t
|
|
|
- | TMono r when r.tm_type = None -> KUnk
|
|
|
- | TDynamic _ -> KDyn
|
|
|
- | _ -> KOther
|
|
|
-
|
|
|
let get_iterator_param t =
|
|
|
match follow t with
|
|
|
| TAnon a ->
|
|
@@ -446,894 +411,6 @@ let rec type_ident_raise ctx i p mode with_type =
|
|
|
let e = type_module_type ctx t None p in
|
|
|
type_field_default_cfg ctx e name p mode with_type
|
|
|
|
|
|
-(*
|
|
|
- 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)
|
|
|
- | TMono m ->
|
|
|
- begin match Monomorph.classify_constraints m with
|
|
|
- | CStructural(fields,_) ->
|
|
|
- (try is_dynamic (PMap.find f fields).cf_type with Not_found -> false)
|
|
|
- | _ ->
|
|
|
- true
|
|
|
- end
|
|
|
- | 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 *)
|
|
|
- (* TODO: check what this did exactly *)
|
|
|
- (* | 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_assign ctx e1 e2 with_type p =
|
|
|
- let e1 = type_access ctx (fst e1) (snd e1) (MSet (Some e2)) with_type in
|
|
|
- let type_rhs with_type = type_expr ctx e2 with_type in
|
|
|
- let assign_to e1 =
|
|
|
- let e2 = type_rhs (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 (OpAssign,e1,e2)) e1.etype p
|
|
|
- in
|
|
|
- (match e1 with
|
|
|
- | AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p
|
|
|
- | AKUsingField _ ->
|
|
|
- error "Invalid operation" p
|
|
|
- | AKExpr { eexpr = TLocal { v_kind = VUser TVOLocalFunction; v_name = name } } ->
|
|
|
- error ("Cannot access function " ^ name ^ " for writing") p
|
|
|
- | AKField fa ->
|
|
|
- let ef = FieldAccess.get_field_expr fa FWrite in
|
|
|
- assign_to ef
|
|
|
- | AKExpr e1 ->
|
|
|
- assign_to e1
|
|
|
- | AKAccessor fa ->
|
|
|
- let fa_set = match FieldAccess.resolve_accessor fa (MSet (Some e2)) with
|
|
|
- | AccessorFound fa -> fa
|
|
|
- | _ -> error "Could not resolve accessor" p
|
|
|
- in
|
|
|
- let dispatcher = new call_dispatcher ctx (MCall [e2]) with_type p in
|
|
|
- dispatcher#field_call fa_set [] [e2]
|
|
|
- | AKAccess(a,tl,c,ebase,ekey) ->
|
|
|
- let e2 = type_rhs WithType.value in
|
|
|
- mk_array_set_call ctx (AbstractCast.find_array_access ctx a tl ekey (Some e2) p) c ebase p
|
|
|
- | AKResolve(sea,name) ->
|
|
|
- let eparam = sea.se_this in
|
|
|
- let e_name = Texpr.Builder.make_string ctx.t name null_pos in
|
|
|
- (new call_dispatcher ctx (MCall [e2]) with_type p)#field_call sea.se_access [eparam;e_name] [e2]
|
|
|
- | AKUsingAccessor sea ->
|
|
|
- let fa_set = match FieldAccess.resolve_accessor sea.se_access (MSet (Some e2)) with
|
|
|
- | AccessorFound fa -> fa
|
|
|
- | _ -> error "Could not resolve accessor" p
|
|
|
- in
|
|
|
- let dispatcher = new call_dispatcher ctx (MCall [e2]) with_type p in
|
|
|
- dispatcher#field_call fa_set [sea.se_this] [e2]
|
|
|
- )
|
|
|
-
|
|
|
-and 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
|
|
|
- let e2_syntax = e2 in
|
|
|
- match op with
|
|
|
- | OpAssign ->
|
|
|
- type_assign ctx e1 e2 with_type p
|
|
|
- | OpAssignOp (OpBoolAnd | OpBoolOr) ->
|
|
|
- error "The operators ||= and &&= are not supported" p
|
|
|
- | OpAssignOp op ->
|
|
|
- let handle 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)
|
|
|
- in
|
|
|
- (match type_access ctx (fst e1) (snd e1) (MSet (Some e2)) with_type 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
|
|
|
- )
|
|
|
- | AKUsingField _ ->
|
|
|
- error "Invalid operation" p
|
|
|
- | AKField fa ->
|
|
|
- let e1 = FieldAccess.get_field_expr fa FWrite in
|
|
|
- handle e1
|
|
|
- | AKExpr e ->
|
|
|
- handle e
|
|
|
- | AKAccessor fa ->
|
|
|
- let e = fa.fa_on in
|
|
|
- let cf = fa.fa_field in
|
|
|
- let t = (FieldAccess.get_field_expr fa FCall).etype in
|
|
|
- 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
|
|
|
- | AKUsingAccessor sea ->
|
|
|
- let fa_set = match FieldAccess.resolve_accessor sea.se_access (MSet (Some e2_syntax)) with
|
|
|
- | AccessorFound fa -> fa
|
|
|
- | _ -> error "Could not resolve accessor" p
|
|
|
- in
|
|
|
- let ef = FieldAccess.get_field_expr fa_set FWrite in
|
|
|
- let et = sea.se_this in
|
|
|
- (* abstract setter + getter *)
|
|
|
- let ta = match sea.se_access.fa_host with
|
|
|
- | FHAbstract(a,tl,_) -> TAbstract(a,tl)
|
|
|
- | _ -> die "" __LOC__
|
|
|
- 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,init_exprs,abstr_this_to_modify = match et.eexpr with
|
|
|
- | TLocal v when not (Meta.has Meta.This v.v_meta) -> v,[],None
|
|
|
- | _ ->
|
|
|
- let v = gen_local ctx ta ef.epos in
|
|
|
- (match et.eexpr with
|
|
|
- | TLocal { v_meta = m } -> v.v_meta <- Meta.copy_from_to Meta.This m v.v_meta
|
|
|
- | _ -> ()
|
|
|
- );
|
|
|
- let decl_v e = mk (TVar (v,Some e)) ctx.t.tvoid p in
|
|
|
- let rec needs_temp_var e =
|
|
|
- match e.eexpr with
|
|
|
- | TConst TThis | TTypeExpr _ -> false
|
|
|
- | TField (e1,(FInstance(_,_,cf) | FStatic(_,cf)))
|
|
|
- when has_class_field_flag cf CfFinal ->
|
|
|
- needs_temp_var e1
|
|
|
- | TParenthesis e1 ->
|
|
|
- needs_temp_var e1
|
|
|
- | _ -> true
|
|
|
- in
|
|
|
- if has_class_field_flag fa_set.fa_field CfModifiesThis then
|
|
|
- match et.eexpr with
|
|
|
- | TField (target,fa) when needs_temp_var target->
|
|
|
- let tmp = gen_local ctx target.etype target.epos in
|
|
|
- let decl_tmp = mk (TVar (tmp,Some target)) ctx.t.tvoid target.epos in
|
|
|
- let etmp = mk (TLocal tmp) tmp.v_type tmp.v_pos in
|
|
|
- let athis = mk (TField (etmp,fa)) et.etype et.epos in
|
|
|
- v,[decl_tmp; decl_v athis],(Some athis)
|
|
|
- | TArray (target,index) when needs_temp_var target ->
|
|
|
- let tmp = gen_local ctx target.etype target.epos in
|
|
|
- let decl_tmp = mk (TVar (tmp,Some target)) ctx.t.tvoid target.epos in
|
|
|
- let etmp = mk (TLocal tmp) tmp.v_type tmp.v_pos in
|
|
|
- let athis = mk (TArray (etmp,index)) et.etype et.epos in
|
|
|
- v,[decl_tmp; decl_v athis],(Some athis)
|
|
|
- | _ ->
|
|
|
- check_assign ctx et;
|
|
|
- v,[decl_v et],(Some et)
|
|
|
- else
|
|
|
- v,[decl_v et],None
|
|
|
- in
|
|
|
- let ev = mk (TLocal v) ta p in
|
|
|
- (* this relies on the fact that cf_name is set_name *)
|
|
|
- let getter_name = sea.se_access.fa_field.cf_name 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
|
|
|
- let e_call =
|
|
|
- (*
|
|
|
- If this method modifies abstract `this`, we should also apply temp var
|
|
|
- modifications to the original tempvar-ed expression.
|
|
|
- Find code like `v = value` and change it to `et = v = value`,
|
|
|
- where `v` is the temp var and `et` is the original expression stored to the temp var.
|
|
|
- *)
|
|
|
- match abstr_this_to_modify with
|
|
|
- | None ->
|
|
|
- e_call
|
|
|
- | Some athis ->
|
|
|
- let rec loop e =
|
|
|
- match e.eexpr with
|
|
|
- | TBinop(OpAssign,({ eexpr = TLocal v1 } as left),right) when v1 == v ->
|
|
|
- let right = { e with eexpr = TBinop(OpAssign,left,loop right) } in
|
|
|
- mk (TBinop(OpAssign,athis,right)) e.etype e.epos
|
|
|
- | _ ->
|
|
|
- map_expr loop e
|
|
|
- in
|
|
|
- loop e_call
|
|
|
- in
|
|
|
- mk (TBlock (init_exprs @ [e_call])) ret p
|
|
|
- | 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 -> die "" __LOC__ | 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
|
|
|
- | AKResolve _ ->
|
|
|
- error "Invalid operation" p
|
|
|
- )
|
|
|
- | _ ->
|
|
|
- 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 | KNumParam _ | KStrParam _ | 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 []) with_type) 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
|
|
|
- | KNumParam t1, KNumParam t2 when Type.type_iseq t1 t2 ->
|
|
|
- t1
|
|
|
- | KNumParam t, KInt | KInt, KNumParam t ->
|
|
|
- t
|
|
|
- | KNumParam _, KFloat | KFloat, KNumParam _ | KNumParam _, KNumParam _ ->
|
|
|
- tfloat
|
|
|
- | KNumParam t, KUnk ->
|
|
|
- unify ctx e2.etype tfloat e2.epos;
|
|
|
- tfloat
|
|
|
- | KUnk, KNumParam t ->
|
|
|
- unify ctx e1.etype tfloat e1.epos;
|
|
|
- tfloat
|
|
|
- | KStrParam _, _
|
|
|
- | _, KStrParam _ ->
|
|
|
- tstring
|
|
|
- | 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 _
|
|
|
- | KNumParam _, _
|
|
|
- | _, KNumParam _
|
|
|
- | 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
|
|
|
- | KNumParam t1, KNumParam t2 when Type.type_iseq t1 t2 ->
|
|
|
- if op <> OpDiv then result := t1
|
|
|
- | KNumParam _, KNumParam _ ->
|
|
|
- result := tfloat
|
|
|
- | KNumParam t, KInt | KInt, KNumParam t ->
|
|
|
- if op <> OpDiv then result := t
|
|
|
- | KNumParam _, KFloat | KFloat, KNumParam _ ->
|
|
|
- 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 -> ()
|
|
|
- | KNumParam _ , (KInt | KFloat | KNumParam _ | KDyn | KUnk ) -> ()
|
|
|
- | (KInt | KFloat | KDyn | KUnk ), KNumParam _ -> ()
|
|
|
- | KStrParam _ , (KString | KStrParam _ | KUnk | KDyn) -> ()
|
|
|
- | (KString | KUnk | KDyn) , KStrParam _ -> ()
|
|
|
- | KAbstract _,_
|
|
|
- | _,KAbstract _
|
|
|
- | KDyn , KUnk
|
|
|
- | KUnk , KDyn
|
|
|
- | KString , KInt
|
|
|
- | KString , KFloat
|
|
|
- | KInt , KString
|
|
|
- | KFloat , KString
|
|
|
- | KNumParam _ , _
|
|
|
- | _ , KNumParam _
|
|
|
- | KStrParam _ , _
|
|
|
- | _ , KStrParam _
|
|
|
- | 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 | _ -> die "" __LOC__),[],[e1;e2])) t p
|
|
|
- | OpArrow ->
|
|
|
- error "Unexpected =>" p
|
|
|
- | OpIn ->
|
|
|
- error "Unexpected in" p
|
|
|
- | OpAssign
|
|
|
- | OpAssignOp _ ->
|
|
|
- die "" __LOC__
|
|
|
- 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 = has_class_field_flag cf CfImpl in
|
|
|
- begin match follow cf.cf_type with
|
|
|
- | TFun([(_,_,t1);(_,_,t2)],tret) ->
|
|
|
- let check e1 e2 swapped =
|
|
|
- let map_arguments () =
|
|
|
- let monos = Monomorph.spawn_constrained_monos (fun t -> t) 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
|
|
|
- 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
|
|
|
- | _ ->
|
|
|
- die "" __LOC__
|
|
|
- end
|
|
|
- | [] ->
|
|
|
- raise Not_found
|
|
|
- in
|
|
|
- if left then
|
|
|
- loop a.a_ops
|
|
|
- else
|
|
|
- let not_impl_or_is_commutative (_, cf) =
|
|
|
- not (has_class_field_flag cf CfImpl) || Meta.has Meta.Commutative cf.cf_meta
|
|
|
- in
|
|
|
- loop (List.filter not_impl_or_is_commutative a.a_ops)
|
|
|
- in
|
|
|
- try
|
|
|
- begin match follow e1.etype with
|
|
|
- | TAbstract({a_impl = Some c} as a,tl) -> find_overload a c tl true
|
|
|
- | _ -> raise Not_found
|
|
|
- end
|
|
|
- with Not_found -> try
|
|
|
- begin match follow e2.etype with
|
|
|
- | TAbstract({a_impl = Some c} as a,tl) -> find_overload a c tl false
|
|
|
- | _ -> raise Not_found
|
|
|
- end
|
|
|
- with Not_found ->
|
|
|
- if abstract_overload_only then raise Not_found
|
|
|
- else make e1 e2
|
|
|
-
|
|
|
-and type_unop ctx op flag e p =
|
|
|
- let set = (op = Increment || op = Decrement) in
|
|
|
- let mode = if set then (MSet None) else MGet in
|
|
|
- let acc = type_access ctx (fst e) (snd e) mode WithType.value (* WITHTYPETODO *) in
|
|
|
- let access e =
|
|
|
- let make e =
|
|
|
- let t = (match op with
|
|
|
- | Not ->
|
|
|
- if flag = Postfix then error "Postfix ! is not supported" p;
|
|
|
- unify ctx e.etype ctx.t.tbool e.epos;
|
|
|
- ctx.t.tbool
|
|
|
- | NegBits ->
|
|
|
- unify ctx e.etype ctx.t.tint e.epos;
|
|
|
- ctx.t.tint
|
|
|
- | Increment
|
|
|
- | Decrement
|
|
|
- | Neg ->
|
|
|
- if set then check_assign ctx e;
|
|
|
- (match classify e.etype with
|
|
|
- | KFloat -> ctx.t.tfloat
|
|
|
- | KNumParam t ->
|
|
|
- unify ctx e.etype ctx.t.tfloat e.epos;
|
|
|
- t
|
|
|
- | k ->
|
|
|
- if unify_int ctx e k then ctx.t.tint else ctx.t.tfloat)
|
|
|
- ) in
|
|
|
- mk (TUnop (op,flag,e)) t p
|
|
|
- in
|
|
|
- try (match follow e.etype with
|
|
|
- | TAbstract ({a_impl = Some c} as a,pl) ->
|
|
|
- let rec loop opl = match opl with
|
|
|
- | [] -> raise Not_found
|
|
|
- | (op2,flag2,cf) :: opl when op == op2 && flag == flag2 ->
|
|
|
- let m = spawn_monomorph ctx p in
|
|
|
- let tcf = apply_params a.a_params pl (monomorphs cf.cf_params cf.cf_type) in
|
|
|
- if has_class_field_flag cf CfImpl then begin
|
|
|
- if type_iseq (tfun [apply_params a.a_params pl a.a_this] m) tcf then cf,tcf,m else loop opl
|
|
|
- end else
|
|
|
- if type_iseq (tfun [e.etype] m) tcf then cf,tcf,m else loop opl
|
|
|
- | _ :: opl -> loop opl
|
|
|
- in
|
|
|
- let cf,t,r = try loop a.a_unops with Not_found -> raise Not_found in
|
|
|
- (match cf.cf_expr with
|
|
|
- | None ->
|
|
|
- let e = {e with etype = apply_params a.a_params pl a.a_this} in
|
|
|
- let e = mk (TUnop(op,flag,e)) r p in
|
|
|
- (* unify ctx r e.etype p; *) (* TODO: I'm not sure why this was here (related to #2295) *)
|
|
|
- e
|
|
|
- | Some _ ->
|
|
|
- let et = type_module_type ctx (TClassDecl c) None p in
|
|
|
- let ef = mk (TField (et,FStatic (c,cf))) t p in
|
|
|
- make_call ctx ef [e] r p)
|
|
|
- | _ -> raise Not_found
|
|
|
- ) with Not_found ->
|
|
|
- make e
|
|
|
- in
|
|
|
- let handle_accessor etarget fa =
|
|
|
- let emethod = FieldAccess.get_field_expr fa (if set then FRead else FWrite) in
|
|
|
- let force_inline = fa.fa_inline in
|
|
|
- let l = save_locals ctx in
|
|
|
- let init_tmp,etarget,eget =
|
|
|
- match needs_temp_var etarget, fst e with
|
|
|
- | true, EField (_, field_name) ->
|
|
|
- let tmp = gen_local ctx etarget.etype p in
|
|
|
- let tmp_ident = (EConst (Ident tmp.v_name), p) in
|
|
|
- (
|
|
|
- mk (TVar (tmp, Some etarget)) ctx.t.tvoid p,
|
|
|
- mk (TLocal tmp) tmp.v_type p,
|
|
|
- (EField (tmp_ident,field_name), p)
|
|
|
- )
|
|
|
- | _ -> (mk (TBlock []) ctx.t.tvoid p, etarget, e)
|
|
|
- in
|
|
|
- let op = (match op with Increment -> OpAdd | Decrement -> OpSub | _ -> die "" __LOC__) in
|
|
|
- let one = (EConst (Int "1"),p) in
|
|
|
- (match follow emethod.etype with
|
|
|
- | TFun (_, t) ->
|
|
|
- (match flag with
|
|
|
- | Prefix ->
|
|
|
- let get = type_binop ctx op eget one false WithType.value p in
|
|
|
- unify ctx get.etype t p;
|
|
|
- l();
|
|
|
- let call_setter = make_call ctx emethod [etarget; get] t ~force_inline p in
|
|
|
- mk (TBlock [init_tmp; call_setter]) t p
|
|
|
- | Postfix ->
|
|
|
- let get = type_expr ctx eget WithType.value in
|
|
|
- let tmp_value = gen_local ctx t p in
|
|
|
- let plusone = type_binop ctx op (EConst (Ident tmp_value.v_name),p) one false WithType.value p in
|
|
|
- unify ctx get.etype t p;
|
|
|
- l();
|
|
|
- mk (TBlock [
|
|
|
- init_tmp;
|
|
|
- mk (TVar (tmp_value,Some get)) ctx.t.tvoid p;
|
|
|
- make_call ctx emethod [etarget; plusone] t ~force_inline p;
|
|
|
- mk (TLocal tmp_value) t p;
|
|
|
- ]) t p
|
|
|
- )
|
|
|
- | _ ->
|
|
|
- l();
|
|
|
- die "" __LOC__
|
|
|
- )
|
|
|
- in
|
|
|
- let rec loop acc =
|
|
|
- match acc with
|
|
|
- | AKExpr e ->
|
|
|
- access e
|
|
|
- | AKField fa ->
|
|
|
- if fa.fa_inline && not set then
|
|
|
- access (acc_get ctx acc p)
|
|
|
- else begin
|
|
|
- let e = FieldAccess.get_field_expr fa (if set then FWrite else FRead) in
|
|
|
- access e
|
|
|
- end
|
|
|
- | AKUsingField _ | AKUsingAccessor _ when not set -> access (acc_get ctx acc p)
|
|
|
- | AKNo s ->
|
|
|
- error ("The field or identifier " ^ s ^ " is not accessible for " ^ (if set then "writing" else "reading")) p
|
|
|
- | AKAccess(a,tl,c,ebase,ekey) ->
|
|
|
- begin try
|
|
|
- (match op with Increment | Decrement -> () | _ -> raise Not_found);
|
|
|
- let v_key = alloc_var VGenerated "tmp" ekey.etype ekey.epos in
|
|
|
- let evar_key = mk (TVar(v_key,Some ekey)) ctx.com.basic.tvoid ekey.epos in
|
|
|
- let ekey = mk (TLocal v_key) ekey.etype ekey.epos in
|
|
|
- (* get *)
|
|
|
- let e_get = mk_array_get_call ctx (AbstractCast.find_array_access_raise ctx a tl ekey None p) c ebase p in
|
|
|
- let v_get = alloc_var VGenerated "tmp" e_get.etype e_get.epos in
|
|
|
- let ev_get = mk (TLocal v_get) v_get.v_type p in
|
|
|
- let evar_get = mk (TVar(v_get,Some e_get)) ctx.com.basic.tvoid p in
|
|
|
- (* op *)
|
|
|
- let e_one = mk (TConst (TInt (Int32.of_int 1))) ctx.com.basic.tint p in
|
|
|
- let e_op = mk (TBinop((if op = Increment then OpAdd else OpSub),ev_get,e_one)) ev_get.etype p in
|
|
|
- (* set *)
|
|
|
- let e_set = mk_array_set_call ctx (AbstractCast.find_array_access_raise ctx a tl ekey (Some e_op) p) c ebase p in
|
|
|
- let el = evar_key :: evar_get :: e_set :: (if flag = Postfix then [ev_get] else []) in
|
|
|
- mk (TBlock el) e_set.etype p
|
|
|
- with Not_found ->
|
|
|
- let e = mk_array_get_call ctx (AbstractCast.find_array_access ctx a tl ekey None p) c ebase p in
|
|
|
- loop (AKExpr e)
|
|
|
- end
|
|
|
- | AKUsingAccessor sea ->
|
|
|
- let fa_set = match FieldAccess.resolve_accessor sea.se_access (MSet None) with
|
|
|
- | AccessorFound fa -> fa
|
|
|
- | _ -> error "Could not resolve accessor" p
|
|
|
- in
|
|
|
- handle_accessor sea.se_this fa_set
|
|
|
- | AKUsingField sea when (op = Decrement || op = Increment) && has_class_field_flag sea.se_access.fa_field CfImpl ->
|
|
|
- handle_accessor sea.se_this sea.se_access
|
|
|
- | AKUsingField _ ->
|
|
|
- error "This kind of operation is not supported" p
|
|
|
- | AKResolve(sea,name) ->
|
|
|
- if not set then
|
|
|
- access ((new call_dispatcher ctx (MCall []) WithType.value p)#resolve_call sea name)
|
|
|
- else
|
|
|
- error "Invalid operation" p
|
|
|
- | AKAccessor fa when not set ->
|
|
|
- access ((new call_dispatcher ctx mode WithType.value p)#field_call fa [] [])
|
|
|
- | AKAccessor fa ->
|
|
|
- let e = fa.fa_on in
|
|
|
- let ef = FieldAccess.get_field_expr fa FCall in
|
|
|
- let t = ef.etype in
|
|
|
- let cf = fa.fa_field in
|
|
|
- let l = save_locals ctx in
|
|
|
- let v = gen_local ctx e.etype p in
|
|
|
- let ev = mk (TLocal v) e.etype p in
|
|
|
- let op = (match op with Increment -> OpAdd | Decrement -> OpSub | _ -> die "" __LOC__) in
|
|
|
- let one = (EConst (Int "1"),p) in
|
|
|
- let eget = (EField ((EConst (Ident v.v_name),p),cf.cf_name),p) in
|
|
|
- match flag with
|
|
|
- | Prefix ->
|
|
|
- let get = type_binop ctx op eget one false WithType.value p in
|
|
|
- unify ctx get.etype t p;
|
|
|
- l();
|
|
|
- mk (TBlock [
|
|
|
- mk (TVar (v,Some e)) ctx.t.tvoid p;
|
|
|
- make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [get] t p
|
|
|
- ]) t p
|
|
|
- | Postfix ->
|
|
|
- let v2 = gen_local ctx t p in
|
|
|
- let ev2 = mk (TLocal v2) t p in
|
|
|
- let get = type_expr ctx eget WithType.value in
|
|
|
- let plusone = type_binop ctx op (EConst (Ident v2.v_name),p) one false WithType.value p in
|
|
|
- unify ctx get.etype t p;
|
|
|
- l();
|
|
|
- mk (TBlock [
|
|
|
- mk (TVar (v,Some e)) ctx.t.tvoid p;
|
|
|
- mk (TVar (v2,Some get)) ctx.t.tvoid p;
|
|
|
- make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [plusone.etype] t) p) [plusone] t p;
|
|
|
- ev2
|
|
|
- ]) t p
|
|
|
- in
|
|
|
- loop acc
|
|
|
-
|
|
|
and type_ident ctx i p mode with_type =
|
|
|
try
|
|
|
type_ident_raise ctx i p mode with_type
|
|
@@ -2883,4 +1960,5 @@ unify_min_ref := unify_min;
|
|
|
unify_min_for_type_source_ref := unify_min_for_type_source;
|
|
|
make_call_ref := make_call;
|
|
|
type_call_target_ref := type_call_target;
|
|
|
+type_access_ref := type_access;
|
|
|
type_block_ref := type_block
|