type.ml 71 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269
  1. (*
  2. The Haxe Compiler
  3. Copyright (C) 2005-2015 Haxe Foundation
  4. This program is free software; you can redistribute it and/or
  5. modify it under the terms of the GNU General Public License
  6. as published by the Free Software Foundation; either version 2
  7. of the License, or (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  15. *)
  16. open Ast
  17. type path = string list * string
  18. type field_kind =
  19. | Var of var_kind
  20. | Method of method_kind
  21. and var_kind = {
  22. v_read : var_access;
  23. v_write : var_access;
  24. }
  25. and var_access =
  26. | AccNormal
  27. | AccNo (* can't be accessed outside of the class itself and its subclasses *)
  28. | AccNever (* can't be accessed, even in subclasses *)
  29. | AccResolve (* call resolve("field") when accessed *)
  30. | AccCall (* perform a method call when accessed *)
  31. | AccInline (* similar to Normal but inline when accessed *)
  32. | AccRequire of string * string option (* set when @:require(cond) fails *)
  33. and method_kind =
  34. | MethNormal
  35. | MethInline
  36. | MethDynamic
  37. | MethMacro
  38. type t =
  39. | TMono of t option ref
  40. | TEnum of tenum * tparams
  41. | TInst of tclass * tparams
  42. | TType of tdef * tparams
  43. | TFun of (string * bool * t) list * t
  44. | TAnon of tanon
  45. | TDynamic of t
  46. | TLazy of (unit -> t) ref
  47. | TAbstract of tabstract * tparams
  48. and tparams = t list
  49. and type_params = (string * t) list
  50. and tconstant =
  51. | TInt of int32
  52. | TFloat of string
  53. | TString of string
  54. | TBool of bool
  55. | TNull
  56. | TThis
  57. | TSuper
  58. and tvar = {
  59. mutable v_id : int;
  60. mutable v_name : string;
  61. mutable v_type : t;
  62. mutable v_capture : bool;
  63. mutable v_extra : (type_params * texpr option) option;
  64. mutable v_meta : metadata;
  65. }
  66. and tfunc = {
  67. tf_args : (tvar * tconstant option) list;
  68. tf_type : t;
  69. tf_expr : texpr;
  70. }
  71. and anon_status =
  72. | Closed
  73. | Opened
  74. | Const
  75. | Extend of t list
  76. | Statics of tclass
  77. | EnumStatics of tenum
  78. | AbstractStatics of tabstract
  79. and tanon = {
  80. mutable a_fields : (string, tclass_field) PMap.t;
  81. a_status : anon_status ref;
  82. }
  83. and texpr_expr =
  84. | TConst of tconstant
  85. | TLocal of tvar
  86. | TArray of texpr * texpr
  87. | TBinop of Ast.binop * texpr * texpr
  88. | TField of texpr * tfield_access
  89. | TTypeExpr of module_type
  90. | TParenthesis of texpr
  91. | TObjectDecl of (string * texpr) list
  92. | TArrayDecl of texpr list
  93. | TCall of texpr * texpr list
  94. | TNew of tclass * tparams * texpr list
  95. | TUnop of Ast.unop * Ast.unop_flag * texpr
  96. | TFunction of tfunc
  97. | TVar of tvar * texpr option
  98. | TBlock of texpr list
  99. | TFor of tvar * texpr * texpr
  100. | TIf of texpr * texpr * texpr option
  101. | TWhile of texpr * texpr * Ast.while_flag
  102. | TSwitch of texpr * (texpr list * texpr) list * texpr option
  103. | TTry of texpr * (tvar * texpr) list
  104. | TReturn of texpr option
  105. | TBreak
  106. | TContinue
  107. | TThrow of texpr
  108. | TCast of texpr * module_type option
  109. | TMeta of metadata_entry * texpr
  110. | TEnumParameter of texpr * tenum_field * int
  111. and tfield_access =
  112. | FInstance of tclass * tparams * tclass_field
  113. | FStatic of tclass * tclass_field
  114. | FAnon of tclass_field
  115. | FDynamic of string
  116. | FClosure of (tclass * tparams) option * tclass_field (* None class = TAnon *)
  117. | FEnum of tenum * tenum_field
  118. and texpr = {
  119. eexpr : texpr_expr;
  120. etype : t;
  121. epos : Ast.pos;
  122. }
  123. and tclass_field = {
  124. mutable cf_name : string;
  125. mutable cf_type : t;
  126. mutable cf_public : bool;
  127. cf_pos : pos;
  128. mutable cf_doc : Ast.documentation;
  129. mutable cf_meta : metadata;
  130. mutable cf_kind : field_kind;
  131. mutable cf_params : type_params;
  132. mutable cf_expr : texpr option;
  133. mutable cf_overloads : tclass_field list;
  134. }
  135. and tclass_kind =
  136. | KNormal
  137. | KTypeParameter of t list
  138. | KExtension of tclass * tparams
  139. | KExpr of Ast.expr
  140. | KGeneric
  141. | KGenericInstance of tclass * tparams
  142. | KMacroType
  143. | KGenericBuild of class_field list
  144. | KAbstractImpl of tabstract
  145. and metadata = Ast.metadata
  146. and tinfos = {
  147. mt_path : path;
  148. mt_module : module_def;
  149. mt_pos : Ast.pos;
  150. mt_private : bool;
  151. mt_doc : Ast.documentation;
  152. mutable mt_meta : metadata;
  153. mt_params : type_params;
  154. }
  155. and tclass = {
  156. mutable cl_path : path;
  157. mutable cl_module : module_def;
  158. mutable cl_pos : Ast.pos;
  159. mutable cl_private : bool;
  160. mutable cl_doc : Ast.documentation;
  161. mutable cl_meta : metadata;
  162. mutable cl_params : type_params;
  163. (* do not insert any fields above *)
  164. mutable cl_kind : tclass_kind;
  165. mutable cl_extern : bool;
  166. mutable cl_interface : bool;
  167. mutable cl_super : (tclass * tparams) option;
  168. mutable cl_implements : (tclass * tparams) list;
  169. mutable cl_fields : (string , tclass_field) PMap.t;
  170. mutable cl_statics : (string, tclass_field) PMap.t;
  171. mutable cl_ordered_statics : tclass_field list;
  172. mutable cl_ordered_fields : tclass_field list;
  173. mutable cl_dynamic : t option;
  174. mutable cl_array_access : t option;
  175. mutable cl_constructor : tclass_field option;
  176. mutable cl_init : texpr option;
  177. mutable cl_overrides : tclass_field list;
  178. mutable cl_build : unit -> bool;
  179. mutable cl_restore : unit -> unit;
  180. }
  181. and tenum_field = {
  182. ef_name : string;
  183. ef_type : t;
  184. ef_pos : Ast.pos;
  185. ef_doc : Ast.documentation;
  186. ef_index : int;
  187. ef_params : type_params;
  188. mutable ef_meta : metadata;
  189. }
  190. and tenum = {
  191. mutable e_path : path;
  192. e_module : module_def;
  193. e_pos : Ast.pos;
  194. e_private : bool;
  195. e_doc : Ast.documentation;
  196. mutable e_meta : metadata;
  197. mutable e_params : type_params;
  198. (* do not insert any fields above *)
  199. e_type : tdef;
  200. mutable e_extern : bool;
  201. mutable e_constrs : (string , tenum_field) PMap.t;
  202. mutable e_names : string list;
  203. }
  204. and tdef = {
  205. t_path : path;
  206. t_module : module_def;
  207. t_pos : Ast.pos;
  208. t_private : bool;
  209. t_doc : Ast.documentation;
  210. mutable t_meta : metadata;
  211. mutable t_params : type_params;
  212. (* do not insert any fields above *)
  213. mutable t_type : t;
  214. }
  215. and tabstract = {
  216. mutable a_path : path;
  217. a_module : module_def;
  218. a_pos : Ast.pos;
  219. a_private : bool;
  220. a_doc : Ast.documentation;
  221. mutable a_meta : metadata;
  222. mutable a_params : type_params;
  223. (* do not insert any fields above *)
  224. mutable a_ops : (Ast.binop * tclass_field) list;
  225. mutable a_unops : (Ast.unop * unop_flag * tclass_field) list;
  226. mutable a_impl : tclass option;
  227. mutable a_this : t;
  228. mutable a_from : t list;
  229. mutable a_from_field : (t * tclass_field) list;
  230. mutable a_to : t list;
  231. mutable a_to_field : (t * tclass_field) list;
  232. mutable a_array : tclass_field list;
  233. mutable a_resolve : tclass_field option;
  234. }
  235. and module_type =
  236. | TClassDecl of tclass
  237. | TEnumDecl of tenum
  238. | TTypeDecl of tdef
  239. | TAbstractDecl of tabstract
  240. and module_def = {
  241. m_id : int;
  242. m_path : path;
  243. mutable m_types : module_type list;
  244. m_extra : module_def_extra;
  245. }
  246. and module_def_extra = {
  247. m_file : string;
  248. m_sign : string;
  249. mutable m_time : float;
  250. mutable m_dirty : bool;
  251. mutable m_added : int;
  252. mutable m_mark : int;
  253. mutable m_deps : (int,module_def) PMap.t;
  254. mutable m_processed : int;
  255. mutable m_kind : module_kind;
  256. mutable m_binded_res : (string, string) PMap.t;
  257. mutable m_macro_calls : string list;
  258. mutable m_if_feature : (string *(tclass * tclass_field * bool)) list;
  259. mutable m_features : (string,bool) Hashtbl.t;
  260. }
  261. and module_kind =
  262. | MCode
  263. | MMacro
  264. | MFake
  265. | MSub
  266. | MExtern
  267. and dt =
  268. | DTSwitch of texpr * (texpr * dt) list * dt option
  269. | DTBind of ((tvar * pos) * texpr) list * dt
  270. | DTGoto of int
  271. | DTExpr of texpr
  272. | DTGuard of texpr * dt * dt option
  273. and decision_tree = {
  274. dt_dt_lookup : dt array;
  275. dt_first : int;
  276. dt_type : t;
  277. dt_var_init : (tvar * texpr option) list;
  278. dt_is_complex : bool;
  279. }
  280. (* ======= General utility ======= *)
  281. let alloc_var =
  282. let uid = ref 0 in
  283. (fun n t -> incr uid; { v_name = n; v_type = t; v_id = !uid; v_capture = false; v_extra = None; v_meta = [] })
  284. let alloc_unbound_var n t =
  285. let v = alloc_var n t in
  286. v.v_meta <- [Meta.Unbound,[],null_pos];
  287. v
  288. let alloc_mid =
  289. let mid = ref 0 in
  290. (fun() -> incr mid; !mid)
  291. let mk e t p = { eexpr = e; etype = t; epos = p }
  292. let mk_block e =
  293. match e.eexpr with
  294. | TBlock _ -> e
  295. | _ -> mk (TBlock [e]) e.etype e.epos
  296. let mk_cast e t p = mk (TCast(e,None)) t p
  297. let null t p = mk (TConst TNull) t p
  298. let mk_mono() = TMono (ref None)
  299. let rec t_dynamic = TDynamic t_dynamic
  300. let tfun pl r = TFun (List.map (fun t -> "",false,t) pl,r)
  301. let fun_args l = List.map (fun (a,c,t) -> a, c <> None, t) l
  302. let mk_class m path pos =
  303. {
  304. cl_path = path;
  305. cl_module = m;
  306. cl_pos = pos;
  307. cl_doc = None;
  308. cl_meta = [];
  309. cl_private = false;
  310. cl_kind = KNormal;
  311. cl_extern = false;
  312. cl_interface = false;
  313. cl_params = [];
  314. cl_super = None;
  315. cl_implements = [];
  316. cl_fields = PMap.empty;
  317. cl_ordered_statics = [];
  318. cl_ordered_fields = [];
  319. cl_statics = PMap.empty;
  320. cl_dynamic = None;
  321. cl_array_access = None;
  322. cl_constructor = None;
  323. cl_init = None;
  324. cl_overrides = [];
  325. cl_build = (fun() -> true);
  326. cl_restore = (fun() -> ());
  327. }
  328. let module_extra file sign time kind =
  329. {
  330. m_file = file;
  331. m_sign = sign;
  332. m_dirty = false;
  333. m_added = 0;
  334. m_mark = 0;
  335. m_time = time;
  336. m_processed = 0;
  337. m_deps = PMap.empty;
  338. m_kind = kind;
  339. m_binded_res = PMap.empty;
  340. m_macro_calls = [];
  341. m_if_feature = [];
  342. m_features = Hashtbl.create 0;
  343. }
  344. let mk_field name t p = {
  345. cf_name = name;
  346. cf_type = t;
  347. cf_pos = p;
  348. cf_doc = None;
  349. cf_meta = [];
  350. cf_public = true;
  351. cf_kind = Var { v_read = AccNormal; v_write = AccNormal };
  352. cf_expr = None;
  353. cf_params = [];
  354. cf_overloads = [];
  355. }
  356. let null_module = {
  357. m_id = alloc_mid();
  358. m_path = [] , "";
  359. m_types = [];
  360. m_extra = module_extra "" "" 0. MFake;
  361. }
  362. let null_class =
  363. let c = mk_class null_module ([],"") Ast.null_pos in
  364. c.cl_private <- true;
  365. c
  366. let null_field = mk_field "" t_dynamic Ast.null_pos
  367. let null_abstract = {
  368. a_path = ([],"");
  369. a_module = null_module;
  370. a_pos = null_pos;
  371. a_private = true;
  372. a_doc = None;
  373. a_meta = [];
  374. a_params = [];
  375. a_ops = [];
  376. a_unops = [];
  377. a_impl = None;
  378. a_this = t_dynamic;
  379. a_from = [];
  380. a_from_field = [];
  381. a_to = [];
  382. a_to_field = [];
  383. a_array = [];
  384. a_resolve = None;
  385. }
  386. let add_dependency m mdep =
  387. if m != null_module && m != mdep then m.m_extra.m_deps <- PMap.add mdep.m_id mdep m.m_extra.m_deps
  388. let arg_name (a,_) = a.v_name
  389. let t_infos t : tinfos =
  390. match t with
  391. | TClassDecl c -> Obj.magic c
  392. | TEnumDecl e -> Obj.magic e
  393. | TTypeDecl t -> Obj.magic t
  394. | TAbstractDecl a -> Obj.magic a
  395. let t_path t = (t_infos t).mt_path
  396. let rec is_parent csup c =
  397. if c == csup || List.exists (fun (i,_) -> is_parent csup i) c.cl_implements then
  398. true
  399. else match c.cl_super with
  400. | None -> false
  401. | Some (c,_) -> is_parent csup c
  402. let map loop t =
  403. match t with
  404. | TMono r ->
  405. (match !r with
  406. | None -> t
  407. | Some t -> loop t) (* erase*)
  408. | TEnum (_,[]) | TInst (_,[]) | TType (_,[]) ->
  409. t
  410. | TEnum (e,tl) ->
  411. TEnum (e, List.map loop tl)
  412. | TInst (c,tl) ->
  413. TInst (c, List.map loop tl)
  414. | TType (t2,tl) ->
  415. TType (t2,List.map loop tl)
  416. | TAbstract (a,tl) ->
  417. TAbstract (a,List.map loop tl)
  418. | TFun (tl,r) ->
  419. TFun (List.map (fun (s,o,t) -> s, o, loop t) tl,loop r)
  420. | TAnon a ->
  421. let fields = PMap.map (fun f -> { f with cf_type = loop f.cf_type }) a.a_fields in
  422. begin match !(a.a_status) with
  423. | Opened ->
  424. a.a_fields <- fields;
  425. t
  426. | _ ->
  427. TAnon {
  428. a_fields = fields;
  429. a_status = a.a_status;
  430. }
  431. end
  432. | TLazy f ->
  433. let ft = !f() in
  434. let ft2 = loop ft in
  435. if ft == ft2 then t else ft2
  436. | TDynamic t2 ->
  437. if t == t2 then t else TDynamic (loop t2)
  438. (* substitute parameters with other types *)
  439. let apply_params cparams params t =
  440. match cparams with
  441. | [] -> t
  442. | _ ->
  443. let rec loop l1 l2 =
  444. match l1, l2 with
  445. | [] , [] -> []
  446. | (x,TLazy f) :: l1, _ -> loop ((x,(!f)()) :: l1) l2
  447. | (_,t1) :: l1 , t2 :: l2 -> (t1,t2) :: loop l1 l2
  448. | _ -> assert false
  449. in
  450. let subst = loop cparams params in
  451. let rec loop t =
  452. try
  453. List.assq t subst
  454. with Not_found ->
  455. match t with
  456. | TMono r ->
  457. (match !r with
  458. | None -> t
  459. | Some t -> loop t)
  460. | TEnum (e,tl) ->
  461. (match tl with
  462. | [] -> t
  463. | _ -> TEnum (e,List.map loop tl))
  464. | TType (t2,tl) ->
  465. (match tl with
  466. | [] -> t
  467. | _ -> TType (t2,List.map loop tl))
  468. | TAbstract (a,tl) ->
  469. (match tl with
  470. | [] -> t
  471. | _ -> TAbstract (a,List.map loop tl))
  472. | TInst (c,tl) ->
  473. (match tl with
  474. | [] ->
  475. t
  476. | [TMono r] ->
  477. (match !r with
  478. | Some tt when t == tt ->
  479. (* for dynamic *)
  480. let pt = mk_mono() in
  481. let t = TInst (c,[pt]) in
  482. (match pt with TMono r -> r := Some t | _ -> assert false);
  483. t
  484. | _ -> TInst (c,List.map loop tl))
  485. | _ ->
  486. TInst (c,List.map loop tl))
  487. | TFun (tl,r) ->
  488. TFun (List.map (fun (s,o,t) -> s, o, loop t) tl,loop r)
  489. | TAnon a ->
  490. let fields = PMap.map (fun f -> { f with cf_type = loop f.cf_type }) a.a_fields in
  491. begin match !(a.a_status) with
  492. | Opened ->
  493. a.a_fields <- fields;
  494. t
  495. | _ ->
  496. TAnon {
  497. a_fields = fields;
  498. a_status = a.a_status;
  499. }
  500. end
  501. | TLazy f ->
  502. let ft = !f() in
  503. let ft2 = loop ft in
  504. if ft == ft2 then
  505. t
  506. else
  507. ft2
  508. | TDynamic t2 ->
  509. if t == t2 then
  510. t
  511. else
  512. TDynamic (loop t2)
  513. in
  514. loop t
  515. let monomorphs eparams t =
  516. apply_params eparams (List.map (fun _ -> mk_mono()) eparams) t
  517. let rec follow t =
  518. match t with
  519. | TMono r ->
  520. (match !r with
  521. | Some t -> follow t
  522. | _ -> t)
  523. | TLazy f ->
  524. follow (!f())
  525. | TType (t,tl) ->
  526. follow (apply_params t.t_params tl t.t_type)
  527. | _ -> t
  528. let rec is_nullable = function
  529. | TMono r ->
  530. (match !r with None -> false | Some t -> is_nullable t)
  531. | TType ({ t_path = ([],"Null") },[_]) ->
  532. true
  533. | TLazy f ->
  534. is_nullable (!f())
  535. | TType (t,tl) ->
  536. is_nullable (apply_params t.t_params tl t.t_type)
  537. | TFun _ ->
  538. false
  539. (*
  540. Type parameters will most of the time be nullable objects, so we don't want to make it hard for users
  541. to have to specify Null<T> all over the place, so while they could be a basic type, let's assume they will not.
  542. This will still cause issues with inlining and haxe.rtti.Generic. In that case proper explicit Null<T> is required to
  543. work correctly with basic types. This could still be fixed by redoing a nullability inference on the typed AST.
  544. | TInst ({ cl_kind = KTypeParameter },_) -> false
  545. *)
  546. | TAbstract (a,_) when Meta.has Meta.CoreType a.a_meta ->
  547. not (Meta.has Meta.NotNull a.a_meta)
  548. | TAbstract (a,tl) ->
  549. not (Meta.has Meta.NotNull a.a_meta) && is_nullable (apply_params a.a_params tl a.a_this)
  550. | _ ->
  551. true
  552. let rec is_null ?(no_lazy=false) = function
  553. | TMono r ->
  554. (match !r with None -> false | Some t -> is_null t)
  555. | TType ({ t_path = ([],"Null") },[t]) ->
  556. not (is_nullable (follow t))
  557. | TLazy f ->
  558. if no_lazy then raise Exit else is_null (!f())
  559. | TType (t,tl) ->
  560. is_null (apply_params t.t_params tl t.t_type)
  561. | _ ->
  562. false
  563. (* Determines if we have a Null<T>. Unlike is_null, this returns true even if the wrapped type is nullable itself. *)
  564. let rec is_explicit_null = function
  565. | TMono r ->
  566. (match !r with None -> false | Some t -> is_null t)
  567. | TType ({ t_path = ([],"Null") },[t]) ->
  568. true
  569. | TLazy f ->
  570. is_null (!f())
  571. | TType (t,tl) ->
  572. is_null (apply_params t.t_params tl t.t_type)
  573. | _ ->
  574. false
  575. let rec has_mono t = match t with
  576. | TMono r ->
  577. (match !r with None -> true | Some t -> has_mono t)
  578. | TInst(_,pl) | TEnum(_,pl) | TAbstract(_,pl) | TType(_,pl) ->
  579. List.exists has_mono pl
  580. | TDynamic _ ->
  581. false
  582. | TFun(args,r) ->
  583. has_mono r || List.exists (fun (_,_,t) -> has_mono t) args
  584. | TAnon a ->
  585. PMap.fold (fun cf b -> has_mono cf.cf_type || b) a.a_fields false
  586. | TLazy r ->
  587. has_mono (!r())
  588. let concat e1 e2 =
  589. let e = (match e1.eexpr, e2.eexpr with
  590. | TBlock el1, TBlock el2 -> TBlock (el1@el2)
  591. | TBlock el, _ -> TBlock (el @ [e2])
  592. | _, TBlock el -> TBlock (e1 :: el)
  593. | _ , _ -> TBlock [e1;e2]
  594. ) in
  595. mk e e2.etype (punion e1.epos e2.epos)
  596. let is_closed a = !(a.a_status) <> Opened
  597. let type_of_module_type = function
  598. | TClassDecl c -> TInst (c,List.map snd c.cl_params)
  599. | TEnumDecl e -> TEnum (e,List.map snd e.e_params)
  600. | TTypeDecl t -> TType (t,List.map snd t.t_params)
  601. | TAbstractDecl a -> TAbstract (a,List.map snd a.a_params)
  602. let tconst_to_const = function
  603. | TInt i -> Int (Int32.to_string i)
  604. | TFloat s -> Float s
  605. | TString s -> String s
  606. | TBool b -> Ident (if b then "true" else "false")
  607. | TNull -> Ident "null"
  608. | TThis -> Ident "this"
  609. | TSuper -> Ident "super"
  610. (* ======= Field utility ======= *)
  611. let field_name f =
  612. match f with
  613. | FAnon f | FInstance (_,_,f) | FStatic (_,f) | FClosure (_,f) -> f.cf_name
  614. | FEnum (_,f) -> f.ef_name
  615. | FDynamic n -> n
  616. let extract_field = function
  617. | FAnon f | FInstance (_,_,f) | FStatic (_,f) | FClosure (_,f) -> Some f
  618. | _ -> None
  619. let is_extern_field f =
  620. match f.cf_kind with
  621. | Method _ -> false
  622. | Var { v_read = AccNormal | AccInline | AccNo } | Var { v_write = AccNormal | AccNo } -> false
  623. | _ -> not (Meta.has Meta.IsVar f.cf_meta)
  624. let field_type f =
  625. match f.cf_params with
  626. | [] -> f.cf_type
  627. | l -> monomorphs l f.cf_type
  628. let rec raw_class_field build_type c tl i =
  629. let apply = apply_params c.cl_params tl in
  630. try
  631. let f = PMap.find i c.cl_fields in
  632. Some (c,tl), build_type f , f
  633. with Not_found -> try (match c.cl_constructor with
  634. | Some ctor when i = "new" -> Some (c,tl), build_type ctor,ctor
  635. | _ -> raise Not_found)
  636. with Not_found -> try
  637. match c.cl_super with
  638. | None ->
  639. raise Not_found
  640. | Some (c,tl) ->
  641. let c2 , t , f = raw_class_field build_type c (List.map apply tl) i in
  642. c2, apply_params c.cl_params tl t , f
  643. with Not_found ->
  644. match c.cl_kind with
  645. | KTypeParameter tl ->
  646. let rec loop = function
  647. | [] ->
  648. raise Not_found
  649. | t :: ctl ->
  650. match follow t with
  651. | TAnon a ->
  652. (try
  653. let f = PMap.find i a.a_fields in
  654. None, build_type f, f
  655. with
  656. Not_found -> loop ctl)
  657. | TInst (c,tl) ->
  658. (try
  659. let c2, t , f = raw_class_field build_type c (List.map apply tl) i in
  660. c2, apply_params c.cl_params tl t, f
  661. with
  662. Not_found -> loop ctl)
  663. | _ ->
  664. loop ctl
  665. in
  666. loop tl
  667. | _ ->
  668. if not c.cl_interface then raise Not_found;
  669. (*
  670. an interface can implements other interfaces without
  671. having to redeclare its fields
  672. *)
  673. let rec loop = function
  674. | [] ->
  675. raise Not_found
  676. | (c,tl) :: l ->
  677. try
  678. let c2, t , f = raw_class_field build_type c (List.map apply tl) i in
  679. c2, apply_params c.cl_params tl t, f
  680. with
  681. Not_found -> loop l
  682. in
  683. loop c.cl_implements
  684. let class_field = raw_class_field field_type
  685. let quick_field t n =
  686. match follow t with
  687. | TInst (c,tl) ->
  688. let c, _, f = raw_class_field (fun f -> f.cf_type) c tl n in
  689. (match c with None -> FAnon f | Some (c,tl) -> FInstance (c,tl,f))
  690. | TAnon a ->
  691. (match !(a.a_status) with
  692. | EnumStatics e ->
  693. let ef = PMap.find n e.e_constrs in
  694. FEnum(e,ef)
  695. | Statics c ->
  696. FStatic (c,PMap.find n c.cl_statics)
  697. | AbstractStatics a ->
  698. begin match a.a_impl with
  699. | Some c ->
  700. let cf = PMap.find n c.cl_statics in
  701. FStatic(c,cf) (* is that right? *)
  702. | _ ->
  703. raise Not_found
  704. end
  705. | _ ->
  706. FAnon (PMap.find n a.a_fields))
  707. | TDynamic _ ->
  708. FDynamic n
  709. | TEnum _ | TMono _ | TAbstract _ | TFun _ ->
  710. raise Not_found
  711. | TLazy _ | TType _ ->
  712. assert false
  713. let quick_field_dynamic t s =
  714. try quick_field t s
  715. with Not_found -> FDynamic s
  716. let rec get_constructor build_type c =
  717. match c.cl_constructor, c.cl_super with
  718. | Some c, _ -> build_type c, c
  719. | None, None -> raise Not_found
  720. | None, Some (csup,cparams) ->
  721. let t, c = get_constructor build_type csup in
  722. apply_params csup.cl_params cparams t, c
  723. (* ======= Printing ======= *)
  724. let print_context() = ref []
  725. let rec s_type_kind t =
  726. let map tl = String.concat ", " (List.map s_type_kind tl) in
  727. match t with
  728. | TMono r ->
  729. begin match !r with
  730. | None -> "TMono (None)"
  731. | Some t -> "TMono (Some (" ^ (s_type_kind t) ^ "))"
  732. end
  733. | TEnum(en,tl) -> Printf.sprintf "TEnum(%s, [%s])" (s_type_path en.e_path) (map tl)
  734. | TInst(c,tl) -> Printf.sprintf "TInst(%s, [%s])" (s_type_path c.cl_path) (map tl)
  735. | TType(t,tl) -> Printf.sprintf "TType(%s, [%s])" (s_type_path t.t_path) (map tl)
  736. | TAbstract(a,tl) -> Printf.sprintf "TAbstract(%s, [%s])" (s_type_path a.a_path) (map tl)
  737. | TFun(tl,r) -> Printf.sprintf "TFun([%s], %s)" (String.concat ", " (List.map (fun (n,b,t) -> Printf.sprintf "%s%s:%s" (if b then "?" else "") n (s_type_kind t)) tl)) (s_type_kind r)
  738. | TAnon an -> "TAnon"
  739. | TDynamic t2 -> "TDynamic"
  740. | TLazy _ -> "TLazy"
  741. let rec s_type ctx t =
  742. match t with
  743. | TMono r ->
  744. (match !r with
  745. | None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
  746. | Some t -> s_type ctx t)
  747. | TEnum (e,tl) ->
  748. Ast.s_type_path e.e_path ^ s_type_params ctx tl
  749. | TInst (c,tl) ->
  750. (match c.cl_kind with
  751. | KExpr e -> Ast.s_expr e
  752. | _ -> Ast.s_type_path c.cl_path ^ s_type_params ctx tl)
  753. | TType (t,tl) ->
  754. Ast.s_type_path t.t_path ^ s_type_params ctx tl
  755. | TAbstract (a,tl) ->
  756. Ast.s_type_path a.a_path ^ s_type_params ctx tl
  757. | TFun ([],t) ->
  758. "Void -> " ^ s_fun ctx t false
  759. | TFun (l,t) ->
  760. String.concat " -> " (List.map (fun (s,b,t) ->
  761. (if b then "?" else "") ^ (if s = "" then "" else s ^ " : ") ^ s_fun ctx t true
  762. ) l) ^ " -> " ^ s_fun ctx t false
  763. | TAnon a ->
  764. 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
  765. "{" ^ (if not (is_closed a) then "+" else "") ^ String.concat "," fl ^ " }"
  766. | TDynamic t2 ->
  767. "Dynamic" ^ s_type_params ctx (if t == t2 then [] else [t2])
  768. | TLazy f ->
  769. s_type ctx (!f())
  770. and s_fun ctx t void =
  771. match t with
  772. | TFun _ ->
  773. "(" ^ s_type ctx t ^ ")"
  774. | TAbstract ({ a_path = ([],"Void") },[]) when void ->
  775. "(" ^ s_type ctx t ^ ")"
  776. | TMono r ->
  777. (match !r with
  778. | None -> s_type ctx t
  779. | Some t -> s_fun ctx t void)
  780. | TLazy f ->
  781. s_fun ctx (!f()) void
  782. | _ ->
  783. s_type ctx t
  784. and s_type_params ctx = function
  785. | [] -> ""
  786. | l -> "<" ^ String.concat ", " (List.map (s_type ctx) l) ^ ">"
  787. let s_access is_read = function
  788. | AccNormal -> "default"
  789. | AccNo -> "null"
  790. | AccNever -> "never"
  791. | AccResolve -> "resolve"
  792. | AccCall -> if is_read then "get" else "set"
  793. | AccInline -> "inline"
  794. | AccRequire (n,_) -> "require " ^ n
  795. let s_kind = function
  796. | Var { v_read = AccNormal; v_write = AccNormal } -> "var"
  797. | Var v -> "(" ^ s_access true v.v_read ^ "," ^ s_access false v.v_write ^ ")"
  798. | Method m ->
  799. match m with
  800. | MethNormal -> "method"
  801. | MethDynamic -> "dynamic method"
  802. | MethInline -> "inline method"
  803. | MethMacro -> "macro method"
  804. let s_expr_kind e =
  805. match e.eexpr with
  806. | TConst _ -> "Const"
  807. | TLocal _ -> "Local"
  808. | TArray (_,_) -> "Array"
  809. | TBinop (_,_,_) -> "Binop"
  810. | TEnumParameter (_,_,_) -> "EnumParameter"
  811. | TField (_,_) -> "Field"
  812. | TTypeExpr _ -> "TypeExpr"
  813. | TParenthesis _ -> "Parenthesis"
  814. | TObjectDecl _ -> "ObjectDecl"
  815. | TArrayDecl _ -> "ArrayDecl"
  816. | TCall (_,_) -> "Call"
  817. | TNew (_,_,_) -> "New"
  818. | TUnop (_,_,_) -> "Unop"
  819. | TFunction _ -> "Function"
  820. | TVar _ -> "Vars"
  821. | TBlock _ -> "Block"
  822. | TFor (_,_,_) -> "For"
  823. | TIf (_,_,_) -> "If"
  824. | TWhile (_,_,_) -> "While"
  825. | TSwitch (_,_,_) -> "Switch"
  826. | TTry (_,_) -> "Try"
  827. | TReturn _ -> "Return"
  828. | TBreak -> "Break"
  829. | TContinue -> "Continue"
  830. | TThrow _ -> "Throw"
  831. | TCast _ -> "Cast"
  832. | TMeta _ -> "Meta"
  833. let s_const = function
  834. | TInt i -> Int32.to_string i
  835. | TFloat s -> s
  836. | TString s -> Printf.sprintf "\"%s\"" (Ast.s_escape s)
  837. | TBool b -> if b then "true" else "false"
  838. | TNull -> "null"
  839. | TThis -> "this"
  840. | TSuper -> "super"
  841. let rec s_expr s_type e =
  842. let sprintf = Printf.sprintf in
  843. let slist f l = String.concat "," (List.map f l) in
  844. let loop = s_expr s_type in
  845. let s_var v = v.v_name ^ ":" ^ string_of_int v.v_id ^ if v.v_capture then "[c]" else "" in
  846. let str = (match e.eexpr with
  847. | TConst c ->
  848. "Const " ^ s_const c
  849. | TLocal v ->
  850. "Local " ^ s_var v
  851. | TArray (e1,e2) ->
  852. sprintf "%s[%s]" (loop e1) (loop e2)
  853. | TBinop (op,e1,e2) ->
  854. sprintf "(%s %s %s)" (loop e1) (s_binop op) (loop e2)
  855. | TEnumParameter (e1,_,i) ->
  856. sprintf "%s[%i]" (loop e1) i
  857. | TField (e,f) ->
  858. let fstr = (match f with
  859. | FStatic (c,f) -> "static(" ^ s_type_path c.cl_path ^ "." ^ f.cf_name ^ ")"
  860. | FInstance (c,_,f) -> "inst(" ^ s_type_path c.cl_path ^ "." ^ f.cf_name ^ " : " ^ s_type f.cf_type ^ ")"
  861. | FClosure (c,f) -> "closure(" ^ (match c with None -> f.cf_name | Some (c,_) -> s_type_path c.cl_path ^ "." ^ f.cf_name) ^ ")"
  862. | FAnon f -> "anon(" ^ f.cf_name ^ ")"
  863. | FEnum (en,f) -> "enum(" ^ s_type_path en.e_path ^ "." ^ f.ef_name ^ ")"
  864. | FDynamic f -> "dynamic(" ^ f ^ ")"
  865. ) in
  866. sprintf "%s.%s" (loop e) fstr
  867. | TTypeExpr m ->
  868. sprintf "TypeExpr %s" (s_type_path (t_path m))
  869. | TParenthesis e ->
  870. sprintf "Parenthesis %s" (loop e)
  871. | TObjectDecl fl ->
  872. sprintf "ObjectDecl {%s}" (slist (fun (f,e) -> sprintf "%s : %s" f (loop e)) fl)
  873. | TArrayDecl el ->
  874. sprintf "ArrayDecl [%s]" (slist loop el)
  875. | TCall (e,el) ->
  876. sprintf "Call %s(%s)" (loop e) (slist loop el)
  877. | TNew (c,pl,el) ->
  878. sprintf "New %s%s(%s)" (s_type_path c.cl_path) (match pl with [] -> "" | l -> sprintf "<%s>" (slist s_type l)) (slist loop el)
  879. | TUnop (op,f,e) ->
  880. (match f with
  881. | Prefix -> sprintf "(%s %s)" (s_unop op) (loop e)
  882. | Postfix -> sprintf "(%s %s)" (loop e) (s_unop op))
  883. | TFunction f ->
  884. 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
  885. sprintf "Function(%s) : %s = %s" args (s_type f.tf_type) (loop f.tf_expr)
  886. | TVar (v,eo) ->
  887. sprintf "Vars %s" (sprintf "%s : %s%s" (s_var v) (s_type v.v_type) (match eo with None -> "" | Some e -> " = " ^ loop e))
  888. | TBlock el ->
  889. sprintf "Block {\n%s}" (String.concat "" (List.map (fun e -> sprintf "%s;\n" (loop e)) el))
  890. | TFor (v,econd,e) ->
  891. sprintf "For (%s : %s in %s,%s)" (s_var v) (s_type v.v_type) (loop econd) (loop e)
  892. | TIf (e,e1,e2) ->
  893. sprintf "If (%s,%s%s)" (loop e) (loop e1) (match e2 with None -> "" | Some e -> "," ^ loop e)
  894. | TWhile (econd,e,flag) ->
  895. (match flag with
  896. | NormalWhile -> sprintf "While (%s,%s)" (loop econd) (loop e)
  897. | DoWhile -> sprintf "DoWhile (%s,%s)" (loop e) (loop econd))
  898. | TSwitch (e,cases,def) ->
  899. 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)
  900. | TTry (e,cl) ->
  901. 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)
  902. | TReturn None ->
  903. "Return"
  904. | TReturn (Some e) ->
  905. sprintf "Return %s" (loop e)
  906. | TBreak ->
  907. "Break"
  908. | TContinue ->
  909. "Continue"
  910. | TThrow e ->
  911. "Throw " ^ (loop e)
  912. | TCast (e,t) ->
  913. sprintf "Cast %s%s" (match t with None -> "" | Some t -> s_type_path (t_path t) ^ ": ") (loop e)
  914. | TMeta ((n,el,_),e) ->
  915. sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
  916. ) in
  917. sprintf "(%s : %s)" str (s_type e.etype)
  918. and s_dt tabs tree =
  919. let s_type = s_type (print_context()) in
  920. tabs ^ match tree with
  921. | DTSwitch (st,cl,dto) ->
  922. "switch(" ^ (s_expr s_type st) ^ ") { \n" ^ tabs
  923. ^ (String.concat ("\n" ^ tabs) (List.map (fun (c,dt) ->
  924. "case " ^ (s_expr s_type c) ^ ":\n" ^ (s_dt (tabs ^ "\t") dt)
  925. ) cl))
  926. ^ (match dto with None -> "" | Some dt -> tabs ^ "default: " ^ (s_dt (tabs ^ "\t") dt))
  927. ^ "\n" ^ (if String.length tabs = 0 then "" else (String.sub tabs 0 (String.length tabs - 1))) ^ "}"
  928. | 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)
  929. | DTGoto i ->
  930. "goto " ^ (string_of_int i)
  931. | DTExpr e -> s_expr s_type e
  932. | 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))
  933. let rec s_expr_pretty tabs s_type e =
  934. let sprintf = Printf.sprintf in
  935. let loop = s_expr_pretty tabs s_type in
  936. let slist f l = String.concat "," (List.map f l) in
  937. match e.eexpr with
  938. | TConst c -> s_const c
  939. | TLocal v -> v.v_name
  940. | TArray (e1,e2) -> sprintf "%s[%s]" (loop e1) (loop e2)
  941. | TBinop (op,e1,e2) -> sprintf "%s %s %s" (loop e1) (s_binop op) (loop e2)
  942. | TEnumParameter (e1,_,i) -> sprintf "%s[%i]" (loop e1) i
  943. | TField (e1,s) -> sprintf "%s.%s" (loop e1) (field_name s)
  944. | TTypeExpr mt -> (s_type_path (t_path mt))
  945. | TParenthesis e1 -> sprintf "(%s)" (loop e1)
  946. | TObjectDecl fl -> sprintf "{%s}" (slist (fun (f,e) -> sprintf "%s : %s" f (loop e)) fl)
  947. | TArrayDecl el -> sprintf "[%s]" (slist loop el)
  948. | TCall (e1,el) -> sprintf "%s(%s)" (loop e1) (slist loop el)
  949. | TNew (c,pl,el) ->
  950. sprintf "new %s(%s)" (s_type_path c.cl_path) (slist loop el)
  951. | TUnop (op,f,e) ->
  952. (match f with
  953. | Prefix -> sprintf "%s %s" (s_unop op) (loop e)
  954. | Postfix -> sprintf "%s %s" (loop e) (s_unop op))
  955. | TFunction f ->
  956. 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
  957. sprintf "function(%s) = %s" args (loop f.tf_expr)
  958. | TVar (v,eo) ->
  959. sprintf "var %s" (sprintf "%s%s" v.v_name (match eo with None -> "" | Some e -> " = " ^ loop e))
  960. | TBlock el ->
  961. let ntabs = tabs ^ "\t" in
  962. 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
  963. s ^ tabs ^ "}"
  964. | TFor (v,econd,e) ->
  965. sprintf "for (%s in %s) %s" v.v_name (loop econd) (loop e)
  966. | TIf (e,e1,e2) ->
  967. sprintf "if (%s)%s%s" (loop e) (loop e1) (match e2 with None -> "" | Some e -> " else " ^ loop e)
  968. | TWhile (econd,e,flag) ->
  969. (match flag with
  970. | NormalWhile -> sprintf "while (%s) %s" (loop econd) (loop e)
  971. | DoWhile -> sprintf "do (%s) while(%s)" (loop e) (loop econd))
  972. | TSwitch (e,cases,def) ->
  973. let ntabs = tabs ^ "\t" in
  974. 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
  975. s ^ tabs ^ "}"
  976. | TTry (e,cl) ->
  977. 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)
  978. | TReturn None ->
  979. "return"
  980. | TReturn (Some e) ->
  981. sprintf "return %s" (loop e)
  982. | TBreak ->
  983. "break"
  984. | TContinue ->
  985. "continue"
  986. | TThrow e ->
  987. "throw " ^ (loop e)
  988. | TCast (e,None) ->
  989. sprintf "cast %s" (loop e)
  990. | TCast (e,Some mt) ->
  991. sprintf "cast (%s,%s)" (loop e) (s_type_path (t_path mt))
  992. | TMeta ((n,el,_),e) ->
  993. sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
  994. let rec s_expr_ast print_var_ids tabs s_type e =
  995. let sprintf = Printf.sprintf in
  996. let loop ?(extra_tabs="") = s_expr_ast print_var_ids (tabs ^ "\t" ^ extra_tabs) s_type in
  997. let tag_args tabs sl = match sl with
  998. | [] -> ""
  999. | [s] when not (String.contains s '\n') -> " " ^ s
  1000. | _ ->
  1001. let tabs = "\n" ^ tabs ^ "\t" in
  1002. tabs ^ (String.concat tabs sl)
  1003. in
  1004. let tag s ?(t=None) ?(extra_tabs="") sl =
  1005. let st = match t with
  1006. | None -> s_type e.etype
  1007. | Some t -> s_type t
  1008. in
  1009. sprintf "[%s:%s]%s" s st (tag_args (tabs ^ extra_tabs) sl)
  1010. in
  1011. let var_id v = if print_var_ids then v.v_id else 0 in
  1012. let const c = sprintf "[Const %s:%s]" (s_const c) (s_type e.etype) in
  1013. let local v = sprintf "[Local %s(%i):%s]" v.v_name (var_id v) (s_type v.v_type) in
  1014. let var v sl = sprintf "[Var %s(%i):%s]%s" v.v_name (var_id v) (s_type v.v_type) (tag_args tabs sl) in
  1015. let module_type mt = sprintf "[TypeExpr %s:%s]" (s_type_path (t_path mt)) (s_type e.etype) in
  1016. match e.eexpr with
  1017. | TConst c -> const c
  1018. | TLocal v -> local v
  1019. | TArray (e1,e2) -> tag "Array" [loop e1; loop e2]
  1020. | TBinop (op,e1,e2) -> tag "Binop" [loop e1; s_binop op; loop e2]
  1021. | TUnop (op,flag,e1) -> tag "Unop" [s_unop op; if flag = Postfix then "Postfix" else "Prefix"; loop e1]
  1022. | TEnumParameter (e1,ef,i) -> tag "EnumParameter" [loop e1; ef.ef_name; string_of_int i]
  1023. | TField (e1,fa) ->
  1024. let sfa = match fa with
  1025. | FInstance(c,tl,cf) -> tag "FInstance" ~extra_tabs:"\t" [s_type (TInst(c,tl)); cf.cf_name]
  1026. | FStatic(c,cf) -> tag "FStatic" ~extra_tabs:"\t" [s_type_path c.cl_path; cf.cf_name]
  1027. | FClosure(co,cf) -> tag "FClosure" ~extra_tabs:"\t" [(match co with None -> "None" | Some (c,tl) -> s_type (TInst(c,tl))); cf.cf_name]
  1028. | FAnon cf -> tag "FAnon" ~extra_tabs:"\t" [cf.cf_name]
  1029. | FDynamic s -> tag "FDynamic" ~extra_tabs:"\t" [s]
  1030. | FEnum(en,ef) -> tag "FEnum" ~extra_tabs:"\t" [s_type_path en.e_path; ef.ef_name]
  1031. in
  1032. tag "Field" [loop e1; sfa]
  1033. | TTypeExpr mt -> module_type mt
  1034. | TParenthesis e1 -> tag "Parenthesis" [loop e1]
  1035. | TObjectDecl fl -> tag "ObjectDecl" (List.map (fun (s,e) -> sprintf "%s: %s" s (loop e)) fl)
  1036. | TArrayDecl el -> tag "ArrayDecl" (List.map loop el)
  1037. | TCall (e1,el) -> tag "Call" (loop e1 :: (List.map loop el))
  1038. | TNew (c,tl,el) -> tag "New" ((s_type (TInst(c,tl))) :: (List.map loop el))
  1039. | TFunction f ->
  1040. let arg (v,cto) =
  1041. tag "Arg" ~t:(Some v.v_type) ~extra_tabs:"\t" (match cto with None -> [local v] | Some ct -> [local v;const ct])
  1042. in
  1043. tag "Function" ((List.map arg f.tf_args) @ [loop f.tf_expr])
  1044. | TVar (v,eo) -> var v (match eo with None -> [] | Some e -> [loop e])
  1045. | TBlock el -> tag "Block" (List.map loop el)
  1046. | TIf (e,e1,e2) -> tag "If" (loop e :: (Printf.sprintf "[Then:%s] %s" (s_type e1.etype) (loop e1)) :: (match e2 with None -> [] | Some e -> [Printf.sprintf "[Else:%s] %s" (s_type e.etype) (loop e)]))
  1047. | TCast (e1,None) -> tag "Cast" [loop e1]
  1048. | TCast (e1,Some mt) -> tag "Cast" [loop e1; module_type mt]
  1049. | TThrow e1 -> tag "Throw" [loop e1]
  1050. | TBreak -> tag "Break" []
  1051. | TContinue -> tag "Continue" []
  1052. | TReturn None -> tag "Return" []
  1053. | TReturn (Some e1) -> tag "Return" [loop e1]
  1054. | TWhile (e1,e2,NormalWhile) -> tag "While" [loop e1; loop e2]
  1055. | TWhile (e1,e2,DoWhile) -> tag "Do" [loop e1; loop e2]
  1056. | TFor (v,e1,e2) -> tag "For" [local v; loop e1; loop e2]
  1057. | TTry (e1,catches) ->
  1058. let sl = List.map (fun (v,e) ->
  1059. sprintf "Catch %s%s" (local v) (tag_args (tabs ^ "\t") [loop ~extra_tabs:"\t" e]);
  1060. ) catches in
  1061. tag "Try" ((loop e1) :: sl)
  1062. | TSwitch (e1,cases,eo) ->
  1063. let sl = List.map (fun (el,e) ->
  1064. tag "Case" ~t:(Some e.etype) ~extra_tabs:"\t" ((List.map loop el) @ [loop ~extra_tabs:"\t" e])
  1065. ) cases in
  1066. let sl = match eo with
  1067. | None -> sl
  1068. | Some e -> sl @ [tag "Default" ~t:(Some e.etype) ~extra_tabs:"\t" [loop ~extra_tabs:"\t" e]]
  1069. in
  1070. tag "Switch" ((loop e1) :: sl)
  1071. | TMeta ((m,el,_),e1) ->
  1072. let s = Meta.to_string m in
  1073. let s = match el with
  1074. | [] -> s
  1075. | _ -> sprintf "%s(%s)" s (String.concat ", " (List.map Ast.s_expr el))
  1076. in
  1077. tag "Meta" [s; loop e1]
  1078. let s_types ?(sep = ", ") tl =
  1079. let pctx = print_context() in
  1080. String.concat sep (List.map (s_type pctx) tl)
  1081. let s_class_kind = function
  1082. | KNormal ->
  1083. "KNormal"
  1084. | KTypeParameter tl ->
  1085. Printf.sprintf "KTypeParameter [%s]" (s_types tl)
  1086. | KExtension(c,tl) ->
  1087. Printf.sprintf "KExtension %s<%s>" (s_type_path c.cl_path) (s_types tl)
  1088. | KExpr _ ->
  1089. "KExpr"
  1090. | KGeneric ->
  1091. "KGeneric"
  1092. | KGenericInstance(c,tl) ->
  1093. Printf.sprintf "KGenericInstance %s<%s>" (s_type_path c.cl_path) (s_types tl)
  1094. | KMacroType ->
  1095. "KMacroType"
  1096. | KGenericBuild _ ->
  1097. "KGenericBuild"
  1098. | KAbstractImpl a ->
  1099. Printf.sprintf "KAbstractImpl %s" (s_type_path a.a_path)
  1100. (* ======= Unification ======= *)
  1101. let rec link e a b =
  1102. (* tell if setting a == b will create a type-loop *)
  1103. let rec loop t =
  1104. if t == a then
  1105. true
  1106. else match t with
  1107. | TMono t -> (match !t with None -> false | Some t -> loop t)
  1108. | TEnum (_,tl) -> List.exists loop tl
  1109. | TInst (_,tl) | TType (_,tl) | TAbstract (_,tl) -> List.exists loop tl
  1110. | TFun (tl,t) -> List.exists (fun (_,_,t) -> loop t) tl || loop t
  1111. | TDynamic t2 ->
  1112. if t == t2 then
  1113. false
  1114. else
  1115. loop t2
  1116. | TLazy f ->
  1117. loop (!f())
  1118. | TAnon a ->
  1119. try
  1120. PMap.iter (fun _ f -> if loop f.cf_type then raise Exit) a.a_fields;
  1121. false
  1122. with
  1123. Exit -> true
  1124. in
  1125. (* tell is already a ~= b *)
  1126. if loop b then
  1127. (follow b) == a
  1128. else if b == t_dynamic then
  1129. true
  1130. else begin
  1131. e := Some b;
  1132. true
  1133. end
  1134. let rec fast_eq a b =
  1135. if a == b then
  1136. true
  1137. else match a , b with
  1138. | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
  1139. List.for_all2 (fun (_,_,t1) (_,_,t2) -> fast_eq t1 t2) l1 l2 && fast_eq r1 r2
  1140. | TType (t1,l1), TType (t2,l2) ->
  1141. t1 == t2 && List.for_all2 fast_eq l1 l2
  1142. | TEnum (e1,l1), TEnum (e2,l2) ->
  1143. e1 == e2 && List.for_all2 fast_eq l1 l2
  1144. | TInst (c1,l1), TInst (c2,l2) ->
  1145. c1 == c2 && List.for_all2 fast_eq l1 l2
  1146. | TAbstract (a1,l1), TAbstract (a2,l2) ->
  1147. a1 == a2 && List.for_all2 fast_eq l1 l2
  1148. | _ , _ ->
  1149. false
  1150. let rec fast_eq_mono ml a b =
  1151. if a == b then
  1152. true
  1153. else match a , b with
  1154. | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
  1155. List.for_all2 (fun (_,_,t1) (_,_,t2) -> fast_eq_mono ml t1 t2) l1 l2 && fast_eq_mono ml r1 r2
  1156. | TType (t1,l1), TType (t2,l2) ->
  1157. t1 == t2 && List.for_all2 (fast_eq_mono ml) l1 l2
  1158. | TEnum (e1,l1), TEnum (e2,l2) ->
  1159. e1 == e2 && List.for_all2 (fast_eq_mono ml) l1 l2
  1160. | TInst (c1,l1), TInst (c2,l2) ->
  1161. c1 == c2 && List.for_all2 (fast_eq_mono ml) l1 l2
  1162. | TAbstract (a1,l1), TAbstract (a2,l2) ->
  1163. a1 == a2 && List.for_all2 (fast_eq_mono ml) l1 l2
  1164. | TMono _, _ ->
  1165. List.memq a ml
  1166. | _ , _ ->
  1167. false
  1168. (* perform unification with subtyping.
  1169. the first type is always the most down in the class hierarchy
  1170. it's also the one that is pointed by the position.
  1171. It's actually a typecheck of A :> B where some mutations can happen *)
  1172. type unify_error =
  1173. | Cannot_unify of t * t
  1174. | Invalid_field_type of string
  1175. | Has_no_field of t * string
  1176. | Has_no_runtime_field of t * string
  1177. | Has_extra_field of t * string
  1178. | Invalid_kind of string * field_kind * field_kind
  1179. | Invalid_visibility of string
  1180. | Not_matching_optional of string
  1181. | Cant_force_optional
  1182. | Invariant_parameter of t * t
  1183. | Constraint_failure of string
  1184. | Missing_overload of tclass_field * t
  1185. | Unify_custom of string
  1186. exception Unify_error of unify_error list
  1187. let cannot_unify a b = Cannot_unify (a,b)
  1188. let invalid_field n = Invalid_field_type n
  1189. let invalid_kind n a b = Invalid_kind (n,a,b)
  1190. let invalid_visibility n = Invalid_visibility n
  1191. let has_no_field t n = Has_no_field (t,n)
  1192. let has_extra_field t n = Has_extra_field (t,n)
  1193. let error l = raise (Unify_error l)
  1194. let has_meta m ml = List.exists (fun (m2,_,_) -> m = m2) ml
  1195. let get_meta m ml = List.find (fun (m2,_,_) -> m = m2) ml
  1196. let no_meta = []
  1197. (*
  1198. we can restrict access as soon as both are runtime-compatible
  1199. *)
  1200. let unify_access a1 a2 =
  1201. a1 = a2 || match a1, a2 with
  1202. | _, AccNo | _, AccNever -> true
  1203. | AccInline, AccNormal -> true
  1204. | _ -> false
  1205. let direct_access = function
  1206. | AccNo | AccNever | AccNormal | AccInline | AccRequire _ -> true
  1207. | AccResolve | AccCall -> false
  1208. let unify_kind k1 k2 =
  1209. k1 = k2 || match k1, k2 with
  1210. | Var v1, Var v2 -> unify_access v1.v_read v2.v_read && unify_access v1.v_write v2.v_write
  1211. | Var v, Method m ->
  1212. (match v.v_read, v.v_write, m with
  1213. | AccNormal, _, MethNormal -> true
  1214. | AccNormal, AccNormal, MethDynamic -> true
  1215. | _ -> false)
  1216. | Method m, Var v ->
  1217. (match m with
  1218. | MethDynamic -> direct_access v.v_read && direct_access v.v_write
  1219. | MethMacro -> false
  1220. | MethNormal | MethInline ->
  1221. match v.v_read,v.v_write with
  1222. | AccNormal,(AccNo | AccNever) -> true
  1223. | _ -> false)
  1224. | Method m1, Method m2 ->
  1225. match m1,m2 with
  1226. | MethInline, MethNormal
  1227. | MethDynamic, MethNormal -> true
  1228. | _ -> false
  1229. let eq_stack = ref []
  1230. type eq_kind =
  1231. | EqStrict
  1232. | EqCoreType
  1233. | EqRightDynamic
  1234. | EqBothDynamic
  1235. | EqDoNotFollowNull (* like EqStrict, but does not follow Null<T> *)
  1236. let rec type_eq param a b =
  1237. let can_follow t = match param with
  1238. | EqCoreType -> false
  1239. | EqDoNotFollowNull -> not (is_null t)
  1240. | _ -> true
  1241. in
  1242. if a == b then
  1243. ()
  1244. else match a , b with
  1245. | TLazy f , _ -> type_eq param (!f()) b
  1246. | _ , TLazy f -> type_eq param a (!f())
  1247. | TMono t , _ ->
  1248. (match !t with
  1249. | None -> if param = EqCoreType || not (link t a b) then error [cannot_unify a b]
  1250. | Some t -> type_eq param t b)
  1251. | _ , TMono t ->
  1252. (match !t with
  1253. | None -> if param = EqCoreType || not (link t b a) then error [cannot_unify a b]
  1254. | Some t -> type_eq param a t)
  1255. | TType (t1,tl1), TType (t2,tl2) when (t1 == t2 || (param = EqCoreType && t1.t_path = t2.t_path)) && List.length tl1 = List.length tl2 ->
  1256. List.iter2 (type_eq param) tl1 tl2
  1257. | TType (t,tl) , _ when can_follow a ->
  1258. type_eq param (apply_params t.t_params tl t.t_type) b
  1259. | _ , TType (t,tl) when can_follow b ->
  1260. if List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!eq_stack) then
  1261. ()
  1262. else begin
  1263. eq_stack := (a,b) :: !eq_stack;
  1264. try
  1265. type_eq param a (apply_params t.t_params tl t.t_type);
  1266. eq_stack := List.tl !eq_stack;
  1267. with
  1268. Unify_error l ->
  1269. eq_stack := List.tl !eq_stack;
  1270. error (cannot_unify a b :: l)
  1271. end
  1272. | TEnum (e1,tl1) , TEnum (e2,tl2) ->
  1273. if e1 != e2 && not (param = EqCoreType && e1.e_path = e2.e_path) then error [cannot_unify a b];
  1274. List.iter2 (type_eq param) tl1 tl2
  1275. | TInst (c1,tl1) , TInst (c2,tl2) ->
  1276. 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];
  1277. List.iter2 (type_eq param) tl1 tl2
  1278. | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
  1279. (try
  1280. type_eq param r1 r2;
  1281. List.iter2 (fun (n,o1,t1) (_,o2,t2) ->
  1282. if o1 <> o2 then error [Not_matching_optional n];
  1283. type_eq param t1 t2
  1284. ) l1 l2
  1285. with
  1286. Unify_error l -> error (cannot_unify a b :: l))
  1287. | TDynamic a , TDynamic b ->
  1288. type_eq param a b
  1289. | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
  1290. if a1 != a2 && not (param = EqCoreType && a1.a_path = a2.a_path) then error [cannot_unify a b];
  1291. List.iter2 (type_eq param) tl1 tl2
  1292. | TAnon a1, TAnon a2 ->
  1293. (try
  1294. PMap.iter (fun n f1 ->
  1295. try
  1296. let f2 = PMap.find n a2.a_fields in
  1297. 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];
  1298. try
  1299. type_eq param f1.cf_type f2.cf_type
  1300. with
  1301. Unify_error l -> error (invalid_field n :: l)
  1302. with
  1303. Not_found ->
  1304. if is_closed a2 then error [has_no_field b n];
  1305. if not (link (ref None) b f1.cf_type) then error [cannot_unify a b];
  1306. a2.a_fields <- PMap.add n f1 a2.a_fields
  1307. ) a1.a_fields;
  1308. PMap.iter (fun n f2 ->
  1309. if not (PMap.mem n a1.a_fields) then begin
  1310. if is_closed a1 then error [has_no_field a n];
  1311. if not (link (ref None) a f2.cf_type) then error [cannot_unify a b];
  1312. a1.a_fields <- PMap.add n f2 a1.a_fields
  1313. end;
  1314. ) a2.a_fields;
  1315. with
  1316. Unify_error l -> error (cannot_unify a b :: l))
  1317. | _ , _ ->
  1318. if b == t_dynamic && (param = EqRightDynamic || param = EqBothDynamic) then
  1319. ()
  1320. else if a == t_dynamic && param = EqBothDynamic then
  1321. ()
  1322. else
  1323. error [cannot_unify a b]
  1324. let type_iseq a b =
  1325. try
  1326. type_eq EqStrict a b;
  1327. true
  1328. with
  1329. Unify_error _ -> false
  1330. let type_iseq_strict a b =
  1331. try
  1332. type_eq EqDoNotFollowNull a b;
  1333. true
  1334. with Unify_error _ ->
  1335. false
  1336. let unify_stack = ref []
  1337. let abstract_cast_stack = ref []
  1338. let unify_new_monos = ref []
  1339. let rec unify a b =
  1340. if a == b then
  1341. ()
  1342. else match a, b with
  1343. | TLazy f , _ -> unify (!f()) b
  1344. | _ , TLazy f -> unify a (!f())
  1345. | TMono t , _ ->
  1346. (match !t with
  1347. | None -> if not (link t a b) then error [cannot_unify a b]
  1348. | Some t -> unify t b)
  1349. | _ , TMono t ->
  1350. (match !t with
  1351. | None -> if not (link t b a) then error [cannot_unify a b]
  1352. | Some t -> unify a t)
  1353. | TType (t,tl) , _ ->
  1354. if not (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!unify_stack)) then begin
  1355. try
  1356. unify_stack := (a,b) :: !unify_stack;
  1357. unify (apply_params t.t_params tl t.t_type) b;
  1358. unify_stack := List.tl !unify_stack;
  1359. with
  1360. Unify_error l ->
  1361. unify_stack := List.tl !unify_stack;
  1362. error (cannot_unify a b :: l)
  1363. end
  1364. | _ , TType (t,tl) ->
  1365. if not (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!unify_stack)) then begin
  1366. try
  1367. unify_stack := (a,b) :: !unify_stack;
  1368. unify a (apply_params t.t_params tl t.t_type);
  1369. unify_stack := List.tl !unify_stack;
  1370. with
  1371. Unify_error l ->
  1372. unify_stack := List.tl !unify_stack;
  1373. error (cannot_unify a b :: l)
  1374. end
  1375. | TEnum (ea,tl1) , TEnum (eb,tl2) ->
  1376. if ea != eb then error [cannot_unify a b];
  1377. unify_type_params a b tl1 tl2
  1378. | TAbstract (a1,tl1) , TAbstract (a2,tl2) when a1 == a2 ->
  1379. begin try
  1380. unify_type_params a b tl1 tl2
  1381. with Unify_error _ as err ->
  1382. (* the type could still have a from/to relation to itself (issue #3494) *)
  1383. begin try
  1384. unify_abstracts a b a1 tl1 a2 tl2
  1385. with Unify_error _ ->
  1386. raise err
  1387. end
  1388. end
  1389. | TAbstract ({a_path=[],"Void"},_) , _
  1390. | _ , TAbstract ({a_path=[],"Void"},_) ->
  1391. error [cannot_unify a b]
  1392. | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
  1393. unify_abstracts a b a1 tl1 a2 tl2
  1394. | TInst (c1,tl1) , TInst (c2,tl2) ->
  1395. let rec loop c tl =
  1396. if c == c2 then begin
  1397. unify_type_params a b tl tl2;
  1398. true
  1399. end else (match c.cl_super with
  1400. | None -> false
  1401. | Some (cs,tls) ->
  1402. loop cs (List.map (apply_params c.cl_params tl) tls)
  1403. ) || List.exists (fun (cs,tls) ->
  1404. loop cs (List.map (apply_params c.cl_params tl) tls)
  1405. ) c.cl_implements
  1406. || (match c.cl_kind with
  1407. | KTypeParameter pl -> List.exists (fun t -> match follow t with TInst (cs,tls) -> loop cs (List.map (apply_params c.cl_params tl) tls) | _ -> false) pl
  1408. | _ -> false)
  1409. in
  1410. if not (loop c1 tl1) then error [cannot_unify a b]
  1411. | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
  1412. let i = ref 0 in
  1413. (try
  1414. (match r2 with
  1415. | TAbstract ({a_path=[],"Void"},_) -> incr i
  1416. | _ -> unify r1 r2; incr i);
  1417. List.iter2 (fun (_,o1,t1) (_,o2,t2) ->
  1418. if o1 && not o2 then error [Cant_force_optional];
  1419. unify t1 t2;
  1420. incr i
  1421. ) l2 l1 (* contravariance *)
  1422. with
  1423. Unify_error l ->
  1424. let msg = if !i = 0 then "Cannot unify return types" else "Cannot unify argument " ^ (string_of_int !i) in
  1425. error (cannot_unify a b :: Unify_custom msg :: l))
  1426. | TInst (c,tl) , TAnon an ->
  1427. if PMap.is_empty an.a_fields then (match c.cl_kind with
  1428. | KTypeParameter pl ->
  1429. (* one of the constraints must unify with { } *)
  1430. if not (List.exists (fun t -> match follow t with TInst _ | TAnon _ -> true | _ -> false) pl) then error [cannot_unify a b]
  1431. | _ -> ());
  1432. (try
  1433. PMap.iter (fun n f2 ->
  1434. (*
  1435. introducing monomorphs while unifying might create infinite loops - see #2315
  1436. let's store these monomorphs and make sure we reach a fixed point
  1437. *)
  1438. let monos = ref [] in
  1439. let make_type f =
  1440. match f.cf_params with
  1441. | [] -> f.cf_type
  1442. | l ->
  1443. let ml = List.map (fun _ -> mk_mono()) l in
  1444. monos := ml;
  1445. apply_params f.cf_params ml f.cf_type
  1446. in
  1447. let _, ft, f1 = (try raw_class_field make_type c tl n with Not_found -> error [has_no_field a n]) in
  1448. let ft = apply_params c.cl_params tl ft in
  1449. if not (unify_kind f1.cf_kind f2.cf_kind) then error [invalid_kind n f1.cf_kind f2.cf_kind];
  1450. if f2.cf_public && not f1.cf_public then error [invalid_visibility n];
  1451. let old_monos = !unify_new_monos in
  1452. unify_new_monos := !monos @ !unify_new_monos;
  1453. if not (List.exists (fun (a2,b2) -> fast_eq b2 f2.cf_type && fast_eq_mono !unify_new_monos ft a2) (!unify_stack)) then begin
  1454. unify_stack := (ft,f2.cf_type) :: !unify_stack;
  1455. (try
  1456. unify_with_access ft f2
  1457. with
  1458. Unify_error l ->
  1459. unify_new_monos := old_monos;
  1460. unify_stack := List.tl !unify_stack;
  1461. error (invalid_field n :: l));
  1462. unify_stack := List.tl !unify_stack;
  1463. end;
  1464. unify_new_monos := old_monos;
  1465. List.iter (fun f2o ->
  1466. if not (List.exists (fun f1o -> type_iseq f1o.cf_type f2o.cf_type) (f1 :: f1.cf_overloads))
  1467. then error [Missing_overload (f1, f2o.cf_type)]
  1468. ) f2.cf_overloads;
  1469. (* we mark the field as :?used because it might be used through the structure *)
  1470. if not (Meta.has Meta.MaybeUsed f1.cf_meta) then f1.cf_meta <- (Meta.MaybeUsed,[],f1.cf_pos) :: f1.cf_meta;
  1471. (match f1.cf_kind with
  1472. | Method MethInline ->
  1473. if (c.cl_extern || Meta.has Meta.Extern f1.cf_meta) && not (Meta.has Meta.Runtime f1.cf_meta) then error [Has_no_runtime_field (a,n)];
  1474. | _ -> ());
  1475. ) an.a_fields;
  1476. (match !(an.a_status) with
  1477. | Opened -> an.a_status := Closed;
  1478. | Statics _ | EnumStatics _ | AbstractStatics _ -> error []
  1479. | Closed | Extend _ | Const -> ())
  1480. with
  1481. Unify_error l -> error (cannot_unify a b :: l))
  1482. | TAnon a1, TAnon a2 ->
  1483. unify_anons a b a1 a2
  1484. | TAnon an, TAbstract ({ a_path = [],"Class" },[pt]) ->
  1485. (match !(an.a_status) with
  1486. | Statics cl -> unify (TInst (cl,List.map (fun _ -> mk_mono()) cl.cl_params)) pt
  1487. | _ -> error [cannot_unify a b])
  1488. | TAnon an, TAbstract ({ a_path = [],"Enum" },[pt]) ->
  1489. (match !(an.a_status) with
  1490. | EnumStatics e -> unify (TEnum (e,List.map (fun _ -> mk_mono()) e.e_params)) pt
  1491. | _ -> error [cannot_unify a b])
  1492. | TEnum _, TAbstract ({ a_path = [],"EnumValue" },[]) ->
  1493. ()
  1494. | TEnum(en,_), TAbstract ({ a_path = ["haxe"],"FlatEnum" },[]) when Meta.has Meta.FlatEnum en.e_meta ->
  1495. ()
  1496. | TFun _, TAbstract ({ a_path = ["haxe"],"Function" },[]) ->
  1497. ()
  1498. | TDynamic t , _ ->
  1499. if t == a then
  1500. ()
  1501. else (match b with
  1502. | TDynamic t2 ->
  1503. if t2 != b then
  1504. (try
  1505. type_eq EqRightDynamic t t2
  1506. with
  1507. Unify_error l -> error (cannot_unify a b :: l));
  1508. | TAbstract(bb,tl) when (List.exists (unify_from bb tl a b) bb.a_from) ->
  1509. ()
  1510. | _ ->
  1511. error [cannot_unify a b])
  1512. | _ , TDynamic t ->
  1513. if t == b then
  1514. ()
  1515. else (match a with
  1516. | TDynamic t2 ->
  1517. if t2 != a then
  1518. (try
  1519. type_eq EqRightDynamic t t2
  1520. with
  1521. Unify_error l -> error (cannot_unify a b :: l));
  1522. | TAnon an ->
  1523. (try
  1524. (match !(an.a_status) with
  1525. | Statics _ | EnumStatics _ -> error []
  1526. | Opened -> an.a_status := Closed
  1527. | _ -> ());
  1528. PMap.iter (fun _ f ->
  1529. try
  1530. type_eq EqStrict (field_type f) t
  1531. with Unify_error l ->
  1532. error (invalid_field f.cf_name :: l)
  1533. ) an.a_fields
  1534. with Unify_error l ->
  1535. error (cannot_unify a b :: l))
  1536. | TAbstract(aa,tl) when (List.exists (unify_to aa tl b) aa.a_to) ->
  1537. ()
  1538. | _ ->
  1539. error [cannot_unify a b])
  1540. | TAbstract (aa,tl), _ ->
  1541. if not (List.exists (unify_to aa tl b) aa.a_to) then error [cannot_unify a b];
  1542. | TInst ({ cl_kind = KTypeParameter ctl } as c,pl), TAbstract (bb,tl) ->
  1543. (* one of the constraints must satisfy the abstract *)
  1544. if not (List.exists (fun t ->
  1545. let t = apply_params c.cl_params pl t in
  1546. try unify t b; true with Unify_error _ -> false
  1547. ) ctl) && not (List.exists (unify_from bb tl a b) bb.a_from) then error [cannot_unify a b];
  1548. | _, TAbstract (bb,tl) ->
  1549. if not (List.exists (unify_from bb tl a b) bb.a_from) then error [cannot_unify a b]
  1550. | _ , _ ->
  1551. error [cannot_unify a b]
  1552. and unify_abstracts a b a1 tl1 a2 tl2 =
  1553. let f1 = unify_to a1 tl1 b in
  1554. let f2 = unify_from a2 tl2 a b in
  1555. if (List.exists (f1 ~allow_transitive_cast:false) a1.a_to)
  1556. || (List.exists (f2 ~allow_transitive_cast:false) a2.a_from)
  1557. || (((Meta.has Meta.CoreType a1.a_meta) || (Meta.has Meta.CoreType a2.a_meta))
  1558. && ((List.exists f1 a1.a_to) || (List.exists f2 a2.a_from))) then
  1559. ()
  1560. else
  1561. error [cannot_unify a b]
  1562. and unify_anons a b a1 a2 =
  1563. (try
  1564. PMap.iter (fun n f2 ->
  1565. try
  1566. let f1 = PMap.find n a1.a_fields in
  1567. if not (unify_kind f1.cf_kind f2.cf_kind) then
  1568. (match !(a1.a_status), f1.cf_kind, f2.cf_kind with
  1569. | Opened, Var { v_read = AccNormal; v_write = AccNo }, Var { v_read = AccNormal; v_write = AccNormal } ->
  1570. f1.cf_kind <- f2.cf_kind;
  1571. | _ -> error [invalid_kind n f1.cf_kind f2.cf_kind]);
  1572. if f2.cf_public && not f1.cf_public then error [invalid_visibility n];
  1573. try
  1574. unify_with_access f1.cf_type f2;
  1575. (match !(a1.a_status) with
  1576. | Statics c when not (Meta.has Meta.MaybeUsed f1.cf_meta) -> f1.cf_meta <- (Meta.MaybeUsed,[],f1.cf_pos) :: f1.cf_meta
  1577. | _ -> ());
  1578. with
  1579. Unify_error l -> error (invalid_field n :: l)
  1580. with
  1581. Not_found ->
  1582. match !(a1.a_status) with
  1583. | Opened ->
  1584. if not (link (ref None) a f2.cf_type) then error [];
  1585. a1.a_fields <- PMap.add n f2 a1.a_fields
  1586. | Const when Meta.has Meta.Optional f2.cf_meta ->
  1587. ()
  1588. | _ ->
  1589. error [has_no_field a n];
  1590. ) a2.a_fields;
  1591. (match !(a1.a_status) with
  1592. | Const when not (PMap.is_empty a2.a_fields) ->
  1593. PMap.iter (fun n _ -> if not (PMap.mem n a2.a_fields) then error [has_extra_field a n]) a1.a_fields;
  1594. | Opened ->
  1595. a1.a_status := Closed
  1596. | _ -> ());
  1597. (match !(a2.a_status) with
  1598. | Statics c -> (match !(a1.a_status) with Statics c2 when c == c2 -> () | _ -> error [])
  1599. | EnumStatics e -> (match !(a1.a_status) with EnumStatics e2 when e == e2 -> () | _ -> error [])
  1600. | AbstractStatics a -> (match !(a1.a_status) with AbstractStatics a2 when a == a2 -> () | _ -> error [])
  1601. | Opened -> a2.a_status := Closed
  1602. | Const | Extend _ | Closed -> ())
  1603. with
  1604. Unify_error l -> error (cannot_unify a b :: l))
  1605. and unify_from ab tl a b ?(allow_transitive_cast=true) t =
  1606. if (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
  1607. abstract_cast_stack := (a,b) :: !abstract_cast_stack;
  1608. let t = apply_params ab.a_params tl t in
  1609. let unify_func = if allow_transitive_cast then unify else type_eq EqStrict in
  1610. let b = try
  1611. unify_func a t;
  1612. true
  1613. with Unify_error _ ->
  1614. false
  1615. in
  1616. abstract_cast_stack := List.tl !abstract_cast_stack;
  1617. b
  1618. end
  1619. and unify_to ab tl b ?(allow_transitive_cast=true) t =
  1620. let t = apply_params ab.a_params tl t in
  1621. let unify_func = if allow_transitive_cast then unify else type_eq EqStrict in
  1622. try
  1623. unify_func t b;
  1624. true
  1625. with Unify_error _ ->
  1626. false
  1627. and unify_from_field ab tl a b ?(allow_transitive_cast=true) (t,cf) =
  1628. if (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
  1629. abstract_cast_stack := (a,b) :: !abstract_cast_stack;
  1630. let unify_func = if allow_transitive_cast then unify else type_eq EqStrict in
  1631. let b = try
  1632. begin match follow cf.cf_type with
  1633. | TFun(_,r) ->
  1634. let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
  1635. let map t = apply_params ab.a_params tl (apply_params cf.cf_params monos t) in
  1636. unify_func a (map t);
  1637. List.iter2 (fun m (name,t) -> match follow t with
  1638. | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
  1639. List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> unify m (map tc) ) constr
  1640. | _ -> ()
  1641. ) monos cf.cf_params;
  1642. unify_func (map r) b;
  1643. | _ -> assert false
  1644. end;
  1645. true
  1646. with Unify_error _ -> false
  1647. in
  1648. abstract_cast_stack := List.tl !abstract_cast_stack;
  1649. b
  1650. end
  1651. and unify_to_field ab tl b ?(allow_transitive_cast=true) (t,cf) =
  1652. let a = TAbstract(ab,tl) in
  1653. if (List.exists (fun (b2,a2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
  1654. abstract_cast_stack := (b,a) :: !abstract_cast_stack;
  1655. let unify_func = if allow_transitive_cast then unify else type_eq EqStrict in
  1656. let r = try
  1657. begin match follow cf.cf_type with
  1658. | TFun((_,_,ta) :: _,_) ->
  1659. let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
  1660. let map t = apply_params ab.a_params tl (apply_params cf.cf_params monos t) in
  1661. let athis = map ab.a_this in
  1662. (* we cannot allow implicit casts when the this type is not completely known yet *)
  1663. (* if has_mono athis then raise (Unify_error []); *)
  1664. with_variance (type_eq EqStrict) athis (map ta);
  1665. (* immediate constraints checking is ok here because we know there are no monomorphs *)
  1666. List.iter2 (fun m (name,t) -> match follow t with
  1667. | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
  1668. List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> unify m (map tc) ) constr
  1669. | _ -> ()
  1670. ) monos cf.cf_params;
  1671. unify_func (map t) b;
  1672. | _ -> assert false
  1673. end;
  1674. true
  1675. with Unify_error _ -> false
  1676. in
  1677. abstract_cast_stack := List.tl !abstract_cast_stack;
  1678. r
  1679. end
  1680. and unify_with_variance f t1 t2 =
  1681. let allows_variance_to t tf = type_iseq tf t in
  1682. match follow t1,follow t2 with
  1683. | TInst(c1,tl1),TInst(c2,tl2) when c1 == c2 ->
  1684. List.iter2 f tl1 tl2
  1685. | TEnum(en1,tl1),TEnum(en2,tl2) when en1 == en2 ->
  1686. List.iter2 f tl1 tl2
  1687. | TAbstract(a1,tl1),TAbstract(a2,tl2) when a1 == a2 && Meta.has Meta.CoreType a1.a_meta ->
  1688. List.iter2 f tl1 tl2
  1689. | TAbstract(a1,pl1),TAbstract(a2,pl2) ->
  1690. if (Meta.has Meta.CoreType a1.a_meta) && (Meta.has Meta.CoreType a2.a_meta) then begin
  1691. let ta1 = apply_params a1.a_params pl1 a1.a_this in
  1692. let ta2 = apply_params a2.a_params pl2 a2.a_this in
  1693. type_eq EqStrict ta1 ta2;
  1694. end;
  1695. if not (List.exists (allows_variance_to t2) a1.a_to) && not (List.exists (allows_variance_to t1) a2.a_from) then
  1696. error [cannot_unify t1 t2]
  1697. | TAbstract(a,pl),t ->
  1698. type_eq EqBothDynamic (apply_params a.a_params pl a.a_this) t;
  1699. if not (List.exists (fun t2 -> allows_variance_to t (apply_params a.a_params pl t2)) a.a_to) then error [cannot_unify t1 t2]
  1700. | t,TAbstract(a,pl) ->
  1701. type_eq EqBothDynamic t (apply_params a.a_params pl a.a_this);
  1702. if not (List.exists (fun t2 -> allows_variance_to t (apply_params a.a_params pl t2)) a.a_from) then error [cannot_unify t1 t2]
  1703. | TAnon a1,TAnon a2 ->
  1704. unify_anons t1 t2 a1 a2
  1705. | _ ->
  1706. error [cannot_unify t1 t2]
  1707. and unify_type_params a b tl1 tl2 =
  1708. List.iter2 (fun t1 t2 ->
  1709. try
  1710. with_variance (type_eq EqRightDynamic) t1 t2
  1711. with Unify_error l ->
  1712. let err = cannot_unify a b in
  1713. error (err :: (Invariant_parameter (t1,t2)) :: l)
  1714. ) tl1 tl2
  1715. and with_variance f t1 t2 =
  1716. try
  1717. f t1 t2
  1718. with Unify_error l -> try
  1719. unify_with_variance (with_variance f) t1 t2
  1720. with Unify_error _ ->
  1721. raise (Unify_error l)
  1722. and unify_with_access t1 f2 =
  1723. match f2.cf_kind with
  1724. (* write only *)
  1725. | Var { v_read = AccNo } | Var { v_read = AccNever } -> unify f2.cf_type t1
  1726. (* read only *)
  1727. | Method MethNormal | Method MethInline | Var { v_write = AccNo } | Var { v_write = AccNever } -> unify t1 f2.cf_type
  1728. (* read/write *)
  1729. | _ -> with_variance (type_eq EqBothDynamic) t1 f2.cf_type
  1730. module Abstract = struct
  1731. open Ast
  1732. let find_to ab pl b =
  1733. if follow b == t_dynamic then
  1734. List.find (fun (t,_) -> follow t == t_dynamic) ab.a_to_field
  1735. else if List.exists (unify_to ab pl ~allow_transitive_cast:false b) ab.a_to then
  1736. raise Not_found (* legacy compatibility *)
  1737. else
  1738. List.find (unify_to_field ab pl b) ab.a_to_field
  1739. let find_from ab pl a b =
  1740. if follow a == t_dynamic then
  1741. List.find (fun (t,_) -> follow t == t_dynamic) ab.a_from_field
  1742. else if List.exists (unify_from ab pl a ~allow_transitive_cast:false b) ab.a_from then
  1743. raise Not_found (* legacy compatibility *)
  1744. else
  1745. List.find (unify_from_field ab pl a b) ab.a_from_field
  1746. let underlying_type_stack = ref []
  1747. let rec get_underlying_type a pl =
  1748. let maybe_recurse t =
  1749. underlying_type_stack := a :: !underlying_type_stack;
  1750. let t = match follow t with
  1751. | TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
  1752. if List.mem a !underlying_type_stack then begin
  1753. let s = String.concat " -> " (List.map (fun a -> s_type_path a.a_path) (List.rev (a :: !underlying_type_stack))) in
  1754. raise (Error("Abstract chain detected: " ^ s,a.a_pos))
  1755. end;
  1756. get_underlying_type a tl
  1757. | _ ->
  1758. t
  1759. in
  1760. underlying_type_stack := List.tl !underlying_type_stack;
  1761. t
  1762. in
  1763. try
  1764. if not (Meta.has Meta.MultiType a.a_meta) then raise Not_found;
  1765. let m = mk_mono() in
  1766. let _ = find_to a pl m in
  1767. maybe_recurse (follow m)
  1768. with Not_found ->
  1769. if Meta.has Meta.CoreType a.a_meta then
  1770. t_dynamic
  1771. else
  1772. maybe_recurse (apply_params a.a_params pl a.a_this)
  1773. let rec follow_with_abstracts t = match follow t with
  1774. | TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
  1775. follow_with_abstracts (get_underlying_type a tl)
  1776. | t ->
  1777. t
  1778. end
  1779. (* ======= Mapping and iterating ======= *)
  1780. let iter_dt f dt = match dt with
  1781. | DTBind(_,dt) -> f dt
  1782. | DTSwitch(_,cl,dto) ->
  1783. List.iter (fun (_,dt) -> f dt) cl;
  1784. (match dto with None -> () | Some dt -> f dt)
  1785. | DTGuard(_,dt1,dt2) ->
  1786. f dt1;
  1787. (match dt2 with None -> () | Some dt -> f dt)
  1788. | DTGoto _ | DTExpr _ -> ()
  1789. let iter f e =
  1790. match e.eexpr with
  1791. | TConst _
  1792. | TLocal _
  1793. | TBreak
  1794. | TContinue
  1795. | TTypeExpr _ ->
  1796. ()
  1797. | TArray (e1,e2)
  1798. | TBinop (_,e1,e2)
  1799. | TFor (_,e1,e2)
  1800. | TWhile (e1,e2,_) ->
  1801. f e1;
  1802. f e2;
  1803. | TThrow e
  1804. | TField (e,_)
  1805. | TEnumParameter (e,_,_)
  1806. | TParenthesis e
  1807. | TCast (e,_)
  1808. | TUnop (_,_,e)
  1809. | TMeta(_,e) ->
  1810. f e
  1811. | TArrayDecl el
  1812. | TNew (_,_,el)
  1813. | TBlock el ->
  1814. List.iter f el
  1815. | TObjectDecl fl ->
  1816. List.iter (fun (_,e) -> f e) fl
  1817. | TCall (e,el) ->
  1818. f e;
  1819. List.iter f el
  1820. | TVar (v,eo) ->
  1821. (match eo with None -> () | Some e -> f e)
  1822. | TFunction fu ->
  1823. f fu.tf_expr
  1824. | TIf (e,e1,e2) ->
  1825. f e;
  1826. f e1;
  1827. (match e2 with None -> () | Some e -> f e)
  1828. | TSwitch (e,cases,def) ->
  1829. f e;
  1830. List.iter (fun (el,e2) -> List.iter f el; f e2) cases;
  1831. (match def with None -> () | Some e -> f e)
  1832. | TTry (e,catches) ->
  1833. f e;
  1834. List.iter (fun (_,e) -> f e) catches
  1835. | TReturn eo ->
  1836. (match eo with None -> () | Some e -> f e)
  1837. let map_expr f e =
  1838. match e.eexpr with
  1839. | TConst _
  1840. | TLocal _
  1841. | TBreak
  1842. | TContinue
  1843. | TTypeExpr _ ->
  1844. e
  1845. | TArray (e1,e2) ->
  1846. let e1 = f e1 in
  1847. { e with eexpr = TArray (e1,f e2) }
  1848. | TBinop (op,e1,e2) ->
  1849. let e1 = f e1 in
  1850. { e with eexpr = TBinop (op,e1,f e2) }
  1851. | TFor (v,e1,e2) ->
  1852. let e1 = f e1 in
  1853. { e with eexpr = TFor (v,e1,f e2) }
  1854. | TWhile (e1,e2,flag) ->
  1855. let e1 = f e1 in
  1856. { e with eexpr = TWhile (e1,f e2,flag) }
  1857. | TThrow e1 ->
  1858. { e with eexpr = TThrow (f e1) }
  1859. | TEnumParameter (e1,ef,i) ->
  1860. { e with eexpr = TEnumParameter(f e1,ef,i) }
  1861. | TField (e1,v) ->
  1862. { e with eexpr = TField (f e1,v) }
  1863. | TParenthesis e1 ->
  1864. { e with eexpr = TParenthesis (f e1) }
  1865. | TUnop (op,pre,e1) ->
  1866. { e with eexpr = TUnop (op,pre,f e1) }
  1867. | TArrayDecl el ->
  1868. { e with eexpr = TArrayDecl (List.map f el) }
  1869. | TNew (t,pl,el) ->
  1870. { e with eexpr = TNew (t,pl,List.map f el) }
  1871. | TBlock el ->
  1872. { e with eexpr = TBlock (List.map f el) }
  1873. | TObjectDecl el ->
  1874. { e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el) }
  1875. | TCall (e1,el) ->
  1876. { e with eexpr = TCall (f e1, List.map f el) }
  1877. | TVar (v,eo) ->
  1878. { e with eexpr = TVar (v, match eo with None -> None | Some e -> Some (f e)) }
  1879. | TFunction fu ->
  1880. { e with eexpr = TFunction { fu with tf_expr = f fu.tf_expr } }
  1881. | TIf (ec,e1,e2) ->
  1882. let ec = f ec in
  1883. let e1 = f e1 in
  1884. { e with eexpr = TIf (ec,e1,match e2 with None -> None | Some e -> Some (f e)) }
  1885. | TSwitch (e1,cases,def) ->
  1886. let e1 = f e1 in
  1887. let cases = List.map (fun (el,e2) -> List.map f el, f e2) cases in
  1888. { e with eexpr = TSwitch (e1, cases, match def with None -> None | Some e -> Some (f e)) }
  1889. | TTry (e1,catches) ->
  1890. let e1 = f e1 in
  1891. { e with eexpr = TTry (e1, List.map (fun (v,e) -> v, f e) catches) }
  1892. | TReturn eo ->
  1893. { e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)) }
  1894. | TCast (e1,t) ->
  1895. { e with eexpr = TCast (f e1,t) }
  1896. | TMeta (m,e1) ->
  1897. {e with eexpr = TMeta(m,f e1)}
  1898. let map_expr_type f ft fv e =
  1899. match e.eexpr with
  1900. | TConst _
  1901. | TBreak
  1902. | TContinue
  1903. | TTypeExpr _ ->
  1904. { e with etype = ft e.etype }
  1905. | TLocal v ->
  1906. { e with eexpr = TLocal (fv v); etype = ft e.etype }
  1907. | TArray (e1,e2) ->
  1908. let e1 = f e1 in
  1909. { e with eexpr = TArray (e1,f e2); etype = ft e.etype }
  1910. | TBinop (op,e1,e2) ->
  1911. let e1 = f e1 in
  1912. { e with eexpr = TBinop (op,e1,f e2); etype = ft e.etype }
  1913. | TFor (v,e1,e2) ->
  1914. let v = fv v in
  1915. let e1 = f e1 in
  1916. { e with eexpr = TFor (v,e1,f e2); etype = ft e.etype }
  1917. | TWhile (e1,e2,flag) ->
  1918. let e1 = f e1 in
  1919. { e with eexpr = TWhile (e1,f e2,flag); etype = ft e.etype }
  1920. | TThrow e1 ->
  1921. { e with eexpr = TThrow (f e1); etype = ft e.etype }
  1922. | TEnumParameter (e1,ef,i) ->
  1923. { e with eexpr = TEnumParameter(f e1,ef,i); etype = ft e.etype }
  1924. | TField (e1,v) ->
  1925. let e1 = f e1 in
  1926. let v = try
  1927. let n = match v with
  1928. | FClosure _ -> raise Not_found
  1929. | FAnon f | FInstance (_,_,f) | FStatic (_,f) -> f.cf_name
  1930. | FEnum (_,f) -> f.ef_name
  1931. | FDynamic n -> n
  1932. in
  1933. quick_field e1.etype n
  1934. with Not_found ->
  1935. v
  1936. in
  1937. { e with eexpr = TField (e1,v); etype = ft e.etype }
  1938. | TParenthesis e1 ->
  1939. { e with eexpr = TParenthesis (f e1); etype = ft e.etype }
  1940. | TUnop (op,pre,e1) ->
  1941. { e with eexpr = TUnop (op,pre,f e1); etype = ft e.etype }
  1942. | TArrayDecl el ->
  1943. { e with eexpr = TArrayDecl (List.map f el); etype = ft e.etype }
  1944. | TNew (c,pl,el) ->
  1945. let et = ft e.etype in
  1946. (* make sure that we use the class corresponding to the replaced type *)
  1947. let t = match c.cl_kind with
  1948. | KTypeParameter _ | KGeneric ->
  1949. et
  1950. | _ ->
  1951. ft (TInst(c,pl))
  1952. in
  1953. 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
  1954. { e with eexpr = TNew (c,pl,List.map f el); etype = et }
  1955. | TBlock el ->
  1956. { e with eexpr = TBlock (List.map f el); etype = ft e.etype }
  1957. | TObjectDecl el ->
  1958. { e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el); etype = ft e.etype }
  1959. | TCall (e1,el) ->
  1960. let e1 = f e1 in
  1961. { e with eexpr = TCall (e1, List.map f el); etype = ft e.etype }
  1962. | TVar (v,eo) ->
  1963. { e with eexpr = TVar (fv v, match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }
  1964. | TFunction fu ->
  1965. let fu = {
  1966. tf_expr = f fu.tf_expr;
  1967. tf_args = List.map (fun (v,o) -> fv v, o) fu.tf_args;
  1968. tf_type = ft fu.tf_type;
  1969. } in
  1970. { e with eexpr = TFunction fu; etype = ft e.etype }
  1971. | TIf (ec,e1,e2) ->
  1972. let ec = f ec in
  1973. let e1 = f e1 in
  1974. { e with eexpr = TIf (ec,e1,match e2 with None -> None | Some e -> Some (f e)); etype = ft e.etype }
  1975. | TSwitch (e1,cases,def) ->
  1976. let e1 = f e1 in
  1977. let cases = List.map (fun (el,e2) -> List.map f el, f e2) cases in
  1978. { e with eexpr = TSwitch (e1, cases, match def with None -> None | Some e -> Some (f e)); etype = ft e.etype }
  1979. | TTry (e1,catches) ->
  1980. let e1 = f e1 in
  1981. { e with eexpr = TTry (e1, List.map (fun (v,e) -> fv v, f e) catches); etype = ft e.etype }
  1982. | TReturn eo ->
  1983. { e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }
  1984. | TCast (e1,t) ->
  1985. { e with eexpr = TCast (f e1,t); etype = ft e.etype }
  1986. | TMeta (m,e1) ->
  1987. {e with eexpr = TMeta(m, f e1); etype = ft e.etype }
  1988. module TExprToExpr = struct
  1989. let tpath p mp pl =
  1990. if snd mp = snd p then
  1991. CTPath {
  1992. tpackage = fst p;
  1993. tname = snd p;
  1994. tparams = List.map (fun t -> TPType t) pl;
  1995. tsub = None;
  1996. }
  1997. else CTPath {
  1998. tpackage = fst mp;
  1999. tname = snd mp;
  2000. tparams = List.map (fun t -> TPType t) pl;
  2001. tsub = Some (snd p);
  2002. }
  2003. let rec convert_type = function
  2004. | TMono r ->
  2005. (match !r with
  2006. | None -> raise Exit
  2007. | Some t -> convert_type t)
  2008. | TInst ({cl_private = true; cl_path=_,name},tl)
  2009. | TEnum ({e_private = true; e_path=_,name},tl)
  2010. | TType ({t_private = true; t_path=_,name},tl)
  2011. | TAbstract ({a_private = true; a_path=_,name},tl) ->
  2012. CTPath {
  2013. tpackage = [];
  2014. tname = name;
  2015. tparams = List.map (fun t -> TPType (convert_type t)) tl;
  2016. tsub = None;
  2017. }
  2018. | TEnum (e,pl) ->
  2019. tpath e.e_path e.e_module.m_path (List.map convert_type pl)
  2020. | TInst({cl_kind = KTypeParameter _} as c,pl) ->
  2021. tpath ([],snd c.cl_path) ([],snd c.cl_path) (List.map convert_type pl)
  2022. | TInst (c,pl) ->
  2023. tpath c.cl_path c.cl_module.m_path (List.map convert_type pl)
  2024. | TType (t,pl) as tf ->
  2025. (* recurse on type-type *)
  2026. if (snd t.t_path).[0] = '#' then convert_type (follow tf) else tpath t.t_path t.t_module.m_path (List.map convert_type pl)
  2027. | TAbstract (a,pl) ->
  2028. tpath a.a_path a.a_module.m_path (List.map convert_type pl)
  2029. | TFun (args,ret) ->
  2030. CTFunction (List.map (fun (_,_,t) -> convert_type t) args, convert_type ret)
  2031. | TAnon a ->
  2032. begin match !(a.a_status) with
  2033. | Statics c -> tpath ([],"Class") ([],"Class") [tpath c.cl_path c.cl_path []]
  2034. | EnumStatics e -> tpath ([],"Enum") ([],"Enum") [tpath e.e_path e.e_path []]
  2035. | _ ->
  2036. CTAnonymous (PMap.foldi (fun _ f acc ->
  2037. {
  2038. cff_name = f.cf_name;
  2039. cff_kind = FVar (mk_ot f.cf_type,None);
  2040. cff_pos = f.cf_pos;
  2041. cff_doc = f.cf_doc;
  2042. cff_meta = f.cf_meta;
  2043. cff_access = [];
  2044. } :: acc
  2045. ) a.a_fields [])
  2046. end
  2047. | (TDynamic t2) as t ->
  2048. tpath ([],"Dynamic") ([],"Dynamic") (if t == t_dynamic then [] else [convert_type t2])
  2049. | TLazy f ->
  2050. convert_type ((!f)())
  2051. and mk_ot t =
  2052. match follow t with
  2053. | TMono _ -> None
  2054. | _ -> (try Some (convert_type t) with Exit -> None)
  2055. let rec convert_expr e =
  2056. let full_type_path t =
  2057. let mp,p = match t with
  2058. | TClassDecl c -> c.cl_module.m_path,c.cl_path
  2059. | TEnumDecl en -> en.e_module.m_path,en.e_path
  2060. | TAbstractDecl a -> a.a_module.m_path,a.a_path
  2061. | TTypeDecl t -> t.t_module.m_path,t.t_path
  2062. in
  2063. if snd mp = snd p then p else (fst mp) @ [snd mp],snd p
  2064. in
  2065. let mk_path = expr_of_type_path in
  2066. let mk_ident = function
  2067. | "`trace" -> Ident "trace"
  2068. | n -> Ident n
  2069. in
  2070. let eopt = function None -> None | Some e -> Some (convert_expr e) in
  2071. ((match e.eexpr with
  2072. | TConst c ->
  2073. EConst (tconst_to_const c)
  2074. | TLocal v -> EConst (mk_ident v.v_name)
  2075. | TArray (e1,e2) -> EArray (convert_expr e1,convert_expr e2)
  2076. | TBinop (op,e1,e2) -> EBinop (op, convert_expr e1, convert_expr e2)
  2077. | TField (e,f) -> EField (convert_expr e, field_name f)
  2078. | TTypeExpr t -> fst (mk_path (full_type_path t) e.epos)
  2079. | TParenthesis e -> EParenthesis (convert_expr e)
  2080. | TObjectDecl fl -> EObjectDecl (List.map (fun (f,e) -> f, convert_expr e) fl)
  2081. | TArrayDecl el -> EArrayDecl (List.map convert_expr el)
  2082. | TCall (e,el) -> ECall (convert_expr e,List.map convert_expr el)
  2083. | TNew (c,pl,el) -> ENew ((match (try convert_type (TInst (c,pl)) with Exit -> convert_type (TInst (c,[]))) with CTPath p -> p | _ -> assert false),List.map convert_expr el)
  2084. | TUnop (op,p,e) -> EUnop (op,p,convert_expr e)
  2085. | TFunction f ->
  2086. let arg (v,c) = v.v_name, false, mk_ot v.v_type, (match c with None -> None | Some c -> Some (EConst (tconst_to_const c),e.epos)) in
  2087. EFunction (None,{ f_params = []; f_args = List.map arg f.tf_args; f_type = mk_ot f.tf_type; f_expr = Some (convert_expr f.tf_expr) })
  2088. | TVar (v,eo) ->
  2089. EVars ([v.v_name, mk_ot v.v_type, eopt eo])
  2090. | TBlock el -> EBlock (List.map convert_expr el)
  2091. | TFor (v,it,e) ->
  2092. let ein = (EIn ((EConst (Ident v.v_name),it.epos),convert_expr it),it.epos) in
  2093. EFor (ein,convert_expr e)
  2094. | TIf (e,e1,e2) -> EIf (convert_expr e,convert_expr e1,eopt e2)
  2095. | TWhile (e1,e2,flag) -> EWhile (convert_expr e1, convert_expr e2, flag)
  2096. | TSwitch (e,cases,def) ->
  2097. let cases = List.map (fun (vl,e) ->
  2098. List.map convert_expr vl,None,(match e.eexpr with TBlock [] -> None | _ -> Some (convert_expr e))
  2099. ) cases in
  2100. let def = match eopt def with None -> None | Some (EBlock [],_) -> Some None | e -> Some e in
  2101. ESwitch (convert_expr e,cases,def)
  2102. | TEnumParameter _ ->
  2103. (* these are considered complex, so the AST is handled in TMeta(Meta.Ast) *)
  2104. assert false
  2105. | TTry (e,catches) -> ETry (convert_expr e,List.map (fun (v,e) -> v.v_name, (try convert_type v.v_type with Exit -> assert false), convert_expr e) catches)
  2106. | TReturn e -> EReturn (eopt e)
  2107. | TBreak -> EBreak
  2108. | TContinue -> EContinue
  2109. | TThrow e -> EThrow (convert_expr e)
  2110. | TCast (e,t) ->
  2111. let t = (match t with
  2112. | None -> None
  2113. | Some t ->
  2114. let t = (match t with TClassDecl c -> TInst (c,[]) | TEnumDecl e -> TEnum (e,[]) | TTypeDecl t -> TType (t,[]) | TAbstractDecl a -> TAbstract (a,[])) in
  2115. Some (try convert_type t with Exit -> assert false)
  2116. ) in
  2117. ECast (convert_expr e,t)
  2118. | TMeta ((Meta.Ast,[e1,_],_),_) -> e1
  2119. | TMeta (m,e) -> EMeta(m,convert_expr e))
  2120. ,e.epos)
  2121. end
  2122. let print_if b e =
  2123. if b then print_endline (s_expr_pretty "" (s_type (print_context())) e)