|
@@ -609,6 +609,8 @@ let concat e1 e2 =
|
|
|
) in
|
|
|
mk e e2.etype (punion e1.epos e2.epos)
|
|
|
|
|
|
+let is_closed a = !(a.a_status) <> Opened
|
|
|
+
|
|
|
(* ======= Field utility ======= *)
|
|
|
|
|
|
let field_name f =
|
|
@@ -731,331 +733,623 @@ let rec get_constructor build_type c =
|
|
|
let t, c = get_constructor build_type csup in
|
|
|
apply_params csup.cl_types cparams t, c
|
|
|
|
|
|
-(* ======= Unification ======= *)
|
|
|
-
|
|
|
-let rec link e a b =
|
|
|
- (* tell if setting a == b will create a type-loop *)
|
|
|
- let rec loop t =
|
|
|
- if t == a then
|
|
|
- true
|
|
|
- else match t with
|
|
|
- | TMono t -> (match !t with None -> false | Some t -> loop t)
|
|
|
- | TEnum (_,tl) -> List.exists loop tl
|
|
|
- | TInst (_,tl) | TType (_,tl) | TAbstract (_,tl) -> List.exists loop tl
|
|
|
- | TFun (tl,t) -> List.exists (fun (_,_,t) -> loop t) tl || loop t
|
|
|
- | TDynamic t2 ->
|
|
|
- if t == t2 then
|
|
|
- false
|
|
|
- else
|
|
|
- loop t2
|
|
|
- | TLazy f ->
|
|
|
- loop (!f())
|
|
|
- | TAnon a ->
|
|
|
- try
|
|
|
- PMap.iter (fun _ f -> if loop f.cf_type then raise Exit) a.a_fields;
|
|
|
- false
|
|
|
- with
|
|
|
- Exit -> true
|
|
|
- in
|
|
|
- (* tell is already a ~= b *)
|
|
|
- if loop b then
|
|
|
- (follow b) == a
|
|
|
- else if b == t_dynamic then
|
|
|
- true
|
|
|
- else begin
|
|
|
- e := Some b;
|
|
|
- true
|
|
|
- end
|
|
|
-
|
|
|
-let rec fast_eq a b =
|
|
|
- if a == b then
|
|
|
- true
|
|
|
- else match a , b with
|
|
|
- | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
|
|
|
- List.for_all2 (fun (_,_,t1) (_,_,t2) -> fast_eq t1 t2) l1 l2 && fast_eq r1 r2
|
|
|
- | TType (t1,l1), TType (t2,l2) ->
|
|
|
- t1 == t2 && List.for_all2 fast_eq l1 l2
|
|
|
- | TEnum (e1,l1), TEnum (e2,l2) ->
|
|
|
- e1 == e2 && List.for_all2 fast_eq l1 l2
|
|
|
- | TInst (c1,l1), TInst (c2,l2) ->
|
|
|
- c1 == c2 && List.for_all2 fast_eq l1 l2
|
|
|
- | TAbstract (a1,l1), TAbstract (a2,l2) ->
|
|
|
- a1 == a2 && List.for_all2 fast_eq l1 l2
|
|
|
- | _ , _ ->
|
|
|
- false
|
|
|
-
|
|
|
-(* perform unification with subtyping.
|
|
|
- the first type is always the most down in the class hierarchy
|
|
|
- it's also the one that is pointed by the position.
|
|
|
- It's actually a typecheck of A :> B where some mutations can happen *)
|
|
|
-
|
|
|
-type unify_error =
|
|
|
- | Cannot_unify of t * t
|
|
|
- | Invalid_field_type of string
|
|
|
- | Has_no_field of t * string
|
|
|
- | Has_no_runtime_field of t * string
|
|
|
- | Has_extra_field of t * string
|
|
|
- | Invalid_kind of string * field_kind * field_kind
|
|
|
- | Invalid_visibility of string
|
|
|
- | Not_matching_optional of string
|
|
|
- | Cant_force_optional
|
|
|
- | Invariant_parameter of t * t
|
|
|
- | Constraint_failure of string
|
|
|
- | Missing_overload of tclass_field * t
|
|
|
- | Unify_custom of string
|
|
|
+(* ======= Printing ======= *)
|
|
|
|
|
|
-exception Unify_error of unify_error list
|
|
|
+let print_context() = ref []
|
|
|
|
|
|
-let cannot_unify a b = Cannot_unify (a,b)
|
|
|
-let invalid_field n = Invalid_field_type n
|
|
|
-let invalid_kind n a b = Invalid_kind (n,a,b)
|
|
|
-let invalid_visibility n = Invalid_visibility n
|
|
|
-let has_no_field t n = Has_no_field (t,n)
|
|
|
-let has_extra_field t n = Has_extra_field (t,n)
|
|
|
-let error l = raise (Unify_error l)
|
|
|
-let has_meta m ml = List.exists (fun (m2,_,_) -> m = m2) ml
|
|
|
-let get_meta m ml = List.find (fun (m2,_,_) -> m = m2) ml
|
|
|
-let no_meta = []
|
|
|
+let rec s_type ctx t =
|
|
|
+ match t with
|
|
|
+ | TMono r ->
|
|
|
+ (match !r with
|
|
|
+ | None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
|
|
|
+ | Some t -> s_type ctx t)
|
|
|
+ | TEnum (e,tl) ->
|
|
|
+ Ast.s_type_path e.e_path ^ s_type_params ctx tl
|
|
|
+ | TInst (c,tl) ->
|
|
|
+ (match c.cl_kind with
|
|
|
+ | KExpr e -> Ast.s_expr e
|
|
|
+ | _ -> Ast.s_type_path c.cl_path ^ s_type_params ctx tl)
|
|
|
+ | TType (t,tl) ->
|
|
|
+ Ast.s_type_path t.t_path ^ s_type_params ctx tl
|
|
|
+ | TAbstract (a,tl) ->
|
|
|
+ Ast.s_type_path a.a_path ^ s_type_params ctx tl
|
|
|
+ | TFun ([],t) ->
|
|
|
+ "Void -> " ^ s_fun ctx t false
|
|
|
+ | TFun (l,t) ->
|
|
|
+ String.concat " -> " (List.map (fun (s,b,t) ->
|
|
|
+ (if b then "?" else "") ^ (if s = "" then "" else s ^ " : ") ^ s_fun ctx t true
|
|
|
+ ) l) ^ " -> " ^ s_fun ctx t false
|
|
|
+ | TAnon a ->
|
|
|
+ let fl = PMap.fold (fun f acc -> ((if Meta.has Meta.Optional f.cf_meta then " ?" else " ") ^ f.cf_name ^ " : " ^ s_type ctx f.cf_type) :: acc) a.a_fields [] in
|
|
|
+ "{" ^ (if not (is_closed a) then "+" else "") ^ String.concat "," fl ^ " }"
|
|
|
+ | TDynamic t2 ->
|
|
|
+ "Dynamic" ^ s_type_params ctx (if t == t2 then [] else [t2])
|
|
|
+ | TLazy f ->
|
|
|
+ s_type ctx (!f())
|
|
|
|
|
|
-(*
|
|
|
- we can restrict access as soon as both are runtime-compatible
|
|
|
-*)
|
|
|
-let unify_access a1 a2 =
|
|
|
- a1 = a2 || match a1, a2 with
|
|
|
- | _, AccNo | _, AccNever -> true
|
|
|
- | AccInline, AccNormal -> true
|
|
|
- | _ -> false
|
|
|
+and s_fun ctx t void =
|
|
|
+ match t with
|
|
|
+ | TFun _ ->
|
|
|
+ "(" ^ s_type ctx t ^ ")"
|
|
|
+ | TAbstract ({ a_path = ([],"Void") },[]) when void ->
|
|
|
+ "(" ^ s_type ctx t ^ ")"
|
|
|
+ | TMono r ->
|
|
|
+ (match !r with
|
|
|
+ | None -> s_type ctx t
|
|
|
+ | Some t -> s_fun ctx t void)
|
|
|
+ | TLazy f ->
|
|
|
+ s_fun ctx (!f()) void
|
|
|
+ | _ ->
|
|
|
+ s_type ctx t
|
|
|
|
|
|
-let direct_access = function
|
|
|
- | AccNo | AccNever | AccNormal | AccInline | AccRequire _ -> true
|
|
|
- | AccResolve | AccCall -> false
|
|
|
+and s_type_params ctx = function
|
|
|
+ | [] -> ""
|
|
|
+ | l -> "<" ^ String.concat ", " (List.map (s_type ctx) l) ^ ">"
|
|
|
|
|
|
-let unify_kind k1 k2 =
|
|
|
- k1 = k2 || match k1, k2 with
|
|
|
- | Var v1, Var v2 -> unify_access v1.v_read v2.v_read && unify_access v1.v_write v2.v_write
|
|
|
- | Var v, Method m ->
|
|
|
- (match v.v_read, v.v_write, m with
|
|
|
- | AccNormal, _, MethNormal -> true
|
|
|
- | AccNormal, AccNormal, MethDynamic -> true
|
|
|
- | _ -> false)
|
|
|
- | Method m, Var v ->
|
|
|
- (match m with
|
|
|
- | MethDynamic -> direct_access v.v_read && direct_access v.v_write
|
|
|
- | MethMacro -> false
|
|
|
- | MethNormal | MethInline ->
|
|
|
- match v.v_write with
|
|
|
- | AccNo | AccNever -> true
|
|
|
- | _ -> false)
|
|
|
- | Method m1, Method m2 ->
|
|
|
- match m1,m2 with
|
|
|
- | MethInline, MethNormal
|
|
|
- | MethDynamic, MethNormal -> true
|
|
|
- | _ -> false
|
|
|
+let s_access is_read = function
|
|
|
+ | AccNormal -> "default"
|
|
|
+ | AccNo -> "null"
|
|
|
+ | AccNever -> "never"
|
|
|
+ | AccResolve -> "resolve"
|
|
|
+ | AccCall -> if is_read then "get" else "set"
|
|
|
+ | AccInline -> "inline"
|
|
|
+ | AccRequire (n,_) -> "require " ^ n
|
|
|
|
|
|
-let eq_stack = ref []
|
|
|
+let s_kind = function
|
|
|
+ | Var { v_read = AccNormal; v_write = AccNormal } -> "var"
|
|
|
+ | Var v -> "(" ^ s_access true v.v_read ^ "," ^ s_access false v.v_write ^ ")"
|
|
|
+ | Method m ->
|
|
|
+ match m with
|
|
|
+ | MethNormal -> "method"
|
|
|
+ | MethDynamic -> "dynamic method"
|
|
|
+ | MethInline -> "inline method"
|
|
|
+ | MethMacro -> "macro method"
|
|
|
|
|
|
-type eq_kind =
|
|
|
- | EqStrict
|
|
|
- | EqCoreType
|
|
|
- | EqRightDynamic
|
|
|
- | EqBothDynamic
|
|
|
+let s_expr_kind e =
|
|
|
+ match e.eexpr with
|
|
|
+ | TConst _ -> "Const"
|
|
|
+ | TLocal _ -> "Local"
|
|
|
+ | TArray (_,_) -> "Array"
|
|
|
+ | TBinop (_,_,_) -> "Binop"
|
|
|
+ | TEnumParameter (_,_,_) -> "EnumParameter"
|
|
|
+ | TField (_,_) -> "Field"
|
|
|
+ | TTypeExpr _ -> "TypeExpr"
|
|
|
+ | TParenthesis _ -> "Parenthesis"
|
|
|
+ | TObjectDecl _ -> "ObjectDecl"
|
|
|
+ | TArrayDecl _ -> "ArrayDecl"
|
|
|
+ | TCall (_,_) -> "Call"
|
|
|
+ | TNew (_,_,_) -> "New"
|
|
|
+ | TUnop (_,_,_) -> "Unop"
|
|
|
+ | TFunction _ -> "Function"
|
|
|
+ | TVar _ -> "Vars"
|
|
|
+ | TBlock _ -> "Block"
|
|
|
+ | TFor (_,_,_) -> "For"
|
|
|
+ | TIf (_,_,_) -> "If"
|
|
|
+ | TWhile (_,_,_) -> "While"
|
|
|
+ | TSwitch (_,_,_) -> "Switch"
|
|
|
+ | TPatMatch _ -> "PatMatch"
|
|
|
+ | TTry (_,_) -> "Try"
|
|
|
+ | TReturn _ -> "Return"
|
|
|
+ | TBreak -> "Break"
|
|
|
+ | TContinue -> "Continue"
|
|
|
+ | TThrow _ -> "Throw"
|
|
|
+ | TCast _ -> "Cast"
|
|
|
+ | TMeta _ -> "Meta"
|
|
|
|
|
|
-let is_closed a = !(a.a_status) <> Opened
|
|
|
+let s_const = function
|
|
|
+ | TInt i -> Int32.to_string i
|
|
|
+ | TFloat s -> s ^ "f"
|
|
|
+ | TString s -> Printf.sprintf "\"%s\"" (Ast.s_escape s)
|
|
|
+ | TBool b -> if b then "true" else "false"
|
|
|
+ | TNull -> "null"
|
|
|
+ | TThis -> "this"
|
|
|
+ | TSuper -> "super"
|
|
|
|
|
|
-let rec type_eq param a b =
|
|
|
- if a == b then
|
|
|
- ()
|
|
|
- else match a , b with
|
|
|
- | TLazy f , _ -> type_eq param (!f()) b
|
|
|
- | _ , TLazy f -> type_eq param a (!f())
|
|
|
- | TMono t , _ ->
|
|
|
- (match !t with
|
|
|
- | None -> if param = EqCoreType || not (link t a b) then error [cannot_unify a b]
|
|
|
- | Some t -> type_eq param t b)
|
|
|
- | _ , TMono t ->
|
|
|
- (match !t with
|
|
|
- | None -> if param = EqCoreType || not (link t b a) then error [cannot_unify a b]
|
|
|
- | Some t -> type_eq param a t)
|
|
|
- | TType (t1,tl1), TType (t2,tl2) when (t1 == t2 || (param = EqCoreType && t1.t_path = t2.t_path)) && List.length tl1 = List.length tl2 ->
|
|
|
- List.iter2 (type_eq param) tl1 tl2
|
|
|
- | TType (t,tl) , _ when param <> EqCoreType ->
|
|
|
- type_eq param (apply_params t.t_types tl t.t_type) b
|
|
|
- | _ , TType (t,tl) when param <> EqCoreType ->
|
|
|
- if List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!eq_stack) then
|
|
|
- ()
|
|
|
- else begin
|
|
|
- eq_stack := (a,b) :: !eq_stack;
|
|
|
- try
|
|
|
- type_eq param a (apply_params t.t_types tl t.t_type);
|
|
|
- eq_stack := List.tl !eq_stack;
|
|
|
- with
|
|
|
- Unify_error l ->
|
|
|
- eq_stack := List.tl !eq_stack;
|
|
|
- error (cannot_unify a b :: l)
|
|
|
- end
|
|
|
- | TEnum (e1,tl1) , TEnum (e2,tl2) ->
|
|
|
- if e1 != e2 && not (param = EqCoreType && e1.e_path = e2.e_path) then error [cannot_unify a b];
|
|
|
- List.iter2 (type_eq param) tl1 tl2
|
|
|
- | TInst (c1,tl1) , TInst (c2,tl2) ->
|
|
|
- if c1 != c2 && not (param = EqCoreType && c1.cl_path = c2.cl_path) && (match c1.cl_kind, c2.cl_kind with KExpr _, KExpr _ -> false | _ -> true) then error [cannot_unify a b];
|
|
|
- List.iter2 (type_eq param) tl1 tl2
|
|
|
- | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
|
|
|
- (try
|
|
|
- type_eq param r1 r2;
|
|
|
- List.iter2 (fun (n,o1,t1) (_,o2,t2) ->
|
|
|
- if o1 <> o2 then error [Not_matching_optional n];
|
|
|
- type_eq param t1 t2
|
|
|
- ) l1 l2
|
|
|
- with
|
|
|
- Unify_error l -> error (cannot_unify a b :: l))
|
|
|
- | TDynamic a , TDynamic b ->
|
|
|
- type_eq param a b
|
|
|
- | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
|
|
|
- if a1 != a2 && not (param = EqCoreType && a1.a_path = a2.a_path) then error [cannot_unify a b];
|
|
|
- List.iter2 (type_eq param) tl1 tl2
|
|
|
- | TAnon a1, TAnon a2 ->
|
|
|
- (try
|
|
|
- PMap.iter (fun n f1 ->
|
|
|
- try
|
|
|
- let f2 = PMap.find n a2.a_fields in
|
|
|
- if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then error [invalid_kind n f1.cf_kind f2.cf_kind];
|
|
|
- try
|
|
|
- type_eq param f1.cf_type f2.cf_type
|
|
|
- with
|
|
|
- Unify_error l -> error (invalid_field n :: l)
|
|
|
- with
|
|
|
- Not_found ->
|
|
|
- if is_closed a2 then error [has_no_field b n];
|
|
|
- if not (link (ref None) b f1.cf_type) then error [cannot_unify a b];
|
|
|
- a2.a_fields <- PMap.add n f1 a2.a_fields
|
|
|
- ) a1.a_fields;
|
|
|
- PMap.iter (fun n f2 ->
|
|
|
- if not (PMap.mem n a1.a_fields) then begin
|
|
|
- if is_closed a1 then error [has_no_field a n];
|
|
|
- if not (link (ref None) a f2.cf_type) then error [cannot_unify a b];
|
|
|
- a1.a_fields <- PMap.add n f2 a1.a_fields
|
|
|
- end;
|
|
|
- ) a2.a_fields;
|
|
|
- with
|
|
|
- Unify_error l -> error (cannot_unify a b :: l))
|
|
|
- | _ , _ ->
|
|
|
- if b == t_dynamic && (param = EqRightDynamic || param = EqBothDynamic) then
|
|
|
- ()
|
|
|
- else if a == t_dynamic && param = EqBothDynamic then
|
|
|
- ()
|
|
|
- else
|
|
|
- error [cannot_unify a b]
|
|
|
+let rec s_expr s_type e =
|
|
|
+ let sprintf = Printf.sprintf in
|
|
|
+ let slist f l = String.concat "," (List.map f l) in
|
|
|
+ let loop = s_expr s_type in
|
|
|
+ let s_var v = v.v_name ^ ":" ^ string_of_int v.v_id ^ if v.v_capture then "[c]" else "" in
|
|
|
+ let str = (match e.eexpr with
|
|
|
+ | TConst c ->
|
|
|
+ "Const " ^ s_const c
|
|
|
+ | TLocal v ->
|
|
|
+ "Local " ^ s_var v
|
|
|
+ | TArray (e1,e2) ->
|
|
|
+ sprintf "%s[%s]" (loop e1) (loop e2)
|
|
|
+ | TBinop (op,e1,e2) ->
|
|
|
+ sprintf "(%s %s %s)" (loop e1) (s_binop op) (loop e2)
|
|
|
+ | TEnumParameter (e1,_,i) ->
|
|
|
+ sprintf "%s[%i]" (loop e1) i
|
|
|
+ | TField (e,f) ->
|
|
|
+ let fstr = (match f with
|
|
|
+ | FStatic (c,f) -> "static(" ^ s_type_path c.cl_path ^ "." ^ f.cf_name ^ ")"
|
|
|
+ | FInstance (c,f) -> "inst(" ^ s_type_path c.cl_path ^ "." ^ f.cf_name ^ " : " ^ s_type f.cf_type ^ ")"
|
|
|
+ | FClosure (c,f) -> "closure(" ^ (match c with None -> f.cf_name | Some c -> s_type_path c.cl_path ^ "." ^ f.cf_name) ^ ")"
|
|
|
+ | FAnon f -> "anon(" ^ f.cf_name ^ ")"
|
|
|
+ | FEnum (en,f) -> "enum(" ^ s_type_path en.e_path ^ "." ^ f.ef_name ^ ")"
|
|
|
+ | FDynamic f -> "dynamic(" ^ f ^ ")"
|
|
|
+ ) in
|
|
|
+ sprintf "%s.%s" (loop e) fstr
|
|
|
+ | TTypeExpr m ->
|
|
|
+ sprintf "TypeExpr %s" (s_type_path (t_path m))
|
|
|
+ | TParenthesis e ->
|
|
|
+ sprintf "Parenthesis %s" (loop e)
|
|
|
+ | TObjectDecl fl ->
|
|
|
+ sprintf "ObjectDecl {%s)" (slist (fun (f,e) -> sprintf "%s : %s" f (loop e)) fl)
|
|
|
+ | TArrayDecl el ->
|
|
|
+ sprintf "ArrayDecl [%s]" (slist loop el)
|
|
|
+ | TCall (e,el) ->
|
|
|
+ sprintf "Call %s(%s)" (loop e) (slist loop el)
|
|
|
+ | TNew (c,pl,el) ->
|
|
|
+ sprintf "New %s%s(%s)" (s_type_path c.cl_path) (match pl with [] -> "" | l -> sprintf "<%s>" (slist s_type l)) (slist loop el)
|
|
|
+ | TUnop (op,f,e) ->
|
|
|
+ (match f with
|
|
|
+ | Prefix -> sprintf "(%s %s)" (s_unop op) (loop e)
|
|
|
+ | Postfix -> sprintf "(%s %s)" (loop e) (s_unop op))
|
|
|
+ | TFunction f ->
|
|
|
+ let args = slist (fun (v,o) -> sprintf "%s : %s%s" (s_var v) (s_type v.v_type) (match o with None -> "" | Some c -> " = " ^ s_const c)) f.tf_args in
|
|
|
+ sprintf "Function(%s) : %s = %s" args (s_type f.tf_type) (loop f.tf_expr)
|
|
|
+ | TVar (v,eo) ->
|
|
|
+ sprintf "Vars %s" (sprintf "%s : %s%s" (s_var v) (s_type v.v_type) (match eo with None -> "" | Some e -> " = " ^ loop e))
|
|
|
+ | TBlock el ->
|
|
|
+ sprintf "Block {\n%s}" (String.concat "" (List.map (fun e -> sprintf "%s;\n" (loop e)) el))
|
|
|
+ | TFor (v,econd,e) ->
|
|
|
+ sprintf "For (%s : %s in %s,%s)" (s_var v) (s_type v.v_type) (loop econd) (loop e)
|
|
|
+ | TIf (e,e1,e2) ->
|
|
|
+ sprintf "If (%s,%s%s)" (loop e) (loop e1) (match e2 with None -> "" | Some e -> "," ^ loop e)
|
|
|
+ | TWhile (econd,e,flag) ->
|
|
|
+ (match flag with
|
|
|
+ | NormalWhile -> sprintf "While (%s,%s)" (loop econd) (loop e)
|
|
|
+ | DoWhile -> sprintf "DoWhile (%s,%s)" (loop e) (loop econd))
|
|
|
+ | TSwitch (e,cases,def) ->
|
|
|
+ sprintf "Switch (%s,(%s)%s)" (loop e) (slist (fun (cl,e) -> sprintf "case %s: %s" (slist loop cl) (loop e)) cases) (match def with None -> "" | Some e -> "," ^ loop e)
|
|
|
+ | TPatMatch dt -> s_dt "" (dt.dt_dt_lookup.(dt.dt_first))
|
|
|
+ | TTry (e,cl) ->
|
|
|
+ sprintf "Try %s(%s) " (loop e) (slist (fun (v,e) -> sprintf "catch( %s : %s ) %s" (s_var v) (s_type v.v_type) (loop e)) cl)
|
|
|
+ | TReturn None ->
|
|
|
+ "Return"
|
|
|
+ | TReturn (Some e) ->
|
|
|
+ sprintf "Return %s" (loop e)
|
|
|
+ | TBreak ->
|
|
|
+ "Break"
|
|
|
+ | TContinue ->
|
|
|
+ "Continue"
|
|
|
+ | TThrow e ->
|
|
|
+ "Throw " ^ (loop e)
|
|
|
+ | TCast (e,t) ->
|
|
|
+ sprintf "Cast %s%s" (match t with None -> "" | Some t -> s_type_path (t_path t) ^ ": ") (loop e)
|
|
|
+ | TMeta ((n,el,_),e) ->
|
|
|
+ sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
|
|
|
+ ) in
|
|
|
+ sprintf "(%s : %s)" str (s_type e.etype)
|
|
|
|
|
|
-let type_iseq a b =
|
|
|
- try
|
|
|
- type_eq EqStrict a b;
|
|
|
- true
|
|
|
- with
|
|
|
- Unify_error _ -> false
|
|
|
+and s_dt tabs tree =
|
|
|
+ let s_type = s_type (print_context()) in
|
|
|
+ tabs ^ match tree with
|
|
|
+ | DTSwitch (st,cl,dto) ->
|
|
|
+ "switch(" ^ (s_expr s_type st) ^ ") { \n" ^ tabs
|
|
|
+ ^ (String.concat ("\n" ^ tabs) (List.map (fun (c,dt) ->
|
|
|
+ "case " ^ (s_expr s_type c) ^ ":\n" ^ (s_dt (tabs ^ "\t") dt)
|
|
|
+ ) cl))
|
|
|
+ ^ (match dto with None -> "" | Some dt -> tabs ^ "default: " ^ (s_dt (tabs ^ "\t") dt))
|
|
|
+ ^ "\n" ^ (if String.length tabs = 0 then "" else (String.sub tabs 0 (String.length tabs - 1))) ^ "}"
|
|
|
+ | DTBind (bl, dt) -> "bind " ^ (String.concat "," (List.map (fun ((v,_),st) -> v.v_name ^ "(" ^ (string_of_int v.v_id) ^ ") =" ^ (s_expr s_type st)) bl)) ^ "\n" ^ (s_dt tabs dt)
|
|
|
+ | DTGoto i ->
|
|
|
+ "goto " ^ (string_of_int i)
|
|
|
+ | DTExpr e -> s_expr s_type e
|
|
|
+ | DTGuard (e,dt1,dt2) -> "if(" ^ (s_expr s_type e) ^ ") " ^ (s_dt tabs dt1) ^ (match dt2 with None -> "" | Some dt -> " else " ^ (s_dt tabs dt))
|
|
|
|
|
|
-let unify_stack = ref []
|
|
|
-let abstract_cast_stack = ref []
|
|
|
+let rec s_expr_pretty tabs s_type e =
|
|
|
+ let sprintf = Printf.sprintf in
|
|
|
+ let loop = s_expr_pretty tabs s_type in
|
|
|
+ let slist f l = String.concat "," (List.map f l) in
|
|
|
+ match e.eexpr with
|
|
|
+ | TConst c -> s_const c
|
|
|
+ | TLocal v -> v.v_name
|
|
|
+ | TArray (e1,e2) -> sprintf "%s[%s]" (loop e1) (loop e2)
|
|
|
+ | TBinop (op,e1,e2) -> sprintf "%s %s %s" (loop e1) (s_binop op) (loop e2)
|
|
|
+ | TEnumParameter (e1,_,i) -> sprintf "%s[%i]" (loop e1) i
|
|
|
+ | TField (e1,s) -> sprintf "%s.%s" (loop e1) (field_name s)
|
|
|
+ | TTypeExpr mt -> (s_type_path (t_path mt))
|
|
|
+ | TParenthesis e1 -> sprintf "(%s)" (loop e1)
|
|
|
+ | TObjectDecl fl -> sprintf "{%s}" (slist (fun (f,e) -> sprintf "%s : %s" f (loop e)) fl)
|
|
|
+ | TArrayDecl el -> sprintf "[%s]" (slist loop el)
|
|
|
+ | TCall (e1,el) -> sprintf "%s(%s)" (loop e1) (slist loop el)
|
|
|
+ | TNew (c,pl,el) ->
|
|
|
+ sprintf "new %s(%s)" (s_type_path c.cl_path) (slist loop el)
|
|
|
+ | TUnop (op,f,e) ->
|
|
|
+ (match f with
|
|
|
+ | Prefix -> sprintf "%s %s" (s_unop op) (loop e)
|
|
|
+ | Postfix -> sprintf "%s %s" (loop e) (s_unop op))
|
|
|
+ | TFunction f ->
|
|
|
+ let args = slist (fun (v,o) -> sprintf "%s:%s%s" v.v_name (s_type v.v_type) (match o with None -> "" | Some c -> " = " ^ s_const c)) f.tf_args in
|
|
|
+ sprintf "function(%s) = %s" args (loop f.tf_expr)
|
|
|
+ | TVar (v,eo) ->
|
|
|
+ sprintf "var %s" (sprintf "%s%s" v.v_name (match eo with None -> "" | Some e -> " = " ^ loop e))
|
|
|
+ | TBlock el ->
|
|
|
+ let ntabs = tabs ^ "\t" in
|
|
|
+ let s = sprintf "{\n%s" (String.concat "" (List.map (fun e -> sprintf "%s%s;\n" ntabs (s_expr_pretty ntabs s_type e)) el)) in
|
|
|
+ s ^ tabs ^ "}"
|
|
|
+ | TFor (v,econd,e) ->
|
|
|
+ sprintf "for (%s in %s) %s" v.v_name (loop econd) (loop e)
|
|
|
+ | TIf (e,e1,e2) ->
|
|
|
+ sprintf "if (%s)%s%s" (loop e) (loop e1) (match e2 with None -> "" | Some e -> " else " ^ loop e)
|
|
|
+ | TWhile (econd,e,flag) ->
|
|
|
+ (match flag with
|
|
|
+ | NormalWhile -> sprintf "while (%s) %s" (loop econd) (loop e)
|
|
|
+ | DoWhile -> sprintf "do (%s) while(%s)" (loop e) (loop econd))
|
|
|
+ | TSwitch (e,cases,def) ->
|
|
|
+ let ntabs = tabs ^ "\t" in
|
|
|
+ let s = sprintf "switch (%s) {\n%s%s" (loop e) (slist (fun (cl,e) -> sprintf "%scase %s: %s\n" ntabs (slist loop cl) (s_expr_pretty ntabs s_type e)) cases) (match def with None -> "" | Some e -> ntabs ^ "default: " ^ (s_expr_pretty ntabs s_type e) ^ "\n") in
|
|
|
+ s ^ tabs ^ "}"
|
|
|
+ | TPatMatch dt -> s_dt tabs (dt.dt_dt_lookup.(dt.dt_first))
|
|
|
+ | TTry (e,cl) ->
|
|
|
+ sprintf "try %s%s" (loop e) (slist (fun (v,e) -> sprintf "catch( %s : %s ) %s" v.v_name (s_type v.v_type) (loop e)) cl)
|
|
|
+ | TReturn None ->
|
|
|
+ "return"
|
|
|
+ | TReturn (Some e) ->
|
|
|
+ sprintf "return %s" (loop e)
|
|
|
+ | TBreak ->
|
|
|
+ "break"
|
|
|
+ | TContinue ->
|
|
|
+ "continue"
|
|
|
+ | TThrow e ->
|
|
|
+ "throw " ^ (loop e)
|
|
|
+ | TCast (e,None) ->
|
|
|
+ sprintf "cast %s" (loop e)
|
|
|
+ | TCast (e,Some mt) ->
|
|
|
+ sprintf "cast (%s,%s)" (loop e) (s_type_path (t_path mt))
|
|
|
+ | TMeta ((n,el,_),e) ->
|
|
|
+ sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
|
|
|
|
|
|
-let rec unify a b =
|
|
|
- if a == b then
|
|
|
- ()
|
|
|
- else match a, b with
|
|
|
- | TLazy f , _ -> unify (!f()) b
|
|
|
- | _ , TLazy f -> unify a (!f())
|
|
|
- | TMono t , _ ->
|
|
|
- (match !t with
|
|
|
- | None -> if not (link t a b) then error [cannot_unify a b]
|
|
|
- | Some t -> unify t b)
|
|
|
- | _ , TMono t ->
|
|
|
- (match !t with
|
|
|
- | None -> if not (link t b a) then error [cannot_unify a b]
|
|
|
- | Some t -> unify a t)
|
|
|
- | TType (t,tl) , _ ->
|
|
|
- if not (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!unify_stack)) then begin
|
|
|
- try
|
|
|
- unify_stack := (a,b) :: !unify_stack;
|
|
|
- unify (apply_params t.t_types tl t.t_type) b;
|
|
|
- unify_stack := List.tl !unify_stack;
|
|
|
- with
|
|
|
- Unify_error l ->
|
|
|
- unify_stack := List.tl !unify_stack;
|
|
|
- error (cannot_unify a b :: l)
|
|
|
- end
|
|
|
- | _ , TType (t,tl) ->
|
|
|
- if not (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!unify_stack)) then begin
|
|
|
- try
|
|
|
- unify_stack := (a,b) :: !unify_stack;
|
|
|
- unify a (apply_params t.t_types tl t.t_type);
|
|
|
- unify_stack := List.tl !unify_stack;
|
|
|
- with
|
|
|
- Unify_error l ->
|
|
|
- unify_stack := List.tl !unify_stack;
|
|
|
- error (cannot_unify a b :: l)
|
|
|
- end
|
|
|
- | TEnum (ea,tl1) , TEnum (eb,tl2) ->
|
|
|
- if ea != eb then error [cannot_unify a b];
|
|
|
- unify_types a b tl1 tl2
|
|
|
- | TAbstract (a1,tl1) , TAbstract (a2,tl2) when a1 == a2 ->
|
|
|
- unify_types a b tl1 tl2
|
|
|
- | TAbstract ({a_path=[],"Void"},_) , _
|
|
|
- | _ , TAbstract ({a_path=[],"Void"},_) ->
|
|
|
- error [cannot_unify a b]
|
|
|
- | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
|
|
|
- let f1 = unify_to_field a1 tl1 b in
|
|
|
- let f2 = unify_from_field a2 tl2 a b in
|
|
|
- if not (List.exists (f1 ~allow_transitive_cast:false) a1.a_to) && not (List.exists (f2 ~allow_transitive_cast:false) a2.a_from)
|
|
|
- && not (List.exists f1 a1.a_to) && not (List.exists f2 a2.a_from) then error [cannot_unify a b]
|
|
|
- | TInst (c1,tl1) , TInst (c2,tl2) ->
|
|
|
- let rec loop c tl =
|
|
|
- if c == c2 then begin
|
|
|
- unify_types a b tl tl2;
|
|
|
- true
|
|
|
- end else (match c.cl_super with
|
|
|
- | None -> false
|
|
|
- | Some (cs,tls) ->
|
|
|
- loop cs (List.map (apply_params c.cl_types tl) tls)
|
|
|
- ) || List.exists (fun (cs,tls) ->
|
|
|
- loop cs (List.map (apply_params c.cl_types tl) tls)
|
|
|
- ) c.cl_implements
|
|
|
- || (match c.cl_kind with
|
|
|
- | KTypeParameter pl -> List.exists (fun t -> match follow t with TInst (cs,tls) -> loop cs (List.map (apply_params c.cl_types tl) tls) | _ -> false) pl
|
|
|
+let s_types ?(sep = ", ") tl =
|
|
|
+ let pctx = print_context() in
|
|
|
+ String.concat sep (List.map (s_type pctx) tl)
|
|
|
+
|
|
|
+let s_class_kind = function
|
|
|
+ | KNormal ->
|
|
|
+ "KNormal"
|
|
|
+ | KTypeParameter tl ->
|
|
|
+ Printf.sprintf "KTypeParameter [%s]" (s_types tl)
|
|
|
+ | KExtension(c,tl) ->
|
|
|
+ Printf.sprintf "KExtension %s<%s>" (s_type_path c.cl_path) (s_types tl)
|
|
|
+ | KExpr _ ->
|
|
|
+ "KExpr"
|
|
|
+ | KGeneric ->
|
|
|
+ "KGeneric"
|
|
|
+ | KGenericInstance(c,tl) ->
|
|
|
+ Printf.sprintf "KGenericInstance %s<%s>" (s_type_path c.cl_path) (s_types tl)
|
|
|
+ | KMacroType ->
|
|
|
+ "KMacroType"
|
|
|
+ | KGenericBuild _ ->
|
|
|
+ "KGenericBuild"
|
|
|
+ | KAbstractImpl a ->
|
|
|
+ Printf.sprintf "KAbstractImpl %s" (s_type_path a.a_path)
|
|
|
+
|
|
|
+(* ======= Unification ======= *)
|
|
|
+
|
|
|
+let rec link e a b =
|
|
|
+ (* tell if setting a == b will create a type-loop *)
|
|
|
+ let rec loop t =
|
|
|
+ if t == a then
|
|
|
+ true
|
|
|
+ else match t with
|
|
|
+ | TMono t -> (match !t with None -> false | Some t -> loop t)
|
|
|
+ | TEnum (_,tl) -> List.exists loop tl
|
|
|
+ | TInst (_,tl) | TType (_,tl) | TAbstract (_,tl) -> List.exists loop tl
|
|
|
+ | TFun (tl,t) -> List.exists (fun (_,_,t) -> loop t) tl || loop t
|
|
|
+ | TDynamic t2 ->
|
|
|
+ if t == t2 then
|
|
|
+ false
|
|
|
+ else
|
|
|
+ loop t2
|
|
|
+ | TLazy f ->
|
|
|
+ loop (!f())
|
|
|
+ | TAnon a ->
|
|
|
+ try
|
|
|
+ PMap.iter (fun _ f -> if loop f.cf_type then raise Exit) a.a_fields;
|
|
|
+ false
|
|
|
+ with
|
|
|
+ Exit -> true
|
|
|
+ in
|
|
|
+ (* tell is already a ~= b *)
|
|
|
+ if loop b then
|
|
|
+ (follow b) == a
|
|
|
+ else if b == t_dynamic then
|
|
|
+ true
|
|
|
+ else begin
|
|
|
+ e := Some b;
|
|
|
+ true
|
|
|
+ end
|
|
|
+
|
|
|
+let rec fast_eq a b =
|
|
|
+ if a == b then
|
|
|
+ true
|
|
|
+ else match a , b with
|
|
|
+ | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
|
|
|
+ List.for_all2 (fun (_,_,t1) (_,_,t2) -> fast_eq t1 t2) l1 l2 && fast_eq r1 r2
|
|
|
+ | TType (t1,l1), TType (t2,l2) ->
|
|
|
+ t1 == t2 && List.for_all2 fast_eq l1 l2
|
|
|
+ | TEnum (e1,l1), TEnum (e2,l2) ->
|
|
|
+ e1 == e2 && List.for_all2 fast_eq l1 l2
|
|
|
+ | TInst (c1,l1), TInst (c2,l2) ->
|
|
|
+ c1 == c2 && List.for_all2 fast_eq l1 l2
|
|
|
+ | TAbstract (a1,l1), TAbstract (a2,l2) ->
|
|
|
+ a1 == a2 && List.for_all2 fast_eq l1 l2
|
|
|
+ | _ , _ ->
|
|
|
+ false
|
|
|
+
|
|
|
+(* perform unification with subtyping.
|
|
|
+ the first type is always the most down in the class hierarchy
|
|
|
+ it's also the one that is pointed by the position.
|
|
|
+ It's actually a typecheck of A :> B where some mutations can happen *)
|
|
|
+
|
|
|
+type unify_error =
|
|
|
+ | Cannot_unify of t * t
|
|
|
+ | Invalid_field_type of string
|
|
|
+ | Has_no_field of t * string
|
|
|
+ | Has_no_runtime_field of t * string
|
|
|
+ | Has_extra_field of t * string
|
|
|
+ | Invalid_kind of string * field_kind * field_kind
|
|
|
+ | Invalid_visibility of string
|
|
|
+ | Not_matching_optional of string
|
|
|
+ | Cant_force_optional
|
|
|
+ | Invariant_parameter of t * t
|
|
|
+ | Constraint_failure of string
|
|
|
+ | Missing_overload of tclass_field * t
|
|
|
+ | Unify_custom of string
|
|
|
+
|
|
|
+exception Unify_error of unify_error list
|
|
|
+
|
|
|
+let cannot_unify a b = Cannot_unify (a,b)
|
|
|
+let invalid_field n = Invalid_field_type n
|
|
|
+let invalid_kind n a b = Invalid_kind (n,a,b)
|
|
|
+let invalid_visibility n = Invalid_visibility n
|
|
|
+let has_no_field t n = Has_no_field (t,n)
|
|
|
+let has_extra_field t n = Has_extra_field (t,n)
|
|
|
+let error l = raise (Unify_error l)
|
|
|
+let has_meta m ml = List.exists (fun (m2,_,_) -> m = m2) ml
|
|
|
+let get_meta m ml = List.find (fun (m2,_,_) -> m = m2) ml
|
|
|
+let no_meta = []
|
|
|
+
|
|
|
+(*
|
|
|
+ we can restrict access as soon as both are runtime-compatible
|
|
|
+*)
|
|
|
+let unify_access a1 a2 =
|
|
|
+ a1 = a2 || match a1, a2 with
|
|
|
+ | _, AccNo | _, AccNever -> true
|
|
|
+ | AccInline, AccNormal -> true
|
|
|
+ | _ -> false
|
|
|
+
|
|
|
+let direct_access = function
|
|
|
+ | AccNo | AccNever | AccNormal | AccInline | AccRequire _ -> true
|
|
|
+ | AccResolve | AccCall -> false
|
|
|
+
|
|
|
+let unify_kind k1 k2 =
|
|
|
+ k1 = k2 || match k1, k2 with
|
|
|
+ | Var v1, Var v2 -> unify_access v1.v_read v2.v_read && unify_access v1.v_write v2.v_write
|
|
|
+ | Var v, Method m ->
|
|
|
+ (match v.v_read, v.v_write, m with
|
|
|
+ | AccNormal, _, MethNormal -> true
|
|
|
+ | AccNormal, AccNormal, MethDynamic -> true
|
|
|
| _ -> false)
|
|
|
- in
|
|
|
- if not (loop c1 tl1) then error [cannot_unify a b]
|
|
|
+ | Method m, Var v ->
|
|
|
+ (match m with
|
|
|
+ | MethDynamic -> direct_access v.v_read && direct_access v.v_write
|
|
|
+ | MethMacro -> false
|
|
|
+ | MethNormal | MethInline ->
|
|
|
+ match v.v_write with
|
|
|
+ | AccNo | AccNever -> true
|
|
|
+ | _ -> false)
|
|
|
+ | Method m1, Method m2 ->
|
|
|
+ match m1,m2 with
|
|
|
+ | MethInline, MethNormal
|
|
|
+ | MethDynamic, MethNormal -> true
|
|
|
+ | _ -> false
|
|
|
+
|
|
|
+let eq_stack = ref []
|
|
|
+
|
|
|
+type eq_kind =
|
|
|
+ | EqStrict
|
|
|
+ | EqCoreType
|
|
|
+ | EqRightDynamic
|
|
|
+ | EqBothDynamic
|
|
|
+
|
|
|
+let rec type_eq param a b =
|
|
|
+ if a == b then
|
|
|
+ ()
|
|
|
+ else match a , b with
|
|
|
+ | TLazy f , _ -> type_eq param (!f()) b
|
|
|
+ | _ , TLazy f -> type_eq param a (!f())
|
|
|
+ | TMono t , _ ->
|
|
|
+ (match !t with
|
|
|
+ | None -> if param = EqCoreType || not (link t a b) then error [cannot_unify a b]
|
|
|
+ | Some t -> type_eq param t b)
|
|
|
+ | _ , TMono t ->
|
|
|
+ (match !t with
|
|
|
+ | None -> if param = EqCoreType || not (link t b a) then error [cannot_unify a b]
|
|
|
+ | Some t -> type_eq param a t)
|
|
|
+ | TType (t1,tl1), TType (t2,tl2) when (t1 == t2 || (param = EqCoreType && t1.t_path = t2.t_path)) && List.length tl1 = List.length tl2 ->
|
|
|
+ List.iter2 (type_eq param) tl1 tl2
|
|
|
+ | TType (t,tl) , _ when param <> EqCoreType ->
|
|
|
+ type_eq param (apply_params t.t_types tl t.t_type) b
|
|
|
+ | _ , TType (t,tl) when param <> EqCoreType ->
|
|
|
+ if List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!eq_stack) then
|
|
|
+ ()
|
|
|
+ else begin
|
|
|
+ eq_stack := (a,b) :: !eq_stack;
|
|
|
+ try
|
|
|
+ type_eq param a (apply_params t.t_types tl t.t_type);
|
|
|
+ eq_stack := List.tl !eq_stack;
|
|
|
+ with
|
|
|
+ Unify_error l ->
|
|
|
+ eq_stack := List.tl !eq_stack;
|
|
|
+ error (cannot_unify a b :: l)
|
|
|
+ end
|
|
|
+ | TEnum (e1,tl1) , TEnum (e2,tl2) ->
|
|
|
+ if e1 != e2 && not (param = EqCoreType && e1.e_path = e2.e_path) then error [cannot_unify a b];
|
|
|
+ List.iter2 (type_eq param) tl1 tl2
|
|
|
+ | TInst (c1,tl1) , TInst (c2,tl2) ->
|
|
|
+ if c1 != c2 && not (param = EqCoreType && c1.cl_path = c2.cl_path) && (match c1.cl_kind, c2.cl_kind with KExpr _, KExpr _ -> false | _ -> true) then error [cannot_unify a b];
|
|
|
+ List.iter2 (type_eq param) tl1 tl2
|
|
|
| TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
|
|
|
- let i = ref 0 in
|
|
|
(try
|
|
|
- (match r2 with
|
|
|
- | TAbstract ({a_path=[],"Void"},_) -> incr i
|
|
|
- | _ -> unify r1 r2; incr i);
|
|
|
- List.iter2 (fun (_,o1,t1) (_,o2,t2) ->
|
|
|
- if o1 && not o2 then error [Cant_force_optional];
|
|
|
- unify t1 t2;
|
|
|
- incr i
|
|
|
- ) l2 l1 (* contravariance *)
|
|
|
+ type_eq param r1 r2;
|
|
|
+ List.iter2 (fun (n,o1,t1) (_,o2,t2) ->
|
|
|
+ if o1 <> o2 then error [Not_matching_optional n];
|
|
|
+ type_eq param t1 t2
|
|
|
+ ) l1 l2
|
|
|
with
|
|
|
- Unify_error l ->
|
|
|
- let msg = if !i = 0 then "Cannot unify return types" else "Cannot unify argument " ^ (string_of_int !i) in
|
|
|
- error (cannot_unify a b :: Unify_custom msg :: l))
|
|
|
- | TInst (c,tl) , TAnon an ->
|
|
|
- if PMap.is_empty an.a_fields then (match c.cl_kind with
|
|
|
- | KTypeParameter pl ->
|
|
|
- (* one of the constraints must unify with { } *)
|
|
|
- if not (List.exists (fun t -> match t with TInst _ | TAnon _ -> true | _ -> false) pl) then error [cannot_unify a b]
|
|
|
- | _ -> ());
|
|
|
+ Unify_error l -> error (cannot_unify a b :: l))
|
|
|
+ | TDynamic a , TDynamic b ->
|
|
|
+ type_eq param a b
|
|
|
+ | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
|
|
|
+ if a1 != a2 && not (param = EqCoreType && a1.a_path = a2.a_path) then error [cannot_unify a b];
|
|
|
+ List.iter2 (type_eq param) tl1 tl2
|
|
|
+ | TAnon a1, TAnon a2 ->
|
|
|
(try
|
|
|
- PMap.iter (fun n f2 ->
|
|
|
- let _, ft, f1 = (try class_field c n with Not_found -> error [has_no_field a n]) in
|
|
|
- if not (unify_kind f1.cf_kind f2.cf_kind) then error [invalid_kind n f1.cf_kind f2.cf_kind];
|
|
|
- if f2.cf_public && not f1.cf_public then error [invalid_visibility n];
|
|
|
- (try
|
|
|
- unify_with_access (apply_params c.cl_types tl ft) f2
|
|
|
- with
|
|
|
- Unify_error l -> error (invalid_field n :: l));
|
|
|
- List.iter (fun f2o ->
|
|
|
- if not (List.exists (fun f1o -> type_iseq f1o.cf_type f2o.cf_type) (f1 :: f1.cf_overloads))
|
|
|
- then error [Missing_overload (f1, f2o.cf_type)]
|
|
|
- ) f2.cf_overloads;
|
|
|
+ PMap.iter (fun n f1 ->
|
|
|
+ try
|
|
|
+ let f2 = PMap.find n a2.a_fields in
|
|
|
+ if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then error [invalid_kind n f1.cf_kind f2.cf_kind];
|
|
|
+ try
|
|
|
+ type_eq param f1.cf_type f2.cf_type
|
|
|
+ with
|
|
|
+ Unify_error l -> error (invalid_field n :: l)
|
|
|
+ with
|
|
|
+ Not_found ->
|
|
|
+ if is_closed a2 then error [has_no_field b n];
|
|
|
+ if not (link (ref None) b f1.cf_type) then error [cannot_unify a b];
|
|
|
+ a2.a_fields <- PMap.add n f1 a2.a_fields
|
|
|
+ ) a1.a_fields;
|
|
|
+ PMap.iter (fun n f2 ->
|
|
|
+ if not (PMap.mem n a1.a_fields) then begin
|
|
|
+ if is_closed a1 then error [has_no_field a n];
|
|
|
+ if not (link (ref None) a f2.cf_type) then error [cannot_unify a b];
|
|
|
+ a1.a_fields <- PMap.add n f2 a1.a_fields
|
|
|
+ end;
|
|
|
+ ) a2.a_fields;
|
|
|
+ with
|
|
|
+ Unify_error l -> error (cannot_unify a b :: l))
|
|
|
+ | _ , _ ->
|
|
|
+ if b == t_dynamic && (param = EqRightDynamic || param = EqBothDynamic) then
|
|
|
+ ()
|
|
|
+ else if a == t_dynamic && param = EqBothDynamic then
|
|
|
+ ()
|
|
|
+ else
|
|
|
+ error [cannot_unify a b]
|
|
|
+
|
|
|
+let type_iseq a b =
|
|
|
+ try
|
|
|
+ type_eq EqStrict a b;
|
|
|
+ true
|
|
|
+ with
|
|
|
+ Unify_error _ -> false
|
|
|
+
|
|
|
+let unify_stack = ref []
|
|
|
+let abstract_cast_stack = ref []
|
|
|
+
|
|
|
+let rec unify a b =
|
|
|
+ if a == b then
|
|
|
+ ()
|
|
|
+ else match a, b with
|
|
|
+ | TLazy f , _ -> unify (!f()) b
|
|
|
+ | _ , TLazy f -> unify a (!f())
|
|
|
+ | TMono t , _ ->
|
|
|
+ (match !t with
|
|
|
+ | None -> if not (link t a b) then error [cannot_unify a b]
|
|
|
+ | Some t -> unify t b)
|
|
|
+ | _ , TMono t ->
|
|
|
+ (match !t with
|
|
|
+ | None -> if not (link t b a) then error [cannot_unify a b]
|
|
|
+ | Some t -> unify a t)
|
|
|
+ | TType (t,tl) , _ ->
|
|
|
+ if not (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!unify_stack)) then begin
|
|
|
+ try
|
|
|
+ unify_stack := (a,b) :: !unify_stack;
|
|
|
+ unify (apply_params t.t_types tl t.t_type) b;
|
|
|
+ unify_stack := List.tl !unify_stack;
|
|
|
+ with
|
|
|
+ Unify_error l ->
|
|
|
+ unify_stack := List.tl !unify_stack;
|
|
|
+ error (cannot_unify a b :: l)
|
|
|
+ end
|
|
|
+ | _ , TType (t,tl) ->
|
|
|
+ if not (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!unify_stack)) then begin
|
|
|
+ try
|
|
|
+ unify_stack := (a,b) :: !unify_stack;
|
|
|
+ unify a (apply_params t.t_types tl t.t_type);
|
|
|
+ unify_stack := List.tl !unify_stack;
|
|
|
+ with
|
|
|
+ Unify_error l ->
|
|
|
+ unify_stack := List.tl !unify_stack;
|
|
|
+ error (cannot_unify a b :: l)
|
|
|
+ end
|
|
|
+ | TEnum (ea,tl1) , TEnum (eb,tl2) ->
|
|
|
+ if ea != eb then error [cannot_unify a b];
|
|
|
+ unify_types a b tl1 tl2
|
|
|
+ | TAbstract (a1,tl1) , TAbstract (a2,tl2) when a1 == a2 ->
|
|
|
+ unify_types a b tl1 tl2
|
|
|
+ | TAbstract ({a_path=[],"Void"},_) , _
|
|
|
+ | _ , TAbstract ({a_path=[],"Void"},_) ->
|
|
|
+ error [cannot_unify a b]
|
|
|
+ | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
|
|
|
+ let f1 = unify_to_field a1 tl1 b in
|
|
|
+ let f2 = unify_from_field a2 tl2 a b in
|
|
|
+ if not (List.exists (f1 ~allow_transitive_cast:false) a1.a_to) && not (List.exists (f2 ~allow_transitive_cast:false) a2.a_from)
|
|
|
+ && not (List.exists f1 a1.a_to) && not (List.exists f2 a2.a_from) then error [cannot_unify a b]
|
|
|
+ | TInst (c1,tl1) , TInst (c2,tl2) ->
|
|
|
+ let rec loop c tl =
|
|
|
+ if c == c2 then begin
|
|
|
+ unify_types a b tl tl2;
|
|
|
+ true
|
|
|
+ end else (match c.cl_super with
|
|
|
+ | None -> false
|
|
|
+ | Some (cs,tls) ->
|
|
|
+ loop cs (List.map (apply_params c.cl_types tl) tls)
|
|
|
+ ) || List.exists (fun (cs,tls) ->
|
|
|
+ loop cs (List.map (apply_params c.cl_types tl) tls)
|
|
|
+ ) c.cl_implements
|
|
|
+ || (match c.cl_kind with
|
|
|
+ | KTypeParameter pl -> List.exists (fun t -> match follow t with TInst (cs,tls) -> loop cs (List.map (apply_params c.cl_types tl) tls) | _ -> false) pl
|
|
|
+ | _ -> false)
|
|
|
+ in
|
|
|
+ if not (loop c1 tl1) then error [cannot_unify a b]
|
|
|
+ | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
|
|
|
+ let i = ref 0 in
|
|
|
+ (try
|
|
|
+ (match r2 with
|
|
|
+ | TAbstract ({a_path=[],"Void"},_) -> incr i
|
|
|
+ | _ -> unify r1 r2; incr i);
|
|
|
+ List.iter2 (fun (_,o1,t1) (_,o2,t2) ->
|
|
|
+ if o1 && not o2 then error [Cant_force_optional];
|
|
|
+ unify t1 t2;
|
|
|
+ incr i
|
|
|
+ ) l2 l1 (* contravariance *)
|
|
|
+ with
|
|
|
+ Unify_error l ->
|
|
|
+ let msg = if !i = 0 then "Cannot unify return types" else "Cannot unify argument " ^ (string_of_int !i) in
|
|
|
+ error (cannot_unify a b :: Unify_custom msg :: l))
|
|
|
+ | TInst (c,tl) , TAnon an ->
|
|
|
+ if PMap.is_empty an.a_fields then (match c.cl_kind with
|
|
|
+ | KTypeParameter pl ->
|
|
|
+ (* one of the constraints must unify with { } *)
|
|
|
+ if not (List.exists (fun t -> match t with TInst _ | TAnon _ -> true | _ -> false) pl) then error [cannot_unify a b]
|
|
|
+ | _ -> ());
|
|
|
+ (try
|
|
|
+ PMap.iter (fun n f2 ->
|
|
|
+ let _, ft, f1 = (try class_field c n with Not_found -> error [has_no_field a n]) in
|
|
|
+ if not (unify_kind f1.cf_kind f2.cf_kind) then error [invalid_kind n f1.cf_kind f2.cf_kind];
|
|
|
+ if f2.cf_public && not f1.cf_public then error [invalid_visibility n];
|
|
|
+ (try
|
|
|
+ unify_with_access (apply_params c.cl_types tl ft) f2
|
|
|
+ with
|
|
|
+ Unify_error l -> error (invalid_field n :: l));
|
|
|
+ List.iter (fun f2o ->
|
|
|
+ if not (List.exists (fun f1o -> type_iseq f1o.cf_type f2o.cf_type) (f1 :: f1.cf_overloads))
|
|
|
+ then error [Missing_overload (f1, f2o.cf_type)]
|
|
|
+ ) f2.cf_overloads;
|
|
|
(* we mark the field as :?used because it might be used through the structure *)
|
|
|
if not (Meta.has Meta.MaybeUsed f1.cf_meta) then f1.cf_meta <- (Meta.MaybeUsed,[],f1.cf_pos) :: f1.cf_meta;
|
|
|
(match f1.cf_kind with
|
|
@@ -1081,792 +1375,498 @@ let rec unify a b =
|
|
|
| _ -> error [invalid_kind n f1.cf_kind f2.cf_kind]);
|
|
|
if f2.cf_public && not f1.cf_public then error [invalid_visibility n];
|
|
|
try
|
|
|
- unify_with_access f1.cf_type f2;
|
|
|
- (match !(a1.a_status) with
|
|
|
- | Statics c when not (Meta.has Meta.MaybeUsed f1.cf_meta) -> f1.cf_meta <- (Meta.MaybeUsed,[],f1.cf_pos) :: f1.cf_meta
|
|
|
- | _ -> ());
|
|
|
- with
|
|
|
- Unify_error l -> error (invalid_field n :: l)
|
|
|
- with
|
|
|
- Not_found ->
|
|
|
- match !(a1.a_status) with
|
|
|
- | Opened ->
|
|
|
- if not (link (ref None) a f2.cf_type) then error [];
|
|
|
- a1.a_fields <- PMap.add n f2 a1.a_fields
|
|
|
- | Const when Meta.has Meta.Optional f2.cf_meta ->
|
|
|
- ()
|
|
|
- | _ ->
|
|
|
- error [has_no_field a n];
|
|
|
- ) a2.a_fields;
|
|
|
- (match !(a1.a_status) with
|
|
|
- | Const when not (PMap.is_empty a2.a_fields) ->
|
|
|
- PMap.iter (fun n _ -> if not (PMap.mem n a2.a_fields) then error [has_extra_field a n]) a1.a_fields;
|
|
|
- | Opened ->
|
|
|
- a1.a_status := Closed
|
|
|
- | _ -> ());
|
|
|
- (match !(a2.a_status) with
|
|
|
- | Statics c -> (match !(a1.a_status) with Statics c2 when c == c2 -> () | _ -> error [])
|
|
|
- | EnumStatics e -> (match !(a1.a_status) with EnumStatics e2 when e == e2 -> () | _ -> error [])
|
|
|
- | AbstractStatics a -> (match !(a1.a_status) with AbstractStatics a2 when a == a2 -> () | _ -> error [])
|
|
|
- | Opened -> a2.a_status := Closed
|
|
|
- | Const | Closed -> ())
|
|
|
- with
|
|
|
- Unify_error l -> error (cannot_unify a b :: l))
|
|
|
- | TAnon an, TAbstract ({ a_path = [],"Class" },[pt]) ->
|
|
|
- (match !(an.a_status) with
|
|
|
- | Statics cl -> unify (TInst (cl,List.map (fun _ -> mk_mono()) cl.cl_types)) pt
|
|
|
- | _ -> error [cannot_unify a b])
|
|
|
- | TAnon an, TAbstract ({ a_path = [],"Enum" },[pt]) ->
|
|
|
- (match !(an.a_status) with
|
|
|
- | EnumStatics e -> unify (TEnum (e,List.map (fun _ -> mk_mono()) e.e_types)) pt
|
|
|
- | _ -> error [cannot_unify a b])
|
|
|
- | TEnum _, TAbstract ({ a_path = [],"EnumValue" },[]) ->
|
|
|
- ()
|
|
|
- | TEnum(en,_), TAbstract ({ a_path = ["haxe"],"FlatEnum" },[]) when Meta.has Meta.FlatEnum en.e_meta ->
|
|
|
- ()
|
|
|
- | TFun _, TAbstract ({ a_path = ["haxe"],"Function" },[]) ->
|
|
|
- ()
|
|
|
- | TDynamic t , _ ->
|
|
|
- if t == a then
|
|
|
- ()
|
|
|
- else (match b with
|
|
|
- | TDynamic t2 ->
|
|
|
- if t2 != b then
|
|
|
- (try
|
|
|
- type_eq EqRightDynamic t t2
|
|
|
- with
|
|
|
- Unify_error l -> error (cannot_unify a b :: l));
|
|
|
- | _ ->
|
|
|
- error [cannot_unify a b])
|
|
|
- | _ , TDynamic t ->
|
|
|
- if t == b then
|
|
|
- ()
|
|
|
- else (match a with
|
|
|
- | TDynamic t2 ->
|
|
|
- if t2 != a then
|
|
|
- (try
|
|
|
- type_eq EqRightDynamic t t2
|
|
|
- with
|
|
|
- Unify_error l -> error (cannot_unify a b :: l));
|
|
|
- | TAnon an ->
|
|
|
- (try
|
|
|
- (match !(an.a_status) with
|
|
|
- | Statics _ | EnumStatics _ -> error []
|
|
|
- | Opened -> an.a_status := Closed
|
|
|
- | _ -> ());
|
|
|
- PMap.iter (fun _ f ->
|
|
|
- try
|
|
|
- type_eq EqStrict (field_type f) t
|
|
|
- with Unify_error l ->
|
|
|
- error (invalid_field f.cf_name :: l)
|
|
|
- ) an.a_fields
|
|
|
- with Unify_error l ->
|
|
|
- error (cannot_unify a b :: l))
|
|
|
- | _ ->
|
|
|
- error [cannot_unify a b])
|
|
|
- | TAbstract (aa,tl), _ ->
|
|
|
- if not (List.exists (unify_to_field aa tl b) aa.a_to) then error [cannot_unify a b];
|
|
|
- | TInst ({ cl_kind = KTypeParameter ctl } as c,pl), TAbstract (bb,tl) ->
|
|
|
- (* one of the constraints must satisfy the abstract *)
|
|
|
- if not (List.exists (fun t ->
|
|
|
- let t = apply_params c.cl_types pl t in
|
|
|
- try unify t b; true with Unify_error _ -> false
|
|
|
- ) ctl) && not (List.exists (unify_from_field bb tl a b) bb.a_from) then error [cannot_unify a b];
|
|
|
- | _, TAbstract (bb,tl) ->
|
|
|
- if not (List.exists (unify_from_field bb tl a b) bb.a_from) then error [cannot_unify a b]
|
|
|
- | _ , _ ->
|
|
|
- error [cannot_unify a b]
|
|
|
-
|
|
|
-and unify_from_field ab tl a b ?(allow_transitive_cast=true) (t,cfo) =
|
|
|
- if (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
|
|
|
- abstract_cast_stack := (a,b) :: !abstract_cast_stack;
|
|
|
- let unify_func = match follow a with TAbstract({a_impl = Some _},_) when ab.a_impl <> None || not allow_transitive_cast -> type_eq EqStrict | _ -> unify in
|
|
|
- let b = try begin match cfo with
|
|
|
- | Some cf -> (match follow cf.cf_type with
|
|
|
- | TFun(_,r) ->
|
|
|
- let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
|
|
|
- let map t = apply_params ab.a_types tl (apply_params cf.cf_params monos t) in
|
|
|
- unify_func a (map t);
|
|
|
- List.iter2 (fun m (name,t) -> match follow t with
|
|
|
- | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
|
|
|
- List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> unify m (map tc) ) constr
|
|
|
- | _ -> ()
|
|
|
- ) monos cf.cf_params;
|
|
|
- unify (map r) b;
|
|
|
- | _ -> assert false)
|
|
|
- | _ ->
|
|
|
- unify_func a (apply_params ab.a_types tl t)
|
|
|
- end;
|
|
|
- true
|
|
|
- with Unify_error _ -> false
|
|
|
- in
|
|
|
- abstract_cast_stack := List.tl !abstract_cast_stack;
|
|
|
- b
|
|
|
- end
|
|
|
-
|
|
|
-and unify_to_field ab tl b ?(allow_transitive_cast=true) (t,cfo) =
|
|
|
- let a = TAbstract(ab,tl) in
|
|
|
- if (List.exists (fun (b2,a2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
|
|
|
- abstract_cast_stack := (b,a) :: !abstract_cast_stack;
|
|
|
- let unify_func = match follow b with
|
|
|
- | TAbstract(ab2,_) when not (Meta.has Meta.CoreType ab.a_meta) || not (Meta.has Meta.CoreType ab2.a_meta) || not allow_transitive_cast ->
|
|
|
- type_eq EqStrict
|
|
|
- | _ ->
|
|
|
- unify
|
|
|
- in
|
|
|
- let r = try begin match cfo with
|
|
|
- | Some cf -> (match follow cf.cf_type with
|
|
|
- | TFun((_,_,ta) :: _,_) ->
|
|
|
- let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
|
|
|
- let map t = apply_params ab.a_types tl (apply_params cf.cf_params monos t) in
|
|
|
- let athis = map ab.a_this in
|
|
|
- (* we cannot allow implicit casts when the this type is not completely known yet *)
|
|
|
- if has_mono athis then raise (Unify_error []);
|
|
|
- with_variance (type_eq EqStrict) athis (map ta);
|
|
|
- (* immediate constraints checking is ok here because we know there are no monomorphs *)
|
|
|
- List.iter2 (fun m (name,t) -> match follow t with
|
|
|
- | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
|
|
|
- List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> unify m (map tc) ) constr
|
|
|
- | _ -> ()
|
|
|
- ) monos cf.cf_params;
|
|
|
- unify_func (map t) b;
|
|
|
- | _ -> assert false)
|
|
|
- | _ ->
|
|
|
- unify_func (apply_params ab.a_types tl t) b;
|
|
|
- end;
|
|
|
- true
|
|
|
- with Unify_error _ -> false
|
|
|
- in
|
|
|
- abstract_cast_stack := List.tl !abstract_cast_stack;
|
|
|
- r
|
|
|
- end
|
|
|
-
|
|
|
-and unify_with_variance t1 t2 =
|
|
|
- let allows_variance_to t (tf,cfo) = match cfo with
|
|
|
- | None -> type_iseq tf t
|
|
|
- | Some _ -> false
|
|
|
- in
|
|
|
- match follow t1,follow t2 with
|
|
|
- | TInst(c1,tl1),TInst(c2,tl2) when c1 == c2 ->
|
|
|
- List.iter2 unify_with_variance tl1 tl2
|
|
|
- | TEnum(en1,tl1),TEnum(en2,tl2) when en1 == en2 ->
|
|
|
- List.iter2 unify_with_variance tl1 tl2
|
|
|
- | TAbstract(a1,pl1),TAbstract(a2,pl2) ->
|
|
|
- let ta1 = apply_params a1.a_types pl1 a1.a_this in
|
|
|
- let ta2 = apply_params a2.a_types pl2 a2.a_this in
|
|
|
- if (Meta.has Meta.CoreType a1.a_meta) && (Meta.has Meta.CoreType a2.a_meta) then
|
|
|
- type_eq EqStrict ta1 ta2;
|
|
|
- if not (List.exists (allows_variance_to ta2) a1.a_to) && not (List.exists (allows_variance_to ta1) a2.a_from) then
|
|
|
- error [cannot_unify t1 t2]
|
|
|
- | TAbstract(a,pl),t ->
|
|
|
- type_eq EqStrict (apply_params a.a_types pl a.a_this) t;
|
|
|
- if not (List.exists (allows_variance_to t) a.a_to) then error [cannot_unify t1 t2]
|
|
|
- | t,TAbstract(a,pl) ->
|
|
|
- type_eq EqStrict t (apply_params a.a_types pl a.a_this);
|
|
|
- if not (List.exists (allows_variance_to t) a.a_from) then error [cannot_unify t1 t2]
|
|
|
- | _ ->
|
|
|
- error [cannot_unify t1 t2]
|
|
|
-
|
|
|
-and unify_types a b tl1 tl2 =
|
|
|
- List.iter2 (fun t1 t2 ->
|
|
|
- try
|
|
|
- with_variance (type_eq EqRightDynamic) t1 t2
|
|
|
- with Unify_error l ->
|
|
|
- let err = cannot_unify a b in
|
|
|
- error (err :: (Invariant_parameter (t1,t2)) :: l)
|
|
|
- ) tl1 tl2
|
|
|
-
|
|
|
-and with_variance f t1 t2 =
|
|
|
- try
|
|
|
- f t1 t2
|
|
|
- with Unify_error l -> try
|
|
|
- unify_with_variance t1 t2
|
|
|
- with Unify_error _ ->
|
|
|
- raise (Unify_error l)
|
|
|
-
|
|
|
-and unify_with_access t1 f2 =
|
|
|
- match f2.cf_kind with
|
|
|
- (* write only *)
|
|
|
- | Var { v_read = AccNo } | Var { v_read = AccNever } -> unify f2.cf_type t1
|
|
|
- (* read only *)
|
|
|
- | Method MethNormal | Method MethInline | Var { v_write = AccNo } | Var { v_write = AccNever } -> unify t1 f2.cf_type
|
|
|
- (* read/write *)
|
|
|
- | _ -> type_eq EqBothDynamic t1 f2.cf_type
|
|
|
-
|
|
|
-(* ======= Mapping and iterating ======= *)
|
|
|
-
|
|
|
-let iter_dt f dt = match dt with
|
|
|
- | DTBind(_,dt) -> f dt
|
|
|
- | DTSwitch(_,cl,dto) ->
|
|
|
- List.iter (fun (_,dt) -> f dt) cl;
|
|
|
- (match dto with None -> () | Some dt -> f dt)
|
|
|
- | DTGuard(_,dt1,dt2) ->
|
|
|
- f dt1;
|
|
|
- (match dt2 with None -> () | Some dt -> f dt)
|
|
|
- | DTGoto _ | DTExpr _ -> ()
|
|
|
-
|
|
|
-let iter f e =
|
|
|
- match e.eexpr with
|
|
|
- | TConst _
|
|
|
- | TLocal _
|
|
|
- | TBreak
|
|
|
- | TContinue
|
|
|
- | TTypeExpr _ ->
|
|
|
- ()
|
|
|
- | TArray (e1,e2)
|
|
|
- | TBinop (_,e1,e2)
|
|
|
- | TFor (_,e1,e2)
|
|
|
- | TWhile (e1,e2,_) ->
|
|
|
- f e1;
|
|
|
- f e2;
|
|
|
- | TThrow e
|
|
|
- | TField (e,_)
|
|
|
- | TEnumParameter (e,_,_)
|
|
|
- | TParenthesis e
|
|
|
- | TCast (e,_)
|
|
|
- | TUnop (_,_,e)
|
|
|
- | TMeta(_,e) ->
|
|
|
- f e
|
|
|
- | TArrayDecl el
|
|
|
- | TNew (_,_,el)
|
|
|
- | TBlock el ->
|
|
|
- List.iter f el
|
|
|
- | TObjectDecl fl ->
|
|
|
- List.iter (fun (_,e) -> f e) fl
|
|
|
- | TCall (e,el) ->
|
|
|
- f e;
|
|
|
- List.iter f el
|
|
|
- | TVar (v,eo) ->
|
|
|
- (match eo with None -> () | Some e -> f e)
|
|
|
- | TFunction fu ->
|
|
|
- f fu.tf_expr
|
|
|
- | TIf (e,e1,e2) ->
|
|
|
- f e;
|
|
|
- f e1;
|
|
|
- (match e2 with None -> () | Some e -> f e)
|
|
|
- | TSwitch (e,cases,def) ->
|
|
|
- f e;
|
|
|
- List.iter (fun (el,e2) -> List.iter f el; f e2) cases;
|
|
|
- (match def with None -> () | Some e -> f e)
|
|
|
- | TPatMatch dt ->
|
|
|
- let rec loop dt = match dt with
|
|
|
- | DTBind(_,dt) -> loop dt
|
|
|
- | DTGoto _ -> ()
|
|
|
- | DTSwitch(e,cl,dto) ->
|
|
|
- f e;
|
|
|
- List.iter (fun (e,dt) ->
|
|
|
- f e;
|
|
|
- loop dt
|
|
|
- ) cl;
|
|
|
- (match dto with None -> () | Some dt -> loop dt)
|
|
|
- | DTExpr e -> f e
|
|
|
- | DTGuard(eg,dt1,dt2) ->
|
|
|
- f eg;
|
|
|
- loop dt1;
|
|
|
- (match dt2 with None -> () | Some dt -> loop dt)
|
|
|
- in
|
|
|
- List.iter (fun (_,eo) -> match eo with None -> () | Some e -> f e) dt.dt_var_init;
|
|
|
- Array.iter loop dt.dt_dt_lookup
|
|
|
- | TTry (e,catches) ->
|
|
|
- f e;
|
|
|
- List.iter (fun (_,e) -> f e) catches
|
|
|
- | TReturn eo ->
|
|
|
- (match eo with None -> () | Some e -> f e)
|
|
|
-
|
|
|
-let map_expr f e =
|
|
|
- match e.eexpr with
|
|
|
- | TConst _
|
|
|
- | TLocal _
|
|
|
- | TBreak
|
|
|
- | TContinue
|
|
|
- | TTypeExpr _ ->
|
|
|
- e
|
|
|
- | TArray (e1,e2) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TArray (e1,f e2) }
|
|
|
- | TBinop (op,e1,e2) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TBinop (op,e1,f e2) }
|
|
|
- | TFor (v,e1,e2) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TFor (v,e1,f e2) }
|
|
|
- | TWhile (e1,e2,flag) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TWhile (e1,f e2,flag) }
|
|
|
- | TThrow e1 ->
|
|
|
- { e with eexpr = TThrow (f e1) }
|
|
|
- | TEnumParameter (e1,ef,i) ->
|
|
|
- { e with eexpr = TEnumParameter(f e1,ef,i) }
|
|
|
- | TField (e1,v) ->
|
|
|
- { e with eexpr = TField (f e1,v) }
|
|
|
- | TParenthesis e1 ->
|
|
|
- { e with eexpr = TParenthesis (f e1) }
|
|
|
- | TUnop (op,pre,e1) ->
|
|
|
- { e with eexpr = TUnop (op,pre,f e1) }
|
|
|
- | TArrayDecl el ->
|
|
|
- { e with eexpr = TArrayDecl (List.map f el) }
|
|
|
- | TNew (t,pl,el) ->
|
|
|
- { e with eexpr = TNew (t,pl,List.map f el) }
|
|
|
- | TBlock el ->
|
|
|
- { e with eexpr = TBlock (List.map f el) }
|
|
|
- | TObjectDecl el ->
|
|
|
- { e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el) }
|
|
|
- | TCall (e1,el) ->
|
|
|
- { e with eexpr = TCall (f e1, List.map f el) }
|
|
|
- | TVar (v,eo) ->
|
|
|
- { e with eexpr = TVar (v, match eo with None -> None | Some e -> Some (f e)) }
|
|
|
- | TFunction fu ->
|
|
|
- { e with eexpr = TFunction { fu with tf_expr = f fu.tf_expr } }
|
|
|
- | TIf (ec,e1,e2) ->
|
|
|
- let ec = f ec in
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TIf (ec,e1,match e2 with None -> None | Some e -> Some (f e)) }
|
|
|
- | TSwitch (e1,cases,def) ->
|
|
|
- let e1 = f e1 in
|
|
|
- let cases = List.map (fun (el,e2) -> List.map f el, f e2) cases in
|
|
|
- { e with eexpr = TSwitch (e1, cases, match def with None -> None | Some e -> Some (f e)) }
|
|
|
- | TPatMatch dt ->
|
|
|
- let rec loop dt = match dt with
|
|
|
- | DTBind(vl,dt) -> DTBind(vl, loop dt)
|
|
|
- | DTGoto _ -> dt
|
|
|
- | DTSwitch(e,cl,dto) -> DTSwitch(f e, List.map (fun (e,dt) -> f e,loop dt) cl,match dto with None -> None | Some dt -> Some (loop dt))
|
|
|
- | DTExpr e -> DTExpr(f e)
|
|
|
- | DTGuard(e,dt1,dt2) -> DTGuard(f e,loop dt1,match dt2 with None -> None | Some dt -> Some (loop dt))
|
|
|
- in
|
|
|
- let vi = List.map (fun (v,eo) -> v, match eo with None -> None | Some e -> Some(f e)) dt.dt_var_init in
|
|
|
- { e with eexpr = TPatMatch({dt with dt_dt_lookup = Array.map loop dt.dt_dt_lookup; dt_var_init = vi})}
|
|
|
- | TTry (e1,catches) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TTry (e1, List.map (fun (v,e) -> v, f e) catches) }
|
|
|
- | TReturn eo ->
|
|
|
- { e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)) }
|
|
|
- | TCast (e1,t) ->
|
|
|
- { e with eexpr = TCast (f e1,t) }
|
|
|
- | TMeta (m,e1) ->
|
|
|
- {e with eexpr = TMeta(m,f e1)}
|
|
|
-
|
|
|
-let map_expr_type f ft fv e =
|
|
|
- match e.eexpr with
|
|
|
- | TConst _
|
|
|
- | TBreak
|
|
|
- | TContinue
|
|
|
- | TTypeExpr _ ->
|
|
|
- { e with etype = ft e.etype }
|
|
|
- | TLocal v ->
|
|
|
- { e with eexpr = TLocal (fv v); etype = ft e.etype }
|
|
|
- | TArray (e1,e2) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TArray (e1,f e2); etype = ft e.etype }
|
|
|
- | TBinop (op,e1,e2) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TBinop (op,e1,f e2); etype = ft e.etype }
|
|
|
- | TFor (v,e1,e2) ->
|
|
|
- let v = fv v in
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TFor (v,e1,f e2); etype = ft e.etype }
|
|
|
- | TWhile (e1,e2,flag) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TWhile (e1,f e2,flag); etype = ft e.etype }
|
|
|
- | TThrow e1 ->
|
|
|
- { e with eexpr = TThrow (f e1); etype = ft e.etype }
|
|
|
- | TEnumParameter (e1,ef,i) ->
|
|
|
- { e with eexpr = TEnumParameter(f e1,ef,i); etype = ft e.etype }
|
|
|
- | TField (e1,v) ->
|
|
|
- let e1 = f e1 in
|
|
|
- let v = try
|
|
|
- let n = match v with
|
|
|
- | FClosure _ -> raise Not_found
|
|
|
- | FAnon f | FInstance (_,f) | FStatic (_,f) -> f.cf_name
|
|
|
- | FEnum (_,f) -> f.ef_name
|
|
|
- | FDynamic n -> n
|
|
|
- in
|
|
|
- quick_field e1.etype n
|
|
|
- with Not_found ->
|
|
|
- v
|
|
|
- in
|
|
|
- { e with eexpr = TField (e1,v); etype = ft e.etype }
|
|
|
- | TParenthesis e1 ->
|
|
|
- { e with eexpr = TParenthesis (f e1); etype = ft e.etype }
|
|
|
- | TUnop (op,pre,e1) ->
|
|
|
- { e with eexpr = TUnop (op,pre,f e1); etype = ft e.etype }
|
|
|
- | TArrayDecl el ->
|
|
|
- { e with eexpr = TArrayDecl (List.map f el); etype = ft e.etype }
|
|
|
- | TNew (c,pl,el) ->
|
|
|
- let et = ft e.etype in
|
|
|
- (* make sure that we use the class corresponding to the replaced type *)
|
|
|
- let t = match c.cl_kind with
|
|
|
- | KTypeParameter _ | KGeneric ->
|
|
|
- et
|
|
|
- | _ ->
|
|
|
- ft (TInst(c,pl))
|
|
|
- in
|
|
|
- let c, pl = (match follow t with TInst (c,pl) -> (c,pl) | TAbstract({a_impl = Some c},pl) -> c,pl | t -> error [has_no_field t "new"]) in
|
|
|
- { e with eexpr = TNew (c,pl,List.map f el); etype = et }
|
|
|
- | TBlock el ->
|
|
|
- { e with eexpr = TBlock (List.map f el); etype = ft e.etype }
|
|
|
- | TObjectDecl el ->
|
|
|
- { e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el); etype = ft e.etype }
|
|
|
- | TCall (e1,el) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TCall (e1, List.map f el); etype = ft e.etype }
|
|
|
- | TVar (v,eo) ->
|
|
|
- { e with eexpr = TVar (fv v, match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }
|
|
|
- | TFunction fu ->
|
|
|
- let fu = {
|
|
|
- tf_expr = f fu.tf_expr;
|
|
|
- tf_args = List.map (fun (v,o) -> fv v, o) fu.tf_args;
|
|
|
- tf_type = ft fu.tf_type;
|
|
|
- } in
|
|
|
- { e with eexpr = TFunction fu; etype = ft e.etype }
|
|
|
- | TIf (ec,e1,e2) ->
|
|
|
- let ec = f ec in
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TIf (ec,e1,match e2 with None -> None | Some e -> Some (f e)); etype = ft e.etype }
|
|
|
- | TSwitch (e1,cases,def) ->
|
|
|
- let e1 = f e1 in
|
|
|
- let cases = List.map (fun (el,e2) -> List.map f el, f e2) cases in
|
|
|
- { e with eexpr = TSwitch (e1, cases, match def with None -> None | Some e -> Some (f e)); etype = ft e.etype }
|
|
|
- | TPatMatch dt ->
|
|
|
- let rec loop dt = match dt with
|
|
|
- | DTBind(vl,dt) -> DTBind(vl, loop dt)
|
|
|
- | DTGoto _ -> dt
|
|
|
- | DTSwitch(e,cl,dto) -> DTSwitch(f e, List.map (fun (e,dt) -> f e,loop dt) cl,match dto with None -> None | Some dt -> Some (loop dt))
|
|
|
- | DTExpr e -> DTExpr(f e)
|
|
|
- | DTGuard (e,dt1,dt2) -> DTGuard(f e, loop dt, match dt2 with None -> None | Some dt -> Some (loop dt))
|
|
|
- in
|
|
|
- let vi = List.map (fun (v,eo) -> v, match eo with None -> None | Some e -> Some(f e)) dt.dt_var_init in
|
|
|
- { e with eexpr = TPatMatch({dt with dt_dt_lookup = Array.map loop dt.dt_dt_lookup; dt_var_init = vi}); etype = ft e.etype}
|
|
|
- | TTry (e1,catches) ->
|
|
|
- let e1 = f e1 in
|
|
|
- { e with eexpr = TTry (e1, List.map (fun (v,e) -> fv v, f e) catches); etype = ft e.etype }
|
|
|
- | TReturn eo ->
|
|
|
- { e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }
|
|
|
- | TCast (e1,t) ->
|
|
|
- { e with eexpr = TCast (f e1,t); etype = ft e.etype }
|
|
|
- | TMeta (m,e1) ->
|
|
|
- {e with eexpr = TMeta(m, f e1); etype = ft e.etype }
|
|
|
-
|
|
|
-(* ======= Miscellaneous ======= *)
|
|
|
+ unify_with_access f1.cf_type f2;
|
|
|
+ (match !(a1.a_status) with
|
|
|
+ | Statics c when not (Meta.has Meta.MaybeUsed f1.cf_meta) -> f1.cf_meta <- (Meta.MaybeUsed,[],f1.cf_pos) :: f1.cf_meta
|
|
|
+ | _ -> ());
|
|
|
+ with
|
|
|
+ Unify_error l -> error (invalid_field n :: l)
|
|
|
+ with
|
|
|
+ Not_found ->
|
|
|
+ match !(a1.a_status) with
|
|
|
+ | Opened ->
|
|
|
+ if not (link (ref None) a f2.cf_type) then error [];
|
|
|
+ a1.a_fields <- PMap.add n f2 a1.a_fields
|
|
|
+ | Const when Meta.has Meta.Optional f2.cf_meta ->
|
|
|
+ ()
|
|
|
+ | _ ->
|
|
|
+ error [has_no_field a n];
|
|
|
+ ) a2.a_fields;
|
|
|
+ (match !(a1.a_status) with
|
|
|
+ | Const when not (PMap.is_empty a2.a_fields) ->
|
|
|
+ PMap.iter (fun n _ -> if not (PMap.mem n a2.a_fields) then error [has_extra_field a n]) a1.a_fields;
|
|
|
+ | Opened ->
|
|
|
+ a1.a_status := Closed
|
|
|
+ | _ -> ());
|
|
|
+ (match !(a2.a_status) with
|
|
|
+ | Statics c -> (match !(a1.a_status) with Statics c2 when c == c2 -> () | _ -> error [])
|
|
|
+ | EnumStatics e -> (match !(a1.a_status) with EnumStatics e2 when e == e2 -> () | _ -> error [])
|
|
|
+ | AbstractStatics a -> (match !(a1.a_status) with AbstractStatics a2 when a == a2 -> () | _ -> error [])
|
|
|
+ | Opened -> a2.a_status := Closed
|
|
|
+ | Const | Closed -> ())
|
|
|
+ with
|
|
|
+ Unify_error l -> error (cannot_unify a b :: l))
|
|
|
+ | TAnon an, TAbstract ({ a_path = [],"Class" },[pt]) ->
|
|
|
+ (match !(an.a_status) with
|
|
|
+ | Statics cl -> unify (TInst (cl,List.map (fun _ -> mk_mono()) cl.cl_types)) pt
|
|
|
+ | _ -> error [cannot_unify a b])
|
|
|
+ | TAnon an, TAbstract ({ a_path = [],"Enum" },[pt]) ->
|
|
|
+ (match !(an.a_status) with
|
|
|
+ | EnumStatics e -> unify (TEnum (e,List.map (fun _ -> mk_mono()) e.e_types)) pt
|
|
|
+ | _ -> error [cannot_unify a b])
|
|
|
+ | TEnum _, TAbstract ({ a_path = [],"EnumValue" },[]) ->
|
|
|
+ ()
|
|
|
+ | TEnum(en,_), TAbstract ({ a_path = ["haxe"],"FlatEnum" },[]) when Meta.has Meta.FlatEnum en.e_meta ->
|
|
|
+ ()
|
|
|
+ | TFun _, TAbstract ({ a_path = ["haxe"],"Function" },[]) ->
|
|
|
+ ()
|
|
|
+ | TDynamic t , _ ->
|
|
|
+ if t == a then
|
|
|
+ ()
|
|
|
+ else (match b with
|
|
|
+ | TDynamic t2 ->
|
|
|
+ if t2 != b then
|
|
|
+ (try
|
|
|
+ type_eq EqRightDynamic t t2
|
|
|
+ with
|
|
|
+ Unify_error l -> error (cannot_unify a b :: l));
|
|
|
+ | _ ->
|
|
|
+ error [cannot_unify a b])
|
|
|
+ | _ , TDynamic t ->
|
|
|
+ if t == b then
|
|
|
+ ()
|
|
|
+ else (match a with
|
|
|
+ | TDynamic t2 ->
|
|
|
+ if t2 != a then
|
|
|
+ (try
|
|
|
+ type_eq EqRightDynamic t t2
|
|
|
+ with
|
|
|
+ Unify_error l -> error (cannot_unify a b :: l));
|
|
|
+ | TAnon an ->
|
|
|
+ (try
|
|
|
+ (match !(an.a_status) with
|
|
|
+ | Statics _ | EnumStatics _ -> error []
|
|
|
+ | Opened -> an.a_status := Closed
|
|
|
+ | _ -> ());
|
|
|
+ PMap.iter (fun _ f ->
|
|
|
+ try
|
|
|
+ type_eq EqStrict (field_type f) t
|
|
|
+ with Unify_error l ->
|
|
|
+ error (invalid_field f.cf_name :: l)
|
|
|
+ ) an.a_fields
|
|
|
+ with Unify_error l ->
|
|
|
+ error (cannot_unify a b :: l))
|
|
|
+ | _ ->
|
|
|
+ error [cannot_unify a b])
|
|
|
+ | TAbstract (aa,tl), _ ->
|
|
|
+ if not (List.exists (unify_to_field aa tl b) aa.a_to) then error [cannot_unify a b];
|
|
|
+ | TInst ({ cl_kind = KTypeParameter ctl } as c,pl), TAbstract (bb,tl) ->
|
|
|
+ (* one of the constraints must satisfy the abstract *)
|
|
|
+ if not (List.exists (fun t ->
|
|
|
+ let t = apply_params c.cl_types pl t in
|
|
|
+ try unify t b; true with Unify_error _ -> false
|
|
|
+ ) ctl) && not (List.exists (unify_from_field bb tl a b) bb.a_from) then error [cannot_unify a b];
|
|
|
+ | _, TAbstract (bb,tl) ->
|
|
|
+ if not (List.exists (unify_from_field bb tl a b) bb.a_from) then error [cannot_unify a b]
|
|
|
+ | _ , _ ->
|
|
|
+ error [cannot_unify a b]
|
|
|
|
|
|
-let find_array_access a pl 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
|
|
|
- unify tab ta;
|
|
|
- unify t1 ta1;
|
|
|
- unify t2 ta2;
|
|
|
- cf,tf,r
|
|
|
- with Unify_error _ ->
|
|
|
- loop cfl
|
|
|
- end
|
|
|
- | TFun([(_,_,tab);(_,_,ta1)],r) as tf when not is_set ->
|
|
|
- begin try
|
|
|
- unify tab ta;
|
|
|
- unify t1 ta1;
|
|
|
- cf,tf,r
|
|
|
- with Unify_error _ ->
|
|
|
- loop cfl
|
|
|
- end
|
|
|
- | _ -> loop cfl
|
|
|
+and unify_from_field ab tl a b ?(allow_transitive_cast=true) (t,cfo) =
|
|
|
+ if (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
|
|
|
+ abstract_cast_stack := (a,b) :: !abstract_cast_stack;
|
|
|
+ let unify_func = match follow a with TAbstract({a_impl = Some _},_) when ab.a_impl <> None || not allow_transitive_cast -> type_eq EqStrict | _ -> unify in
|
|
|
+ let b = try begin match cfo with
|
|
|
+ | Some cf -> (match follow cf.cf_type with
|
|
|
+ | TFun(_,r) ->
|
|
|
+ let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
|
|
|
+ let map t = apply_params ab.a_types tl (apply_params cf.cf_params monos t) in
|
|
|
+ unify_func a (map t);
|
|
|
+ List.iter2 (fun m (name,t) -> match follow t with
|
|
|
+ | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
|
|
|
+ List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> unify m (map tc) ) constr
|
|
|
+ | _ -> ()
|
|
|
+ ) monos cf.cf_params;
|
|
|
+ unify (map r) b;
|
|
|
+ | _ -> assert false)
|
|
|
+ | _ ->
|
|
|
+ unify_func a (apply_params ab.a_types tl t)
|
|
|
+ end;
|
|
|
+ true
|
|
|
+ with Unify_error _ -> false
|
|
|
in
|
|
|
- loop a.a_array
|
|
|
-
|
|
|
-(* ======= Printing ======= *)
|
|
|
-
|
|
|
-let print_context() = ref []
|
|
|
+ abstract_cast_stack := List.tl !abstract_cast_stack;
|
|
|
+ b
|
|
|
+ end
|
|
|
|
|
|
-let rec s_type ctx t =
|
|
|
- match t with
|
|
|
- | TMono r ->
|
|
|
- (match !r with
|
|
|
- | None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
|
|
|
- | Some t -> s_type ctx t)
|
|
|
- | TEnum (e,tl) ->
|
|
|
- Ast.s_type_path e.e_path ^ s_type_params ctx tl
|
|
|
- | TInst (c,tl) ->
|
|
|
- (match c.cl_kind with
|
|
|
- | KExpr e -> Ast.s_expr e
|
|
|
- | _ -> Ast.s_type_path c.cl_path ^ s_type_params ctx tl)
|
|
|
- | TType (t,tl) ->
|
|
|
- Ast.s_type_path t.t_path ^ s_type_params ctx tl
|
|
|
- | TAbstract (a,tl) ->
|
|
|
- Ast.s_type_path a.a_path ^ s_type_params ctx tl
|
|
|
- | TFun ([],t) ->
|
|
|
- "Void -> " ^ s_fun ctx t false
|
|
|
- | TFun (l,t) ->
|
|
|
- String.concat " -> " (List.map (fun (s,b,t) ->
|
|
|
- (if b then "?" else "") ^ (if s = "" then "" else s ^ " : ") ^ s_fun ctx t true
|
|
|
- ) l) ^ " -> " ^ s_fun ctx t false
|
|
|
- | TAnon a ->
|
|
|
- let fl = PMap.fold (fun f acc -> ((if Meta.has Meta.Optional f.cf_meta then " ?" else " ") ^ f.cf_name ^ " : " ^ s_type ctx f.cf_type) :: acc) a.a_fields [] in
|
|
|
- "{" ^ (if not (is_closed a) then "+" else "") ^ String.concat "," fl ^ " }"
|
|
|
- | TDynamic t2 ->
|
|
|
- "Dynamic" ^ s_type_params ctx (if t == t2 then [] else [t2])
|
|
|
- | TLazy f ->
|
|
|
- s_type ctx (!f())
|
|
|
+and unify_to_field ab tl b ?(allow_transitive_cast=true) (t,cfo) =
|
|
|
+ let a = TAbstract(ab,tl) in
|
|
|
+ if (List.exists (fun (b2,a2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
|
|
|
+ abstract_cast_stack := (b,a) :: !abstract_cast_stack;
|
|
|
+ let unify_func = match follow b with
|
|
|
+ | TAbstract(ab2,_) when not (Meta.has Meta.CoreType ab.a_meta) || not (Meta.has Meta.CoreType ab2.a_meta) || not allow_transitive_cast ->
|
|
|
+ type_eq EqStrict
|
|
|
+ | _ ->
|
|
|
+ unify
|
|
|
+ in
|
|
|
+ let r = try begin match cfo with
|
|
|
+ | Some cf -> (match follow cf.cf_type with
|
|
|
+ | TFun((_,_,ta) :: _,_) ->
|
|
|
+ let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
|
|
|
+ let map t = apply_params ab.a_types tl (apply_params cf.cf_params monos t) in
|
|
|
+ let athis = map ab.a_this in
|
|
|
+ (* we cannot allow implicit casts when the this type is not completely known yet *)
|
|
|
+ (* if has_mono athis then raise (Unify_error []); *)
|
|
|
+ with_variance (type_eq EqStrict) athis (map ta);
|
|
|
+ (* immediate constraints checking is ok here because we know there are no monomorphs *)
|
|
|
+ List.iter2 (fun m (name,t) -> match follow t with
|
|
|
+ | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
|
|
|
+ List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> unify m (map tc) ) constr
|
|
|
+ | _ -> ()
|
|
|
+ ) monos cf.cf_params;
|
|
|
+ unify_func (map t) b;
|
|
|
+ | _ -> assert false)
|
|
|
+ | _ ->
|
|
|
+ unify_func (apply_params ab.a_types tl t) b;
|
|
|
+ end;
|
|
|
+ true
|
|
|
+ with Unify_error _ -> false
|
|
|
+ in
|
|
|
+ abstract_cast_stack := List.tl !abstract_cast_stack;
|
|
|
+ r
|
|
|
+ end
|
|
|
|
|
|
-and s_fun ctx t void =
|
|
|
- match t with
|
|
|
- | TFun _ ->
|
|
|
- "(" ^ s_type ctx t ^ ")"
|
|
|
- | TAbstract ({ a_path = ([],"Void") },[]) when void ->
|
|
|
- "(" ^ s_type ctx t ^ ")"
|
|
|
- | TMono r ->
|
|
|
- (match !r with
|
|
|
- | None -> s_type ctx t
|
|
|
- | Some t -> s_fun ctx t void)
|
|
|
- | TLazy f ->
|
|
|
- s_fun ctx (!f()) void
|
|
|
+and unify_with_variance t1 t2 =
|
|
|
+ let allows_variance_to t (tf,cfo) = match cfo with
|
|
|
+ | None -> type_iseq tf t
|
|
|
+ | Some _ -> false
|
|
|
+ in
|
|
|
+ match follow t1,follow t2 with
|
|
|
+ | TInst(c1,tl1),TInst(c2,tl2) when c1 == c2 ->
|
|
|
+ List.iter2 unify_with_variance tl1 tl2
|
|
|
+ | TEnum(en1,tl1),TEnum(en2,tl2) when en1 == en2 ->
|
|
|
+ List.iter2 unify_with_variance tl1 tl2
|
|
|
+ | TAbstract(a1,pl1),TAbstract(a2,pl2) ->
|
|
|
+ let ta1 = apply_params a1.a_types pl1 a1.a_this in
|
|
|
+ let ta2 = apply_params a2.a_types pl2 a2.a_this in
|
|
|
+ if (Meta.has Meta.CoreType a1.a_meta) && (Meta.has Meta.CoreType a2.a_meta) then
|
|
|
+ type_eq EqStrict ta1 ta2;
|
|
|
+ if not (List.exists (allows_variance_to ta2) a1.a_to) && not (List.exists (allows_variance_to ta1) a2.a_from) then
|
|
|
+ error [cannot_unify t1 t2]
|
|
|
+ | TAbstract(a,pl),t ->
|
|
|
+ type_eq EqStrict (apply_params a.a_types pl a.a_this) t;
|
|
|
+ if not (List.exists (allows_variance_to t) a.a_to) then error [cannot_unify t1 t2]
|
|
|
+ | t,TAbstract(a,pl) ->
|
|
|
+ type_eq EqStrict t (apply_params a.a_types pl a.a_this);
|
|
|
+ if not (List.exists (allows_variance_to t) a.a_from) then error [cannot_unify t1 t2]
|
|
|
| _ ->
|
|
|
- s_type ctx t
|
|
|
+ error [cannot_unify t1 t2]
|
|
|
|
|
|
-and s_type_params ctx = function
|
|
|
- | [] -> ""
|
|
|
- | l -> "<" ^ String.concat ", " (List.map (s_type ctx) l) ^ ">"
|
|
|
+and unify_types a b tl1 tl2 =
|
|
|
+ List.iter2 (fun t1 t2 ->
|
|
|
+ try
|
|
|
+ with_variance (type_eq EqRightDynamic) t1 t2
|
|
|
+ with Unify_error l ->
|
|
|
+ let err = cannot_unify a b in
|
|
|
+ error (err :: (Invariant_parameter (t1,t2)) :: l)
|
|
|
+ ) tl1 tl2
|
|
|
|
|
|
-let s_access is_read = function
|
|
|
- | AccNormal -> "default"
|
|
|
- | AccNo -> "null"
|
|
|
- | AccNever -> "never"
|
|
|
- | AccResolve -> "resolve"
|
|
|
- | AccCall -> if is_read then "get" else "set"
|
|
|
- | AccInline -> "inline"
|
|
|
- | AccRequire (n,_) -> "require " ^ n
|
|
|
+and with_variance f t1 t2 =
|
|
|
+ try
|
|
|
+ f t1 t2
|
|
|
+ with Unify_error l -> try
|
|
|
+ unify_with_variance t1 t2
|
|
|
+ with Unify_error _ ->
|
|
|
+ raise (Unify_error l)
|
|
|
|
|
|
-let s_kind = function
|
|
|
- | Var { v_read = AccNormal; v_write = AccNormal } -> "var"
|
|
|
- | Var v -> "(" ^ s_access true v.v_read ^ "," ^ s_access false v.v_write ^ ")"
|
|
|
- | Method m ->
|
|
|
- match m with
|
|
|
- | MethNormal -> "method"
|
|
|
- | MethDynamic -> "dynamic method"
|
|
|
- | MethInline -> "inline method"
|
|
|
- | MethMacro -> "macro method"
|
|
|
+and unify_with_access t1 f2 =
|
|
|
+ match f2.cf_kind with
|
|
|
+ (* write only *)
|
|
|
+ | Var { v_read = AccNo } | Var { v_read = AccNever } -> unify f2.cf_type t1
|
|
|
+ (* read only *)
|
|
|
+ | Method MethNormal | Method MethInline | Var { v_write = AccNo } | Var { v_write = AccNever } -> unify t1 f2.cf_type
|
|
|
+ (* read/write *)
|
|
|
+ | _ -> type_eq EqBothDynamic t1 f2.cf_type
|
|
|
|
|
|
-let s_expr_kind e =
|
|
|
- match e.eexpr with
|
|
|
- | TConst _ -> "Const"
|
|
|
- | TLocal _ -> "Local"
|
|
|
- | TArray (_,_) -> "Array"
|
|
|
- | TBinop (_,_,_) -> "Binop"
|
|
|
- | TEnumParameter (_,_,_) -> "EnumParameter"
|
|
|
- | TField (_,_) -> "Field"
|
|
|
- | TTypeExpr _ -> "TypeExpr"
|
|
|
- | TParenthesis _ -> "Parenthesis"
|
|
|
- | TObjectDecl _ -> "ObjectDecl"
|
|
|
- | TArrayDecl _ -> "ArrayDecl"
|
|
|
- | TCall (_,_) -> "Call"
|
|
|
- | TNew (_,_,_) -> "New"
|
|
|
- | TUnop (_,_,_) -> "Unop"
|
|
|
- | TFunction _ -> "Function"
|
|
|
- | TVar _ -> "Vars"
|
|
|
- | TBlock _ -> "Block"
|
|
|
- | TFor (_,_,_) -> "For"
|
|
|
- | TIf (_,_,_) -> "If"
|
|
|
- | TWhile (_,_,_) -> "While"
|
|
|
- | TSwitch (_,_,_) -> "Switch"
|
|
|
- | TPatMatch _ -> "PatMatch"
|
|
|
- | TTry (_,_) -> "Try"
|
|
|
- | TReturn _ -> "Return"
|
|
|
- | TBreak -> "Break"
|
|
|
- | TContinue -> "Continue"
|
|
|
- | TThrow _ -> "Throw"
|
|
|
- | TCast _ -> "Cast"
|
|
|
- | TMeta _ -> "Meta"
|
|
|
+(* ======= Mapping and iterating ======= *)
|
|
|
|
|
|
-let s_const = function
|
|
|
- | TInt i -> Int32.to_string i
|
|
|
- | TFloat s -> s ^ "f"
|
|
|
- | TString s -> Printf.sprintf "\"%s\"" (Ast.s_escape s)
|
|
|
- | TBool b -> if b then "true" else "false"
|
|
|
- | TNull -> "null"
|
|
|
- | TThis -> "this"
|
|
|
- | TSuper -> "super"
|
|
|
+let iter_dt f dt = match dt with
|
|
|
+ | DTBind(_,dt) -> f dt
|
|
|
+ | DTSwitch(_,cl,dto) ->
|
|
|
+ List.iter (fun (_,dt) -> f dt) cl;
|
|
|
+ (match dto with None -> () | Some dt -> f dt)
|
|
|
+ | DTGuard(_,dt1,dt2) ->
|
|
|
+ f dt1;
|
|
|
+ (match dt2 with None -> () | Some dt -> f dt)
|
|
|
+ | DTGoto _ | DTExpr _ -> ()
|
|
|
|
|
|
-let rec s_expr s_type e =
|
|
|
- let sprintf = Printf.sprintf in
|
|
|
- let slist f l = String.concat "," (List.map f l) in
|
|
|
- let loop = s_expr s_type in
|
|
|
- let s_var v = v.v_name ^ ":" ^ string_of_int v.v_id ^ if v.v_capture then "[c]" else "" in
|
|
|
- let str = (match e.eexpr with
|
|
|
- | TConst c ->
|
|
|
- "Const " ^ s_const c
|
|
|
- | TLocal v ->
|
|
|
- "Local " ^ s_var v
|
|
|
- | TArray (e1,e2) ->
|
|
|
- sprintf "%s[%s]" (loop e1) (loop e2)
|
|
|
- | TBinop (op,e1,e2) ->
|
|
|
- sprintf "(%s %s %s)" (loop e1) (s_binop op) (loop e2)
|
|
|
- | TEnumParameter (e1,_,i) ->
|
|
|
- sprintf "%s[%i]" (loop e1) i
|
|
|
- | TField (e,f) ->
|
|
|
- let fstr = (match f with
|
|
|
- | FStatic (c,f) -> "static(" ^ s_type_path c.cl_path ^ "." ^ f.cf_name ^ ")"
|
|
|
- | FInstance (c,f) -> "inst(" ^ s_type_path c.cl_path ^ "." ^ f.cf_name ^ " : " ^ s_type f.cf_type ^ ")"
|
|
|
- | FClosure (c,f) -> "closure(" ^ (match c with None -> f.cf_name | Some c -> s_type_path c.cl_path ^ "." ^ f.cf_name) ^ ")"
|
|
|
- | FAnon f -> "anon(" ^ f.cf_name ^ ")"
|
|
|
- | FEnum (en,f) -> "enum(" ^ s_type_path en.e_path ^ "." ^ f.ef_name ^ ")"
|
|
|
- | FDynamic f -> "dynamic(" ^ f ^ ")"
|
|
|
- ) in
|
|
|
- sprintf "%s.%s" (loop e) fstr
|
|
|
- | TTypeExpr m ->
|
|
|
- sprintf "TypeExpr %s" (s_type_path (t_path m))
|
|
|
- | TParenthesis e ->
|
|
|
- sprintf "Parenthesis %s" (loop e)
|
|
|
+let iter f e =
|
|
|
+ match e.eexpr with
|
|
|
+ | TConst _
|
|
|
+ | TLocal _
|
|
|
+ | TBreak
|
|
|
+ | TContinue
|
|
|
+ | TTypeExpr _ ->
|
|
|
+ ()
|
|
|
+ | TArray (e1,e2)
|
|
|
+ | TBinop (_,e1,e2)
|
|
|
+ | TFor (_,e1,e2)
|
|
|
+ | TWhile (e1,e2,_) ->
|
|
|
+ f e1;
|
|
|
+ f e2;
|
|
|
+ | TThrow e
|
|
|
+ | TField (e,_)
|
|
|
+ | TEnumParameter (e,_,_)
|
|
|
+ | TParenthesis e
|
|
|
+ | TCast (e,_)
|
|
|
+ | TUnop (_,_,e)
|
|
|
+ | TMeta(_,e) ->
|
|
|
+ f e
|
|
|
+ | TArrayDecl el
|
|
|
+ | TNew (_,_,el)
|
|
|
+ | TBlock el ->
|
|
|
+ List.iter f el
|
|
|
| TObjectDecl fl ->
|
|
|
- sprintf "ObjectDecl {%s)" (slist (fun (f,e) -> sprintf "%s : %s" f (loop e)) fl)
|
|
|
- | TArrayDecl el ->
|
|
|
- sprintf "ArrayDecl [%s]" (slist loop el)
|
|
|
+ List.iter (fun (_,e) -> f e) fl
|
|
|
| TCall (e,el) ->
|
|
|
- sprintf "Call %s(%s)" (loop e) (slist loop el)
|
|
|
- | TNew (c,pl,el) ->
|
|
|
- sprintf "New %s%s(%s)" (s_type_path c.cl_path) (match pl with [] -> "" | l -> sprintf "<%s>" (slist s_type l)) (slist loop el)
|
|
|
- | TUnop (op,f,e) ->
|
|
|
- (match f with
|
|
|
- | Prefix -> sprintf "(%s %s)" (s_unop op) (loop e)
|
|
|
- | Postfix -> sprintf "(%s %s)" (loop e) (s_unop op))
|
|
|
- | TFunction f ->
|
|
|
- let args = slist (fun (v,o) -> sprintf "%s : %s%s" (s_var v) (s_type v.v_type) (match o with None -> "" | Some c -> " = " ^ s_const c)) f.tf_args in
|
|
|
- sprintf "Function(%s) : %s = %s" args (s_type f.tf_type) (loop f.tf_expr)
|
|
|
+ f e;
|
|
|
+ List.iter f el
|
|
|
| TVar (v,eo) ->
|
|
|
- sprintf "Vars %s" (sprintf "%s : %s%s" (s_var v) (s_type v.v_type) (match eo with None -> "" | Some e -> " = " ^ loop e))
|
|
|
- | TBlock el ->
|
|
|
- sprintf "Block {\n%s}" (String.concat "" (List.map (fun e -> sprintf "%s;\n" (loop e)) el))
|
|
|
- | TFor (v,econd,e) ->
|
|
|
- sprintf "For (%s : %s in %s,%s)" (s_var v) (s_type v.v_type) (loop econd) (loop e)
|
|
|
+ (match eo with None -> () | Some e -> f e)
|
|
|
+ | TFunction fu ->
|
|
|
+ f fu.tf_expr
|
|
|
| TIf (e,e1,e2) ->
|
|
|
- sprintf "If (%s,%s%s)" (loop e) (loop e1) (match e2 with None -> "" | Some e -> "," ^ loop e)
|
|
|
- | TWhile (econd,e,flag) ->
|
|
|
- (match flag with
|
|
|
- | NormalWhile -> sprintf "While (%s,%s)" (loop econd) (loop e)
|
|
|
- | DoWhile -> sprintf "DoWhile (%s,%s)" (loop e) (loop econd))
|
|
|
+ f e;
|
|
|
+ f e1;
|
|
|
+ (match e2 with None -> () | Some e -> f e)
|
|
|
| TSwitch (e,cases,def) ->
|
|
|
- sprintf "Switch (%s,(%s)%s)" (loop e) (slist (fun (cl,e) -> sprintf "case %s: %s" (slist loop cl) (loop e)) cases) (match def with None -> "" | Some e -> "," ^ loop e)
|
|
|
- | TPatMatch dt -> s_dt "" (dt.dt_dt_lookup.(dt.dt_first))
|
|
|
- | TTry (e,cl) ->
|
|
|
- sprintf "Try %s(%s) " (loop e) (slist (fun (v,e) -> sprintf "catch( %s : %s ) %s" (s_var v) (s_type v.v_type) (loop e)) cl)
|
|
|
- | TReturn None ->
|
|
|
- "Return"
|
|
|
- | TReturn (Some e) ->
|
|
|
- sprintf "Return %s" (loop e)
|
|
|
- | TBreak ->
|
|
|
- "Break"
|
|
|
- | TContinue ->
|
|
|
- "Continue"
|
|
|
- | TThrow e ->
|
|
|
- "Throw " ^ (loop e)
|
|
|
- | TCast (e,t) ->
|
|
|
- sprintf "Cast %s%s" (match t with None -> "" | Some t -> s_type_path (t_path t) ^ ": ") (loop e)
|
|
|
- | TMeta ((n,el,_),e) ->
|
|
|
- sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
|
|
|
- ) in
|
|
|
- sprintf "(%s : %s)" str (s_type e.etype)
|
|
|
+ f e;
|
|
|
+ List.iter (fun (el,e2) -> List.iter f el; f e2) cases;
|
|
|
+ (match def with None -> () | Some e -> f e)
|
|
|
+ | TPatMatch dt ->
|
|
|
+ let rec loop dt = match dt with
|
|
|
+ | DTBind(_,dt) -> loop dt
|
|
|
+ | DTGoto _ -> ()
|
|
|
+ | DTSwitch(e,cl,dto) ->
|
|
|
+ f e;
|
|
|
+ List.iter (fun (e,dt) ->
|
|
|
+ f e;
|
|
|
+ loop dt
|
|
|
+ ) cl;
|
|
|
+ (match dto with None -> () | Some dt -> loop dt)
|
|
|
+ | DTExpr e -> f e
|
|
|
+ | DTGuard(eg,dt1,dt2) ->
|
|
|
+ f eg;
|
|
|
+ loop dt1;
|
|
|
+ (match dt2 with None -> () | Some dt -> loop dt)
|
|
|
+ in
|
|
|
+ List.iter (fun (_,eo) -> match eo with None -> () | Some e -> f e) dt.dt_var_init;
|
|
|
+ Array.iter loop dt.dt_dt_lookup
|
|
|
+ | TTry (e,catches) ->
|
|
|
+ f e;
|
|
|
+ List.iter (fun (_,e) -> f e) catches
|
|
|
+ | TReturn eo ->
|
|
|
+ (match eo with None -> () | Some e -> f e)
|
|
|
|
|
|
-and s_dt tabs tree =
|
|
|
- let s_type = s_type (print_context()) in
|
|
|
- tabs ^ match tree with
|
|
|
- | DTSwitch (st,cl,dto) ->
|
|
|
- "switch(" ^ (s_expr s_type st) ^ ") { \n" ^ tabs
|
|
|
- ^ (String.concat ("\n" ^ tabs) (List.map (fun (c,dt) ->
|
|
|
- "case " ^ (s_expr s_type c) ^ ":\n" ^ (s_dt (tabs ^ "\t") dt)
|
|
|
- ) cl))
|
|
|
- ^ (match dto with None -> "" | Some dt -> tabs ^ "default: " ^ (s_dt (tabs ^ "\t") dt))
|
|
|
- ^ "\n" ^ (if String.length tabs = 0 then "" else (String.sub tabs 0 (String.length tabs - 1))) ^ "}"
|
|
|
- | DTBind (bl, dt) -> "bind " ^ (String.concat "," (List.map (fun ((v,_),st) -> v.v_name ^ "(" ^ (string_of_int v.v_id) ^ ") =" ^ (s_expr s_type st)) bl)) ^ "\n" ^ (s_dt tabs dt)
|
|
|
- | DTGoto i ->
|
|
|
- "goto " ^ (string_of_int i)
|
|
|
- | DTExpr e -> s_expr s_type e
|
|
|
- | DTGuard (e,dt1,dt2) -> "if(" ^ (s_expr s_type e) ^ ") " ^ (s_dt tabs dt1) ^ (match dt2 with None -> "" | Some dt -> " else " ^ (s_dt tabs dt))
|
|
|
+let map_expr f e =
|
|
|
+ match e.eexpr with
|
|
|
+ | TConst _
|
|
|
+ | TLocal _
|
|
|
+ | TBreak
|
|
|
+ | TContinue
|
|
|
+ | TTypeExpr _ ->
|
|
|
+ e
|
|
|
+ | TArray (e1,e2) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TArray (e1,f e2) }
|
|
|
+ | TBinop (op,e1,e2) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TBinop (op,e1,f e2) }
|
|
|
+ | TFor (v,e1,e2) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TFor (v,e1,f e2) }
|
|
|
+ | TWhile (e1,e2,flag) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TWhile (e1,f e2,flag) }
|
|
|
+ | TThrow e1 ->
|
|
|
+ { e with eexpr = TThrow (f e1) }
|
|
|
+ | TEnumParameter (e1,ef,i) ->
|
|
|
+ { e with eexpr = TEnumParameter(f e1,ef,i) }
|
|
|
+ | TField (e1,v) ->
|
|
|
+ { e with eexpr = TField (f e1,v) }
|
|
|
+ | TParenthesis e1 ->
|
|
|
+ { e with eexpr = TParenthesis (f e1) }
|
|
|
+ | TUnop (op,pre,e1) ->
|
|
|
+ { e with eexpr = TUnop (op,pre,f e1) }
|
|
|
+ | TArrayDecl el ->
|
|
|
+ { e with eexpr = TArrayDecl (List.map f el) }
|
|
|
+ | TNew (t,pl,el) ->
|
|
|
+ { e with eexpr = TNew (t,pl,List.map f el) }
|
|
|
+ | TBlock el ->
|
|
|
+ { e with eexpr = TBlock (List.map f el) }
|
|
|
+ | TObjectDecl el ->
|
|
|
+ { e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el) }
|
|
|
+ | TCall (e1,el) ->
|
|
|
+ { e with eexpr = TCall (f e1, List.map f el) }
|
|
|
+ | TVar (v,eo) ->
|
|
|
+ { e with eexpr = TVar (v, match eo with None -> None | Some e -> Some (f e)) }
|
|
|
+ | TFunction fu ->
|
|
|
+ { e with eexpr = TFunction { fu with tf_expr = f fu.tf_expr } }
|
|
|
+ | TIf (ec,e1,e2) ->
|
|
|
+ let ec = f ec in
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TIf (ec,e1,match e2 with None -> None | Some e -> Some (f e)) }
|
|
|
+ | TSwitch (e1,cases,def) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ let cases = List.map (fun (el,e2) -> List.map f el, f e2) cases in
|
|
|
+ { e with eexpr = TSwitch (e1, cases, match def with None -> None | Some e -> Some (f e)) }
|
|
|
+ | TPatMatch dt ->
|
|
|
+ let rec loop dt = match dt with
|
|
|
+ | DTBind(vl,dt) -> DTBind(vl, loop dt)
|
|
|
+ | DTGoto _ -> dt
|
|
|
+ | DTSwitch(e,cl,dto) -> DTSwitch(f e, List.map (fun (e,dt) -> f e,loop dt) cl,match dto with None -> None | Some dt -> Some (loop dt))
|
|
|
+ | DTExpr e -> DTExpr(f e)
|
|
|
+ | DTGuard(e,dt1,dt2) -> DTGuard(f e,loop dt1,match dt2 with None -> None | Some dt -> Some (loop dt))
|
|
|
+ in
|
|
|
+ let vi = List.map (fun (v,eo) -> v, match eo with None -> None | Some e -> Some(f e)) dt.dt_var_init in
|
|
|
+ { e with eexpr = TPatMatch({dt with dt_dt_lookup = Array.map loop dt.dt_dt_lookup; dt_var_init = vi})}
|
|
|
+ | TTry (e1,catches) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TTry (e1, List.map (fun (v,e) -> v, f e) catches) }
|
|
|
+ | TReturn eo ->
|
|
|
+ { e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)) }
|
|
|
+ | TCast (e1,t) ->
|
|
|
+ { e with eexpr = TCast (f e1,t) }
|
|
|
+ | TMeta (m,e1) ->
|
|
|
+ {e with eexpr = TMeta(m,f e1)}
|
|
|
|
|
|
-let rec s_expr_pretty tabs s_type e =
|
|
|
- let sprintf = Printf.sprintf in
|
|
|
- let loop = s_expr_pretty tabs s_type in
|
|
|
- let slist f l = String.concat "," (List.map f l) in
|
|
|
+let map_expr_type f ft fv e =
|
|
|
match e.eexpr with
|
|
|
- | TConst c -> s_const c
|
|
|
- | TLocal v -> v.v_name
|
|
|
- | TArray (e1,e2) -> sprintf "%s[%s]" (loop e1) (loop e2)
|
|
|
- | TBinop (op,e1,e2) -> sprintf "%s %s %s" (loop e1) (s_binop op) (loop e2)
|
|
|
- | TEnumParameter (e1,_,i) -> sprintf "%s[%i]" (loop e1) i
|
|
|
- | TField (e1,s) -> sprintf "%s.%s" (loop e1) (field_name s)
|
|
|
- | TTypeExpr mt -> (s_type_path (t_path mt))
|
|
|
- | TParenthesis e1 -> sprintf "(%s)" (loop e1)
|
|
|
- | TObjectDecl fl -> sprintf "{%s}" (slist (fun (f,e) -> sprintf "%s : %s" f (loop e)) fl)
|
|
|
- | TArrayDecl el -> sprintf "[%s]" (slist loop el)
|
|
|
- | TCall (e1,el) -> sprintf "%s(%s)" (loop e1) (slist loop el)
|
|
|
+ | TConst _
|
|
|
+ | TBreak
|
|
|
+ | TContinue
|
|
|
+ | TTypeExpr _ ->
|
|
|
+ { e with etype = ft e.etype }
|
|
|
+ | TLocal v ->
|
|
|
+ { e with eexpr = TLocal (fv v); etype = ft e.etype }
|
|
|
+ | TArray (e1,e2) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TArray (e1,f e2); etype = ft e.etype }
|
|
|
+ | TBinop (op,e1,e2) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TBinop (op,e1,f e2); etype = ft e.etype }
|
|
|
+ | TFor (v,e1,e2) ->
|
|
|
+ let v = fv v in
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TFor (v,e1,f e2); etype = ft e.etype }
|
|
|
+ | TWhile (e1,e2,flag) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TWhile (e1,f e2,flag); etype = ft e.etype }
|
|
|
+ | TThrow e1 ->
|
|
|
+ { e with eexpr = TThrow (f e1); etype = ft e.etype }
|
|
|
+ | TEnumParameter (e1,ef,i) ->
|
|
|
+ { e with eexpr = TEnumParameter(f e1,ef,i); etype = ft e.etype }
|
|
|
+ | TField (e1,v) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ let v = try
|
|
|
+ let n = match v with
|
|
|
+ | FClosure _ -> raise Not_found
|
|
|
+ | FAnon f | FInstance (_,f) | FStatic (_,f) -> f.cf_name
|
|
|
+ | FEnum (_,f) -> f.ef_name
|
|
|
+ | FDynamic n -> n
|
|
|
+ in
|
|
|
+ quick_field e1.etype n
|
|
|
+ with Not_found ->
|
|
|
+ v
|
|
|
+ in
|
|
|
+ { e with eexpr = TField (e1,v); etype = ft e.etype }
|
|
|
+ | TParenthesis e1 ->
|
|
|
+ { e with eexpr = TParenthesis (f e1); etype = ft e.etype }
|
|
|
+ | TUnop (op,pre,e1) ->
|
|
|
+ { e with eexpr = TUnop (op,pre,f e1); etype = ft e.etype }
|
|
|
+ | TArrayDecl el ->
|
|
|
+ { e with eexpr = TArrayDecl (List.map f el); etype = ft e.etype }
|
|
|
| TNew (c,pl,el) ->
|
|
|
- sprintf "new %s(%s)" (s_type_path c.cl_path) (slist loop el)
|
|
|
- | TUnop (op,f,e) ->
|
|
|
- (match f with
|
|
|
- | Prefix -> sprintf "%s %s" (s_unop op) (loop e)
|
|
|
- | Postfix -> sprintf "%s %s" (loop e) (s_unop op))
|
|
|
- | TFunction f ->
|
|
|
- let args = slist (fun (v,o) -> sprintf "%s:%s%s" v.v_name (s_type v.v_type) (match o with None -> "" | Some c -> " = " ^ s_const c)) f.tf_args in
|
|
|
- sprintf "function(%s) = %s" args (loop f.tf_expr)
|
|
|
- | TVar (v,eo) ->
|
|
|
- sprintf "var %s" (sprintf "%s%s" v.v_name (match eo with None -> "" | Some e -> " = " ^ loop e))
|
|
|
+ let et = ft e.etype in
|
|
|
+ (* make sure that we use the class corresponding to the replaced type *)
|
|
|
+ let t = match c.cl_kind with
|
|
|
+ | KTypeParameter _ | KGeneric ->
|
|
|
+ et
|
|
|
+ | _ ->
|
|
|
+ ft (TInst(c,pl))
|
|
|
+ in
|
|
|
+ let c, pl = (match follow t with TInst (c,pl) -> (c,pl) | TAbstract({a_impl = Some c},pl) -> c,pl | t -> error [has_no_field t "new"]) in
|
|
|
+ { e with eexpr = TNew (c,pl,List.map f el); etype = et }
|
|
|
| TBlock el ->
|
|
|
- let ntabs = tabs ^ "\t" in
|
|
|
- let s = sprintf "{\n%s" (String.concat "" (List.map (fun e -> sprintf "%s%s;\n" ntabs (s_expr_pretty ntabs s_type e)) el)) in
|
|
|
- s ^ tabs ^ "}"
|
|
|
- | TFor (v,econd,e) ->
|
|
|
- sprintf "for (%s in %s) %s" v.v_name (loop econd) (loop e)
|
|
|
- | TIf (e,e1,e2) ->
|
|
|
- sprintf "if (%s)%s%s" (loop e) (loop e1) (match e2 with None -> "" | Some e -> " else " ^ loop e)
|
|
|
- | TWhile (econd,e,flag) ->
|
|
|
- (match flag with
|
|
|
- | NormalWhile -> sprintf "while (%s) %s" (loop econd) (loop e)
|
|
|
- | DoWhile -> sprintf "do (%s) while(%s)" (loop e) (loop econd))
|
|
|
- | TSwitch (e,cases,def) ->
|
|
|
- let ntabs = tabs ^ "\t" in
|
|
|
- let s = sprintf "switch (%s) {\n%s%s" (loop e) (slist (fun (cl,e) -> sprintf "%scase %s: %s\n" ntabs (slist loop cl) (s_expr_pretty ntabs s_type e)) cases) (match def with None -> "" | Some e -> ntabs ^ "default: " ^ (s_expr_pretty ntabs s_type e) ^ "\n") in
|
|
|
- s ^ tabs ^ "}"
|
|
|
- | TPatMatch dt -> s_dt tabs (dt.dt_dt_lookup.(dt.dt_first))
|
|
|
- | TTry (e,cl) ->
|
|
|
- sprintf "try %s%s" (loop e) (slist (fun (v,e) -> sprintf "catch( %s : %s ) %s" v.v_name (s_type v.v_type) (loop e)) cl)
|
|
|
- | TReturn None ->
|
|
|
- "return"
|
|
|
- | TReturn (Some e) ->
|
|
|
- sprintf "return %s" (loop e)
|
|
|
- | TBreak ->
|
|
|
- "break"
|
|
|
- | TContinue ->
|
|
|
- "continue"
|
|
|
- | TThrow e ->
|
|
|
- "throw " ^ (loop e)
|
|
|
- | TCast (e,None) ->
|
|
|
- sprintf "cast %s" (loop e)
|
|
|
- | TCast (e,Some mt) ->
|
|
|
- sprintf "cast (%s,%s)" (loop e) (s_type_path (t_path mt))
|
|
|
- | TMeta ((n,el,_),e) ->
|
|
|
- sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
|
|
|
+ { e with eexpr = TBlock (List.map f el); etype = ft e.etype }
|
|
|
+ | TObjectDecl el ->
|
|
|
+ { e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el); etype = ft e.etype }
|
|
|
+ | TCall (e1,el) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TCall (e1, List.map f el); etype = ft e.etype }
|
|
|
+ | TVar (v,eo) ->
|
|
|
+ { e with eexpr = TVar (fv v, match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }
|
|
|
+ | TFunction fu ->
|
|
|
+ let fu = {
|
|
|
+ tf_expr = f fu.tf_expr;
|
|
|
+ tf_args = List.map (fun (v,o) -> fv v, o) fu.tf_args;
|
|
|
+ tf_type = ft fu.tf_type;
|
|
|
+ } in
|
|
|
+ { e with eexpr = TFunction fu; etype = ft e.etype }
|
|
|
+ | TIf (ec,e1,e2) ->
|
|
|
+ let ec = f ec in
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TIf (ec,e1,match e2 with None -> None | Some e -> Some (f e)); etype = ft e.etype }
|
|
|
+ | TSwitch (e1,cases,def) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ let cases = List.map (fun (el,e2) -> List.map f el, f e2) cases in
|
|
|
+ { e with eexpr = TSwitch (e1, cases, match def with None -> None | Some e -> Some (f e)); etype = ft e.etype }
|
|
|
+ | TPatMatch dt ->
|
|
|
+ let rec loop dt = match dt with
|
|
|
+ | DTBind(vl,dt) -> DTBind(vl, loop dt)
|
|
|
+ | DTGoto _ -> dt
|
|
|
+ | DTSwitch(e,cl,dto) -> DTSwitch(f e, List.map (fun (e,dt) -> f e,loop dt) cl,match dto with None -> None | Some dt -> Some (loop dt))
|
|
|
+ | DTExpr e -> DTExpr(f e)
|
|
|
+ | DTGuard (e,dt1,dt2) -> DTGuard(f e, loop dt, match dt2 with None -> None | Some dt -> Some (loop dt))
|
|
|
+ in
|
|
|
+ let vi = List.map (fun (v,eo) -> v, match eo with None -> None | Some e -> Some(f e)) dt.dt_var_init in
|
|
|
+ { e with eexpr = TPatMatch({dt with dt_dt_lookup = Array.map loop dt.dt_dt_lookup; dt_var_init = vi}); etype = ft e.etype}
|
|
|
+ | TTry (e1,catches) ->
|
|
|
+ let e1 = f e1 in
|
|
|
+ { e with eexpr = TTry (e1, List.map (fun (v,e) -> fv v, f e) catches); etype = ft e.etype }
|
|
|
+ | TReturn eo ->
|
|
|
+ { e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }
|
|
|
+ | TCast (e1,t) ->
|
|
|
+ { e with eexpr = TCast (f e1,t); etype = ft e.etype }
|
|
|
+ | TMeta (m,e1) ->
|
|
|
+ {e with eexpr = TMeta(m, f e1); etype = ft e.etype }
|
|
|
|
|
|
-let s_types ?(sep = ", ") tl =
|
|
|
- let pctx = print_context() in
|
|
|
- String.concat sep (List.map (s_type pctx) tl)
|
|
|
+(* ======= Miscellaneous ======= *)
|
|
|
|
|
|
-let s_class_kind = function
|
|
|
- | KNormal ->
|
|
|
- "KNormal"
|
|
|
- | KTypeParameter tl ->
|
|
|
- Printf.sprintf "KTypeParameter [%s]" (s_types tl)
|
|
|
- | KExtension(c,tl) ->
|
|
|
- Printf.sprintf "KExtension %s<%s>" (s_type_path c.cl_path) (s_types tl)
|
|
|
- | KExpr _ ->
|
|
|
- "KExpr"
|
|
|
- | KGeneric ->
|
|
|
- "KGeneric"
|
|
|
- | KGenericInstance(c,tl) ->
|
|
|
- Printf.sprintf "KGenericInstance %s<%s>" (s_type_path c.cl_path) (s_types tl)
|
|
|
- | KMacroType ->
|
|
|
- "KMacroType"
|
|
|
- | KGenericBuild _ ->
|
|
|
- "KGenericBuild"
|
|
|
- | KAbstractImpl a ->
|
|
|
- Printf.sprintf "KAbstractImpl %s" (s_type_path a.a_path)
|
|
|
+let find_array_access a pl 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
|
|
|
+ unify tab ta;
|
|
|
+ unify t1 ta1;
|
|
|
+ unify t2 ta2;
|
|
|
+ cf,tf,r
|
|
|
+ with Unify_error _ ->
|
|
|
+ loop cfl
|
|
|
+ end
|
|
|
+ | TFun([(_,_,tab);(_,_,ta1)],r) as tf when not is_set ->
|
|
|
+ begin try
|
|
|
+ unify tab ta;
|
|
|
+ unify t1 ta1;
|
|
|
+ cf,tf,r
|
|
|
+ with Unify_error _ ->
|
|
|
+ loop cfl
|
|
|
+ end
|
|
|
+ | _ -> loop cfl
|
|
|
+ in
|
|
|
+ loop a.a_array
|