123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349 |
- (*
- * Copyright (C)2005-2013 Haxe Foundation
- *
- * Permission is hereby granted, free of charge, to any person obtaining a
- * copy of this software and associated documentation files (the "Software"),
- * to deal in the Software without restriction, including without limitation
- * the rights to use, copy, modify, merge, publish, distribute, sublicense,
- * and/or sell copies of the Software, and to permit persons to whom the
- * Software is furnished to do so, subject to the following conditions:
- *
- * The above copyright notice and this permission notice shall be included in
- * all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
- * DEALINGS IN THE SOFTWARE.
- *)
- open Gencommon.ReflectionCFs
- open Ast
- open Common
- open Gencommon
- open Gencommon.SourceWriter
- open Type
- open Printf
- open Option
- let is_cs_basic_type t =
- match follow t with
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | TInst( { cl_path = ([], "Int") }, [] )
- | TAbstract ({ a_path = ([], "Int") },[])
- | TInst( { cl_path = ([], "Float") }, [] )
- | TAbstract ({ a_path = ([], "Float") },[])
- | TEnum( { e_path = ([], "Bool") }, [] )
- | TAbstract ({ a_path = ([], "Bool") },[]) ->
- true
- | TAbstract _ when like_float t ->
- true
- | TEnum(e, _) when not (Meta.has Meta.Class e.e_meta) -> true
- | TInst(cl, _) when Meta.has Meta.Struct cl.cl_meta -> true
- | _ -> false
- (* see http://msdn.microsoft.com/en-us/library/2sk3x8a7(v=vs.71).aspx *)
- let cs_binops =
- [Ast.OpAdd, "op_Addition";
- Ast.OpSub, "op_Subtraction";
- Ast.OpMult, "op_Multiply";
- Ast.OpDiv, "op_Division";
- Ast.OpMod, "op_Modulus";
- Ast.OpXor, "op_ExclusiveOr";
- Ast.OpOr, "op_BitwiseOr";
- Ast.OpAnd, "op_BitwiseAnd";
- Ast.OpBoolAnd, "op_LogicalAnd";
- Ast.OpBoolOr, "op_LogicalOr";
- Ast.OpAssign, "op_Assign";
- Ast.OpShl, "op_LeftShift";
- Ast.OpShr, "op_RightShift";
- Ast.OpShr, "op_SignedRightShift";
- Ast.OpUShr, "op_UnsignedRightShift";
- Ast.OpEq, "op_Equality";
- Ast.OpGt, "op_GreaterThan";
- Ast.OpLt, "op_LessThan";
- Ast.OpNotEq, "op_Inequality";
- Ast.OpGte, "op_GreaterThanOrEqual";
- Ast.OpLte, "op_LessThanOrEqual";
- Ast.OpAssignOp Ast.OpMult, "op_MultiplicationAssignment";
- Ast.OpAssignOp Ast.OpSub, "op_SubtractionAssignment";
- Ast.OpAssignOp Ast.OpXor, "op_ExclusiveOrAssignment";
- Ast.OpAssignOp Ast.OpShl, "op_LeftShiftAssignment";
- Ast.OpAssignOp Ast.OpMod, "op_ModulusAssignment";
- Ast.OpAssignOp Ast.OpAdd, "op_AdditionAssignment";
- Ast.OpAssignOp Ast.OpAnd, "op_BitwiseAndAssignment";
- Ast.OpAssignOp Ast.OpOr, "op_BitwiseOrAssignment";
- (* op_Comma *)
- Ast.OpAssignOp Ast.OpDiv, "op_DivisionAssignment";]
- let cs_unops =
- [Ast.Decrement, "op_Decrement";
- Ast.Increment, "op_Increment";
- Ast.Not, "op_UnaryNegation";
- Ast.Neg, "op_UnaryMinus";
- Ast.NegBits, "op_OnesComplement"]
- let binops_names = List.fold_left (fun acc (op,n) -> PMap.add n op acc) PMap.empty cs_binops
- let unops_names = List.fold_left (fun acc (op,n) -> PMap.add n op acc) PMap.empty cs_unops
- let get_item = "get_Item"
- let set_item = "set_Item"
- let is_tparam t =
- match follow t with
- | TInst( { cl_kind = KTypeParameter _ }, [] ) -> true
- | _ -> false
- let rec is_int_float t =
- match follow t with
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | TInst( { cl_path = ([], "Int") }, [] )
- | TAbstract ({ a_path = ([], "Int") },[])
- | TInst( { cl_path = ([], "Float") }, [] )
- | TAbstract ({ a_path = ([], "Float") },[]) ->
- true
- | TAbstract _ when like_float t ->
- true
- | TInst( { cl_path = (["haxe"; "lang"], "Null") }, [t] ) -> is_int_float t
- | _ -> false
- let rec is_null t =
- match t with
- | TInst( { cl_path = (["haxe"; "lang"], "Null") }, _ )
- | TType( { t_path = ([], "Null") }, _ ) -> true
- | TType( t, tl ) -> is_null (apply_params t.t_types tl t.t_type)
- | TMono r ->
- (match !r with
- | Some t -> is_null t
- | _ -> false)
- | TLazy f ->
- is_null (!f())
- | _ -> false
- let parse_explicit_iface =
- let regex = Str.regexp "\\." in
- let parse_explicit_iface str =
- let split = Str.split regex str in
- let rec get_iface split pack =
- match split with
- | clname :: fn_name :: [] -> fn_name, (List.rev pack, clname)
- | pack_piece :: tl -> get_iface tl (pack_piece :: pack)
- | _ -> assert false
- in
- get_iface split []
- in parse_explicit_iface
- let is_string t =
- match follow t with
- | TInst( { cl_path = ([], "String") }, [] ) -> true
- | _ -> false
- (* ******************************************* *)
- (* CSharpSpecificESynf *)
- (* ******************************************* *)
- (*
- Some CSharp-specific syntax filters that must run before ExpressionUnwrap
- dependencies:
- It must run before ExprUnwrap, as it may not return valid Expr/Statement expressions
- It must run before ClassInstance, as it will detect expressions that need unchanged TTypeExpr
- *)
- module CSharpSpecificESynf =
- struct
- let name = "csharp_specific_e"
- let priority = solve_deps name [DBefore ExpressionUnwrap.priority; DBefore ClassInstance.priority; DAfter TryCatchWrapper.priority]
- let get_cl_from_t t =
- match follow t with
- | TInst(cl,_) -> cl
- | _ -> assert false
- let traverse gen runtime_cl =
- let basic = gen.gcon.basic in
- let uint = match get_type gen ([], "UInt") with | TTypeDecl t -> TType(t, []) | TAbstractDecl a -> TAbstract(a, []) | _ -> assert false in
- let is_var = alloc_var "__is__" t_dynamic in
- let rec run e =
- match e.eexpr with
- (* Std.is() *)
- | TCall(
- { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "is" })) },
- [ obj; { eexpr = TTypeExpr(TClassDecl { cl_path = [], "Dynamic" } | TAbstractDecl { a_path = [], "Dynamic" }) }]
- ) ->
- Type.map_expr run e
- | TCall(
- { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "is"}) ) },
- [ obj; { eexpr = TTypeExpr(md) }]
- ) ->
- let mk_is obj md =
- { e with eexpr = TCall( { eexpr = TLocal is_var; etype = t_dynamic; epos = e.epos }, [
- obj;
- { eexpr = TTypeExpr md; etype = t_dynamic (* this is after all a syntax filter *); epos = e.epos }
- ] ) }
- in
- let obj = run obj in
- (match follow_module follow md with
- | TClassDecl{ cl_path = ([], "Float") } ->
- (* on the special case of seeing if it is a Float, we need to test if both it is a float and if it is an Int *)
- let mk_is local =
- mk_paren {
- eexpr = TBinop(Ast.OpBoolOr, mk_is local md, mk_is local (TClassDecl (get_cl_from_t basic.tint)));
- etype = basic.tbool;
- epos = e.epos
- }
- in
- let ret = match obj.eexpr with
- | TLocal(v) -> mk_is obj
- | _ ->
- let var = mk_temp gen "is" obj.etype in
- let added = { obj with eexpr = TVars([var, Some(obj)]); etype = basic.tvoid } in
- let local = mk_local var obj.epos in
- {
- eexpr = TBlock([ added; mk_is local ]);
- etype = basic.tbool;
- epos = e.epos
- }
- in
- ret
- | TClassDecl{ cl_path = ([], "Int") } ->
- {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl "isInt" e.epos [],
- [ obj ]
- );
- etype = basic.tbool;
- epos = e.epos
- }
- | _ ->
- mk_is obj md
- )
- (* end Std.is() *)
- | TBinop( Ast.OpUShr, e1, e2 ) ->
- mk_cast e.etype { e with eexpr = TBinop( Ast.OpShr, mk_cast uint (run e1), run e2 ) }
- | TBinop( Ast.OpAssignOp Ast.OpUShr, e1, e2 ) ->
- let mk_ushr local =
- { e with eexpr = TBinop(Ast.OpAssign, local, run { e with eexpr = TBinop(Ast.OpUShr, local, run e2) }) }
- in
- let mk_local obj =
- let var = mk_temp gen "opUshr" obj.etype in
- let added = { obj with eexpr = TVars([var, Some(obj)]); etype = basic.tvoid } in
- let local = mk_local var obj.epos in
- local, added
- in
- let e1 = run e1 in
- let ret = match e1.eexpr with
- | TField({ eexpr = TLocal _ }, _)
- | TField({ eexpr = TTypeExpr _ }, _)
- | TArray({ eexpr = TLocal _ }, _)
- | TLocal(_) ->
- mk_ushr e1
- | TField(fexpr, field) ->
- let local, added = mk_local fexpr in
- { e with eexpr = TBlock([ added; mk_ushr { e1 with eexpr = TField(local, field) } ]); }
- | TArray(ea1, ea2) ->
- let local, added = mk_local ea1 in
- { e with eexpr = TBlock([ added; mk_ushr { e1 with eexpr = TArray(local, ea2) } ]); }
- | _ -> (* invalid left-side expression *)
- assert false
- in
- ret
- | _ -> Type.map_expr run e
- in
- run
- let configure gen (mapping_func:texpr->texpr) =
- let map e = Some(mapping_func e) in
- gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
- end;;
- (* ******************************************* *)
- (* CSharpSpecificSynf *)
- (* ******************************************* *)
- (*
- Some CSharp-specific syntax filters that can run after ExprUnwrap
- dependencies:
- Runs after ExprUnwrap
- *)
- module CSharpSpecificSynf =
- struct
- let name = "csharp_specific"
- let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority; DAfter HardNullableSynf.priority ]
- let get_cl_from_t t =
- match follow t with
- | TInst(cl,_) -> cl
- | _ -> assert false
- let is_tparam t =
- match follow t with
- | TInst( { cl_kind = KTypeParameter _ }, _ ) -> true
- | _ -> false
- let traverse gen runtime_cl =
- let basic = gen.gcon.basic in
- let tchar = match ( get_type gen (["cs"], "Char16") ) with | TTypeDecl t -> t | _ -> assert false in
- let tchar = TType(tchar,[]) in
- let string_ext = get_cl ( get_type gen (["haxe";"lang"], "StringExt")) in
- let is_string t = match follow t with | TInst({ cl_path = ([], "String") }, []) -> true | _ -> false in
- let clstring = match basic.tstring with | TInst(cl,_) -> cl | _ -> assert false in
- let is_struct t = (* not basic type *)
- match follow t with
- | TInst(cl, _) when Meta.has Meta.Struct cl.cl_meta -> true
- | _ -> false
- in
- let is_cl t = match gen.greal_type t with | TInst ( { cl_path = (["System"], "Type") }, [] ) -> true | _ -> false in
- let rec run e =
- match e.eexpr with
- (* Std.int() *)
- | TCall(
- { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "int" }) ) },
- [obj]
- ) ->
- run (mk_cast basic.tint obj)
- (* end Std.int() *)
- (* TODO: change cf_name *)
- | TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = "length" })) ->
- { e with eexpr = TField(run ef, FDynamic "Length") }
- | TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = "toLowerCase" })) ->
- { e with eexpr = TField(run ef, FDynamic "ToLower") }
- | TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = "toUpperCase" })) ->
- { e with eexpr = TField(run ef, FDynamic "ToUpper") }
- | TCall( { eexpr = TField(_, FStatic({ cl_path = [], "String" }, { cf_name = "fromCharCode" })) }, [cc] ) ->
- { e with eexpr = TNew(get_cl_from_t basic.tstring, [], [mk_cast tchar (run cc); mk_int gen 1 cc.epos]) }
- | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("charAt" as field) })) }, args )
- | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("charCodeAt" as field) })) }, args )
- | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("indexOf" as field) })) }, args )
- | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("lastIndexOf" as field) })) }, args )
- | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("split" as field) })) }, args )
- | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("substring" as field) })) }, args )
- | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("substr" as field) })) }, args ) ->
- { e with eexpr = TCall(mk_static_field_access_infer string_ext field e.epos [], [run ef] @ (List.map run args)) }
- | TNew( { cl_path = ([], "String") }, [], [p] ) -> run p (* new String(myString) -> myString *)
- | TCast(expr, _) when is_int_float e.etype && not (is_int_float expr.etype) && not (is_null e.etype) ->
- let needs_cast = match gen.gfollow#run_f e.etype with
- | TInst _ -> false
- | _ -> true
- in
- let fun_name = if like_int e.etype then "toInt" else "toDouble" in
- let ret = {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl fun_name expr.epos [],
- [ run expr ]
- );
- etype = basic.tint;
- epos = expr.epos
- } in
- if needs_cast then mk_cast e.etype ret else ret
- | TCast(expr, _) when is_string e.etype ->
- { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "toString" expr.epos [], [run expr] ) }
- | TBinop( (Ast.OpNotEq as op), e1, e2)
- | TBinop( (Ast.OpEq as op), e1, e2) when is_string e1.etype || is_string e2.etype ->
- let mk_ret e = match op with | Ast.OpNotEq -> { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) } | _ -> e in
- mk_ret { e with
- eexpr = TCall({
- eexpr = TField(mk_classtype_access clstring e.epos, FDynamic "Equals");
- etype = TFun(["obj1",false,basic.tstring; "obj2",false,basic.tstring], basic.tbool);
- epos = e1.epos
- }, [ run e1; run e2 ])
- }
- | TCast(expr, _) when is_tparam e.etype ->
- let static = mk_static_field_access_infer (runtime_cl) "genericCast" e.epos [e.etype] in
- { e with eexpr = TCall(static, [mk_local (alloc_var "$type_param" e.etype) expr.epos; run expr]); }
- | TBinop( (Ast.OpNotEq as op), e1, e2)
- | TBinop( (Ast.OpEq as op), e1, e2) when is_struct e1.etype || is_struct e2.etype ->
- let mk_ret e = match op with | Ast.OpNotEq -> { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) } | _ -> e in
- mk_ret { e with
- eexpr = TCall({
- eexpr = TField(run e1, FDynamic "Equals");
- etype = TFun(["obj1",false,t_dynamic;], basic.tbool);
- epos = e1.epos
- }, [ run e2 ])
- }
- | TBinop ( (Ast.OpEq as op), e1, e2 )
- | TBinop ( (Ast.OpNotEq as op), e1, e2 ) when is_cl e1.etype ->
- let static = mk_static_field_access_infer (runtime_cl) "typeEq" e.epos [] in
- let ret = { e with eexpr = TCall(static, [run e1; run e2]); } in
- if op = Ast.OpNotEq then
- { ret with eexpr = TUnop(Ast.Not, Ast.Prefix, ret) }
- else
- ret
- | _ -> Type.map_expr run e
- in
- run
- let configure gen (mapping_func:texpr->texpr) =
- let map e = Some(mapping_func e) in
- gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
- end;;
- (* Type Parameters Handling *)
- let handle_type_params gen ifaces base_generic =
- let basic = gen.gcon.basic in
- (*
- starting to set gtparam_cast.
- *)
- (* NativeArray: the most important. *)
- (*
- var new_arr = new NativeArray<TO_T>(old_arr.Length);
- var i = -1;
- while( i < old_arr.Length )
- {
- new_arr[i] = (TO_T) old_arr[i];
- }
- *)
- let native_arr_cl = get_cl ( get_type gen (["cs"], "NativeArray") ) in
- let get_narr_param t = match follow t with
- | TInst({ cl_path = (["cs"], "NativeArray") }, [param]) -> param
- | _ -> assert false
- in
- let gtparam_cast_native_array e to_t =
- let old_param = get_narr_param e.etype in
- let new_param = get_narr_param to_t in
- let new_v = mk_temp gen "new_arr" to_t in
- let i = mk_temp gen "i" basic.tint in
- let old_len = mk_field_access gen e "Length" e.epos in
- let obj_v = mk_temp gen "obj" t_dynamic in
- let block = [
- {
- eexpr = TVars(
- [
- new_v, Some( {
- eexpr = TNew(native_arr_cl, [new_param], [old_len] );
- etype = to_t;
- epos = e.epos
- } );
- i, Some( mk_int gen (-1) e.epos )
- ]);
- etype = basic.tvoid;
- epos = e.epos };
- {
- eexpr = TWhile(
- {
- eexpr = TBinop(
- Ast.OpLt,
- { eexpr = TUnop(Ast.Increment, Ast.Prefix, mk_local i e.epos); etype = basic.tint; epos = e.epos },
- old_len
- );
- etype = basic.tbool;
- epos = e.epos
- },
- { eexpr = TBlock [
- {
- eexpr = TVars([obj_v, Some (mk_cast t_dynamic { eexpr = TArray(e, mk_local i e.epos); etype = old_param; epos = e.epos })]);
- etype = basic.tvoid;
- epos = e.epos
- };
- {
- eexpr = TIf({
- eexpr = TBinop(Ast.OpNotEq, mk_local obj_v e.epos, null e.etype e.epos);
- etype = basic.tbool;
- epos = e.epos
- },
- {
- eexpr = TBinop(
- Ast.OpAssign,
- { eexpr = TArray(mk_local new_v e.epos, mk_local i e.epos); etype = new_param; epos = e.epos },
- mk_cast new_param (mk_local obj_v e.epos)
- );
- etype = new_param;
- epos = e.epos
- },
- None);
- etype = basic.tvoid;
- epos = e.epos
- }
- ]; etype = basic.tvoid; epos = e.epos },
- Ast.NormalWhile
- );
- etype = basic.tvoid;
- epos = e.epos;
- };
- mk_local new_v e.epos
- ] in
- { eexpr = TBlock(block); etype = to_t; epos = e.epos }
- in
- Hashtbl.add gen.gtparam_cast (["cs"], "NativeArray") gtparam_cast_native_array;
- (* end set gtparam_cast *)
- TypeParams.RealTypeParams.default_config gen (fun e t -> gen.gcon.warning ("Cannot cast to " ^ (debug_type t)) e.epos; mk_cast t e) ifaces base_generic
- let connecting_string = "?" (* ? see list here http://www.fileformat.info/info/unicode/category/index.htm and here for C# http://msdn.microsoft.com/en-us/library/aa664670.aspx *)
- let default_package = "cs" (* I'm having this separated as I'm still not happy with having a cs package. Maybe dotnet would be better? *)
- let strict_mode = ref false (* strict mode is so we can check for unexpected information *)
- (* reserved c# words *)
- let reserved = let res = Hashtbl.create 120 in
- List.iter (fun lst -> Hashtbl.add res lst ("@" ^ lst)) ["abstract"; "as"; "base"; "bool"; "break"; "byte"; "case"; "catch"; "char"; "checked"; "class";
- "const"; "continue"; "decimal"; "default"; "delegate"; "do"; "double"; "else"; "enum"; "event"; "explicit";
- "extern"; "false"; "finally"; "fixed"; "float"; "for"; "foreach"; "goto"; "if"; "implicit"; "in"; "int";
- "interface"; "internal"; "is"; "lock"; "long"; "namespace"; "new"; "null"; "object"; "operator"; "out"; "override";
- "params"; "private"; "protected"; "public"; "readonly"; "ref"; "return"; "sbyte"; "sealed"; "short"; "sizeof";
- "stackalloc"; "static"; "string"; "struct"; "switch"; "this"; "throw"; "true"; "try"; "typeof"; "uint"; "ulong";
- "unchecked"; "unsafe"; "ushort"; "using"; "virtual"; "volatile"; "void"; "while"; "add"; "ascending"; "by"; "descending";
- "dynamic"; "equals"; "from"; "get"; "global"; "group"; "into"; "join"; "let"; "on"; "orderby"; "partial";
- "remove"; "select"; "set"; "value"; "var"; "where"; "yield"];
- res
- let dynamic_anon = TAnon( { a_fields = PMap.empty; a_status = ref Closed } )
- let rec get_class_modifiers meta cl_type cl_access cl_modifiers =
- match meta with
- | [] -> cl_type,cl_access,cl_modifiers
- | (Meta.Struct,[],_) :: meta -> get_class_modifiers meta "struct" cl_access cl_modifiers
- | (Meta.Protected,[],_) :: meta -> get_class_modifiers meta cl_type "protected" cl_modifiers
- | (Meta.Internal,[],_) :: meta -> get_class_modifiers meta cl_type "internal" cl_modifiers
- (* no abstract for now | (":abstract",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("abstract" :: cl_modifiers)
- | (":static",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("static" :: cl_modifiers) TODO: support those types *)
- | (Meta.Final,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("sealed" :: cl_modifiers)
- | (Meta.Unsafe,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("unsafe" :: cl_modifiers)
- | _ :: meta -> get_class_modifiers meta cl_type cl_access cl_modifiers
- let rec get_fun_modifiers meta access modifiers =
- match meta with
- | [] -> access,modifiers
- | (Meta.Protected,[],_) :: meta -> get_fun_modifiers meta "protected" modifiers
- | (Meta.Internal,[],_) :: meta -> get_fun_modifiers meta "internal" modifiers
- | (Meta.ReadOnly,[],_) :: meta -> get_fun_modifiers meta access ("readonly" :: modifiers)
- | (Meta.Unsafe,[],_) :: meta -> get_fun_modifiers meta access ("unsafe" :: modifiers)
- | (Meta.Volatile,[],_) :: meta -> get_fun_modifiers meta access ("volatile" :: modifiers)
- | _ :: meta -> get_fun_modifiers meta access modifiers
- (* this was the way I found to pass the generator context to be accessible across all functions here *)
- (* so 'configure' is almost 'top-level' and will have all functions needed to make this work *)
- let configure gen =
- let basic = gen.gcon.basic in
- let fn_cl = get_cl (get_type gen (["haxe";"lang"],"Function")) in
- let null_t = (get_cl (get_type gen (["haxe";"lang"],"Null")) ) in
- let runtime_cl = get_cl (get_type gen (["haxe";"lang"],"Runtime")) in
- let no_root = Common.defined gen.gcon Define.NoRoot in
- let change_clname n = n in
- let change_id name = try Hashtbl.find reserved name with | Not_found -> name in
- let change_ns md = if no_root then
- function
- | [] when is_hxgen md -> ["haxe";"root"]
- | ns -> List.map change_id ns
- else List.map change_id in
- let change_field = change_id in
- let write_id w name = write w (change_id name) in
- let write_field w name = write w (change_field name) in
- gen.gfollow#add ~name:"follow_basic" (fun t -> match t with
- | TEnum ({ e_path = ([], "Bool") }, [])
- | TAbstract ({ a_path = ([], "Bool") },[])
- | TEnum ({ e_path = ([], "Void") }, [])
- | TAbstract ({ a_path = ([], "Void") },[])
- | TInst ({ cl_path = ([],"Float") },[])
- | TAbstract ({ a_path = ([],"Float") },[])
- | TInst ({ cl_path = ([],"Int") },[])
- | TAbstract ({ a_path = ([],"Int") },[])
- | TType ({ t_path = [],"UInt" },[])
- | TAbstract ({ a_path = [],"UInt" },[])
- | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[])
- | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[])
- | TType ({ t_path = ["haxe";"_Int64"], "NativeUInt64" },[])
- | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeUInt64" },[])
- | TType ({ t_path = ["cs"],"UInt64" },[])
- | TAbstract ({ a_path = ["cs"],"UInt64" },[])
- | TType ({ t_path = ["cs"],"UInt8" },[])
- | TAbstract ({ a_path = ["cs"],"UInt8" },[])
- | TType ({ t_path = ["cs"],"Int8" },[])
- | TAbstract ({ a_path = ["cs"],"Int8" },[])
- | TType ({ t_path = ["cs"],"Int16" },[])
- | TAbstract ({ a_path = ["cs"],"Int16" },[])
- | TType ({ t_path = ["cs"],"UInt16" },[])
- | TAbstract ({ a_path = ["cs"],"UInt16" },[])
- | TType ({ t_path = ["cs"],"Char16" },[])
- | TAbstract ({ a_path = ["cs"],"Char16" },[])
- | TType ({ t_path = ["cs"],"Ref" },_)
- | TAbstract ({ a_path = ["cs"],"Ref" },_)
- | TType ({ t_path = ["cs"],"Out" },_)
- | TAbstract ({ a_path = ["cs"],"Out" },_)
- | TType ({ t_path = [],"Single" },[])
- | TAbstract ({ a_path = [],"Single" },[]) -> Some t
- | TType ({ t_path = [],"Null" },[_]) -> Some t
- | TAbstract ({ a_impl = Some _ } as a, pl) ->
- Some (gen.gfollow#run_f ( Codegen.Abstract.get_underlying_type a pl) )
- | TAbstract( { a_path = ([], "EnumValue") }, _ )
- | TInst( { cl_path = ([], "EnumValue") }, _ ) -> Some t_dynamic
- | _ -> None);
- let module_s md =
- let path = (t_infos md).mt_path in
- match path with
- | ([], "String") -> "string"
- | ([], "Null") -> path_s (change_ns md ["haxe"; "lang"], change_clname "Null")
- | (ns,clname) -> path_s (change_ns md ns, change_clname clname)
- in
- let ifaces = Hashtbl.create 1 in
- let ti64 = match ( get_type gen (["haxe";"_Int64"], "NativeInt64") ) with | TTypeDecl t -> TType(t,[]) | TAbstractDecl a -> TAbstract(a,[]) | _ -> assert false in
- let ttype = get_cl ( get_type gen (["System"], "Type") ) in
- let has_tdyn tl =
- List.exists (fun t -> match follow t with
- | TDynamic _ | TMono _ -> true
- | _ -> false
- ) tl
- in
- let rec real_type t =
- let t = gen.gfollow#run_f t in
- let ret = match t with
- | TAbstract ({ a_impl = Some _ } as a, pl) ->
- real_type (Codegen.Abstract.get_underlying_type a pl)
- | TInst( { cl_path = (["haxe"], "Int32") }, [] ) -> gen.gcon.basic.tint
- | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> ti64
- | TAbstract( { a_path = [],"Class" }, _ )
- | TAbstract( { a_path = [],"Enum" }, _ )
- | TInst( { cl_path = ([], "Class") }, _ )
- | TInst( { cl_path = ([], "Enum") }, _ ) -> TInst(ttype,[])
- | TEnum(_, [])
- | TInst(_, []) -> t
- | TInst(cl, params) when
- has_tdyn params &&
- Hashtbl.mem ifaces cl.cl_path ->
- TInst(Hashtbl.find ifaces cl.cl_path, [])
- | TEnum(e, params) ->
- TEnum(e, List.map (fun _ -> t_dynamic) params)
- | TInst(cl, params) when Meta.has Meta.Enum cl.cl_meta ->
- TInst(cl, List.map (fun _ -> t_dynamic) params)
- | TInst(cl, params) -> TInst(cl, change_param_type (TClassDecl cl) params)
- | TType({ t_path = ([], "Null") }, [t]) ->
- (*
- Null<> handling is a little tricky.
- It will only change to haxe.lang.Null<> when the actual type is non-nullable or a type parameter
- It works on cases such as Hash<T> returning Null<T> since cast_detect will invoke real_type at the original type,
- Null<T>, which will then return the type haxe.lang.Null<>
- *)
- (match real_type t with
- | TInst( { cl_kind = KTypeParameter _ }, _ ) -> TInst(null_t, [t])
- | _ when is_cs_basic_type t -> TInst(null_t, [t])
- | _ -> real_type t)
- | TAbstract _
- | TType _ -> t
- | TAnon (anon) when (match !(anon.a_status) with | Statics _ | EnumStatics _ | AbstractStatics _ -> true | _ -> false) -> t
- | TFun _ -> TInst(fn_cl,[])
- | _ -> t_dynamic
- in
- ret
- and
- (*
- On hxcs, the only type parameters allowed to be declared are the basic c# types.
- That's made like this to avoid casting problems when type parameters in this case
- add nothing to performance, since the memory layout is always the same.
- To avoid confusion between Generic<Dynamic> (which has a different meaning in hxcs AST),
- all those references are using dynamic_anon, which means Generic<{}>
- *)
- change_param_type md tl =
- let is_hxgeneric = (TypeParams.RealTypeParams.is_hxgeneric md) in
- let ret t = match is_hxgeneric, real_type t with
- | false, _ -> t
- (*
- Because Null<> types need a special compiler treatment for many operations (e.g. boxing/unboxing),
- Null<> type parameters will be transformed into Dynamic.
- *)
- | true, TInst ( { cl_path = (["haxe";"lang"], "Null") }, _ ) -> dynamic_anon
- | true, TInst ( { cl_kind = KTypeParameter _ }, _ ) -> t
- | true, TInst _
- | true, TEnum _
- | true, TAbstract _ when is_cs_basic_type t -> t
- | true, TDynamic _ -> t
- | true, _ -> dynamic_anon
- in
- if is_hxgeneric && List.exists (fun t -> match follow t with | TDynamic _ -> true | _ -> false) tl then
- List.map (fun _ -> t_dynamic) tl
- else
- List.map ret tl
- in
- let is_dynamic t = match real_type t with
- | TMono _ | TDynamic _ -> true
- | TAnon anon ->
- (match !(anon.a_status) with
- | EnumStatics _ | Statics _ -> false
- | _ -> true
- )
- | _ -> false
- in
- let rec t_s t =
- match real_type t with
- (* basic types *)
- | TEnum ({ e_path = ([], "Bool") }, [])
- | TAbstract ({ a_path = ([], "Bool") },[]) -> "bool"
- | TEnum ({ e_path = ([], "Void") }, [])
- | TAbstract ({ a_path = ([], "Void") },[]) -> "object"
- | TInst ({ cl_path = ([],"Float") },[])
- | TAbstract ({ a_path = ([],"Float") },[]) -> "double"
- | TInst ({ cl_path = ([],"Int") },[])
- | TAbstract ({ a_path = ([],"Int") },[]) -> "int"
- | TType ({ t_path = [],"UInt" },[])
- | TAbstract ({ a_path = [],"UInt" },[]) -> "uint"
- | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[])
- | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) -> "long"
- | TType ({ t_path = ["haxe";"_Int64"], "NativeUInt64" },[])
- | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeUInt64" },[]) -> "ulong"
- | TType ({ t_path = ["cs"],"UInt64" },[])
- | TAbstract ({ a_path = ["cs"],"UInt64" },[]) -> "ulong"
- | TType ({ t_path = ["cs"],"UInt8" },[])
- | TAbstract ({ a_path = ["cs"],"UInt8" },[]) -> "byte"
- | TType ({ t_path = ["cs"],"Int8" },[])
- | TAbstract ({ a_path = ["cs"],"Int8" },[]) -> "sbyte"
- | TType ({ t_path = ["cs"],"Int16" },[])
- | TAbstract ({ a_path = ["cs"],"Int16" },[]) -> "short"
- | TType ({ t_path = ["cs"],"UInt16" },[])
- | TAbstract ({ a_path = ["cs"],"UInt16" },[]) -> "ushort"
- | TType ({ t_path = ["cs"],"Char16" },[])
- | TAbstract ({ a_path = ["cs"],"Char16" },[]) -> "char"
- | TType ({ t_path = [],"Single" },[])
- | TAbstract ({ a_path = [],"Single" },[]) -> "float"
- | TInst ({ cl_path = ["haxe"],"Int32" },[])
- | TAbstract ({ a_path = ["haxe"],"Int32" },[]) -> "int"
- | TInst ({ cl_path = ["haxe"],"Int64" },[])
- | TAbstract ({ a_path = ["haxe"],"Int64" },[]) -> "long"
- | TInst ({ cl_path = ([], "Dynamic") },_)
- | TAbstract ({ a_path = ([], "Dynamic") },_) -> "object"
- | TType ({ t_path = ["cs"],"Out" },[t])
- | TAbstract ({ a_path = ["cs"],"Out" },[t])
- | TType ({ t_path = ["cs"],"Ref" },[t])
- | TAbstract ({ a_path = ["cs"],"Ref" },[t]) -> t_s t
- | TInst({ cl_path = (["cs"], "NativeArray") }, [param]) ->
- let rec check_t_s t =
- match real_type t with
- | TInst({ cl_path = (["cs"], "NativeArray") }, [param]) ->
- (check_t_s param) ^ "[]"
- | _ -> t_s (run_follow gen t)
- in
- (check_t_s param) ^ "[]"
- | TInst({ cl_path = (["cs"], "Pointer") },[t])
- | TAbstract({ a_path = (["cs"], "Pointer") },[t])->
- t_s t ^ "*"
- (* end of basic types *)
- | TInst ({ cl_kind = KTypeParameter _; cl_path=p }, []) -> snd p
- | TMono r -> (match !r with | None -> "object" | Some t -> t_s (run_follow gen t))
- | TInst ({ cl_path = [], "String" }, []) -> "string"
- | TEnum (e, params) -> ("global::" ^ (module_s (TEnumDecl e)))
- | TInst (cl, _ :: _) when Meta.has Meta.Enum cl.cl_meta ->
- "global::" ^ module_s (TClassDecl cl)
- | TInst (({ cl_path = p } as cl), params) -> (path_param_s (TClassDecl cl) p params)
- | TType (({ t_path = p } as t), params) -> (path_param_s (TTypeDecl t) p params)
- | TAnon (anon) ->
- (match !(anon.a_status) with
- | Statics _ | EnumStatics _ -> "System.Type"
- | _ -> "object")
- | TDynamic _ -> "object"
- | TAbstract(a,pl) when a.a_impl <> None ->
- t_s (Codegen.Abstract.get_underlying_type a pl)
- (* No Lazy type nor Function type made. That's because function types will be at this point be converted into other types *)
- | _ -> if !strict_mode then begin trace ("[ !TypeError " ^ (Type.s_type (Type.print_context()) t) ^ " ]"); assert false end else "[ !TypeError " ^ (Type.s_type (Type.print_context()) t) ^ " ]"
- and path_param_s md path params =
- match params with
- | [] -> "global::" ^ module_s md
- | _ -> sprintf "%s<%s>" ("global::" ^ module_s md) (String.concat ", " (List.map (fun t -> t_s t) (change_param_type md params)))
- in
- let rett_s t =
- match t with
- | TEnum ({e_path = ([], "Void")}, [])
- | TAbstract ({ a_path = ([], "Void") },[]) -> "void"
- | _ -> t_s t
- in
- let argt_s t =
- match t with
- | TType ({ t_path = (["cs"], "Ref") }, [t])
- | TAbstract ({ a_path = (["cs"], "Ref") },[t]) -> "ref " ^ t_s t
- | TType ({ t_path = (["cs"], "Out") }, [t])
- | TAbstract ({ a_path = (["cs"], "Out") },[t]) -> "out " ^ t_s t
- | _ -> t_s t
- in
- let escape ichar b =
- match ichar with
- | 92 (* \ *) -> Buffer.add_string b "\\\\"
- | 39 (* ' *) -> Buffer.add_string b "\\\'"
- | 34 -> Buffer.add_string b "\\\""
- | 13 (* \r *) -> Buffer.add_string b "\\r"
- | 10 (* \n *) -> Buffer.add_string b "\\n"
- | 9 (* \t *) -> Buffer.add_string b "\\t"
- | c when c < 32 || c >= 127 -> Buffer.add_string b (Printf.sprintf "\\u%.4x" c)
- | c -> Buffer.add_char b (Char.chr c)
- in
- let escape s =
- let b = Buffer.create 0 in
- (try
- UTF8.validate s;
- UTF8.iter (fun c -> escape (UChar.code c) b) s
- with
- UTF8.Malformed_code ->
- String.iter (fun c -> escape (Char.code c) b) s
- );
- Buffer.contents b
- in
- let has_semicolon e =
- match e.eexpr with
- | TBlock _ | TFor _ | TSwitch _ | TMatch _ | TTry _ | TIf _ -> false
- | TWhile (_,_,flag) when flag = Ast.NormalWhile -> false
- | _ -> true
- in
- let in_value = ref false in
- let rec md_s md =
- let md = follow_module (gen.gfollow#run_f) md in
- match md with
- | TClassDecl ({ cl_types = [] } as cl) ->
- t_s (TInst(cl,[]))
- | TClassDecl (cl) when not (is_hxgen md) ->
- t_s (TInst(cl,List.map (fun t -> t_dynamic) cl.cl_types))
- | TEnumDecl ({ e_types = [] } as e) ->
- t_s (TEnum(e,[]))
- | TEnumDecl (e) when not (is_hxgen md) ->
- t_s (TEnum(e,List.map (fun t -> t_dynamic) e.e_types))
- | TClassDecl cl ->
- t_s (TInst(cl,[]))
- | TEnumDecl e ->
- t_s (TEnum(e,[]))
- | TTypeDecl t ->
- t_s (TType(t, List.map (fun t -> t_dynamic) t.t_types))
- | TAbstractDecl a ->
- t_s (TAbstract(a, List.map(fun t -> t_dynamic) a.a_types))
- in
- let rec ensure_local e explain =
- match e.eexpr with
- | TLocal _ -> e
- | TCast(e,_)
- | TParenthesis e -> ensure_local e explain
- | _ -> gen.gcon.error ("This function argument " ^ explain ^ " must be a local variable.") e.epos; e
- in
- let is_pointer t = match follow t with
- | TInst({ cl_path = (["cs"], "Pointer") }, _)
- | TAbstract ({ a_path = (["cs"], "Pointer") },_) ->
- true
- | _ ->
- false in
- let last_line = ref (-1) in
- let line_directive =
- if Common.defined gen.gcon Define.RealPosition then
- fun w p -> ()
- else fun w p ->
- let cur_line = Lexer.get_error_line p in
- let is_relative_path = (String.sub p.pfile 0 1) = "." in
- let file = if is_relative_path then Common.get_full_path p.pfile else p.pfile in
- if cur_line <> ((!last_line)+1) then begin print w "#line %d \"%s\"" cur_line (Ast.s_escape file); newline w end;
- last_line := cur_line
- in
- let rec extract_tparams params el =
- match el with
- | ({ eexpr = TLocal({ v_name = "$type_param" }) } as tp) :: tl ->
- extract_tparams (tp.etype :: params) tl
- | _ -> (params, el)
- in
- let expr_s w e =
- last_line := -1;
- in_value := false;
- let rec expr_s w e =
- let was_in_value = !in_value in
- in_value := true;
- (match e.eexpr with
- | TConst c ->
- (match c with
- | TInt i32 ->
- write w (Int32.to_string i32);
- (*match real_type e.etype with
- | TType( { t_path = (["haxe";"_Int64"], "NativeInt64") }, [] ) -> write w "L";
- | _ -> ()
- *)
- | TFloat s ->
- write w s;
- (if String.get s (String.length s - 1) = '.' then write w "0");
- (*match real_type e.etype with
- | TType( { t_path = ([], "Single") }, [] ) -> write w "f"
- | _ -> ()
- *)
- | TString s ->
- write w "\"";
- write w (escape s);
- write w "\""
- | TBool b -> write w (if b then "true" else "false")
- | TNull ->
- write w "default(";
- write w (t_s e.etype);
- write w ")"
- | TThis -> write w "this"
- | TSuper -> write w "base")
- | TLocal { v_name = "__sbreak__" } -> write w "break"
- | TLocal { v_name = "__undefined__" } ->
- write w (t_s (TInst(runtime_cl, List.map (fun _ -> t_dynamic) runtime_cl.cl_types)));
- write w ".undefined";
- | TLocal { v_name = "__typeof__" } -> write w "typeof"
- | TLocal { v_name = "__sizeof__" } -> write w "sizeof"
- | TLocal var ->
- write_id w var.v_name
- | TField (_, FEnum(e, ef)) ->
- let s = ef.ef_name in
- print w "%s." ("global::" ^ module_s (TEnumDecl e)); write_field w s
- | TArray (e1, e2) ->
- expr_s w e1; write w "["; expr_s w e2; write w "]"
- | TBinop ((Ast.OpAssign as op), e1, e2)
- | TBinop ((Ast.OpAssignOp _ as op), e1, e2) ->
- expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2
- | TBinop (op, e1, e2) ->
- write w "( ";
- expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2;
- write w " )"
- | TField ({ eexpr = TTypeExpr mt }, s) ->
- (match mt with
- | TClassDecl { cl_path = (["haxe"], "Int64") } -> write w ("global::" ^ module_s mt)
- | TClassDecl { cl_path = (["haxe"], "Int32") } -> write w ("global::" ^ module_s mt)
- | TClassDecl { cl_interface = true } ->
- write w ("global::" ^ module_s mt);
- write w "__Statics_";
- | TClassDecl cl -> write w (t_s (TInst(cl, List.map (fun _ -> t_empty) cl.cl_types)))
- | TEnumDecl en -> write w (t_s (TEnum(en, List.map (fun _ -> t_empty) en.e_types)))
- | TTypeDecl td -> write w (t_s (gen.gfollow#run_f (TType(td, List.map (fun _ -> t_empty) td.t_types))))
- | TAbstractDecl a -> write w (t_s (TAbstract(a, List.map (fun _ -> t_empty) a.a_types)))
- );
- write w ".";
- write_field w (field_name s)
- | TField (e, s) ->
- expr_s w e; write w "."; write_field w (field_name s)
- | TTypeExpr mt ->
- (match mt with
- | TClassDecl { cl_path = (["haxe"], "Int64") } -> write w ("global::" ^ module_s mt)
- | TClassDecl { cl_path = (["haxe"], "Int32") } -> write w ("global::" ^ module_s mt)
- | TClassDecl cl -> write w (t_s (TInst(cl, List.map (fun _ -> t_dynamic) cl.cl_types)))
- | TEnumDecl en -> write w (t_s (TEnum(en, List.map (fun _ -> t_dynamic) en.e_types)))
- | TTypeDecl td -> write w (t_s (gen.gfollow#run_f (TType(td, List.map (fun _ -> t_dynamic) td.t_types))))
- | TAbstractDecl a -> write w (t_s (TAbstract(a, List.map (fun _ -> t_dynamic) a.a_types)))
- )
- | TParenthesis e ->
- write w "("; expr_s w e; write w ")"
- | TArrayDecl el ->
- print w "new %s" (t_s e.etype);
- write w "{";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- expr_s w e;
- acc + 1
- ) 0 el);
- write w "}"
- | TCall ({ eexpr = TLocal( { v_name = "__is__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) ->
- write w "( ";
- expr_s w expr;
- write w " is ";
- write w (md_s md);
- write w " )"
- | TCall ({ eexpr = TLocal( { v_name = "__as__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) ->
- write w "( ";
- expr_s w expr;
- write w " as ";
- write w (md_s md);
- write w " )"
- | TCall ({ eexpr = TLocal( { v_name = "__as__" } ) }, [ expr ] ) ->
- write w "( ";
- expr_s w expr;
- write w " as ";
- write w (t_s e.etype);
- write w " )";
- | TCall ({ eexpr = TLocal( { v_name = "__cs__" } ) }, [ { eexpr = TConst(TString(s)) } ] ) ->
- write w s
- | TCall ({ eexpr = TLocal( { v_name = "__unsafe__" } ) }, [ e ] ) ->
- write w "unsafe";
- expr_s w (mk_block e)
- | TCall ({ eexpr = TLocal( { v_name = "__checked__" } ) }, [ e ] ) ->
- write w "checked";
- expr_s w (mk_block e)
- | TCall ({ eexpr = TLocal( { v_name = "__lock__" } ) }, [ eobj; eblock ] ) ->
- write w "lock(";
- expr_s w eobj;
- write w ")";
- expr_s w (mk_block eblock)
- | TCall ({ eexpr = TLocal( { v_name = "__fixed__" } ) }, [ e ] ) ->
- let first = ref true in
- let rec loop = function
- | ({ eexpr = TVars([v, Some({ eexpr = TCast( { eexpr = TCast(e, _) }, _) }) ]) } as expr) :: tl when is_pointer v.v_type ->
- (if !first then first := false);
- write w "fixed(";
- let vf = mk_temp gen "fixed" v.v_type in
- expr_s w { expr with eexpr = TVars([vf, Some e]) };
- write w ")";
- begin_block w;
- expr_s w { expr with eexpr = TVars([v, Some (mk_local vf expr.epos)]) };
- write w ";";
- loop tl;
- end_block w
- | el when not !first ->
- expr_s w { e with eexpr = TBlock el }
- | _ ->
- trace (debug_expr e);
- gen.gcon.error "Invalid 'fixed' keyword format" e.epos
- in
- (match e.eexpr with
- | TBlock bl -> loop bl
- | _ ->
- trace "not block";
- trace (debug_expr e);
- gen.gcon.error "Invalid 'fixed' keyword format" e.epos
- )
- | TCall ({ eexpr = TLocal( { v_name = "__addressOf__" } ) }, [ e ] ) ->
- let e = ensure_local e "for addressOf" in
- write w "&";
- expr_s w e
- | TCall ({ eexpr = TLocal( { v_name = "__valueOf__" } ) }, [ e ] ) ->
- write w "*(";
- expr_s w e;
- write w ")"
- | TCall ({ eexpr = TLocal( { v_name = "__goto__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
- print w "goto label%ld" v
- | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
- print w "label%ld: {}" v
- | TCall ({ eexpr = TLocal( { v_name = "__rethrow__" } ) }, _) ->
- write w "throw"
- (* operator overloading handling *)
- | TCall({ eexpr = TField(ef, FInstance(cl,{ cf_name = "__get" })) }, [idx]) when not (is_hxgen (TClassDecl cl)) ->
- expr_s w { e with eexpr = TArray(ef, idx) }
- | TCall({ eexpr = TField(ef, FInstance(cl,{ cf_name = "__set" })) }, [idx; v]) when not (is_hxgen (TClassDecl cl)) ->
- expr_s w { e with eexpr = TBinop(Ast.OpAssign, { e with eexpr = TArray(ef, idx) }, v) }
- | TCall({ eexpr = TField(ef, FStatic(_,cf)) }, el) when PMap.mem cf.cf_name binops_names ->
- let _, elr = extract_tparams [] el in
- (match elr with
- | [e1;e2] ->
- expr_s w { e with eexpr = TBinop(PMap.find cf.cf_name binops_names, e1, e2) }
- | _ -> do_call w e el)
- | TCall({ eexpr = TField(ef, FStatic(_,cf)) }, el) when PMap.mem cf.cf_name unops_names ->
- (match extract_tparams [] el with
- | _, [e1] ->
- expr_s w { e with eexpr = TUnop(PMap.find cf.cf_name unops_names, Ast.Prefix,e1) }
- | _ -> do_call w e el)
- | TCall (e, el) ->
- do_call w e el
- | TNew (({ cl_path = (["cs"], "NativeArray") } as cl), params, [ size ]) ->
- let rec check_t_s t times =
- match real_type t with
- | TInst({ cl_path = (["cs"], "NativeArray") }, [param]) ->
- (check_t_s param (times+1))
- | _ ->
- print w "new %s[" (t_s (run_follow gen t));
- expr_s w size;
- print w "]";
- let rec loop i =
- if i <= 0 then () else (write w "[]"; loop (i-1))
- in
- loop (times - 1)
- in
- check_t_s (TInst(cl, params)) 0
- | TNew ({ cl_path = ([], "String") } as cl, [], el) ->
- write w "new ";
- write w (t_s (TInst(cl, [])));
- write w "(";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- expr_s w e;
- acc + 1
- ) 0 el);
- write w ")"
- | TNew (cl, params, el) ->
- write w "new ";
- write w (path_param_s (TClassDecl cl) cl.cl_path params);
- write w "(";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- expr_s w e;
- acc + 1
- ) 0 el);
- write w ")"
- | TUnop ((Ast.Increment as op), flag, e)
- | TUnop ((Ast.Decrement as op), flag, e) ->
- (match flag with
- | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " " ); expr_s w e
- | Ast.Postfix -> expr_s w e; write w (Ast.s_unop op))
- | TUnop (op, flag, e) ->
- (match flag with
- | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " (" ); expr_s w e; write w ") "
- | Ast.Postfix -> write w "("; expr_s w e; write w (") " ^ Ast.s_unop op))
- | TVars (v_eop_l) ->
- ignore (List.fold_left (fun acc (var, eopt) ->
- (if acc <> 0 then write w ", ");
- print w "%s " (t_s var.v_type);
- write_id w var.v_name;
- (match eopt with
- | None ->
- write w " = ";
- expr_s w (null var.v_type e.epos)
- | Some e ->
- write w " = ";
- expr_s w e
- );
- acc + 1
- ) 0 v_eop_l);
- | TBlock [e] when was_in_value ->
- expr_s w e
- | TBlock el ->
- begin_block w;
- List.iter (fun e ->
- line_directive w e.epos;
- in_value := false;
- expr_s w e;
- (if has_semicolon e then write w ";");
- newline w
- ) el;
- end_block w
- | TIf (econd, e1, Some(eelse)) when was_in_value ->
- write w "( ";
- expr_s w (mk_paren econd);
- write w " ? ";
- expr_s w (mk_paren e1);
- write w " : ";
- expr_s w (mk_paren eelse);
- write w " )";
- | TIf (econd, e1, eelse) ->
- write w "if ";
- expr_s w (mk_paren econd);
- write w " ";
- in_value := false;
- expr_s w (mk_block e1);
- (match eelse with
- | None -> ()
- | Some e ->
- write w " else ";
- in_value := false;
- expr_s w (mk_block e)
- )
- | TWhile (econd, eblock, flag) ->
- (match flag with
- | Ast.NormalWhile ->
- write w "while ";
- expr_s w (mk_paren econd);
- write w "";
- in_value := false;
- expr_s w (mk_block eblock)
- | Ast.DoWhile ->
- write w "do ";
- in_value := false;
- expr_s w (mk_block eblock);
- write w "while ";
- in_value := true;
- expr_s w (mk_paren econd);
- )
- | TSwitch (econd, ele_l, default) ->
- write w "switch ";
- expr_s w (mk_paren econd);
- begin_block w;
- List.iter (fun (el, e) ->
- List.iter (fun e ->
- write w "case ";
- in_value := true;
- expr_s w e;
- write w ":";
- ) el;
- newline w;
- in_value := false;
- expr_s w (mk_block e);
- newline w;
- newline w
- ) ele_l;
- if is_some default then begin
- write w "default:";
- newline w;
- in_value := false;
- expr_s w (get default);
- newline w;
- end;
- end_block w
- | TTry (tryexpr, ve_l) ->
- write w "try ";
- in_value := false;
- expr_s w (mk_block tryexpr);
- List.iter (fun (var, e) ->
- print w "catch (%s %s)" (t_s var.v_type) (var.v_name);
- in_value := false;
- expr_s w (mk_block e);
- newline w
- ) ve_l
- | TReturn eopt ->
- write w "return ";
- if is_some eopt then expr_s w (get eopt)
- | TBreak -> write w "break"
- | TContinue -> write w "continue"
- | TThrow e ->
- write w "throw ";
- expr_s w e
- | TCast (e1,md_t) ->
- ((*match gen.gfollow#run_f e.etype with
- | TType({ t_path = ([], "UInt") }, []) ->
- write w "( unchecked ((uint) ";
- expr_s w e1;
- write w ") )"
- | _ ->*)
- (* FIXME I'm ignoring module type *)
- print w "((%s) (" (t_s e.etype);
- expr_s w e1;
- write w ") )"
- )
- | TFor (_,_,content) ->
- write w "[ for not supported ";
- expr_s w content;
- write w " ]";
- if !strict_mode then assert false
- | TObjectDecl _ -> write w "[ obj decl not supported ]"; if !strict_mode then assert false
- | TFunction _ -> write w "[ func decl not supported ]"; if !strict_mode then assert false
- | TMatch _ -> write w "[ match not supported ]"; if !strict_mode then assert false
- )
- and do_call w e el =
- let params, el = extract_tparams [] el in
- let params = List.rev params in
- expr_s w e;
- (match params with
- | [] -> ()
- | params ->
- let md = match e.eexpr with
- | TField(ef, _) -> t_to_md (run_follow gen ef.etype)
- | _ -> assert false
- in
- write w "<";
- ignore (List.fold_left (fun acc t ->
- (if acc <> 0 then write w ", ");
- write w (t_s t);
- acc + 1
- ) 0 (change_param_type md params));
- write w ">"
- );
- let rec loop acc elist tlist =
- match elist, tlist with
- | e :: etl, (_,_,t) :: ttl ->
- (if acc <> 0 then write w ", ");
- (match real_type t with
- | TType({ t_path = (["cs"], "Ref") }, _)
- | TAbstract ({ a_path = (["cs"], "Ref") },_) ->
- let e = ensure_local e "of type cs.Ref" in
- write w "ref ";
- expr_s w e
- | TType({ t_path = (["cs"], "Out") }, _)
- | TAbstract ({ a_path = (["cs"], "Out") },_) ->
- let e = ensure_local e "of type cs.Out" in
- write w "out ";
- expr_s w e
- | _ ->
- expr_s w e
- );
- loop (acc + 1) etl ttl
- | e :: etl, [] ->
- (if acc <> 0 then write w ", ");
- expr_s w e;
- loop (acc + 1) etl []
- | _ -> ()
- in
- write w "(";
- let ft = match follow e.etype with
- | TFun(args,_) -> args
- | _ -> []
- in
- loop 0 el ft;
- write w ")"
- in
- expr_s w e
- in
- let get_string_params cl_types =
- match cl_types with
- | [] ->
- ("","")
- | _ ->
- let params = sprintf "<%s>" (String.concat ", " (List.map (fun (_, tcl) -> match follow tcl with | TInst(cl, _) -> snd cl.cl_path | _ -> assert false) cl_types)) in
- let params_extends = List.fold_left (fun acc (name, t) ->
- match run_follow gen t with
- | TInst (cl, p) ->
- (match cl.cl_implements with
- | [] -> acc
- | _ -> acc) (* TODO
- | _ -> (sprintf " where %s : %s" name (String.concat ", " (List.map (fun (cl,p) -> path_param_s (TClassDecl cl) cl.cl_path p) cl.cl_implements))) :: acc ) *)
- | _ -> trace (t_s t); assert false (* FIXME it seems that a cl_types will never be anything other than cl.cl_types. I'll take the risk and fail if not, just to see if that confirms *)
- ) [] cl_types in
- (params, String.concat " " params_extends)
- in
- let rec gen_class_field w ?(is_overload=false) is_static cl is_final cf =
- let is_interface = cl.cl_interface in
- let name, is_new, is_explicit_iface = match cf.cf_name with
- | "new" -> snd cl.cl_path, true, false
- | name when String.contains name '.' ->
- let fn_name, path = parse_explicit_iface name in
- (path_s path) ^ "." ^ fn_name, false, true
- | name -> try
- let binop = PMap.find name binops_names in
- "operator " ^ s_binop binop, false, false
- with | Not_found -> try
- let unop = PMap.find name unops_names in
- "operator " ^ s_unop unop, false, false
- with | Not_found ->
- name, false, false
- in
- let rec loop_static cl =
- match is_static, cl.cl_super with
- | false, _ -> []
- | true, None -> []
- | true, Some(cl,_) ->
- (try
- let cf2 = PMap.find cf.cf_name cl.cl_statics in
- Gencommon.CastDetect.type_eq gen EqStrict cf.cf_type cf2.cf_type;
- ["new"]
- with
- | Not_found | Unify_error _ ->
- loop_static cl
- )
- in
- let modf = loop_static cl in
- (match cf.cf_kind with
- | Var _
- | Method (MethDynamic) when not (Type.is_extern_field cf) ->
- (if is_overload || List.exists (fun cf -> cf.cf_expr <> None) cf.cf_overloads then
- gen.gcon.error "Only normal (non-dynamic) methods can be overloaded" cf.cf_pos);
- if not is_interface then begin
- let access, modifiers = get_fun_modifiers cf.cf_meta "public" [] in
- let modifiers = modifiers @ modf in
- (match cf.cf_expr with
- | Some e ->
- print w "%s %s%s %s %s = " access (if is_static then "static " else "") (String.concat " " modifiers) (t_s (run_follow gen cf.cf_type)) (change_field name);
- expr_s w e;
- write w ";"
- | None ->
- print w "%s %s%s %s %s;" access (if is_static then "static " else "") (String.concat " " modifiers) (t_s (run_follow gen cf.cf_type)) (change_field name)
- )
- end (* TODO see how (get,set) variable handle when they are interfaces *)
- | Method _ when Type.is_extern_field cf || (match cl.cl_kind, cf.cf_expr with | KAbstractImpl _, None -> true | _ -> false) ->
- List.iter (fun cf -> if cl.cl_interface || cf.cf_expr <> None then
- gen_class_field w ~is_overload:true is_static cl (Meta.has Meta.Final cf.cf_meta) cf
- ) cf.cf_overloads
- | Var _ | Method MethDynamic -> ()
- | Method mkind ->
- List.iter (fun cf ->
- if cl.cl_interface || cf.cf_expr <> None then
- gen_class_field w ~is_overload:true is_static cl (Meta.has Meta.Final cf.cf_meta) cf
- ) cf.cf_overloads;
- let is_virtual = not is_final && match mkind with | MethInline -> false | _ when not is_new -> true | _ -> false in
- let is_virtual = if not is_virtual || Meta.has Meta.Final cf.cf_meta then false else is_virtual in
- let is_override = List.memq cf cl.cl_overrides in
- let is_override = is_override || match cf.cf_name, follow cf.cf_type with
- | "Equals", TFun([_,_,targ], tret) ->
- (match follow targ, follow tret with
- | TDynamic _, TEnum({ e_path = ([], "Bool") }, [])
- | TDynamic _, TAbstract({ a_path = ([], "Bool") }, []) -> true
- | _ -> false)
- | "GetHashCode", TFun([],_) -> true
- | _ -> false
- in
- let is_virtual = is_virtual && not (Meta.has Meta.Final cl.cl_meta) && not (is_interface) in
- let visibility = if is_interface then "" else "public" in
- let visibility, modifiers = get_fun_modifiers cf.cf_meta visibility [] in
- let modifiers = modifiers @ modf in
- let visibility, is_virtual = if is_explicit_iface then "",false else visibility, is_virtual in
- let v_n = if is_static then "static " else if is_override && not is_interface then "override " else if is_virtual then "virtual " else "" in
- let cf_type = if is_override && not is_overload && not (Meta.has Meta.Overload cf.cf_meta) then match field_access gen (TInst(cl, List.map snd cl.cl_types)) cf.cf_name with | FClassField(_,_,_,_,_,actual_t,_) -> actual_t | _ -> assert false else cf.cf_type in
- let ret_type, args = match follow cf_type with | TFun (strbtl, t) -> (t, strbtl) | _ -> assert false in
- (* public static void funcName *)
- print w "%s %s %s %s %s" (visibility) v_n (String.concat " " modifiers) (if is_new then "" else rett_s (run_follow gen ret_type)) (change_field name);
- let params, params_ext = get_string_params cf.cf_params in
- (* <T>(string arg1, object arg2) with T : object *)
- (match cf.cf_expr with
- | Some { eexpr = TFunction tf } ->
- print w "%s(%s)%s" (params) (String.concat ", " (List.map2 (fun (var, _) (_,_,t) -> sprintf "%s %s" (argt_s (run_follow gen t)) (change_id var.v_name)) tf.tf_args args)) (params_ext)
- | _ ->
- print w "%s(%s)%s" (params) (String.concat ", " (List.map (fun (name, _, t) -> sprintf "%s %s" (argt_s (run_follow gen t)) (change_id name)) args)) (params_ext)
- );
- if is_interface then
- write w ";"
- else begin
- let rec loop meta =
- match meta with
- | [] ->
- let expr = match cf.cf_expr with
- | None -> mk (TBlock([])) t_dynamic Ast.null_pos
- | Some s ->
- match s.eexpr with
- | TFunction tf ->
- mk_block (tf.tf_expr)
- | _ -> assert false (* FIXME *)
- in
- (if is_new then begin
- let rec get_super_call el =
- match el with
- | ( { eexpr = TCall( { eexpr = TConst(TSuper) }, _) } as call) :: rest ->
- Some call, rest
- | ( { eexpr = TBlock(bl) } as block ) :: rest ->
- let ret, mapped = get_super_call bl in
- ret, ( { block with eexpr = TBlock(mapped) } :: rest )
- | _ ->
- None, el
- in
- match expr.eexpr with
- | TBlock(bl) ->
- let super_call, rest = get_super_call bl in
- (match super_call with
- | None -> ()
- | Some sc ->
- write w " : ";
- let t = Common.timer "expression to string" in
- expr_s w sc;
- t()
- );
- begin_block w;
- write w "unchecked ";
- let t = Common.timer "expression to string" in
- expr_s w { expr with eexpr = TBlock(rest) };
- t();
- write w "#line default";
- end_block w;
- | _ -> assert false
- end else begin
- begin_block w;
- write w "unchecked ";
- let t = Common.timer "expression to string" in
- expr_s w expr;
- t();
- write w "#line default";
- end_block w;
- end)
- | (Meta.FunctionCode, [Ast.EConst (Ast.String contents),_],_) :: tl ->
- begin_block w;
- write w contents;
- end_block w
- | _ :: tl -> loop tl
- in
- loop cf.cf_meta
- end);
- newline w;
- newline w;
- in
- let check_special_behaviors w cl = match cl.cl_kind with
- | KAbstractImpl _ -> ()
- | _ ->
- (* get/set pairs *)
- let pairs = ref PMap.empty in
- (try
- let get = PMap.find "__get" cl.cl_fields in
- List.iter (fun cf ->
- let args,ret = get_fun cf.cf_type in
- match args with
- | [_,_,idx] -> pairs := PMap.add (t_s idx) ( t_s ret, Some cf, None ) !pairs
- | _ -> gen.gcon.warning "The __get function must have exactly one argument (the index)" cf.cf_pos
- ) (get :: get.cf_overloads)
- with | Not_found -> ());
- (try
- let set = PMap.find "__set" cl.cl_fields in
- List.iter (fun cf ->
- let args, ret = get_fun cf.cf_type in
- match args with
- | [_,_,idx; _,_,v] -> (try
- let vt, g, _ = PMap.find (t_s idx) !pairs in
- let tvt = t_s v in
- if vt <> tvt then gen.gcon.warning "The __get function of same index has a different type from this __set function" cf.cf_pos;
- pairs := PMap.add (t_s idx) (vt, g, Some cf) !pairs
- with | Not_found ->
- pairs := PMap.add (t_s idx) (t_s v, None, Some cf) !pairs)
- | _ ->
- gen.gcon.warning "The __set function must have exactly two arguments (index, value)" cf.cf_pos
- ) (set :: set.cf_overloads)
- with | Not_found -> ());
- PMap.iter (fun idx (v, get, set) ->
- print w "public %s this[%s index]" v idx;
- begin_block w;
- (match get with
- | None -> ()
- | Some _ ->
- write w "get";
- begin_block w;
- write w "return this.__get(index);";
- end_block w);
- (match set with
- | None -> ()
- | Some _ ->
- write w "set";
- begin_block w;
- write w "this.__set(index,value);";
- end_block w);
- end_block w) !pairs;
- (if not (PMap.is_empty !pairs) then try
- let get = PMap.find "__get" cl.cl_fields in
- let idx_t, v_t = match follow get.cf_type with
- | TFun([_,_,arg_t],ret_t) ->
- t_s (run_follow gen arg_t), t_s (run_follow gen ret_t)
- | _ -> gen.gcon.error "The __get function must be a function with one argument. " get.cf_pos; assert false
- in
- List.iter (fun (cl,args) ->
- match cl.cl_array_access with
- | None -> ()
- | Some t ->
- let changed_t = apply_params cl.cl_types (List.map (fun _ -> t_dynamic) cl.cl_types) t in
- let t_as_s = t_s (run_follow gen changed_t) in
- print w "%s %s.this[int key]" t_as_s (t_s (TInst(cl, args)));
- begin_block w;
- write w "get";
- begin_block w;
- print w "return ((%s) this.__get(key));" t_as_s;
- end_block w;
- write w "set";
- begin_block w;
- print w "this.__set(key, (%s) value);" v_t;
- end_block w;
- end_block w;
- newline w;
- newline w
- ) cl.cl_implements
- with | Not_found -> ());
- if cl.cl_interface && is_hxgen (TClassDecl cl) && is_some cl.cl_array_access then begin
- let changed_t = apply_params cl.cl_types (List.map (fun _ -> t_dynamic) cl.cl_types) (get cl.cl_array_access) in
- print w "%s this[int key]" (t_s (run_follow gen changed_t));
- begin_block w;
- write w "get;";
- newline w;
- write w "set;";
- newline w;
- end_block w;
- newline w;
- newline w
- end;
- (try
- if cl.cl_interface then raise Not_found;
- let cf = PMap.find "toString" cl.cl_fields in
- (if List.exists (fun c -> c.cf_name = "toString") cl.cl_overrides then raise Not_found);
- (match cf.cf_type with
- | TFun([], ret) ->
- (match real_type ret with
- | TInst( { cl_path = ([], "String") }, []) ->
- write w "public override string ToString()";
- begin_block w;
- write w "return this.toString();";
- end_block w;
- newline w;
- newline w
- | _ ->
- gen.gcon.error "A toString() function should return a String!" cf.cf_pos
- )
- | _ -> ()
- )
- with | Not_found -> ());
- (* properties *
- let handle_prop static f =
- match f.cf_kind with
- | Method _ -> ()
- | Var v when not (Type.is_extern_field f) -> ()
- | Var v ->
- let prop acc = match acc with
- | AccNo | AccNever | AccCall -> true
- | _ -> false
- in
- if prop v.v_read && prop v.v_write && (v.v_read = AccCall || v.v_write = AccCall) then begin
- let this = if static then
- mk_classtype_access cl f.cf_pos
- else
- { eexpr = TConst TThis; etype = TInst(cl,List.map snd cl.cl_types); epos = f.cf_pos }
- in
- print w "public %s%s %s" (if static then "static " else "") (t_s f.cf_type) f.cf_name;
- begin_block w;
- (match v.v_read with
- | AccCall ->
- write w "get";
- begin_block w;
- write w "return ";
- expr_s w this;
- print w ".get_%s();" f.cf_name;
- end_block w
- | _ -> ());
- (match v.v_write with
- | AccCall ->
- write w "set";
- begin_block w;
- expr_s w this;
- print w ".set_%s(value);" f.cf_name;
- end_block w
- | _ -> ());
- end_block w;
- end
- in
- List.iter (handle_prop true) cl.cl_ordered_statics;
- List.iter (handle_prop false) cl.cl_ordered_fields *)
- in
- let gen_class w cl =
- write w "#pragma warning disable 109, 114, 219, 429, 168, 162";
- newline w;
- let should_close = match change_ns (TClassDecl cl) (fst (cl.cl_path)) with
- | [] -> false
- | ns ->
- print w "namespace %s" (String.concat "." ns);
- begin_block w;
- true
- in
- let is_main =
- match gen.gcon.main_class with
- | Some ( (_,"Main") as path) when path = cl.cl_path && not cl.cl_interface ->
- (*
- for cases where the main class is called Main, there will be a problem with creating the entry point there.
- In this special case, a special entry point class will be created
- *)
- write w "public class EntryPoint__Main";
- begin_block w;
- write w "public static void Main()";
- begin_block w;
- (if Hashtbl.mem gen.gtypes (["cs"], "Boot") then write w "cs.Boot.init();"; newline w);
- expr_s w { eexpr = TTypeExpr(TClassDecl cl); etype = t_dynamic; epos = Ast.null_pos };
- write w ".main();";
- end_block w;
- end_block w;
- false
- | Some path when path = cl.cl_path && not cl.cl_interface -> true
- | _ -> false
- in
- let clt, access, modifiers = get_class_modifiers cl.cl_meta (if cl.cl_interface then "interface" else "class") "public" [] in
- let is_final = clt = "struct" || Meta.has Meta.Final cl.cl_meta in
- print w "%s %s %s %s" access (String.concat " " modifiers) clt (change_clname (snd cl.cl_path));
- (* type parameters *)
- let params, params_ext = get_string_params cl.cl_types in
- let extends_implements = (match cl.cl_super with | None -> [] | Some (cl,p) -> [path_param_s (TClassDecl cl) cl.cl_path p]) @ (List.map (fun (cl,p) -> path_param_s (TClassDecl cl) cl.cl_path p) cl.cl_implements) in
- (match extends_implements with
- | [] -> print w "%s %s" params params_ext
- | _ -> print w "%s : %s %s" params (String.concat ", " extends_implements) params_ext);
- (* class head ok: *)
- (* public class Test<A> : X, Y, Z where A : Y *)
- begin_block w;
- (* our constructor is expected to be a normal "new" function *
- if !strict_mode && is_some cl.cl_constructor then assert false;*)
- let rec loop meta =
- match meta with
- | [] -> ()
- | (Meta.ClassCode, [Ast.EConst (Ast.String contents),_],_) :: tl ->
- write w contents
- | _ :: tl -> loop tl
- in
- loop cl.cl_meta;
- if is_main then begin
- write w "public static void Main()";
- begin_block w;
- (if Hashtbl.mem gen.gtypes (["cs"], "Boot") then write w "cs.Boot.init();"; newline w);
- write w "main();";
- end_block w
- end;
- (match cl.cl_init with
- | None -> ()
- | Some init ->
- print w "static %s() " (snd cl.cl_path);
- expr_s w (mk_block init));
- (if is_some cl.cl_constructor then gen_class_field w false cl is_final (get cl.cl_constructor));
- if not cl.cl_interface then List.iter (gen_class_field w true cl is_final) cl.cl_ordered_statics;
- List.iter (gen_class_field w false cl is_final) cl.cl_ordered_fields;
- check_special_behaviors w cl;
- end_block w;
- if cl.cl_interface && cl.cl_ordered_statics <> [] then begin
- print w "public class %s__Statics_" (snd cl.cl_path);
- begin_block w;
- List.iter (gen_class_field w true { cl with cl_interface = false } is_final) cl.cl_ordered_statics;
- end_block w
- end;
- if should_close then end_block w
- in
- let gen_enum w e =
- let should_close = match change_ns (TEnumDecl e) (fst e.e_path) with
- | [] -> false
- | ns ->
- print w "namespace %s" (String.concat "." ns);
- begin_block w;
- true
- in
- print w "public enum %s" (change_clname (snd e.e_path));
- begin_block w;
- write w (String.concat ", " (List.map (change_id) e.e_names));
- end_block w;
- if should_close then end_block w
- in
- let module_type_gen w md_tp =
- match md_tp with
- | TClassDecl cl ->
- if not cl.cl_extern then begin
- (if no_root && len w = 0 then write w "using haxe.root;"; newline w;);
- gen_class w cl;
- newline w;
- newline w
- end;
- (not cl.cl_extern)
- | TEnumDecl e ->
- if not e.e_extern then begin
- (if no_root && len w = 0 then write w "using haxe.root;"; newline w;);
- gen_enum w e;
- newline w;
- newline w
- end;
- (not e.e_extern)
- | TAbstractDecl _
- | TTypeDecl _ ->
- false
- in
- let module_gen w md_def =
- List.fold_left (fun should md -> module_type_gen w md or should) false md_def.m_types
- in
- (* generate source code *)
- init_ctx gen;
- Hashtbl.add gen.gspecial_vars "__rethrow__" true;
- Hashtbl.add gen.gspecial_vars "__typeof__" true;
- Hashtbl.add gen.gspecial_vars "__label__" true;
- Hashtbl.add gen.gspecial_vars "__goto__" true;
- Hashtbl.add gen.gspecial_vars "__is__" true;
- Hashtbl.add gen.gspecial_vars "__as__" true;
- Hashtbl.add gen.gspecial_vars "__cs__" true;
- Hashtbl.add gen.gspecial_vars "__checked__" true;
- Hashtbl.add gen.gspecial_vars "__lock__" true;
- Hashtbl.add gen.gspecial_vars "__fixed__" true;
- Hashtbl.add gen.gspecial_vars "__unsafe__" true;
- Hashtbl.add gen.gspecial_vars "__addressOf__" true;
- Hashtbl.add gen.gspecial_vars "__valueOf__" true;
- Hashtbl.add gen.gspecial_vars "__sizeof__" true;
- Hashtbl.add gen.gsupported_conversions (["haxe"; "lang"], "Null") (fun t1 t2 -> true);
- let last_needs_box = gen.gneeds_box in
- gen.gneeds_box <- (fun t -> match t with | TInst( { cl_path = (["haxe"; "lang"], "Null") }, _ ) -> true | _ -> last_needs_box t);
- gen.greal_type <- real_type;
- gen.greal_type_param <- change_param_type;
- SetHXGen.run_filter gen SetHXGen.default_hxgen_func;
- (* before running the filters, follow all possible types *)
- (* this is needed so our module transformations don't break some core features *)
- (* like multitype selection *)
- let run_follow_gen = run_follow gen in
- let rec type_map e = Type.map_expr_type (fun e->type_map e) (run_follow_gen) (fun tvar-> tvar.v_type <- (run_follow_gen tvar.v_type); tvar) e in
- let super_map (cl,tl) = (cl, List.map run_follow_gen tl) in
- List.iter (function
- | TClassDecl cl ->
- let all_fields = (Option.map_default (fun cf -> [cf]) [] cl.cl_constructor) @ cl.cl_ordered_fields @ cl.cl_ordered_statics in
- List.iter (fun cf ->
- cf.cf_type <- run_follow_gen cf.cf_type;
- cf.cf_expr <- Option.map type_map cf.cf_expr
- ) all_fields;
- cl.cl_dynamic <- Option.map run_follow_gen cl.cl_dynamic;
- cl.cl_array_access <- Option.map run_follow_gen cl.cl_array_access;
- cl.cl_init <- Option.map type_map cl.cl_init;
- cl.cl_super <- Option.map super_map cl.cl_super;
- cl.cl_implements <- List.map super_map cl.cl_implements
- | _ -> ()
- ) gen.gcon.types;
- let closure_t = ClosuresToClass.DoubleAndDynamicClosureImpl.get_ctx gen 6 in
- (*let closure_t = ClosuresToClass.create gen 10 float_cl
- (fun l -> l)
- (fun l -> l)
- (fun args -> args)
- (fun args -> [])
- in
- ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (fun e _ _ -> e));
- StubClosureImpl.configure gen (StubClosureImpl.default_implementation gen float_cl 10 (fun e _ _ -> e));*)
- let tp_v = alloc_var "$type_param" t_dynamic in
- let mk_tp t pos = { eexpr = TLocal(tp_v); etype = t; epos = pos } in
- TypeParams.configure gen (fun ecall efield params elist ->
- match efield.eexpr with
- | TField(_, FEnum _) ->
- { ecall with eexpr = TCall(efield, elist) }
- | _ ->
- { ecall with eexpr = TCall(efield, (List.map (fun t -> mk_tp t ecall.epos ) params) @ elist) }
- );
- HardNullableSynf.configure gen (HardNullableSynf.traverse gen
- (fun e ->
- match real_type e.etype with
- | TInst({ cl_path = (["haxe";"lang"], "Null") }, [t]) ->
- { (mk_field_access gen e "value" e.epos) with etype = t }
- | _ ->
- trace (debug_type e.etype); gen.gcon.error "This expression is not a Nullable expression" e.epos; assert false
- )
- (fun v t has_value ->
- match has_value, real_type v.etype with
- | true, TDynamic _ | true, TAnon _ | true, TMono _ ->
- {
- eexpr = TCall(mk_static_field_access_infer null_t "ofDynamic" v.epos [t], [mk_tp t v.epos; v]);
- etype = TInst(null_t, [t]);
- epos = v.epos
- }
- | _ ->
- { eexpr = TNew(null_t, [t], [gen.ghandle_cast t v.etype v; { eexpr = TConst(TBool has_value); etype = gen.gcon.basic.tbool; epos = v.epos } ]); etype = TInst(null_t, [t]); epos = v.epos }
- )
- (fun e ->
- {
- eexpr = TCall(
- { (mk_field_access gen { (mk_paren e) with etype = real_type e.etype } "toDynamic" e.epos) with etype = TFun([], t_dynamic) },
- []);
- etype = t_dynamic;
- epos = e.epos
- }
- )
- (fun e ->
- mk_field_access gen { e with etype = real_type e.etype } "hasValue" e.epos
- )
- (fun e1 e2 ->
- {
- eexpr = TCall(
- mk_field_access gen e1 "Equals" e1.epos,
- [e2]);
- etype = basic.tbool;
- epos = e1.epos;
- }
- )
- true
- false
- );
- let explicit_fn_name c tl fname =
- path_param_s (TClassDecl c) c.cl_path tl ^ "." ^ fname
- in
- FixOverrides.configure ~explicit_fn_name:explicit_fn_name gen;
- NormalizeType.configure gen;
- AbstractImplementationFix.configure gen;
- IteratorsInterface.configure gen (fun e -> e);
- OverrideFix.configure gen;
- ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (get_cl (get_type gen (["haxe";"lang"],"Function")) ));
- EnumToClass.configure gen (Some (fun e -> mk_cast gen.gcon.basic.tint e)) false true (get_cl (get_type gen (["haxe";"lang"],"Enum")) ) true false;
- InterfaceVarsDeleteModf.configure gen;
- let dynamic_object = (get_cl (get_type gen (["haxe";"lang"],"DynamicObject")) ) in
- let object_iface = get_cl (get_type gen (["haxe";"lang"],"IHxObject")) in
- (*fixme: THIS IS A HACK. take this off *)
- let empty_e = match (get_type gen (["haxe";"lang"], "EmptyObject")) with | TEnumDecl e -> e | _ -> assert false in
- (*OverloadingCtor.set_new_create_empty gen ({eexpr=TEnumField(empty_e, "EMPTY"); etype=TEnum(empty_e,[]); epos=null_pos;});*)
- let empty_expr = { eexpr = (TTypeExpr (TEnumDecl empty_e)); etype = (TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics empty_e) }); epos = null_pos } in
- let empty_ef =
- try
- PMap.find "EMPTY" empty_e.e_constrs
- with Not_found -> gen.gcon.error "Required enum field EMPTY was not found" empty_e.e_pos; assert false
- in
- OverloadingConstructor.configure ~empty_ctor_type:(TEnum(empty_e, [])) ~empty_ctor_expr:({ eexpr=TField(empty_expr, FEnum(empty_e, empty_ef)); etype=TEnum(empty_e,[]); epos=null_pos; }) ~supports_ctor_inheritance:false gen;
- let rcf_static_find = mk_static_field_access_infer (get_cl (get_type gen (["haxe";"lang"], "FieldLookup"))) "findHash" Ast.null_pos [] in
- let rcf_static_lookup = mk_static_field_access_infer (get_cl (get_type gen (["haxe";"lang"], "FieldLookup"))) "lookupHash" Ast.null_pos [] in
- let can_be_float = like_float in
- let rcf_on_getset_field main_expr field_expr field may_hash may_set is_unsafe =
- let is_float = can_be_float (real_type main_expr.etype) in
- let fn_name = if is_some may_set then "setField" else "getField" in
- let fn_name = if is_float then fn_name ^ "_f" else fn_name in
- let pos = field_expr.epos in
- let is_unsafe = { eexpr = TConst(TBool is_unsafe); etype = basic.tbool; epos = pos } in
- let should_cast = match main_expr.etype with | TInst({ cl_path = ([], "Float") }, []) -> false | _ -> true in
- let infer = mk_static_field_access_infer runtime_cl fn_name field_expr.epos [] in
- let first_args =
- [ field_expr; { eexpr = TConst(TString field); etype = basic.tstring; epos = pos } ]
- @ if is_some may_hash then [ { eexpr = TConst(TInt (get may_hash)); etype = basic.tint; epos = pos } ] else []
- in
- let args = first_args @ match is_float, may_set with
- | true, Some(set) ->
- [ if should_cast then mk_cast basic.tfloat set else set ]
- | false, Some(set) ->
- [ set ]
- | _ ->
- [ is_unsafe ]
- in
- let call = { main_expr with eexpr = TCall(infer,args) } in
- let call = if is_float && should_cast then mk_cast main_expr.etype call else call in
- call
- in
- let rcf_on_call_field ecall field_expr field may_hash args =
- let infer = mk_static_field_access_infer runtime_cl "callField" field_expr.epos [] in
- let hash_arg = match may_hash with
- | None -> []
- | Some h -> [ { eexpr = TConst(TInt h); etype = basic.tint; epos = field_expr.epos } ]
- in
- let arr_call = if args <> [] then
- { eexpr = TArrayDecl args; etype = basic.tarray t_dynamic; epos = ecall.epos }
- else
- null (basic.tarray t_dynamic) ecall.epos
- in
- let call_args =
- [field_expr; { field_expr with eexpr = TConst(TString field); etype = basic.tstring } ]
- @ hash_arg
- @ [ arr_call ]
- in
- mk_cast ecall.etype { ecall with eexpr = TCall(infer, call_args) }
- in
- handle_type_params gen ifaces (get_cl (get_type gen (["haxe";"lang"], "IGenericObject")));
- let rcf_ctx = ReflectionCFs.new_ctx gen closure_t object_iface true rcf_on_getset_field rcf_on_call_field (fun hash hash_array ->
- { hash with eexpr = TCall(rcf_static_find, [hash; hash_array]); etype=basic.tint }
- ) (fun hash -> { hash with eexpr = TCall(rcf_static_lookup, [hash]); etype = gen.gcon.basic.tstring } ) false in
- ReflectionCFs.UniversalBaseClass.default_config gen (get_cl (get_type gen (["haxe";"lang"],"HxObject")) ) object_iface dynamic_object;
- ReflectionCFs.configure_dynamic_field_access rcf_ctx false;
- (* let closure_func = ReflectionCFs.implement_closure_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"],"Closure")) ) in *)
- let closure_cl = get_cl (get_type gen (["haxe";"lang"],"Closure")) in
- let varargs_cl = get_cl (get_type gen (["haxe";"lang"],"VarArgsFunction")) in
- let dynamic_name = gen.gmk_internal_name "hx" "invokeDynamic" in
- List.iter (fun cl ->
- List.iter (fun cf ->
- if cf.cf_name = dynamic_name then cl.cl_overrides <- cf :: cl.cl_overrides
- ) cl.cl_ordered_fields
- ) [closure_cl; varargs_cl];
- let closure_func = ReflectionCFs.get_closure_func rcf_ctx closure_cl in
- ReflectionCFs.implement_varargs_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"], "VarArgsBase")) );
- let slow_invoke = mk_static_field_access_infer (runtime_cl) "slowCallField" Ast.null_pos [] in
- ReflectionCFs.configure rcf_ctx ~slow_invoke:(fun ethis efield eargs -> {
- eexpr = TCall(slow_invoke, [ethis; efield; eargs]);
- etype = t_dynamic;
- epos = ethis.epos;
- } ) object_iface;
- let objdecl_fn = ReflectionCFs.implement_dynamic_object_ctor rcf_ctx dynamic_object in
- ObjectDeclMap.configure gen (ObjectDeclMap.traverse gen objdecl_fn);
- InitFunction.configure gen true;
- TArrayTransform.configure gen (TArrayTransform.default_implementation gen (
- fun e ->
- match e.eexpr with
- | TArray(e1, e2) ->
- ( match follow e1.etype with
- | TDynamic _ | TAnon _ | TMono _ -> true
- | TInst({ cl_kind = KTypeParameter _ }, _) -> true
- | _ -> false )
- | _ -> assert false
- ) "__get" "__set" );
- let field_is_dynamic t field =
- match field_access gen (gen.greal_type t) field with
- | FEnumField _
- | FClassField _ -> false
- | _ -> true
- in
- let is_type_param e = match follow e with
- | TInst( { cl_kind = KTypeParameter _ },[]) -> true
- | _ -> false
- in
- let is_dynamic_expr e = is_dynamic e.etype || match e.eexpr with
- | TField(tf, f) -> field_is_dynamic tf.etype (field_name f)
- | _ -> false
- in
- let may_nullable t = match gen.gfollow#run_f t with
- | TType({ t_path = ([], "Null") }, [t]) ->
- (match follow t with
- | TInst({ cl_path = ([], "String") }, [])
- | TInst({ cl_path = ([], "Float") }, [])
- | TAbstract ({ a_path = ([], "Float") },[])
- | TInst({ cl_path = (["haxe"], "Int32")}, [] )
- | TInst({ cl_path = (["haxe"], "Int64")}, [] )
- | TInst({ cl_path = ([], "Int") }, [])
- | TAbstract ({ a_path = ([], "Int") },[])
- | TEnum({ e_path = ([], "Bool") }, [])
- | TAbstract ({ a_path = ([], "Bool") },[]) -> Some t
- | TAbstract _ when like_float t -> Some t
- | _ -> None )
- | _ -> None
- in
- let is_double t = like_float t && not (like_int t) in
- let is_int t = like_int t in
- let is_null t = match real_type t with
- | TInst( { cl_path = (["haxe";"lang"], "Null") }, _ ) -> true
- | _ -> false
- in
- let is_null_expr e = is_null e.etype || match e.eexpr with
- | TField(tf, f) -> (match field_access gen (real_type tf.etype) (field_name f) with
- | FClassField(_,_,_,_,_,actual_t,_) -> is_null actual_t
- | _ -> false)
- | _ -> false
- in
- let should_handle_opeq t =
- match real_type t with
- | TDynamic _ | TAnon _ | TMono _
- | TInst( { cl_kind = KTypeParameter _ }, _ )
- | TInst( { cl_path = (["haxe";"lang"], "Null") }, _ ) -> true
- | _ -> false
- in
- let string_cl = match gen.gcon.basic.tstring with
- | TInst(c,[]) -> c
- | _ -> assert false
- in
- DynamicOperators.configure gen
- (DynamicOperators.abstract_implementation gen (fun e -> match e.eexpr with
- | TBinop (Ast.OpEq, e1, e2)
- | TBinop (Ast.OpNotEq, e1, e2) -> should_handle_opeq e1.etype or should_handle_opeq e2.etype
- | TBinop (Ast.OpAssignOp Ast.OpAdd, e1, e2) ->
- is_dynamic_expr e1 || is_null_expr e1 || is_string e.etype
- | TBinop (Ast.OpAdd, e1, e2) -> is_dynamic e1.etype or is_dynamic e2.etype or is_type_param e1.etype or is_type_param e2.etype or is_string e1.etype or is_string e2.etype or is_string e.etype
- | TBinop (Ast.OpLt, e1, e2)
- | TBinop (Ast.OpLte, e1, e2)
- | TBinop (Ast.OpGte, e1, e2)
- | TBinop (Ast.OpGt, e1, e2) -> is_dynamic e.etype or is_dynamic_expr e1 or is_dynamic_expr e2 or is_string e1.etype or is_string e2.etype
- | TBinop (_, e1, e2) -> is_dynamic e.etype or is_dynamic_expr e1 or is_dynamic_expr e2
- | TUnop (_, _, e1) -> is_dynamic_expr e1 || is_null_expr e1 (* we will see if the expression is Null<T> also, as the unwrap from Unop will be the same *)
- | _ -> false)
- (fun e1 e2 ->
- let is_basic = is_cs_basic_type (follow e1.etype) || is_cs_basic_type (follow e2.etype) in
- let is_ref = if is_basic then false else match follow e1.etype, follow e2.etype with
- | TDynamic _, _
- | _, TDynamic _
- | TInst( { cl_path = ([], "String") }, [] ), _
- | _, TInst( { cl_path = ([], "String") }, [] )
- | TInst( { cl_kind = KTypeParameter _ }, [] ), _
- | _, TInst( { cl_kind = KTypeParameter _ }, [] ) -> false
- | _, _ -> true
- in
- let static = mk_static_field_access_infer (runtime_cl) (if is_ref then "refEq" else "eq") e1.epos [] in
- { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tbool; epos=e1.epos }
- )
- (fun e e1 e2 ->
- match may_nullable e1.etype, may_nullable e2.etype with
- | Some t1, Some t2 ->
- let t1, t2 = if is_string t1 || is_string t2 then
- basic.tstring, basic.tstring
- else if is_double t1 || is_double t2 then
- basic.tfloat, basic.tfloat
- else if is_int t1 || is_int t2 then
- basic.tint, basic.tint
- else t1, t2 in
- { eexpr = TBinop(Ast.OpAdd, mk_cast t1 e1, mk_cast t2 e2); etype = e.etype; epos = e1.epos }
- | _ when is_string e.etype || is_string e1.etype || is_string e2.etype ->
- {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl "concat" e.epos [],
- [ e1; e2 ]
- );
- etype = basic.tstring;
- epos = e.epos
- }
- | _ ->
- let static = mk_static_field_access_infer (runtime_cl) "plus" e1.epos [] in
- mk_cast e.etype { eexpr = TCall(static, [e1; e2]); etype = t_dynamic; epos=e1.epos })
- (fun e1 e2 ->
- if is_string e1.etype then begin
- { e1 with eexpr = TCall(mk_static_field_access_infer string_cl "Compare" e1.epos [], [ e1; e2 ]); etype = gen.gcon.basic.tint }
- end else begin
- let static = mk_static_field_access_infer (runtime_cl) "compare" e1.epos [] in
- { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tint; epos=e1.epos }
- end) ~handle_strings:false);
- FilterClosures.configure gen (FilterClosures.traverse gen (fun e1 s -> true) closure_func);
- let base_exception = get_cl (get_type gen (["System"], "Exception")) in
- let base_exception_t = TInst(base_exception, []) in
- let hx_exception = get_cl (get_type gen (["haxe";"lang"], "HaxeException")) in
- let hx_exception_t = TInst(hx_exception, []) in
- let rec is_exception t =
- match follow t with
- | TInst(cl,_) ->
- if cl == base_exception then
- true
- else
- (match cl.cl_super with | None -> false | Some (cl,arg) -> is_exception (TInst(cl,arg)))
- | _ -> false
- in
- TryCatchWrapper.configure gen
- (
- TryCatchWrapper.traverse gen
- (fun t -> not (is_exception (real_type t)))
- (fun throwexpr expr ->
- let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], base_exception_t)) expr.epos in
- { throwexpr with eexpr = TThrow { expr with eexpr = TCall(wrap_static, [expr]); etype = hx_exception_t }; etype = gen.gcon.basic.tvoid }
- )
- (fun v_to_unwrap pos ->
- let local = mk_cast hx_exception_t { eexpr = TLocal(v_to_unwrap); etype = v_to_unwrap.v_type; epos = pos } in
- mk_field_access gen local "obj" pos
- )
- (fun rethrow ->
- { rethrow with eexpr = TCall(mk_local (alloc_var "__rethrow__" t_dynamic) rethrow.epos, [rethrow]); etype = gen.gcon.basic.tvoid }
- )
- (base_exception_t)
- (hx_exception_t)
- (fun v e -> e)
- );
- let get_typeof e =
- { e with eexpr = TCall( { eexpr = TLocal( alloc_var "__typeof__" t_dynamic ); etype = t_dynamic; epos = e.epos }, [e] ) }
- in
- ClassInstance.configure gen (ClassInstance.traverse gen (fun e mt ->
- get_typeof e
- ));
- CastDetect.configure gen (CastDetect.default_implementation gen (Some (TEnum(empty_e, []))) true ~native_string_cast:false ~overloads_cast_to_base:true);
- (*FollowAll.configure gen;*)
- SwitchToIf.configure gen (SwitchToIf.traverse gen (fun e ->
- match e.eexpr with
- | TSwitch(cond, cases, def) ->
- (match gen.gfollow#run_f cond.etype with
- | TInst({ cl_path = ([], "Int") },[])
- | TAbstract ({ a_path = ([], "Int") },[])
- | TInst({ cl_path = ([], "String") },[]) ->
- (List.exists (fun (c,_) ->
- List.exists (fun expr -> match expr.eexpr with | TConst _ -> false | _ -> true ) c
- ) cases)
- | _ -> true
- )
- | _ -> assert false
- ) true ) ;
- ExpressionUnwrap.configure gen (ExpressionUnwrap.traverse gen (fun e -> Some { eexpr = TVars([mk_temp gen "expr" e.etype, Some e]); etype = gen.gcon.basic.tvoid; epos = e.epos }));
- UnnecessaryCastsRemoval.configure gen;
- IntDivisionSynf.configure gen (IntDivisionSynf.default_implementation gen true);
- UnreachableCodeEliminationSynf.configure gen (UnreachableCodeEliminationSynf.traverse gen false true true false);
- let native_arr_cl = get_cl ( get_type gen (["cs"], "NativeArray") ) in
- ArrayDeclSynf.configure gen (ArrayDeclSynf.default_implementation gen native_arr_cl);
- let goto_special = alloc_var "__goto__" t_dynamic in
- let label_special = alloc_var "__label__" t_dynamic in
- SwitchBreakSynf.configure gen (SwitchBreakSynf.traverse gen
- (fun e_loop n api ->
- api ({ eexpr = TCall( mk_local label_special e_loop.epos, [ mk_int gen n e_loop.epos ] ); etype = t_dynamic; epos = e_loop.epos }) false;
- e_loop
- )
- (fun e_break n api ->
- { eexpr = TCall( mk_local goto_special e_break.epos, [ mk_int gen n e_break.epos ] ); etype = t_dynamic; epos = e_break.epos }
- )
- );
- DefaultArguments.configure gen (DefaultArguments.traverse gen);
- CSharpSpecificSynf.configure gen (CSharpSpecificSynf.traverse gen runtime_cl);
- CSharpSpecificESynf.configure gen (CSharpSpecificESynf.traverse gen runtime_cl);
- let mkdir dir = if not (Sys.file_exists dir) then Unix.mkdir dir 0o755 in
- mkdir gen.gcon.file;
- mkdir (gen.gcon.file ^ "/src");
- (* add resources array *)
- (try
- let res = get_cl (Hashtbl.find gen.gtypes (["haxe"], "Resource")) in
- mkdir (gen.gcon.file ^ "/src/Resources");
- let cf = PMap.find "content" res.cl_statics in
- let res = ref [] in
- Hashtbl.iter (fun name v ->
- res := { eexpr = TConst(TString name); etype = gen.gcon.basic.tstring; epos = Ast.null_pos } :: !res;
- let f = open_out (gen.gcon.file ^ "/src/Resources/" ^ name) in
- output_string f v;
- close_out f
- ) gen.gcon.resources;
- cf.cf_expr <- Some ({ eexpr = TArrayDecl(!res); etype = gen.gcon.basic.tarray gen.gcon.basic.tstring; epos = Ast.null_pos })
- with | Not_found -> ());
- run_filters gen;
- (* after the filters have been run, add all hashed fields to FieldLookup *)
- let normalize_i i =
- let i = Int32.of_int (i) in
- if i < Int32.zero then
- Int32.logor (Int32.logand i (Int32.of_int 0x3FFFFFFF)) (Int32.shift_left Int32.one 30)
- else i
- in
- let hashes = Hashtbl.fold (fun i s acc -> (normalize_i i,s) :: acc) rcf_ctx.rcf_hash_fields [] in
- let hashes = List.sort (fun (i,s) (i2,s2) -> compare i i2) hashes in
- let flookup_cl = get_cl (get_type gen (["haxe";"lang"], "FieldLookup")) in
- (try
- let basic = gen.gcon.basic in
- let change_array = ArrayDeclSynf.default_implementation gen native_arr_cl in
- let cl = flookup_cl in
- let field_ids = PMap.find "fieldIds" cl.cl_statics in
- let fields = PMap.find "fields" cl.cl_statics in
- field_ids.cf_expr <- Some (change_array {
- eexpr = TArrayDecl(List.map (fun (i,s) -> { eexpr = TConst(TInt (i)); etype = basic.tint; epos = field_ids.cf_pos }) hashes);
- etype = basic.tarray basic.tint;
- epos = field_ids.cf_pos
- });
- fields.cf_expr <- Some (change_array {
- eexpr = TArrayDecl(List.map (fun (i,s) -> { eexpr = TConst(TString s); etype = basic.tstring; epos = fields.cf_pos }) hashes);
- etype = basic.tarray basic.tstring;
- epos = fields.cf_pos
- })
- with | Not_found ->
- gen.gcon.error "Fields 'fieldIds' and 'fields' were not found in class haxe.lang.FieldLookup" flookup_cl.cl_pos
- );
- TypeParams.RenameTypeParameters.run gen;
- let t = Common.timer "code generation" in
- generate_modules gen "cs" "src" module_gen;
- dump_descriptor gen ("hxcs_build.txt") path_s module_s;
- if ( not (Common.defined gen.gcon Define.NoCompilation) ) then begin
- let old_dir = Sys.getcwd() in
- Sys.chdir gen.gcon.file;
- let cmd = "haxelib run hxcs hxcs_build.txt --haxe-version " ^ (string_of_int gen.gcon.version) in
- print_endline cmd;
- if gen.gcon.run_command cmd <> 0 then failwith "Build failed";
- Sys.chdir old_dir;
- end;
- t()
- (* end of configure function *)
- let before_generate con =
- ()
- let generate con =
- (try
- let gen = new_ctx con in
- let basic = con.basic in
- (* make the basic functions in C# *)
- let type_cl = get_cl ( get_type gen (["System"], "Type")) in
- let basic_fns =
- [
- mk_class_field "Equals" (TFun(["obj",false,t_dynamic], basic.tbool)) true Ast.null_pos (Method MethNormal) [];
- mk_class_field "ToString" (TFun([], basic.tstring)) true Ast.null_pos (Method MethNormal) [];
- mk_class_field "GetHashCode" (TFun([], basic.tint)) true Ast.null_pos (Method MethNormal) [];
- mk_class_field "GetType" (TFun([], TInst(type_cl, []))) true Ast.null_pos (Method MethNormal) [];
- ] in
- List.iter (fun cf -> gen.gbase_class_fields <- PMap.add cf.cf_name cf gen.gbase_class_fields) basic_fns;
- configure gen
- with | TypeNotFound path ->
- con.error ("Error. Module '" ^ (path_s path) ^ "' is required and was not included in build.") Ast.null_pos);
- debug_mode := false
|