typeload.ml 45 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299
  1. (*
  2. * Haxe Compiler
  3. * Copyright (c)2005-2008 Nicolas Cannasse
  4. *
  5. * This program is free software; you can redistribute it and/or modify
  6. * it under the terms of the GNU General Public License as published by
  7. * the Free Software Foundation; either version 2 of the License, or
  8. * (at your option) any later version.
  9. *
  10. * This program is distributed in the hope that it will be useful,
  11. * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13. * GNU General Public License for more details.
  14. *
  15. * You should have received a copy of the GNU General Public License
  16. * along with this program; if not, write to the Free Software
  17. * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18. *)
  19. open Ast
  20. open Type
  21. open Common
  22. open Typecore
  23. (* make sure we don't access metadata at load time *)
  24. let has_meta m (ml:Ast.metadata) =
  25. List.exists (fun(m2,_) -> m = m2) ml
  26. let type_function_param ctx t e opt p =
  27. match e with
  28. | None ->
  29. if opt then ctx.t.tnull t, Some (EConst (Ident "null"),p) else t, None
  30. | Some e ->
  31. t, Some e
  32. let type_static_var ctx t e p =
  33. ctx.in_static <- true;
  34. let e = type_expr ctx e true in
  35. unify ctx e.etype t p;
  36. (* specific case for UInt statics *)
  37. match t with
  38. | TType ({ t_path = ([],"UInt") },[]) -> { e with etype = t }
  39. | _ -> e
  40. let apply_macro ctx path el p =
  41. let cpath, meth = (match List.rev (ExtString.String.nsplit path ".") with
  42. | meth :: name :: pack -> (List.rev pack,name), meth
  43. | _ -> error "Invalid macro path" p
  44. ) in
  45. ctx.g.do_macro ctx cpath meth el p
  46. (** since load_type_def and load_instance are used in PASS2, they should not access the structure of a type **)
  47. (*
  48. load a type or a subtype definition
  49. *)
  50. let rec load_type_def ctx p t =
  51. let no_pack = t.tpackage = [] in
  52. let tname = (match t.tsub with None -> t.tname | Some n -> n) in
  53. try
  54. List.find (fun t2 ->
  55. let tp = t_path t2 in
  56. tp = (t.tpackage,tname) || (no_pack && snd tp = tname)
  57. ) ctx.local_types
  58. with
  59. Not_found ->
  60. let next() =
  61. let m = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in
  62. let tpath = (t.tpackage,tname) in
  63. try
  64. List.find (fun t -> not (t_private t) && t_path t = tpath) m.mtypes
  65. with
  66. Not_found -> raise (Error (Type_not_found (m.mpath,tname),p))
  67. in
  68. let rec loop = function
  69. | [] -> raise Exit
  70. | (_ :: lnext) as l ->
  71. try
  72. load_type_def ctx p { t with tpackage = List.rev l }
  73. with
  74. | Error (Module_not_found _,p2)
  75. | Error (Type_not_found _,p2) when p == p2 -> loop lnext
  76. in
  77. try
  78. if not no_pack then raise Exit;
  79. (match fst ctx.current.mpath with
  80. | [] -> raise Exit
  81. | x :: _ ->
  82. (* this can occur due to haxe remoting : a module can be
  83. already defined in the "js" package and is not allowed
  84. to access the js classes *)
  85. try
  86. (match PMap.find x ctx.com.package_rules with
  87. | Forbidden -> raise Exit
  88. | _ -> ())
  89. with Not_found -> ());
  90. loop (List.rev (fst ctx.current.mpath));
  91. with
  92. Exit -> next()
  93. (* build an instance from a full type *)
  94. let rec load_instance ctx t p allow_no_params =
  95. try
  96. if t.tpackage <> [] || t.tsub <> None then raise Not_found;
  97. let pt = List.assoc t.tname ctx.type_params in
  98. if t.tparams <> [] then error ("Class type parameter " ^ t.tname ^ " can't have parameters") p;
  99. pt
  100. with Not_found ->
  101. let types , path , f = ctx.g.do_build_instance ctx (load_type_def ctx p t) p in
  102. if allow_no_params && t.tparams = [] then
  103. f (List.map (fun (name,t) ->
  104. match follow t with
  105. | TInst (c,_) ->
  106. let t = mk_mono() in
  107. if c.cl_implements <> [] then delay ctx (fun() ->
  108. List.iter (fun (i,tl) -> unify ctx t (TInst(i,tl)) p) c.cl_implements
  109. );
  110. t;
  111. | _ -> assert false
  112. ) types)
  113. else if path = ([],"Dynamic") then
  114. match t.tparams with
  115. | [] -> t_dynamic
  116. | [TPType t] -> TDynamic (load_complex_type ctx p t)
  117. | _ -> error "Too many parameters for Dynamic" p
  118. else begin
  119. if List.length types <> List.length t.tparams then error ("Invalid number of type parameters for " ^ s_type_path path) p;
  120. let tparams = List.map (fun t ->
  121. match t with
  122. | TPConst c ->
  123. let name, const = (match c with
  124. | String s -> "S" ^ s, TString s
  125. | Int i -> "I" ^ i, TInt (Int32.of_string i)
  126. | Float f -> "F" ^ f, TFloat f
  127. | _ -> assert false
  128. ) in
  129. let c = mk_class ([],name) p in
  130. c.cl_kind <- KConstant const;
  131. TInst (c,[])
  132. | TPType t -> load_complex_type ctx p t
  133. ) t.tparams in
  134. let params = List.map2 (fun t (name,t2) ->
  135. let isconst = (match t with TInst ({ cl_kind = KConstant _ },_) -> true | _ -> false) in
  136. if isconst <> (name = "Const") && t != t_dynamic then error (if isconst then "Constant value unexpected here" else "Constant value excepted as type parameter") p;
  137. match follow t2 with
  138. | TInst ({ cl_implements = [] }, []) ->
  139. t
  140. | TInst (c,[]) ->
  141. let r = exc_protect (fun r ->
  142. r := (fun() -> t);
  143. List.iter (fun (i,params) ->
  144. unify ctx t (apply_params types tparams (TInst (i,params))) p
  145. ) c.cl_implements;
  146. t
  147. ) in
  148. delay ctx (fun () -> ignore(!r()));
  149. TLazy r
  150. | _ -> assert false
  151. ) tparams types in
  152. f params
  153. end
  154. (*
  155. build an instance from a complex type
  156. *)
  157. and load_complex_type ctx p t =
  158. match t with
  159. | CTParent t -> load_complex_type ctx p t
  160. | CTPath t -> load_instance ctx t p false
  161. | CTExtend (t,l) ->
  162. (match load_complex_type ctx p (CTAnonymous l) with
  163. | TAnon a ->
  164. let rec loop t =
  165. match follow t with
  166. | TInst (c,tl) ->
  167. let c2 = mk_class (fst c.cl_path,"+" ^ snd c.cl_path) p in
  168. c2.cl_private <- true;
  169. PMap.iter (fun f _ ->
  170. try
  171. ignore(class_field c f);
  172. error ("Cannot redefine field " ^ f) p
  173. with
  174. Not_found -> ()
  175. ) a.a_fields;
  176. (* do NOT tag as extern - for protect *)
  177. c2.cl_kind <- KExtension (c,tl);
  178. c2.cl_super <- Some (c,tl);
  179. c2.cl_fields <- a.a_fields;
  180. TInst (c2,[])
  181. | TMono _ ->
  182. error "Please ensure correct initialization of cascading signatures" p
  183. | TAnon a2 ->
  184. PMap.iter (fun f _ ->
  185. if PMap.mem f a2.a_fields then error ("Cannot redefine field " ^ f) p
  186. ) a.a_fields;
  187. mk_anon (PMap.foldi PMap.add a.a_fields a2.a_fields)
  188. | _ -> error "Cannot only extend classes and anonymous" p
  189. in
  190. loop (load_instance ctx t p false)
  191. | _ -> assert false)
  192. | CTAnonymous l ->
  193. let rec loop acc (n,pub,f,p) =
  194. if PMap.mem n acc then error ("Duplicate field declaration : " ^ n) p;
  195. let t , access = (match f with
  196. | AFVar t ->
  197. load_complex_type ctx p t, Var { v_read = AccNormal; v_write = AccNormal }
  198. | AFFun (tl,t) ->
  199. let t = load_complex_type ctx p t in
  200. let args = List.map (fun (name,o,t) -> name , o, load_complex_type ctx p t) tl in
  201. TFun (args,t), Method MethNormal
  202. | AFProp (t,i1,i2) ->
  203. let access m get =
  204. match m with
  205. | "null" -> AccNo
  206. | "never" -> AccNever
  207. | "default" -> AccNormal
  208. | "dynamic" -> AccCall ((if get then "get_" else "set_") ^ n)
  209. | _ -> AccCall m
  210. in
  211. load_complex_type ctx p t, Var { v_read = access i1 true; v_write = access i2 false }
  212. ) in
  213. PMap.add n {
  214. cf_name = n;
  215. cf_type = t;
  216. cf_public = (match pub with None -> true | Some p -> p);
  217. cf_kind = access;
  218. cf_params = [];
  219. cf_expr = None;
  220. cf_doc = None;
  221. cf_meta = no_meta;
  222. } acc
  223. in
  224. mk_anon (List.fold_left loop PMap.empty l)
  225. | CTFunction (args,r) ->
  226. match args with
  227. | [CTPath { tpackage = []; tparams = []; tname = "Void" }] ->
  228. TFun ([],load_complex_type ctx p r)
  229. | _ ->
  230. TFun (List.map (fun t -> "",false,load_complex_type ctx p t) args,load_complex_type ctx p r)
  231. let hide_types ctx =
  232. let old_locals = ctx.local_types in
  233. let old_type_params = ctx.type_params in
  234. ctx.local_types <- ctx.g.std.mtypes;
  235. ctx.type_params <- [];
  236. (fun() ->
  237. ctx.local_types <- old_locals;
  238. ctx.type_params <- old_type_params;
  239. )
  240. (*
  241. load a type while ignoring the current imports or local types
  242. *)
  243. let load_core_type ctx name =
  244. let show = hide_types ctx in
  245. let t = load_instance ctx { tpackage = []; tname = name; tparams = []; tsub = None; } null_pos false in
  246. show();
  247. t
  248. let t_iterator ctx =
  249. let show = hide_types ctx in
  250. match load_type_def ctx null_pos { tpackage = []; tname = "Iterator"; tparams = []; tsub = None } with
  251. | TTypeDecl t ->
  252. show();
  253. if List.length t.t_types <> 1 then assert false;
  254. let pt = mk_mono() in
  255. apply_params t.t_types [pt] t.t_type, pt
  256. | _ ->
  257. assert false
  258. (*
  259. load either a type t or Null<Unknown> if not defined
  260. *)
  261. let load_type_opt ?(opt=false) ctx p t =
  262. let t = (match t with None -> mk_mono() | Some t -> load_complex_type ctx p t) in
  263. if opt then ctx.t.tnull t else t
  264. (* ---------------------------------------------------------------------- *)
  265. (* Structure check *)
  266. let valid_redefinition ctx f1 t1 f2 t2 =
  267. let valid t1 t2 =
  268. type_eq EqStrict t1 t2;
  269. if is_null t1 <> is_null t2 then raise (Unify_error [Cannot_unify (t1,t2)]);
  270. in
  271. let t1, t2 = (match f1.cf_params, f2.cf_params with
  272. | [], [] -> t1, t2
  273. | l1, l2 when List.length l1 = List.length l2 ->
  274. let monos = List.map (fun _ -> mk_mono()) l1 in
  275. apply_params l1 monos t1, apply_params l2 monos t2
  276. | _ -> t1, t2
  277. ) in
  278. match follow t1, follow t2 with
  279. | TFun (args1,r1) , TFun (args2,r2) when List.length args1 = List.length args2 ->
  280. List.iter2 (fun (n,o1,a1) (_,o2,a2) ->
  281. if o1 <> o2 then raise (Unify_error [Not_matching_optional n]);
  282. valid a1 a2;
  283. ) args1 args2;
  284. valid r1 r2;
  285. | _ , _ ->
  286. (* in case args differs, or if an interface var *)
  287. valid t1 t2
  288. let check_overriding ctx c p () =
  289. match c.cl_super with
  290. | None ->
  291. (match c.cl_overrides with
  292. | [] -> ()
  293. | i :: _ ->
  294. display_error ctx ("Field " ^ i ^ " is declared 'override' but doesn't override any field") p)
  295. | Some (csup,params) ->
  296. PMap.iter (fun i f ->
  297. try
  298. let t , f2 = raw_class_field (fun f -> f.cf_type) csup i in
  299. ignore(follow f.cf_type); (* force evaluation *)
  300. let p = (match f.cf_expr with None -> p | Some e -> e.epos) in
  301. if not (List.mem i c.cl_overrides) then
  302. display_error ctx ("Field " ^ i ^ " should be declared with 'override' since it is inherited from superclass") p
  303. else if f.cf_public <> f2.cf_public then
  304. display_error ctx ("Field " ^ i ^ " has different visibility (public/private) than superclass one") p
  305. else if f2.cf_kind = Method MethInline then
  306. display_error ctx ("Field " ^ i ^ " is inlined and cannot be overridden") p
  307. else if f2.cf_kind <> f.cf_kind then
  308. display_error ctx ("Field " ^ i ^ " has different property access than in superclass") p
  309. else try
  310. let t = apply_params csup.cl_types params t in
  311. valid_redefinition ctx f f.cf_type f2 t
  312. with
  313. Unify_error l ->
  314. display_error ctx ("Field " ^ i ^ " overload parent class with different or incomplete type") p;
  315. display_error ctx (error_msg (Unify l)) p;
  316. with
  317. Not_found ->
  318. if List.mem i c.cl_overrides then display_error ctx ("Field " ^ i ^ " is declared 'override' but doesn't override any field") p
  319. ) c.cl_fields
  320. let class_field_no_interf c i =
  321. try
  322. let f = PMap.find i c.cl_fields in
  323. f.cf_type , f
  324. with Not_found ->
  325. match c.cl_super with
  326. | None ->
  327. raise Not_found
  328. | Some (c,tl) ->
  329. (* rec over class_field *)
  330. let t , f = raw_class_field (fun f -> f.cf_type) c i in
  331. apply_params c.cl_types tl t , f
  332. let rec check_interface ctx c p intf params =
  333. PMap.iter (fun i f ->
  334. try
  335. let t2, f2 = class_field_no_interf c i in
  336. ignore(follow f2.cf_type); (* force evaluation *)
  337. let p = (match f2.cf_expr with None -> p | Some e -> e.epos) in
  338. if f.cf_public && not f2.cf_public then
  339. display_error ctx ("Field " ^ i ^ " should be public as requested by " ^ s_type_path intf.cl_path) p
  340. else if not (unify_kind f2.cf_kind f.cf_kind) then
  341. display_error ctx ("Field " ^ i ^ " has different property access than in " ^ s_type_path intf.cl_path ^ " (" ^ s_kind f2.cf_kind ^ " should be " ^ s_kind f.cf_kind ^ ")") p
  342. else try
  343. valid_redefinition ctx f2 t2 f (apply_params intf.cl_types params f.cf_type)
  344. with
  345. Unify_error l ->
  346. display_error ctx ("Field " ^ i ^ " has different type than in " ^ s_type_path intf.cl_path) p;
  347. display_error ctx (error_msg (Unify l)) p;
  348. with
  349. Not_found ->
  350. if not c.cl_interface then display_error ctx ("Field " ^ i ^ " needed by " ^ s_type_path intf.cl_path ^ " is missing") p
  351. ) intf.cl_fields;
  352. List.iter (fun (i2,p2) ->
  353. check_interface ctx c p i2 (List.map (apply_params intf.cl_types params) p2)
  354. ) intf.cl_implements
  355. let check_interfaces ctx c p () =
  356. match c.cl_path with
  357. | "Proxy" :: _ , _ -> ()
  358. | _ ->
  359. List.iter (fun (intf,params) -> check_interface ctx c p intf params) c.cl_implements
  360. let rec return_flow ctx e =
  361. let error() = display_error ctx "A return is missing here" e.epos; raise Exit in
  362. let return_flow = return_flow ctx in
  363. match e.eexpr with
  364. | TReturn _ | TThrow _ -> ()
  365. | TParenthesis e ->
  366. return_flow e
  367. | TBlock el ->
  368. let rec loop = function
  369. | [] -> error()
  370. | [e] -> return_flow e
  371. | { eexpr = TReturn _ } :: _ | { eexpr = TThrow _ } :: _ -> ()
  372. | _ :: l -> loop l
  373. in
  374. loop el
  375. | TIf (_,e1,Some e2) ->
  376. return_flow e1;
  377. return_flow e2;
  378. | TSwitch (v,cases,Some e) ->
  379. List.iter (fun (_,e) -> return_flow e) cases;
  380. return_flow e
  381. | TSwitch (e,cases,None) when (match follow e.etype with TEnum _ -> true | _ -> false) ->
  382. List.iter (fun (_,e) -> return_flow e) cases;
  383. | TMatch (_,_,cases,def) ->
  384. List.iter (fun (_,_,e) -> return_flow e) cases;
  385. (match def with None -> () | Some e -> return_flow e)
  386. | TTry (e,cases) ->
  387. return_flow e;
  388. List.iter (fun (_,_,e) -> return_flow e) cases;
  389. | _ ->
  390. error()
  391. (* ---------------------------------------------------------------------- *)
  392. (* PASS 1 & 2 : Module and Class Structure *)
  393. let set_heritance ctx c herits p =
  394. let rec loop = function
  395. | HPrivate | HExtern | HInterface ->
  396. ()
  397. | HExtends t ->
  398. if c.cl_super <> None then error "Cannot extend several classes" p;
  399. let t = load_instance ctx t p false in
  400. (match follow t with
  401. | TInst ({ cl_path = [],"Array" },_)
  402. | TInst ({ cl_path = [],"String" },_)
  403. | TInst ({ cl_path = [],"Date" },_)
  404. | TInst ({ cl_path = [],"Xml" },_) when ((not (platform ctx.com Cpp)) && (match c.cl_path with "mt" :: _ , _ -> false | _ -> true)) ->
  405. error "Cannot extend basic class" p;
  406. | TInst (cl,params) ->
  407. if is_parent c cl then error "Recursive class" p;
  408. if c.cl_interface then error "Cannot extend an interface" p;
  409. if cl.cl_interface then error "Cannot extend by using an interface" p;
  410. if Type.has_meta ":final" cl.cl_meta && not (Type.has_meta ":hack" c.cl_meta) then error "Cannot extend a final class" p;
  411. c.cl_super <- Some (cl,params)
  412. | _ -> error "Should extend by using a class" p)
  413. | HImplements t ->
  414. let t = load_instance ctx t p false in
  415. (match follow t with
  416. | TInst ({ cl_path = [],"ArrayAccess"; cl_extern = true; },[t]) ->
  417. if c.cl_array_access <> None then error "Duplicate array access" p;
  418. c.cl_array_access <- Some t
  419. | TInst (cl,params) ->
  420. if is_parent c cl then error "Recursive class" p;
  421. c.cl_implements <- (cl, params) :: c.cl_implements
  422. | TDynamic t ->
  423. if c.cl_dynamic <> None then error "Cannot have several dynamics" p;
  424. c.cl_dynamic <- Some t
  425. | _ -> error "Should implement by using an interface or a class" p)
  426. in
  427. (*
  428. resolve imports before calling build_inheritance, since it requires full paths.
  429. that means that typedefs are not working, but that's a fair limitation
  430. *)
  431. let rec resolve_imports t =
  432. match t.tpackage with
  433. | _ :: _ -> t
  434. | [] ->
  435. try
  436. let lt = List.find (fun lt -> snd (t_path lt) = t.tname) ctx.local_types in
  437. { t with tpackage = fst (t_path lt) }
  438. with
  439. Not_found -> t
  440. in
  441. let herits = List.map (function
  442. | HExtends t -> HExtends (resolve_imports t)
  443. | HImplements t -> HImplements (resolve_imports t)
  444. | h -> h
  445. ) herits in
  446. List.iter loop (List.filter (ctx.g.do_inherit ctx c p) herits)
  447. let type_type_params ctx path p (n,flags) =
  448. let c = mk_class (fst path @ [snd path],n) p in
  449. c.cl_kind <- KTypeParameter;
  450. let t = TInst (c,[]) in
  451. match flags with
  452. | [] -> n, t
  453. | _ ->
  454. let r = exc_protect (fun r ->
  455. r := (fun _ -> t);
  456. set_heritance ctx c (List.map (fun t -> HImplements t) flags) p;
  457. t
  458. ) in
  459. delay ctx (fun () -> ignore(!r()));
  460. n, TLazy r
  461. let type_function ctx args ret static constr f p =
  462. let locals = save_locals ctx in
  463. let fargs = List.map (fun (n,c,t) ->
  464. let c = (match c with
  465. | None -> None
  466. | Some e ->
  467. let p = pos e in
  468. let e = ctx.g.do_optimize ctx (type_expr ctx e true) in
  469. unify ctx e.etype t p;
  470. match e.eexpr with
  471. | TConst c -> Some c
  472. | _ -> error "Parameter default value should be constant" p
  473. ) in
  474. let n = add_local ctx n t in
  475. n, c, t
  476. ) args in
  477. let old_ret = ctx.ret in
  478. let old_static = ctx.in_static in
  479. let old_constr = ctx.in_constructor in
  480. let old_opened = ctx.opened in
  481. ctx.in_static <- static;
  482. ctx.in_constructor <- constr;
  483. ctx.ret <- ret;
  484. ctx.opened <- [];
  485. let e = type_expr ctx f.f_expr false in
  486. let rec loop e =
  487. match e.eexpr with
  488. | TReturn (Some _) -> raise Exit
  489. | TFunction _ -> ()
  490. | _ -> Type.iter loop e
  491. in
  492. let have_ret = (try loop e; false with Exit -> true) in
  493. if have_ret then
  494. (try return_flow ctx e with Exit -> ())
  495. else
  496. unify ctx ret ctx.t.tvoid p;
  497. let rec loop e =
  498. match e.eexpr with
  499. | TCall ({ eexpr = TConst TSuper },_) -> raise Exit
  500. | TFunction _ -> ()
  501. | _ -> Type.iter loop e
  502. in
  503. if constr && (match ctx.curclass.cl_super with None -> false | Some (cl,_) -> cl.cl_constructor <> None) then
  504. (try
  505. loop e;
  506. error "Missing super constructor call" p
  507. with
  508. Exit -> ());
  509. locals();
  510. List.iter (fun r -> r := Closed) ctx.opened;
  511. ctx.ret <- old_ret;
  512. ctx.in_static <- old_static;
  513. ctx.in_constructor <- old_constr;
  514. ctx.opened <- old_opened;
  515. e , fargs
  516. let init_core_api ctx c =
  517. let ctx2 = (match ctx.g.core_api with
  518. | None ->
  519. let com2 = Common.clone ctx.com in
  520. com2.class_path <- ctx.com.std_path;
  521. let ctx2 = ctx.g.do_create com2 in
  522. ctx.g.core_api <- Some ctx2;
  523. ctx2
  524. | Some c ->
  525. c
  526. ) in
  527. let t = load_instance ctx2 { tpackage = fst c.cl_path; tname = snd c.cl_path; tparams = []; tsub = None; } c.cl_pos true in
  528. match t with
  529. | TInst (ccore,_) ->
  530. (match c.cl_doc with
  531. | None -> c.cl_doc <- ccore.cl_doc
  532. | Some _ -> ());
  533. let check_fields fcore fl =
  534. PMap.iter (fun i f ->
  535. if not f.cf_public then () else
  536. let f2 = try PMap.find f.cf_name fl with Not_found -> error ("Missing field " ^ i ^ " required by core type") c.cl_pos in
  537. let p = (match f2.cf_expr with None -> c.cl_pos | Some e -> e.epos) in
  538. (try
  539. type_eq EqCoreType (apply_params ccore.cl_types (List.map snd c.cl_types) f.cf_type) f2.cf_type
  540. with Unify_error l ->
  541. display_error ctx ("Field " ^ i ^ " has different type than in core type") p;
  542. display_error ctx (error_msg (Unify l)) p);
  543. if f2.cf_public <> f.cf_public then error ("Field " ^ i ^ " has different visibility than core type") p;
  544. (match f2.cf_doc with
  545. | None -> f2.cf_doc <- f.cf_doc
  546. | Some _ -> ());
  547. if f2.cf_kind <> f.cf_kind then begin
  548. match f2.cf_kind, f.cf_kind with
  549. | Method MethInline, Method MethNormal -> () (* allow to add 'inline' *)
  550. | _ ->
  551. error ("Field " ^ i ^ " has different property access than core type") p;
  552. end;
  553. (match follow f.cf_type, follow f2.cf_type with
  554. | TFun (pl1,_), TFun (pl2,_) ->
  555. if List.length pl1 != List.length pl2 then assert false;
  556. List.iter2 (fun (n1,_,_) (n2,_,_) ->
  557. if n1 <> n2 then error ("Method parameter name '" ^ n2 ^ "' should be '" ^ n1 ^ "'") p;
  558. ) pl1 pl2;
  559. | _ -> ());
  560. ) fcore;
  561. PMap.iter (fun i f ->
  562. let p = (match f.cf_expr with None -> c.cl_pos | Some e -> e.epos) in
  563. if f.cf_public && not (PMap.mem f.cf_name fcore) then error ("Public field " ^ i ^ " is not part of core type") p;
  564. ) fl;
  565. in
  566. check_fields ccore.cl_fields c.cl_fields;
  567. check_fields ccore.cl_statics c.cl_statics;
  568. | _ -> assert false
  569. let patch_class ctx c fields =
  570. let h = (try Some (Hashtbl.find ctx.g.type_patches c.cl_path) with Not_found -> None) in
  571. match h with
  572. | None -> fields
  573. | Some (h,hcl) ->
  574. c.cl_meta <- c.cl_meta @ hcl.tp_meta;
  575. let rec loop acc = function
  576. | [] -> List.rev acc
  577. | f :: l ->
  578. (* patch arguments types *)
  579. (match f.cff_kind with
  580. | FFun (pl,ff) ->
  581. let param ((n,opt,t,e) as p) =
  582. try n, opt, (Hashtbl.find h (("$" ^ n),false)).tp_type, e with Not_found -> p
  583. in
  584. f.cff_kind <- FFun (pl,{ ff with f_args = List.map param ff.f_args })
  585. | _ -> ());
  586. (* other patches *)
  587. match (try Some (Hashtbl.find h (f.cff_name,List.mem AStatic f.cff_access)) with Not_found -> None) with
  588. | None -> loop (f :: acc) l
  589. | Some { tp_remove = true } -> loop acc l
  590. | Some p ->
  591. f.cff_meta <- f.cff_meta @ p.tp_meta;
  592. (match p.tp_type with
  593. | None -> ()
  594. | Some t ->
  595. f.cff_kind <- match f.cff_kind with
  596. | FVar (_,e) -> FVar (Some t,e)
  597. | FProp (get,set,_) -> FProp (get,set,t)
  598. | FFun (pl,f) -> FFun (pl,{ f with f_type = Some t }));
  599. loop (f :: acc) l
  600. in
  601. List.rev (loop [] fields)
  602. let init_class ctx c p herits fields =
  603. let fields = patch_class ctx c fields in
  604. ctx.type_params <- c.cl_types;
  605. c.cl_extern <- List.mem HExtern herits;
  606. c.cl_interface <- List.mem HInterface herits;
  607. set_heritance ctx c herits p;
  608. let core_api = has_meta ":core_api" c.cl_meta in
  609. let is_macro = has_meta ":macro" c.cl_meta in
  610. let fields, herits = if is_macro && not ctx.in_macro then begin
  611. c.cl_extern <- true;
  612. List.filter (fun f -> List.mem AStatic f.cff_access) fields, []
  613. end else fields, herits in
  614. if core_api then delay ctx ((fun() -> init_core_api ctx c));
  615. let tthis = TInst (c,List.map snd c.cl_types) in
  616. let rec extends_public c =
  617. List.exists (fun (c,_) -> c.cl_path = (["haxe"],"Public") || extends_public c) c.cl_implements ||
  618. match c.cl_super with
  619. | None -> false
  620. | Some (c,_) -> extends_public c
  621. in
  622. let extends_public = extends_public c in
  623. let is_public access parent =
  624. if List.mem APrivate access then
  625. false
  626. else if List.mem APublic access then
  627. true
  628. else match parent with
  629. | Some { cf_public = p } -> p
  630. | _ -> c.cl_extern || c.cl_interface || extends_public
  631. in
  632. let rec get_parent c name =
  633. match c.cl_super with
  634. | None -> None
  635. | Some (csup,_) ->
  636. try
  637. Some (PMap.find name csup.cl_fields)
  638. with
  639. Not_found -> get_parent csup name
  640. in
  641. let type_opt ctx p t =
  642. match t with
  643. | None when c.cl_extern || c.cl_interface ->
  644. display_error ctx "Type required for extern classes and interfaces" p;
  645. t_dynamic
  646. | None when core_api ->
  647. display_error ctx "Type required for core api classes" p;
  648. t_dynamic
  649. | _ ->
  650. load_type_opt ctx p t
  651. in
  652. let rec has_field f = function
  653. | None -> false
  654. | Some (c,_) ->
  655. PMap.exists f c.cl_fields || has_field f c.cl_super || List.exists (fun i -> has_field f (Some i)) c.cl_implements
  656. in
  657. let loop_cf f =
  658. let name = f.cff_name in
  659. let p = f.cff_pos in
  660. let stat = List.mem AStatic f.cff_access in
  661. let inline = List.mem AInline f.cff_access in
  662. match f.cff_kind with
  663. | FVar (t,e) ->
  664. if not stat && has_field name c.cl_super then error ("Redefinition of variable " ^ name ^ " in subclass is not allowed") p;
  665. if inline && not stat then error "Inline variable must be static" p;
  666. if inline && e = None then error "Inline variable must be initialized" p;
  667. let t = (match t with
  668. | None ->
  669. if not stat then display_error ctx ("Type required for member variable " ^ name) p;
  670. mk_mono()
  671. | Some t ->
  672. let old = ctx.type_params in
  673. if stat then ctx.type_params <- [];
  674. let t = load_complex_type ctx p t in
  675. if stat then ctx.type_params <- old;
  676. t
  677. ) in
  678. let cf = {
  679. cf_name = name;
  680. cf_doc = f.cff_doc;
  681. cf_meta = f.cff_meta;
  682. cf_type = t;
  683. cf_kind = Var (if inline then { v_read = AccInline ; v_write = AccNever } else { v_read = AccNormal; v_write = AccNormal });
  684. cf_expr = None;
  685. cf_public = is_public f.cff_access None;
  686. cf_params = [];
  687. } in
  688. let delay = (match e with
  689. | None -> (fun() -> ())
  690. | Some e ->
  691. let ctx = { ctx with curclass = c; tthis = tthis } in
  692. let r = exc_protect (fun r ->
  693. r := (fun() -> t);
  694. if ctx.com.verbose then print_endline ("Typing " ^ s_type_path c.cl_path ^ "." ^ name);
  695. cf.cf_expr <- Some (type_static_var ctx t e p);
  696. t
  697. ) in
  698. cf.cf_type <- TLazy r;
  699. (fun () -> ignore(!r()))
  700. ) in
  701. f, false, cf, delay
  702. | FFun (params,fd) ->
  703. let params = List.map (fun (n,flags) ->
  704. match flags with
  705. | [] ->
  706. type_type_params ctx ([],name) p (n,[])
  707. | _ -> error "This notation is not allowed because it can't be checked" p
  708. ) params in
  709. if inline && c.cl_interface then error "You can't declare inline methods in interfaces" p;
  710. let is_macro = (is_macro && stat) || has_meta ":macro" f.cff_meta in
  711. if is_macro && not stat then error "Only static methods can be macros" p;
  712. let fd = if not is_macro then
  713. fd
  714. else if ctx.in_macro then
  715. let texpr = CTPath { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None } in
  716. {
  717. f_type = (match fd.f_type with None -> Some texpr | t -> t);
  718. f_args = List.map (fun (a,o,t,e) -> a,o,(match t with None -> Some texpr | _ -> t),e) fd.f_args;
  719. f_expr = fd.f_expr;
  720. }
  721. else
  722. let tdyn = Some (CTPath { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None }) in
  723. {
  724. f_type = tdyn;
  725. f_args = List.map (fun (a,o,_,_) -> a,o,tdyn,None) fd.f_args;
  726. f_expr = (EBlock [],p)
  727. }
  728. in
  729. let parent = (if not stat then get_parent c name else None) in
  730. let dynamic = List.mem ADynamic f.cff_access || (match parent with Some { cf_kind = Method MethDynamic } -> true | _ -> false) in
  731. if inline && dynamic then error "You can't have both 'inline' and 'dynamic'" p;
  732. let ctx = { ctx with
  733. curclass = c;
  734. curmethod = name;
  735. tthis = tthis;
  736. type_params = if stat then params else params @ ctx.type_params;
  737. } in
  738. let ret = type_opt ctx p fd.f_type in
  739. let args = List.map (fun (name,opt,t,c) ->
  740. let t, c = type_function_param ctx (type_opt ctx p t) c opt p in
  741. name, c, t
  742. ) fd.f_args in
  743. let t = TFun (fun_args args,ret) in
  744. let constr = (name = "new") in
  745. if constr && c.cl_interface then error "An interface cannot have a constructor" p;
  746. if c.cl_interface && not stat && (match fd.f_expr with EBlock [] , _ -> false | _ -> true) then error "An interface method cannot have a body" p;
  747. if constr then (match fd.f_type with
  748. | None | Some (CTPath { tpackage = []; tname = "Void" }) -> ()
  749. | _ -> error "A class constructor can't have a return value" p
  750. );
  751. let cf = {
  752. cf_name = name;
  753. cf_doc = f.cff_doc;
  754. cf_meta = f.cff_meta;
  755. cf_type = t;
  756. cf_kind = Method (if is_macro then MethMacro else if inline then MethInline else if dynamic then MethDynamic else MethNormal);
  757. cf_expr = None;
  758. cf_public = is_public f.cff_access parent;
  759. cf_params = params;
  760. } in
  761. let r = exc_protect (fun r ->
  762. r := (fun() -> t);
  763. if ctx.com.verbose then print_endline ("Typing " ^ s_type_path c.cl_path ^ "." ^ name);
  764. let e , fargs = type_function ctx args ret stat constr fd p in
  765. let f = {
  766. tf_args = fargs;
  767. tf_type = ret;
  768. tf_expr = e;
  769. } in
  770. if stat && name = "__init__" then
  771. (match e.eexpr with
  772. | TBlock [] | TBlock [{ eexpr = TConst _ }] | TConst _ | TObjectDecl [] -> ()
  773. | _ -> c.cl_init <- Some e);
  774. cf.cf_expr <- Some (mk (TFunction f) t p);
  775. t
  776. ) in
  777. let delay = if (ctx.com.dead_code_removal && not !Common.display) then begin
  778. let is_main = (match ctx.com.main_class with | Some cl when c.cl_path = cl -> true | _ -> false) && name = "main" in
  779. let keep = core_api || is_main || has_meta ":keep" c.cl_meta || has_meta ":keep" f.cff_meta || (stat && name = "__init__") in
  780. let remove item lst = List.filter (fun i -> item <> i.cf_name) lst in
  781. if ((c.cl_extern && not inline) || c.cl_interface) && cf.cf_name <> "__init__" then begin
  782. (fun() -> ())
  783. end else begin
  784. cf.cf_type <- TLazy r;
  785. (fun() ->
  786. if not keep then begin
  787. delay ctx (fun () ->
  788. match cf.cf_expr with
  789. | None ->
  790. if ctx.com.verbose then print_endline ("Removed " ^ (snd c.cl_path) ^ "." ^ name);
  791. if stat then begin
  792. c.cl_statics <- PMap.remove name c.cl_statics;
  793. c.cl_ordered_statics <- remove name c.cl_ordered_statics;
  794. end else begin
  795. if name = "new" then c.cl_constructor <- None;
  796. c.cl_fields <- PMap.remove name c.cl_fields;
  797. c.cl_ordered_fields <- remove name c.cl_ordered_fields;
  798. end
  799. | _ -> ())
  800. end else
  801. ignore((!r)())
  802. )
  803. end
  804. end else begin
  805. if ((c.cl_extern && not inline) || c.cl_interface) && cf.cf_name <> "__init__" then begin
  806. (fun() -> ())
  807. end else begin
  808. cf.cf_type <- TLazy r;
  809. (fun() -> ignore((!r)()))
  810. end
  811. end in
  812. f, constr, cf, delay
  813. | FProp (get,set,t) ->
  814. let ret = load_complex_type ctx p t in
  815. let check_get = ref (fun() -> ()) in
  816. let check_set = ref (fun() -> ()) in
  817. let check_method m t () =
  818. try
  819. let t2 = (if stat then (PMap.find m c.cl_statics).cf_type else fst (class_field c m)) in
  820. unify_raise ctx t2 t p;
  821. with
  822. | Error (Unify l,_) -> raise (Error (Stack (Custom ("In method " ^ m ^ " required by property " ^ name),Unify l),p))
  823. | Not_found -> if not c.cl_interface then error ("Method " ^ m ^ " required by property " ^ name ^ " is missing") p
  824. in
  825. let get = (match get with
  826. | "null" -> AccNo
  827. | "dynamic" -> AccCall ("get_" ^ name)
  828. | "never" -> AccNever
  829. | "default" -> AccNormal
  830. | _ ->
  831. check_get := check_method get (TFun ([],ret));
  832. AccCall get
  833. ) in
  834. let set = (match set with
  835. | "null" ->
  836. (* standard flash library read-only variables can't be accessed for writing, even in subclasses *)
  837. if c.cl_extern && (match c.cl_path with "flash" :: _ , _ -> true | _ -> false) && Common.defined ctx.com "flash9" then
  838. AccNever
  839. else
  840. AccNo
  841. | "never" -> AccNever
  842. | "dynamic" -> AccCall ("set_" ^ name)
  843. | "default" -> AccNormal
  844. | _ ->
  845. check_set := check_method set (TFun (["",false,ret],ret));
  846. AccCall set
  847. ) in
  848. if set = AccNormal && (match get with AccCall _ -> true | _ -> false) then error "Unsupported property combination" p;
  849. let cf = {
  850. cf_name = name;
  851. cf_doc = f.cff_doc;
  852. cf_meta = f.cff_meta;
  853. cf_kind = Var { v_read = get; v_write = set };
  854. cf_expr = None;
  855. cf_type = ret;
  856. cf_public = is_public f.cff_access None;
  857. cf_params = [];
  858. } in
  859. f, false, cf, (fun() -> (!check_get)(); (!check_set)())
  860. in
  861. let rec check_require = function
  862. | [] -> None
  863. | (":require",conds) :: l ->
  864. let rec loop = function
  865. | [] -> check_require l
  866. | (EConst (Ident i | Type i),_) :: l ->
  867. if not (Common.defined ctx.com i) then
  868. Some i
  869. else
  870. loop l
  871. | _ -> error "Invalid require identifier" p
  872. in
  873. loop conds
  874. | _ :: l ->
  875. check_require l
  876. in
  877. let cl_req = check_require c.cl_meta in
  878. let fl = List.map (fun f ->
  879. let fd , constr, f , delayed = loop_cf f in
  880. let is_static = List.mem AStatic fd.cff_access in
  881. if is_static && f.cf_name = "name" && Common.defined ctx.com "js" then error "This identifier cannot be used in Javascript for statics" p;
  882. if (is_static || constr) && c.cl_interface && f.cf_name <> "__init__" then error "You can't declare static fields in interfaces" p;
  883. let req = check_require fd.cff_meta in
  884. let req = (match req with None -> if is_static || constr then cl_req else None | _ -> req) in
  885. (match req with
  886. | None -> ()
  887. | Some r -> f.cf_kind <- Var { v_read = AccRequire r; v_write = AccRequire r });
  888. if constr then begin
  889. if c.cl_constructor <> None then error "Duplicate constructor" p;
  890. c.cl_constructor <- Some f;
  891. end else if not is_static || f.cf_name <> "__init__" then begin
  892. if PMap.mem f.cf_name (if is_static then c.cl_statics else c.cl_fields) then error ("Duplicate class field declaration : " ^ f.cf_name) p;
  893. if PMap.exists f.cf_name (if is_static then c.cl_fields else c.cl_statics) then error ("Same field name can't be use for both static and instance : " ^ f.cf_name) p;
  894. if is_static then begin
  895. c.cl_statics <- PMap.add f.cf_name f c.cl_statics;
  896. c.cl_ordered_statics <- f :: c.cl_ordered_statics;
  897. end else begin
  898. c.cl_fields <- PMap.add f.cf_name f c.cl_fields;
  899. c.cl_ordered_fields <- f :: c.cl_ordered_fields;
  900. if List.mem AOverride fd.cff_access then c.cl_overrides <- f.cf_name :: c.cl_overrides;
  901. end;
  902. end;
  903. delayed
  904. ) fields in
  905. c.cl_ordered_statics <- List.rev c.cl_ordered_statics;
  906. c.cl_ordered_fields <- List.rev c.cl_ordered_fields;
  907. (*
  908. define a default inherited constructor.
  909. This is actually pretty tricky since we can't assume that the constructor of the
  910. superclass has been defined yet because type structure is not stabilized wrt recursion.
  911. *)
  912. let rec define_constructor ctx c =
  913. try
  914. Some (Hashtbl.find ctx.g.constructs c.cl_path)
  915. with Not_found ->
  916. match c.cl_super with
  917. | None -> None
  918. | Some (csuper,_) ->
  919. match define_constructor ctx csuper with
  920. | None -> None
  921. | Some (acc,pl,f) as infos ->
  922. let p = c.cl_pos in
  923. let esuper = (ECall ((EConst (Ident "super"),p),List.map (fun (n,_,_,_) -> (EConst (Ident n),p)) f.f_args),p) in
  924. let acc = (if csuper.cl_extern && acc = [] then [APublic] else acc) in
  925. let fnew = { f with f_expr = esuper; f_args = List.map (fun (a,opt,t,def) ->
  926. (*
  927. we are removing the type and letting the type inference
  928. work because the current package is not the same as the superclass one
  929. or there might be private and/or imported types
  930. if we are an extern class then we need a type
  931. if the type is Dynamic also because it would not propagate
  932. if we have a package declaration, we are sure it's fully qualified
  933. *)
  934. let rec is_qualified = function
  935. | CTPath t -> is_qual_name t
  936. | CTParent t -> is_qualified t
  937. | CTFunction (tl,t) -> List.for_all is_qualified tl && is_qualified t
  938. | CTAnonymous fl -> List.for_all (fun (_,_,f,_) -> is_qual_field f) fl
  939. | CTExtend (t,fl) -> is_qual_name t && List.for_all (fun (_,_,f,_) -> is_qual_field f) fl
  940. and is_qual_field = function
  941. | AFVar t -> is_qualified t
  942. | AFProp (t,_,_) -> is_qualified t
  943. | AFFun (pl,t) -> List.for_all (fun (_,_,t) -> is_qualified t) pl && is_qualified t
  944. and is_qual_name t =
  945. match t.tpackage with
  946. | [] -> t.tname = "Dynamic" && List.for_all is_qual_param t.tparams
  947. | _ :: _ -> true
  948. and is_qual_param = function
  949. | TPType t -> is_qualified t
  950. | TPConst _ -> false (* prevent multiple incompatible types *)
  951. in
  952. let t = (match t with
  953. | Some t when is_qualified t -> Some t
  954. | _ -> None
  955. ) in
  956. a,opt,t,def
  957. ) f.f_args } in
  958. let _, _, cf, delayed = loop_cf { cff_name = "new"; cff_pos = p; cff_doc = None; cff_meta = []; cff_access = acc; cff_kind = FFun (pl,fnew) } in
  959. c.cl_constructor <- Some cf;
  960. Hashtbl.add ctx.g.constructs c.cl_path (acc,pl,f);
  961. delay ctx delayed;
  962. infos
  963. in
  964. (*
  965. extern classes will browse superclass to find a constructor
  966. *)
  967. if not c.cl_extern then ignore(define_constructor ctx c);
  968. fl
  969. let resolve_typedef ctx t =
  970. match t with
  971. | TClassDecl _ | TEnumDecl _ -> t
  972. | TTypeDecl td ->
  973. match follow td.t_type with
  974. | TEnum (e,_) -> TEnumDecl e
  975. | TInst (c,_) -> TClassDecl c
  976. | _ -> t
  977. let type_module ctx m tdecls loadp =
  978. (* PASS 1 : build module structure - does not load any module or type - should be atomic ! *)
  979. let decls = ref [] in
  980. let decl_with_name name p priv =
  981. let tpath = if priv then (fst m @ ["_" ^ snd m], name) else (fst m, name) in
  982. if priv && List.exists (fun t -> tpath = t_path t) (!decls) then error ("Type name " ^ name ^ " is already defined in this module") p;
  983. try
  984. let m2 = Hashtbl.find ctx.g.types_module tpath in
  985. if m <> m2 && String.lowercase (s_type_path m2) = String.lowercase (s_type_path m) then error ("Module " ^ s_type_path m2 ^ " is loaded with a different case than " ^ s_type_path m) loadp;
  986. error ("Type name " ^ s_type_path tpath ^ " is redefined from module " ^ s_type_path m2) p
  987. with
  988. Not_found ->
  989. Hashtbl.add ctx.g.types_module tpath m;
  990. tpath
  991. in
  992. List.iter (fun (d,p) ->
  993. match d with
  994. | EImport _ | EUsing _ -> ()
  995. | EClass d ->
  996. let priv = List.mem HPrivate d.d_flags in
  997. let path = decl_with_name d.d_name p priv in
  998. let c = mk_class path p in
  999. c.cl_private <- priv;
  1000. c.cl_doc <- d.d_doc;
  1001. c.cl_meta <- d.d_meta;
  1002. (* store the constructor for later usage *)
  1003. List.iter (fun cf ->
  1004. match cf with
  1005. | { cff_name = "new"; cff_kind = FFun (pl,f) } -> Hashtbl.add ctx.g.constructs path (cf.cff_access,pl,f)
  1006. | _ -> ()
  1007. ) d.d_data;
  1008. decls := TClassDecl c :: !decls
  1009. | EEnum d ->
  1010. let priv = List.mem EPrivate d.d_flags in
  1011. let path = decl_with_name d.d_name p priv in
  1012. let e = {
  1013. e_path = path;
  1014. e_pos = p;
  1015. e_doc = d.d_doc;
  1016. e_meta = d.d_meta;
  1017. e_types = [];
  1018. e_private = priv;
  1019. e_extern = List.mem EExtern d.d_flags;
  1020. e_constrs = PMap.empty;
  1021. e_names = [];
  1022. } in
  1023. decls := TEnumDecl e :: !decls
  1024. | ETypedef d ->
  1025. let priv = List.mem EPrivate d.d_flags in
  1026. let path = decl_with_name d.d_name p priv in
  1027. let t = {
  1028. t_path = path;
  1029. t_pos = p;
  1030. t_doc = d.d_doc;
  1031. t_private = priv;
  1032. t_types = [];
  1033. t_type = mk_mono();
  1034. t_meta = d.d_meta;
  1035. } in
  1036. decls := TTypeDecl t :: !decls
  1037. ) tdecls;
  1038. let m = {
  1039. mpath = m;
  1040. mtypes = List.rev !decls;
  1041. } in
  1042. Hashtbl.add ctx.g.modules m.mpath m;
  1043. (* PASS 2 : build types structure - does not type any expression ! *)
  1044. let ctx = {
  1045. com = ctx.com;
  1046. g = ctx.g;
  1047. t = ctx.t;
  1048. curclass = ctx.curclass;
  1049. tthis = ctx.tthis;
  1050. ret = ctx.ret;
  1051. current = m;
  1052. locals = PMap.empty;
  1053. locals_map = PMap.empty;
  1054. locals_map_inv = PMap.empty;
  1055. local_types = ctx.g.std.mtypes @ m.mtypes;
  1056. local_using = [];
  1057. type_params = [];
  1058. curmethod = "";
  1059. untyped = false;
  1060. in_super_call = false;
  1061. in_constructor = false;
  1062. in_static = false;
  1063. in_macro = ctx.in_macro;
  1064. in_display = false;
  1065. in_loop = false;
  1066. opened = [];
  1067. param_type = None;
  1068. } in
  1069. let delays = ref [] in
  1070. let get_class name =
  1071. let c = List.find (fun d -> match d with TClassDecl { cl_path = _ , n } -> n = name | _ -> false) m.mtypes in
  1072. match c with TClassDecl c -> c | _ -> assert false
  1073. in
  1074. let get_enum name =
  1075. let e = List.find (fun d -> match d with TEnumDecl { e_path = _ , n } -> n = name | _ -> false) m.mtypes in
  1076. match e with TEnumDecl e -> e | _ -> assert false
  1077. in
  1078. let get_tdef name =
  1079. let s = List.find (fun d -> match d with TTypeDecl { t_path = _ , n } -> n = name | _ -> false) m.mtypes in
  1080. match s with TTypeDecl s -> s | _ -> assert false
  1081. in
  1082. (* here is an additional PASS 1 phase, which handle the type parameters declaration, with lazy contraints *)
  1083. List.iter (fun (d,p) ->
  1084. match d with
  1085. | EImport _ | EUsing _ -> ()
  1086. | EClass d ->
  1087. let c = get_class d.d_name in
  1088. c.cl_types <- List.map (type_type_params ctx c.cl_path p) d.d_params;
  1089. | EEnum d ->
  1090. let e = get_enum d.d_name in
  1091. e.e_types <- List.map (type_type_params ctx e.e_path p) d.d_params;
  1092. | ETypedef d ->
  1093. let t = get_tdef d.d_name in
  1094. t.t_types <- List.map (type_type_params ctx t.t_path p) d.d_params;
  1095. ) tdecls;
  1096. (* back to PASS2 *)
  1097. List.iter (fun (d,p) ->
  1098. match d with
  1099. | EImport t ->
  1100. (match t.tsub with
  1101. | None ->
  1102. let md = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in
  1103. let types = List.filter (fun t -> not (t_private t)) md.mtypes in
  1104. ctx.local_types <- ctx.local_types @ types
  1105. | Some _ ->
  1106. let t = load_type_def ctx p t in
  1107. ctx.local_types <- ctx.local_types @ [t]
  1108. )
  1109. | EUsing t ->
  1110. (match t.tsub with
  1111. | None ->
  1112. let md = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in
  1113. let types = List.filter (fun t -> not (t_private t)) md.mtypes in
  1114. ctx.local_using <- ctx.local_using @ (List.map (resolve_typedef ctx) types);
  1115. | Some _ ->
  1116. let t = load_type_def ctx p t in
  1117. ctx.local_using<- ctx.local_using @ [resolve_typedef ctx t])
  1118. | EClass d ->
  1119. let c = get_class d.d_name in
  1120. delays := !delays @ check_overriding ctx c p :: check_interfaces ctx c p :: init_class ctx c p d.d_flags d.d_data
  1121. | EEnum d ->
  1122. let e = get_enum d.d_name in
  1123. ctx.type_params <- e.e_types;
  1124. let et = TEnum (e,List.map snd e.e_types) in
  1125. let names = ref [] in
  1126. let index = ref 0 in
  1127. let rec loop = function
  1128. | (":build",[ECall (epath,el),p]) :: _ ->
  1129. let rec loop (e,p) =
  1130. match e with
  1131. | EConst (Ident i) | EConst (Type i) -> i
  1132. | EField (e,f) | EType (e,f) -> loop e ^ "." ^ f
  1133. | _ -> error "Build call parameter must be a class path" p
  1134. in
  1135. let s = loop epath in
  1136. if ctx.in_macro then error "You cannot used :build inside a macro : make sure that your enum is not used in macro" p;
  1137. (match apply_macro ctx s el p with
  1138. | None -> error "Enum build failure" p
  1139. | Some (EArrayDecl el,_) | Some (EBlock el,_) ->
  1140. List.map (fun (e,p) ->
  1141. match e with
  1142. | EConst (Ident i) | EConst (Type i) | EConst (String i) -> i, None, [], [], p
  1143. | _ -> error "Invalid enum constructor" p
  1144. ) el
  1145. | _ -> error "Build macro must return an block" p
  1146. )
  1147. | _ :: l -> loop l
  1148. | [] -> []
  1149. in
  1150. let extra = loop d.d_meta in
  1151. List.iter (fun (c,doc,meta,t,p) ->
  1152. if c = "name" && Common.defined ctx.com "js" then error "This identifier cannot be used in Javascript" p;
  1153. let t = (match t with
  1154. | [] -> et
  1155. | l ->
  1156. let pnames = ref PMap.empty in
  1157. TFun (List.map (fun (s,opt,t) ->
  1158. if PMap.mem s (!pnames) then error ("Duplicate parameter '" ^ s ^ "' in enum constructor " ^ c) p;
  1159. pnames := PMap.add s () (!pnames);
  1160. s, opt, load_type_opt ~opt ctx p (Some t)
  1161. ) l, et)
  1162. ) in
  1163. if PMap.mem c e.e_constrs then error ("Duplicate constructor " ^ c) p;
  1164. e.e_constrs <- PMap.add c {
  1165. ef_name = c;
  1166. ef_type = t;
  1167. ef_pos = p;
  1168. ef_doc = doc;
  1169. ef_index = !index;
  1170. ef_meta = meta;
  1171. } e.e_constrs;
  1172. incr index;
  1173. names := c :: !names;
  1174. ) (d.d_data @ extra);
  1175. e.e_names <- List.rev !names;
  1176. e.e_extern <- e.e_extern || e.e_names = [];
  1177. | ETypedef d ->
  1178. let t = get_tdef d.d_name in
  1179. ctx.type_params <- t.t_types;
  1180. let tt = load_complex_type ctx p d.d_data in
  1181. if t.t_type == follow tt then error "Recursive typedef is not allowed" p;
  1182. (match t.t_type with
  1183. | TMono r ->
  1184. (match !r with
  1185. | None -> r := Some tt;
  1186. | Some _ -> assert false);
  1187. | _ -> assert false);
  1188. ) tdecls;
  1189. (* PASS 3 : type checking, delayed until all modules and types are built *)
  1190. List.iter (delay ctx) (List.rev (!delays));
  1191. m
  1192. let parse_module ctx m p =
  1193. let remap = ref (fst m) in
  1194. let file = (match m with
  1195. | [] , name -> name
  1196. | x :: l , name ->
  1197. let x = (try
  1198. match PMap.find x ctx.com.package_rules with
  1199. | Forbidden -> error ("You can't access the " ^ x ^ " package with current compilation flags (for " ^ s_type_path m ^ ")") p;
  1200. | Directory d -> d
  1201. | Remap d -> remap := d :: l; d
  1202. with Not_found -> x
  1203. ) in
  1204. String.concat "/" (x :: l) ^ "/" ^ name
  1205. ) ^ ".hx" in
  1206. let file = Common.find_file ctx.com file in
  1207. let ch = (try open_in_bin file with _ -> error ("Could not open " ^ file) p) in
  1208. let t = Common.timer "parsing" in
  1209. Lexer.init file;
  1210. let pack , decls = (try Parser.parse ctx.com (Lexing.from_channel ch) with e -> close_in ch; t(); raise e) in
  1211. t();
  1212. close_in ch;
  1213. if ctx.com.verbose then print_endline ("Parsed " ^ file);
  1214. if pack <> !remap then begin
  1215. let spack m = if m = [] then "<empty>" else String.concat "." m in
  1216. if p == Ast.null_pos then
  1217. error ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p
  1218. else
  1219. error ("Invalid package : " ^ spack (fst m) ^ " should be " ^ spack pack) p
  1220. end;
  1221. if !remap <> fst m then
  1222. (* build typedefs to redirect to real package *)
  1223. List.rev (List.fold_left (fun acc (t,p) ->
  1224. let build f d =
  1225. let priv = List.mem f d.d_flags in
  1226. (ETypedef {
  1227. d_name = d.d_name;
  1228. d_doc = None;
  1229. d_meta = [];
  1230. d_params = d.d_params;
  1231. d_flags = if priv then [EPrivate] else [];
  1232. d_data = CTPath (if priv then { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None; } else
  1233. {
  1234. tpackage = !remap;
  1235. tname = d.d_name;
  1236. tparams = List.map (fun (s,_) ->
  1237. TPType (CTPath { tpackage = []; tname = s; tparams = []; tsub = None; })
  1238. ) d.d_params;
  1239. tsub = None;
  1240. });
  1241. },p) :: acc
  1242. in
  1243. match t with
  1244. | EClass d -> build HPrivate d
  1245. | EEnum d -> build EPrivate d
  1246. | ETypedef d -> build EPrivate d
  1247. | EImport _ | EUsing _ -> acc
  1248. ) [(EImport { tpackage = !remap; tname = snd m; tparams = []; tsub = None; },null_pos)] decls)
  1249. else
  1250. decls
  1251. let load_module ctx m p =
  1252. try
  1253. Hashtbl.find ctx.g.modules m
  1254. with
  1255. Not_found ->
  1256. let decls = (try
  1257. parse_module ctx m p
  1258. with Not_found ->
  1259. let rec loop = function
  1260. | [] -> raise (Error (Module_not_found m,p))
  1261. | load :: l ->
  1262. match load m p with
  1263. | None -> loop l
  1264. | Some (_,a) -> a
  1265. in
  1266. loop ctx.com.load_extern_type
  1267. ) in
  1268. type_module ctx m decls p