typer.ml 143 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150
  1. (*
  2. * Copyright (C)2005-2013 Haxe Foundation
  3. *
  4. * Permission is hereby granted, free of charge, to any person obtaining a
  5. * copy of this software and associated documentation files (the "Software"),
  6. * to deal in the Software without restriction, including without limitation
  7. * the rights to use, copy, modify, merge, publish, distribute, sublicense,
  8. * and/or sell copies of the Software, and to permit persons to whom the
  9. * Software is furnished to do so, subject to the following conditions:
  10. *
  11. * The above copyright notice and this permission notice shall be included in
  12. * all copies or substantial portions of the Software.
  13. *
  14. * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  15. * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  16. * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  17. * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  18. * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  19. * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  20. * DEALINGS IN THE SOFTWARE.
  21. *)
  22. open Ast
  23. open Type
  24. open Common
  25. open Typecore
  26. (* ---------------------------------------------------------------------- *)
  27. (* TOOLS *)
  28. type switch_mode =
  29. | CMatch of (tenum_field * (string * t) option list option * pos)
  30. | CExpr of texpr
  31. type access_mode =
  32. | MGet
  33. | MSet
  34. | MCall
  35. exception DisplayFields of (string * t * documentation) list
  36. exception DisplayMetadata of metadata_entry list
  37. exception WithTypeError of unify_error list * pos
  38. type access_kind =
  39. | AKNo of string
  40. | AKExpr of texpr
  41. | AKSet of texpr * t * tclass_field
  42. | AKInline of texpr * tclass_field * tfield_access * t
  43. | AKMacro of texpr * tclass_field
  44. | AKUsing of texpr * tclass * tclass_field * texpr
  45. | AKAccess of texpr * texpr
  46. let mk_infos ctx p params =
  47. let file = if ctx.in_macro then p.pfile else if Common.defined ctx.com Define.AbsolutePath then Common.get_full_path p.pfile else Filename.basename p.pfile in
  48. (EObjectDecl (
  49. ("fileName" , (EConst (String file) , p)) ::
  50. ("lineNumber" , (EConst (Int (string_of_int (Lexer.get_error_line p))),p)) ::
  51. ("className" , (EConst (String (s_type_path ctx.curclass.cl_path)),p)) ::
  52. if ctx.curfield.cf_name = "" then
  53. params
  54. else
  55. ("methodName", (EConst (String ctx.curfield.cf_name),p)) :: params
  56. ) ,p)
  57. let check_assign ctx e =
  58. match e.eexpr with
  59. | TLocal _ | TArray _ | TField _ ->
  60. ()
  61. | TConst TThis | TTypeExpr _ when ctx.untyped ->
  62. ()
  63. | _ ->
  64. error "Invalid assign" e.epos
  65. type type_class =
  66. | KInt
  67. | KFloat
  68. | KString
  69. | KUnk
  70. | KDyn
  71. | KOther
  72. | KParam of t
  73. | KAbstract of tabstract
  74. let rec classify t =
  75. match follow t with
  76. | TInst ({ cl_path = ([],"String") },[]) -> KString
  77. | TAbstract({a_impl = Some _} as a,_) -> KAbstract a
  78. | TAbstract ({ a_path = [],"Int" },[]) -> KInt
  79. | TAbstract ({ a_path = [],"Float" },[]) -> KFloat
  80. | TAbstract (a,[]) when List.exists (fun (t,_) -> match classify t with KInt | KFloat -> true | _ -> false) a.a_to -> KParam t
  81. | TInst ({ cl_kind = KTypeParameter ctl },_) when List.exists (fun t -> match classify t with KInt | KFloat -> true | _ -> false) ctl -> KParam t
  82. | TMono r when !r = None -> KUnk
  83. | TDynamic _ -> KDyn
  84. | _ -> KOther
  85. let object_field f =
  86. let pf = Parser.quoted_ident_prefix in
  87. let pflen = String.length pf in
  88. if String.length f >= pflen && String.sub f 0 pflen = pf then String.sub f pflen (String.length f - pflen), false else f, true
  89. let get_iterator_param t =
  90. match follow t with
  91. | TAnon a ->
  92. if !(a.a_status) <> Closed then raise Not_found;
  93. (match follow (PMap.find "hasNext" a.a_fields).cf_type, follow (PMap.find "next" a.a_fields).cf_type with
  94. | TFun ([],tb), TFun([],t) when (match follow tb with TAbstract ({ a_path = [],"Bool" },[]) -> true | _ -> false) ->
  95. if PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 <> 2 then raise Not_found;
  96. t
  97. | _ ->
  98. raise Not_found)
  99. | _ ->
  100. raise Not_found
  101. let get_iterable_param t =
  102. match follow t with
  103. | TAnon a ->
  104. if !(a.a_status) <> Closed then raise Not_found;
  105. (match follow (PMap.find "iterator" a.a_fields).cf_type with
  106. | TFun ([],it) ->
  107. let t = get_iterator_param it in
  108. if PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 <> 1 then raise Not_found;
  109. t
  110. | _ ->
  111. raise Not_found)
  112. | _ -> raise Not_found
  113. (*
  114. temporally remove the constant flag from structures to allow larger unification
  115. *)
  116. let remove_constant_flag t callb =
  117. let tmp = ref [] in
  118. let rec loop t =
  119. match follow t with
  120. | TAnon a ->
  121. if !(a.a_status) = Const then begin
  122. a.a_status := Closed;
  123. tmp := a :: !tmp;
  124. end;
  125. PMap.iter (fun _ f -> loop f.cf_type) a.a_fields;
  126. | _ ->
  127. ()
  128. in
  129. let restore() =
  130. List.iter (fun a -> a.a_status := Const) (!tmp)
  131. in
  132. try
  133. loop t;
  134. let ret = callb (!tmp <> []) in
  135. restore();
  136. ret
  137. with e ->
  138. restore();
  139. raise e
  140. let rec is_pos_infos = function
  141. | TMono r ->
  142. (match !r with
  143. | Some t -> is_pos_infos t
  144. | _ -> false)
  145. | TLazy f ->
  146. is_pos_infos (!f())
  147. | TType ({ t_path = ["haxe"] , "PosInfos" },[]) ->
  148. true
  149. | TType (t,tl) ->
  150. is_pos_infos (apply_params t.t_types tl t.t_type)
  151. | _ ->
  152. false
  153. let add_constraint_checks ctx ctypes pl f tl p =
  154. List.iter2 (fun m (name,t) ->
  155. match follow t with
  156. | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
  157. let constr = List.map (fun t ->
  158. let t = apply_params f.cf_params tl t in
  159. (* only apply params if not static : in that case no param is passed *)
  160. let t = (if pl = [] then t else apply_params ctypes pl t) in
  161. t
  162. ) constr in
  163. delay ctx PCheckConstraint (fun() ->
  164. List.iter (fun ct ->
  165. try
  166. Type.unify m ct
  167. with Unify_error l ->
  168. display_error ctx (error_msg (Unify (Constraint_failure (f.cf_name ^ "." ^ name) :: l))) p;
  169. ) constr
  170. );
  171. | _ -> ()
  172. ) tl f.cf_params
  173. let field_type ctx c pl f p =
  174. match f.cf_params with
  175. | [] -> f.cf_type
  176. | l ->
  177. let monos = List.map (fun _ -> mk_mono()) l in
  178. if not (Meta.has Meta.Generic f.cf_meta) then add_constraint_checks ctx c.cl_types pl f monos p;
  179. apply_params l monos f.cf_type
  180. let class_field ctx c pl name p =
  181. raw_class_field (fun f -> field_type ctx c pl f p) c name
  182. (* checks if we can access to a given class field using current context *)
  183. let rec can_access ctx c cf stat =
  184. if cf.cf_public then
  185. true
  186. else
  187. (* has metadata path *)
  188. let make_path c f =
  189. fst c.cl_path @ [snd c.cl_path; f.cf_name]
  190. in
  191. let rec expr_path acc e =
  192. match fst e with
  193. | EField (e,f) -> expr_path (f :: acc) e
  194. | EConst (Ident n) -> n :: acc
  195. | _ -> []
  196. in
  197. let rec chk_path psub pfull =
  198. match psub, pfull with
  199. | [], _ -> true
  200. | a :: l1, b :: l2 when a = b -> chk_path l1 l2
  201. | _ -> false
  202. in
  203. let has m c f path =
  204. let rec loop = function
  205. | (m2,[e],_) :: l when m = m2 ->
  206. let p = expr_path [] e in
  207. (p <> [] && chk_path p path) || loop l
  208. | _ :: l -> loop l
  209. | [] -> false
  210. in
  211. loop c.cl_meta || loop f.cf_meta
  212. in
  213. let cur_path = make_path ctx.curclass ctx.curfield in
  214. let is_constr = cf.cf_name = "new" in
  215. let rec loop c =
  216. (try
  217. (* if our common ancestor declare/override the field, then we can access it *)
  218. let f = if is_constr then (match c.cl_constructor with None -> raise Not_found | Some c -> c) else PMap.find cf.cf_name (if stat then c.cl_statics else c.cl_fields) in
  219. is_parent c ctx.curclass || has Meta.Allow c f cur_path
  220. with Not_found ->
  221. false
  222. )
  223. || (match c.cl_super with
  224. | Some (csup,_) -> loop csup
  225. | None -> false)
  226. || has Meta.Access ctx.curclass ctx.curfield (make_path c cf)
  227. in
  228. let b = loop c
  229. (* access is also allowed of we access a type parameter which is constrained to our (base) class *)
  230. || (match c.cl_kind with
  231. | KTypeParameter tl ->
  232. List.exists (fun t -> match follow t with TInst(c,_) -> loop c | _ -> false) tl
  233. | _ -> false)
  234. || (Meta.has Meta.PrivateAccess ctx.meta) in
  235. if b && Common.defined ctx.com Common.Define.As3 && not (Meta.has Meta.Public cf.cf_meta) then cf.cf_meta <- (Meta.Public,[],cf.cf_pos) :: cf.cf_meta;
  236. b
  237. (* removes the first argument of the class field's function type and all its overloads *)
  238. let prepare_using_field cf = match cf.cf_type with
  239. | TFun((_,_,tf) :: args,ret) ->
  240. let rec loop acc overloads = match overloads with
  241. | ({cf_type = TFun((_,_,tfo) :: args,ret)} as cfo) :: l ->
  242. let tfo = apply_params cfo.cf_params (List.map snd cfo.cf_params) tfo in
  243. (* ignore overloads which have a different first argument *)
  244. if Type.type_iseq tf tfo then loop ({cfo with cf_type = TFun(args,ret)} :: acc) l else loop acc l
  245. | _ :: l ->
  246. loop acc l
  247. | [] ->
  248. acc
  249. in
  250. {cf with cf_overloads = loop [] cf.cf_overloads; cf_type = TFun(args,ret)}
  251. | _ -> cf
  252. let find_array_access a pl c t1 t2 is_set =
  253. let ta = apply_params a.a_types pl a.a_this in
  254. let rec loop cfl = match cfl with
  255. | [] -> raise Not_found
  256. | cf :: cfl when not (Meta.has Meta.ArrayAccess cf.cf_meta) ->
  257. loop cfl
  258. | cf :: cfl ->
  259. match follow (apply_params a.a_types pl (monomorphs cf.cf_params cf.cf_type)) with
  260. | TFun([(_,_,tab);(_,_,ta1);(_,_,ta2)],r) as tf when is_set && type_iseq tab ta && type_iseq ta1 t1 && type_iseq ta2 t2 ->
  261. cf,tf,r
  262. | TFun([(_,_,tab);(_,_,ta1)],r) as tf when not is_set && type_iseq tab ta && type_iseq ta1 t1 ->
  263. cf,tf,r
  264. | _ -> loop cfl
  265. in
  266. loop a.a_array
  267. let parse_string ctx s p inlined =
  268. let old = Lexer.save() in
  269. let old_file = (try Some (Hashtbl.find Lexer.all_files p.pfile) with Not_found -> None) in
  270. let old_display = !Parser.resume_display in
  271. let old_de = !Parser.display_error in
  272. let restore() =
  273. (match old_file with
  274. | None -> ()
  275. | Some f -> Hashtbl.replace Lexer.all_files p.pfile f);
  276. if not inlined then Parser.resume_display := old_display;
  277. Lexer.restore old;
  278. Parser.display_error := old_de
  279. in
  280. Lexer.init p.pfile;
  281. Parser.display_error := (fun e p -> raise (Parser.Error (e,p)));
  282. if not inlined then Parser.resume_display := null_pos;
  283. let _, decls = try
  284. Parser.parse ctx.com (Lexing.from_string s)
  285. with Parser.Error (e,pe) ->
  286. restore();
  287. error (Parser.error_msg e) (if inlined then pe else p)
  288. | Lexer.Error (e,pe) ->
  289. restore();
  290. error (Lexer.error_msg e) (if inlined then pe else p)
  291. in
  292. restore();
  293. match decls with
  294. | [(d,_)] -> d
  295. | _ -> assert false
  296. let parse_expr_string ctx s p inl =
  297. let head = "class X{static function main() " in
  298. let head = (if p.pmin > String.length head then head ^ String.make (p.pmin - String.length head) ' ' else head) in
  299. let rec loop e = let e = Ast.map_expr loop e in (fst e,p) in
  300. match parse_string ctx (head ^ s ^ ";}") p inl with
  301. | EClass { d_data = [{ cff_name = "main"; cff_kind = FFun { f_expr = Some e } }]} -> if inl then e else loop e
  302. | _ -> assert false
  303. (* ---------------------------------------------------------------------- *)
  304. (* PASS 3 : type expression & check structure *)
  305. let rec base_types t =
  306. let tl = ref [] in
  307. let rec loop t = (match t with
  308. | TInst(cl, params) ->
  309. (match cl.cl_kind with
  310. | KTypeParameter tl -> List.iter loop tl
  311. | _ -> ());
  312. List.iter (fun (ic, ip) ->
  313. let t = apply_params cl.cl_types params (TInst (ic,ip)) in
  314. loop t
  315. ) cl.cl_implements;
  316. (match cl.cl_super with None -> () | Some (csup, pl) ->
  317. let t = apply_params cl.cl_types params (TInst (csup,pl)) in
  318. loop t);
  319. tl := t :: !tl;
  320. | TType (td,pl) ->
  321. loop (apply_params td.t_types pl td.t_type);
  322. (* prioritize the most generic definition *)
  323. tl := t :: !tl;
  324. | TLazy f -> loop (!f())
  325. | TMono r -> (match !r with None -> () | Some t -> loop t)
  326. | _ -> tl := t :: !tl) in
  327. loop t;
  328. !tl
  329. let rec unify_min_raise ctx (el:texpr list) : t =
  330. match el with
  331. | [] -> mk_mono()
  332. | [e] -> e.etype
  333. | _ ->
  334. let rec chk_null e = is_null e.etype ||
  335. match e.eexpr with
  336. | TConst TNull -> true
  337. | TBlock el ->
  338. (match List.rev el with
  339. | [] -> false
  340. | e :: _ -> chk_null e)
  341. | TParenthesis e -> chk_null e
  342. | _ -> false
  343. in
  344. (* First pass: Try normal unification and find out if null is involved. *)
  345. let rec loop t = function
  346. | [] ->
  347. false, t
  348. | e :: el ->
  349. let t = if chk_null e then ctx.t.tnull t else t in
  350. try
  351. unify_raise ctx e.etype t e.epos;
  352. loop t el
  353. with Error (Unify _,_) -> try
  354. unify_raise ctx t e.etype e.epos;
  355. loop (if is_null t then ctx.t.tnull e.etype else e.etype) el
  356. with Error (Unify _,_) ->
  357. true, t
  358. in
  359. let has_error, t = loop (mk_mono()) el in
  360. if not has_error then
  361. t
  362. else try
  363. (* specific case for const anon : we don't want to hide fields but restrict their common type *)
  364. let fcount = ref (-1) in
  365. let field_count a =
  366. PMap.fold (fun _ acc -> acc + 1) a.a_fields 0
  367. in
  368. let expr f = match f.cf_expr with None -> mk (TBlock []) f.cf_type f.cf_pos | Some e -> e in
  369. let fields = List.fold_left (fun acc e ->
  370. match follow e.etype with
  371. | TAnon a when !(a.a_status) = Const ->
  372. a.a_status := Closed;
  373. if !fcount = -1 then begin
  374. fcount := field_count a;
  375. PMap.map (fun f -> [expr f]) a.a_fields
  376. end else begin
  377. if !fcount <> field_count a then raise Not_found;
  378. PMap.mapi (fun n el -> expr (PMap.find n a.a_fields) :: el) acc
  379. end
  380. | _ ->
  381. raise Not_found
  382. ) PMap.empty el in
  383. let fields = PMap.foldi (fun n el acc ->
  384. let t = try unify_min_raise ctx el with Error (Unify _, _) -> raise Not_found in
  385. PMap.add n (mk_field n t (List.hd el).epos) acc
  386. ) fields PMap.empty in
  387. TAnon { a_fields = fields; a_status = ref Closed }
  388. with Not_found ->
  389. (* Second pass: Get all base types (interfaces, super classes and their interfaces) of most general type.
  390. Then for each additional type filter all types that do not unify. *)
  391. let common_types = base_types t in
  392. let dyn_types = List.fold_left (fun acc t ->
  393. let rec loop c =
  394. Meta.has Meta.UnifyMinDynamic c.cl_meta || (match c.cl_super with None -> false | Some (c,_) -> loop c)
  395. in
  396. match t with
  397. | TInst (c,params) when params <> [] && loop c ->
  398. TInst (c,List.map (fun _ -> t_dynamic) params) :: acc
  399. | _ -> acc
  400. ) [] common_types in
  401. let common_types = ref (match List.rev dyn_types with [] -> common_types | l -> common_types @ l) in
  402. let loop e =
  403. let first_error = ref None in
  404. let filter t = (try unify_raise ctx e.etype t e.epos; true
  405. with Error (Unify l, p) as err -> if !first_error = None then first_error := Some(err); false)
  406. in
  407. common_types := List.filter filter !common_types;
  408. match !common_types, !first_error with
  409. | [], Some err -> raise err
  410. | _ -> ()
  411. in
  412. match !common_types with
  413. | [] ->
  414. error "No common base type found" (punion (List.hd el).epos (List.hd (List.rev el)).epos)
  415. | _ ->
  416. List.iter loop (List.tl el);
  417. List.hd !common_types
  418. let unify_min ctx el =
  419. try unify_min_raise ctx el
  420. with Error (Unify l,p) ->
  421. if not ctx.untyped then display_error ctx (error_msg (Unify l)) p;
  422. (List.hd el).etype
  423. let rec unify_call_params ctx ?(overloads=None) cf el args r p inline =
  424. (* 'overloads' will carry a ( return_result ) list, called 'compatible' *)
  425. (* it's used to correctly support an overload selection algorithm *)
  426. let overloads, compatible, legacy = match cf, overloads with
  427. | Some(TInst(c,pl),f), None when ctx.com.config.pf_overload && Meta.has Meta.Overload f.cf_meta ->
  428. let overloads = List.filter (fun (_,f2) -> not (f == f2)) (Typeload.get_overloads c f.cf_name) in
  429. if overloads = [] then (* is static function *)
  430. List.map (fun f -> f.cf_type, f) f.cf_overloads, [], false
  431. else
  432. overloads, [], false
  433. | Some(_,f), None ->
  434. List.map (fun f -> f.cf_type, f) f.cf_overloads, [], true
  435. | _, Some s ->
  436. s
  437. | _ -> [], [], true
  438. in
  439. let next ?retval () =
  440. let compatible = Option.map_default (fun r -> r :: compatible) compatible retval in
  441. match cf, overloads with
  442. | Some (TInst(c,pl),_), (ft,o) :: l ->
  443. let o = { o with cf_type = ft } in
  444. let args, ret = (match follow (apply_params c.cl_types pl (field_type ctx c pl o p)) with (* I'm getting non-followed types here. Should it happen? *)
  445. | TFun (tl,t) -> tl, t
  446. | _ -> assert false
  447. ) in
  448. Some (unify_call_params ctx ~overloads:(Some (l,compatible,legacy)) (Some (TInst(c,pl),o)) el args ret p inline)
  449. | Some (t,_), (ft,o) :: l ->
  450. let o = { o with cf_type = ft } in
  451. let args, ret = (match Type.field_type o with
  452. | TFun (tl,t) -> tl, t
  453. | _ -> assert false
  454. ) in
  455. Some (unify_call_params ctx ~overloads:(Some (l,compatible,legacy)) (Some (t, o)) el args ret p inline)
  456. | _ ->
  457. match compatible with
  458. | [] -> None
  459. | [acc,t] -> Some (List.map fst acc, t)
  460. | comp ->
  461. match Codegen.Overloads.reduce_compatible compatible with
  462. | [acc,t] -> Some (List.map fst acc, t)
  463. | (acc,t) :: _ -> (* ambiguous overload *)
  464. let name = match cf with | Some(_,f) -> "'" ^ f.cf_name ^ "' " | _ -> "" in
  465. let format_amb = String.concat "\n" (List.map (fun (_,t) ->
  466. "Function " ^ name ^ "with type " ^ (s_type (print_context()) t)
  467. ) compatible) in
  468. display_error ctx ("This call is ambiguous between the following methods:\n" ^ format_amb) p;
  469. Some (List.map fst acc,t)
  470. | [] -> None
  471. in
  472. let fun_details() =
  473. let format_arg = (fun (name,opt,_) -> (if opt then "?" else "") ^ name) in
  474. "Function " ^ (match cf with None -> "" | Some (_,f) -> "'" ^ f.cf_name ^ "' ") ^ "requires " ^ (if args = [] then "no arguments" else "arguments : " ^ String.concat ", " (List.map format_arg args))
  475. in
  476. let error acc txt =
  477. match next() with
  478. | Some l -> l
  479. | None ->
  480. display_error ctx (txt ^ " arguments\n" ^ (fun_details())) p;
  481. List.rev (List.map fst acc), (TFun(args,r))
  482. in
  483. let arg_error ul name opt p =
  484. match next() with
  485. | Some l -> l
  486. | None -> raise (Error (Stack (Unify ul,Custom ("For " ^ (if opt then "optional " else "") ^ "function argument '" ^ name ^ "'")), p))
  487. in
  488. let rec no_opt = function
  489. | [] -> []
  490. | ({ eexpr = TConst TNull },true) :: l -> no_opt l
  491. | l -> l
  492. in
  493. let rec default_value t =
  494. if is_pos_infos t then
  495. let infos = mk_infos ctx p [] in
  496. let e = type_expr ctx infos (WithType t) in
  497. (e, true)
  498. else
  499. (null (ctx.t.tnull t) p, true)
  500. in
  501. let rec loop acc l l2 skip =
  502. match l , l2 with
  503. | [] , [] ->
  504. let args,tf = if not (inline && ctx.g.doinline) && not ctx.com.config.pf_pad_nulls then
  505. List.rev (no_opt acc), (TFun(args,r))
  506. else
  507. List.rev (acc), (TFun(args,r))
  508. in
  509. if not legacy && ctx.com.config.pf_overload then
  510. match next ~retval:(args,tf) () with
  511. | Some l -> l
  512. | None ->
  513. display_error ctx ("No overloaded function matches the arguments. Are the arguments correctly typed?") p;
  514. List.map fst args, tf
  515. else
  516. List.map fst args, tf
  517. | [] , (_,false,_) :: _ ->
  518. error (List.fold_left (fun acc (_,_,t) -> default_value t :: acc) acc l2) "Not enough"
  519. | [] , (name,true,t) :: l ->
  520. loop (default_value t :: acc) [] l skip
  521. | _ , [] ->
  522. (match List.rev skip with
  523. | [] -> error acc "Too many"
  524. | [name,ul] -> arg_error ul name true p
  525. | (name,ul) :: _ -> arg_error (Unify_custom ("Invalid arguments\n" ^ fun_details()) :: ul) name true p)
  526. | ee :: l, (name,opt,t) :: l2 ->
  527. try
  528. let e = type_expr ctx ee (WithTypeResume t) in
  529. (try unify_raise ctx e.etype t e.epos with Error (Unify l,p) -> raise (WithTypeError (l,p)));
  530. loop ((e,false) :: acc) l l2 skip
  531. with
  532. WithTypeError (ul,p) ->
  533. if opt then
  534. loop (default_value t :: acc) (ee :: l) l2 ((name,ul) :: skip)
  535. else
  536. arg_error ul name false p
  537. in
  538. loop [] el args []
  539. let fast_enum_field e ef p =
  540. let et = mk (TTypeExpr (TEnumDecl e)) (TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics e) }) p in
  541. TField (et,FEnum (e,ef))
  542. let rec type_module_type ctx t tparams p =
  543. match t with
  544. | TClassDecl c ->
  545. let t_tmp = {
  546. t_path = fst c.cl_path, "#" ^ snd c.cl_path;
  547. t_module = c.cl_module;
  548. t_doc = None;
  549. t_pos = c.cl_pos;
  550. t_type = TAnon {
  551. a_fields = c.cl_statics;
  552. a_status = ref (Statics c);
  553. };
  554. t_private = true;
  555. t_types = [];
  556. t_meta = no_meta;
  557. } in
  558. mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p
  559. | TEnumDecl e ->
  560. let types = (match tparams with None -> List.map (fun _ -> mk_mono()) e.e_types | Some l -> l) in
  561. let fl = PMap.fold (fun f acc ->
  562. PMap.add f.ef_name {
  563. cf_name = f.ef_name;
  564. cf_public = true;
  565. cf_type = f.ef_type;
  566. cf_kind = (match follow f.ef_type with
  567. | TFun _ -> Method MethNormal
  568. | _ -> Var { v_read = AccNormal; v_write = AccNo }
  569. );
  570. cf_pos = e.e_pos;
  571. cf_doc = None;
  572. cf_meta = no_meta;
  573. cf_expr = None;
  574. cf_params = f.ef_params;
  575. cf_overloads = [];
  576. } acc
  577. ) e.e_constrs PMap.empty in
  578. let t_tmp = {
  579. t_path = fst e.e_path, "#" ^ snd e.e_path;
  580. t_module = e.e_module;
  581. t_doc = None;
  582. t_pos = e.e_pos;
  583. t_type = TAnon {
  584. a_fields = fl;
  585. a_status = ref (EnumStatics e);
  586. };
  587. t_private = true;
  588. t_types = e.e_types;
  589. t_meta = no_meta;
  590. } in
  591. mk (TTypeExpr (TEnumDecl e)) (TType (t_tmp,types)) p
  592. | TTypeDecl s ->
  593. let t = apply_params s.t_types (List.map (fun _ -> mk_mono()) s.t_types) s.t_type in
  594. (match follow t with
  595. | TEnum (e,params) ->
  596. type_module_type ctx (TEnumDecl e) (Some params) p
  597. | TInst (c,params) ->
  598. type_module_type ctx (TClassDecl c) (Some params) p
  599. | TAbstract (a,params) ->
  600. type_module_type ctx (TAbstractDecl a) (Some params) p
  601. | _ ->
  602. error (s_type_path s.t_path ^ " is not a value") p)
  603. | TAbstractDecl { a_impl = Some c } ->
  604. type_module_type ctx (TClassDecl c) tparams p
  605. | TAbstractDecl a ->
  606. if not (Meta.has Meta.RuntimeValue a.a_meta) then error (s_type_path a.a_path ^ " is not a value") p;
  607. let t_tmp = {
  608. t_path = fst a.a_path, "#" ^ snd a.a_path;
  609. t_module = a.a_module;
  610. t_doc = None;
  611. t_pos = a.a_pos;
  612. t_type = TAnon {
  613. a_fields = PMap.empty;
  614. a_status = ref (AbstractStatics a);
  615. };
  616. t_private = true;
  617. t_types = [];
  618. t_meta = no_meta;
  619. } in
  620. mk (TTypeExpr (TAbstractDecl a)) (TType (t_tmp,[])) p
  621. let type_type ctx tpath p =
  622. type_module_type ctx (Typeload.load_type_def ctx p { tpackage = fst tpath; tname = snd tpath; tparams = []; tsub = None }) None p
  623. let get_constructor ctx c params p =
  624. match c.cl_kind with
  625. | KAbstractImpl a ->
  626. let f = (try PMap.find "_new" c.cl_statics with Not_found -> error (s_type_path a.a_path ^ " does not have a constructor") p) in
  627. let ct = field_type ctx c params f p in
  628. apply_params a.a_types params ct, f
  629. | _ ->
  630. let ct, f = (try Type.get_constructor (fun f -> field_type ctx c params f p) c with Not_found -> error (s_type_path c.cl_path ^ " does not have a constructor") p) in
  631. apply_params c.cl_types params ct, f
  632. let make_call ctx e params t p =
  633. try
  634. let ethis, fname = (match e.eexpr with TField (ethis,f) -> ethis, field_name f | _ -> raise Exit) in
  635. let f, cl = (match follow ethis.etype with
  636. | TInst (c,params) -> (try let _,_,f = Type.class_field c fname in f with Not_found -> raise Exit), Some c
  637. | TAnon a -> (try PMap.find fname a.a_fields with Not_found -> raise Exit), (match !(a.a_status) with Statics c -> Some c | _ -> None)
  638. | _ -> raise Exit
  639. ) in
  640. if f.cf_kind <> Method MethInline then raise Exit;
  641. let is_extern = (match cl with
  642. | Some { cl_extern = true } -> true
  643. | Some { cl_kind = KAbstractImpl _ } -> true
  644. | _ when Meta.has Meta.Extern f.cf_meta -> true
  645. | _ -> false
  646. ) in
  647. let config = match cl with
  648. | Some ({cl_kind = KAbstractImpl _ }) when Meta.has Meta.Impl f.cf_meta ->
  649. (match if fname = "_new" then
  650. t
  651. else if params = [] then
  652. error "Invalid abstract implementation function" f.cf_pos
  653. else
  654. follow (List.hd params).etype with
  655. | TAbstract(a,pl) ->
  656. Some (a.a_types <> [] || f.cf_params <> [], fun t -> apply_params a.a_types pl (monomorphs f.cf_params t))
  657. | _ ->
  658. None);
  659. | _ ->
  660. None
  661. in
  662. ignore(follow f.cf_type); (* force evaluation *)
  663. let params = List.map (ctx.g.do_optimize ctx) params in
  664. (match f.cf_expr with
  665. | Some { eexpr = TFunction fd } ->
  666. (match Optimizer.type_inline ctx f fd ethis params t config p is_extern with
  667. | None ->
  668. if is_extern then error "Inline could not be done" p;
  669. raise Exit;
  670. | Some e -> e)
  671. | _ ->
  672. (*
  673. we can't inline because there is most likely a loop in the typing.
  674. this can be caused by mutually recursive vars/functions, some of them
  675. being inlined or not. In that case simply ignore inlining.
  676. *)
  677. raise Exit)
  678. with Exit ->
  679. mk (TCall (e,params)) t p
  680. let rec acc_get ctx g p =
  681. match g with
  682. | AKNo f -> error ("Field " ^ f ^ " cannot be accessed for reading") p
  683. | AKExpr e -> e
  684. | AKSet _ | AKAccess _ -> assert false
  685. | AKUsing (et,_,_,e) ->
  686. (* build a closure with first parameter applied *)
  687. (match follow et.etype with
  688. | TFun (_ :: args,ret) ->
  689. let tcallb = TFun (args,ret) in
  690. let twrap = TFun ([("_e",false,e.etype)],tcallb) in
  691. let args = List.map (fun (n,_,t) -> alloc_var n t) args in
  692. let ve = alloc_var "_e" e.etype in
  693. let ecall = make_call ctx et (List.map (fun v -> mk (TLocal v) v.v_type p) (ve :: args)) ret p in
  694. let ecallb = mk (TFunction {
  695. tf_args = List.map (fun v -> v,None) args;
  696. tf_type = ret;
  697. tf_expr = mk (TReturn (Some ecall)) t_dynamic p;
  698. }) tcallb p in
  699. let ewrap = mk (TFunction {
  700. tf_args = [ve,None];
  701. tf_type = tcallb;
  702. tf_expr = mk (TReturn (Some ecallb)) t_dynamic p;
  703. }) twrap p in
  704. make_call ctx ewrap [e] tcallb p
  705. | _ -> assert false)
  706. | AKInline (e,f,fmode,t) ->
  707. (* do not create a closure for static calls *)
  708. let cmode = (match fmode with FStatic _ -> fmode | FInstance (c,f) -> FClosure (Some c,f) | _ -> assert false) in
  709. ignore(follow f.cf_type); (* force computing *)
  710. (match f.cf_expr with
  711. | None ->
  712. if ctx.com.display then
  713. mk (TField (e,cmode)) t p
  714. else
  715. error "Recursive inline is not supported" p
  716. | Some { eexpr = TFunction _ } ->
  717. let chk_class c = if (c.cl_extern || Meta.has Meta.Extern f.cf_meta) && not (Meta.has Meta.Runtime f.cf_meta) then display_error ctx "Can't create closure on an inline extern method" p in
  718. (match follow e.etype with
  719. | TInst (c,_) -> chk_class c
  720. | TAnon a -> (match !(a.a_status) with Statics c -> chk_class c | _ -> ())
  721. | _ -> ());
  722. mk (TField (e,cmode)) t p
  723. | Some e ->
  724. let rec loop e = Type.map_expr loop { e with epos = p } in
  725. loop e)
  726. | AKMacro _ ->
  727. assert false
  728. let error_require r p =
  729. let r = if r = "sys" then
  730. "a system platform (php,neko,cpp,etc.)"
  731. else try
  732. if String.sub r 0 5 <> "flash" then raise Exit;
  733. let _, v = ExtString.String.replace (String.sub r 5 (String.length r - 5)) "_" "." in
  734. "flash version " ^ v ^ " (use -swf-version " ^ v ^ ")"
  735. with _ ->
  736. "'" ^ r ^ "' to be enabled"
  737. in
  738. error ("Accessing this field requires " ^ r) p
  739. let get_this ctx p =
  740. match ctx.curfun with
  741. | FunStatic ->
  742. error "Cannot access this from a static function" p
  743. | FunMemberLocal ->
  744. let v = (match ctx.vthis with
  745. | None ->
  746. (* we might be in a closure of an abstract member, so check for local "this" first *)
  747. let v = try PMap.find "this" ctx.locals with Not_found -> gen_local ctx ctx.tthis in
  748. ctx.vthis <- Some v;
  749. v
  750. | Some v ->
  751. ctx.locals <- PMap.add v.v_name v ctx.locals;
  752. v
  753. ) in
  754. mk (TLocal v) ctx.tthis p
  755. | FunMemberAbstract ->
  756. let v = (try PMap.find "this" ctx.locals with Not_found -> assert false) in
  757. mk (TLocal v) v.v_type p
  758. | FunConstructor | FunMember ->
  759. mk (TConst TThis) ctx.tthis p
  760. let field_access ctx mode f fmode t e p =
  761. let fnormal() = AKExpr (mk (TField (e,fmode)) t p) in
  762. let normal() =
  763. match follow e.etype with
  764. | TAnon a ->
  765. (match !(a.a_status) with
  766. | EnumStatics en ->
  767. let c = (try PMap.find f.cf_name en.e_constrs with Not_found -> assert false) in
  768. let fmode = FEnum (en,c) in
  769. AKExpr (mk (TField (e,fmode)) t p)
  770. | _ -> fnormal())
  771. | _ -> fnormal()
  772. in
  773. match f.cf_kind with
  774. | Method m ->
  775. if mode = MSet && m <> MethDynamic && not ctx.untyped then error "Cannot rebind this method : please use 'dynamic' before method declaration" p;
  776. (match m, mode with
  777. | _ when (match e.eexpr with TTypeExpr(TClassDecl ({cl_kind = KAbstractImpl a} as c)) -> c == ctx.curclass && ctx.curfun = FunMemberAbstract && Meta.has Meta.Impl f.cf_meta | _ -> false) ->
  778. let e = mk (TField(e,fmode)) t p in
  779. AKUsing(e,ctx.curclass,f,get_this ctx p)
  780. | MethInline, _ -> AKInline (e,f,fmode,t)
  781. | MethMacro, MGet -> display_error ctx "Macro functions must be called immediately" p; normal()
  782. | MethMacro, MCall -> AKMacro (e,f)
  783. | _ , MGet ->
  784. let cmode = (match fmode with
  785. | FInstance (c,cf) -> FClosure (Some c,cf)
  786. | FStatic _ | FEnum _ -> fmode
  787. | FAnon f -> FClosure (None, f)
  788. | FDynamic _ | FClosure _ -> assert false
  789. ) in
  790. AKExpr (mk (TField (e,cmode)) t p)
  791. | _ -> normal())
  792. | Var v ->
  793. match (match mode with MGet | MCall -> v.v_read | MSet -> v.v_write) with
  794. | AccNo ->
  795. (match follow e.etype with
  796. | TInst (c,_) when is_parent c ctx.curclass || can_access ctx c { f with cf_public = false } false -> normal()
  797. | TAnon a ->
  798. (match !(a.a_status) with
  799. | Opened when mode = MSet ->
  800. f.cf_kind <- Var { v with v_write = AccNormal };
  801. normal()
  802. | Statics c2 when ctx.curclass == c2 || can_access ctx c2 { f with cf_public = false } true -> normal()
  803. | _ -> if ctx.untyped then normal() else AKNo f.cf_name)
  804. | _ ->
  805. if ctx.untyped then normal() else AKNo f.cf_name)
  806. | AccNormal ->
  807. (*
  808. if we are reading from a read-only variable on an anonymous object, it might actually be a method, so make sure to create a closure
  809. *)
  810. let is_maybe_method() =
  811. match v.v_write, follow t, follow e.etype with
  812. | (AccNo | AccNever), TFun _, TAnon a ->
  813. (match !(a.a_status) with
  814. | Statics _ | EnumStatics _ -> false
  815. | _ -> true)
  816. | _ -> false
  817. in
  818. if mode = MGet && is_maybe_method() then
  819. AKExpr (mk (TField (e,FClosure (None,f))) t p)
  820. else
  821. normal()
  822. | AccCall ->
  823. let m = (match mode with MSet -> "set_" | _ -> "get_") ^ f.cf_name in
  824. if m = ctx.curfield.cf_name && (match e.eexpr with TConst TThis -> true | TTypeExpr (TClassDecl c) when c == ctx.curclass -> true | _ -> false) then
  825. let prefix = (match ctx.com.platform with Flash when Common.defined ctx.com Define.As3 -> "$" | _ -> "") in
  826. if is_extern_field f then begin
  827. display_error ctx "This field cannot be accessed because it is not a real variable" p;
  828. display_error ctx "Add @:isVar here to enable it" f.cf_pos;
  829. end;
  830. AKExpr (mk (TField (e,if prefix = "" then fmode else FDynamic (prefix ^ f.cf_name))) t p)
  831. else if (match e.eexpr with TTypeExpr (TClassDecl ({cl_kind = KAbstractImpl _} as c)) when c == ctx.curclass -> true | _ -> false) then begin
  832. let this = get_this ctx p in
  833. if mode = MSet then begin
  834. let c,a = match ctx.curclass with {cl_kind = KAbstractImpl a} as c -> c,a | _ -> assert false in
  835. let f = PMap.find m c.cl_statics in
  836. (* we don't have access to the type parameters here, right? *)
  837. (* let t = apply_params a.a_types pl (field_type ctx c [] f p) in *)
  838. let t = (field_type ctx c [] f p) in
  839. let ef = mk (TField (e,FStatic (c,f))) t p in
  840. AKUsing (ef,c,f,this)
  841. end else
  842. AKExpr (make_call ctx (mk (TField (e,quick_field_dynamic e.etype m)) (tfun [this.etype] t) p) [this] t p)
  843. end else if mode = MSet then
  844. AKSet (e,t,f)
  845. else
  846. AKExpr (make_call ctx (mk (TField (e,quick_field_dynamic e.etype m)) (tfun [] t) p) [] t p)
  847. | AccResolve ->
  848. let fstring = mk (TConst (TString f.cf_name)) ctx.t.tstring p in
  849. let tresolve = tfun [ctx.t.tstring] t in
  850. AKExpr (make_call ctx (mk (TField (e,FDynamic "resolve")) tresolve p) [fstring] t p)
  851. | AccNever ->
  852. if ctx.untyped then normal() else AKNo f.cf_name
  853. | AccInline ->
  854. AKInline (e,f,fmode,t)
  855. | AccRequire (r,msg) ->
  856. match msg with
  857. | None -> error_require r p
  858. | Some msg -> error msg p
  859. let rec using_field ctx mode e i p =
  860. if mode = MSet then raise Not_found;
  861. (* do not try to find using fields if the type is a monomorph, which could lead to side-effects *)
  862. let is_dynamic = match follow e.etype with
  863. | TMono _ -> raise Not_found
  864. | t -> t == t_dynamic
  865. in
  866. let check_constant_struct = ref false in
  867. let rec loop = function
  868. | [] ->
  869. raise Not_found
  870. | c :: l ->
  871. try
  872. let cf = PMap.find i c.cl_statics in
  873. if Meta.has Meta.NoUsing cf.cf_meta then raise Not_found;
  874. let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
  875. let map = apply_params cf.cf_params monos in
  876. let t = map cf.cf_type in
  877. begin match follow t with
  878. | TFun((_,_,(TType({t_path = ["haxe";"macro"],"ExprOf"},[t0]) | t0)) :: args,r) ->
  879. if is_dynamic && follow t0 != t_dynamic then raise Not_found;
  880. Type.unify e.etype t0;
  881. (* early constraints check is possible because e.etype has no monomorphs *)
  882. List.iter2 (fun m (name,t) -> match follow t with
  883. | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
  884. List.iter (fun tc -> Type.unify m (map tc)) constr
  885. | _ -> ()
  886. ) monos cf.cf_params;
  887. let et = type_module_type ctx (TClassDecl c) None p in
  888. AKUsing (mk (TField (et,FStatic (c,cf))) t p,c,cf,e)
  889. | _ ->
  890. raise Not_found
  891. end
  892. with Not_found ->
  893. loop l
  894. | Unify_error el ->
  895. if List.exists (function Has_extra_field _ -> true | _ -> false) el then check_constant_struct := true;
  896. loop l
  897. in
  898. try loop ctx.m.module_using with Not_found ->
  899. try loop ctx.g.global_using with Not_found ->
  900. if not !check_constant_struct then raise Not_found;
  901. remove_constant_flag e.etype (fun ok -> if ok then using_field ctx mode e i p else raise Not_found)
  902. let rec type_ident_raise ?(imported_enums=true) ctx i p mode =
  903. match i with
  904. | "true" ->
  905. if mode = MGet then
  906. AKExpr (mk (TConst (TBool true)) ctx.t.tbool p)
  907. else
  908. AKNo i
  909. | "false" ->
  910. if mode = MGet then
  911. AKExpr (mk (TConst (TBool false)) ctx.t.tbool p)
  912. else
  913. AKNo i
  914. | "this" ->
  915. (match mode, ctx.curclass.cl_kind with
  916. | MSet, KAbstractImpl _ ->
  917. (match ctx.curfield.cf_kind with
  918. | Method MethInline -> ()
  919. | Method _ when ctx.curfield.cf_name = "_new" -> ()
  920. | _ -> error "You can only modify 'this' inside an inline function" p);
  921. AKExpr (get_this ctx p)
  922. | _ ->
  923. if mode = MGet then
  924. AKExpr (get_this ctx p)
  925. else
  926. AKNo i)
  927. | "super" ->
  928. let t = (match ctx.curclass.cl_super with
  929. | None -> error "Current class does not have a superclass" p
  930. | Some (c,params) -> TInst(c,params)
  931. ) in
  932. (match ctx.curfun with
  933. | FunMember | FunConstructor -> ()
  934. | FunMemberAbstract -> error "Cannot access super inside an abstract function" p
  935. | FunStatic -> error "Cannot access super inside a static function" p;
  936. | FunMemberLocal -> error "Cannot access super inside a local function" p);
  937. if mode <> MSet && ctx.in_super_call then ctx.in_super_call <- false;
  938. AKExpr (mk (TConst TSuper) t p)
  939. | "null" ->
  940. if mode = MGet then
  941. AKExpr (null (mk_mono()) p)
  942. else
  943. AKNo i
  944. | _ ->
  945. try
  946. let v = PMap.find i ctx.locals in
  947. (match v.v_extra with
  948. | Some (params,e) ->
  949. let t = monomorphs params v.v_type in
  950. (match e with
  951. | Some ({ eexpr = TFunction f } as e) ->
  952. (* create a fake class with a fake field to emulate inlining *)
  953. let c = mk_class ctx.m.curmod (["local"],v.v_name) e.epos in
  954. let cf = { (mk_field v.v_name v.v_type e.epos) with cf_params = params; cf_expr = Some e; cf_kind = Method MethInline } in
  955. c.cl_extern <- true;
  956. c.cl_fields <- PMap.add cf.cf_name cf PMap.empty;
  957. AKInline (mk (TConst TNull) (TInst (c,[])) p, cf, FInstance(c,cf), t)
  958. | _ ->
  959. AKExpr (mk (TLocal v) t p))
  960. | _ ->
  961. AKExpr (mk (TLocal v) v.v_type p))
  962. with Not_found -> try
  963. (* member variable lookup *)
  964. if ctx.curfun = FunStatic then raise Not_found;
  965. let c , t , f = class_field ctx ctx.curclass [] i p in
  966. field_access ctx mode f (match c with None -> FAnon f | Some c -> FInstance (c,f)) t (get_this ctx p) p
  967. with Not_found -> try
  968. (* lookup using on 'this' *)
  969. if ctx.curfun = FunStatic then raise Not_found;
  970. (match using_field ctx mode (mk (TConst TThis) ctx.tthis p) i p with
  971. | AKUsing (et,c,f,_) -> AKUsing (et,c,f,get_this ctx p)
  972. | _ -> assert false)
  973. with Not_found -> try
  974. (* static variable lookup *)
  975. let f = PMap.find i ctx.curclass.cl_statics in
  976. let e = type_type ctx ctx.curclass.cl_path p in
  977. (* check_locals_masking already done in type_type *)
  978. field_access ctx mode f (FStatic (ctx.curclass,f)) (field_type ctx ctx.curclass [] f p) e p
  979. with Not_found -> try
  980. if not imported_enums then raise Not_found;
  981. (* lookup imported enums *)
  982. let rec loop l =
  983. match l with
  984. | [] -> raise Not_found
  985. | t :: l ->
  986. match t with
  987. | TClassDecl _ | TAbstractDecl _ ->
  988. loop l
  989. | TTypeDecl t ->
  990. (match follow t.t_type with
  991. | TEnum (e,_) -> loop ((TEnumDecl e) :: l)
  992. | _ -> loop l)
  993. | TEnumDecl e ->
  994. try
  995. let ef = PMap.find i e.e_constrs in
  996. let et = type_module_type ctx t None p in
  997. mk (TField (et,FEnum (e,ef))) (monomorphs ef.ef_params (monomorphs e.e_types ef.ef_type)) p
  998. with
  999. Not_found -> loop l
  1000. in
  1001. let e = (try loop (List.rev ctx.m.curmod.m_types) with Not_found -> loop ctx.m.module_types) in
  1002. if mode = MSet then
  1003. AKNo i
  1004. else
  1005. AKExpr e
  1006. with Not_found ->
  1007. (* lookup imported globals *)
  1008. let t, name = PMap.find i ctx.m.module_globals in
  1009. let e = type_module_type ctx t None p in
  1010. type_field ctx e name p mode
  1011. and type_field ctx e i p mode =
  1012. let no_field() =
  1013. let t = match follow e.etype with
  1014. | TAnon a -> (match !(a.a_status) with
  1015. | Statics {cl_kind = KAbstractImpl a} -> TAbstract(a,[])
  1016. | _ -> e.etype)
  1017. | TInst({cl_kind = KAbstractImpl a},_) -> TAbstract(a,[])
  1018. | _ -> e.etype
  1019. in
  1020. if not ctx.untyped then display_error ctx (string_error i (string_source t) (s_type (print_context()) t ^ " has no field " ^ i)) p;
  1021. AKExpr (mk (TField (e,FDynamic i)) (mk_mono()) p)
  1022. in
  1023. match follow e.etype with
  1024. | TInst (c,params) ->
  1025. let rec loop_dyn c params =
  1026. match c.cl_dynamic with
  1027. | Some t ->
  1028. let t = apply_params c.cl_types params t in
  1029. if (mode = MGet || mode = MCall) && PMap.mem "resolve" c.cl_fields then begin
  1030. let f = PMap.find "resolve" c.cl_fields in
  1031. AKExpr (make_call ctx (mk (TField (e,FInstance (c,f))) (tfun [ctx.t.tstring] t) p) [Codegen.type_constant ctx.com (String i) p] t p)
  1032. end else
  1033. AKExpr (mk (TField (e,FDynamic i)) t p)
  1034. | None ->
  1035. match c.cl_super with
  1036. | None -> raise Not_found
  1037. | Some (c,params) -> loop_dyn c params
  1038. in
  1039. (try
  1040. let c2, t , f = class_field ctx c params i p in
  1041. if e.eexpr = TConst TSuper then (match mode,f.cf_kind with
  1042. | MGet,Var {v_read = AccCall }
  1043. | MSet,Var {v_write = AccCall }
  1044. | MCall,Var {v_read = AccCall } ->
  1045. ()
  1046. | MCall, Var _ ->
  1047. error "Cannot access superclass variable for calling: needs to be a proper method" p
  1048. | MCall, _ ->
  1049. ()
  1050. | MGet,Var _
  1051. | MSet,Var _ when (match c2 with Some { cl_extern = true; cl_path = ("flash" :: _,_) } -> true | _ -> false) ->
  1052. ()
  1053. | _, Method _ ->
  1054. error "Cannot create closure on super method" p
  1055. | _ ->
  1056. error "Normal variables cannot be accessed with 'super', use 'this' instead" p);
  1057. if not (can_access ctx c f false) && not ctx.untyped then display_error ctx ("Cannot access private field " ^ i) p;
  1058. field_access ctx mode f (match c2 with None -> FAnon f | Some c -> FInstance (c,f)) (apply_params c.cl_types params t) e p
  1059. with Not_found -> try
  1060. using_field ctx mode e i p
  1061. with Not_found -> try
  1062. loop_dyn c params
  1063. with Not_found ->
  1064. if PMap.mem i c.cl_statics then error ("Cannot access static field " ^ i ^ " from a class instance") p;
  1065. (*
  1066. This is a fix to deal with optimize_completion which will call iterator()
  1067. on the expression for/in, which vectors do no have.
  1068. *)
  1069. if ctx.com.display && i = "iterator" && c.cl_path = (["flash"],"Vector") then begin
  1070. let it = TAnon {
  1071. a_fields = PMap.add "next" (mk_field "next" (TFun([],List.hd params)) p) PMap.empty;
  1072. a_status = ref Closed;
  1073. } in
  1074. AKExpr (mk (TField (e,FDynamic i)) (TFun([],it)) p)
  1075. end else
  1076. no_field())
  1077. | TDynamic t ->
  1078. (try
  1079. using_field ctx mode e i p
  1080. with Not_found ->
  1081. AKExpr (mk (TField (e,FDynamic i)) t p))
  1082. | TAnon a ->
  1083. (try
  1084. let f = PMap.find i a.a_fields in
  1085. if not f.cf_public && not ctx.untyped then begin
  1086. match !(a.a_status) with
  1087. | Closed -> () (* always allow anon private fields access *)
  1088. | Statics c when can_access ctx c f true -> ()
  1089. | _ -> display_error ctx ("Cannot access private field " ^ i) p
  1090. end;
  1091. let fmode, ft = (match !(a.a_status) with
  1092. | Statics c -> FStatic (c,f), field_type ctx c [] f p
  1093. | EnumStatics e -> FEnum (e,try PMap.find f.cf_name e.e_constrs with Not_found -> assert false), Type.field_type f
  1094. | _ ->
  1095. match f.cf_params with
  1096. | [] ->
  1097. FAnon f, Type.field_type f
  1098. | l ->
  1099. (* handle possible constraints *)
  1100. let monos = List.map (fun _ -> mk_mono()) l in
  1101. let t = apply_params f.cf_params monos f.cf_type in
  1102. add_constraint_checks ctx [] [] f monos p;
  1103. FAnon f, t
  1104. ) in
  1105. field_access ctx mode f fmode ft e p
  1106. with Not_found ->
  1107. if is_closed a then try
  1108. using_field ctx mode e i p
  1109. with Not_found ->
  1110. no_field()
  1111. else
  1112. let f = {
  1113. cf_name = i;
  1114. cf_type = mk_mono();
  1115. cf_doc = None;
  1116. cf_meta = no_meta;
  1117. cf_public = true;
  1118. cf_pos = p;
  1119. cf_kind = Var { v_read = AccNormal; v_write = (match mode with MSet -> AccNormal | MGet | MCall -> AccNo) };
  1120. cf_expr = None;
  1121. cf_params = [];
  1122. cf_overloads = [];
  1123. } in
  1124. a.a_fields <- PMap.add i f a.a_fields;
  1125. field_access ctx mode f (FAnon f) (Type.field_type f) e p
  1126. )
  1127. | TMono r ->
  1128. if ctx.untyped && (match ctx.com.platform with Flash8 -> Common.defined ctx.com Define.SwfMark | _ -> false) then ctx.com.warning "Mark" p;
  1129. let f = {
  1130. cf_name = i;
  1131. cf_type = mk_mono();
  1132. cf_doc = None;
  1133. cf_meta = no_meta;
  1134. cf_public = true;
  1135. cf_pos = p;
  1136. cf_kind = Var { v_read = AccNormal; v_write = (match mode with MSet -> AccNormal | MGet | MCall -> AccNo) };
  1137. cf_expr = None;
  1138. cf_params = [];
  1139. cf_overloads = [];
  1140. } in
  1141. let x = ref Opened in
  1142. let t = TAnon { a_fields = PMap.add i f PMap.empty; a_status = x } in
  1143. ctx.opened <- x :: ctx.opened;
  1144. r := Some t;
  1145. field_access ctx mode f (FAnon f) (Type.field_type f) e p
  1146. | TAbstract (a,pl) ->
  1147. (try
  1148. let c = (match a.a_impl with None -> raise Not_found | Some c -> c) in
  1149. let f = PMap.find i c.cl_statics in
  1150. let field_type f =
  1151. let t = field_type ctx c [] f p in
  1152. apply_params a.a_types pl t
  1153. in
  1154. let et = type_module_type ctx (TClassDecl c) None p in
  1155. let field_expr f t = mk (TField (et,FStatic (c,f))) t p in
  1156. (match mode, f.cf_kind with
  1157. | MGet, Var {v_read = AccCall } ->
  1158. (* getter call *)
  1159. let f = PMap.find ("get_" ^ f.cf_name) c.cl_statics in
  1160. let t = field_type f in
  1161. let r = match follow t with TFun(_,r) -> r | _ -> raise Not_found in
  1162. let ef = field_expr f t in
  1163. AKExpr(make_call ctx ef [e] r p)
  1164. | MSet, Var {v_write = AccCall } ->
  1165. let f = PMap.find ("set_" ^ f.cf_name) c.cl_statics in
  1166. let t = field_type f in
  1167. let ef = field_expr f t in
  1168. AKUsing (ef,c,f,e)
  1169. | MCall, Var {v_read = AccCall} ->
  1170. error (i ^ " cannot be called") p
  1171. | MGet, Var {v_read = AccNever} ->
  1172. AKNo f.cf_name
  1173. | MCall, _ ->
  1174. let t = field_type f in
  1175. begin match follow t with
  1176. | TFun((_,_,t1) :: _,_) ->
  1177. (match f.cf_kind with Method MethMacro -> () | _ -> unify ctx (apply_params a.a_types pl a.a_this) t1 p)
  1178. | _ ->
  1179. error (i ^ " cannot be called") p
  1180. end;
  1181. let ef = field_expr f t in
  1182. AKUsing (ef,c,f,e)
  1183. | MGet, _ ->
  1184. let t = field_type f in
  1185. let ef = field_expr f t in
  1186. AKUsing (ef,c,f,e)
  1187. | MSet, _ ->
  1188. error "This operation is unsupported" p)
  1189. with Not_found -> try
  1190. using_field ctx mode e i p
  1191. with Not_found -> try
  1192. (match ctx.curfun, e.eexpr with
  1193. | FunMemberAbstract, TConst (TThis) -> type_field ctx {e with etype = apply_params a.a_types pl a.a_this} i p mode;
  1194. | _ -> raise Not_found)
  1195. with Not_found ->
  1196. no_field())
  1197. | _ ->
  1198. try using_field ctx mode e i p with Not_found -> no_field()
  1199. let type_bind ctx (e : texpr) params p =
  1200. let args,ret = match follow e.etype with TFun(args, ret) -> args, ret | _ -> error "First parameter of callback is not a function" p in
  1201. let vexpr v = mk (TLocal v) v.v_type p in
  1202. let acount = ref 0 in
  1203. let alloc_name n =
  1204. if n = "" || String.length n > 2 then begin
  1205. incr acount;
  1206. "a" ^ string_of_int !acount;
  1207. end else
  1208. n
  1209. in
  1210. let rec loop args params given_args missing_args ordered_args = match args, params with
  1211. | [], [] -> given_args,missing_args,ordered_args
  1212. | [], _ -> error "Too many callback arguments" p
  1213. | (n,o,t) :: args , [] when o ->
  1214. let a = if is_pos_infos t then
  1215. let infos = mk_infos ctx p [] in
  1216. ordered_args @ [type_expr ctx infos (WithType t)]
  1217. else if ctx.com.config.pf_pad_nulls then
  1218. (ordered_args @ [(mk (TConst TNull) t_dynamic p)])
  1219. else
  1220. ordered_args
  1221. in
  1222. loop args [] given_args missing_args a
  1223. | (n,o,t) :: _ , (EConst(Ident "_"),p) :: _ when ctx.com.platform = Flash && o && not (is_nullable t) ->
  1224. error "Usage of _ is currently not supported for optional non-nullable arguments on flash9" p
  1225. | (n,o,t) :: args , ([] as params)
  1226. | (n,o,t) :: args , (EConst(Ident "_"),_) :: params ->
  1227. let v = alloc_var (alloc_name n) (if o then ctx.t.tnull t else t) in
  1228. loop args params given_args (missing_args @ [v,o]) (ordered_args @ [vexpr v])
  1229. | (n,o,t) :: args , param :: params ->
  1230. let e = type_expr ctx param (WithType t) in
  1231. unify ctx e.etype t p;
  1232. let v = alloc_var (alloc_name n) t in
  1233. loop args params (given_args @ [v,o,Some e]) missing_args (ordered_args @ [vexpr v])
  1234. in
  1235. let given_args,missing_args,ordered_args = loop args params [] [] [] in
  1236. let rec gen_loc_name n =
  1237. let name = if n = 0 then "f" else "f" ^ (string_of_int n) in
  1238. if List.exists (fun (n,_,_) -> name = n) args then gen_loc_name (n + 1) else name
  1239. in
  1240. let loc = alloc_var (gen_loc_name 0) e.etype in
  1241. let given_args = (loc,false,Some e) :: given_args in
  1242. let inner_fun_args l = List.map (fun (v,o) -> v.v_name, o, v.v_type) l in
  1243. let t_inner = TFun(inner_fun_args missing_args, ret) in
  1244. let call = make_call ctx (vexpr loc) ordered_args ret p in
  1245. let func = mk (TFunction {
  1246. tf_args = List.map (fun (v,o) -> v, if o then Some TNull else None) missing_args;
  1247. tf_type = ret;
  1248. tf_expr = mk (TReturn (Some call)) ret p;
  1249. }) t_inner p in
  1250. let outer_fun_args l = List.map (fun (v,o,_) -> v.v_name, o, v.v_type) l in
  1251. let func = mk (TFunction {
  1252. tf_args = List.map (fun (v,_,_) -> v,None) given_args;
  1253. tf_type = t_inner;
  1254. tf_expr = mk (TReturn (Some func)) t_inner p;
  1255. }) (TFun(outer_fun_args given_args, t_inner)) p in
  1256. make_call ctx func (List.map (fun (_,_,e) -> (match e with Some e -> e | None -> assert false)) given_args) t_inner p
  1257. (*
  1258. We want to try unifying as an integer and apply side effects.
  1259. However, in case the value is not a normal Monomorph but one issued
  1260. from a Dynamic relaxation, we will instead unify with float since
  1261. we don't want to accidentaly truncate the value
  1262. *)
  1263. let unify_int ctx e k =
  1264. let is_dynamic t =
  1265. match follow t with
  1266. | TDynamic _ -> true
  1267. | _ -> false
  1268. in
  1269. let is_dynamic_array t =
  1270. match follow t with
  1271. | TInst (_,[p]) -> is_dynamic p
  1272. | _ -> true
  1273. in
  1274. let is_dynamic_field t f =
  1275. match follow t with
  1276. | TAnon a ->
  1277. (try is_dynamic (PMap.find f a.a_fields).cf_type with Not_found -> false)
  1278. | TInst (c,pl) ->
  1279. (try is_dynamic (apply_params c.cl_types pl ((let _,t,_ = Type.class_field c f in t))) with Not_found -> false)
  1280. | _ ->
  1281. true
  1282. in
  1283. let is_dynamic_return t =
  1284. match follow t with
  1285. | TFun (_,r) -> is_dynamic r
  1286. | _ -> true
  1287. in
  1288. (*
  1289. This is some quick analysis that matches the most common cases of dynamic-to-mono convertions
  1290. *)
  1291. let rec maybe_dynamic_mono e =
  1292. match e.eexpr with
  1293. | TLocal _ -> is_dynamic e.etype
  1294. | TArray({ etype = t } as e,_) -> is_dynamic_array t || maybe_dynamic_rec e t
  1295. | TField({ etype = t } as e,f) -> is_dynamic_field t (field_name f) || maybe_dynamic_rec e t
  1296. | TCall({ etype = t } as e,_) -> is_dynamic_return t || maybe_dynamic_rec e t
  1297. | TParenthesis e -> maybe_dynamic_mono e
  1298. | TIf (_,a,Some b) -> maybe_dynamic_mono a || maybe_dynamic_mono b
  1299. | _ -> false
  1300. and maybe_dynamic_rec e t =
  1301. match follow t with
  1302. | TMono _ | TDynamic _ -> maybe_dynamic_mono e
  1303. (* we might have inferenced a tmono into a single field *)
  1304. | TAnon a when !(a.a_status) = Opened -> maybe_dynamic_mono e
  1305. | _ -> false
  1306. in
  1307. match k with
  1308. | KUnk | KDyn when maybe_dynamic_mono e ->
  1309. unify ctx e.etype ctx.t.tfloat e.epos;
  1310. false
  1311. | _ ->
  1312. unify ctx e.etype ctx.t.tint e.epos;
  1313. true
  1314. let type_generic_function ctx (e,cf) el ?(using_param=None) p =
  1315. if cf.cf_params = [] then error "Function has no type parameters and cannot be generic" p;
  1316. let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
  1317. let c,stat = match follow e.etype with
  1318. | (TInst (c,_)) -> c,false
  1319. | (TAnon a) -> (match !(a.a_status) with Statics c -> c,true | _ -> assert false)
  1320. | _ -> assert false
  1321. in
  1322. let t = apply_params cf.cf_params monos cf.cf_type in
  1323. add_constraint_checks ctx c.cl_types [] cf monos p;
  1324. let args,ret = match t,using_param with
  1325. | TFun((_,_,ta) :: args,ret),Some e ->
  1326. (* manually unify first argument *)
  1327. unify ctx e.etype ta p;
  1328. args,ret
  1329. | TFun(args,ret),None -> args,ret
  1330. | _ -> error "Invalid field type for generic call" p
  1331. in
  1332. let el,_ = unify_call_params ctx None el args ret p false in
  1333. let el = match using_param with None -> el | Some e -> e :: el in
  1334. (try
  1335. let gctx = Codegen.make_generic ctx cf.cf_params monos p in
  1336. let name = cf.cf_name ^ "_" ^ gctx.Codegen.name in
  1337. let cf2 = try
  1338. let cf2 = PMap.find name (if stat then c.cl_statics else c.cl_fields) in
  1339. unify ctx cf2.cf_type t cf2.cf_pos;
  1340. cf2
  1341. with Not_found ->
  1342. let cf2 = mk_field name t cf.cf_pos in
  1343. if stat then begin
  1344. c.cl_statics <- PMap.add name cf2 c.cl_statics;
  1345. c.cl_ordered_statics <- cf2 :: c.cl_ordered_statics
  1346. end else begin
  1347. c.cl_fields <- PMap.add name cf2 c.cl_fields;
  1348. c.cl_ordered_fields <- cf2 :: c.cl_ordered_fields
  1349. end;
  1350. ignore(follow cf.cf_type);
  1351. cf2.cf_expr <- (match cf.cf_expr with
  1352. | None -> None
  1353. | Some e -> Some (Codegen.generic_substitute_expr gctx e));
  1354. cf2.cf_kind <- cf.cf_kind;
  1355. cf2.cf_public <- cf.cf_public;
  1356. let metadata = List.filter (fun (m,_,_) -> match m with
  1357. | Meta.Generic -> false
  1358. | _ -> true
  1359. ) cf.cf_meta in
  1360. cf2.cf_meta <- (Meta.NoCompletion,[],p) :: (Meta.NoUsing,[],p) :: metadata;
  1361. cf2
  1362. in
  1363. let e = if stat then type_type ctx c.cl_path p else e in
  1364. let e = acc_get ctx (field_access ctx MCall cf2 (if stat then FStatic (c,cf2) else FInstance (c,cf2)) cf2.cf_type e p) p in
  1365. (el,ret,e)
  1366. with Codegen.Generic_Exception (msg,p) ->
  1367. error msg p)
  1368. let call_to_string ctx c e =
  1369. let et = type_module_type ctx (TClassDecl c) None e.epos in
  1370. let cf = PMap.find "toString" c.cl_statics in
  1371. make_call ctx (mk (TField(et,FStatic(c,cf))) cf.cf_type e.epos) [e] ctx.t.tstring e.epos
  1372. let rec type_binop ctx op e1 e2 is_assign_op p =
  1373. match op with
  1374. | OpAssign ->
  1375. let e1 = type_access ctx (fst e1) (snd e1) MSet in
  1376. let tt = (match e1 with AKNo _ | AKInline _ | AKUsing _ | AKMacro _ | AKAccess _ -> Value | AKSet(_,t,_) -> WithType t | AKExpr e -> WithType e.etype) in
  1377. let e2 = type_expr ctx e2 tt in
  1378. (match e1 with
  1379. | AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p
  1380. | AKExpr e1 ->
  1381. unify ctx e2.etype e1.etype p;
  1382. check_assign ctx e1;
  1383. (match e1.eexpr , e2.eexpr with
  1384. | TLocal i1 , TLocal i2 when i1 == i2 -> error "Assigning a value to itself" p
  1385. | TField ({ eexpr = TConst TThis },FInstance (_,f1)) , TField ({ eexpr = TConst TThis },FInstance (_,f2)) when f1 == f2 ->
  1386. error "Assigning a value to itself" p
  1387. | _ , _ -> ());
  1388. mk (TBinop (op,e1,e2)) e1.etype p
  1389. | AKSet (e,t,cf) ->
  1390. unify ctx e2.etype t p;
  1391. make_call ctx (mk (TField (e,quick_field_dynamic e.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [e2] t p
  1392. | AKAccess(ebase,ekey) ->
  1393. let a,pl,c = match follow ebase.etype with TAbstract({a_impl = Some c} as a,pl) -> a,pl,c | _ -> error "Invalid operation" p in
  1394. let cf,tf,r =
  1395. try find_array_access a pl c ekey.etype e2.etype true
  1396. with Not_found -> error ("No @:arrayAccess function accepts arguments of " ^ (s_type (print_context()) ekey.etype) ^ " and " ^ (s_type (print_context()) e2.etype)) p
  1397. in
  1398. let et = type_module_type ctx (TClassDecl c) None p in
  1399. let ef = mk (TField(et,(FStatic(c,cf)))) tf p in
  1400. make_call ctx ef [ebase;ekey;e2] r p
  1401. | AKUsing(ef,_,_,et) ->
  1402. (* this must be an abstract setter *)
  1403. let ret = match follow ef.etype with
  1404. | TFun([_;(_,_,t)],ret) ->
  1405. unify ctx e2.etype t p;
  1406. ret
  1407. | _ -> error "Invalid field type for abstract setter" p
  1408. in
  1409. make_call ctx ef [et;e2] ret p
  1410. | AKInline _ | AKMacro _ ->
  1411. assert false)
  1412. | OpAssignOp op ->
  1413. (match type_access ctx (fst e1) (snd e1) MSet with
  1414. | AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p
  1415. | AKExpr e ->
  1416. let eop = type_binop ctx op e1 e2 true p in
  1417. (match eop.eexpr with
  1418. | TBinop (_,_,e2) ->
  1419. unify ctx eop.etype e.etype p;
  1420. check_assign ctx e;
  1421. mk (TBinop (OpAssignOp op,e,e2)) e.etype p;
  1422. | TField(e2,FDynamic ":needsAssign") ->
  1423. unify ctx e2.etype e.etype p;
  1424. check_assign ctx e;
  1425. mk (TBinop (OpAssign,e,e2)) e.etype p;
  1426. | _ ->
  1427. (* this must be an abstract cast *)
  1428. check_assign ctx e;
  1429. eop)
  1430. | AKSet (e,t,cf) ->
  1431. let l = save_locals ctx in
  1432. let v = gen_local ctx e.etype in
  1433. let ev = mk (TLocal v) e.etype p in
  1434. let get = type_binop ctx op (EField ((EConst (Ident v.v_name),p),cf.cf_name),p) e2 true p in
  1435. unify ctx get.etype t p;
  1436. l();
  1437. mk (TBlock [
  1438. mk (TVars [v,Some e]) ctx.t.tvoid p;
  1439. make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [get] t p
  1440. ]) t p
  1441. | AKUsing(ef,c,cf,et) ->
  1442. (* abstract setter + getter *)
  1443. let ta = match c.cl_kind with KAbstractImpl a -> TAbstract(a, List.map (fun _ -> mk_mono()) a.a_types) | _ -> assert false in
  1444. let ret = match follow ef.etype with
  1445. | TFun([_;_],ret) -> ret
  1446. | _ -> error "Invalid field type for abstract setter" p
  1447. in
  1448. let l = save_locals ctx in
  1449. let v = gen_local ctx ta in
  1450. let ev = mk (TLocal v) ta p in
  1451. (* this relies on the fact that cf_name is set_name *)
  1452. let getter_name = String.sub cf.cf_name 4 (String.length cf.cf_name - 4) in
  1453. let get = type_binop ctx op (EField ((EConst (Ident v.v_name),p),getter_name),p) e2 true p in
  1454. unify ctx get.etype ret p;
  1455. l();
  1456. mk (TBlock [
  1457. mk (TVars [v,Some et]) ctx.t.tvoid p;
  1458. make_call ctx ef [ev;get] ret p
  1459. ]) ret p
  1460. | AKAccess(ebase,ekey) ->
  1461. let a,pl,c = match follow ebase.etype with TAbstract({a_impl = Some c} as a,pl) -> a,pl,c | _ -> error "Invalid operation" p in
  1462. let et = type_module_type ctx (TClassDecl c) None p in
  1463. let cf_get,tf_get,r_get =
  1464. try find_array_access a pl c ekey.etype t_dynamic false
  1465. with Not_found -> error ("No @:arrayAccess function accepts an argument of " ^ (s_type (print_context()) ekey.etype)) p
  1466. in
  1467. (* bind complex keys to a variable so they do not make it into the output twice *)
  1468. let ekey,l = match Optimizer.make_constant_expression ctx ekey with
  1469. | Some e -> e, fun () -> None
  1470. | None ->
  1471. let save = save_locals ctx in
  1472. let v = gen_local ctx ekey.etype in
  1473. let e = mk (TLocal v) ekey.etype p in
  1474. e, fun () -> (save(); Some (mk (TVars [v,Some ekey]) ctx.t.tvoid p))
  1475. in
  1476. let ast_call = ECall((EField(Interp.make_ast ebase,cf_get.cf_name),p),[Interp.make_ast ekey]),p in
  1477. let eget = type_binop ctx op ast_call e2 true p in
  1478. unify ctx eget.etype r_get p;
  1479. let cf_set,tf_set,r_set =
  1480. try find_array_access a pl c ekey.etype eget.etype true
  1481. with Not_found -> error ("No @:arrayAccess function accepts arguments of " ^ (s_type (print_context()) ekey.etype) ^ " and " ^ (s_type (print_context()) eget.etype)) p
  1482. in
  1483. let ef_set = mk (TField(et,(FStatic(c,cf_set)))) tf_set p in
  1484. (match l() with
  1485. | None -> make_call ctx ef_set [ebase;ekey;eget] r_set p
  1486. | Some e ->
  1487. mk (TBlock [
  1488. e;
  1489. make_call ctx ef_set [ebase;ekey;eget] r_set p
  1490. ]) r_set p)
  1491. | AKInline _ | AKMacro _ ->
  1492. assert false)
  1493. | _ ->
  1494. let e1 = type_expr ctx e1 Value in
  1495. let e2 = type_expr ctx e2 (if op == OpEq || op == OpNotEq then WithType e1.etype else Value) in
  1496. let tint = ctx.t.tint in
  1497. let tfloat = ctx.t.tfloat in
  1498. let tstring = ctx.t.tstring in
  1499. let to_string e =
  1500. match classify e.etype with
  1501. | KAbstract {a_impl = Some c} when PMap.mem "toString" c.cl_statics ->
  1502. call_to_string ctx c e
  1503. | KUnk | KDyn | KParam _ | KOther | KAbstract _ ->
  1504. let std = type_type ctx ([],"Std") e.epos in
  1505. let acc = acc_get ctx (type_field ctx std "string" e.epos MCall) e.epos in
  1506. ignore(follow acc.etype);
  1507. let acc = (match acc.eexpr with TField (e,FClosure (Some c,f)) -> { acc with eexpr = TField (e,FInstance (c,f)) } | _ -> acc) in
  1508. make_call ctx acc [e] ctx.t.tstring e.epos
  1509. | KInt | KFloat | KString -> e
  1510. in
  1511. let mk_op t =
  1512. if op = OpAdd && (classify t) = KString then
  1513. let e1 = to_string e1 in
  1514. let e2 = to_string e2 in
  1515. mk (TBinop (op,e1,e2)) t p
  1516. else
  1517. mk (TBinop (op,e1,e2)) t p
  1518. in
  1519. let make e1 e2 = match op with
  1520. | OpAdd ->
  1521. mk_op (match classify e1.etype, classify e2.etype with
  1522. | KInt , KInt ->
  1523. tint
  1524. | KFloat , KInt
  1525. | KInt, KFloat
  1526. | KFloat, KFloat ->
  1527. tfloat
  1528. | KUnk , KInt ->
  1529. if unify_int ctx e1 KUnk then tint else tfloat
  1530. | KUnk , KFloat
  1531. | KUnk , KString ->
  1532. unify ctx e1.etype e2.etype e1.epos;
  1533. e1.etype
  1534. | KInt , KUnk ->
  1535. if unify_int ctx e2 KUnk then tint else tfloat
  1536. | KFloat , KUnk
  1537. | KString , KUnk ->
  1538. unify ctx e2.etype e1.etype e2.epos;
  1539. e2.etype
  1540. | _ , KString
  1541. | KString , _ ->
  1542. tstring
  1543. | _ , KDyn ->
  1544. e2.etype
  1545. | KDyn , _ ->
  1546. e1.etype
  1547. | KUnk , KUnk ->
  1548. let ok1 = unify_int ctx e1 KUnk in
  1549. let ok2 = unify_int ctx e2 KUnk in
  1550. if ok1 && ok2 then tint else tfloat
  1551. | KParam t1, KParam t2 when Type.type_iseq t1 t2 ->
  1552. t1
  1553. | KParam t, KInt | KInt, KParam t ->
  1554. t
  1555. | KParam _, KFloat | KFloat, KParam _ | KParam _, KParam _ ->
  1556. tfloat
  1557. | KParam t, KUnk ->
  1558. unify ctx e2.etype tfloat e2.epos;
  1559. tfloat
  1560. | KUnk, KParam t ->
  1561. unify ctx e1.etype tfloat e1.epos;
  1562. tfloat
  1563. | KAbstract _,_
  1564. | _,KAbstract _
  1565. | KParam _, _
  1566. | _, KParam _
  1567. | KOther, _
  1568. | _ , KOther ->
  1569. let pr = print_context() in
  1570. error ("Cannot add " ^ s_type pr e1.etype ^ " and " ^ s_type pr e2.etype) p
  1571. )
  1572. | OpAnd
  1573. | OpOr
  1574. | OpXor
  1575. | OpShl
  1576. | OpShr
  1577. | OpUShr ->
  1578. let i = tint in
  1579. unify ctx e1.etype i e1.epos;
  1580. unify ctx e2.etype i e2.epos;
  1581. mk_op i
  1582. | OpMod
  1583. | OpMult
  1584. | OpDiv
  1585. | OpSub ->
  1586. let result = ref (if op = OpDiv then tfloat else tint) in
  1587. (match classify e1.etype, classify e2.etype with
  1588. | KFloat, KFloat ->
  1589. result := tfloat
  1590. | KParam t1, KParam t2 when Type.type_iseq t1 t2 ->
  1591. if op <> OpDiv then result := t1
  1592. | KParam _, KParam _ ->
  1593. result := tfloat
  1594. | KParam t, KInt | KInt, KParam t ->
  1595. if op <> OpDiv then result := t
  1596. | KParam _, KFloat | KFloat, KParam _ ->
  1597. result := tfloat
  1598. | KFloat, k ->
  1599. ignore(unify_int ctx e2 k);
  1600. result := tfloat
  1601. | k, KFloat ->
  1602. ignore(unify_int ctx e1 k);
  1603. result := tfloat
  1604. | k1 , k2 ->
  1605. let ok1 = unify_int ctx e1 k1 in
  1606. let ok2 = unify_int ctx e2 k2 in
  1607. if not ok1 || not ok2 then result := tfloat;
  1608. );
  1609. mk_op !result
  1610. | OpEq
  1611. | OpNotEq ->
  1612. (try
  1613. unify_raise ctx e1.etype e2.etype p;
  1614. (* we only have to check one type here, because unification fails if one is Void and the other is not *)
  1615. (match follow e2.etype with TAbstract({a_path=[],"Void"},_) -> error "Cannot compare Void" p | _ -> ())
  1616. with
  1617. Error (Unify _,_) -> unify ctx e2.etype e1.etype p);
  1618. mk_op ctx.t.tbool
  1619. | OpGt
  1620. | OpGte
  1621. | OpLt
  1622. | OpLte ->
  1623. (match classify e1.etype, classify e2.etype with
  1624. | KInt , KInt | KInt , KFloat | KFloat , KInt | KFloat , KFloat | KString , KString -> ()
  1625. | KInt , KUnk -> ignore(unify_int ctx e2 KUnk)
  1626. | KFloat , KUnk | KString , KUnk -> unify ctx e2.etype e1.etype e2.epos
  1627. | KUnk , KInt -> ignore(unify_int ctx e1 KUnk)
  1628. | KUnk , KFloat | KUnk , KString -> unify ctx e1.etype e2.etype e1.epos
  1629. | KUnk , KUnk ->
  1630. ignore(unify_int ctx e1 KUnk);
  1631. ignore(unify_int ctx e2 KUnk);
  1632. | KDyn , KInt | KDyn , KFloat | KDyn , KString -> ()
  1633. | KInt , KDyn | KFloat , KDyn | KString , KDyn -> ()
  1634. | KDyn , KDyn -> ()
  1635. | KParam _ , x | x , KParam _ when x <> KString && x <> KOther -> ()
  1636. | KAbstract _,_
  1637. | _,KAbstract _
  1638. | KDyn , KUnk
  1639. | KUnk , KDyn
  1640. | KString , KInt
  1641. | KString , KFloat
  1642. | KInt , KString
  1643. | KFloat , KString
  1644. | KParam _ , _
  1645. | _ , KParam _
  1646. | KOther , _
  1647. | _ , KOther ->
  1648. let pr = print_context() in
  1649. error ("Cannot compare " ^ s_type pr e1.etype ^ " and " ^ s_type pr e2.etype) p
  1650. );
  1651. mk_op ctx.t.tbool
  1652. | OpBoolAnd
  1653. | OpBoolOr ->
  1654. let b = ctx.t.tbool in
  1655. unify ctx e1.etype b p;
  1656. unify ctx e2.etype b p;
  1657. mk_op b
  1658. | OpInterval ->
  1659. let t = Typeload.load_core_type ctx "IntIterator" in
  1660. unify ctx e1.etype tint e1.epos;
  1661. unify ctx e2.etype tint e2.epos;
  1662. mk (TNew ((match t with TInst (c,[]) -> c | _ -> assert false),[],[e1;e2])) t p
  1663. | OpArrow ->
  1664. error "Unexpected =>" p
  1665. | OpAssign
  1666. | OpAssignOp _ ->
  1667. assert false
  1668. in
  1669. let find_overload a pl c t left =
  1670. let rec loop ops = match ops with
  1671. | [] -> raise Not_found
  1672. | (o,cf) :: ops when is_assign_op && o = OpAssignOp(op) || o == op ->
  1673. (match follow (monomorphs cf.cf_params cf.cf_type) with
  1674. | TFun([(_,_,t1);(_,_,t2)],r) ->
  1675. let t1,t2 = if left || Meta.has Meta.Commutative cf.cf_meta then t1,t2 else t2,t1 in
  1676. if type_iseq t t2 && (if Meta.has Meta.Impl cf.cf_meta then type_iseq (apply_params a.a_types pl a.a_this) t1 else type_iseq (TAbstract(a,pl)) t1) then begin
  1677. if not (can_access ctx c cf true) then display_error ctx ("Cannot access operator function " ^ (s_type_path a.a_path) ^ "." ^ cf.cf_name) p;
  1678. cf,r,o = OpAssignOp(op),Meta.has Meta.Commutative cf.cf_meta
  1679. end else loop ops
  1680. | _ -> loop ops)
  1681. | _ :: ops ->
  1682. loop ops
  1683. in
  1684. loop a.a_ops
  1685. in
  1686. let mk_cast_op c f a pl e1 e2 r assign =
  1687. let t = field_type ctx c [] f p in
  1688. let t = apply_params a.a_types pl t in
  1689. let et = type_module_type ctx (TClassDecl c) None p in
  1690. let ef = mk (TField (et,FStatic (c,f))) t p in
  1691. let ec = make_call ctx ef [e1;e2] r p in
  1692. (* obviously a hack to report back that we need an assignment *)
  1693. if is_assign_op && not assign then mk (TField(ec,FDynamic ":needsAssign")) t_dynamic p else ec
  1694. in
  1695. let cast_rec e1t e2t r =
  1696. let e = make e1t e2t in
  1697. begin try
  1698. unify_raise ctx e.etype r p
  1699. with Error (Unify _,_) ->
  1700. error ("The result of this operation (" ^ (s_type (print_context()) e.etype) ^ ") is not compatible with declared return type " ^ (s_type (print_context()) r)) p;
  1701. end;
  1702. {e with etype = r}
  1703. in
  1704. try (match follow e1.etype with
  1705. | TAbstract ({a_impl = Some c} as a,pl) ->
  1706. let f,r,assign,commutative = find_overload a pl c e2.etype true in
  1707. begin match f.cf_expr with
  1708. | None ->
  1709. let e2 = match follow e2.etype with TAbstract(a,pl) -> {e2 with etype = apply_params a.a_types pl a.a_this} | _ -> e2 in
  1710. cast_rec {e1 with etype = apply_params a.a_types pl a.a_this} e2 r
  1711. | Some _ ->
  1712. mk_cast_op c f a pl e1 e2 r assign
  1713. end
  1714. | _ ->
  1715. raise Not_found)
  1716. with Not_found -> try (match follow e2.etype with
  1717. | TAbstract ({a_impl = Some c} as a,pl) ->
  1718. let f,r,assign,commutative = find_overload a pl c e1.etype false in
  1719. begin match f.cf_expr with
  1720. | None ->
  1721. let e1 = match follow e1.etype with TAbstract(a,pl) -> {e1 with etype = apply_params a.a_types pl a.a_this} | _ -> e1 in
  1722. let e1,e2 = if commutative then e2,e1 else e1,e2 in
  1723. cast_rec e1 {e2 with etype = apply_params a.a_types pl a.a_this} r
  1724. | Some _ ->
  1725. let e1,e2 = if commutative then e2,e1 else e1,e2 in
  1726. mk_cast_op c f a pl e1 e2 r assign
  1727. end
  1728. | _ ->
  1729. raise Not_found)
  1730. with Not_found ->
  1731. make e1 e2
  1732. and type_unop ctx op flag e p =
  1733. let set = (op = Increment || op = Decrement) in
  1734. let acc = type_access ctx (fst e) (snd e) (if set then MSet else MGet) in
  1735. let access e =
  1736. let make e =
  1737. let t = (match op with
  1738. | Not ->
  1739. unify ctx e.etype ctx.t.tbool e.epos;
  1740. ctx.t.tbool
  1741. | Increment
  1742. | Decrement
  1743. | Neg
  1744. | NegBits ->
  1745. if set then check_assign ctx e;
  1746. (match classify e.etype with
  1747. | KFloat -> ctx.t.tfloat
  1748. | KParam t ->
  1749. unify ctx e.etype ctx.t.tfloat e.epos;
  1750. t
  1751. | k ->
  1752. if unify_int ctx e k then ctx.t.tint else ctx.t.tfloat)
  1753. ) in
  1754. mk (TUnop (op,flag,e)) t p
  1755. in
  1756. try (match follow e.etype with
  1757. | TAbstract ({a_impl = Some c} as a,pl) ->
  1758. let rec loop opl = match opl with
  1759. | [] -> raise Not_found
  1760. | (op2,flag2,cf) :: opl when op == op2 && flag == flag2 ->
  1761. let m = mk_mono() in
  1762. let tcf = apply_params c.cl_types pl (monomorphs cf.cf_params cf.cf_type) in
  1763. if Meta.has Meta.Impl cf.cf_meta then begin
  1764. if type_iseq (tfun [apply_params a.a_types pl a.a_this] m) tcf then cf,tcf,m else loop opl
  1765. end else
  1766. if type_iseq (tfun [e.etype] m) tcf then cf,tcf,m else loop opl
  1767. | _ :: opl -> loop opl
  1768. in
  1769. let cf,t,r = loop a.a_unops in
  1770. if not (can_access ctx c cf true) then error ("Cannot access " ^ cf.cf_name) p;
  1771. (match cf.cf_expr with
  1772. | None ->
  1773. let e = make {e with etype = apply_params a.a_types pl a.a_this} in
  1774. unify ctx r e.etype p;
  1775. {e with etype = r}
  1776. | Some _ ->
  1777. let et = type_module_type ctx (TClassDecl c) None p in
  1778. let ef = mk (TField (et,FStatic (c,cf))) t p in
  1779. make_call ctx ef [e] r p)
  1780. | _ -> raise Not_found
  1781. ) with Not_found ->
  1782. make e
  1783. in
  1784. match acc with
  1785. | AKExpr e -> access e
  1786. | AKInline _ | AKUsing _ when not set -> access (acc_get ctx acc p)
  1787. | AKNo s ->
  1788. error ("The field or identifier " ^ s ^ " is not accessible for " ^ (if set then "writing" else "reading")) p
  1789. | AKInline _ | AKUsing _ | AKMacro _ | AKAccess _ ->
  1790. error "This kind of operation is not supported" p
  1791. | AKSet (e,t,cf) ->
  1792. let l = save_locals ctx in
  1793. let v = gen_local ctx e.etype in
  1794. let ev = mk (TLocal v) e.etype p in
  1795. let op = (match op with Increment -> OpAdd | Decrement -> OpSub | _ -> assert false) in
  1796. let one = (EConst (Int "1"),p) in
  1797. let eget = (EField ((EConst (Ident v.v_name),p),cf.cf_name),p) in
  1798. match flag with
  1799. | Prefix ->
  1800. let get = type_binop ctx op eget one false p in
  1801. unify ctx get.etype t p;
  1802. l();
  1803. mk (TBlock [
  1804. mk (TVars [v,Some e]) ctx.t.tvoid p;
  1805. make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [get] t p
  1806. ]) t p
  1807. | Postfix ->
  1808. let v2 = gen_local ctx t in
  1809. let ev2 = mk (TLocal v2) t p in
  1810. let get = type_expr ctx eget Value in
  1811. let plusone = type_binop ctx op (EConst (Ident v2.v_name),p) one false p in
  1812. unify ctx get.etype t p;
  1813. l();
  1814. mk (TBlock [
  1815. mk (TVars [v,Some e; v2,Some get]) ctx.t.tvoid p;
  1816. make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [plusone.etype] t) p) [plusone] t p;
  1817. ev2
  1818. ]) t p
  1819. and type_switch_old ctx e cases def with_type p =
  1820. let eval = type_expr ctx e Value in
  1821. let old_m = ctx.m in
  1822. let enum = ref None in
  1823. let used_cases = Hashtbl.create 0 in
  1824. let is_fake_enum e =
  1825. e.e_path = ([],"Bool") || Meta.has Meta.FakeEnum e.e_meta
  1826. in
  1827. (match follow eval.etype with
  1828. | TEnum (e,_) when is_fake_enum e -> ()
  1829. | TEnum (e,params) ->
  1830. enum := Some (Some (e,params));
  1831. (* hack to prioritize enum lookup *)
  1832. ctx.m <- { ctx.m with module_types = TEnumDecl e :: ctx.m.module_types }
  1833. | TMono _ ->
  1834. enum := Some None;
  1835. | t ->
  1836. if t == t_dynamic then enum := Some None
  1837. );
  1838. let case_expr c =
  1839. enum := None;
  1840. (* this inversion is needed *)
  1841. unify ctx eval.etype c.etype c.epos;
  1842. CExpr c
  1843. in
  1844. let type_match e en s pl =
  1845. let p = e.epos in
  1846. let params = (match !enum with
  1847. | None ->
  1848. assert false
  1849. | Some None when is_fake_enum en ->
  1850. raise Exit
  1851. | Some None ->
  1852. let params = List.map (fun _ -> mk_mono()) en.e_types in
  1853. enum := Some (Some (en,params));
  1854. unify ctx eval.etype (TEnum (en,params)) p;
  1855. params
  1856. | Some (Some (en2,params)) ->
  1857. if en != en2 then error ("This constructor is part of enum " ^ s_type_path en.e_path ^ " but is matched with enum " ^ s_type_path en2.e_path) p;
  1858. params
  1859. ) in
  1860. if Hashtbl.mem used_cases s then error "This constructor has already been used" p;
  1861. Hashtbl.add used_cases s ();
  1862. let cst = (try PMap.find s en.e_constrs with Not_found -> assert false) in
  1863. let et = apply_params en.e_types params (monomorphs cst.ef_params cst.ef_type) in
  1864. let pl, rt = (match et with
  1865. | TFun (l,rt) ->
  1866. let pl = (if List.length l = List.length pl then pl else
  1867. match pl with
  1868. | [None] -> List.map (fun _ -> None) l
  1869. | _ -> error ("This constructor requires " ^ string_of_int (List.length l) ^ " arguments") p
  1870. ) in
  1871. Some (List.map2 (fun p (_,_,t) -> match p with None -> None | Some p -> Some (p, t)) pl l), rt
  1872. | TEnum _ ->
  1873. if pl <> [] then error "This constructor does not require any argument" p;
  1874. None, et
  1875. | _ -> assert false
  1876. ) in
  1877. unify ctx rt eval.etype p;
  1878. CMatch (cst,pl,p)
  1879. in
  1880. let type_case efull e pl p =
  1881. try
  1882. let e = (match !enum, e with
  1883. | None, _ -> raise Exit
  1884. | Some (Some (en,params)), (EConst (Ident i),p) ->
  1885. let ef = (try
  1886. PMap.find i en.e_constrs
  1887. with Not_found ->
  1888. display_error ctx ("This constructor is not part of the enum " ^ s_type_path en.e_path) p;
  1889. raise Exit
  1890. ) in
  1891. mk (fast_enum_field en ef p) (apply_params en.e_types params ef.ef_type) (snd e)
  1892. | _ ->
  1893. type_expr ctx e Value
  1894. ) in
  1895. let pl = List.map (fun e ->
  1896. match fst e with
  1897. | EConst (Ident "_") -> None
  1898. | EConst (Ident i) -> Some i
  1899. | _ -> raise Exit
  1900. ) pl in
  1901. (match e.eexpr with
  1902. | TField (_,FEnum (en,c)) -> type_match e en c.ef_name pl
  1903. | _ -> if pl = [] then case_expr e else raise Exit)
  1904. with Exit ->
  1905. case_expr (type_expr ctx efull Value)
  1906. in
  1907. let cases = List.map (fun (el,eg,e2) ->
  1908. if el = [] then error "Case must match at least one expression" (punion_el el);
  1909. let el = List.map (fun e ->
  1910. match e with
  1911. | (ECall (c,pl),p) -> type_case e c pl p
  1912. | e -> type_case e e [] (snd e)
  1913. ) el in
  1914. el, e2
  1915. ) cases in
  1916. ctx.m <- old_m;
  1917. let el = ref [] in
  1918. let type_case_code e =
  1919. let e = (match e with
  1920. | Some e -> type_expr ctx e with_type
  1921. | None -> mk (TBlock []) ctx.com.basic.tvoid Ast.null_pos
  1922. ) in
  1923. el := e :: !el;
  1924. e
  1925. in
  1926. let def() = (match def with
  1927. | None -> None
  1928. | Some e ->
  1929. let locals = save_locals ctx in
  1930. let e = type_case_code e in
  1931. locals();
  1932. Some e
  1933. ) in
  1934. match !enum with
  1935. | Some (Some (enum,enparams)) ->
  1936. let same_params p1 p2 =
  1937. let l1 = (match p1 with None -> [] | Some l -> l) in
  1938. let l2 = (match p2 with None -> [] | Some l -> l) in
  1939. let rec loop = function
  1940. | [] , [] -> true
  1941. | None :: l , [] | [] , None :: l -> loop (l,[])
  1942. | None :: l1, None :: l2 -> loop (l1,l2)
  1943. | Some (n1,t1) :: l1, Some (n2,t2) :: l2 ->
  1944. n1 = n2 && type_iseq t1 t2 && loop (l1,l2)
  1945. | _ -> false
  1946. in
  1947. loop (l1,l2)
  1948. in
  1949. let matchs (el,e) =
  1950. match el with
  1951. | CMatch (c,params,p1) :: l ->
  1952. let params = ref params in
  1953. let cl = List.map (fun c ->
  1954. match c with
  1955. | CMatch (c,p,p2) ->
  1956. if not (same_params p !params) then display_error ctx "Constructors parameters differs : should be same name, same type, and same position" p2;
  1957. if p <> None then params := p;
  1958. c
  1959. | _ -> assert false
  1960. ) l in
  1961. let locals = save_locals ctx in
  1962. let params = (match !params with
  1963. | None -> None
  1964. | Some l ->
  1965. let has = ref false in
  1966. let l = List.map (fun v ->
  1967. match v with
  1968. | None -> None
  1969. | Some (v,t) -> has := true; Some (add_local ctx v t)
  1970. ) l in
  1971. if !has then Some l else None
  1972. ) in
  1973. let e = type_case_code e in
  1974. locals();
  1975. (c :: cl) , params, e
  1976. | _ ->
  1977. assert false
  1978. in
  1979. let indexes (el,vars,e) =
  1980. List.map (fun c -> c.ef_index) el, vars, e
  1981. in
  1982. let cases = List.map matchs cases in
  1983. let def = def() in
  1984. (match def with
  1985. | Some _ -> ()
  1986. | None ->
  1987. let tenum = TEnum(enum,enparams) in
  1988. let l = PMap.fold (fun c acc ->
  1989. let t = monomorphs enum.e_types (monomorphs c.ef_params (match c.ef_type with TFun (_,t) -> t | t -> t)) in
  1990. if Hashtbl.mem used_cases c.ef_name || not (try unify_raise ctx t tenum c.ef_pos; true with Error (Unify _,_) -> false) then acc else c.ef_name :: acc
  1991. ) enum.e_constrs [] in
  1992. match l with
  1993. | [] -> ()
  1994. | _ -> display_error ctx ("Some constructors are not matched : " ^ String.concat "," l) p
  1995. );
  1996. let t = if with_type = NoValue then (mk_mono()) else unify_min ctx (List.rev !el) in
  1997. mk (TMatch (eval,(enum,enparams),List.map indexes cases,def)) t p
  1998. | _ ->
  1999. let consts = Hashtbl.create 0 in
  2000. let exprs (el,e) =
  2001. let el = List.map (fun c ->
  2002. match c with
  2003. | CExpr (({ eexpr = TConst c }) as e) ->
  2004. if Hashtbl.mem consts c then error "Duplicate constant in switch" e.epos;
  2005. Hashtbl.add consts c true;
  2006. e
  2007. | CExpr c -> c
  2008. | CMatch (_,_,p) -> error "You cannot use a normal switch on an enum constructor" p
  2009. ) el in
  2010. let locals = save_locals ctx in
  2011. let e = type_case_code e in
  2012. locals();
  2013. el, e
  2014. in
  2015. let cases = List.map exprs cases in
  2016. let def = def() in
  2017. let t = if with_type = NoValue then (mk_mono()) else unify_min ctx (List.rev !el) in
  2018. mk (TSwitch (eval,cases,def)) t p
  2019. and type_switch ctx e cases def (with_type:with_type) p =
  2020. try
  2021. if (Common.defined ctx.com Common.Define.NoPatternMatching) then raise Exit;
  2022. match_expr ctx e cases def with_type p
  2023. with Exit ->
  2024. type_switch_old ctx e cases def with_type p
  2025. and type_ident ctx i p mode =
  2026. try
  2027. type_ident_raise ctx i p mode
  2028. with Not_found -> try
  2029. (* lookup type *)
  2030. if is_lower_ident i then raise Not_found;
  2031. let e = (try type_type ctx ([],i) p with Error (Module_not_found ([],name),_) when name = i -> raise Not_found) in
  2032. AKExpr e
  2033. with Not_found ->
  2034. if ctx.untyped then begin
  2035. if i = "__this__" then
  2036. AKExpr (mk (TConst TThis) ctx.tthis p)
  2037. else
  2038. let t = mk_mono() in
  2039. AKExpr (mk (TLocal (alloc_var i t)) t p)
  2040. end else begin
  2041. if ctx.curfun = FunStatic && PMap.mem i ctx.curclass.cl_fields then error ("Cannot access " ^ i ^ " in static function") p;
  2042. let err = Unknown_ident i in
  2043. if ctx.in_display then raise (Error (err,p));
  2044. if ctx.com.display then begin
  2045. display_error ctx (error_msg err) p;
  2046. let t = mk_mono() in
  2047. AKExpr (mk (TLocal (add_local ctx i t)) t p)
  2048. end else begin
  2049. if List.exists (fun (i2,_) -> i2 = i) ctx.type_params then
  2050. display_error ctx ("Type parameter " ^ i ^ " is only available at compilation and is not a runtime value") p
  2051. else
  2052. display_error ctx (error_msg err) p;
  2053. AKExpr (mk (TConst TNull) t_dynamic p)
  2054. end
  2055. end
  2056. and type_access ctx e p mode =
  2057. match e with
  2058. | EConst (Ident s) ->
  2059. type_ident ctx s p mode
  2060. | EField _ ->
  2061. let fields path e =
  2062. List.fold_left (fun e (f,_,p) ->
  2063. let e = acc_get ctx (e MGet) p in
  2064. type_field ctx e f p
  2065. ) e path
  2066. in
  2067. let type_path path =
  2068. let rec loop acc path =
  2069. match path with
  2070. | [] ->
  2071. (match List.rev acc with
  2072. | [] -> assert false
  2073. | (name,flag,p) :: path ->
  2074. try
  2075. fields path (type_access ctx (EConst (Ident name)) p)
  2076. with
  2077. Error (Unknown_ident _,p2) as e when p = p2 ->
  2078. try
  2079. let path = ref [] in
  2080. let name , _ , _ = List.find (fun (name,flag,p) ->
  2081. if flag then
  2082. true
  2083. else begin
  2084. path := name :: !path;
  2085. false
  2086. end
  2087. ) (List.rev acc) in
  2088. raise (Error (Module_not_found (List.rev !path,name),p))
  2089. with
  2090. Not_found ->
  2091. if ctx.in_display then raise (Parser.TypePath (List.map (fun (n,_,_) -> n) (List.rev acc),None));
  2092. raise e)
  2093. | (_,false,_) as x :: path ->
  2094. loop (x :: acc) path
  2095. | (name,true,p) as x :: path ->
  2096. let pack = List.rev_map (fun (x,_,_) -> x) acc in
  2097. let def() =
  2098. try
  2099. let e = type_type ctx (pack,name) p in
  2100. fields path (fun _ -> AKExpr e)
  2101. with
  2102. Error (Module_not_found m,_) when m = (pack,name) ->
  2103. loop ((List.rev path) @ x :: acc) []
  2104. in
  2105. match path with
  2106. | (sname,true,p) :: path ->
  2107. let get_static t =
  2108. fields ((sname,true,p) :: path) (fun _ -> AKExpr (type_module_type ctx t None p))
  2109. in
  2110. let check_module m v =
  2111. try
  2112. let md = Typeload.load_module ctx m p in
  2113. (* first look for existing subtype *)
  2114. (try
  2115. let t = List.find (fun t -> not (t_infos t).mt_private && t_path t = (fst m,sname)) md.m_types in
  2116. Some (fields path (fun _ -> AKExpr (type_module_type ctx t None p)))
  2117. with Not_found -> try
  2118. (* then look for main type statics *)
  2119. if fst m = [] then raise Not_found; (* ensure that we use def() to resolve local types first *)
  2120. let t = List.find (fun t -> not (t_infos t).mt_private && t_path t = m) md.m_types in
  2121. Some (get_static t)
  2122. with Not_found ->
  2123. None)
  2124. with Error (Module_not_found m2,_) when m = m2 ->
  2125. None
  2126. in
  2127. let rec loop pack =
  2128. match check_module (pack,name) sname with
  2129. | Some r -> r
  2130. | None ->
  2131. match List.rev pack with
  2132. | [] -> def()
  2133. | _ :: l -> loop (List.rev l)
  2134. in
  2135. (match pack with
  2136. | [] ->
  2137. (try
  2138. let t = List.find (fun t -> snd (t_infos t).mt_path = name) (ctx.m.curmod.m_types @ ctx.m.module_types) in
  2139. get_static t
  2140. with Not_found ->
  2141. loop (fst ctx.m.curmod.m_path))
  2142. | _ ->
  2143. match check_module (pack,name) sname with
  2144. | Some r -> r
  2145. | None -> def());
  2146. | _ -> def()
  2147. in
  2148. match path with
  2149. | [] -> assert false
  2150. | (name,_,p) :: pnext ->
  2151. try
  2152. fields pnext (fun _ -> type_ident_raise ctx name p MGet)
  2153. with
  2154. Not_found -> loop [] path
  2155. in
  2156. let rec loop acc e =
  2157. match fst e with
  2158. | EField (e,s) ->
  2159. loop ((s,not (is_lower_ident s),p) :: acc) e
  2160. | EConst (Ident i) ->
  2161. type_path ((i,not (is_lower_ident i),p) :: acc)
  2162. | _ ->
  2163. fields acc (type_access ctx (fst e) (snd e))
  2164. in
  2165. loop [] (e,p) mode
  2166. | EArray (e1,e2) ->
  2167. let e1 = type_expr ctx e1 Value in
  2168. let e2 = type_expr ctx e2 Value in
  2169. (try (match follow e1.etype with
  2170. | TAbstract ({a_impl = Some c} as a,pl) when a.a_array <> [] ->
  2171. (match mode with
  2172. | MSet ->
  2173. (* resolve later *)
  2174. AKAccess (e1, e2)
  2175. | _ ->
  2176. let cf,tf,r = find_array_access a pl c e2.etype t_dynamic false in
  2177. let et = type_module_type ctx (TClassDecl c) None p in
  2178. let ef = mk (TField(et,(FStatic(c,cf)))) tf p in
  2179. AKExpr (make_call ctx ef [e1;e2] r p))
  2180. | _ -> raise Not_found)
  2181. with Not_found ->
  2182. unify ctx e2.etype ctx.t.tint e2.epos;
  2183. let rec loop et =
  2184. match follow et with
  2185. | TInst ({ cl_array_access = Some t; cl_types = pl },tl) ->
  2186. apply_params pl tl t
  2187. | TInst ({ cl_super = Some (c,stl); cl_types = pl },tl) ->
  2188. apply_params pl tl (loop (TInst (c,stl)))
  2189. | TInst ({ cl_path = [],"ArrayAccess" },[t]) ->
  2190. t
  2191. | TAbstract(a,tl) when Meta.has Meta.ArrayAccess a.a_meta ->
  2192. loop (apply_params a.a_types tl a.a_this)
  2193. | _ ->
  2194. let pt = mk_mono() in
  2195. let t = ctx.t.tarray pt in
  2196. (try unify_raise ctx et t p
  2197. with Error(Unify _,_) -> if not ctx.untyped then error ("Array access is not allowed on " ^ (s_type (print_context()) e1.etype)) e1.epos);
  2198. pt
  2199. in
  2200. let pt = loop e1.etype in
  2201. AKExpr (mk (TArray (e1,e2)) pt p))
  2202. | _ ->
  2203. AKExpr (type_expr ctx (e,p) Value)
  2204. and type_vars ctx vl p in_block =
  2205. let save = if in_block then (fun() -> ()) else save_locals ctx in
  2206. let vl = List.map (fun (v,t,e) ->
  2207. try
  2208. let t = Typeload.load_type_opt ctx p t in
  2209. let e = (match e with
  2210. | None -> None
  2211. | Some e ->
  2212. let e = type_expr ctx e (WithType t) in
  2213. unify ctx e.etype t p;
  2214. Some e
  2215. ) in
  2216. if v.[0] = '$' && not ctx.com.display then error "Variables names starting with a dollar are not allowed" p;
  2217. add_local ctx v t, e
  2218. with
  2219. Error (e,p) ->
  2220. display_error ctx (error_msg e) p;
  2221. add_local ctx v t_dynamic, None
  2222. ) vl in
  2223. save();
  2224. mk (TVars vl) ctx.t.tvoid p
  2225. and with_type_error ctx with_type msg p =
  2226. match with_type with
  2227. | WithTypeResume _ -> raise (WithTypeError ([Unify_custom msg],p))
  2228. | _ -> display_error ctx msg p
  2229. and type_expr ctx (e,p) (with_type:with_type) =
  2230. match e with
  2231. | EField ((EConst (String s),p),"code") ->
  2232. if UTF8.length s <> 1 then error "String must be a single UTF8 char" p;
  2233. mk (TConst (TInt (Int32.of_int (UChar.code (UTF8.get s 0))))) ctx.t.tint p
  2234. | EField(_,n) when n.[0] = '$' ->
  2235. error "Field names starting with $ are not allowed" p
  2236. | EConst (Ident s) ->
  2237. (try
  2238. acc_get ctx (type_ident_raise ~imported_enums:false ctx s p MGet) p
  2239. with Not_found -> try
  2240. (match with_type with
  2241. | WithType t | WithTypeResume t ->
  2242. (match follow t with
  2243. | TEnum (e,pl) ->
  2244. (try
  2245. let ef = PMap.find s e.e_constrs in
  2246. mk (fast_enum_field e ef p) (apply_params e.e_types pl (monomorphs ef.ef_params ef.ef_type)) p
  2247. with Not_found ->
  2248. if ctx.untyped then raise Not_found;
  2249. with_type_error ctx with_type (string_error s e.e_names ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path e.e_path)) p;
  2250. mk (TConst TNull) t p)
  2251. | _ -> raise Not_found)
  2252. | _ ->
  2253. raise Not_found)
  2254. with Not_found ->
  2255. acc_get ctx (type_access ctx e p MGet) p)
  2256. | EField _
  2257. | EArray _ ->
  2258. acc_get ctx (type_access ctx e p MGet) p
  2259. | EConst (Regexp (r,opt)) ->
  2260. let str = mk (TConst (TString r)) ctx.t.tstring p in
  2261. let opt = mk (TConst (TString opt)) ctx.t.tstring p in
  2262. let t = Typeload.load_core_type ctx "EReg" in
  2263. mk (TNew ((match t with TInst (c,[]) -> c | _ -> assert false),[],[str;opt])) t p
  2264. | EConst (String s) when Lexer.is_fmt_string p ->
  2265. let e = ref None in
  2266. let pmin = ref p.pmin in
  2267. let min = ref (p.pmin + 1) in
  2268. let add enext len =
  2269. let p = { p with pmin = !min; pmax = !min + len } in
  2270. min := !min + len;
  2271. match !e with
  2272. | None -> e := Some (enext,p)
  2273. | Some prev ->
  2274. e := Some (EBinop (OpAdd,prev,(enext,p)),punion (pos prev) p)
  2275. in
  2276. let add_sub start pos =
  2277. let len = pos - start in
  2278. if len > 0 || !e = None then add (EConst (String (String.sub s start len))) len
  2279. in
  2280. let warn_escape = Common.defined ctx.com Define.FormatWarning in
  2281. let warn pos len =
  2282. ctx.com.warning "This string is formated" { p with pmin = !pmin + 1 + pos; pmax = !pmin + 1 + pos + len }
  2283. in
  2284. let len = String.length s in
  2285. let rec parse start pos =
  2286. if pos = len then add_sub start pos else
  2287. let c = String.unsafe_get s pos in
  2288. let pos = pos + 1 in
  2289. if c = '\'' then begin
  2290. incr pmin;
  2291. incr min;
  2292. end;
  2293. if c <> '$' || pos = len then parse start pos else
  2294. match String.unsafe_get s pos with
  2295. | '$' ->
  2296. if warn_escape then warn pos 1;
  2297. (* double $ *)
  2298. add_sub start pos;
  2299. parse (pos + 1) (pos + 1)
  2300. | '{' ->
  2301. parse_group start pos '{' '}' "brace"
  2302. | 'a'..'z' | 'A'..'Z' | '_' ->
  2303. add_sub start (pos - 1);
  2304. incr min;
  2305. let rec loop i =
  2306. if i = len then i else
  2307. let c = String.unsafe_get s i in
  2308. match c with
  2309. | 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' -> loop (i+1)
  2310. | _ -> i
  2311. in
  2312. let iend = loop (pos + 1) in
  2313. let len = iend - pos in
  2314. if warn_escape then warn pos len;
  2315. add (EConst (Ident (String.sub s pos len))) len;
  2316. parse (pos + len) (pos + len)
  2317. | _ ->
  2318. (* keep as-it *)
  2319. parse start pos
  2320. and parse_group start pos gopen gclose gname =
  2321. add_sub start (pos - 1);
  2322. let rec loop groups i =
  2323. if i = len then
  2324. match groups with
  2325. | [] -> assert false
  2326. | g :: _ -> error ("Unclosed " ^ gname) { p with pmin = !pmin + g + 1; pmax = !pmin + g + 2 }
  2327. else
  2328. let c = String.unsafe_get s i in
  2329. if c = gopen then
  2330. loop (i :: groups) (i + 1)
  2331. else if c = gclose then begin
  2332. let groups = List.tl groups in
  2333. if groups = [] then i else loop groups (i + 1)
  2334. end else
  2335. loop groups (i + 1)
  2336. in
  2337. let send = loop [pos] (pos + 1) in
  2338. let slen = send - pos - 1 in
  2339. let scode = String.sub s (pos + 1) slen in
  2340. if warn_escape then warn (pos + 1) slen;
  2341. min := !min + 2;
  2342. add (fst (parse_expr_string ctx scode { p with pmin = !pmin + pos + 2; pmax = !pmin + send + 1 } true)) slen;
  2343. min := !min + 1;
  2344. parse (send + 1) (send + 1)
  2345. in
  2346. parse 0 0;
  2347. (match !e with
  2348. | None -> assert false
  2349. | Some e -> type_expr ctx e with_type);
  2350. | EConst c ->
  2351. Codegen.type_constant ctx.com c p
  2352. | EBinop (op,e1,e2) ->
  2353. type_binop ctx op e1 e2 false p
  2354. | EBlock [] when with_type <> NoValue ->
  2355. type_expr ctx (EObjectDecl [],p) with_type
  2356. | EBlock l ->
  2357. let locals = save_locals ctx in
  2358. let rec loop = function
  2359. | [] -> []
  2360. | (EVars vl,p) :: l ->
  2361. let e = type_vars ctx vl p true in
  2362. e :: loop l
  2363. | [e] ->
  2364. (try
  2365. [type_expr ctx e with_type]
  2366. with
  2367. Error (e,p) -> display_error ctx (error_msg e) p; [])
  2368. | e :: l ->
  2369. try
  2370. let e = type_expr ctx e NoValue in
  2371. e :: loop l
  2372. with
  2373. Error (e,p) -> display_error ctx (error_msg e) p; loop l
  2374. in
  2375. let l = loop l in
  2376. locals();
  2377. let rec loop = function
  2378. | [] -> ctx.t.tvoid
  2379. | [e] -> e.etype
  2380. | _ :: l -> loop l
  2381. in
  2382. mk (TBlock l) (loop l) p
  2383. | EParenthesis e ->
  2384. let e = type_expr ctx e with_type in
  2385. mk (TParenthesis e) e.etype p
  2386. | EObjectDecl fl ->
  2387. let a = (match with_type with
  2388. | WithType t | WithTypeResume t ->
  2389. (match follow t with
  2390. | TAnon a when not (PMap.is_empty a.a_fields) -> Some a
  2391. | _ -> None)
  2392. | _ -> None
  2393. ) in
  2394. (match a with
  2395. | None ->
  2396. let rec loop (l,acc) (f,e) =
  2397. let f,add = object_field f in
  2398. if PMap.mem f acc then error ("Duplicate field in object declaration : " ^ f) p;
  2399. let e = type_expr ctx e Value in
  2400. (match follow e.etype with TAbstract({a_path=[],"Void"},_) -> error "Fields of type Void are not allowed in structures" e.epos | _ -> ());
  2401. let cf = mk_field f e.etype e.epos in
  2402. ((f,e) :: l, if add then PMap.add f cf acc else acc)
  2403. in
  2404. let fields , types = List.fold_left loop ([],PMap.empty) fl in
  2405. let x = ref Const in
  2406. ctx.opened <- x :: ctx.opened;
  2407. mk (TObjectDecl (List.rev fields)) (TAnon { a_fields = types; a_status = x }) p
  2408. | Some a ->
  2409. let fields = ref PMap.empty in
  2410. let extra_fields = ref [] in
  2411. let fl = List.map (fun (n, e) ->
  2412. let n,add = object_field n in
  2413. if PMap.mem n !fields then error ("Duplicate field in object declaration : " ^ n) p;
  2414. let e = try
  2415. let t = (PMap.find n a.a_fields).cf_type in
  2416. let e = type_expr ctx e (match with_type with WithTypeResume _ -> WithTypeResume t | _ -> WithType t) in
  2417. unify ctx e.etype t e.epos;
  2418. (try type_eq EqStrict e.etype t; e with Unify_error _ -> mk (TCast (e,None)) t e.epos)
  2419. with Not_found ->
  2420. extra_fields := n :: !extra_fields;
  2421. type_expr ctx e Value
  2422. in
  2423. if add then begin
  2424. let cf = mk_field n e.etype e.epos in
  2425. fields := PMap.add n cf !fields;
  2426. end;
  2427. (n,e)
  2428. ) fl in
  2429. let t = (TAnon { a_fields = !fields; a_status = ref Const }) in
  2430. if not ctx.untyped then begin
  2431. let unify_error l p =
  2432. match with_type with
  2433. | WithTypeResume _ -> raise (WithTypeError (l,p))
  2434. | _ -> raise (Error (Unify l,p))
  2435. in
  2436. PMap.iter (fun n cf ->
  2437. if not (Meta.has Meta.Optional cf.cf_meta) && not (PMap.mem n !fields) then unify_error [has_no_field t n] p;
  2438. ) a.a_fields;
  2439. (match !extra_fields with
  2440. | [] -> ()
  2441. | _ -> unify_error (List.map (fun n -> has_extra_field t n) !extra_fields) p);
  2442. end;
  2443. a.a_status := Closed;
  2444. mk (TObjectDecl fl) t p)
  2445. | EArrayDecl [(EFor _,_) | (EWhile _,_) as e] ->
  2446. let v = gen_local ctx (mk_mono()) in
  2447. let et = ref (EConst(Ident "null"),p) in
  2448. let rec map_compr (e,p) =
  2449. match e with
  2450. | EFor(it,e2) -> (EFor (it, map_compr e2),p)
  2451. | EWhile(cond,e2,flag) -> (EWhile (cond,map_compr e2,flag),p)
  2452. | EIf (cond,e2,None) -> (EIf (cond,map_compr e2,None),p)
  2453. | EBlock [e] -> (EBlock [map_compr e],p)
  2454. | EParenthesis e2 -> (EParenthesis (map_compr e2),p)
  2455. | EBinop(OpArrow,a,b) ->
  2456. et := (ENew({tpackage=[];tname="Map";tparams=[];tsub=None},[]),p);
  2457. (ECall ((EField ((EConst (Ident v.v_name),p),"set"),p),[a;b]),p)
  2458. | _ ->
  2459. et := (EArrayDecl [],p);
  2460. (ECall ((EField ((EConst (Ident v.v_name),p),"push"),p),[(e,p)]),p)
  2461. in
  2462. let e = map_compr e in
  2463. let ea = type_expr ctx !et with_type in
  2464. unify ctx v.v_type ea.etype p;
  2465. let efor = type_expr ctx e NoValue in
  2466. mk (TBlock [
  2467. mk (TVars [v,Some ea]) ctx.t.tvoid p;
  2468. efor;
  2469. mk (TLocal v) v.v_type p;
  2470. ]) v.v_type p
  2471. | EArrayDecl ((EBinop(OpArrow,_,_),_) as e1 :: el) ->
  2472. let keys = Hashtbl.create 0 in
  2473. let tkey,tval,resume = match with_type with
  2474. | WithType (TAbstract({a_path=[],"Map"},[tk;tv])) -> tk,tv,false
  2475. | WithTypeResume (TAbstract({a_path=[],"Map"},[tk;tv])) -> tk,tv,true
  2476. | _ -> mk_mono(),mk_mono(),false
  2477. in
  2478. let unify_with_resume ctx a b p =
  2479. if resume then try unify_raise ctx a b p with Error (Unify l,p) -> raise (WithTypeError(l,p))
  2480. else unify ctx a b p
  2481. in
  2482. let type_arrow e1 e2 =
  2483. let e1 = type_expr ctx e1 (WithType tkey) in
  2484. try
  2485. let p = Hashtbl.find keys e1.eexpr in
  2486. display_error ctx "Duplicate key" e1.epos;
  2487. error "Previously defined here" p
  2488. with Not_found ->
  2489. Hashtbl.add keys e1.eexpr e1.epos;
  2490. unify_with_resume ctx e1.etype tkey e1.epos;
  2491. let e2 = type_expr ctx e2 (WithType tval) in
  2492. unify_with_resume ctx e2.etype tval e2.epos;
  2493. e1,e2
  2494. in
  2495. let m = Typeload.load_module ctx ([],"Map") null_pos in
  2496. let a,c = match m.m_types with
  2497. | (TAbstractDecl ({a_impl = Some c} as a)) :: _ -> a,c
  2498. | _ -> assert false
  2499. in
  2500. let tmap = TAbstract(a,[tkey;tval]) in
  2501. let cf = PMap.find "set" c.cl_statics in
  2502. let el = e1 :: el in
  2503. let v = gen_local ctx tmap in
  2504. let ev = mk (TLocal v) tmap p in
  2505. let ef = mk (TField(ev,FInstance(c,cf))) (tfun [tkey;tval] ctx.t.tvoid) p in
  2506. let el = ev :: List.fold_left (fun acc e -> match fst e with
  2507. | EBinop(OpArrow,e1,e2) ->
  2508. let e1,e2 = type_arrow e1 e2 in
  2509. (make_call ctx ef [e1;e2] ctx.com.basic.tvoid p) :: acc
  2510. | _ ->
  2511. error "Expected a => b" (snd e)
  2512. ) [] el in
  2513. let enew = mk (TNew(c,[tkey;tval],[])) tmap p in
  2514. let el = (mk (TVars [v,Some enew]) t_dynamic p) :: (List.rev el) in
  2515. mk (TBlock el) tmap p
  2516. | EArrayDecl el ->
  2517. let tp = (match with_type with
  2518. | WithType t | WithTypeResume t ->
  2519. (match follow t with
  2520. | TInst ({ cl_path = [],"Array" },[tp]) ->
  2521. (match follow tp with
  2522. | TMono _ -> None
  2523. | _ -> Some tp)
  2524. | TAnon _ ->
  2525. (try
  2526. Some (get_iterable_param t)
  2527. with Not_found ->
  2528. None)
  2529. | _ ->
  2530. if t == t_dynamic then Some t else None)
  2531. | _ ->
  2532. None
  2533. ) in
  2534. (match tp with
  2535. | None ->
  2536. let el = List.map (fun e -> type_expr ctx e Value) el in
  2537. let t = try
  2538. unify_min_raise ctx el
  2539. with Error (Unify l,p) ->
  2540. if ctx.untyped then t_dynamic else begin
  2541. display_error ctx "Arrays of mixed types are only allowed if the type is forced to Array<Dynamic>" p;
  2542. raise (Error (Unify l, p))
  2543. end
  2544. in
  2545. mk (TArrayDecl el) (ctx.t.tarray t) p
  2546. | Some t ->
  2547. let el = List.map (fun e ->
  2548. let e = type_expr ctx e (match with_type with WithTypeResume _ -> WithTypeResume t | _ -> WithType t) in
  2549. (match with_type with
  2550. | WithTypeResume _ -> (try unify_raise ctx e.etype t e.epos with Error (Unify l,p) -> raise (WithTypeError (l,p)))
  2551. | _ -> unify ctx e.etype t e.epos);
  2552. e
  2553. ) el in
  2554. mk (TArrayDecl el) (ctx.t.tarray t) p)
  2555. | EVars vl ->
  2556. type_vars ctx vl p false
  2557. | EFor (it,e2) ->
  2558. let i, e1 = (match it with
  2559. | (EIn ((EConst (Ident i),_),e),_) -> i, e
  2560. | _ -> error "For expression should be 'v in expr'" (snd it)
  2561. ) in
  2562. let e1 = type_expr ctx e1 Value in
  2563. let old_loop = ctx.in_loop in
  2564. let old_locals = save_locals ctx in
  2565. ctx.in_loop <- true;
  2566. let e = (match Optimizer.optimize_for_loop ctx i e1 e2 p with
  2567. | Some e -> e
  2568. | None ->
  2569. let t, pt = Typeload.t_iterator ctx in
  2570. let i = add_local ctx i pt in
  2571. let e1 = (match follow e1.etype with
  2572. | TMono _
  2573. | TDynamic _ ->
  2574. display_error ctx "You can't iterate on a Dynamic value, please specify Iterator or Iterable" e1.epos;
  2575. e1
  2576. | TLazy _ ->
  2577. assert false
  2578. | _ ->
  2579. (try
  2580. unify_raise ctx e1.etype t e1.epos;
  2581. e1
  2582. with Error (Unify _,_) ->
  2583. let acc = acc_get ctx (type_field ctx e1 "iterator" e1.epos MCall) e1.epos in
  2584. let acc = (match acc.eexpr with TField (e,FClosure (c,f)) -> { acc with eexpr = TField (e,match c with None -> FAnon f | Some c -> FInstance (c,f)) } | _ -> acc) in
  2585. try
  2586. unify_raise ctx acc.etype (tfun [] t) acc.epos;
  2587. make_call ctx acc [] t e1.epos
  2588. with Error (Unify(l),p) ->
  2589. display_error ctx "Field iterator has an invalid type" acc.epos;
  2590. display_error ctx (error_msg (Unify l)) p;
  2591. mk (TConst TNull) t_dynamic p
  2592. )
  2593. ) in
  2594. let e2 = type_expr ctx e2 NoValue in
  2595. (* can we inline hasNext() ? *)
  2596. (try
  2597. let c,pl = (match follow e1.etype with TInst (c,pl) -> c,pl | _ -> raise Exit) in
  2598. let _, ft, fhasnext = (try class_field ctx c pl "hasNext" p with Not_found -> raise Exit) in
  2599. if fhasnext.cf_kind <> Method MethInline then raise Exit;
  2600. let tmp = gen_local ctx e1.etype in
  2601. let eit = mk (TLocal tmp) e1.etype p in
  2602. let ehasnext = make_call ctx (mk (TField (eit,FInstance (c, fhasnext))) (TFun([],ctx.t.tbool)) p) [] ctx.t.tbool p in
  2603. let enext = mk (TVars [i,Some (make_call ctx (mk (TField (eit,FDynamic "next")) (TFun ([],pt)) p) [] pt p)]) ctx.t.tvoid p in
  2604. let eblock = (match e2.eexpr with
  2605. | TBlock el -> { e2 with eexpr = TBlock (enext :: el) }
  2606. | _ -> mk (TBlock [enext;e2]) ctx.t.tvoid p
  2607. ) in
  2608. mk (TBlock [
  2609. mk (TVars [tmp,Some e1]) ctx.t.tvoid p;
  2610. mk (TWhile (ehasnext,eblock,NormalWhile)) ctx.t.tvoid p
  2611. ]) ctx.t.tvoid p
  2612. with Exit ->
  2613. mk (TFor (i,e1,e2)) ctx.t.tvoid p)
  2614. ) in
  2615. ctx.in_loop <- old_loop;
  2616. old_locals();
  2617. e
  2618. | EIn _ ->
  2619. error "This expression is not allowed outside a for loop" p
  2620. | ETernary (e1,e2,e3) ->
  2621. type_expr ctx (EIf (e1,e2,Some e3),p) with_type
  2622. | EIf (e,e1,e2) ->
  2623. let e = type_expr ctx e Value in
  2624. unify ctx e.etype ctx.t.tbool e.epos;
  2625. let e1 = type_expr ctx e1 with_type in
  2626. (match e2 with
  2627. | None ->
  2628. mk (TIf (e,e1,None)) ctx.t.tvoid p
  2629. | Some e2 ->
  2630. let e2 = type_expr ctx e2 with_type in
  2631. let e1,e2,t = match with_type with
  2632. | NoValue -> e1,e2,ctx.t.tvoid
  2633. | Value -> e1,e2,unify_min ctx [e1; e2]
  2634. | WithType t | WithTypeResume t when (match follow t with TMono _ -> true | _ -> false) -> e1,e2,unify_min ctx [e1; e2]
  2635. | WithType t | WithTypeResume t ->
  2636. begin try
  2637. unify_raise ctx e1.etype t e1.epos;
  2638. unify_raise ctx e2.etype t e2.epos;
  2639. with Error (Unify l,p) -> match with_type with
  2640. | WithTypeResume _ -> raise (WithTypeError (l,p))
  2641. | _ -> display_error ctx (error_msg (Unify l)) p
  2642. end;
  2643. let e1 = Codegen.Abstract.check_cast ctx t e1 e1.epos in
  2644. let e2 = Codegen.Abstract.check_cast ctx t e2 e2.epos in
  2645. e1,e2,t
  2646. in
  2647. mk (TIf (e,e1,Some e2)) t p)
  2648. | EWhile (cond,e,NormalWhile) ->
  2649. let old_loop = ctx.in_loop in
  2650. let cond = type_expr ctx cond Value in
  2651. unify ctx cond.etype ctx.t.tbool cond.epos;
  2652. ctx.in_loop <- true;
  2653. let e = type_expr ctx e NoValue in
  2654. ctx.in_loop <- old_loop;
  2655. mk (TWhile (cond,e,NormalWhile)) ctx.t.tvoid p
  2656. | EWhile (cond,e,DoWhile) ->
  2657. let old_loop = ctx.in_loop in
  2658. ctx.in_loop <- true;
  2659. let e = type_expr ctx e NoValue in
  2660. ctx.in_loop <- old_loop;
  2661. let cond = type_expr ctx cond Value in
  2662. unify ctx cond.etype ctx.t.tbool cond.epos;
  2663. mk (TWhile (cond,e,DoWhile)) ctx.t.tvoid p
  2664. | ESwitch (e,cases,def) ->
  2665. type_switch ctx e cases def with_type p
  2666. | EReturn e ->
  2667. let e , t = (match e with
  2668. | None ->
  2669. let v = ctx.t.tvoid in
  2670. unify ctx v ctx.ret p;
  2671. None , v
  2672. | Some e ->
  2673. let e = type_expr ctx e (WithType ctx.ret) in
  2674. unify ctx e.etype ctx.ret e.epos;
  2675. let e = Codegen.Abstract.check_cast ctx ctx.ret e p in
  2676. Some e , e.etype
  2677. ) in
  2678. mk (TReturn e) t_dynamic p
  2679. | EBreak ->
  2680. if not ctx.in_loop then display_error ctx "Break outside loop" p;
  2681. mk TBreak t_dynamic p
  2682. | EContinue ->
  2683. if not ctx.in_loop then display_error ctx "Continue outside loop" p;
  2684. mk TContinue t_dynamic p
  2685. | ETry (e1,catches) ->
  2686. let e1 = type_expr ctx e1 with_type in
  2687. let catches = List.map (fun (v,t,e) ->
  2688. let t = Typeload.load_complex_type ctx (pos e) t in
  2689. let name = (match follow t with
  2690. | TInst ({ cl_path = path },params) | TEnum ({ e_path = path },params) ->
  2691. List.iter (fun pt ->
  2692. if pt != t_dynamic then error "Catch class parameter must be Dynamic" p;
  2693. ) params;
  2694. add_feature ctx.com "typed_catch";
  2695. (match path with
  2696. | x :: _ , _ -> x
  2697. | [] , name -> name)
  2698. | TDynamic _ -> ""
  2699. | _ -> error "Catch type must be a class" p
  2700. ) in
  2701. let locals = save_locals ctx in
  2702. let v = add_local ctx v t in
  2703. let e = type_expr ctx e with_type in
  2704. locals();
  2705. if with_type <> NoValue then unify ctx e.etype e1.etype e.epos;
  2706. if PMap.mem name ctx.locals then error ("Local variable " ^ name ^ " is preventing usage of this type here") e.epos;
  2707. v , e
  2708. ) catches in
  2709. mk (TTry (e1,catches)) (if with_type = NoValue then ctx.t.tvoid else e1.etype) p
  2710. | EThrow e ->
  2711. let e = type_expr ctx e Value in
  2712. mk (TThrow e) (mk_mono()) p
  2713. | ECall (((EConst (Ident s),_) as e),el) ->
  2714. (try
  2715. let t, e, pl = (match with_type with
  2716. | WithType t | WithTypeResume t ->
  2717. (match follow t with
  2718. | TEnum (e,pl) -> t, e, pl
  2719. | _ -> raise Exit)
  2720. | _ -> raise Exit
  2721. ) in
  2722. try
  2723. ignore(type_ident_raise ~imported_enums:false ctx s p MCall);
  2724. raise Exit
  2725. with Not_found -> try
  2726. let ef = PMap.find s e.e_constrs in
  2727. let et = apply_params e.e_types pl (monomorphs ef.ef_params ef.ef_type) in
  2728. let constr = mk (fast_enum_field e ef p) et p in
  2729. build_call ctx (AKExpr constr) el (match with_type with WithTypeResume _ -> WithTypeResume t | _ -> WithType t) p
  2730. with Not_found ->
  2731. if ctx.untyped then raise Exit; (* __js__, etc. *)
  2732. with_type_error ctx with_type (string_error s e.e_names ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path e.e_path)) p;
  2733. mk (TConst TNull) t p
  2734. with Exit ->
  2735. type_call ctx e el with_type p)
  2736. | ECall (e,el) ->
  2737. type_call ctx e el with_type p
  2738. | ENew (t,el) ->
  2739. let t = Typeload.load_instance ctx t p true in
  2740. let ct = (match follow t with
  2741. | TAbstract (a,pl) ->
  2742. (match a.a_impl with
  2743. | None -> t
  2744. | Some c -> TInst (c,pl))
  2745. | _ -> t
  2746. ) in
  2747. (match follow ct with
  2748. | TInst ({cl_kind = KTypeParameter tl} as c,params) ->
  2749. if not (Codegen.is_generic_parameter ctx c) then error "Only generic type parameters can be constructed" p;
  2750. let el = List.map (fun e -> type_expr ctx e Value) el in
  2751. let ct = (tfun (List.map (fun e -> e.etype) el) ctx.t.tvoid) in
  2752. if not (List.exists (fun t -> match follow t with
  2753. | TAnon a ->
  2754. (try
  2755. unify ctx (PMap.find "new" a.a_fields).cf_type ct p;
  2756. true
  2757. with Not_found ->
  2758. false)
  2759. | _ -> false
  2760. ) tl) then error (s_type_path c.cl_path ^ " does not have a constructor") p;
  2761. mk (TNew (c,params,el)) t p
  2762. | TInst (c,params) ->
  2763. let ct, f = get_constructor ctx c params p in
  2764. if not (can_access ctx c f true || is_parent c ctx.curclass) && not ctx.untyped then display_error ctx "Cannot access private constructor" p;
  2765. (match f.cf_kind with
  2766. | Var { v_read = AccRequire (r,msg) } -> (match msg with Some msg -> error msg p | None -> error_require r p)
  2767. | _ -> ());
  2768. let el = (match follow ct with
  2769. | TFun (args,r) ->
  2770. (try
  2771. fst (unify_call_params ctx (Some (TInst(c,params),f)) el args r p false)
  2772. with Error (e,p) ->
  2773. display_error ctx (error_msg e) p;
  2774. [])
  2775. | _ ->
  2776. error "Constructor is not a function" p
  2777. ) in
  2778. (match c.cl_kind with
  2779. | KAbstractImpl a when not (Meta.has Meta.MultiType a.a_meta) ->
  2780. let ta = TAnon { a_fields = c.cl_statics; a_status = ref (Statics c) } in
  2781. let e = mk (TTypeExpr (TClassDecl c)) ta p in
  2782. let e = mk (TField (e,(FStatic (c,f)))) ct p in
  2783. make_call ctx e el t p
  2784. | _ ->
  2785. mk (TNew (c,params,el)) t p)
  2786. | _ ->
  2787. error (s_type (print_context()) t ^ " cannot be constructed") p)
  2788. | EUnop (op,flag,e) ->
  2789. type_unop ctx op flag e p
  2790. | EFunction (name,f) ->
  2791. let params = Typeload.type_function_params ctx f (match name with None -> "localfun" | Some n -> n) p in
  2792. if params <> [] then begin
  2793. if name = None then display_error ctx "Type parameters not supported in unnamed local functions" p;
  2794. if with_type <> NoValue then error "Type parameters are not supported for rvalue functions" p
  2795. end else
  2796. List.iter (fun tp -> if tp.tp_constraints <> [] then display_error ctx "Type parameters constraints are not supported for local functions" p) f.f_params;
  2797. let old = ctx.type_params in
  2798. ctx.type_params <- params @ ctx.type_params;
  2799. let rt = Typeload.load_type_opt ctx p f.f_type in
  2800. let args = List.map (fun (s,opt,t,c) ->
  2801. let t = Typeload.load_type_opt ctx p t in
  2802. let t, c = Typeload.type_function_param ctx t c opt p in
  2803. s , c, t
  2804. ) f.f_args in
  2805. (match with_type with
  2806. | WithType t | WithTypeResume t ->
  2807. let rec loop t =
  2808. (match follow t with
  2809. | TFun (args2,_) when List.length args2 = List.length args ->
  2810. List.iter2 (fun (_,_,t1) (_,_,t2) ->
  2811. match follow t1 with
  2812. | TMono _ -> unify ctx t2 t1 p
  2813. | _ -> ()
  2814. ) args args2;
  2815. | TAbstract({a_this = ta} as a,tl) ->
  2816. loop (apply_params a.a_types tl ta)
  2817. | _ -> ())
  2818. in
  2819. loop t
  2820. | _ ->
  2821. ());
  2822. let ft = TFun (fun_args args,rt) in
  2823. let inline, v = (match name with
  2824. | None -> false, None
  2825. | Some v when ExtString.String.starts_with v "inline_" -> true, Some (String.sub v 7 (String.length v - 7))
  2826. | Some v -> false, Some v
  2827. ) in
  2828. let v = (match v with
  2829. | None -> None
  2830. | Some v ->
  2831. if v.[0] = '$' then display_error ctx "Variables names starting with a dollar are not allowed" p;
  2832. Some (add_local ctx v ft)
  2833. ) in
  2834. let e , fargs = Typeload.type_function ctx args rt (match ctx.curfun with FunStatic -> FunStatic | _ -> FunMemberLocal) f false p in
  2835. ctx.type_params <- old;
  2836. let f = {
  2837. tf_args = fargs;
  2838. tf_type = rt;
  2839. tf_expr = e;
  2840. } in
  2841. let e = mk (TFunction f) ft p in
  2842. (match v with
  2843. | None -> e
  2844. | Some v ->
  2845. if params <> [] || inline then v.v_extra <- Some (params,if inline then Some e else None);
  2846. let rec loop = function
  2847. | Codegen.Block f | Codegen.Loop f | Codegen.Function f -> f loop
  2848. | Codegen.Use v2 when v == v2 -> raise Exit
  2849. | Codegen.Use _ | Codegen.Declare _ -> ()
  2850. in
  2851. let is_rec = (try Codegen.local_usage loop e; false with Exit -> true) in
  2852. let decl = (if is_rec then begin
  2853. if inline then display_error ctx "Inline function cannot be recursive" e.epos;
  2854. let vnew = add_local ctx v.v_name ft in
  2855. mk (TVars [vnew,Some (mk (TBlock [
  2856. mk (TVars [v,Some (mk (TConst TNull) ft p)]) ctx.t.tvoid p;
  2857. mk (TBinop (OpAssign,mk (TLocal v) ft p,e)) ft p;
  2858. mk (TLocal v) ft p
  2859. ]) ft p)]) ctx.t.tvoid p
  2860. end else if inline then
  2861. mk (TBlock []) ctx.t.tvoid p (* do not add variable since it will be inlined *)
  2862. else
  2863. mk (TVars [v,Some e]) ctx.t.tvoid p
  2864. ) in
  2865. if with_type <> NoValue && not inline then mk (TBlock [decl;mk (TLocal v) v.v_type p]) v.v_type p else decl)
  2866. | EUntyped e ->
  2867. let old = ctx.untyped in
  2868. ctx.untyped <- true;
  2869. let e = type_expr ctx e with_type in
  2870. ctx.untyped <- old;
  2871. {
  2872. eexpr = e.eexpr;
  2873. etype = mk_mono();
  2874. epos = e.epos;
  2875. }
  2876. | ECast (e,None) ->
  2877. let e = type_expr ctx e Value in
  2878. mk (TCast (e,None)) (mk_mono()) p
  2879. | ECast (e, Some t) ->
  2880. add_feature ctx.com "typed_cast";
  2881. let t = Typeload.load_complex_type ctx (pos e) t in
  2882. let texpr = (match follow t with
  2883. | TInst (_,params) | TEnum (_,params) ->
  2884. List.iter (fun pt ->
  2885. if follow pt != t_dynamic then error "Cast type parameters must be Dynamic" p;
  2886. ) params;
  2887. (match follow t with
  2888. | TInst (c,_) ->
  2889. (match c.cl_kind with KTypeParameter _ -> error "Can't cast to a type parameter" p | _ -> ());
  2890. TClassDecl c
  2891. | TEnum (e,_) -> TEnumDecl e
  2892. | _ -> assert false);
  2893. | TAbstract (a,params) when Meta.has Meta.RuntimeValue a.a_meta ->
  2894. List.iter (fun pt ->
  2895. if follow pt != t_dynamic then error "Cast type parameters must be Dynamic" p;
  2896. ) params;
  2897. TAbstractDecl a
  2898. | _ ->
  2899. error "Cast type must be a class or an enum" p
  2900. ) in
  2901. mk (TCast (type_expr ctx e Value,Some texpr)) t p
  2902. | EDisplay (e,iscall) when Common.defined_value_safe ctx.com Define.DisplayMode = "usage" ->
  2903. let e = try type_expr ctx e Value with Error (Unknown_ident n,_) -> raise (Parser.TypePath ([n],None)) in
  2904. (match e.eexpr with
  2905. | TField(_,fa) -> (match extract_field fa with
  2906. | None -> e
  2907. | Some cf ->
  2908. cf.cf_meta <- (Meta.Usage,[],p) :: cf.cf_meta;
  2909. e)
  2910. | _ -> e)
  2911. | EDisplay (e,iscall) ->
  2912. let old = ctx.in_display in
  2913. let opt_args args ret = TFun(List.map(fun (n,o,t) -> n,true,t) args,ret) in
  2914. ctx.in_display <- true;
  2915. let e = (try type_expr ctx e Value with Error (Unknown_ident n,_) -> raise (Parser.TypePath ([n],None))) in
  2916. let e = match e.eexpr with
  2917. | TField (e1,fa) ->
  2918. let mode = Common.defined_value_safe ctx.com Define.DisplayMode in
  2919. if field_name fa = "bind" then (match follow e1.etype with
  2920. | TFun(args,ret) -> {e1 with etype = opt_args args ret}
  2921. | _ -> e)
  2922. else if mode = "position" then (match extract_field fa with
  2923. | None -> e
  2924. | Some cf -> raise (Typecore.DisplayPosition [cf.cf_pos]))
  2925. else if mode = "metadata" then (match fa with
  2926. | FStatic (c,cf) | FInstance (c,cf) | FClosure(Some c,cf) -> raise (DisplayMetadata (c.cl_meta @ cf.cf_meta))
  2927. | _ -> e)
  2928. else
  2929. e
  2930. | TTypeExpr mt when Common.defined_value_safe ctx.com Define.DisplayMode = "position" ->
  2931. raise (DisplayPosition [match mt with
  2932. | TClassDecl c -> c.cl_pos
  2933. | TEnumDecl en -> en.e_pos
  2934. | TTypeDecl t -> t.t_pos
  2935. | TAbstractDecl a -> a.a_pos])
  2936. | TTypeExpr mt when Common.defined_value_safe ctx.com Define.DisplayMode = "metadata" ->
  2937. raise (DisplayMetadata (match mt with
  2938. | TClassDecl c -> c.cl_meta
  2939. | TEnumDecl en -> en.e_meta
  2940. | TTypeDecl t -> t.t_meta
  2941. | TAbstractDecl a -> a.a_meta))
  2942. | _ ->
  2943. e
  2944. in
  2945. ctx.in_display <- old;
  2946. let opt_type t =
  2947. match t with
  2948. | TLazy f ->
  2949. Typeload.return_partial_type := true;
  2950. let t = (!f)() in
  2951. Typeload.return_partial_type := false;
  2952. t
  2953. | _ ->
  2954. t
  2955. in
  2956. let rec get_fields t =
  2957. match follow t with
  2958. | TInst (c,params) ->
  2959. let priv = is_parent c ctx.curclass in
  2960. let merge ?(cond=(fun _ -> true)) a b =
  2961. PMap.foldi (fun k f m -> if cond f then PMap.add k f m else m) a b
  2962. in
  2963. let rec loop c params =
  2964. let m = List.fold_left (fun m (i,params) ->
  2965. merge m (loop i params)
  2966. ) PMap.empty c.cl_implements in
  2967. let m = (match c.cl_super with
  2968. | None -> m
  2969. | Some (csup,cparams) -> merge m (loop csup cparams)
  2970. ) in
  2971. let m = merge ~cond:(fun f -> priv || can_access ctx c f false) c.cl_fields m in
  2972. let m = (match c.cl_kind with
  2973. | KTypeParameter pl -> List.fold_left (fun acc t -> merge acc (get_fields t)) m pl
  2974. | _ -> m
  2975. ) in
  2976. PMap.map (fun f -> { f with cf_type = apply_params c.cl_types params (opt_type f.cf_type); cf_public = true; }) m
  2977. in
  2978. loop c params
  2979. | TAbstract({a_impl = Some c} as a,pl) ->
  2980. ctx.m.module_using <- c :: ctx.m.module_using;
  2981. PMap.fold (fun f acc ->
  2982. if f.cf_name <> "_new" && can_access ctx c f true && Meta.has Meta.Impl f.cf_meta then begin
  2983. let f = prepare_using_field f in
  2984. let t = apply_params a.a_types pl (follow f.cf_type) in
  2985. PMap.add f.cf_name { f with cf_public = true; cf_type = opt_type t } acc
  2986. end else
  2987. acc
  2988. ) c.cl_statics PMap.empty
  2989. | TAnon a ->
  2990. (match !(a.a_status) with
  2991. | Statics c ->
  2992. PMap.fold (fun f acc -> if can_access ctx c f true then PMap.add f.cf_name { f with cf_public = true; cf_type = opt_type f.cf_type } acc else acc) a.a_fields PMap.empty
  2993. | _ ->
  2994. a.a_fields)
  2995. | TFun (args,ret) ->
  2996. let t = opt_args args ret in
  2997. let cf = mk_field "bind" (tfun [t] t) p in
  2998. PMap.add "bind" cf PMap.empty
  2999. | _ ->
  3000. PMap.empty
  3001. in
  3002. let fields = get_fields e.etype in
  3003. (*
  3004. add 'using' methods compatible with this type
  3005. *)
  3006. let rec loop acc = function
  3007. | [] -> acc
  3008. | c :: l ->
  3009. let acc = ref (loop acc l) in
  3010. let rec dup t = Type.map dup t in
  3011. List.iter (fun f ->
  3012. if not (Meta.has Meta.NoUsing f.cf_meta) then
  3013. let f = { f with cf_type = opt_type f.cf_type } in
  3014. let monos = List.map (fun _ -> mk_mono()) f.cf_params in
  3015. let map = apply_params f.cf_params monos in
  3016. match follow (map f.cf_type) with
  3017. | TFun((_,_,TType({t_path=["haxe";"macro"], "ExprOf"}, [t])) :: args, ret)
  3018. | TFun((_,_,t) :: args, ret) ->
  3019. (try
  3020. unify_raise ctx (dup e.etype) t e.epos;
  3021. List.iter2 (fun m (name,t) -> match follow t with
  3022. | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
  3023. List.iter (fun tc -> unify_raise ctx (dup e.etype) (map tc) e.epos) constr
  3024. | _ -> ()
  3025. ) monos f.cf_params;
  3026. if not (can_access ctx c f true) || follow e.etype == t_dynamic && follow t != t_dynamic then
  3027. ()
  3028. else begin
  3029. let f = prepare_using_field f in
  3030. let f = { f with cf_params = []; cf_public = true; cf_type = TFun(args,ret) } in
  3031. acc := PMap.add f.cf_name f (!acc)
  3032. end
  3033. with Error (Unify _,_) -> ())
  3034. | _ -> ()
  3035. ) c.cl_ordered_statics;
  3036. !acc
  3037. in
  3038. let use_methods = match follow e.etype with TMono _ -> PMap.empty | _ -> loop (loop PMap.empty ctx.g.global_using) ctx.m.module_using in
  3039. let fields = PMap.fold (fun f acc -> PMap.add f.cf_name f acc) fields use_methods in
  3040. let fields = PMap.fold (fun f acc -> if Meta.has Meta.NoCompletion f.cf_meta then acc else f :: acc) fields [] in
  3041. let t = (if iscall then
  3042. match follow e.etype with
  3043. | TFun _ -> e.etype
  3044. | _ -> t_dynamic
  3045. else match fields with
  3046. | [] -> e.etype
  3047. | _ ->
  3048. let get_field acc f =
  3049. List.fold_left (fun acc f -> if f.cf_public then (f.cf_name,f.cf_type,f.cf_doc) :: acc else acc) acc (f :: f.cf_overloads)
  3050. in
  3051. raise (DisplayFields (List.fold_left get_field [] fields))
  3052. ) in
  3053. (match follow t with
  3054. | TMono _ | TDynamic _ when ctx.in_macro -> mk (TConst TNull) t p
  3055. | _ -> raise (DisplayTypes [t]))
  3056. | EDisplayNew t ->
  3057. let t = Typeload.load_instance ctx t p true in
  3058. (match follow t with
  3059. | TInst (c,params) | TAbstract({a_impl = Some c},params) ->
  3060. let ct, f = get_constructor ctx c params p in
  3061. raise (DisplayTypes (ct :: List.map (fun f -> f.cf_type) f.cf_overloads))
  3062. | _ ->
  3063. error "Not a class" p)
  3064. | ECheckType (e,t) ->
  3065. let t = Typeload.load_complex_type ctx p t in
  3066. let e = type_expr ctx e (WithType t) in
  3067. let e = Codegen.Abstract.check_cast ctx t e p in
  3068. unify ctx e.etype t e.epos;
  3069. if e.etype == t then e else mk (TCast (e,None)) t p
  3070. | EMeta (m,e) ->
  3071. let old = ctx.meta in
  3072. ctx.meta <- m :: ctx.meta;
  3073. let e = type_expr ctx e with_type in
  3074. let e = match m with
  3075. | (Meta.ToString,_,_) ->
  3076. (match follow e.etype with
  3077. | TAbstract({a_impl = Some c},_) when PMap.mem "toString" c.cl_statics -> call_to_string ctx c e
  3078. | _ -> e)
  3079. | _ -> e
  3080. in
  3081. ctx.meta <- old;
  3082. e
  3083. and type_call ctx e el (with_type:with_type) p =
  3084. let def () = (match e with
  3085. | EField ((EConst (Ident "super"),_),_) , _ -> ctx.in_super_call <- true
  3086. | _ -> ());
  3087. build_call ctx (type_access ctx (fst e) (snd e) MCall) el with_type p
  3088. in
  3089. match e, el with
  3090. | (EConst (Ident "trace"),p) , e :: el ->
  3091. if Common.defined ctx.com Define.NoTraces then
  3092. null ctx.t.tvoid p
  3093. else
  3094. let params = (match el with [] -> [] | _ -> ["customParams",(EArrayDecl el , p)]) in
  3095. let infos = mk_infos ctx p params in
  3096. if platform ctx.com Js && el = [] && has_dce ctx.com then
  3097. let e = type_expr ctx e Value in
  3098. let infos = type_expr ctx infos Value in
  3099. mk (TCall (mk (TLocal (alloc_var "`trace" t_dynamic)) t_dynamic p,[e;infos])) ctx.t.tvoid p
  3100. else
  3101. let me = Meta.ToString,[],pos e in
  3102. type_expr ctx (ECall ((EField ((EField ((EConst (Ident "haxe"),p),"Log"),p),"trace"),p),[(EMeta (me,e),pos e);EUntyped infos,p]),p) NoValue
  3103. | (EConst(Ident "callback"),p1),args ->
  3104. let ecb = try Some (type_ident_raise ctx "callback" p1 MCall) with Not_found -> None in
  3105. (match ecb with
  3106. | Some ecb ->
  3107. build_call ctx ecb args with_type p
  3108. | None ->
  3109. display_error ctx "callback syntax has changed to func.bind(args)" p;
  3110. let e = type_expr ctx e Value in
  3111. type_bind ctx e args p)
  3112. | (EField (e,"bind"),p), args ->
  3113. let e = type_expr ctx e Value in
  3114. (match follow e.etype with
  3115. | TFun _ -> type_bind ctx e args p
  3116. | _ -> def ())
  3117. | (EConst (Ident "$type"),_) , [e] ->
  3118. let e = type_expr ctx e Value in
  3119. ctx.com.warning (s_type (print_context()) e.etype) e.epos;
  3120. e
  3121. | (EConst (Ident "__unprotect__"),_) , [(EConst (String _),_) as e] ->
  3122. let e = type_expr ctx e Value in
  3123. if Common.platform ctx.com Flash then
  3124. let t = tfun [e.etype] e.etype in
  3125. mk (TCall (mk (TLocal (alloc_var "__unprotect__" t)) t p,[e])) e.etype e.epos
  3126. else
  3127. e
  3128. | (EConst (Ident "super"),sp) , el ->
  3129. if ctx.curfun <> FunConstructor then error "Cannot call super constructor outside class constructor" p;
  3130. let el, t = (match ctx.curclass.cl_super with
  3131. | None -> error "Current class does not have a super" p
  3132. | Some (c,params) ->
  3133. let ct, f = get_constructor ctx c params p in
  3134. let el, _ = (match follow ct with
  3135. | TFun (args,r) ->
  3136. unify_call_params ctx (Some (TInst(c,params),f)) el args r p false
  3137. | _ ->
  3138. error "Constructor is not a function" p
  3139. ) in
  3140. el , TInst (c,params)
  3141. ) in
  3142. mk (TCall (mk (TConst TSuper) t sp,el)) ctx.t.tvoid p
  3143. | _ ->
  3144. def ()
  3145. and build_call ctx acc el (with_type:with_type) p =
  3146. let fopts t f = match follow t with
  3147. | (TInst (c,pl) as t) -> Some (t,f)
  3148. | (TAnon a) as t -> (match !(a.a_status) with Statics c -> Some (TInst(c,[]),f) | _ -> Some (t,f))
  3149. | _ -> None
  3150. in
  3151. match acc with
  3152. | AKInline (ethis,f,fmode,t) ->
  3153. let params, tfunc = (match follow t with
  3154. | TFun (args,r) -> unify_call_params ctx (fopts ethis.etype f) el args r p true
  3155. | _ -> error (s_type (print_context()) t ^ " cannot be called") p
  3156. ) in
  3157. make_call ctx (mk (TField (ethis,fmode)) t p) params (match tfunc with TFun(_,r) -> r | _ -> assert false) p
  3158. | AKUsing (et,cl,ef,eparam) when Meta.has Meta.Generic ef.cf_meta ->
  3159. (match et.eexpr with
  3160. | TField(ec,_) ->
  3161. let el,t,e = type_generic_function ctx (ec,ef) el ~using_param:(Some eparam) p in
  3162. make_call ctx e el t p
  3163. | _ -> assert false)
  3164. | AKUsing (et,cl,ef,eparam) ->
  3165. let ef = prepare_using_field ef in
  3166. (match et.eexpr with
  3167. | TField (ec,_) ->
  3168. let acc = type_field ctx ec ef.cf_name p MCall in
  3169. (match acc with
  3170. | AKMacro _ ->
  3171. build_call ctx acc (Interp.make_ast eparam :: el) with_type p
  3172. | AKExpr _ | AKInline _ | AKUsing _ ->
  3173. let params, tfunc = (match follow et.etype with
  3174. | TFun ( _ :: args,r) -> unify_call_params ctx (Some (TInst(cl,[]),ef)) el args r p (ef.cf_kind = Method MethInline)
  3175. | _ -> assert false
  3176. ) in
  3177. let args,r = match tfunc with TFun(args,r) -> args,r | _ -> assert false in
  3178. let et = {et with etype = TFun(("",false,eparam.etype) :: args,r)} in
  3179. make_call ctx et (eparam::params) r p
  3180. | _ -> assert false)
  3181. | _ -> assert false)
  3182. | AKMacro (ethis,f) ->
  3183. if ctx.macro_depth > 300 then error "Stack overflow" p;
  3184. ctx.macro_depth <- ctx.macro_depth + 1;
  3185. let f = (match ethis.eexpr with
  3186. | TTypeExpr (TClassDecl c) ->
  3187. (match ctx.g.do_macro ctx MExpr c.cl_path f.cf_name el p with
  3188. | None -> (fun() -> type_expr ctx (EConst (Ident "null"),p) Value)
  3189. | Some (EVars vl,p) -> (fun() -> type_vars ctx vl p true)
  3190. | Some e -> (fun() -> type_expr ctx (EMeta((Meta.PrivateAccess,[],snd e),e),snd e) with_type))
  3191. | _ ->
  3192. (* member-macro call : since we will make a static call, let's found the actual class and not its subclass *)
  3193. (match follow ethis.etype with
  3194. | TInst (c,_) ->
  3195. let rec loop c =
  3196. if PMap.mem f.cf_name c.cl_fields then
  3197. match ctx.g.do_macro ctx MExpr c.cl_path f.cf_name (Interp.make_ast ethis :: el) p with
  3198. | None -> (fun() -> type_expr ctx (EConst (Ident "null"),p) Value)
  3199. | Some e -> (fun() -> type_expr ctx e Value)
  3200. else
  3201. match c.cl_super with
  3202. | None -> assert false
  3203. | Some (csup,_) -> loop csup
  3204. in
  3205. loop c
  3206. | _ -> assert false)) in
  3207. ctx.macro_depth <- ctx.macro_depth - 1;
  3208. let old = ctx.on_error in
  3209. ctx.on_error <- (fun ctx msg ep ->
  3210. old ctx msg ep;
  3211. (* display additional info in the case the error is not part of our original call *)
  3212. if ep.pfile <> p.pfile || ep.pmax < p.pmin || ep.pmin > p.pmax then old ctx "Called from macro here" p
  3213. );
  3214. let e = try f() with Error (m,p) -> display_error ctx (error_msg m) p; ctx.on_error <- old; raise Fatal_error in
  3215. ctx.on_error <- old;
  3216. e
  3217. | AKNo _ | AKSet _ | AKAccess _ ->
  3218. ignore(acc_get ctx acc p);
  3219. assert false
  3220. | AKExpr e ->
  3221. let el , t, e = (match follow e.etype with
  3222. | TFun (args,r) ->
  3223. let fopts = (match acc with
  3224. | AKExpr {eexpr = TField(e, (FStatic (_,f) | FInstance(_,f) | FAnon(f)))} ->
  3225. fopts e.etype f
  3226. | _ ->
  3227. None
  3228. ) in
  3229. (match fopts,acc with
  3230. | Some (_,cf),AKExpr({eexpr = TField(e,_)}) when Meta.has Meta.Generic cf.cf_meta ->
  3231. type_generic_function ctx (e,cf) el p
  3232. | _ ->
  3233. let el, tfunc = unify_call_params ctx fopts el args r p false in
  3234. el,(match tfunc with TFun(_,r) -> r | _ -> assert false), {e with etype = tfunc})
  3235. | TMono _ ->
  3236. let t = mk_mono() in
  3237. let el = List.map (fun e -> type_expr ctx e Value) el in
  3238. unify ctx (tfun (List.map (fun e -> e.etype) el) t) e.etype e.epos;
  3239. el, t, e
  3240. | t ->
  3241. let el = List.map (fun e -> type_expr ctx e Value) el in
  3242. el, (if t == t_dynamic then
  3243. t_dynamic
  3244. else if ctx.untyped then
  3245. mk_mono()
  3246. else
  3247. error (s_type (print_context()) e.etype ^ " cannot be called") e.epos), e
  3248. ) in
  3249. mk (TCall (e,el)) t p
  3250. and check_to_string ctx t =
  3251. match follow t with
  3252. | TInst (c,_) ->
  3253. (try
  3254. let _, _, f = Type.class_field c "toString" in
  3255. ignore(follow f.cf_type);
  3256. with Not_found ->
  3257. ())
  3258. | _ -> ()
  3259. (* ---------------------------------------------------------------------- *)
  3260. (* FINALIZATION *)
  3261. let get_main ctx =
  3262. match ctx.com.main_class with
  3263. | None -> None
  3264. | Some cl ->
  3265. let t = Typeload.load_type_def ctx null_pos { tpackage = fst cl; tname = snd cl; tparams = []; tsub = None } in
  3266. let fmode, ft, r = (match t with
  3267. | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ ->
  3268. error ("Invalid -main : " ^ s_type_path cl ^ " is not a class") null_pos
  3269. | TClassDecl c ->
  3270. try
  3271. let f = PMap.find "main" c.cl_statics in
  3272. let t = Type.field_type f in
  3273. (match follow t with
  3274. | TFun ([],r) -> FStatic (c,f), t, r
  3275. | _ -> error ("Invalid -main : " ^ s_type_path cl ^ " has invalid main function") c.cl_pos);
  3276. with
  3277. Not_found -> error ("Invalid -main : " ^ s_type_path cl ^ " does not have static function main") c.cl_pos
  3278. ) in
  3279. let emain = type_type ctx cl null_pos in
  3280. Some (mk (TCall (mk (TField (emain,fmode)) ft null_pos,[])) r null_pos)
  3281. let finalize ctx =
  3282. flush_pass ctx PFinal "final"
  3283. type state =
  3284. | Generating
  3285. | Done
  3286. | NotYet
  3287. let generate ctx =
  3288. let types = ref [] in
  3289. let states = Hashtbl.create 0 in
  3290. let state p = try Hashtbl.find states p with Not_found -> NotYet in
  3291. let statics = ref PMap.empty in
  3292. let rec loop t =
  3293. let p = t_path t in
  3294. match state p with
  3295. | Done -> ()
  3296. | Generating ->
  3297. ctx.com.warning ("Warning : maybe loop in static generation of " ^ s_type_path p) (t_infos t).mt_pos;
  3298. | NotYet ->
  3299. Hashtbl.add states p Generating;
  3300. let t = (match t with
  3301. | TClassDecl c ->
  3302. walk_class p c;
  3303. t
  3304. | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ ->
  3305. t
  3306. ) in
  3307. Hashtbl.replace states p Done;
  3308. types := t :: !types
  3309. and loop_class p c =
  3310. if c.cl_path <> p then loop (TClassDecl c)
  3311. and loop_enum p e =
  3312. if e.e_path <> p then loop (TEnumDecl e)
  3313. and loop_abstract p a =
  3314. if a.a_path <> p then loop (TAbstractDecl a)
  3315. and walk_static_call p c name =
  3316. try
  3317. let f = PMap.find name c.cl_statics in
  3318. match f.cf_expr with
  3319. | None -> ()
  3320. | Some e ->
  3321. if PMap.mem (c.cl_path,name) (!statics) then
  3322. ()
  3323. else begin
  3324. statics := PMap.add (c.cl_path,name) () (!statics);
  3325. walk_expr p e;
  3326. end
  3327. with
  3328. Not_found -> ()
  3329. and walk_expr p e =
  3330. match e.eexpr with
  3331. | TTypeExpr t ->
  3332. (match t with
  3333. | TClassDecl c -> loop_class p c
  3334. | TEnumDecl e -> loop_enum p e
  3335. | TAbstractDecl a -> loop_abstract p a
  3336. | TTypeDecl _ -> assert false)
  3337. | TNew (c,_,_) ->
  3338. iter (walk_expr p) e;
  3339. loop_class p c;
  3340. let rec loop c =
  3341. if PMap.mem (c.cl_path,"new") (!statics) then
  3342. ()
  3343. else begin
  3344. statics := PMap.add (c.cl_path,"new") () !statics;
  3345. (match c.cl_constructor with
  3346. | Some { cf_expr = Some e } -> walk_expr p e
  3347. | _ -> ());
  3348. match c.cl_super with
  3349. | None -> ()
  3350. | Some (csup,_) -> loop csup
  3351. end
  3352. in
  3353. loop c
  3354. | TMatch (_,(enum,_),_,_) ->
  3355. loop_enum p enum;
  3356. iter (walk_expr p) e
  3357. | TCall (f,_) ->
  3358. iter (walk_expr p) e;
  3359. (* static call for initializing a variable *)
  3360. let rec loop f =
  3361. match f.eexpr with
  3362. | TField ({ eexpr = TTypeExpr t },name) ->
  3363. (match t with
  3364. | TEnumDecl _ -> ()
  3365. | TAbstractDecl _ -> ()
  3366. | TTypeDecl _ -> assert false
  3367. | TClassDecl c -> walk_static_call p c (field_name name))
  3368. | _ -> ()
  3369. in
  3370. loop f
  3371. | _ ->
  3372. iter (walk_expr p) e
  3373. and walk_class p c =
  3374. (match c.cl_super with None -> () | Some (c,_) -> loop_class p c);
  3375. List.iter (fun (c,_) -> loop_class p c) c.cl_implements;
  3376. (match c.cl_init with
  3377. | None -> ()
  3378. | Some e -> walk_expr p e);
  3379. PMap.iter (fun _ f ->
  3380. match f.cf_expr with
  3381. | None -> ()
  3382. | Some e ->
  3383. match e.eexpr with
  3384. | TFunction _ -> ()
  3385. | _ -> walk_expr p e
  3386. ) c.cl_statics
  3387. in
  3388. let sorted_modules = List.sort (fun m1 m2 -> compare m1.m_path m2.m_path) (Hashtbl.fold (fun _ m acc -> m :: acc) ctx.g.modules []) in
  3389. List.iter (fun m -> List.iter loop m.m_types) sorted_modules;
  3390. get_main ctx, List.rev !types, sorted_modules
  3391. (* ---------------------------------------------------------------------- *)
  3392. (* MACROS *)
  3393. let macro_enable_cache = ref false
  3394. let macro_interp_cache = ref None
  3395. let delayed_macro_result = ref ((fun() -> assert false) : unit -> unit -> Interp.value)
  3396. let get_type_patch ctx t sub =
  3397. let new_patch() =
  3398. { tp_type = None; tp_remove = false; tp_meta = [] }
  3399. in
  3400. let path = Ast.parse_path t in
  3401. let h, tp = (try
  3402. Hashtbl.find ctx.g.type_patches path
  3403. with Not_found ->
  3404. let h = Hashtbl.create 0 in
  3405. let tp = new_patch() in
  3406. Hashtbl.add ctx.g.type_patches path (h,tp);
  3407. h, tp
  3408. ) in
  3409. match sub with
  3410. | None -> tp
  3411. | Some k ->
  3412. try
  3413. Hashtbl.find h k
  3414. with Not_found ->
  3415. let tp = new_patch() in
  3416. Hashtbl.add h k tp;
  3417. tp
  3418. let macro_timer ctx path =
  3419. Common.timer (if Common.defined ctx.com Define.MacroTimes then "macro " ^ path else "macro execution")
  3420. let typing_timer ctx f =
  3421. let t = Common.timer "typing" in
  3422. let old = ctx.com.error and oldp = ctx.pass in
  3423. (*
  3424. disable resumable errors... unless we are in display mode (we want to reach point of completion)
  3425. *)
  3426. if not ctx.com.display then ctx.com.error <- (fun e p -> raise (Error(Custom e,p)));
  3427. if ctx.pass < PTypeField then ctx.pass <- PTypeField;
  3428. let exit() =
  3429. t();
  3430. ctx.com.error <- old;
  3431. ctx.pass <- oldp;
  3432. in
  3433. try
  3434. let r = f() in
  3435. exit();
  3436. r
  3437. with Error (ekind,p) ->
  3438. exit();
  3439. Interp.compiler_error (Typecore.error_msg ekind) p
  3440. | WithTypeError (l,p) ->
  3441. exit();
  3442. Interp.compiler_error (Typecore.error_msg (Unify l)) p
  3443. | e ->
  3444. exit();
  3445. raise e
  3446. let make_macro_api ctx p =
  3447. let make_instance = function
  3448. | TClassDecl c -> TInst (c,List.map snd c.cl_types)
  3449. | TEnumDecl e -> TEnum (e,List.map snd e.e_types)
  3450. | TTypeDecl t -> TType (t,List.map snd t.t_types)
  3451. | TAbstractDecl a -> TAbstract (a,List.map snd a.a_types)
  3452. in
  3453. let parse_expr_string s p inl =
  3454. typing_timer ctx (fun() -> parse_expr_string ctx s p inl)
  3455. in
  3456. {
  3457. Interp.pos = p;
  3458. Interp.get_com = (fun() -> ctx.com);
  3459. Interp.get_type = (fun s ->
  3460. typing_timer ctx (fun() ->
  3461. let path = parse_path s in
  3462. try
  3463. let m = Some (Typeload.load_instance ctx { tpackage = fst path; tname = snd path; tparams = []; tsub = None } p true) in
  3464. m
  3465. with Error (Module_not_found _,p2) when p == p2 ->
  3466. None
  3467. )
  3468. );
  3469. Interp.get_module = (fun s ->
  3470. typing_timer ctx (fun() ->
  3471. let path = parse_path s in
  3472. let m = List.map make_instance (Typeload.load_module ctx path p).m_types in
  3473. m
  3474. )
  3475. );
  3476. Interp.on_generate = (fun f ->
  3477. Common.add_filter ctx.com (fun() ->
  3478. let t = macro_timer ctx "onGenerate" in
  3479. f (List.map make_instance ctx.com.types);
  3480. t()
  3481. )
  3482. );
  3483. Interp.on_type_not_found = (fun f ->
  3484. ctx.com.load_extern_type <- (fun path p ->
  3485. match f (s_type_path path) with
  3486. | Interp.VNull -> None
  3487. | td ->
  3488. let (pack,name),tdef,p = Interp.decode_type_def td in
  3489. Some (name,(pack,[tdef,p]))
  3490. ) :: ctx.com.load_extern_type;
  3491. );
  3492. Interp.parse_string = parse_expr_string;
  3493. Interp.typeof = (fun e ->
  3494. typing_timer ctx (fun() -> (type_expr ctx e Value).etype)
  3495. );
  3496. Interp.get_display = (fun s ->
  3497. let is_displaying = ctx.com.display in
  3498. let old_resume = !Parser.resume_display in
  3499. let old_error = ctx.on_error in
  3500. let restore () =
  3501. if not is_displaying then begin
  3502. ctx.com.defines <- PMap.remove (fst (Define.infos Define.Display)) ctx.com.defines;
  3503. ctx.com.display <- false
  3504. end;
  3505. Parser.resume_display := old_resume;
  3506. ctx.on_error <- old_error;
  3507. in
  3508. (* temporarily enter display mode with a fake position *)
  3509. if not is_displaying then begin
  3510. Common.define ctx.com Define.Display;
  3511. ctx.com.display <- true;
  3512. end;
  3513. Parser.resume_display := {
  3514. Ast.pfile = "macro";
  3515. Ast.pmin = 0;
  3516. Ast.pmax = 0;
  3517. };
  3518. ctx.on_error <- (fun ctx msg p -> raise (Error(Custom msg,p)));
  3519. let str = try
  3520. let e = parse_expr_string s Ast.null_pos true in
  3521. let e = Optimizer.optimize_completion_expr e in
  3522. ignore (type_expr ctx e Value);
  3523. "NO COMPLETION"
  3524. with DisplayFields fields ->
  3525. let pctx = print_context() in
  3526. String.concat "," (List.map (fun (f,t,_) -> f ^ ":" ^ s_type pctx t) fields)
  3527. | DisplayTypes tl ->
  3528. let pctx = print_context() in
  3529. String.concat "," (List.map (s_type pctx) tl)
  3530. | Parser.TypePath (p,sub) ->
  3531. (match sub with
  3532. | None ->
  3533. "path(" ^ String.concat "." p ^ ")"
  3534. | Some (c,_) ->
  3535. "path(" ^ String.concat "." p ^ ":" ^ c ^ ")")
  3536. | Typecore.Error (msg,p) ->
  3537. "error(" ^ error_msg msg ^ ")"
  3538. in
  3539. restore();
  3540. str
  3541. );
  3542. Interp.allow_package = (fun v -> Common.allow_package ctx.com v);
  3543. Interp.type_patch = (fun t f s v ->
  3544. typing_timer ctx (fun() ->
  3545. let v = (match v with None -> None | Some s ->
  3546. match parse_string ctx ("typedef T = " ^ s) null_pos false with
  3547. | ETypedef { d_data = ct } -> Some ct
  3548. | _ -> assert false
  3549. ) in
  3550. let tp = get_type_patch ctx t (Some (f,s)) in
  3551. match v with
  3552. | None -> tp.tp_remove <- true
  3553. | Some _ -> tp.tp_type <- v
  3554. );
  3555. );
  3556. Interp.meta_patch = (fun m t f s ->
  3557. let m = (match parse_string ctx (m ^ " typedef T = T") null_pos false with
  3558. | ETypedef t -> t.d_meta
  3559. | _ -> assert false
  3560. ) in
  3561. let tp = get_type_patch ctx t (match f with None -> None | Some f -> Some (f,s)) in
  3562. tp.tp_meta <- tp.tp_meta @ m;
  3563. );
  3564. Interp.set_js_generator = (fun gen ->
  3565. let js_ctx = Genjs.alloc_ctx ctx.com in
  3566. ctx.com.js_gen <- Some (fun() ->
  3567. let jsctx = Interp.enc_obj [
  3568. "outputFile", Interp.enc_string ctx.com.file;
  3569. "types", Interp.enc_array (List.map (fun t -> Interp.encode_type (make_instance t)) ctx.com.types);
  3570. "main", (match ctx.com.main with None -> Interp.VNull | Some e -> Interp.encode_texpr e);
  3571. "generateValue", Interp.VFunction (Interp.Fun1 (fun v ->
  3572. match v with
  3573. | Interp.VAbstract (Interp.ATExpr e) ->
  3574. let str = Genjs.gen_single_expr js_ctx e false in
  3575. Interp.enc_string str
  3576. | _ -> failwith "Invalid expression";
  3577. ));
  3578. "isKeyword", Interp.VFunction (Interp.Fun1 (fun v ->
  3579. Interp.VBool (Hashtbl.mem Genjs.kwds (Interp.dec_string v))
  3580. ));
  3581. "quoteString", Interp.VFunction (Interp.Fun1 (fun v ->
  3582. Interp.enc_string ("\"" ^ Ast.s_escape (Interp.dec_string v) ^ "\"")
  3583. ));
  3584. "buildMetaData", Interp.VFunction (Interp.Fun1 (fun t ->
  3585. match Codegen.build_metadata ctx.com (Interp.decode_tdecl t) with
  3586. | None -> Interp.VNull
  3587. | Some e -> Interp.encode_texpr e
  3588. ));
  3589. "generateStatement", Interp.VFunction (Interp.Fun1 (fun v ->
  3590. match v with
  3591. | Interp.VAbstract (Interp.ATExpr e) ->
  3592. let str = Genjs.gen_single_expr js_ctx e true in
  3593. Interp.enc_string str
  3594. | _ -> failwith "Invalid expression";
  3595. ));
  3596. "setTypeAccessor", Interp.VFunction (Interp.Fun1 (fun callb ->
  3597. js_ctx.Genjs.type_accessor <- (fun t ->
  3598. let v = Interp.encode_type (make_instance t) in
  3599. let ret = Interp.call (Interp.get_ctx()) Interp.VNull callb [v] Nast.null_pos in
  3600. Interp.dec_string ret
  3601. );
  3602. Interp.VNull
  3603. ));
  3604. "setCurrentClass", Interp.VFunction (Interp.Fun1 (fun c ->
  3605. Genjs.set_current_class js_ctx (match Interp.decode_tdecl c with TClassDecl c -> c | _ -> assert false);
  3606. Interp.VNull
  3607. ));
  3608. ] in
  3609. let t = macro_timer ctx "jsGenerator" in
  3610. gen jsctx;
  3611. t()
  3612. );
  3613. );
  3614. Interp.get_local_type = (fun() ->
  3615. match ctx.g.get_build_infos() with
  3616. | Some (mt,_) ->
  3617. Some (match mt with
  3618. | TClassDecl c -> TInst (c,[])
  3619. | TEnumDecl e -> TEnum (e,[])
  3620. | TTypeDecl t -> TType (t,[])
  3621. | TAbstractDecl a -> TAbstract(a,[]))
  3622. | None ->
  3623. if ctx.curclass == null_class then
  3624. None
  3625. else
  3626. Some (TInst (ctx.curclass,[]))
  3627. );
  3628. Interp.get_local_method = (fun() ->
  3629. ctx.curfield.cf_name;
  3630. );
  3631. Interp.get_local_using = (fun() ->
  3632. ctx.m.module_using;
  3633. );
  3634. Interp.get_local_vars = (fun () ->
  3635. ctx.locals;
  3636. );
  3637. Interp.get_build_fields = (fun() ->
  3638. match ctx.g.get_build_infos() with
  3639. | None -> Interp.VNull
  3640. | Some (_,fields) -> Interp.enc_array (List.map Interp.encode_field fields)
  3641. );
  3642. Interp.get_pattern_locals = (fun e t ->
  3643. !get_pattern_locals_ref ctx e t
  3644. );
  3645. Interp.define_type = (fun v ->
  3646. let m, tdef, pos = (try Interp.decode_type_def v with Interp.Invalid_expr -> Interp.exc (Interp.VString "Invalid type definition")) in
  3647. let mdep = Typeload.type_module ctx m ctx.m.curmod.m_extra.m_file [tdef,pos] pos in
  3648. mdep.m_extra.m_kind <- MFake;
  3649. mdep.m_extra.m_time <- -1.;
  3650. add_dependency ctx.m.curmod mdep;
  3651. );
  3652. Interp.module_dependency = (fun mpath file ismacro ->
  3653. let m = typing_timer ctx (fun() -> Typeload.load_module ctx (parse_path mpath) p) in
  3654. if ismacro then
  3655. m.m_extra.m_macro_calls <- file :: List.filter ((<>) file) m.m_extra.m_macro_calls
  3656. else
  3657. add_dependency m (create_fake_module ctx file);
  3658. );
  3659. Interp.current_module = (fun() ->
  3660. ctx.m.curmod
  3661. );
  3662. Interp.delayed_macro = (fun i ->
  3663. let mctx = (match ctx.g.macros with None -> assert false | Some (_,mctx) -> mctx) in
  3664. let f = (try DynArray.get mctx.g.delayed_macros i with _ -> failwith "Delayed macro retrieve failure") in
  3665. f();
  3666. let ret = !delayed_macro_result in
  3667. delayed_macro_result := (fun() -> assert false);
  3668. ret
  3669. );
  3670. Interp.use_cache = (fun() ->
  3671. !macro_enable_cache
  3672. );
  3673. }
  3674. let rec init_macro_interp ctx mctx mint =
  3675. let p = Ast.null_pos in
  3676. ignore(Typeload.load_module mctx (["haxe";"macro"],"Expr") p);
  3677. ignore(Typeload.load_module mctx (["haxe";"macro"],"Type") p);
  3678. flush_macro_context mint ctx;
  3679. Interp.init mint;
  3680. if !macro_enable_cache && not (Common.defined mctx.com Define.NoMacroCache) then macro_interp_cache := Some mint
  3681. and flush_macro_context mint ctx =
  3682. let mctx = (match ctx.g.macros with None -> assert false | Some (_,mctx) -> mctx) in
  3683. finalize mctx;
  3684. let _, types, modules = generate mctx in
  3685. mctx.com.types <- types;
  3686. mctx.com.Common.modules <- modules;
  3687. (* if one of the type we are using has been modified, we need to create a new macro context from scratch *)
  3688. let mint = if not (Interp.can_reuse mint types) then begin
  3689. let com2 = mctx.com in
  3690. let mint = Interp.create com2 (make_macro_api ctx Ast.null_pos) in
  3691. let macro = ((fun() -> Interp.select mint), mctx) in
  3692. ctx.g.macros <- Some macro;
  3693. mctx.g.macros <- Some macro;
  3694. init_macro_interp ctx mctx mint;
  3695. mint
  3696. end else mint in
  3697. (* we should maybe ensure that all filters in Main are applied. Not urgent atm *)
  3698. (try Interp.add_types mint types (Codegen.post_process [Codegen.Abstract.handle_abstract_casts mctx; Codegen.captured_vars mctx.com; Codegen.rename_local_vars mctx.com])
  3699. with Error (e,p) -> display_error ctx (error_msg e) p; raise Fatal_error);
  3700. Codegen.post_process_end()
  3701. let create_macro_interp ctx mctx =
  3702. let com2 = mctx.com in
  3703. let mint, init = (match !macro_interp_cache with
  3704. | None ->
  3705. let mint = Interp.create com2 (make_macro_api ctx Ast.null_pos) in
  3706. mint, (fun() -> init_macro_interp ctx mctx mint)
  3707. | Some mint ->
  3708. Interp.do_reuse mint;
  3709. mint, (fun() -> ())
  3710. ) in
  3711. let on_error = com2.error in
  3712. com2.error <- (fun e p ->
  3713. Interp.set_error (Interp.get_ctx()) true;
  3714. macro_interp_cache := None;
  3715. on_error e p
  3716. );
  3717. let macro = ((fun() -> Interp.select mint), mctx) in
  3718. ctx.g.macros <- Some macro;
  3719. mctx.g.macros <- Some macro;
  3720. (* mctx.g.core_api <- ctx.g.core_api; // causes some issues because of optional args and Null type in Flash9 *)
  3721. init()
  3722. let get_macro_context ctx p =
  3723. let api = make_macro_api ctx p in
  3724. match ctx.g.macros with
  3725. | Some (select,ctx) ->
  3726. select();
  3727. api, ctx
  3728. | None ->
  3729. let com2 = Common.clone ctx.com in
  3730. ctx.com.get_macros <- (fun() -> Some com2);
  3731. com2.package_rules <- PMap.empty;
  3732. com2.main_class <- None;
  3733. com2.display <- false;
  3734. List.iter (fun p -> com2.defines <- PMap.remove (platform_name p) com2.defines) platforms;
  3735. com2.defines_signature <- None;
  3736. com2.class_path <- List.filter (fun s -> not (ExtString.String.exists s "/_std/")) com2.class_path;
  3737. com2.class_path <- List.map (fun p -> p ^ "neko" ^ "/_std/") com2.std_path @ com2.class_path;
  3738. let to_remove = List.map (fun d -> fst (Define.infos d)) [Define.NoTraces] in
  3739. let to_remove = to_remove @ List.map (fun (_,d) -> "flash" ^ d) Common.flash_versions in
  3740. com2.defines <- PMap.foldi (fun k v acc -> if List.mem k to_remove then acc else PMap.add k v acc) com2.defines PMap.empty;
  3741. Common.define com2 Define.Macro;
  3742. Common.init_platform com2 Neko;
  3743. let mctx = ctx.g.do_create com2 in
  3744. create_macro_interp ctx mctx;
  3745. api, mctx
  3746. let load_macro ctx cpath f p =
  3747. (*
  3748. The time measured here takes into account both macro typing an init, but benchmarks
  3749. shows that - unless you re doing heavy statics vars init - the time is mostly spent in
  3750. typing the classes needed for macro execution.
  3751. *)
  3752. let t = macro_timer ctx "typing (+init)" in
  3753. let api, mctx = get_macro_context ctx p in
  3754. let mint = Interp.get_ctx() in
  3755. let m = (try Hashtbl.find ctx.g.types_module cpath with Not_found -> cpath) in
  3756. let mloaded = Typeload.load_module mctx m p in
  3757. mctx.m <- {
  3758. curmod = mloaded;
  3759. module_types = [];
  3760. module_using = [];
  3761. module_globals = PMap.empty;
  3762. wildcard_packages = [];
  3763. };
  3764. add_dependency ctx.m.curmod mloaded;
  3765. let cl, meth = (match Typeload.load_instance mctx { tpackage = fst cpath; tname = snd cpath; tparams = []; tsub = None } p true with
  3766. | TInst (c,_) ->
  3767. finalize mctx;
  3768. c, (try PMap.find f c.cl_statics with Not_found -> error ("Method " ^ f ^ " not found on class " ^ s_type_path cpath) p)
  3769. | _ -> error "Macro should be called on a class" p
  3770. ) in
  3771. let meth = (match follow meth.cf_type with TFun (args,ret) -> args,ret,cl,meth | _ -> error "Macro call should be a method" p) in
  3772. if not ctx.in_macro then flush_macro_context mint ctx;
  3773. t();
  3774. let call args =
  3775. let t = macro_timer ctx (s_type_path cpath ^ "." ^ f) in
  3776. incr stats.s_macros_called;
  3777. let r = Interp.call_path (Interp.get_ctx()) ((fst cpath) @ [snd cpath]) f args api in
  3778. t();
  3779. r
  3780. in
  3781. mctx, meth, call
  3782. let type_macro ctx mode cpath f (el:Ast.expr list) p =
  3783. let mctx, (margs,mret,mclass,mfield), call_macro = load_macro ctx cpath f p in
  3784. let mpos = mfield.cf_pos in
  3785. let ctexpr = { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None } in
  3786. let expr = Typeload.load_instance mctx ctexpr p false in
  3787. (match mode with
  3788. | MExpr ->
  3789. unify mctx mret expr mpos;
  3790. | MBuild ->
  3791. let ctfields = { tpackage = []; tname = "Array"; tparams = [TPType (CTPath { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = Some "Field" })]; tsub = None } in
  3792. let tfields = Typeload.load_instance mctx ctfields p false in
  3793. unify mctx mret tfields mpos
  3794. | MMacroType ->
  3795. let cttype = { tpackage = ["haxe";"macro"]; tname = "Type"; tparams = []; tsub = None } in
  3796. let ttype = Typeload.load_instance mctx cttype p false in
  3797. unify mctx mret ttype mpos
  3798. );
  3799. (*
  3800. if the function's last argument is of Array<Expr>, split the argument list and use [] for unify_call_params
  3801. *)
  3802. let el,el2 = match List.rev margs with
  3803. | (_,_,TInst({cl_path=([], "Array")},[e])) :: rest when (try Type.type_eq EqStrict e expr; true with Unify_error _ -> false) ->
  3804. let rec loop (acc1,acc2) el1 el2 = match el1,el2 with
  3805. | [],[] ->
  3806. List.rev acc1, List.rev acc2
  3807. | [], e2 :: [] ->
  3808. (List.rev ((EArrayDecl [],p) :: acc1), [])
  3809. | [], _ ->
  3810. (* not enough arguments, will be handled by unify_call_params *)
  3811. List.rev acc1, List.rev acc2
  3812. | e1 :: l1, e2 :: [] ->
  3813. loop (((EArrayDecl [],p) :: acc1), [e1]) l1 []
  3814. | e1 :: l1, [] ->
  3815. loop (acc1, e1 :: acc2) l1 []
  3816. | e1 :: l1, e2 :: l2 ->
  3817. loop (e1 :: acc1, acc2) l1 l2
  3818. in
  3819. loop ([],[]) el margs
  3820. | _ ->
  3821. el,[]
  3822. in
  3823. let todo = ref [] in
  3824. let args =
  3825. (*
  3826. force default parameter types to haxe.macro.Expr, and if success allow to pass any value type since it will be encoded
  3827. *)
  3828. let eargs = List.map (fun (n,o,t) -> try unify_raise mctx t expr p; (n, o, t_dynamic), true with Error (Unify _,_) -> (n,o,t), false) margs in
  3829. (*
  3830. this is quite tricky here : we want to use unify_call_params which will type our AST expr
  3831. but we want to be able to get it back after it's been padded with nulls
  3832. *)
  3833. let index = ref (-1) in
  3834. let constants = List.map (fun e ->
  3835. let p = snd e in
  3836. let e = (try
  3837. (match Codegen.type_constant_value ctx.com e with
  3838. | { eexpr = TConst (TString _); epos = p } when Lexer.is_fmt_string p ->
  3839. Lexer.remove_fmt_string p;
  3840. todo := (fun() -> Lexer.add_fmt_string p) :: !todo;
  3841. | _ -> ());
  3842. e
  3843. with Error (Custom _,_) ->
  3844. (* if it's not a constant, let's make something that is typed as haxe.macro.Expr - for nice error reporting *)
  3845. (EBlock [
  3846. (EVars ["__tmp",Some (CTPath ctexpr),Some (EConst (Ident "null"),p)],p);
  3847. (EConst (Ident "__tmp"),p);
  3848. ],p)
  3849. ) in
  3850. (* let's track the index by doing [e][index] (we will keep the expression type this way) *)
  3851. incr index;
  3852. (EArray ((EArrayDecl [e],p),(EConst (Int (string_of_int (!index))),p)),p)
  3853. ) el in
  3854. let elt, _ = unify_call_params mctx (Some (TInst(mclass,[]),mfield)) constants (List.map fst eargs) t_dynamic p false in
  3855. List.iter (fun f -> f()) (!todo);
  3856. List.map2 (fun (_,ise) e ->
  3857. let e, et = (match e.eexpr with
  3858. (* get back our index and real expression *)
  3859. | TArray ({ eexpr = TArrayDecl [e] }, { eexpr = TConst (TInt index) }) -> List.nth el (Int32.to_int index), e
  3860. (* added by unify_call_params *)
  3861. | TConst TNull -> (EConst (Ident "null"),e.epos), e
  3862. | _ -> assert false
  3863. ) in
  3864. if ise then
  3865. Interp.encode_expr e
  3866. else match Interp.eval_expr (Interp.get_ctx()) et with
  3867. | None -> assert false
  3868. | Some v -> v
  3869. ) eargs elt
  3870. in
  3871. let args = match el2 with
  3872. | [] -> args
  3873. | _ -> (match List.rev args with _::args -> List.rev args | [] -> []) @ [Interp.enc_array (List.map Interp.encode_expr el2)]
  3874. in
  3875. let call() =
  3876. match call_macro args with
  3877. | None -> None
  3878. | Some v ->
  3879. try
  3880. Some (match mode with
  3881. | MExpr -> Interp.decode_expr v
  3882. | MBuild ->
  3883. let fields = (match v with
  3884. | Interp.VNull ->
  3885. (match ctx.g.get_build_infos() with
  3886. | None -> assert false
  3887. | Some (_,fields) -> fields)
  3888. | _ ->
  3889. List.map Interp.decode_field (Interp.dec_array v)
  3890. ) in
  3891. (EVars ["fields",Some (CTAnonymous fields),None],p)
  3892. | MMacroType ->
  3893. ctx.ret <- Interp.decode_type v;
  3894. (EBlock [],p)
  3895. )
  3896. with Interp.Invalid_expr ->
  3897. error "The macro didn't return a valid result" p
  3898. in
  3899. let e = (if ctx.in_macro then begin
  3900. (*
  3901. this is super-tricky : we can't evaluate a macro inside a macro because we might trigger some cycles.
  3902. So instead, we generate a haxe.macro.Context.delayedCalled(i) expression that will only evaluate the
  3903. macro if/when it is called.
  3904. The tricky part is that the whole delayed-evaluation process has to use the same contextual informations
  3905. as if it was evaluated now.
  3906. *)
  3907. let ctx = {
  3908. ctx with locals = ctx.locals;
  3909. } in
  3910. let pos = DynArray.length mctx.g.delayed_macros in
  3911. DynArray.add mctx.g.delayed_macros (fun() ->
  3912. delayed_macro_result := (fun() ->
  3913. let mint = Interp.get_ctx() in
  3914. match call() with
  3915. | None -> (fun() -> raise Interp.Abort)
  3916. | Some e -> Interp.eval mint (Genneko.gen_expr mint.Interp.gen (type_expr ctx e Value))
  3917. );
  3918. );
  3919. ctx.m.curmod.m_extra.m_time <- -1.; (* disable caching for modules having macro-in-macro *)
  3920. let e = (EConst (Ident "__dollar__delay_call"),p) in
  3921. Some (EUntyped (ECall (e,[EConst (Int (string_of_int pos)),p]),p),p)
  3922. end else
  3923. call()
  3924. ) in
  3925. e
  3926. let call_macro ctx path meth args p =
  3927. let mctx, (margs,_,mclass,mfield), call = load_macro ctx path meth p in
  3928. let el, _ = unify_call_params mctx (Some (TInst(mclass,[]),mfield)) args margs t_dynamic p false in
  3929. call (List.map (fun e -> try Interp.make_const e with Exit -> error "Parameter should be a constant" e.epos) el)
  3930. let call_init_macro ctx e =
  3931. let p = { pfile = "--macro"; pmin = 0; pmax = 0 } in
  3932. let api = make_macro_api ctx p in
  3933. let e = api.Interp.parse_string e p false in
  3934. match fst e with
  3935. | ECall (e,args) ->
  3936. let rec loop e =
  3937. match fst e with
  3938. | EField (e,f) -> f :: loop e
  3939. | EConst (Ident i) -> [i]
  3940. | _ -> error "Invalid macro call" p
  3941. in
  3942. let path, meth = (match loop e with
  3943. | [meth] -> (["haxe";"macro"],"Compiler"), meth
  3944. | meth :: cl :: path -> (List.rev path,cl), meth
  3945. | _ -> error "Invalid macro call" p) in
  3946. ignore(call_macro ctx path meth args p);
  3947. | _ ->
  3948. error "Invalid macro call" p
  3949. (* ---------------------------------------------------------------------- *)
  3950. (* TYPER INITIALIZATION *)
  3951. let rec create com =
  3952. let ctx = {
  3953. com = com;
  3954. t = com.basic;
  3955. g = {
  3956. core_api = None;
  3957. macros = None;
  3958. modules = Hashtbl.create 0;
  3959. types_module = Hashtbl.create 0;
  3960. type_patches = Hashtbl.create 0;
  3961. delayed = [];
  3962. debug_delayed = [];
  3963. delayed_macros = DynArray.create();
  3964. doinline = not (Common.defined com Define.NoInline || com.display);
  3965. hook_generate = [];
  3966. get_build_infos = (fun() -> None);
  3967. std = null_module;
  3968. global_using = [];
  3969. do_inherit = Codegen.on_inherit;
  3970. do_create = create;
  3971. do_macro = type_macro;
  3972. do_load_module = Typeload.load_module;
  3973. do_optimize = Optimizer.reduce_expression;
  3974. do_build_instance = Codegen.build_instance;
  3975. };
  3976. m = {
  3977. curmod = null_module;
  3978. module_types = [];
  3979. module_using = [];
  3980. module_globals = PMap.empty;
  3981. wildcard_packages = [];
  3982. };
  3983. meta = [];
  3984. pass = PBuildModule;
  3985. macro_depth = 0;
  3986. untyped = false;
  3987. curfun = FunStatic;
  3988. in_loop = false;
  3989. in_super_call = false;
  3990. in_display = false;
  3991. in_macro = Common.defined com Define.Macro;
  3992. ret = mk_mono();
  3993. locals = PMap.empty;
  3994. type_params = [];
  3995. curclass = null_class;
  3996. curfield = null_field;
  3997. tthis = mk_mono();
  3998. opened = [];
  3999. vthis = None;
  4000. on_error = (fun ctx msg p -> ctx.com.error msg p);
  4001. } in
  4002. ctx.g.std <- (try
  4003. Typeload.load_module ctx ([],"StdTypes") null_pos
  4004. with
  4005. Error (Module_not_found ([],"StdTypes"),_) -> error "Standard library not found" null_pos
  4006. );
  4007. List.iter (fun t ->
  4008. match t with
  4009. | TAbstractDecl a ->
  4010. (match snd a.a_path with
  4011. | "Void" -> ctx.t.tvoid <- TAbstract (a,[]);
  4012. | "Float" -> ctx.t.tfloat <- TAbstract (a,[]);
  4013. | "Int" -> ctx.t.tint <- TAbstract (a,[])
  4014. | "Bool" -> ctx.t.tbool <- TAbstract (a,[])
  4015. | _ -> ());
  4016. | TEnumDecl e ->
  4017. ()
  4018. | TClassDecl c ->
  4019. ()
  4020. | TTypeDecl td ->
  4021. (match snd td.t_path with
  4022. | "Null" ->
  4023. let mk_null t =
  4024. try
  4025. if not (is_nullable ~no_lazy:true t) then TType (td,[t]) else t
  4026. with Exit ->
  4027. (* don't force lazy evaluation *)
  4028. let r = ref (fun() -> assert false) in
  4029. r := (fun() ->
  4030. let t = (if not (is_nullable t) then TType (td,[t]) else t) in
  4031. r := (fun() -> t);
  4032. t
  4033. );
  4034. TLazy r
  4035. in
  4036. ctx.t.tnull <- if not com.config.pf_static then (fun t -> t) else mk_null;
  4037. | _ -> ());
  4038. ) ctx.g.std.m_types;
  4039. let m = Typeload.load_module ctx ([],"String") null_pos in
  4040. (match m.m_types with
  4041. | [TClassDecl c] -> ctx.t.tstring <- TInst (c,[])
  4042. | _ -> assert false);
  4043. let m = Typeload.load_module ctx ([],"Array") null_pos in
  4044. (match m.m_types with
  4045. | [TClassDecl c] -> ctx.t.tarray <- (fun t -> TInst (c,[t]))
  4046. | _ -> assert false);
  4047. let m = Typeload.load_module ctx (["haxe"],"EnumTools") null_pos in
  4048. (match m.m_types with
  4049. | [TClassDecl c1;TClassDecl c2] -> ctx.g.global_using <- c1 :: c2 :: ctx.g.global_using
  4050. | [TClassDecl c1] ->
  4051. let m = Typeload.load_module ctx (["haxe"],"EnumValueTools") null_pos in
  4052. (match m.m_types with
  4053. | [TClassDecl c2 ] -> ctx.g.global_using <- c1 :: c2 :: ctx.g.global_using
  4054. | _ -> assert false);
  4055. | _ -> assert false);
  4056. ctx
  4057. ;;
  4058. unify_min_ref := unify_min;
  4059. make_call_ref := make_call;
  4060. get_constructor_ref := get_constructor;
  4061. check_abstract_cast_ref := Codegen.Abstract.check_cast;