1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269 |
- (*
- The Haxe Compiler
- Copyright (C) 2005-2015 Haxe Foundation
- This program is free software; you can redistribute it and/or
- modify it under the terms of the GNU General Public License
- as published by the Free Software Foundation; either version 2
- of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
- *)
- open Ast
- type path = string list * string
- type field_kind =
- | Var of var_kind
- | Method of method_kind
- and var_kind = {
- v_read : var_access;
- v_write : var_access;
- }
- and var_access =
- | AccNormal
- | AccNo (* can't be accessed outside of the class itself and its subclasses *)
- | AccNever (* can't be accessed, even in subclasses *)
- | AccResolve (* call resolve("field") when accessed *)
- | AccCall (* perform a method call when accessed *)
- | AccInline (* similar to Normal but inline when accessed *)
- | AccRequire of string * string option (* set when @:require(cond) fails *)
- and method_kind =
- | MethNormal
- | MethInline
- | MethDynamic
- | MethMacro
- type t =
- | TMono of t option ref
- | TEnum of tenum * tparams
- | TInst of tclass * tparams
- | TType of tdef * tparams
- | TFun of (string * bool * t) list * t
- | TAnon of tanon
- | TDynamic of t
- | TLazy of (unit -> t) ref
- | TAbstract of tabstract * tparams
- and tparams = t list
- and type_params = (string * t) list
- and tconstant =
- | TInt of int32
- | TFloat of string
- | TString of string
- | TBool of bool
- | TNull
- | TThis
- | TSuper
- and tvar = {
- mutable v_id : int;
- mutable v_name : string;
- mutable v_type : t;
- mutable v_capture : bool;
- mutable v_extra : (type_params * texpr option) option;
- mutable v_meta : metadata;
- }
- and tfunc = {
- tf_args : (tvar * tconstant option) list;
- tf_type : t;
- tf_expr : texpr;
- }
- and anon_status =
- | Closed
- | Opened
- | Const
- | Extend of t list
- | Statics of tclass
- | EnumStatics of tenum
- | AbstractStatics of tabstract
- and tanon = {
- mutable a_fields : (string, tclass_field) PMap.t;
- a_status : anon_status ref;
- }
- and texpr_expr =
- | TConst of tconstant
- | TLocal of tvar
- | TArray of texpr * texpr
- | TBinop of Ast.binop * texpr * texpr
- | TField of texpr * tfield_access
- | TTypeExpr of module_type
- | TParenthesis of texpr
- | TObjectDecl of (string * texpr) list
- | TArrayDecl of texpr list
- | TCall of texpr * texpr list
- | TNew of tclass * tparams * texpr list
- | TUnop of Ast.unop * Ast.unop_flag * texpr
- | TFunction of tfunc
- | TVar of tvar * texpr option
- | TBlock of texpr list
- | TFor of tvar * texpr * texpr
- | TIf of texpr * texpr * texpr option
- | TWhile of texpr * texpr * Ast.while_flag
- | TSwitch of texpr * (texpr list * texpr) list * texpr option
- | TTry of texpr * (tvar * texpr) list
- | TReturn of texpr option
- | TBreak
- | TContinue
- | TThrow of texpr
- | TCast of texpr * module_type option
- | TMeta of metadata_entry * texpr
- | TEnumParameter of texpr * tenum_field * int
- and tfield_access =
- | FInstance of tclass * tparams * tclass_field
- | FStatic of tclass * tclass_field
- | FAnon of tclass_field
- | FDynamic of string
- | FClosure of (tclass * tparams) option * tclass_field (* None class = TAnon *)
- | FEnum of tenum * tenum_field
- and texpr = {
- eexpr : texpr_expr;
- etype : t;
- epos : Ast.pos;
- }
- and tclass_field = {
- mutable cf_name : string;
- mutable cf_type : t;
- mutable cf_public : bool;
- cf_pos : pos;
- mutable cf_doc : Ast.documentation;
- mutable cf_meta : metadata;
- mutable cf_kind : field_kind;
- mutable cf_params : type_params;
- mutable cf_expr : texpr option;
- mutable cf_overloads : tclass_field list;
- }
- and tclass_kind =
- | KNormal
- | KTypeParameter of t list
- | KExtension of tclass * tparams
- | KExpr of Ast.expr
- | KGeneric
- | KGenericInstance of tclass * tparams
- | KMacroType
- | KGenericBuild of class_field list
- | KAbstractImpl of tabstract
- and metadata = Ast.metadata
- and tinfos = {
- mt_path : path;
- mt_module : module_def;
- mt_pos : Ast.pos;
- mt_private : bool;
- mt_doc : Ast.documentation;
- mutable mt_meta : metadata;
- mt_params : type_params;
- }
- and tclass = {
- mutable cl_path : path;
- mutable cl_module : module_def;
- mutable cl_pos : Ast.pos;
- mutable cl_private : bool;
- mutable cl_doc : Ast.documentation;
- mutable cl_meta : metadata;
- mutable cl_params : type_params;
- (* do not insert any fields above *)
- mutable cl_kind : tclass_kind;
- mutable cl_extern : bool;
- mutable cl_interface : bool;
- mutable cl_super : (tclass * tparams) option;
- mutable cl_implements : (tclass * tparams) list;
- mutable cl_fields : (string , tclass_field) PMap.t;
- mutable cl_statics : (string, tclass_field) PMap.t;
- mutable cl_ordered_statics : tclass_field list;
- mutable cl_ordered_fields : tclass_field list;
- mutable cl_dynamic : t option;
- mutable cl_array_access : t option;
- mutable cl_constructor : tclass_field option;
- mutable cl_init : texpr option;
- mutable cl_overrides : tclass_field list;
- mutable cl_build : unit -> bool;
- mutable cl_restore : unit -> unit;
- }
- and tenum_field = {
- ef_name : string;
- ef_type : t;
- ef_pos : Ast.pos;
- ef_doc : Ast.documentation;
- ef_index : int;
- ef_params : type_params;
- mutable ef_meta : metadata;
- }
- and tenum = {
- mutable e_path : path;
- e_module : module_def;
- e_pos : Ast.pos;
- e_private : bool;
- e_doc : Ast.documentation;
- mutable e_meta : metadata;
- mutable e_params : type_params;
- (* do not insert any fields above *)
- e_type : tdef;
- mutable e_extern : bool;
- mutable e_constrs : (string , tenum_field) PMap.t;
- mutable e_names : string list;
- }
- and tdef = {
- t_path : path;
- t_module : module_def;
- t_pos : Ast.pos;
- t_private : bool;
- t_doc : Ast.documentation;
- mutable t_meta : metadata;
- mutable t_params : type_params;
- (* do not insert any fields above *)
- mutable t_type : t;
- }
- and tabstract = {
- mutable a_path : path;
- a_module : module_def;
- a_pos : Ast.pos;
- a_private : bool;
- a_doc : Ast.documentation;
- mutable a_meta : metadata;
- mutable a_params : type_params;
- (* do not insert any fields above *)
- mutable a_ops : (Ast.binop * tclass_field) list;
- mutable a_unops : (Ast.unop * unop_flag * tclass_field) list;
- mutable a_impl : tclass option;
- mutable a_this : t;
- mutable a_from : t list;
- mutable a_from_field : (t * tclass_field) list;
- mutable a_to : t list;
- mutable a_to_field : (t * tclass_field) list;
- mutable a_array : tclass_field list;
- mutable a_resolve : tclass_field option;
- }
- and module_type =
- | TClassDecl of tclass
- | TEnumDecl of tenum
- | TTypeDecl of tdef
- | TAbstractDecl of tabstract
- and module_def = {
- m_id : int;
- m_path : path;
- mutable m_types : module_type list;
- m_extra : module_def_extra;
- }
- and module_def_extra = {
- m_file : string;
- m_sign : string;
- mutable m_time : float;
- mutable m_dirty : bool;
- mutable m_added : int;
- mutable m_mark : int;
- mutable m_deps : (int,module_def) PMap.t;
- mutable m_processed : int;
- mutable m_kind : module_kind;
- mutable m_binded_res : (string, string) PMap.t;
- mutable m_macro_calls : string list;
- mutable m_if_feature : (string *(tclass * tclass_field * bool)) list;
- mutable m_features : (string,bool) Hashtbl.t;
- }
- and module_kind =
- | MCode
- | MMacro
- | MFake
- | MSub
- | MExtern
- and dt =
- | DTSwitch of texpr * (texpr * dt) list * dt option
- | DTBind of ((tvar * pos) * texpr) list * dt
- | DTGoto of int
- | DTExpr of texpr
- | DTGuard of texpr * dt * dt option
- and decision_tree = {
- dt_dt_lookup : dt array;
- dt_first : int;
- dt_type : t;
- dt_var_init : (tvar * texpr option) list;
- dt_is_complex : bool;
- }
- (* ======= General utility ======= *)
- let alloc_var =
- let uid = ref 0 in
- (fun n t -> incr uid; { v_name = n; v_type = t; v_id = !uid; v_capture = false; v_extra = None; v_meta = [] })
- let alloc_unbound_var n t =
- let v = alloc_var n t in
- v.v_meta <- [Meta.Unbound,[],null_pos];
- v
- let alloc_mid =
- let mid = ref 0 in
- (fun() -> incr mid; !mid)
- let mk e t p = { eexpr = e; etype = t; epos = p }
- let mk_block e =
- match e.eexpr with
- | TBlock _ -> e
- | _ -> mk (TBlock [e]) e.etype e.epos
- let mk_cast e t p = mk (TCast(e,None)) t p
- let null t p = mk (TConst TNull) t p
- let mk_mono() = TMono (ref None)
- let rec t_dynamic = TDynamic t_dynamic
- let tfun pl r = TFun (List.map (fun t -> "",false,t) pl,r)
- let fun_args l = List.map (fun (a,c,t) -> a, c <> None, t) l
- let mk_class m path pos =
- {
- cl_path = path;
- cl_module = m;
- cl_pos = pos;
- cl_doc = None;
- cl_meta = [];
- cl_private = false;
- cl_kind = KNormal;
- cl_extern = false;
- cl_interface = false;
- cl_params = [];
- cl_super = None;
- cl_implements = [];
- cl_fields = PMap.empty;
- cl_ordered_statics = [];
- cl_ordered_fields = [];
- cl_statics = PMap.empty;
- cl_dynamic = None;
- cl_array_access = None;
- cl_constructor = None;
- cl_init = None;
- cl_overrides = [];
- cl_build = (fun() -> true);
- cl_restore = (fun() -> ());
- }
- let module_extra file sign time kind =
- {
- m_file = file;
- m_sign = sign;
- m_dirty = false;
- m_added = 0;
- m_mark = 0;
- m_time = time;
- m_processed = 0;
- m_deps = PMap.empty;
- m_kind = kind;
- m_binded_res = PMap.empty;
- m_macro_calls = [];
- m_if_feature = [];
- m_features = Hashtbl.create 0;
- }
- let mk_field name t p = {
- cf_name = name;
- cf_type = t;
- cf_pos = p;
- cf_doc = None;
- cf_meta = [];
- cf_public = true;
- cf_kind = Var { v_read = AccNormal; v_write = AccNormal };
- cf_expr = None;
- cf_params = [];
- cf_overloads = [];
- }
- let null_module = {
- m_id = alloc_mid();
- m_path = [] , "";
- m_types = [];
- m_extra = module_extra "" "" 0. MFake;
- }
- let null_class =
- let c = mk_class null_module ([],"") Ast.null_pos in
- c.cl_private <- true;
- c
- let null_field = mk_field "" t_dynamic Ast.null_pos
- let null_abstract = {
- a_path = ([],"");
- a_module = null_module;
- a_pos = null_pos;
- a_private = true;
- a_doc = None;
- a_meta = [];
- a_params = [];
- a_ops = [];
- a_unops = [];
- a_impl = None;
- a_this = t_dynamic;
- a_from = [];
- a_from_field = [];
- a_to = [];
- a_to_field = [];
- a_array = [];
- a_resolve = None;
- }
- let add_dependency m mdep =
- if m != null_module && m != mdep then m.m_extra.m_deps <- PMap.add mdep.m_id mdep m.m_extra.m_deps
- let arg_name (a,_) = a.v_name
- let t_infos t : tinfos =
- match t with
- | TClassDecl c -> Obj.magic c
- | TEnumDecl e -> Obj.magic e
- | TTypeDecl t -> Obj.magic t
- | TAbstractDecl a -> Obj.magic a
- let t_path t = (t_infos t).mt_path
- let rec is_parent csup c =
- if c == csup || List.exists (fun (i,_) -> is_parent csup i) c.cl_implements then
- true
- else match c.cl_super with
- | None -> false
- | Some (c,_) -> is_parent csup c
- let map loop t =
- match t with
- | TMono r ->
- (match !r with
- | None -> t
- | Some t -> loop t) (* erase*)
- | TEnum (_,[]) | TInst (_,[]) | TType (_,[]) ->
- t
- | TEnum (e,tl) ->
- TEnum (e, List.map loop tl)
- | TInst (c,tl) ->
- TInst (c, List.map loop tl)
- | TType (t2,tl) ->
- TType (t2,List.map loop tl)
- | TAbstract (a,tl) ->
- TAbstract (a,List.map loop tl)
- | TFun (tl,r) ->
- TFun (List.map (fun (s,o,t) -> s, o, loop t) tl,loop r)
- | TAnon a ->
- let fields = PMap.map (fun f -> { f with cf_type = loop f.cf_type }) a.a_fields in
- begin match !(a.a_status) with
- | Opened ->
- a.a_fields <- fields;
- t
- | _ ->
- TAnon {
- a_fields = fields;
- a_status = a.a_status;
- }
- end
- | TLazy f ->
- let ft = !f() in
- let ft2 = loop ft in
- if ft == ft2 then t else ft2
- | TDynamic t2 ->
- if t == t2 then t else TDynamic (loop t2)
- (* substitute parameters with other types *)
- let apply_params cparams params t =
- match cparams with
- | [] -> t
- | _ ->
- let rec loop l1 l2 =
- match l1, l2 with
- | [] , [] -> []
- | (x,TLazy f) :: l1, _ -> loop ((x,(!f)()) :: l1) l2
- | (_,t1) :: l1 , t2 :: l2 -> (t1,t2) :: loop l1 l2
- | _ -> assert false
- in
- let subst = loop cparams params in
- let rec loop t =
- try
- List.assq t subst
- with Not_found ->
- match t with
- | TMono r ->
- (match !r with
- | None -> t
- | Some t -> loop t)
- | TEnum (e,tl) ->
- (match tl with
- | [] -> t
- | _ -> TEnum (e,List.map loop tl))
- | TType (t2,tl) ->
- (match tl with
- | [] -> t
- | _ -> TType (t2,List.map loop tl))
- | TAbstract (a,tl) ->
- (match tl with
- | [] -> t
- | _ -> TAbstract (a,List.map loop tl))
- | TInst (c,tl) ->
- (match tl with
- | [] ->
- t
- | [TMono r] ->
- (match !r with
- | Some tt when t == tt ->
- (* for dynamic *)
- let pt = mk_mono() in
- let t = TInst (c,[pt]) in
- (match pt with TMono r -> r := Some t | _ -> assert false);
- t
- | _ -> TInst (c,List.map loop tl))
- | _ ->
- TInst (c,List.map loop tl))
- | TFun (tl,r) ->
- TFun (List.map (fun (s,o,t) -> s, o, loop t) tl,loop r)
- | TAnon a ->
- let fields = PMap.map (fun f -> { f with cf_type = loop f.cf_type }) a.a_fields in
- begin match !(a.a_status) with
- | Opened ->
- a.a_fields <- fields;
- t
- | _ ->
- TAnon {
- a_fields = fields;
- a_status = a.a_status;
- }
- end
- | TLazy f ->
- let ft = !f() in
- let ft2 = loop ft in
- if ft == ft2 then
- t
- else
- ft2
- | TDynamic t2 ->
- if t == t2 then
- t
- else
- TDynamic (loop t2)
- in
- loop t
- let monomorphs eparams t =
- apply_params eparams (List.map (fun _ -> mk_mono()) eparams) t
- let rec follow t =
- match t with
- | TMono r ->
- (match !r with
- | Some t -> follow t
- | _ -> t)
- | TLazy f ->
- follow (!f())
- | TType (t,tl) ->
- follow (apply_params t.t_params tl t.t_type)
- | _ -> t
- let rec is_nullable = function
- | TMono r ->
- (match !r with None -> false | Some t -> is_nullable t)
- | TType ({ t_path = ([],"Null") },[_]) ->
- true
- | TLazy f ->
- is_nullable (!f())
- | TType (t,tl) ->
- is_nullable (apply_params t.t_params tl t.t_type)
- | TFun _ ->
- false
- (*
- Type parameters will most of the time be nullable objects, so we don't want to make it hard for users
- to have to specify Null<T> all over the place, so while they could be a basic type, let's assume they will not.
- This will still cause issues with inlining and haxe.rtti.Generic. In that case proper explicit Null<T> is required to
- work correctly with basic types. This could still be fixed by redoing a nullability inference on the typed AST.
- | TInst ({ cl_kind = KTypeParameter },_) -> false
- *)
- | TAbstract (a,_) when Meta.has Meta.CoreType a.a_meta ->
- not (Meta.has Meta.NotNull a.a_meta)
- | TAbstract (a,tl) ->
- not (Meta.has Meta.NotNull a.a_meta) && is_nullable (apply_params a.a_params tl a.a_this)
- | _ ->
- true
- let rec is_null ?(no_lazy=false) = function
- | TMono r ->
- (match !r with None -> false | Some t -> is_null t)
- | TType ({ t_path = ([],"Null") },[t]) ->
- not (is_nullable (follow t))
- | TLazy f ->
- if no_lazy then raise Exit else is_null (!f())
- | TType (t,tl) ->
- is_null (apply_params t.t_params tl t.t_type)
- | _ ->
- false
- (* Determines if we have a Null<T>. Unlike is_null, this returns true even if the wrapped type is nullable itself. *)
- let rec is_explicit_null = function
- | TMono r ->
- (match !r with None -> false | Some t -> is_null t)
- | TType ({ t_path = ([],"Null") },[t]) ->
- true
- | TLazy f ->
- is_null (!f())
- | TType (t,tl) ->
- is_null (apply_params t.t_params tl t.t_type)
- | _ ->
- false
- let rec has_mono t = match t with
- | TMono r ->
- (match !r with None -> true | Some t -> has_mono t)
- | TInst(_,pl) | TEnum(_,pl) | TAbstract(_,pl) | TType(_,pl) ->
- List.exists has_mono pl
- | TDynamic _ ->
- false
- | TFun(args,r) ->
- has_mono r || List.exists (fun (_,_,t) -> has_mono t) args
- | TAnon a ->
- PMap.fold (fun cf b -> has_mono cf.cf_type || b) a.a_fields false
- | TLazy r ->
- has_mono (!r())
- let concat e1 e2 =
- let e = (match e1.eexpr, e2.eexpr with
- | TBlock el1, TBlock el2 -> TBlock (el1@el2)
- | TBlock el, _ -> TBlock (el @ [e2])
- | _, TBlock el -> TBlock (e1 :: el)
- | _ , _ -> TBlock [e1;e2]
- ) in
- mk e e2.etype (punion e1.epos e2.epos)
- let is_closed a = !(a.a_status) <> Opened
- let type_of_module_type = function
- | TClassDecl c -> TInst (c,List.map snd c.cl_params)
- | TEnumDecl e -> TEnum (e,List.map snd e.e_params)
- | TTypeDecl t -> TType (t,List.map snd t.t_params)
- | TAbstractDecl a -> TAbstract (a,List.map snd a.a_params)
- let tconst_to_const = function
- | TInt i -> Int (Int32.to_string i)
- | TFloat s -> Float s
- | TString s -> String s
- | TBool b -> Ident (if b then "true" else "false")
- | TNull -> Ident "null"
- | TThis -> Ident "this"
- | TSuper -> Ident "super"
- (* ======= Field utility ======= *)
- let field_name f =
- match f with
- | FAnon f | FInstance (_,_,f) | FStatic (_,f) | FClosure (_,f) -> f.cf_name
- | FEnum (_,f) -> f.ef_name
- | FDynamic n -> n
- let extract_field = function
- | FAnon f | FInstance (_,_,f) | FStatic (_,f) | FClosure (_,f) -> Some f
- | _ -> None
- let is_extern_field f =
- match f.cf_kind with
- | Method _ -> false
- | Var { v_read = AccNormal | AccInline | AccNo } | Var { v_write = AccNormal | AccNo } -> false
- | _ -> not (Meta.has Meta.IsVar f.cf_meta)
- let field_type f =
- match f.cf_params with
- | [] -> f.cf_type
- | l -> monomorphs l f.cf_type
- let rec raw_class_field build_type c tl i =
- let apply = apply_params c.cl_params tl in
- try
- let f = PMap.find i c.cl_fields in
- Some (c,tl), build_type f , f
- with Not_found -> try (match c.cl_constructor with
- | Some ctor when i = "new" -> Some (c,tl), build_type ctor,ctor
- | _ -> raise Not_found)
- with Not_found -> try
- match c.cl_super with
- | None ->
- raise Not_found
- | Some (c,tl) ->
- let c2 , t , f = raw_class_field build_type c (List.map apply tl) i in
- c2, apply_params c.cl_params tl t , f
- with Not_found ->
- match c.cl_kind with
- | KTypeParameter tl ->
- let rec loop = function
- | [] ->
- raise Not_found
- | t :: ctl ->
- match follow t with
- | TAnon a ->
- (try
- let f = PMap.find i a.a_fields in
- None, build_type f, f
- with
- Not_found -> loop ctl)
- | TInst (c,tl) ->
- (try
- let c2, t , f = raw_class_field build_type c (List.map apply tl) i in
- c2, apply_params c.cl_params tl t, f
- with
- Not_found -> loop ctl)
- | _ ->
- loop ctl
- in
- loop tl
- | _ ->
- if not c.cl_interface then raise Not_found;
- (*
- an interface can implements other interfaces without
- having to redeclare its fields
- *)
- let rec loop = function
- | [] ->
- raise Not_found
- | (c,tl) :: l ->
- try
- let c2, t , f = raw_class_field build_type c (List.map apply tl) i in
- c2, apply_params c.cl_params tl t, f
- with
- Not_found -> loop l
- in
- loop c.cl_implements
- let class_field = raw_class_field field_type
- let quick_field t n =
- match follow t with
- | TInst (c,tl) ->
- let c, _, f = raw_class_field (fun f -> f.cf_type) c tl n in
- (match c with None -> FAnon f | Some (c,tl) -> FInstance (c,tl,f))
- | TAnon a ->
- (match !(a.a_status) with
- | EnumStatics e ->
- let ef = PMap.find n e.e_constrs in
- FEnum(e,ef)
- | Statics c ->
- FStatic (c,PMap.find n c.cl_statics)
- | AbstractStatics a ->
- begin match a.a_impl with
- | Some c ->
- let cf = PMap.find n c.cl_statics in
- FStatic(c,cf) (* is that right? *)
- | _ ->
- raise Not_found
- end
- | _ ->
- FAnon (PMap.find n a.a_fields))
- | TDynamic _ ->
- FDynamic n
- | TEnum _ | TMono _ | TAbstract _ | TFun _ ->
- raise Not_found
- | TLazy _ | TType _ ->
- assert false
- let quick_field_dynamic t s =
- try quick_field t s
- with Not_found -> FDynamic s
- let rec get_constructor build_type c =
- match c.cl_constructor, c.cl_super with
- | Some c, _ -> build_type c, c
- | None, None -> raise Not_found
- | None, Some (csup,cparams) ->
- let t, c = get_constructor build_type csup in
- apply_params csup.cl_params cparams t, c
- (* ======= Printing ======= *)
- let print_context() = ref []
- let rec s_type_kind t =
- let map tl = String.concat ", " (List.map s_type_kind tl) in
- match t with
- | TMono r ->
- begin match !r with
- | None -> "TMono (None)"
- | Some t -> "TMono (Some (" ^ (s_type_kind t) ^ "))"
- end
- | TEnum(en,tl) -> Printf.sprintf "TEnum(%s, [%s])" (s_type_path en.e_path) (map tl)
- | TInst(c,tl) -> Printf.sprintf "TInst(%s, [%s])" (s_type_path c.cl_path) (map tl)
- | TType(t,tl) -> Printf.sprintf "TType(%s, [%s])" (s_type_path t.t_path) (map tl)
- | TAbstract(a,tl) -> Printf.sprintf "TAbstract(%s, [%s])" (s_type_path a.a_path) (map tl)
- | TFun(tl,r) -> Printf.sprintf "TFun([%s], %s)" (String.concat ", " (List.map (fun (n,b,t) -> Printf.sprintf "%s%s:%s" (if b then "?" else "") n (s_type_kind t)) tl)) (s_type_kind r)
- | TAnon an -> "TAnon"
- | TDynamic t2 -> "TDynamic"
- | TLazy _ -> "TLazy"
- let rec s_type ctx t =
- match t with
- | TMono r ->
- (match !r with
- | None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
- | Some t -> s_type ctx t)
- | TEnum (e,tl) ->
- Ast.s_type_path e.e_path ^ s_type_params ctx tl
- | TInst (c,tl) ->
- (match c.cl_kind with
- | KExpr e -> Ast.s_expr e
- | _ -> Ast.s_type_path c.cl_path ^ s_type_params ctx tl)
- | TType (t,tl) ->
- Ast.s_type_path t.t_path ^ s_type_params ctx tl
- | TAbstract (a,tl) ->
- Ast.s_type_path a.a_path ^ s_type_params ctx tl
- | TFun ([],t) ->
- "Void -> " ^ s_fun ctx t false
- | TFun (l,t) ->
- String.concat " -> " (List.map (fun (s,b,t) ->
- (if b then "?" else "") ^ (if s = "" then "" else s ^ " : ") ^ s_fun ctx t true
- ) l) ^ " -> " ^ s_fun ctx t false
- | TAnon a ->
- let fl = PMap.fold (fun f acc -> ((if Meta.has Meta.Optional f.cf_meta then " ?" else " ") ^ f.cf_name ^ " : " ^ s_type ctx f.cf_type) :: acc) a.a_fields [] in
- "{" ^ (if not (is_closed a) then "+" else "") ^ String.concat "," fl ^ " }"
- | TDynamic t2 ->
- "Dynamic" ^ s_type_params ctx (if t == t2 then [] else [t2])
- | TLazy f ->
- s_type ctx (!f())
- and s_fun ctx t void =
- match t with
- | TFun _ ->
- "(" ^ s_type ctx t ^ ")"
- | TAbstract ({ a_path = ([],"Void") },[]) when void ->
- "(" ^ s_type ctx t ^ ")"
- | TMono r ->
- (match !r with
- | None -> s_type ctx t
- | Some t -> s_fun ctx t void)
- | TLazy f ->
- s_fun ctx (!f()) void
- | _ ->
- s_type ctx t
- and s_type_params ctx = function
- | [] -> ""
- | l -> "<" ^ String.concat ", " (List.map (s_type ctx) l) ^ ">"
- let s_access is_read = function
- | AccNormal -> "default"
- | AccNo -> "null"
- | AccNever -> "never"
- | AccResolve -> "resolve"
- | AccCall -> if is_read then "get" else "set"
- | AccInline -> "inline"
- | AccRequire (n,_) -> "require " ^ n
- let s_kind = function
- | Var { v_read = AccNormal; v_write = AccNormal } -> "var"
- | Var v -> "(" ^ s_access true v.v_read ^ "," ^ s_access false v.v_write ^ ")"
- | Method m ->
- match m with
- | MethNormal -> "method"
- | MethDynamic -> "dynamic method"
- | MethInline -> "inline method"
- | MethMacro -> "macro method"
- let s_expr_kind e =
- match e.eexpr with
- | TConst _ -> "Const"
- | TLocal _ -> "Local"
- | TArray (_,_) -> "Array"
- | TBinop (_,_,_) -> "Binop"
- | TEnumParameter (_,_,_) -> "EnumParameter"
- | TField (_,_) -> "Field"
- | TTypeExpr _ -> "TypeExpr"
- | TParenthesis _ -> "Parenthesis"
- | TObjectDecl _ -> "ObjectDecl"
- | TArrayDecl _ -> "ArrayDecl"
- | TCall (_,_) -> "Call"
- | TNew (_,_,_) -> "New"
- | TUnop (_,_,_) -> "Unop"
- | TFunction _ -> "Function"
- | TVar _ -> "Vars"
- | TBlock _ -> "Block"
- | TFor (_,_,_) -> "For"
- | TIf (_,_,_) -> "If"
- | TWhile (_,_,_) -> "While"
- | TSwitch (_,_,_) -> "Switch"
- | TTry (_,_) -> "Try"
- | TReturn _ -> "Return"
- | TBreak -> "Break"
- | TContinue -> "Continue"
- | TThrow _ -> "Throw"
- | TCast _ -> "Cast"
- | TMeta _ -> "Meta"
- let s_const = function
- | TInt i -> Int32.to_string i
- | TFloat s -> s
- | TString s -> Printf.sprintf "\"%s\"" (Ast.s_escape s)
- | TBool b -> if b then "true" else "false"
- | TNull -> "null"
- | TThis -> "this"
- | TSuper -> "super"
- let rec s_expr s_type e =
- let sprintf = Printf.sprintf in
- let slist f l = String.concat "," (List.map f l) in
- let loop = s_expr s_type in
- let s_var v = v.v_name ^ ":" ^ string_of_int v.v_id ^ if v.v_capture then "[c]" else "" in
- let str = (match e.eexpr with
- | TConst c ->
- "Const " ^ s_const c
- | TLocal v ->
- "Local " ^ s_var v
- | TArray (e1,e2) ->
- sprintf "%s[%s]" (loop e1) (loop e2)
- | TBinop (op,e1,e2) ->
- sprintf "(%s %s %s)" (loop e1) (s_binop op) (loop e2)
- | TEnumParameter (e1,_,i) ->
- sprintf "%s[%i]" (loop e1) i
- | TField (e,f) ->
- let fstr = (match f with
- | FStatic (c,f) -> "static(" ^ s_type_path c.cl_path ^ "." ^ f.cf_name ^ ")"
- | FInstance (c,_,f) -> "inst(" ^ s_type_path c.cl_path ^ "." ^ f.cf_name ^ " : " ^ s_type f.cf_type ^ ")"
- | FClosure (c,f) -> "closure(" ^ (match c with None -> f.cf_name | Some (c,_) -> s_type_path c.cl_path ^ "." ^ f.cf_name) ^ ")"
- | FAnon f -> "anon(" ^ f.cf_name ^ ")"
- | FEnum (en,f) -> "enum(" ^ s_type_path en.e_path ^ "." ^ f.ef_name ^ ")"
- | FDynamic f -> "dynamic(" ^ f ^ ")"
- ) in
- sprintf "%s.%s" (loop e) fstr
- | TTypeExpr m ->
- sprintf "TypeExpr %s" (s_type_path (t_path m))
- | TParenthesis e ->
- sprintf "Parenthesis %s" (loop e)
- | TObjectDecl fl ->
- sprintf "ObjectDecl {%s}" (slist (fun (f,e) -> sprintf "%s : %s" f (loop e)) fl)
- | TArrayDecl el ->
- sprintf "ArrayDecl [%s]" (slist loop el)
- | TCall (e,el) ->
- sprintf "Call %s(%s)" (loop e) (slist loop el)
- | TNew (c,pl,el) ->
- sprintf "New %s%s(%s)" (s_type_path c.cl_path) (match pl with [] -> "" | l -> sprintf "<%s>" (slist s_type l)) (slist loop el)
- | TUnop (op,f,e) ->
- (match f with
- | Prefix -> sprintf "(%s %s)" (s_unop op) (loop e)
- | Postfix -> sprintf "(%s %s)" (loop e) (s_unop op))
- | TFunction f ->
- let args = slist (fun (v,o) -> sprintf "%s : %s%s" (s_var v) (s_type v.v_type) (match o with None -> "" | Some c -> " = " ^ s_const c)) f.tf_args in
- sprintf "Function(%s) : %s = %s" args (s_type f.tf_type) (loop f.tf_expr)
- | TVar (v,eo) ->
- sprintf "Vars %s" (sprintf "%s : %s%s" (s_var v) (s_type v.v_type) (match eo with None -> "" | Some e -> " = " ^ loop e))
- | TBlock el ->
- sprintf "Block {\n%s}" (String.concat "" (List.map (fun e -> sprintf "%s;\n" (loop e)) el))
- | TFor (v,econd,e) ->
- sprintf "For (%s : %s in %s,%s)" (s_var v) (s_type v.v_type) (loop econd) (loop e)
- | TIf (e,e1,e2) ->
- sprintf "If (%s,%s%s)" (loop e) (loop e1) (match e2 with None -> "" | Some e -> "," ^ loop e)
- | TWhile (econd,e,flag) ->
- (match flag with
- | NormalWhile -> sprintf "While (%s,%s)" (loop econd) (loop e)
- | DoWhile -> sprintf "DoWhile (%s,%s)" (loop e) (loop econd))
- | TSwitch (e,cases,def) ->
- sprintf "Switch (%s,(%s)%s)" (loop e) (slist (fun (cl,e) -> sprintf "case %s: %s" (slist loop cl) (loop e)) cases) (match def with None -> "" | Some e -> "," ^ loop e)
- | TTry (e,cl) ->
- sprintf "Try %s(%s) " (loop e) (slist (fun (v,e) -> sprintf "catch( %s : %s ) %s" (s_var v) (s_type v.v_type) (loop e)) cl)
- | TReturn None ->
- "Return"
- | TReturn (Some e) ->
- sprintf "Return %s" (loop e)
- | TBreak ->
- "Break"
- | TContinue ->
- "Continue"
- | TThrow e ->
- "Throw " ^ (loop e)
- | TCast (e,t) ->
- sprintf "Cast %s%s" (match t with None -> "" | Some t -> s_type_path (t_path t) ^ ": ") (loop e)
- | TMeta ((n,el,_),e) ->
- sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
- ) in
- sprintf "(%s : %s)" str (s_type e.etype)
- and s_dt tabs tree =
- let s_type = s_type (print_context()) in
- tabs ^ match tree with
- | DTSwitch (st,cl,dto) ->
- "switch(" ^ (s_expr s_type st) ^ ") { \n" ^ tabs
- ^ (String.concat ("\n" ^ tabs) (List.map (fun (c,dt) ->
- "case " ^ (s_expr s_type c) ^ ":\n" ^ (s_dt (tabs ^ "\t") dt)
- ) cl))
- ^ (match dto with None -> "" | Some dt -> tabs ^ "default: " ^ (s_dt (tabs ^ "\t") dt))
- ^ "\n" ^ (if String.length tabs = 0 then "" else (String.sub tabs 0 (String.length tabs - 1))) ^ "}"
- | DTBind (bl, dt) -> "bind " ^ (String.concat "," (List.map (fun ((v,_),st) -> v.v_name ^ "(" ^ (string_of_int v.v_id) ^ ") =" ^ (s_expr s_type st)) bl)) ^ "\n" ^ (s_dt tabs dt)
- | DTGoto i ->
- "goto " ^ (string_of_int i)
- | DTExpr e -> s_expr s_type e
- | DTGuard (e,dt1,dt2) -> "if(" ^ (s_expr s_type e) ^ ") " ^ (s_dt tabs dt1) ^ (match dt2 with None -> "" | Some dt -> " else " ^ (s_dt tabs dt))
- let rec s_expr_pretty tabs s_type e =
- let sprintf = Printf.sprintf in
- let loop = s_expr_pretty tabs s_type in
- let slist f l = String.concat "," (List.map f l) in
- match e.eexpr with
- | TConst c -> s_const c
- | TLocal v -> v.v_name
- | TArray (e1,e2) -> sprintf "%s[%s]" (loop e1) (loop e2)
- | TBinop (op,e1,e2) -> sprintf "%s %s %s" (loop e1) (s_binop op) (loop e2)
- | TEnumParameter (e1,_,i) -> sprintf "%s[%i]" (loop e1) i
- | TField (e1,s) -> sprintf "%s.%s" (loop e1) (field_name s)
- | TTypeExpr mt -> (s_type_path (t_path mt))
- | TParenthesis e1 -> sprintf "(%s)" (loop e1)
- | TObjectDecl fl -> sprintf "{%s}" (slist (fun (f,e) -> sprintf "%s : %s" f (loop e)) fl)
- | TArrayDecl el -> sprintf "[%s]" (slist loop el)
- | TCall (e1,el) -> sprintf "%s(%s)" (loop e1) (slist loop el)
- | TNew (c,pl,el) ->
- sprintf "new %s(%s)" (s_type_path c.cl_path) (slist loop el)
- | TUnop (op,f,e) ->
- (match f with
- | Prefix -> sprintf "%s %s" (s_unop op) (loop e)
- | Postfix -> sprintf "%s %s" (loop e) (s_unop op))
- | TFunction f ->
- let args = slist (fun (v,o) -> sprintf "%s:%s%s" v.v_name (s_type v.v_type) (match o with None -> "" | Some c -> " = " ^ s_const c)) f.tf_args in
- sprintf "function(%s) = %s" args (loop f.tf_expr)
- | TVar (v,eo) ->
- sprintf "var %s" (sprintf "%s%s" v.v_name (match eo with None -> "" | Some e -> " = " ^ loop e))
- | TBlock el ->
- let ntabs = tabs ^ "\t" in
- let s = sprintf "{\n%s" (String.concat "" (List.map (fun e -> sprintf "%s%s;\n" ntabs (s_expr_pretty ntabs s_type e)) el)) in
- s ^ tabs ^ "}"
- | TFor (v,econd,e) ->
- sprintf "for (%s in %s) %s" v.v_name (loop econd) (loop e)
- | TIf (e,e1,e2) ->
- sprintf "if (%s)%s%s" (loop e) (loop e1) (match e2 with None -> "" | Some e -> " else " ^ loop e)
- | TWhile (econd,e,flag) ->
- (match flag with
- | NormalWhile -> sprintf "while (%s) %s" (loop econd) (loop e)
- | DoWhile -> sprintf "do (%s) while(%s)" (loop e) (loop econd))
- | TSwitch (e,cases,def) ->
- let ntabs = tabs ^ "\t" in
- let s = sprintf "switch (%s) {\n%s%s" (loop e) (slist (fun (cl,e) -> sprintf "%scase %s: %s\n" ntabs (slist loop cl) (s_expr_pretty ntabs s_type e)) cases) (match def with None -> "" | Some e -> ntabs ^ "default: " ^ (s_expr_pretty ntabs s_type e) ^ "\n") in
- s ^ tabs ^ "}"
- | TTry (e,cl) ->
- sprintf "try %s%s" (loop e) (slist (fun (v,e) -> sprintf "catch( %s : %s ) %s" v.v_name (s_type v.v_type) (loop e)) cl)
- | TReturn None ->
- "return"
- | TReturn (Some e) ->
- sprintf "return %s" (loop e)
- | TBreak ->
- "break"
- | TContinue ->
- "continue"
- | TThrow e ->
- "throw " ^ (loop e)
- | TCast (e,None) ->
- sprintf "cast %s" (loop e)
- | TCast (e,Some mt) ->
- sprintf "cast (%s,%s)" (loop e) (s_type_path (t_path mt))
- | TMeta ((n,el,_),e) ->
- sprintf "@%s%s %s" (Meta.to_string n) (match el with [] -> "" | _ -> "(" ^ (String.concat ", " (List.map Ast.s_expr el)) ^ ")") (loop e)
- let rec s_expr_ast print_var_ids tabs s_type e =
- let sprintf = Printf.sprintf in
- let loop ?(extra_tabs="") = s_expr_ast print_var_ids (tabs ^ "\t" ^ extra_tabs) s_type in
- let tag_args tabs sl = match sl with
- | [] -> ""
- | [s] when not (String.contains s '\n') -> " " ^ s
- | _ ->
- let tabs = "\n" ^ tabs ^ "\t" in
- tabs ^ (String.concat tabs sl)
- in
- let tag s ?(t=None) ?(extra_tabs="") sl =
- let st = match t with
- | None -> s_type e.etype
- | Some t -> s_type t
- in
- sprintf "[%s:%s]%s" s st (tag_args (tabs ^ extra_tabs) sl)
- in
- let var_id v = if print_var_ids then v.v_id else 0 in
- let const c = sprintf "[Const %s:%s]" (s_const c) (s_type e.etype) in
- let local v = sprintf "[Local %s(%i):%s]" v.v_name (var_id v) (s_type v.v_type) in
- let var v sl = sprintf "[Var %s(%i):%s]%s" v.v_name (var_id v) (s_type v.v_type) (tag_args tabs sl) in
- let module_type mt = sprintf "[TypeExpr %s:%s]" (s_type_path (t_path mt)) (s_type e.etype) in
- match e.eexpr with
- | TConst c -> const c
- | TLocal v -> local v
- | TArray (e1,e2) -> tag "Array" [loop e1; loop e2]
- | TBinop (op,e1,e2) -> tag "Binop" [loop e1; s_binop op; loop e2]
- | TUnop (op,flag,e1) -> tag "Unop" [s_unop op; if flag = Postfix then "Postfix" else "Prefix"; loop e1]
- | TEnumParameter (e1,ef,i) -> tag "EnumParameter" [loop e1; ef.ef_name; string_of_int i]
- | TField (e1,fa) ->
- let sfa = match fa with
- | FInstance(c,tl,cf) -> tag "FInstance" ~extra_tabs:"\t" [s_type (TInst(c,tl)); cf.cf_name]
- | FStatic(c,cf) -> tag "FStatic" ~extra_tabs:"\t" [s_type_path c.cl_path; cf.cf_name]
- | FClosure(co,cf) -> tag "FClosure" ~extra_tabs:"\t" [(match co with None -> "None" | Some (c,tl) -> s_type (TInst(c,tl))); cf.cf_name]
- | FAnon cf -> tag "FAnon" ~extra_tabs:"\t" [cf.cf_name]
- | FDynamic s -> tag "FDynamic" ~extra_tabs:"\t" [s]
- | FEnum(en,ef) -> tag "FEnum" ~extra_tabs:"\t" [s_type_path en.e_path; ef.ef_name]
- in
- tag "Field" [loop e1; sfa]
- | TTypeExpr mt -> module_type mt
- | TParenthesis e1 -> tag "Parenthesis" [loop e1]
- | TObjectDecl fl -> tag "ObjectDecl" (List.map (fun (s,e) -> sprintf "%s: %s" s (loop e)) fl)
- | TArrayDecl el -> tag "ArrayDecl" (List.map loop el)
- | TCall (e1,el) -> tag "Call" (loop e1 :: (List.map loop el))
- | TNew (c,tl,el) -> tag "New" ((s_type (TInst(c,tl))) :: (List.map loop el))
- | TFunction f ->
- let arg (v,cto) =
- tag "Arg" ~t:(Some v.v_type) ~extra_tabs:"\t" (match cto with None -> [local v] | Some ct -> [local v;const ct])
- in
- tag "Function" ((List.map arg f.tf_args) @ [loop f.tf_expr])
- | TVar (v,eo) -> var v (match eo with None -> [] | Some e -> [loop e])
- | TBlock el -> tag "Block" (List.map loop el)
- | TIf (e,e1,e2) -> tag "If" (loop e :: (Printf.sprintf "[Then:%s] %s" (s_type e1.etype) (loop e1)) :: (match e2 with None -> [] | Some e -> [Printf.sprintf "[Else:%s] %s" (s_type e.etype) (loop e)]))
- | TCast (e1,None) -> tag "Cast" [loop e1]
- | TCast (e1,Some mt) -> tag "Cast" [loop e1; module_type mt]
- | TThrow e1 -> tag "Throw" [loop e1]
- | TBreak -> tag "Break" []
- | TContinue -> tag "Continue" []
- | TReturn None -> tag "Return" []
- | TReturn (Some e1) -> tag "Return" [loop e1]
- | TWhile (e1,e2,NormalWhile) -> tag "While" [loop e1; loop e2]
- | TWhile (e1,e2,DoWhile) -> tag "Do" [loop e1; loop e2]
- | TFor (v,e1,e2) -> tag "For" [local v; loop e1; loop e2]
- | TTry (e1,catches) ->
- let sl = List.map (fun (v,e) ->
- sprintf "Catch %s%s" (local v) (tag_args (tabs ^ "\t") [loop ~extra_tabs:"\t" e]);
- ) catches in
- tag "Try" ((loop e1) :: sl)
- | TSwitch (e1,cases,eo) ->
- let sl = List.map (fun (el,e) ->
- tag "Case" ~t:(Some e.etype) ~extra_tabs:"\t" ((List.map loop el) @ [loop ~extra_tabs:"\t" e])
- ) cases in
- let sl = match eo with
- | None -> sl
- | Some e -> sl @ [tag "Default" ~t:(Some e.etype) ~extra_tabs:"\t" [loop ~extra_tabs:"\t" e]]
- in
- tag "Switch" ((loop e1) :: sl)
- | TMeta ((m,el,_),e1) ->
- let s = Meta.to_string m in
- let s = match el with
- | [] -> s
- | _ -> sprintf "%s(%s)" s (String.concat ", " (List.map Ast.s_expr el))
- in
- tag "Meta" [s; loop e1]
- let s_types ?(sep = ", ") tl =
- let pctx = print_context() in
- String.concat sep (List.map (s_type pctx) tl)
- let s_class_kind = function
- | KNormal ->
- "KNormal"
- | KTypeParameter tl ->
- Printf.sprintf "KTypeParameter [%s]" (s_types tl)
- | KExtension(c,tl) ->
- Printf.sprintf "KExtension %s<%s>" (s_type_path c.cl_path) (s_types tl)
- | KExpr _ ->
- "KExpr"
- | KGeneric ->
- "KGeneric"
- | KGenericInstance(c,tl) ->
- Printf.sprintf "KGenericInstance %s<%s>" (s_type_path c.cl_path) (s_types tl)
- | KMacroType ->
- "KMacroType"
- | KGenericBuild _ ->
- "KGenericBuild"
- | KAbstractImpl a ->
- Printf.sprintf "KAbstractImpl %s" (s_type_path a.a_path)
- (* ======= Unification ======= *)
- let rec link e a b =
- (* tell if setting a == b will create a type-loop *)
- let rec loop t =
- if t == a then
- true
- else match t with
- | TMono t -> (match !t with None -> false | Some t -> loop t)
- | TEnum (_,tl) -> List.exists loop tl
- | TInst (_,tl) | TType (_,tl) | TAbstract (_,tl) -> List.exists loop tl
- | TFun (tl,t) -> List.exists (fun (_,_,t) -> loop t) tl || loop t
- | TDynamic t2 ->
- if t == t2 then
- false
- else
- loop t2
- | TLazy f ->
- loop (!f())
- | TAnon a ->
- try
- PMap.iter (fun _ f -> if loop f.cf_type then raise Exit) a.a_fields;
- false
- with
- Exit -> true
- in
- (* tell is already a ~= b *)
- if loop b then
- (follow b) == a
- else if b == t_dynamic then
- true
- else begin
- e := Some b;
- true
- end
- let rec fast_eq a b =
- if a == b then
- true
- else match a , b with
- | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
- List.for_all2 (fun (_,_,t1) (_,_,t2) -> fast_eq t1 t2) l1 l2 && fast_eq r1 r2
- | TType (t1,l1), TType (t2,l2) ->
- t1 == t2 && List.for_all2 fast_eq l1 l2
- | TEnum (e1,l1), TEnum (e2,l2) ->
- e1 == e2 && List.for_all2 fast_eq l1 l2
- | TInst (c1,l1), TInst (c2,l2) ->
- c1 == c2 && List.for_all2 fast_eq l1 l2
- | TAbstract (a1,l1), TAbstract (a2,l2) ->
- a1 == a2 && List.for_all2 fast_eq l1 l2
- | _ , _ ->
- false
- let rec fast_eq_mono ml a b =
- if a == b then
- true
- else match a , b with
- | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
- List.for_all2 (fun (_,_,t1) (_,_,t2) -> fast_eq_mono ml t1 t2) l1 l2 && fast_eq_mono ml r1 r2
- | TType (t1,l1), TType (t2,l2) ->
- t1 == t2 && List.for_all2 (fast_eq_mono ml) l1 l2
- | TEnum (e1,l1), TEnum (e2,l2) ->
- e1 == e2 && List.for_all2 (fast_eq_mono ml) l1 l2
- | TInst (c1,l1), TInst (c2,l2) ->
- c1 == c2 && List.for_all2 (fast_eq_mono ml) l1 l2
- | TAbstract (a1,l1), TAbstract (a2,l2) ->
- a1 == a2 && List.for_all2 (fast_eq_mono ml) l1 l2
- | TMono _, _ ->
- List.memq a ml
- | _ , _ ->
- false
- (* perform unification with subtyping.
- the first type is always the most down in the class hierarchy
- it's also the one that is pointed by the position.
- It's actually a typecheck of A :> B where some mutations can happen *)
- type unify_error =
- | Cannot_unify of t * t
- | Invalid_field_type of string
- | Has_no_field of t * string
- | Has_no_runtime_field of t * string
- | Has_extra_field of t * string
- | Invalid_kind of string * field_kind * field_kind
- | Invalid_visibility of string
- | Not_matching_optional of string
- | Cant_force_optional
- | Invariant_parameter of t * t
- | Constraint_failure of string
- | Missing_overload of tclass_field * t
- | Unify_custom of string
- exception Unify_error of unify_error list
- let cannot_unify a b = Cannot_unify (a,b)
- let invalid_field n = Invalid_field_type n
- let invalid_kind n a b = Invalid_kind (n,a,b)
- let invalid_visibility n = Invalid_visibility n
- let has_no_field t n = Has_no_field (t,n)
- let has_extra_field t n = Has_extra_field (t,n)
- let error l = raise (Unify_error l)
- let has_meta m ml = List.exists (fun (m2,_,_) -> m = m2) ml
- let get_meta m ml = List.find (fun (m2,_,_) -> m = m2) ml
- let no_meta = []
- (*
- we can restrict access as soon as both are runtime-compatible
- *)
- let unify_access a1 a2 =
- a1 = a2 || match a1, a2 with
- | _, AccNo | _, AccNever -> true
- | AccInline, AccNormal -> true
- | _ -> false
- let direct_access = function
- | AccNo | AccNever | AccNormal | AccInline | AccRequire _ -> true
- | AccResolve | AccCall -> false
- let unify_kind k1 k2 =
- k1 = k2 || match k1, k2 with
- | Var v1, Var v2 -> unify_access v1.v_read v2.v_read && unify_access v1.v_write v2.v_write
- | Var v, Method m ->
- (match v.v_read, v.v_write, m with
- | AccNormal, _, MethNormal -> true
- | AccNormal, AccNormal, MethDynamic -> true
- | _ -> false)
- | Method m, Var v ->
- (match m with
- | MethDynamic -> direct_access v.v_read && direct_access v.v_write
- | MethMacro -> false
- | MethNormal | MethInline ->
- match v.v_read,v.v_write with
- | AccNormal,(AccNo | AccNever) -> true
- | _ -> false)
- | Method m1, Method m2 ->
- match m1,m2 with
- | MethInline, MethNormal
- | MethDynamic, MethNormal -> true
- | _ -> false
- let eq_stack = ref []
- type eq_kind =
- | EqStrict
- | EqCoreType
- | EqRightDynamic
- | EqBothDynamic
- | EqDoNotFollowNull (* like EqStrict, but does not follow Null<T> *)
- let rec type_eq param a b =
- let can_follow t = match param with
- | EqCoreType -> false
- | EqDoNotFollowNull -> not (is_null t)
- | _ -> true
- in
- if a == b then
- ()
- else match a , b with
- | TLazy f , _ -> type_eq param (!f()) b
- | _ , TLazy f -> type_eq param a (!f())
- | TMono t , _ ->
- (match !t with
- | None -> if param = EqCoreType || not (link t a b) then error [cannot_unify a b]
- | Some t -> type_eq param t b)
- | _ , TMono t ->
- (match !t with
- | None -> if param = EqCoreType || not (link t b a) then error [cannot_unify a b]
- | Some t -> type_eq param a t)
- | TType (t1,tl1), TType (t2,tl2) when (t1 == t2 || (param = EqCoreType && t1.t_path = t2.t_path)) && List.length tl1 = List.length tl2 ->
- List.iter2 (type_eq param) tl1 tl2
- | TType (t,tl) , _ when can_follow a ->
- type_eq param (apply_params t.t_params tl t.t_type) b
- | _ , TType (t,tl) when can_follow b ->
- if List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!eq_stack) then
- ()
- else begin
- eq_stack := (a,b) :: !eq_stack;
- try
- type_eq param a (apply_params t.t_params tl t.t_type);
- eq_stack := List.tl !eq_stack;
- with
- Unify_error l ->
- eq_stack := List.tl !eq_stack;
- error (cannot_unify a b :: l)
- end
- | TEnum (e1,tl1) , TEnum (e2,tl2) ->
- if e1 != e2 && not (param = EqCoreType && e1.e_path = e2.e_path) then error [cannot_unify a b];
- List.iter2 (type_eq param) tl1 tl2
- | TInst (c1,tl1) , TInst (c2,tl2) ->
- if c1 != c2 && not (param = EqCoreType && c1.cl_path = c2.cl_path) && (match c1.cl_kind, c2.cl_kind with KExpr _, KExpr _ -> false | _ -> true) then error [cannot_unify a b];
- List.iter2 (type_eq param) tl1 tl2
- | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
- (try
- type_eq param r1 r2;
- List.iter2 (fun (n,o1,t1) (_,o2,t2) ->
- if o1 <> o2 then error [Not_matching_optional n];
- type_eq param t1 t2
- ) l1 l2
- with
- Unify_error l -> error (cannot_unify a b :: l))
- | TDynamic a , TDynamic b ->
- type_eq param a b
- | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
- if a1 != a2 && not (param = EqCoreType && a1.a_path = a2.a_path) then error [cannot_unify a b];
- List.iter2 (type_eq param) tl1 tl2
- | TAnon a1, TAnon a2 ->
- (try
- PMap.iter (fun n f1 ->
- try
- let f2 = PMap.find n a2.a_fields in
- if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then error [invalid_kind n f1.cf_kind f2.cf_kind];
- try
- type_eq param f1.cf_type f2.cf_type
- with
- Unify_error l -> error (invalid_field n :: l)
- with
- Not_found ->
- if is_closed a2 then error [has_no_field b n];
- if not (link (ref None) b f1.cf_type) then error [cannot_unify a b];
- a2.a_fields <- PMap.add n f1 a2.a_fields
- ) a1.a_fields;
- PMap.iter (fun n f2 ->
- if not (PMap.mem n a1.a_fields) then begin
- if is_closed a1 then error [has_no_field a n];
- if not (link (ref None) a f2.cf_type) then error [cannot_unify a b];
- a1.a_fields <- PMap.add n f2 a1.a_fields
- end;
- ) a2.a_fields;
- with
- Unify_error l -> error (cannot_unify a b :: l))
- | _ , _ ->
- if b == t_dynamic && (param = EqRightDynamic || param = EqBothDynamic) then
- ()
- else if a == t_dynamic && param = EqBothDynamic then
- ()
- else
- error [cannot_unify a b]
- let type_iseq a b =
- try
- type_eq EqStrict a b;
- true
- with
- Unify_error _ -> false
- let type_iseq_strict a b =
- try
- type_eq EqDoNotFollowNull a b;
- true
- with Unify_error _ ->
- false
- let unify_stack = ref []
- let abstract_cast_stack = ref []
- let unify_new_monos = ref []
- let rec unify a b =
- if a == b then
- ()
- else match a, b with
- | TLazy f , _ -> unify (!f()) b
- | _ , TLazy f -> unify a (!f())
- | TMono t , _ ->
- (match !t with
- | None -> if not (link t a b) then error [cannot_unify a b]
- | Some t -> unify t b)
- | _ , TMono t ->
- (match !t with
- | None -> if not (link t b a) then error [cannot_unify a b]
- | Some t -> unify a t)
- | TType (t,tl) , _ ->
- if not (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!unify_stack)) then begin
- try
- unify_stack := (a,b) :: !unify_stack;
- unify (apply_params t.t_params tl t.t_type) b;
- unify_stack := List.tl !unify_stack;
- with
- Unify_error l ->
- unify_stack := List.tl !unify_stack;
- error (cannot_unify a b :: l)
- end
- | _ , TType (t,tl) ->
- if not (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!unify_stack)) then begin
- try
- unify_stack := (a,b) :: !unify_stack;
- unify a (apply_params t.t_params tl t.t_type);
- unify_stack := List.tl !unify_stack;
- with
- Unify_error l ->
- unify_stack := List.tl !unify_stack;
- error (cannot_unify a b :: l)
- end
- | TEnum (ea,tl1) , TEnum (eb,tl2) ->
- if ea != eb then error [cannot_unify a b];
- unify_type_params a b tl1 tl2
- | TAbstract (a1,tl1) , TAbstract (a2,tl2) when a1 == a2 ->
- begin try
- unify_type_params a b tl1 tl2
- with Unify_error _ as err ->
- (* the type could still have a from/to relation to itself (issue #3494) *)
- begin try
- unify_abstracts a b a1 tl1 a2 tl2
- with Unify_error _ ->
- raise err
- end
- end
- | TAbstract ({a_path=[],"Void"},_) , _
- | _ , TAbstract ({a_path=[],"Void"},_) ->
- error [cannot_unify a b]
- | TAbstract (a1,tl1) , TAbstract (a2,tl2) ->
- unify_abstracts a b a1 tl1 a2 tl2
- | TInst (c1,tl1) , TInst (c2,tl2) ->
- let rec loop c tl =
- if c == c2 then begin
- unify_type_params a b tl tl2;
- true
- end else (match c.cl_super with
- | None -> false
- | Some (cs,tls) ->
- loop cs (List.map (apply_params c.cl_params tl) tls)
- ) || List.exists (fun (cs,tls) ->
- loop cs (List.map (apply_params c.cl_params tl) tls)
- ) c.cl_implements
- || (match c.cl_kind with
- | KTypeParameter pl -> List.exists (fun t -> match follow t with TInst (cs,tls) -> loop cs (List.map (apply_params c.cl_params tl) tls) | _ -> false) pl
- | _ -> false)
- in
- if not (loop c1 tl1) then error [cannot_unify a b]
- | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 ->
- let i = ref 0 in
- (try
- (match r2 with
- | TAbstract ({a_path=[],"Void"},_) -> incr i
- | _ -> unify r1 r2; incr i);
- List.iter2 (fun (_,o1,t1) (_,o2,t2) ->
- if o1 && not o2 then error [Cant_force_optional];
- unify t1 t2;
- incr i
- ) l2 l1 (* contravariance *)
- with
- Unify_error l ->
- let msg = if !i = 0 then "Cannot unify return types" else "Cannot unify argument " ^ (string_of_int !i) in
- error (cannot_unify a b :: Unify_custom msg :: l))
- | TInst (c,tl) , TAnon an ->
- if PMap.is_empty an.a_fields then (match c.cl_kind with
- | KTypeParameter pl ->
- (* one of the constraints must unify with { } *)
- if not (List.exists (fun t -> match follow t with TInst _ | TAnon _ -> true | _ -> false) pl) then error [cannot_unify a b]
- | _ -> ());
- (try
- PMap.iter (fun n f2 ->
- (*
- introducing monomorphs while unifying might create infinite loops - see #2315
- let's store these monomorphs and make sure we reach a fixed point
- *)
- let monos = ref [] in
- let make_type f =
- match f.cf_params with
- | [] -> f.cf_type
- | l ->
- let ml = List.map (fun _ -> mk_mono()) l in
- monos := ml;
- apply_params f.cf_params ml f.cf_type
- in
- let _, ft, f1 = (try raw_class_field make_type c tl n with Not_found -> error [has_no_field a n]) in
- let ft = apply_params c.cl_params tl ft in
- if not (unify_kind f1.cf_kind f2.cf_kind) then error [invalid_kind n f1.cf_kind f2.cf_kind];
- if f2.cf_public && not f1.cf_public then error [invalid_visibility n];
- let old_monos = !unify_new_monos in
- unify_new_monos := !monos @ !unify_new_monos;
- if not (List.exists (fun (a2,b2) -> fast_eq b2 f2.cf_type && fast_eq_mono !unify_new_monos ft a2) (!unify_stack)) then begin
- unify_stack := (ft,f2.cf_type) :: !unify_stack;
- (try
- unify_with_access ft f2
- with
- Unify_error l ->
- unify_new_monos := old_monos;
- unify_stack := List.tl !unify_stack;
- error (invalid_field n :: l));
- unify_stack := List.tl !unify_stack;
- end;
- unify_new_monos := old_monos;
- List.iter (fun f2o ->
- if not (List.exists (fun f1o -> type_iseq f1o.cf_type f2o.cf_type) (f1 :: f1.cf_overloads))
- then error [Missing_overload (f1, f2o.cf_type)]
- ) f2.cf_overloads;
- (* we mark the field as :?used because it might be used through the structure *)
- if not (Meta.has Meta.MaybeUsed f1.cf_meta) then f1.cf_meta <- (Meta.MaybeUsed,[],f1.cf_pos) :: f1.cf_meta;
- (match f1.cf_kind with
- | Method MethInline ->
- if (c.cl_extern || Meta.has Meta.Extern f1.cf_meta) && not (Meta.has Meta.Runtime f1.cf_meta) then error [Has_no_runtime_field (a,n)];
- | _ -> ());
- ) an.a_fields;
- (match !(an.a_status) with
- | Opened -> an.a_status := Closed;
- | Statics _ | EnumStatics _ | AbstractStatics _ -> error []
- | Closed | Extend _ | Const -> ())
- with
- Unify_error l -> error (cannot_unify a b :: l))
- | TAnon a1, TAnon a2 ->
- unify_anons a b a1 a2
- | TAnon an, TAbstract ({ a_path = [],"Class" },[pt]) ->
- (match !(an.a_status) with
- | Statics cl -> unify (TInst (cl,List.map (fun _ -> mk_mono()) cl.cl_params)) pt
- | _ -> error [cannot_unify a b])
- | TAnon an, TAbstract ({ a_path = [],"Enum" },[pt]) ->
- (match !(an.a_status) with
- | EnumStatics e -> unify (TEnum (e,List.map (fun _ -> mk_mono()) e.e_params)) pt
- | _ -> error [cannot_unify a b])
- | TEnum _, TAbstract ({ a_path = [],"EnumValue" },[]) ->
- ()
- | TEnum(en,_), TAbstract ({ a_path = ["haxe"],"FlatEnum" },[]) when Meta.has Meta.FlatEnum en.e_meta ->
- ()
- | TFun _, TAbstract ({ a_path = ["haxe"],"Function" },[]) ->
- ()
- | TDynamic t , _ ->
- if t == a then
- ()
- else (match b with
- | TDynamic t2 ->
- if t2 != b then
- (try
- type_eq EqRightDynamic t t2
- with
- Unify_error l -> error (cannot_unify a b :: l));
- | TAbstract(bb,tl) when (List.exists (unify_from bb tl a b) bb.a_from) ->
- ()
- | _ ->
- error [cannot_unify a b])
- | _ , TDynamic t ->
- if t == b then
- ()
- else (match a with
- | TDynamic t2 ->
- if t2 != a then
- (try
- type_eq EqRightDynamic t t2
- with
- Unify_error l -> error (cannot_unify a b :: l));
- | TAnon an ->
- (try
- (match !(an.a_status) with
- | Statics _ | EnumStatics _ -> error []
- | Opened -> an.a_status := Closed
- | _ -> ());
- PMap.iter (fun _ f ->
- try
- type_eq EqStrict (field_type f) t
- with Unify_error l ->
- error (invalid_field f.cf_name :: l)
- ) an.a_fields
- with Unify_error l ->
- error (cannot_unify a b :: l))
- | TAbstract(aa,tl) when (List.exists (unify_to aa tl b) aa.a_to) ->
- ()
- | _ ->
- error [cannot_unify a b])
- | TAbstract (aa,tl), _ ->
- if not (List.exists (unify_to aa tl b) aa.a_to) then error [cannot_unify a b];
- | TInst ({ cl_kind = KTypeParameter ctl } as c,pl), TAbstract (bb,tl) ->
- (* one of the constraints must satisfy the abstract *)
- if not (List.exists (fun t ->
- let t = apply_params c.cl_params pl t in
- try unify t b; true with Unify_error _ -> false
- ) ctl) && not (List.exists (unify_from bb tl a b) bb.a_from) then error [cannot_unify a b];
- | _, TAbstract (bb,tl) ->
- if not (List.exists (unify_from bb tl a b) bb.a_from) then error [cannot_unify a b]
- | _ , _ ->
- error [cannot_unify a b]
- and unify_abstracts a b a1 tl1 a2 tl2 =
- let f1 = unify_to a1 tl1 b in
- let f2 = unify_from a2 tl2 a b in
- if (List.exists (f1 ~allow_transitive_cast:false) a1.a_to)
- || (List.exists (f2 ~allow_transitive_cast:false) a2.a_from)
- || (((Meta.has Meta.CoreType a1.a_meta) || (Meta.has Meta.CoreType a2.a_meta))
- && ((List.exists f1 a1.a_to) || (List.exists f2 a2.a_from))) then
- ()
- else
- error [cannot_unify a b]
- and unify_anons a b a1 a2 =
- (try
- PMap.iter (fun n f2 ->
- try
- let f1 = PMap.find n a1.a_fields in
- if not (unify_kind f1.cf_kind f2.cf_kind) then
- (match !(a1.a_status), f1.cf_kind, f2.cf_kind with
- | Opened, Var { v_read = AccNormal; v_write = AccNo }, Var { v_read = AccNormal; v_write = AccNormal } ->
- f1.cf_kind <- f2.cf_kind;
- | _ -> error [invalid_kind n f1.cf_kind f2.cf_kind]);
- if f2.cf_public && not f1.cf_public then error [invalid_visibility n];
- try
- unify_with_access f1.cf_type f2;
- (match !(a1.a_status) with
- | Statics c when not (Meta.has Meta.MaybeUsed f1.cf_meta) -> f1.cf_meta <- (Meta.MaybeUsed,[],f1.cf_pos) :: f1.cf_meta
- | _ -> ());
- with
- Unify_error l -> error (invalid_field n :: l)
- with
- Not_found ->
- match !(a1.a_status) with
- | Opened ->
- if not (link (ref None) a f2.cf_type) then error [];
- a1.a_fields <- PMap.add n f2 a1.a_fields
- | Const when Meta.has Meta.Optional f2.cf_meta ->
- ()
- | _ ->
- error [has_no_field a n];
- ) a2.a_fields;
- (match !(a1.a_status) with
- | Const when not (PMap.is_empty a2.a_fields) ->
- PMap.iter (fun n _ -> if not (PMap.mem n a2.a_fields) then error [has_extra_field a n]) a1.a_fields;
- | Opened ->
- a1.a_status := Closed
- | _ -> ());
- (match !(a2.a_status) with
- | Statics c -> (match !(a1.a_status) with Statics c2 when c == c2 -> () | _ -> error [])
- | EnumStatics e -> (match !(a1.a_status) with EnumStatics e2 when e == e2 -> () | _ -> error [])
- | AbstractStatics a -> (match !(a1.a_status) with AbstractStatics a2 when a == a2 -> () | _ -> error [])
- | Opened -> a2.a_status := Closed
- | Const | Extend _ | Closed -> ())
- with
- Unify_error l -> error (cannot_unify a b :: l))
- and unify_from ab tl a b ?(allow_transitive_cast=true) t =
- if (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
- abstract_cast_stack := (a,b) :: !abstract_cast_stack;
- let t = apply_params ab.a_params tl t in
- let unify_func = if allow_transitive_cast then unify else type_eq EqStrict in
- let b = try
- unify_func a t;
- true
- with Unify_error _ ->
- false
- in
- abstract_cast_stack := List.tl !abstract_cast_stack;
- b
- end
- and unify_to ab tl b ?(allow_transitive_cast=true) t =
- let t = apply_params ab.a_params tl t in
- let unify_func = if allow_transitive_cast then unify else type_eq EqStrict in
- try
- unify_func t b;
- true
- with Unify_error _ ->
- false
- and unify_from_field ab tl a b ?(allow_transitive_cast=true) (t,cf) =
- if (List.exists (fun (a2,b2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
- abstract_cast_stack := (a,b) :: !abstract_cast_stack;
- let unify_func = if allow_transitive_cast then unify else type_eq EqStrict in
- let b = try
- begin match follow cf.cf_type with
- | TFun(_,r) ->
- let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
- let map t = apply_params ab.a_params tl (apply_params cf.cf_params monos t) in
- unify_func a (map t);
- List.iter2 (fun m (name,t) -> match follow t with
- | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
- List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> unify m (map tc) ) constr
- | _ -> ()
- ) monos cf.cf_params;
- unify_func (map r) b;
- | _ -> assert false
- end;
- true
- with Unify_error _ -> false
- in
- abstract_cast_stack := List.tl !abstract_cast_stack;
- b
- end
- and unify_to_field ab tl b ?(allow_transitive_cast=true) (t,cf) =
- let a = TAbstract(ab,tl) in
- if (List.exists (fun (b2,a2) -> fast_eq a a2 && fast_eq b b2) (!abstract_cast_stack)) then false else begin
- abstract_cast_stack := (b,a) :: !abstract_cast_stack;
- let unify_func = if allow_transitive_cast then unify else type_eq EqStrict in
- let r = try
- begin match follow cf.cf_type with
- | TFun((_,_,ta) :: _,_) ->
- let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
- let map t = apply_params ab.a_params tl (apply_params cf.cf_params monos t) in
- let athis = map ab.a_this in
- (* we cannot allow implicit casts when the this type is not completely known yet *)
- (* if has_mono athis then raise (Unify_error []); *)
- with_variance (type_eq EqStrict) athis (map ta);
- (* immediate constraints checking is ok here because we know there are no monomorphs *)
- List.iter2 (fun m (name,t) -> match follow t with
- | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
- List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> unify m (map tc) ) constr
- | _ -> ()
- ) monos cf.cf_params;
- unify_func (map t) b;
- | _ -> assert false
- end;
- true
- with Unify_error _ -> false
- in
- abstract_cast_stack := List.tl !abstract_cast_stack;
- r
- end
- and unify_with_variance f t1 t2 =
- let allows_variance_to t tf = type_iseq tf t in
- match follow t1,follow t2 with
- | TInst(c1,tl1),TInst(c2,tl2) when c1 == c2 ->
- List.iter2 f tl1 tl2
- | TEnum(en1,tl1),TEnum(en2,tl2) when en1 == en2 ->
- List.iter2 f tl1 tl2
- | TAbstract(a1,tl1),TAbstract(a2,tl2) when a1 == a2 && Meta.has Meta.CoreType a1.a_meta ->
- List.iter2 f tl1 tl2
- | TAbstract(a1,pl1),TAbstract(a2,pl2) ->
- if (Meta.has Meta.CoreType a1.a_meta) && (Meta.has Meta.CoreType a2.a_meta) then begin
- let ta1 = apply_params a1.a_params pl1 a1.a_this in
- let ta2 = apply_params a2.a_params pl2 a2.a_this in
- type_eq EqStrict ta1 ta2;
- end;
- if not (List.exists (allows_variance_to t2) a1.a_to) && not (List.exists (allows_variance_to t1) a2.a_from) then
- error [cannot_unify t1 t2]
- | TAbstract(a,pl),t ->
- type_eq EqBothDynamic (apply_params a.a_params pl a.a_this) t;
- if not (List.exists (fun t2 -> allows_variance_to t (apply_params a.a_params pl t2)) a.a_to) then error [cannot_unify t1 t2]
- | t,TAbstract(a,pl) ->
- type_eq EqBothDynamic t (apply_params a.a_params pl a.a_this);
- if not (List.exists (fun t2 -> allows_variance_to t (apply_params a.a_params pl t2)) a.a_from) then error [cannot_unify t1 t2]
- | TAnon a1,TAnon a2 ->
- unify_anons t1 t2 a1 a2
- | _ ->
- error [cannot_unify t1 t2]
- and unify_type_params a b tl1 tl2 =
- List.iter2 (fun t1 t2 ->
- try
- with_variance (type_eq EqRightDynamic) t1 t2
- with Unify_error l ->
- let err = cannot_unify a b in
- error (err :: (Invariant_parameter (t1,t2)) :: l)
- ) tl1 tl2
- and with_variance f t1 t2 =
- try
- f t1 t2
- with Unify_error l -> try
- unify_with_variance (with_variance f) t1 t2
- with Unify_error _ ->
- raise (Unify_error l)
- and unify_with_access t1 f2 =
- match f2.cf_kind with
- (* write only *)
- | Var { v_read = AccNo } | Var { v_read = AccNever } -> unify f2.cf_type t1
- (* read only *)
- | Method MethNormal | Method MethInline | Var { v_write = AccNo } | Var { v_write = AccNever } -> unify t1 f2.cf_type
- (* read/write *)
- | _ -> with_variance (type_eq EqBothDynamic) t1 f2.cf_type
- module Abstract = struct
- open Ast
- let find_to ab pl b =
- if follow b == t_dynamic then
- List.find (fun (t,_) -> follow t == t_dynamic) ab.a_to_field
- else if List.exists (unify_to ab pl ~allow_transitive_cast:false b) ab.a_to then
- raise Not_found (* legacy compatibility *)
- else
- List.find (unify_to_field ab pl b) ab.a_to_field
- let find_from ab pl a b =
- if follow a == t_dynamic then
- List.find (fun (t,_) -> follow t == t_dynamic) ab.a_from_field
- else if List.exists (unify_from ab pl a ~allow_transitive_cast:false b) ab.a_from then
- raise Not_found (* legacy compatibility *)
- else
- List.find (unify_from_field ab pl a b) ab.a_from_field
- let underlying_type_stack = ref []
- let rec get_underlying_type a pl =
- let maybe_recurse t =
- underlying_type_stack := a :: !underlying_type_stack;
- let t = match follow t with
- | TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
- if List.mem a !underlying_type_stack then begin
- let s = String.concat " -> " (List.map (fun a -> s_type_path a.a_path) (List.rev (a :: !underlying_type_stack))) in
- raise (Error("Abstract chain detected: " ^ s,a.a_pos))
- end;
- get_underlying_type a tl
- | _ ->
- t
- in
- underlying_type_stack := List.tl !underlying_type_stack;
- t
- in
- try
- if not (Meta.has Meta.MultiType a.a_meta) then raise Not_found;
- let m = mk_mono() in
- let _ = find_to a pl m in
- maybe_recurse (follow m)
- with Not_found ->
- if Meta.has Meta.CoreType a.a_meta then
- t_dynamic
- else
- maybe_recurse (apply_params a.a_params pl a.a_this)
- let rec follow_with_abstracts t = match follow t with
- | TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
- follow_with_abstracts (get_underlying_type a tl)
- | t ->
- t
- end
- (* ======= Mapping and iterating ======= *)
- let iter_dt f dt = match dt with
- | DTBind(_,dt) -> f dt
- | DTSwitch(_,cl,dto) ->
- List.iter (fun (_,dt) -> f dt) cl;
- (match dto with None -> () | Some dt -> f dt)
- | DTGuard(_,dt1,dt2) ->
- f dt1;
- (match dt2 with None -> () | Some dt -> f dt)
- | DTGoto _ | DTExpr _ -> ()
- let iter f e =
- match e.eexpr with
- | TConst _
- | TLocal _
- | TBreak
- | TContinue
- | TTypeExpr _ ->
- ()
- | TArray (e1,e2)
- | TBinop (_,e1,e2)
- | TFor (_,e1,e2)
- | TWhile (e1,e2,_) ->
- f e1;
- f e2;
- | TThrow e
- | TField (e,_)
- | TEnumParameter (e,_,_)
- | TParenthesis e
- | TCast (e,_)
- | TUnop (_,_,e)
- | TMeta(_,e) ->
- f e
- | TArrayDecl el
- | TNew (_,_,el)
- | TBlock el ->
- List.iter f el
- | TObjectDecl fl ->
- List.iter (fun (_,e) -> f e) fl
- | TCall (e,el) ->
- f e;
- List.iter f el
- | TVar (v,eo) ->
- (match eo with None -> () | Some e -> f e)
- | TFunction fu ->
- f fu.tf_expr
- | TIf (e,e1,e2) ->
- f e;
- f e1;
- (match e2 with None -> () | Some e -> f e)
- | TSwitch (e,cases,def) ->
- f e;
- List.iter (fun (el,e2) -> List.iter f el; f e2) cases;
- (match def with None -> () | Some e -> f e)
- | TTry (e,catches) ->
- f e;
- List.iter (fun (_,e) -> f e) catches
- | TReturn eo ->
- (match eo with None -> () | Some e -> f e)
- let map_expr f e =
- match e.eexpr with
- | TConst _
- | TLocal _
- | TBreak
- | TContinue
- | TTypeExpr _ ->
- e
- | TArray (e1,e2) ->
- let e1 = f e1 in
- { e with eexpr = TArray (e1,f e2) }
- | TBinop (op,e1,e2) ->
- let e1 = f e1 in
- { e with eexpr = TBinop (op,e1,f e2) }
- | TFor (v,e1,e2) ->
- let e1 = f e1 in
- { e with eexpr = TFor (v,e1,f e2) }
- | TWhile (e1,e2,flag) ->
- let e1 = f e1 in
- { e with eexpr = TWhile (e1,f e2,flag) }
- | TThrow e1 ->
- { e with eexpr = TThrow (f e1) }
- | TEnumParameter (e1,ef,i) ->
- { e with eexpr = TEnumParameter(f e1,ef,i) }
- | TField (e1,v) ->
- { e with eexpr = TField (f e1,v) }
- | TParenthesis e1 ->
- { e with eexpr = TParenthesis (f e1) }
- | TUnop (op,pre,e1) ->
- { e with eexpr = TUnop (op,pre,f e1) }
- | TArrayDecl el ->
- { e with eexpr = TArrayDecl (List.map f el) }
- | TNew (t,pl,el) ->
- { e with eexpr = TNew (t,pl,List.map f el) }
- | TBlock el ->
- { e with eexpr = TBlock (List.map f el) }
- | TObjectDecl el ->
- { e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el) }
- | TCall (e1,el) ->
- { e with eexpr = TCall (f e1, List.map f el) }
- | TVar (v,eo) ->
- { e with eexpr = TVar (v, match eo with None -> None | Some e -> Some (f e)) }
- | TFunction fu ->
- { e with eexpr = TFunction { fu with tf_expr = f fu.tf_expr } }
- | TIf (ec,e1,e2) ->
- let ec = f ec in
- let e1 = f e1 in
- { e with eexpr = TIf (ec,e1,match e2 with None -> None | Some e -> Some (f e)) }
- | TSwitch (e1,cases,def) ->
- let e1 = f e1 in
- let cases = List.map (fun (el,e2) -> List.map f el, f e2) cases in
- { e with eexpr = TSwitch (e1, cases, match def with None -> None | Some e -> Some (f e)) }
- | TTry (e1,catches) ->
- let e1 = f e1 in
- { e with eexpr = TTry (e1, List.map (fun (v,e) -> v, f e) catches) }
- | TReturn eo ->
- { e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)) }
- | TCast (e1,t) ->
- { e with eexpr = TCast (f e1,t) }
- | TMeta (m,e1) ->
- {e with eexpr = TMeta(m,f e1)}
- let map_expr_type f ft fv e =
- match e.eexpr with
- | TConst _
- | TBreak
- | TContinue
- | TTypeExpr _ ->
- { e with etype = ft e.etype }
- | TLocal v ->
- { e with eexpr = TLocal (fv v); etype = ft e.etype }
- | TArray (e1,e2) ->
- let e1 = f e1 in
- { e with eexpr = TArray (e1,f e2); etype = ft e.etype }
- | TBinop (op,e1,e2) ->
- let e1 = f e1 in
- { e with eexpr = TBinop (op,e1,f e2); etype = ft e.etype }
- | TFor (v,e1,e2) ->
- let v = fv v in
- let e1 = f e1 in
- { e with eexpr = TFor (v,e1,f e2); etype = ft e.etype }
- | TWhile (e1,e2,flag) ->
- let e1 = f e1 in
- { e with eexpr = TWhile (e1,f e2,flag); etype = ft e.etype }
- | TThrow e1 ->
- { e with eexpr = TThrow (f e1); etype = ft e.etype }
- | TEnumParameter (e1,ef,i) ->
- { e with eexpr = TEnumParameter(f e1,ef,i); etype = ft e.etype }
- | TField (e1,v) ->
- let e1 = f e1 in
- let v = try
- let n = match v with
- | FClosure _ -> raise Not_found
- | FAnon f | FInstance (_,_,f) | FStatic (_,f) -> f.cf_name
- | FEnum (_,f) -> f.ef_name
- | FDynamic n -> n
- in
- quick_field e1.etype n
- with Not_found ->
- v
- in
- { e with eexpr = TField (e1,v); etype = ft e.etype }
- | TParenthesis e1 ->
- { e with eexpr = TParenthesis (f e1); etype = ft e.etype }
- | TUnop (op,pre,e1) ->
- { e with eexpr = TUnop (op,pre,f e1); etype = ft e.etype }
- | TArrayDecl el ->
- { e with eexpr = TArrayDecl (List.map f el); etype = ft e.etype }
- | TNew (c,pl,el) ->
- let et = ft e.etype in
- (* make sure that we use the class corresponding to the replaced type *)
- let t = match c.cl_kind with
- | KTypeParameter _ | KGeneric ->
- et
- | _ ->
- ft (TInst(c,pl))
- in
- let c, pl = (match follow t with TInst (c,pl) -> (c,pl) | TAbstract({a_impl = Some c},pl) -> c,pl | t -> error [has_no_field t "new"]) in
- { e with eexpr = TNew (c,pl,List.map f el); etype = et }
- | TBlock el ->
- { e with eexpr = TBlock (List.map f el); etype = ft e.etype }
- | TObjectDecl el ->
- { e with eexpr = TObjectDecl (List.map (fun (v,e) -> v, f e) el); etype = ft e.etype }
- | TCall (e1,el) ->
- let e1 = f e1 in
- { e with eexpr = TCall (e1, List.map f el); etype = ft e.etype }
- | TVar (v,eo) ->
- { e with eexpr = TVar (fv v, match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }
- | TFunction fu ->
- let fu = {
- tf_expr = f fu.tf_expr;
- tf_args = List.map (fun (v,o) -> fv v, o) fu.tf_args;
- tf_type = ft fu.tf_type;
- } in
- { e with eexpr = TFunction fu; etype = ft e.etype }
- | TIf (ec,e1,e2) ->
- let ec = f ec in
- let e1 = f e1 in
- { e with eexpr = TIf (ec,e1,match e2 with None -> None | Some e -> Some (f e)); etype = ft e.etype }
- | TSwitch (e1,cases,def) ->
- let e1 = f e1 in
- let cases = List.map (fun (el,e2) -> List.map f el, f e2) cases in
- { e with eexpr = TSwitch (e1, cases, match def with None -> None | Some e -> Some (f e)); etype = ft e.etype }
- | TTry (e1,catches) ->
- let e1 = f e1 in
- { e with eexpr = TTry (e1, List.map (fun (v,e) -> fv v, f e) catches); etype = ft e.etype }
- | TReturn eo ->
- { e with eexpr = TReturn (match eo with None -> None | Some e -> Some (f e)); etype = ft e.etype }
- | TCast (e1,t) ->
- { e with eexpr = TCast (f e1,t); etype = ft e.etype }
- | TMeta (m,e1) ->
- {e with eexpr = TMeta(m, f e1); etype = ft e.etype }
- module TExprToExpr = struct
- let tpath p mp pl =
- if snd mp = snd p then
- CTPath {
- tpackage = fst p;
- tname = snd p;
- tparams = List.map (fun t -> TPType t) pl;
- tsub = None;
- }
- else CTPath {
- tpackage = fst mp;
- tname = snd mp;
- tparams = List.map (fun t -> TPType t) pl;
- tsub = Some (snd p);
- }
- let rec convert_type = function
- | TMono r ->
- (match !r with
- | None -> raise Exit
- | Some t -> convert_type t)
- | TInst ({cl_private = true; cl_path=_,name},tl)
- | TEnum ({e_private = true; e_path=_,name},tl)
- | TType ({t_private = true; t_path=_,name},tl)
- | TAbstract ({a_private = true; a_path=_,name},tl) ->
- CTPath {
- tpackage = [];
- tname = name;
- tparams = List.map (fun t -> TPType (convert_type t)) tl;
- tsub = None;
- }
- | TEnum (e,pl) ->
- tpath e.e_path e.e_module.m_path (List.map convert_type pl)
- | TInst({cl_kind = KTypeParameter _} as c,pl) ->
- tpath ([],snd c.cl_path) ([],snd c.cl_path) (List.map convert_type pl)
- | TInst (c,pl) ->
- tpath c.cl_path c.cl_module.m_path (List.map convert_type pl)
- | TType (t,pl) as tf ->
- (* recurse on type-type *)
- if (snd t.t_path).[0] = '#' then convert_type (follow tf) else tpath t.t_path t.t_module.m_path (List.map convert_type pl)
- | TAbstract (a,pl) ->
- tpath a.a_path a.a_module.m_path (List.map convert_type pl)
- | TFun (args,ret) ->
- CTFunction (List.map (fun (_,_,t) -> convert_type t) args, convert_type ret)
- | TAnon a ->
- begin match !(a.a_status) with
- | Statics c -> tpath ([],"Class") ([],"Class") [tpath c.cl_path c.cl_path []]
- | EnumStatics e -> tpath ([],"Enum") ([],"Enum") [tpath e.e_path e.e_path []]
- | _ ->
- CTAnonymous (PMap.foldi (fun _ f acc ->
- {
- cff_name = f.cf_name;
- cff_kind = FVar (mk_ot f.cf_type,None);
- cff_pos = f.cf_pos;
- cff_doc = f.cf_doc;
- cff_meta = f.cf_meta;
- cff_access = [];
- } :: acc
- ) a.a_fields [])
- end
- | (TDynamic t2) as t ->
- tpath ([],"Dynamic") ([],"Dynamic") (if t == t_dynamic then [] else [convert_type t2])
- | TLazy f ->
- convert_type ((!f)())
- and mk_ot t =
- match follow t with
- | TMono _ -> None
- | _ -> (try Some (convert_type t) with Exit -> None)
- let rec convert_expr e =
- let full_type_path t =
- let mp,p = match t with
- | TClassDecl c -> c.cl_module.m_path,c.cl_path
- | TEnumDecl en -> en.e_module.m_path,en.e_path
- | TAbstractDecl a -> a.a_module.m_path,a.a_path
- | TTypeDecl t -> t.t_module.m_path,t.t_path
- in
- if snd mp = snd p then p else (fst mp) @ [snd mp],snd p
- in
- let mk_path = expr_of_type_path in
- let mk_ident = function
- | "`trace" -> Ident "trace"
- | n -> Ident n
- in
- let eopt = function None -> None | Some e -> Some (convert_expr e) in
- ((match e.eexpr with
- | TConst c ->
- EConst (tconst_to_const c)
- | TLocal v -> EConst (mk_ident v.v_name)
- | TArray (e1,e2) -> EArray (convert_expr e1,convert_expr e2)
- | TBinop (op,e1,e2) -> EBinop (op, convert_expr e1, convert_expr e2)
- | TField (e,f) -> EField (convert_expr e, field_name f)
- | TTypeExpr t -> fst (mk_path (full_type_path t) e.epos)
- | TParenthesis e -> EParenthesis (convert_expr e)
- | TObjectDecl fl -> EObjectDecl (List.map (fun (f,e) -> f, convert_expr e) fl)
- | TArrayDecl el -> EArrayDecl (List.map convert_expr el)
- | TCall (e,el) -> ECall (convert_expr e,List.map convert_expr el)
- | TNew (c,pl,el) -> ENew ((match (try convert_type (TInst (c,pl)) with Exit -> convert_type (TInst (c,[]))) with CTPath p -> p | _ -> assert false),List.map convert_expr el)
- | TUnop (op,p,e) -> EUnop (op,p,convert_expr e)
- | TFunction f ->
- let arg (v,c) = v.v_name, false, mk_ot v.v_type, (match c with None -> None | Some c -> Some (EConst (tconst_to_const c),e.epos)) in
- EFunction (None,{ f_params = []; f_args = List.map arg f.tf_args; f_type = mk_ot f.tf_type; f_expr = Some (convert_expr f.tf_expr) })
- | TVar (v,eo) ->
- EVars ([v.v_name, mk_ot v.v_type, eopt eo])
- | TBlock el -> EBlock (List.map convert_expr el)
- | TFor (v,it,e) ->
- let ein = (EIn ((EConst (Ident v.v_name),it.epos),convert_expr it),it.epos) in
- EFor (ein,convert_expr e)
- | TIf (e,e1,e2) -> EIf (convert_expr e,convert_expr e1,eopt e2)
- | TWhile (e1,e2,flag) -> EWhile (convert_expr e1, convert_expr e2, flag)
- | TSwitch (e,cases,def) ->
- let cases = List.map (fun (vl,e) ->
- List.map convert_expr vl,None,(match e.eexpr with TBlock [] -> None | _ -> Some (convert_expr e))
- ) cases in
- let def = match eopt def with None -> None | Some (EBlock [],_) -> Some None | e -> Some e in
- ESwitch (convert_expr e,cases,def)
- | TEnumParameter _ ->
- (* these are considered complex, so the AST is handled in TMeta(Meta.Ast) *)
- assert false
- | TTry (e,catches) -> ETry (convert_expr e,List.map (fun (v,e) -> v.v_name, (try convert_type v.v_type with Exit -> assert false), convert_expr e) catches)
- | TReturn e -> EReturn (eopt e)
- | TBreak -> EBreak
- | TContinue -> EContinue
- | TThrow e -> EThrow (convert_expr e)
- | TCast (e,t) ->
- let t = (match t with
- | None -> None
- | Some t ->
- let t = (match t with TClassDecl c -> TInst (c,[]) | TEnumDecl e -> TEnum (e,[]) | TTypeDecl t -> TType (t,[]) | TAbstractDecl a -> TAbstract (a,[])) in
- Some (try convert_type t with Exit -> assert false)
- ) in
- ECast (convert_expr e,t)
- | TMeta ((Meta.Ast,[e1,_],_),_) -> e1
- | TMeta (m,e) -> EMeta(m,convert_expr e))
- ,e.epos)
- end
- let print_if b e =
- if b then print_endline (s_expr_pretty "" (s_type (print_context())) e)
|