|
|
@@ -134,447 +134,6 @@ let escape_res_name name allow_dirs =
|
|
|
else
|
|
|
"-x" ^ (string_of_int (Char.code chr))) name
|
|
|
|
|
|
-(* -------------------------------------------------------------------------- *)
|
|
|
-(* REMOTING PROXYS *)
|
|
|
-
|
|
|
-let extend_remoting ctx c t p async prot =
|
|
|
- if c.cl_super <> None then error "Cannot extend several classes" p;
|
|
|
- (* remove forbidden packages *)
|
|
|
- let rules = ctx.com.package_rules in
|
|
|
- ctx.com.package_rules <- PMap.foldi (fun key r acc -> match r with Forbidden -> acc | _ -> PMap.add key r acc) rules PMap.empty;
|
|
|
- (* parse module *)
|
|
|
- let path = (t.tpackage,t.tname) in
|
|
|
- let new_name = (if async then "Async_" else "Remoting_") ^ t.tname in
|
|
|
- (* check if the proxy already exists *)
|
|
|
- let t = (try
|
|
|
- Typeload.load_type_def ctx p { tpackage = fst path; tname = new_name; tparams = []; tsub = None }
|
|
|
- with
|
|
|
- Error (Module_not_found _,p2) when p == p2 ->
|
|
|
- (* build it *)
|
|
|
- Common.log ctx.com ("Building proxy for " ^ s_type_path path);
|
|
|
- let file, decls = (try
|
|
|
- Typeload.parse_module ctx path p
|
|
|
- with
|
|
|
- | Not_found -> ctx.com.package_rules <- rules; error ("Could not load proxy module " ^ s_type_path path ^ (if fst path = [] then " (try using absolute path)" else "")) p
|
|
|
- | e -> ctx.com.package_rules <- rules; raise e) in
|
|
|
- ctx.com.package_rules <- rules;
|
|
|
- let base_fields = [
|
|
|
- { cff_name = "__cnx"; cff_pos = p; cff_doc = None; cff_meta = []; cff_access = []; cff_kind = FVar (Some (CTPath { tpackage = ["haxe";"remoting"]; tname = if async then "AsyncConnection" else "Connection"; tparams = []; tsub = None }),None) };
|
|
|
- { cff_name = "new"; cff_pos = p; cff_doc = None; cff_meta = []; cff_access = [APublic]; cff_kind = FFun { f_args = ["c",false,None,None]; f_type = None; f_expr = Some (EBinop (OpAssign,(EConst (Ident "__cnx"),p),(EConst (Ident "c"),p)),p); f_params = [] } };
|
|
|
- ] in
|
|
|
- let tvoid = CTPath { tpackage = []; tname = "Void"; tparams = []; tsub = None } in
|
|
|
- let build_field is_public acc f =
|
|
|
- if f.cff_name = "new" then
|
|
|
- acc
|
|
|
- else match f.cff_kind with
|
|
|
- | FFun fd when (is_public || List.mem APublic f.cff_access) && not (List.mem AStatic f.cff_access) ->
|
|
|
- if List.exists (fun (_,_,t,_) -> t = None) fd.f_args then error ("Field " ^ f.cff_name ^ " type is not complete and cannot be used by RemotingProxy") p;
|
|
|
- let eargs = [EArrayDecl (List.map (fun (a,_,_,_) -> (EConst (Ident a),p)) fd.f_args),p] in
|
|
|
- let ftype = (match fd.f_type with Some (CTPath { tpackage = []; tname = "Void" }) -> None | _ -> fd.f_type) in
|
|
|
- let fargs, eargs = if async then match ftype with
|
|
|
- | Some tret -> fd.f_args @ ["__callb",true,Some (CTFunction ([tret],tvoid)),None], eargs @ [EConst (Ident "__callb"),p]
|
|
|
- | _ -> fd.f_args, eargs @ [EConst (Ident "null"),p]
|
|
|
- else
|
|
|
- fd.f_args, eargs
|
|
|
- in
|
|
|
- let id = (EConst (String f.cff_name), p) in
|
|
|
- let id = if prot then id else ECall ((EConst (Ident "__unprotect__"),p),[id]),p in
|
|
|
- let expr = ECall (
|
|
|
- (EField (
|
|
|
- (ECall ((EField ((EConst (Ident "__cnx"),p),"resolve"),p),[id]),p),
|
|
|
- "call")
|
|
|
- ,p),eargs),p
|
|
|
- in
|
|
|
- let expr = if async || ftype = None then expr else (EReturn (Some expr),p) in
|
|
|
- let fd = {
|
|
|
- f_params = fd.f_params;
|
|
|
- f_args = fargs;
|
|
|
- f_type = if async then None else ftype;
|
|
|
- f_expr = Some (EBlock [expr],p);
|
|
|
- } in
|
|
|
- { cff_name = f.cff_name; cff_pos = f.cff_pos; cff_doc = None; cff_meta = []; cff_access = [APublic]; cff_kind = FFun fd } :: acc
|
|
|
- | _ -> acc
|
|
|
- in
|
|
|
- let decls = List.map (fun d ->
|
|
|
- match d with
|
|
|
- | EClass c, p when c.d_name = t.tname ->
|
|
|
- let is_public = List.mem HExtern c.d_flags || List.mem HInterface c.d_flags in
|
|
|
- let fields = List.rev (List.fold_left (build_field is_public) base_fields c.d_data) in
|
|
|
- (EClass { c with d_flags = []; d_name = new_name; d_data = fields },p)
|
|
|
- | _ -> d
|
|
|
- ) decls in
|
|
|
- let m = Typeload.type_module ctx (t.tpackage,new_name) file decls p in
|
|
|
- add_dependency ctx.m.curmod m;
|
|
|
- try
|
|
|
- List.find (fun tdecl -> snd (t_path tdecl) = new_name) m.m_types
|
|
|
- with Not_found ->
|
|
|
- error ("Module " ^ s_type_path path ^ " does not define type " ^ t.tname) p
|
|
|
- ) in
|
|
|
- match t with
|
|
|
- | TClassDecl c2 when c2.cl_params = [] -> ignore(c2.cl_build()); c.cl_super <- Some (c2,[]);
|
|
|
- | _ -> error "Remoting proxy must be a class without parameters" p
|
|
|
-
|
|
|
-(* -------------------------------------------------------------------------- *)
|
|
|
-(* HAXE.RTTI.GENERIC *)
|
|
|
-
|
|
|
-exception Generic_Exception of string * Ast.pos
|
|
|
-
|
|
|
-type generic_context = {
|
|
|
- ctx : typer;
|
|
|
- subst : (t * t) list;
|
|
|
- name : string;
|
|
|
- p : pos;
|
|
|
- mutable mg : module_def option;
|
|
|
-}
|
|
|
-
|
|
|
-let make_generic ctx ps pt p =
|
|
|
- let rec loop l1 l2 =
|
|
|
- match l1, l2 with
|
|
|
- | [] , [] -> []
|
|
|
- | (x,TLazy f) :: l1, _ -> loop ((x,(!f)()) :: l1) l2
|
|
|
- | (_,t1) :: l1 , t2 :: l2 -> (t1,t2) :: loop l1 l2
|
|
|
- | _ -> assert false
|
|
|
- in
|
|
|
- let name =
|
|
|
- String.concat "_" (List.map2 (fun (s,_) t ->
|
|
|
- let s_type_path_underscore (p,s) = match p with [] -> s | _ -> String.concat "_" p ^ "_" ^ s in
|
|
|
- let rec loop top t = match follow t with
|
|
|
- | TInst(c,tl) -> (s_type_path_underscore c.cl_path) ^ (loop_tl tl)
|
|
|
- | TEnum(en,tl) -> (s_type_path_underscore en.e_path) ^ (loop_tl tl)
|
|
|
- | TAbstract(a,tl) -> (s_type_path_underscore a.a_path) ^ (loop_tl tl)
|
|
|
- | _ when not top -> "_" (* allow unknown/incompatible types as type parameters to retain old behavior *)
|
|
|
- | TMono _ -> raise (Generic_Exception (("Could not determine type for parameter " ^ s), p))
|
|
|
- | TDynamic _ -> "Dynamic"
|
|
|
- | t -> raise (Generic_Exception (("Type parameter must be a class or enum instance (found " ^ (s_type (print_context()) t) ^ ")"), p))
|
|
|
- and loop_tl tl = match tl with
|
|
|
- | [] -> ""
|
|
|
- | tl -> "_" ^ String.concat "_" (List.map (loop false) tl)
|
|
|
- in
|
|
|
- loop true t
|
|
|
- ) ps pt)
|
|
|
- in
|
|
|
- {
|
|
|
- ctx = ctx;
|
|
|
- subst = loop ps pt;
|
|
|
- name = name;
|
|
|
- p = p;
|
|
|
- mg = None;
|
|
|
- }
|
|
|
-
|
|
|
-let rec generic_substitute_type gctx t =
|
|
|
- match t with
|
|
|
- | TInst ({ cl_kind = KGeneric } as c2,tl2) ->
|
|
|
- (* maybe loop, or generate cascading generics *)
|
|
|
- let _, _, f = gctx.ctx.g.do_build_instance gctx.ctx (TClassDecl c2) gctx.p in
|
|
|
- let t = f (List.map (generic_substitute_type gctx) tl2) in
|
|
|
- (match follow t,gctx.mg with TInst(c,_), Some m -> add_dependency m c.cl_module | _ -> ());
|
|
|
- t
|
|
|
- | _ ->
|
|
|
- try
|
|
|
- generic_substitute_type gctx (List.assq t gctx.subst)
|
|
|
- with Not_found ->
|
|
|
- Type.map (generic_substitute_type gctx) t
|
|
|
-
|
|
|
-let generic_substitute_expr gctx e =
|
|
|
- let vars = Hashtbl.create 0 in
|
|
|
- let build_var v =
|
|
|
- try
|
|
|
- Hashtbl.find vars v.v_id
|
|
|
- with Not_found ->
|
|
|
- let v2 = alloc_var v.v_name (generic_substitute_type gctx v.v_type) in
|
|
|
- v2.v_meta <- v.v_meta;
|
|
|
- Hashtbl.add vars v.v_id v2;
|
|
|
- v2
|
|
|
- in
|
|
|
- let rec build_expr e =
|
|
|
- match e.eexpr with
|
|
|
- | TField(e1, FInstance({cl_kind = KGeneric} as c,tl,cf)) ->
|
|
|
- let _, _, f = gctx.ctx.g.do_build_instance gctx.ctx (TClassDecl c) gctx.p in
|
|
|
- let t = f (List.map (generic_substitute_type gctx) tl) in
|
|
|
- let fa = try
|
|
|
- quick_field t cf.cf_name
|
|
|
- with Not_found ->
|
|
|
- error (Printf.sprintf "Type %s has no field %s (possible typing order issue)" (s_type (print_context()) t) cf.cf_name) e.epos
|
|
|
- in
|
|
|
- build_expr {e with eexpr = TField(e1,fa)}
|
|
|
- | TTypeExpr (TClassDecl ({cl_kind = KTypeParameter _;} as c)) when Meta.has Meta.Const c.cl_meta ->
|
|
|
- let rec loop subst = match subst with
|
|
|
- | (t1,t2) :: subst ->
|
|
|
- begin match follow t1 with
|
|
|
- | TInst(c2,_) when c == c2 -> t2
|
|
|
- | _ -> loop subst
|
|
|
- end
|
|
|
- | [] -> raise Not_found
|
|
|
- in
|
|
|
- begin try
|
|
|
- let t = loop gctx.subst in
|
|
|
- begin match follow t with
|
|
|
- | TInst({cl_kind = KExpr e},_) -> type_expr gctx.ctx e Value
|
|
|
- | _ -> error "Only Const type parameters can be used as value" e.epos
|
|
|
- end
|
|
|
- with Not_found ->
|
|
|
- e
|
|
|
- end
|
|
|
- | _ ->
|
|
|
- map_expr_type build_expr (generic_substitute_type gctx) build_var e
|
|
|
- in
|
|
|
- build_expr e
|
|
|
-
|
|
|
-let has_ctor_constraint c = match c.cl_kind with
|
|
|
- | KTypeParameter tl ->
|
|
|
- List.exists (fun t -> match follow t with
|
|
|
- | TAnon a when PMap.mem "new" a.a_fields -> true
|
|
|
- | TAbstract({a_path=["haxe"],"Constructible"},_) -> true
|
|
|
- | _ -> false
|
|
|
- ) tl;
|
|
|
- | _ -> false
|
|
|
-
|
|
|
-let get_short_name =
|
|
|
- let i = ref (-1) in
|
|
|
- (fun () ->
|
|
|
- incr i;
|
|
|
- Printf.sprintf "Hx___short___hx_type_%i" !i
|
|
|
- )
|
|
|
-
|
|
|
-let rec build_generic ctx c p tl =
|
|
|
- let pack = fst c.cl_path in
|
|
|
- let recurse = ref false in
|
|
|
- let rec check_recursive t =
|
|
|
- match follow t with
|
|
|
- | TInst (c2,tl) ->
|
|
|
- (match c2.cl_kind with
|
|
|
- | KTypeParameter tl ->
|
|
|
- if not (Typeload.is_generic_parameter ctx c2) && has_ctor_constraint c2 then
|
|
|
- error "Type parameters with a constructor cannot be used non-generically" p;
|
|
|
- recurse := true
|
|
|
- | _ -> ());
|
|
|
- List.iter check_recursive tl;
|
|
|
- | _ ->
|
|
|
- ()
|
|
|
- in
|
|
|
- List.iter check_recursive tl;
|
|
|
- if !recurse then begin
|
|
|
- TInst (c,tl) (* build a normal instance *)
|
|
|
- end else begin
|
|
|
- let gctx = make_generic ctx c.cl_params tl p in
|
|
|
- let name = (snd c.cl_path) ^ "_" ^ gctx.name in
|
|
|
- try
|
|
|
- Typeload.load_instance ctx { tpackage = pack; tname = name; tparams = []; tsub = None } p false
|
|
|
- with Error(Module_not_found path,_) when path = (pack,name) ->
|
|
|
- let m = (try Hashtbl.find ctx.g.modules (Hashtbl.find ctx.g.types_module c.cl_path) with Not_found -> assert false) in
|
|
|
- let ctx = { ctx with m = { ctx.m with module_types = m.m_types @ ctx.m.module_types } } in
|
|
|
- ignore(c.cl_build()); (* make sure the super class is already setup *)
|
|
|
- let mg = {
|
|
|
- m_id = alloc_mid();
|
|
|
- m_path = (pack,name);
|
|
|
- m_types = [];
|
|
|
- m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake;
|
|
|
- } in
|
|
|
- gctx.mg <- Some mg;
|
|
|
- let cg = mk_class mg (pack,name) c.cl_pos in
|
|
|
- mg.m_types <- [TClassDecl cg];
|
|
|
- Hashtbl.add ctx.g.modules mg.m_path mg;
|
|
|
- add_dependency mg m;
|
|
|
- add_dependency ctx.m.curmod mg;
|
|
|
- (* ensure that type parameters are set in dependencies *)
|
|
|
- let dep_stack = ref [] in
|
|
|
- let rec loop t =
|
|
|
- if not (List.memq t !dep_stack) then begin
|
|
|
- dep_stack := t :: !dep_stack;
|
|
|
- match t with
|
|
|
- | TInst (c,tl) -> add_dep c.cl_module tl
|
|
|
- | TEnum (e,tl) -> add_dep e.e_module tl
|
|
|
- | TType (t,tl) -> add_dep t.t_module tl
|
|
|
- | TAbstract (a,tl) -> add_dep a.a_module tl
|
|
|
- | TMono r ->
|
|
|
- (match !r with
|
|
|
- | None -> ()
|
|
|
- | Some t -> loop t)
|
|
|
- | TLazy f ->
|
|
|
- loop ((!f)());
|
|
|
- | TDynamic t2 ->
|
|
|
- if t == t2 then () else loop t2
|
|
|
- | TAnon a ->
|
|
|
- PMap.iter (fun _ f -> loop f.cf_type) a.a_fields
|
|
|
- | TFun (args,ret) ->
|
|
|
- List.iter (fun (_,_,t) -> loop t) args;
|
|
|
- loop ret
|
|
|
- end
|
|
|
- and add_dep m tl =
|
|
|
- add_dependency mg m;
|
|
|
- List.iter loop tl
|
|
|
- in
|
|
|
- List.iter loop tl;
|
|
|
- let build_field cf_old =
|
|
|
- (* We have to clone the type parameters (issue #4672). We cannot substitute the constraints immediately because
|
|
|
- we need the full substitution list first. *)
|
|
|
- let param_subst,params = List.fold_left (fun (subst,params) (s,t) -> match follow t with
|
|
|
- | TInst(c,tl) as t ->
|
|
|
- let t2 = TInst({c with cl_pos = c.cl_pos;},tl) in
|
|
|
- (t,t2) :: subst,(s,t2) :: params
|
|
|
- | _ -> assert false
|
|
|
- ) ([],[]) cf_old.cf_params in
|
|
|
- let gctx = {gctx with subst = param_subst @ gctx.subst} in
|
|
|
- let cf_new = {cf_old with cf_pos = cf_old.cf_pos} in (* copy *)
|
|
|
- (* Type parameter constraints are substituted here. *)
|
|
|
- cf_new.cf_params <- List.rev_map (fun (s,t) -> match follow t with
|
|
|
- | TInst({cl_kind = KTypeParameter tl1} as c,_) ->
|
|
|
- let tl1 = List.map (generic_substitute_type gctx) tl1 in
|
|
|
- c.cl_kind <- KTypeParameter tl1;
|
|
|
- s,t
|
|
|
- | _ -> assert false
|
|
|
- ) params;
|
|
|
- let f () =
|
|
|
- let t = generic_substitute_type gctx cf_old.cf_type in
|
|
|
- ignore (follow t);
|
|
|
- begin try (match cf_old.cf_expr with
|
|
|
- | None ->
|
|
|
- begin match cf_old.cf_kind with
|
|
|
- | Method _ when not c.cl_interface && not c.cl_extern ->
|
|
|
- display_error ctx (Printf.sprintf "Field %s has no expression (possible typing order issue)" cf_new.cf_name) cf_new.cf_pos;
|
|
|
- display_error ctx (Printf.sprintf "While building %s" (s_type_path cg.cl_path)) p;
|
|
|
- | _ ->
|
|
|
- ()
|
|
|
- end
|
|
|
- | Some e ->
|
|
|
- cf_new.cf_expr <- Some (generic_substitute_expr gctx e)
|
|
|
- ) with Unify_error l ->
|
|
|
- error (error_msg (Unify l)) cf_new.cf_pos
|
|
|
- end;
|
|
|
- t
|
|
|
- in
|
|
|
- let r = exc_protect ctx (fun r ->
|
|
|
- let t = mk_mono() in
|
|
|
- r := (fun() -> t);
|
|
|
- unify_raise ctx (f()) t p;
|
|
|
- t
|
|
|
- ) "build_generic" in
|
|
|
- delay ctx PForce (fun() -> ignore ((!r)()));
|
|
|
- cf_new.cf_type <- TLazy r;
|
|
|
- cf_new
|
|
|
- in
|
|
|
- if c.cl_init <> None || c.cl_dynamic <> None then error "This class can't be generic" p;
|
|
|
- List.iter (fun cf -> match cf.cf_kind with
|
|
|
- | Method MethMacro when not ctx.in_macro -> ()
|
|
|
- | _ -> error "A generic class can't have static fields" cf.cf_pos
|
|
|
- ) c.cl_ordered_statics;
|
|
|
- cg.cl_super <- (match c.cl_super with
|
|
|
- | None -> None
|
|
|
- | Some (cs,pl) ->
|
|
|
- let find_class subst =
|
|
|
- let rec loop subst = match subst with
|
|
|
- | (TInst(c,[]),t) :: subst when c == cs -> t
|
|
|
- | _ :: subst -> loop subst
|
|
|
- | [] -> raise Not_found
|
|
|
- in
|
|
|
- try
|
|
|
- if pl <> [] then raise Not_found;
|
|
|
- let t = loop subst in
|
|
|
- (* extended type parameter: concrete type must have a constructor, but generic base class must not have one *)
|
|
|
- begin match follow t,c.cl_constructor with
|
|
|
- | TInst(cs,_),None ->
|
|
|
- ignore(cs.cl_build());
|
|
|
- begin match cs.cl_constructor with
|
|
|
- | None -> error ("Cannot use " ^ (s_type_path cs.cl_path) ^ " as type parameter because it is extended and has no constructor") p
|
|
|
- | _ -> ()
|
|
|
- end;
|
|
|
- | _,Some cf -> error "Generics extending type parameters cannot have constructors" cf.cf_pos
|
|
|
- | _ -> ()
|
|
|
- end;
|
|
|
- t
|
|
|
- with Not_found ->
|
|
|
- apply_params c.cl_params tl (TInst(cs,pl))
|
|
|
- in
|
|
|
- let ts = follow (find_class gctx.subst) in
|
|
|
- let cs,pl = Typeload.Inheritance.check_extends ctx c ts p in
|
|
|
- match cs.cl_kind with
|
|
|
- | KGeneric ->
|
|
|
- (match build_generic ctx cs p pl with
|
|
|
- | TInst (cs,pl) -> Some (cs,pl)
|
|
|
- | _ -> assert false)
|
|
|
- | _ -> Some(cs,pl)
|
|
|
- );
|
|
|
- Typeload.add_constructor ctx cg false p;
|
|
|
- cg.cl_kind <- KGenericInstance (c,tl);
|
|
|
- cg.cl_meta <- (Meta.NoDoc,[],p) :: cg.cl_meta;
|
|
|
- if has_meta Meta.Keep c.cl_meta then cg.cl_meta <- (Meta.Keep,[],p) :: cg.cl_meta;
|
|
|
- cg.cl_interface <- c.cl_interface;
|
|
|
- cg.cl_constructor <- (match cg.cl_constructor, c.cl_constructor, c.cl_super with
|
|
|
- | _, Some cf, _ -> Some (build_field cf)
|
|
|
- | Some ctor, _, _ -> Some ctor
|
|
|
- | None, None, None -> None
|
|
|
- | _ -> error "Please define a constructor for this class in order to use it as generic" c.cl_pos
|
|
|
- );
|
|
|
- cg.cl_implements <- List.map (fun (i,tl) ->
|
|
|
- (match follow (generic_substitute_type gctx (TInst (i, List.map (generic_substitute_type gctx) tl))) with
|
|
|
- | TInst (i,tl) -> i, tl
|
|
|
- | _ -> assert false)
|
|
|
- ) c.cl_implements;
|
|
|
- cg.cl_ordered_fields <- List.map (fun f ->
|
|
|
- let f = build_field f in
|
|
|
- cg.cl_fields <- PMap.add f.cf_name f cg.cl_fields;
|
|
|
- f
|
|
|
- ) c.cl_ordered_fields;
|
|
|
- cg.cl_overrides <- List.map (fun f ->
|
|
|
- try PMap.find f.cf_name cg.cl_fields with Not_found -> assert false
|
|
|
- ) c.cl_overrides;
|
|
|
- (* In rare cases the class name can become too long, so let's shorten it (issue #3090). *)
|
|
|
- if String.length (snd cg.cl_path) > 254 then begin
|
|
|
- let n = get_short_name () in
|
|
|
- cg.cl_meta <- (Meta.Native,[EConst(String (n)),p],p) :: cg.cl_meta;
|
|
|
- end;
|
|
|
- TInst (cg,[])
|
|
|
- end
|
|
|
-
|
|
|
-(* -------------------------------------------------------------------------- *)
|
|
|
-(* HAXE.XML.PROXY *)
|
|
|
-
|
|
|
-let extend_xml_proxy ctx c t file p =
|
|
|
- let t = Typeload.load_complex_type ctx p t in
|
|
|
- let file = (try Common.find_file ctx.com file with Not_found -> file) in
|
|
|
- add_dependency c.cl_module (create_fake_module ctx file);
|
|
|
- let used = ref PMap.empty in
|
|
|
- let print_results() =
|
|
|
- PMap.iter (fun id used ->
|
|
|
- if not used then ctx.com.warning (id ^ " is not used") p;
|
|
|
- ) (!used)
|
|
|
- in
|
|
|
- let check_used = Common.defined ctx.com Define.CheckXmlProxy in
|
|
|
- if check_used then ctx.g.hook_generate <- print_results :: ctx.g.hook_generate;
|
|
|
- try
|
|
|
- let rec loop = function
|
|
|
- | Xml.Element (_,attrs,childs) ->
|
|
|
- (try
|
|
|
- let id = List.assoc "id" attrs in
|
|
|
- if PMap.mem id c.cl_fields then error ("Duplicate id " ^ id) p;
|
|
|
- let t = if not check_used then t else begin
|
|
|
- used := PMap.add id false (!used);
|
|
|
- let ft() = used := PMap.add id true (!used); t in
|
|
|
- TLazy (ref ft)
|
|
|
- end in
|
|
|
- let f = {
|
|
|
- cf_name = id;
|
|
|
- cf_type = t;
|
|
|
- cf_public = true;
|
|
|
- cf_pos = p;
|
|
|
- cf_doc = None;
|
|
|
- cf_meta = no_meta;
|
|
|
- cf_kind = Var { v_read = AccResolve; v_write = AccNo };
|
|
|
- cf_params = [];
|
|
|
- cf_expr = None;
|
|
|
- cf_overloads = [];
|
|
|
- } in
|
|
|
- c.cl_fields <- PMap.add id f c.cl_fields;
|
|
|
- with
|
|
|
- Not_found -> ());
|
|
|
- List.iter loop childs;
|
|
|
- | Xml.PCData _ -> ()
|
|
|
- in
|
|
|
- loop (Xml.parse_file file)
|
|
|
- with
|
|
|
- | Xml.Error e -> error ("XML error " ^ Xml.error e) p
|
|
|
- | Xml.File_not_found f -> error ("XML File not found : " ^ f) p
|
|
|
-
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
(* BUILD META DATA OBJECT *)
|
|
|
|
|
|
@@ -617,127 +176,6 @@ let build_metadata com t =
|
|
|
let meta_obj = (try ("obj", make_meta_field (List.assoc "" meta)) :: meta_obj with Not_found -> meta_obj) in
|
|
|
Some (mk (TObjectDecl meta_obj) t_dynamic p)
|
|
|
|
|
|
-(* -------------------------------------------------------------------------- *)
|
|
|
-(* MACRO TYPE *)
|
|
|
-
|
|
|
-let get_macro_path ctx e args p =
|
|
|
- let rec loop e =
|
|
|
- match fst e with
|
|
|
- | EField (e,f) -> f :: loop e
|
|
|
- | EConst (Ident i) -> [i]
|
|
|
- | _ -> error "Invalid macro call" p
|
|
|
- in
|
|
|
- let path = match e with
|
|
|
- | (EConst(Ident i)),_ ->
|
|
|
- let path = try
|
|
|
- if not (PMap.mem i ctx.curclass.cl_statics) then raise Not_found;
|
|
|
- ctx.curclass.cl_path
|
|
|
- with Not_found -> try
|
|
|
- (t_infos (fst (PMap.find i ctx.m.module_globals))).mt_path
|
|
|
- with Not_found ->
|
|
|
- error "Invalid macro call" p
|
|
|
- in
|
|
|
- i :: (snd path) :: (fst path)
|
|
|
- | _ ->
|
|
|
- loop e
|
|
|
- in
|
|
|
- (match path with
|
|
|
- | meth :: cl :: path -> (List.rev path,cl), meth, args
|
|
|
- | _ -> error "Invalid macro call" p)
|
|
|
-
|
|
|
-let build_macro_type ctx pl p =
|
|
|
- let path, field, args = (match pl with
|
|
|
- | [TInst ({ cl_kind = KExpr (ECall (e,args),_) },_)]
|
|
|
- | [TInst ({ cl_kind = KExpr (EArrayDecl [ECall (e,args),_],_) },_)] ->
|
|
|
- get_macro_path ctx e args p
|
|
|
- | _ ->
|
|
|
- error "MacroType requires a single expression call parameter" p
|
|
|
- ) in
|
|
|
- let old = ctx.ret in
|
|
|
- let t = (match ctx.g.do_macro ctx MMacroType path field args p with
|
|
|
- | None -> mk_mono()
|
|
|
- | Some _ -> ctx.ret
|
|
|
- ) in
|
|
|
- ctx.ret <- old;
|
|
|
- t
|
|
|
-
|
|
|
-let build_macro_build ctx c pl cfl p =
|
|
|
- let path, field, args = match Meta.get Meta.GenericBuild c.cl_meta with
|
|
|
- | _,[ECall(e,args),_],_ -> get_macro_path ctx e args p
|
|
|
- | _ -> error "genericBuild requires a single expression call parameter" p
|
|
|
- in
|
|
|
- let old = ctx.ret,ctx.g.get_build_infos in
|
|
|
- ctx.g.get_build_infos <- (fun() -> Some (TClassDecl c, pl, cfl));
|
|
|
- let t = (match ctx.g.do_macro ctx MMacroType path field args p with
|
|
|
- | None -> mk_mono()
|
|
|
- | Some _ -> ctx.ret
|
|
|
- ) in
|
|
|
- ctx.ret <- fst old;
|
|
|
- ctx.g.get_build_infos <- snd old;
|
|
|
- t
|
|
|
-
|
|
|
-(* -------------------------------------------------------------------------- *)
|
|
|
-(* API EVENTS *)
|
|
|
-
|
|
|
-let build_instance ctx mtype p =
|
|
|
- match mtype with
|
|
|
- | TClassDecl c ->
|
|
|
- if ctx.pass > PBuildClass then ignore(c.cl_build());
|
|
|
- let build f s =
|
|
|
- let r = exc_protect ctx (fun r ->
|
|
|
- let t = mk_mono() in
|
|
|
- r := (fun() -> t);
|
|
|
- let tf = (f()) in
|
|
|
- unify_raise ctx tf t p;
|
|
|
- link_dynamic t tf;
|
|
|
- t
|
|
|
- ) s in
|
|
|
- delay ctx PForce (fun() -> ignore ((!r)()));
|
|
|
- TLazy r
|
|
|
- in
|
|
|
- let ft = (fun pl ->
|
|
|
- match c.cl_kind with
|
|
|
- | KGeneric ->
|
|
|
- build (fun () -> build_generic ctx c p pl) "build_generic"
|
|
|
- | KMacroType ->
|
|
|
- build (fun () -> build_macro_type ctx pl p) "macro_type"
|
|
|
- | KGenericBuild cfl ->
|
|
|
- build (fun () -> build_macro_build ctx c pl cfl p) "generic_build"
|
|
|
- | _ ->
|
|
|
- TInst (c,pl)
|
|
|
- ) in
|
|
|
- c.cl_params , c.cl_path , ft
|
|
|
- | TEnumDecl e ->
|
|
|
- e.e_params , e.e_path , (fun t -> TEnum (e,t))
|
|
|
- | TTypeDecl t ->
|
|
|
- t.t_params , t.t_path , (fun tl -> TType(t,tl))
|
|
|
- | TAbstractDecl a ->
|
|
|
- a.a_params, a.a_path, (fun tl -> TAbstract(a,tl))
|
|
|
-
|
|
|
-let on_inherit ctx c p (is_extends,tp) =
|
|
|
- if not is_extends then
|
|
|
- true
|
|
|
- else match tp with
|
|
|
- | { tpackage = ["haxe";"remoting"]; tname = "Proxy"; tparams = [TPType(CTPath t)] } ->
|
|
|
- extend_remoting ctx c t p false true;
|
|
|
- false
|
|
|
- | { tpackage = ["haxe";"remoting"]; tname = "AsyncProxy"; tparams = [TPType(CTPath t)] } ->
|
|
|
- extend_remoting ctx c t p true true;
|
|
|
- false
|
|
|
- | { tpackage = ["haxe";"xml"]; tname = "Proxy"; tparams = [TPExpr(EConst (String file),p);TPType t] } ->
|
|
|
- extend_xml_proxy ctx c t file p;
|
|
|
- true
|
|
|
- | _ ->
|
|
|
- true
|
|
|
-
|
|
|
-let push_this ctx e = match e.eexpr with
|
|
|
- | TConst ((TInt _ | TFloat _ | TString _ | TBool _) as ct) ->
|
|
|
- (EConst (tconst_to_const ct),e.epos),fun () -> ()
|
|
|
- | _ ->
|
|
|
- ctx.this_stack <- e :: ctx.this_stack;
|
|
|
- let er = EMeta((Meta.This,[],e.epos), (EConst(Ident "this"),e.epos)),e.epos in
|
|
|
- er,fun () -> ctx.this_stack <- List.tl ctx.this_stack
|
|
|
-
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
(* ABSTRACT CASTS *)
|
|
|
|
Simon Krajewski