| 12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862 |
- (*
- * haXe/C# & Java Compiler
- * Copyright (c)2011 Cauê Waneck
- * based on and including code by (c)2005-2008 Nicolas Cannasse, Hugh Sanderson and Franco Ponticelli
- *
- * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- *)
- open Ast
- open Common
- open Gencommon
- open Gencommon.SourceWriter
- open Type
- open Printf
- open Option
- let is_boxed_type t = match follow t with
- | TInst ({ cl_path = (["java";"lang"], "Boolean") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Double") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Integer") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Byte") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Short") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Character") }, [])
- | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> true
- | _ -> false
- let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with
- | TInst ({ cl_path = (["java";"lang"], "Boolean") }, []) -> gen.gcon.basic.tbool
- | TInst ({ cl_path = (["java";"lang"], "Double") }, []) -> gen.gcon.basic.tfloat
- | TInst ({ cl_path = (["java";"lang"], "Integer") }, []) -> gen.gcon.basic.tint
- | TInst ({ cl_path = (["java";"lang"], "Byte") }, []) -> tbyte
- | TInst ({ cl_path = (["java";"lang"], "Short") }, []) -> tshort
- | TInst ({ cl_path = (["java";"lang"], "Character") }, []) -> tchar
- | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> tfloat
- | _ -> assert false
- let rec t_has_type_param t = match follow t with
- | TInst({ cl_kind = KTypeParameter }, []) -> true
- | TEnum(_, params)
- | TInst(_, params) -> List.exists t_has_type_param params
- | TFun(f,ret) -> t_has_type_param ret || List.exists (fun (_,_,t) -> t_has_type_param t) f
- | _ -> false
- let rec t_has_type_param_shallow last t = match follow t with
- | TInst({ cl_kind = KTypeParameter }, []) -> true
- | TEnum(_, params)
- | TInst(_, params) when not last -> List.exists (t_has_type_param_shallow true) params
- | TFun(f,ret) when not last -> t_has_type_param_shallow true ret || List.exists (fun (_,_,t) -> t_has_type_param_shallow true t) f
- | _ -> false
- let is_java_basic_type t =
- match follow t with
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | TInst( { cl_path = ([], "Int") }, [] )
- | TInst( { cl_path = ([], "Float") }, [] )
- | TEnum( { e_path = ([], "Bool") }, [] ) ->
- true
- | _ -> false
- let is_bool t =
- match follow t with
- | TEnum( { e_path = ([], "Bool") }, [] ) ->
- true
- | _ -> false
- let is_int_float gen t =
- match follow (gen.greal_type t) with
- | TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TInst( { cl_path = ([], "Int") }, [] )
- | TInst( { cl_path = ([], "Float") }, [] ) ->
- true
- | _ -> 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
- (* ******************************************* *)
- (* JavaSpecificESynf *)
- (* ******************************************* *)
- (*
- Some Java-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
- It must run after CastDetect, as it changes casts
- It must run after TryCatchWrapper, to change Std.is() calls inside there
- *)
- module JavaSpecificESynf =
- struct
- let name = "java_specific_e"
- let priority = solve_deps name [ DBefore ExpressionUnwrap.priority; DBefore ClassInstance.priority; DAfter CastDetect.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 float_cl = get_cl ( get_type gen (["java";"lang"], "Double")) in
- let bool_md = get_type gen (["java";"lang"], "Boolean") in
- let is_var = alloc_var "__is__" t_dynamic in
- let rec run e =
- match e.eexpr with
- (* Math changes *)
- | TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "NaN" ) ->
- mk_static_field_access_infer float_cl "NaN" e.epos []
- | TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "NEGATIVE_INFINITY" ) ->
- mk_static_field_access_infer float_cl "NEGATIVE_INFINITY" e.epos []
- | TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "POSITIVE_INFINITY" ) ->
- mk_static_field_access_infer float_cl "POSITIVE_INFINITY" e.epos []
- | TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "isNaN" ) ->
- mk_static_field_access_infer float_cl "isNaN" e.epos []
- | TCall( { eexpr = TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "floor" ) }, _)
- | TCall( { eexpr = TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "round" ) }, _)
- | TCall( { eexpr = TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "ceil" ) }, _) ->
- mk_cast basic.tint (Type.map_expr run e)
- | TCall( ( { eexpr = TField( { eexpr = TTypeExpr( TClassDecl( { cl_path = (["java";"lang"], "Math") }) ) }, "isFinite" ) } as efield ), [v]) ->
- { e with eexpr =
- TUnop(Ast.Not, Ast.Prefix, {
- e with eexpr = TCall( mk_static_field_access_infer float_cl "isInfinite" efield.epos [], [run v] )
- })
- }
- (* end of math changes *)
- (* Std.is() *)
- | TCall(
- { eexpr = TField( { eexpr = TTypeExpr ( TClassDecl { cl_path = ([], "Std") } ) }, "is") },
- [ obj; { eexpr = TTypeExpr(md) } ]
- ) ->
- let mk_is obj md =
- { e with eexpr = TCall( { eexpr = TLocal is_var; etype = t_dynamic; epos = e.epos }, [
- run obj;
- { eexpr = TTypeExpr md; etype = t_dynamic (* this is after all a syntax filter *); epos = e.epos }
- ] ) }
- in
- (match follow_module follow md with
- | TClassDecl({ cl_path = ([], "Float") }) ->
- {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl "isDouble" e.epos [],
- [ run obj ]
- );
- etype = basic.tbool;
- epos = e.epos
- }
- | TClassDecl{ cl_path = ([], "Int") } ->
- {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl "isInt" e.epos [],
- [ run obj ]
- );
- etype = basic.tbool;
- epos = e.epos
- }
- | TEnumDecl{ e_path = ([], "Bool") } ->
- mk_is obj bool_md
- | TClassDecl{ cl_path = ([], "Dynamic") } ->
- (match obj.eexpr with
- | TLocal _ | TConst _ -> { e with eexpr = TConst(TBool true) }
- | _ -> { e with eexpr = TBlock([run obj; { e with eexpr = TConst(TBool true) }]) }
- )
- | _ ->
- mk_is obj md
- )
- (* end Std.is() *)
- | _ -> 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;;
- (* ******************************************* *)
- (* JavaSpecificSynf *)
- (* ******************************************* *)
- (*
- Some Java-specific syntax filters that can run after ExprUnwrap
- dependencies:
- Runs after ExprUnwarp
- *)
- module JavaSpecificSynf =
- struct
- let name = "java_specific"
- let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority; DBefore IntDivisionSynf.priority ]
- let java_hash s =
- let h = ref Int32.zero in
- let thirtyone = Int32.of_int 31 in
- for i = 0 to String.length s - 1 do
- h := Int32.add (Int32.mul thirtyone !h) (Int32.of_int (int_of_char (String.unsafe_get s i)));
- done;
- !h
- let rec is_final_return_expr is_switch e =
- let is_final_return_expr = is_final_return_expr is_switch in
- match e.eexpr with
- | TReturn _
- | TThrow _ -> true
- (* this is hack to not use 'break' on switch cases *)
- | TLocal { v_name = "__fallback__" } when is_switch -> true
- | TCall( { eexpr = TLocal { v_name = "__goto__" } }, _ ) -> true
- | TParenthesis p -> is_final_return_expr p
- | TBlock bl -> is_final_return_block is_switch bl
- | TSwitch (_, el_e_l, edef) ->
- List.for_all (fun (_,e) -> is_final_return_expr e) el_e_l && Option.map_default is_final_return_expr false edef
- | TMatch (_, _, il_vl_e_l, edef) ->
- List.for_all (fun (_,_,e) -> is_final_return_expr e)il_vl_e_l && Option.map_default is_final_return_expr false edef
- | TIf (_,eif, Some eelse) ->
- is_final_return_expr eif && is_final_return_expr eelse
- | TFor (_,_,e) ->
- is_final_return_expr e
- | TWhile (_,e,_) ->
- is_final_return_expr e
- | TFunction tf ->
- is_final_return_expr tf.tf_expr
- | TTry (e, ve_l) ->
- is_final_return_expr e && List.for_all (fun (_,e) -> is_final_return_expr e) ve_l
- | _ -> false
- and is_final_return_block is_switch el =
- match el with
- | [] -> false
- | final :: [] -> is_final_return_expr is_switch final
- | hd :: tl -> is_final_return_block is_switch tl
- let is_null e = match e.eexpr with | TConst(TNull) -> true | _ -> false
- let rec is_equatable gen t =
- match follow t with
- | TInst(cl,_) ->
- if cl.cl_path = (["haxe";"lang"], "IEquatable") then
- true
- else
- List.exists (fun (cl,p) -> is_equatable gen (TInst(cl,p))) cl.cl_implements
- || (match cl.cl_super with | Some(cl,p) -> is_equatable gen (TInst(cl,p)) | None -> false)
- | _ -> false
- (*
- Changing string switch
- will take an expression like
- switch(str)
- {
- case "a":
- case "b":
- }
- and modify it to:
- {
- var execute_def = true;
- switch(str.hashCode())
- {
- case (hashcode of a):
- if (str == "a")
- {
- execute_def = false;
- ..code here
- } //else if (str == otherVariableWithSameHashCode) {
- ...
- }
- ...
- }
- if (execute_def)
- {
- ..default code
- }
- }
- this might actually be slower in some cases than a if/else approach, but it scales well and as a bonus,
- hashCode in java are cached, so we only have the performance hit once to cache it.
- *)
- let change_string_switch gen eswitch e1 ecases edefault =
- let basic = gen.gcon.basic in
- let is_final_ret = is_final_return_expr false eswitch in
- let has_default = is_some edefault in
- let block = ref [] in
- let local = match e1.eexpr with
- | TLocal _ -> e1
- | _ ->
- let var = mk_temp gen "svar" e1.etype in
- let added = { e1 with eexpr = TVars([var, Some(e1)]); etype = basic.tvoid } in
- let local = mk_local var e1.epos in
- block := added :: !block;
- local
- in
- let execute_def_var = mk_temp gen "executeDef" gen.gcon.basic.tbool in
- let execute_def = mk_local execute_def_var e1.epos in
- let execute_def_set = { eexpr = TBinop(Ast.OpAssign, execute_def, { eexpr = TConst(TBool false); etype = basic.tbool; epos = e1.epos }); etype = basic.tbool; epos = e1.epos } in
- let hash_cache = ref None in
- let local_hashcode = ref { local with
- eexpr = TCall({ local with
- eexpr = TField(local, "hashCode");
- etype = TFun([], basic.tint);
- }, []);
- etype = basic.tint
- } in
- let get_hash_cache () =
- match !hash_cache with
- | Some c -> c
- | None ->
- let var = mk_temp gen "hash" basic.tint in
- let cond = !local_hashcode in
- block := { eexpr = TVars([var, Some cond]); etype = basic.tvoid; epos = local.epos } :: !block;
- let local = mk_local var local.epos in
- local_hashcode := local;
- hash_cache := Some local;
- local
- in
- let has_case = ref false in
- (* first we need to reorder all cases so all collisions are close to each other *)
- let get_str e = match e.eexpr with | TConst(TString s) -> s | _ -> assert false in
- let has_conflict = ref false in
- let rec reorder_cases unordered ordered =
- match unordered with
- | [] -> ordered
- | (el, e) :: tl ->
- let current = Hashtbl.create 1 in
- List.iter (fun e ->
- let str = get_str e in
- let hash = java_hash str in
- Hashtbl.add current hash true
- ) el;
- let rec extract_fields cases found_cases ret_cases =
- match cases with
- | [] -> found_cases, ret_cases
- | (el, e) :: tl ->
- if List.exists (fun e -> Hashtbl.mem current (java_hash (get_str e)) ) el then begin
- has_conflict := true;
- List.iter (fun e -> Hashtbl.add current (java_hash (get_str e)) true) el;
- extract_fields tl ( (el, e) :: found_cases ) ret_cases
- end else
- extract_fields tl found_cases ( (el, e) :: ret_cases )
- in
- let found, remaining = extract_fields tl [] [] in
- let ret = if found <> [] then
- let ret = List.sort (fun (e1,_) (e2,_) -> compare (List.length e2) (List.length e1) ) ( (el, e) :: found ) in
- let rec loop ret acc =
- match ret with
- | (el, e) :: ( (_,_) :: _ as tl ) -> loop tl ( (true, el, e) :: acc )
- | (el, e) :: [] -> ( (false, el, e) :: acc )
- | _ -> assert false
- in
- List.rev (loop ret [])
- else
- (false, el, e) :: []
- in
- reorder_cases remaining (ordered @ ret)
- in
- let already_in_cases = Hashtbl.create 0 in
- let change_case (has_fallback, el, e) =
- let conds, el = List.fold_left (fun (conds,el) e ->
- has_case := true;
- match e.eexpr with
- | TConst(TString s) ->
- let hashed = java_hash s in
- let equals_test = {
- eexpr = TCall({ e with eexpr = TField(local, "equals"); etype = TFun(["obj",false,t_dynamic],basic.tbool) }, [ e ]);
- etype = basic.tbool;
- epos = e.epos
- } in
- let hashed_expr = { eexpr = TConst(TInt hashed); etype = basic.tint; epos = e.epos } in
- let hashed_exprs = if !has_conflict then begin
- if Hashtbl.mem already_in_cases hashed then
- el
- else begin
- Hashtbl.add already_in_cases hashed true;
- hashed_expr :: el
- end
- end else hashed_expr :: el in
- let conds = match conds with
- | None -> equals_test
- | Some c ->
- (*
- if there is more than one case, we should test first if hash equals to the one specified.
- This way we can save a heavier string compare
- *)
- let equals_test = mk_paren {
- eexpr = TBinop(Ast.OpBoolAnd, { eexpr = TBinop(Ast.OpEq, get_hash_cache(), hashed_expr); etype = basic.tbool; epos = e.epos }, equals_test);
- etype = basic.tbool;
- epos = e.epos;
- } in
- { eexpr = TBinop(Ast.OpBoolOr, equals_test, c); etype = basic.tbool; epos = e1.epos }
- in
- Some conds, hashed_exprs
- | _ -> assert false
- ) (None,[]) el in
- let e = if has_default then Codegen.concat execute_def_set e else e in
- let e = if !has_conflict then Codegen.concat e { e with eexpr = TBreak; etype = basic.tvoid } else e in
- let e = {
- eexpr = TIf(get conds, e, None);
- etype = basic.tvoid;
- epos = e.epos
- } in
- let e = if has_fallback then { e with eexpr = TBlock([ e; mk_local (alloc_var "__fallback__" t_dynamic) e.epos]) } else e in
- (el, e)
- in
- let switch = { eswitch with
- eexpr = TSwitch(!local_hashcode, List.map change_case (reorder_cases ecases []), None);
- } in
- (if !has_case then begin
- (if has_default then block := { e1 with eexpr = TVars([execute_def_var, Some({ e1 with eexpr = TConst(TBool true); etype = basic.tbool })]); etype = basic.tvoid } :: !block);
- block := switch :: !block
- end);
- (match edefault with
- | None -> ()
- | Some edef when not !has_case ->
- block := edef :: !block
- | Some edef ->
- let eelse = if is_final_ret then Some { eexpr = TThrow { eexpr = TConst(TNull); etype = t_dynamic; epos = edef.epos }; etype = basic.tvoid; epos = edef.epos } else None in
- block := { edef with eexpr = TIf(execute_def, edef, eelse); etype = basic.tvoid } :: !block
- );
- { eswitch with eexpr = TBlock(List.rev !block) }
- 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 tchar = match ( get_type gen (["java"], "Char16") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
- let tbyte = match ( get_type gen (["java"], "Int8") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
- let tshort = match ( get_type gen (["java"], "Int16") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
- let tsingle = match ( get_type gen ([], "Single") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false 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 rec run e =
- match e.eexpr with
- (* for new NativeArray<T> issues *)
- | TNew(({ cl_path = (["java"], "NativeArray") } as cl), [t], el) when t_has_type_param t ->
- mk_cast (TInst(cl,[t])) (mk_cast t_dynamic ({ e with eexpr = TNew(cl, [t_empty], List.map run el) }))
- (* Std.int() *)
- | TCall(
- { eexpr = TField( { eexpr = TTypeExpr ( TClassDecl ({ cl_path = ([], "Std") }) ) }, "int") },
- [obj]
- ) ->
- run (mk_cast basic.tint obj)
- (* end Std.int() *)
- | TField( ef, "length" ) when is_string ef.etype ->
- { e with eexpr = TCall(Type.map_expr run e, []) }
- | TCall( ( { eexpr = TField({ eexpr = TTypeExpr (TTypeDecl t) }, "fromCharCode") } ), [cc] ) when is_string (follow (TType(t,List.map snd t.t_types))) ->
- { 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, field) } as efield ), args ) when is_string ef.etype ->
- (match field with
- | "charAt" | "charCodeAt" | "split" | "indexOf"
- | "lastIndexOf" | "substring" | "substr" ->
- { e with eexpr = TCall(mk_static_field_access_infer string_ext field e.epos [], [run ef] @ (List.map run args)) }
- | _ when String.get field 0 = '_' ->
- { e with eexpr = TCall({ efield with eexpr = TField(run ef, String.sub field 1 ( (String.length field) - 1)) }, List.map run args) }
- | _ ->
- { e with eexpr = TCall(run efield, List.map run args) }
- )
- | TCast(expr, m) when is_boxed_type e.etype ->
- (* let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with *)
- run { e with etype = unboxed_type gen e.etype tbyte tshort tchar tsingle }
- | TCast(expr, _) when is_bool e.etype ->
- {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl "toBool" expr.epos [],
- [ run expr ]
- );
- etype = basic.tbool;
- epos = e.epos
- }
- | TCast(expr, _) when is_int_float gen e.etype && not (is_int_float gen expr.etype) ->
- let needs_cast = match gen.gfollow#run_f e.etype with
- | TInst _ -> false
- | _ -> true
- in
- let fun_name = match follow e.etype with
- | TInst ({ cl_path = ([], "Float") },[]) -> "toDouble"
- | _ -> "toInt"
- in
- let ret = {
- eexpr = TCall(
- mk_static_field_access_infer runtime_cl fun_name expr.epos [],
- [ run expr ]
- );
- etype = if fun_name = "toDouble" then basic.tfloat else basic.tint;
- epos = expr.epos
- } in
- if needs_cast then mk_cast e.etype ret else ret
- (*| TCast(expr, c) when is_int_float gen e.etype ->
- (* cases when float x = (float) (java.lang.Double val); *)
- (* FIXME: this fix is broken since it will fail on cases where float x = (float) (java.lang.Float val) or similar. FIX THIS *)
- let need_second_cast = match gen.gfollow#run_f e.etype with
- | TInst _ -> false
- | _ -> true
- in
- if need_second_cast then { e with eexpr = TCast(mk_cast (follow e.etype) (run expr), c) } else Type.map_expr run e*)
- | TCast(expr, _) when is_string e.etype ->
- { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "toString" expr.epos [], [run expr] ) }
- | TSwitch(cond, ecases, edefault) when is_string cond.etype ->
- (*let change_string_switch gen eswitch e1 ecases edefault =*)
- change_string_switch gen e (run cond) (List.map (fun (el,e) -> (el, run e)) ecases) (Option.map run edefault)
- | TBinop( (Ast.OpNotEq as op), e1, e2)
- | TBinop( (Ast.OpEq as op), e1, e2) when not (is_null e2 || is_null e1) && (is_string e1.etype || is_string e2.etype || is_equatable gen e1.etype || is_equatable gen e2.etype) ->
- let static = mk_static_field_access_infer (runtime_cl) "valEq" e1.epos [] in
- let eret = { eexpr = TCall(static, [run e1; run e2]); etype = gen.gcon.basic.tbool; epos=e.epos } in
- if op = Ast.OpNotEq then { eret with eexpr = TUnop(Ast.Not, Ast.Prefix, eret) } else eret
- | _ -> Type.map_expr run e
- in
- run
- let configure gen (mapping_func:texpr->texpr) =
- (if java_hash "Testing string hashCode implementation from haXe" <> (Int32.of_int 545883604) then assert false);
- let map e = Some(mapping_func e) in
- gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map
- end;;
- 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 = "java" (* 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"; "assert"; "boolean"; "break"; "byte"; "case"; "catch"; "char"; "class";
- "const"; "continue"; "default"; "do"; "double"; "else"; "enum"; "extends"; "final";
- "false"; "finally"; "float"; "for"; "goto"; "if"; "implements"; "import"; "instanceof"; "int";
- "interface"; "long"; "native"; "new"; "null"; "package"; "private"; "protected"; "public"; "return"; "short";
- "static"; "strictfp"; "super"; "switch"; "synchronized"; "this"; "throw"; "throws"; "transient"; "true"; "try";
- "void"; "volatile"; "while"; ];
- 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
- (*| (":struct",[],_) :: meta -> get_class_modifiers meta "struct" cl_access cl_modifiers*)
- | (":protected",[],_) :: meta -> get_class_modifiers meta cl_type "protected" cl_modifiers
- | (":internal",[],_) :: meta -> get_class_modifiers meta cl_type "" 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 *)
- | (":final",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("final" :: 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
- | (":protected",[],_) :: meta -> get_fun_modifiers meta "protected" modifiers
- | (":internal",[],_) :: meta -> get_fun_modifiers meta "" modifiers
- (*| (":readonly",[],_) :: meta -> get_fun_modifiers meta access ("readonly" :: modifiers)*)
- (*| (":unsafe",[],_) :: meta -> get_fun_modifiers meta access ("unsafe" :: modifiers)*)
- | (":volatile",[],_) :: meta -> get_fun_modifiers meta access ("volatile" :: modifiers)
- | (":transient",[],_) :: meta -> get_fun_modifiers meta access ("transient" :: 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 runtime_cl = get_cl (get_type gen (["haxe";"lang"],"Runtime")) in
- (*let string_ref = get_cl ( get_type gen (["haxe";"lang"], "StringRefl")) in*)
- let ti64 = match ( get_type gen (["haxe";"_Int64"], "NativeInt64") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in
- let has_tdynamic params =
- List.exists (fun e -> match gen.greal_type e with | TDynamic _ -> true | _ -> false) params
- in
- (*
- The type parameters always need to be changed to their boxed counterparts
- *)
- let change_param_type md params =
- match md with
- | TClassDecl( { cl_path = (["java"], "NativeArray") } ) -> params
- | _ ->
- match params with
- | [] -> []
- | _ ->
- if has_tdynamic params then List.map (fun _ -> t_dynamic) params else
- List.map (fun t ->
- let f_t = gen.gfollow#run_f t in
- match gen.gfollow#run_f t with
- | TEnum ({ e_path = ([], "Bool") }, [])
- | TInst ({ cl_path = ([],"Float") },[])
- | TInst ({ cl_path = ["haxe"],"Int32" },[])
- | TInst ({ cl_path = ([],"Int") },[])
- | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[])
- | TType ({ t_path = ["haxe"],"Int64" },[])
- | TType ({ t_path = ["java"],"Int8" },[])
- | TType ({ t_path = ["java"],"Int16" },[])
- | TType ({ t_path = ["java"],"Char16" },[])
- | TType ({ t_path = [],"Single" },[]) -> basic.tnull f_t
- (*| TType ({ t_path = [], "Null"*)
- | TInst (cl, ((_ :: _) as p)) ->
- TInst(cl, List.map (fun _ -> t_dynamic) p)
- | TEnum (e, ((_ :: _) as p)) ->
- TEnum(e, List.map (fun _ -> t_dynamic) p)
- | _ -> t
- ) params
- in
- let rec change_ns ns = match ns with
- | [] -> ["haxe"; "root"]
- | _ -> ns
- in
- let change_clname n = n in
- let change_id name = try Hashtbl.find reserved name with | Not_found -> name 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") }, [])
- | TEnum ({ e_path = ([], "Void") }, [])
- | TInst ({ cl_path = ([],"Float") },[])
- | TInst ({ cl_path = ([],"Int") },[])
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[])
- | TType ({ t_path = ["java"],"Int8" },[])
- | TType ({ t_path = ["java"],"Int16" },[])
- | TType ({ t_path = ["java"],"Char16" },[])
- | TType ({ t_path = [],"Single" },[])
- | TType ({ t_path = [],"Null" },[_]) -> Some t
- | TInst( { cl_path = ([], "EnumValue") }, _ ) -> Some t_dynamic
- | _ -> None);
- let change_path path = (change_ns (fst path), change_clname (snd path)) in
- let path_s path = match path with
- | (ns,clname) -> path_s (change_ns ns, change_clname clname)
- in
- let cl_cl = get_cl (get_type gen (["java";"lang"],"Class")) in
- let rec real_type t =
- let t = gen.gfollow#run_f t in
- match t with
- | TInst( { cl_path = (["haxe"], "Int32") }, [] ) -> gen.gcon.basic.tint
- | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> ti64
- | TInst( { cl_path = ([], "Class") }, p )
- | TInst( { cl_path = ([], "Enum") }, p ) -> TInst(cl_cl,p)
- | TEnum _
- | TInst _ -> t
- | TType({ t_path = ([], "Null") }, [t]) when is_java_basic_type t -> t_dynamic
- | TType({ t_path = ([], "Null") }, [t]) ->
- (match follow t with
- | TInst( { cl_kind = KTypeParameter }, []) -> t_dynamic
- | _ -> real_type t
- )
- | TType _ -> t
- | TAnon (anon) when (match !(anon.a_status) with | Statics _ | EnumStatics _ -> true | _ -> false) -> t
- | TAnon _ -> dynamic_anon
- | TFun _ -> TInst(fn_cl,[])
- | _ -> t_dynamic
- 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") }, []) -> "boolean"
- | TEnum ({ e_path = ([], "Void") }, []) -> "java.lang.Object"
- | TInst ({ cl_path = ([],"Float") },[]) -> "double"
- | TInst ({ cl_path = ([],"Int") },[]) -> "int"
- | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[]) -> "long"
- | TType ({ t_path = ["java"],"Int8" },[]) -> "byte"
- | TType ({ t_path = ["java"],"Int16" },[]) -> "short"
- | TType ({ t_path = ["java"],"Char16" },[]) -> "char"
- | TType ({ t_path = [],"Single" },[]) -> "float"
- | TInst ({ cl_path = ["haxe"],"Int32" },[]) -> "int"
- | TInst ({ cl_path = ["haxe"],"Int64" },[]) -> "long"
- | TInst ({ cl_path = ([], "Dynamic") }, _) -> "java.lang.Object"
- | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
- let rec check_t_s t =
- match real_type t with
- | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
- (check_t_s param) ^ "[]"
- | _ -> t_s (run_follow gen t)
- in
- (check_t_s param) ^ "[]"
- (* end of basic types *)
- | TInst ({ cl_kind = KTypeParameter; cl_path=p }, []) -> snd p
- | TMono r -> (match !r with | None -> "java.lang.Object" | Some t -> t_s (run_follow gen t))
- | TInst ({ cl_path = [], "String" }, []) -> "java.lang.String"
- | TInst ({ cl_path = [], "Class" }, _) | TInst ({ cl_path = [], "Enum" }, _) -> assert false (* should have been converted earlier *)
- | TEnum (({e_path = p;} as e), params) -> (path_param_s (TEnumDecl e) p params)
- | 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 _ -> "java.lang.Class"
- | _ -> "java.lang.Object")
- | TDynamic _ -> "java.lang.Object"
- (* 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 param_t_s t =
- match run_follow gen t with
- | TEnum ({ e_path = ([], "Bool") }, []) -> "java.lang.Boolean"
- | TInst ({ cl_path = ([],"Float") },[]) -> "java.lang.Double"
- | TInst ({ cl_path = ([],"Int") },[]) -> "java.lang.Integer"
- | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[]) -> "java.lang.Long"
- | TInst ({ cl_path = ["haxe"],"Int64" },[]) -> "java.lang.Long"
- | TInst ({ cl_path = ["haxe"],"Int32" },[]) -> "java.lang.Integer"
- | TType ({ t_path = ["java"],"Int8" },[]) -> "java.lang.Byte"
- | TType ({ t_path = ["java"],"Int16" },[]) -> "java.lang.Short"
- | TType ({ t_path = ["java"],"Char16" },[]) -> "java.lang.Character"
- | TType ({ t_path = [],"Single" },[]) -> "java.lang.Float"
- | TDynamic _ -> "?"
- | TInst (cl, params) -> t_s (TInst(cl, change_param_type (TClassDecl cl) params))
- | TType (cl, params) -> t_s (TType(cl, change_param_type (TTypeDecl cl) params))
- | TEnum (e, params) -> t_s (TEnum(e, change_param_type (TEnumDecl e) params))
- | _ -> t_s t
- and path_param_s md path params =
- match params with
- | [] -> path_s path
- | _ when has_tdynamic params -> path_s path
- | _ -> sprintf "%s<%s>" (path_s path) (String.concat ", " (List.map (fun t -> param_t_s t) (change_param_type md params)))
- in
- let rett_s t =
- match t with
- | TEnum ({e_path = ([], "Void")}, []) -> "void"
- | _ -> 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
- | TLocal { v_name = "__fallback__" }
- | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt _) } ] ) -> false
- | 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) ->
- t_s (TInst(cl,[]))
- | TEnumDecl (e) ->
- t_s (TEnum(e,[]))
- | TTypeDecl t ->
- t_s (TType(t, []))
- in
- (*
- it seems that Java doesn't like when you create a new array with the type parameter defined
- so we'll just ignore all type parameters, and hope for the best!
- *)
- let rec transform_nativearray_t t = match real_type t with
- | TInst( ({ cl_path = (["java"], "NativeArray") } as narr), [t]) ->
- TInst(narr, [transform_nativearray_t t])
- | TInst(cl, params) -> TInst(cl, List.map (fun _ -> t_dynamic) params)
- | TEnum(e, params) -> TEnum(e, List.map (fun _ -> t_dynamic) params)
- | TType(t, params) -> TType(t, List.map (fun _ -> t_dynamic) params)
- | _ -> t
- in
- let expr_s w e =
- 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 ->
- print w "%ld" i32;
- (match real_type e.etype with
- | TType( { t_path = (["haxe";"_Int64"], "NativeInt64") }, [] ) -> write w "L";
- | _ -> ()
- )
- | TFloat s ->
- write w s;
- (* fix for Int notation, which only fit in a Float *)
- (if not (String.contains s '.' || String.contains s 'e' || String.contains s 'E') then write w ".0");
- (match real_type e.etype with
- | TType( { t_path = ([], "Single") }, [] ) -> write w "f"
- | _ -> ()
- )
- | TString s -> print w "\"%s\"" (escape s)
- | TBool b -> write w (if b then "true" else "false")
- | TNull ->
- (match real_type e.etype with
- | TType( { t_path = (["haxe";"_Int64"], "NativeInt64") }, [] )
- | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> write w "0L"
- | TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | TInst({ cl_path = ([], "Int") },[]) -> expr_s w ({ e with eexpr = TConst(TInt Int32.zero) })
- | TInst({ cl_path = ([], "Float") },[]) -> expr_s w ({ e with eexpr = TConst(TFloat "0.0") })
- | TEnum({ e_path = ([], "Bool") }, []) -> write w "false"
- | _ -> write w "null")
- | TThis -> write w "this"
- | TSuper -> write w "super")
- | TLocal { v_name = "__fallback__" } -> ()
- | 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 var ->
- write_id w var.v_name
- | TEnumField (e, s) ->
- print w "%s." (path_s e.e_path); 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 (e, s) | TClosure (e, s) ->
- expr_s w e; write w "."; write_field w s
- | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int32") }) ->
- write w (path_s (["haxe"], "Int32"))
- | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int64") }) ->
- write w (path_s (["haxe"], "Int64"))
- | TTypeExpr mt -> write w (md_s mt)
- | TParenthesis e ->
- write w "("; expr_s w e; write w ")"
- | TArrayDecl el when t_has_type_param_shallow false e.etype ->
- print w "( (%s) (new java.lang.Object[] " (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 "}) )"
- | TArrayDecl el ->
- print w "new %s" (param_t_s (transform_nativearray_t e.etype));
- let is_double = match follow e.etype with
- | TInst(_,[ t ]) -> ( match follow t with | TInst({ cl_path=([],"Float") },[]) -> Some t | _ -> None )
- | _ -> None
- in
- write w "{";
- ignore (List.fold_left (fun acc e ->
- (if acc <> 0 then write w ", ");
- (* this is a hack so we are able to convert ints to boxed Double / Float when needed *)
- let e = if is_some is_double then mk_cast (get is_double) e else e in
- expr_s w e;
- acc + 1
- ) 0 el);
- write w "}"
- | TCall( ( { eexpr = TField({ eexpr = TTypeExpr (TClassDecl { cl_path = ([], "String") }) }, "fromCharCode") } ), [cc] ) ->
- write w "Character.toString((char) ";
- expr_s w cc;
- write w ")"
- | TCall ({ eexpr = TLocal( { v_name = "__is__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) ->
- write w "( ";
- expr_s w expr;
- write w " instanceof ";
- write w (md_s md);
- write w " )"
- | TCall ({ eexpr = TLocal( { v_name = "__java__" } ) }, [ { eexpr = TConst(TString(s)) } ] ) ->
- write w s
- | TCall ({ eexpr = TLocal( { v_name = "__lock__" } ) }, [ eobj; eblock ] ) ->
- write w "synchronized(";
- expr_s w eobj;
- write w ")";
- expr_s w (mk_block eblock)
- | TCall ({ eexpr = TLocal( { v_name = "__goto__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
- print w "break label%ld" v
- | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt v) } ] ) ->
- print w "label%ld:" v
- | TCall ({ eexpr = TLocal( { v_name = "__typeof__" } ) }, [ { eexpr = TTypeExpr md } as expr ] ) ->
- expr_s w expr;
- write w ".class"
- | TCall (e, el) ->
- 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 params, el = extract_tparams [] el 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 (param_t_s (change_param_type md t));
- acc + 1
- ) 0 params);
- write w ">"
- );*)
- 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_path = (["java"], "NativeArray") } as cl), params, [ size ]) ->
- let rec check_t_s t times =
- match real_type t with
- | TInst({ cl_path = (["java"], "NativeArray") }, [param]) ->
- (check_t_s param (times+1))
- | _ ->
- print w "new %s[" (t_s (transform_nativearray_t 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;
- (*let last_line = ref (-1) in
- let line_directive 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 "../" ^ 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*)
- List.iter (fun e ->
- (*line_directive 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
- 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 gen_class_field w 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 -> name, false, false
- in
- (match cf.cf_kind with
- | Var _
- | Method (MethDynamic) ->
- if not is_interface then begin
- let access, modifiers = get_fun_modifiers cf.cf_meta "public" [] in
- 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 mkind ->
- let is_virtual = is_new || (not is_final && match mkind with | MethInline -> false | _ when not is_new -> true | _ -> false) in
- let is_override = match cf.cf_name with
- | "equals" when not is_static ->
- (match cf.cf_type with
- | TFun([_,_,t], ret) ->
- (match (real_type t, real_type ret) with
- | TDynamic _, TEnum( { e_path = ([], "Bool") }, [])
- | TAnon _, TEnum( { e_path = ([], "Bool") }, []) -> true
- | _ -> List.mem cf.cf_name cl.cl_overrides
- )
- | _ -> List.mem cf.cf_name cl.cl_overrides)
- | "toString" when not is_static ->
- (match cf.cf_type with
- | TFun([], ret) ->
- (match real_type ret with
- | TInst( { cl_path = ([], "String") }, []) -> true
- | _ -> gen.gcon.error "A toString() function should return a String!" cf.cf_pos; false
- )
- | _ -> List.mem cf.cf_name cl.cl_overrides
- )
- | "hashCode" when not is_static ->
- (match cf.cf_type with
- | TFun([], ret) ->
- (match real_type ret with
- | TInst( { cl_path = ([], "Int") }, []) ->
- true
- | _ -> gen.gcon.error "A hashCode() function should return an Int!" cf.cf_pos; false
- )
- | _ -> List.mem cf.cf_name cl.cl_overrides
- )
- | _ -> List.mem cf.cf_name cl.cl_overrides
- in
- let visibility = if is_interface then "" else "public" in
- let visibility, modifiers = get_fun_modifiers cf.cf_meta visibility [] 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 "" else if not is_virtual then "final " else "" in
- let cf_type = if is_override 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 params = List.map snd cl.cl_types in
- let ret_type, args = match cf_type, cf.cf_type with | TFun (strbtl, t), TFun(rargs, _) -> (apply_params cl.cl_types params (real_type t), List.map2 (fun(_,_,t) (n,o,_) -> (n,o,apply_params cl.cl_types params (real_type t))) strbtl rargs) | _ -> assert false in
- (if is_override && not is_interface then write w "@Override ");
- (* public static void funcName *)
- let params, _ = get_string_params cf.cf_params in
- print w "%s %s%s %s %s %s" (visibility) v_n (String.concat " " modifiers) params (if is_new then "" else rett_s (run_follow gen ret_type)) (change_field name);
- (* <T>(string arg1, object arg2) with T : object *)
- print w "(%s)" (String.concat ", " (List.map (fun (name, _, t) -> sprintf "%s %s" (t_s (run_follow gen t)) (change_id name)) args));
- 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
- expr_s w expr
- end else begin
- expr_s w expr;
- end)
- | (":throws", [Ast.EConst (Ast.String t), _], _) :: tl ->
- print w " throws %s" t;
- loop tl
- | (":functionBody", [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 gen_class w cl =
- let should_close = match change_ns (fst cl.cl_path) with
- | [] -> false
- | ns ->
- print w "package %s;" (String.concat "." (change_ns ns));
- newline w;
- false
- in
- let rec loop_meta meta acc =
- match meta with
- | (":SuppressWarnings", [Ast.EConst (Ast.String w),_],_) :: meta -> loop_meta meta (w :: acc)
- | _ :: meta -> loop_meta meta acc
- | _ -> acc
- in
- let suppress_warnings = loop_meta cl.cl_meta [ "rawtypes"; "unchecked" ] in
- write w "import haxe.root.*;";
- newline w;
- write w "@SuppressWarnings(value={";
- let first = ref true in
- List.iter (fun s ->
- (if !first then first := false else write w ", ");
- print w "\"%s\"" (escape s)
- ) suppress_warnings;
- write w "})";
- newline w;
- let clt, access, modifiers = get_class_modifiers cl.cl_meta (if cl.cl_interface then "interface" else "class") "public" [] in
- let is_final = 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, _ = get_string_params cl.cl_types in
- let cl_p_to_string (cl,p) = path_param_s (TClassDecl cl) cl.cl_path p in
- print w "%s" params;
- (if is_some cl.cl_super then print w " extends %s" (cl_p_to_string (get cl.cl_super)));
- (match cl.cl_implements with
- | [] -> ()
- | _ -> print w " %s %s" (if cl.cl_interface then "extends" else "implements") (String.concat ", " (List.map cl_p_to_string cl.cl_implements))
- );
- (* 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
- | [] -> ()
- | (":classContents", [Ast.EConst (Ast.String contents),_],_) :: tl ->
- write w contents
- | _ :: tl -> loop tl
- in
- loop cl.cl_meta;
- (match gen.gcon.main_class with
- | Some path when path = cl.cl_path ->
- write w "public static void main(String[] args)";
- begin_block w;
- (if Hashtbl.mem gen.gtypes ([], "Sys") then write w "Sys._args = args;"; newline w);
- write w "main();";
- end_block w
- | _ -> ()
- );
- (match cl.cl_init with
- | None -> ()
- | Some init ->
- write w "static ";
- 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;
- end_block w;
- if should_close then end_block w
- in
- let gen_enum w e =
- let should_close = match change_ns (fst e.e_path) with
- | [] -> false
- | ns ->
- print w "package %s;" (String.concat "." (change_ns ns));
- newline w;
- false
- in
- print w "public enum %s" (change_clname (snd e.e_path));
- begin_block w;
- write w (String.concat ", " 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
- gen_class w cl;
- newline w;
- newline w
- end;
- (not cl.cl_extern)
- | TEnumDecl e ->
- if not e.e_extern then begin
- gen_enum w e;
- newline w;
- newline w
- end;
- (not e.e_extern)
- | TTypeDecl e ->
- false
- in
- let module_gen w md =
- module_type_gen w md
- in
- (* generate source code *)
- init_ctx gen;
- 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 "__typeof__" true;
- Hashtbl.add gen.gspecial_vars "__java__" true;
- Hashtbl.add gen.gspecial_vars "__lock__" true;
- gen.greal_type <- real_type;
- gen.greal_type_param <- change_param_type;
- SetHXGen.run_filter gen SetHXGen.default_hxgen_func;
- 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));*)
- IteratorsInterface.configure gen (fun e -> e);
- ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (get_cl (get_type gen (["haxe";"lang"],"Function")) ));
- EnumToClass.configure gen (None) false true (get_cl (get_type gen (["haxe";"lang"],"Enum")) ) false true;
- 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;});*)
- OverloadingConstructor.configure gen (TEnum(empty_e, [])) ({eexpr=TEnumField(empty_e, "EMPTY"); etype=TEnum(empty_e,[]); epos=null_pos;}) false;
- 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 t = match follow (real_type t) with
- | TInst({ cl_path = (["haxe"], "Int32")}, [] )
- | TInst({ cl_path = ([], "Int") }, [])
- | TInst({ cl_path = ([], "Float") }, []) -> true
- | _ -> false
- in
- let rcf_on_getset_field main_expr field_expr field may_hash may_set is_unsafe =
- let is_float = can_be_float (if is_none may_set then main_expr.etype else (get may_set).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); etype = t_dynamic }
- in
- let rcf_ctx = ReflectionCFs.new_ctx gen closure_t object_iface false 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 ) 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 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;
- } );
- 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
- | TInst({ cl_path = (["java"], "NativeArray") }, _) -> false
- | _ -> true )
- | _ -> assert false
- ) "__get" "__set" );
- let field_is_dynamic t field =
- match field_access gen (gen.greal_type t) field with
- | FClassField (cl,p,_,_,t) ->
- is_dynamic (apply_params cl.cl_types p t)
- | FEnumField _ -> 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 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") }, [])
- | TInst({ cl_path = (["haxe"], "Int32")}, [] )
- | TInst({ cl_path = (["haxe"], "Int64")}, [] )
- | TInst({ cl_path = ([], "Int") }, [])
- | TEnum({ e_path = ([], "Bool") }, []) -> Some t
- | _ -> None )
- | _ -> None
- in
- let is_double t = match follow t with | TInst({ cl_path = ([], "Float") }, []) -> true | _ -> false in
- let is_int t = match follow t with | TInst({ cl_path = ([], "Int") }, []) -> true | _ -> false in
- DynamicOperators.configure gen
- (DynamicOperators.abstract_implementation gen (fun e -> match e.eexpr with
- | TBinop (Ast.OpEq, e1, e2)
- | TBinop (Ast.OpAdd, e1, e2)
- | TBinop (Ast.OpNotEq, e1, e2) -> is_dynamic e1.etype or is_dynamic e2.etype or is_type_param e1.etype or is_type_param e2.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
- | _ -> false)
- (fun e1 e2 ->
- let is_null e = match e.eexpr with | TConst(TNull) | TLocal({ v_name = "__undefined__" }) -> true | _ -> false in
- if is_null e1 || is_null e2 then
- match e1.eexpr, e2.eexpr with
- | TConst c1, TConst c2 ->
- { e1 with eexpr = TConst(TBool (c1 = c2)); etype = basic.tbool }
- | _ ->
- { e1 with eexpr = TBinop(Ast.OpEq, e1, e2); etype = basic.tbool }
- else begin
- let is_ref = match follow e1.etype, follow e2.etype with
- | TDynamic _, _
- | _, TDynamic _
- | TInst({ cl_path = ([], "Float") },[]), _
- | TInst( { cl_path = (["haxe"], "Int32") }, [] ), _
- | TInst( { cl_path = (["haxe"], "Int64") }, [] ), _
- | TInst({ cl_path = ([], "Int") },[]), _
- | TEnum({ e_path = ([], "Bool") },[]), _
- | _, TInst({ cl_path = ([], "Float") },[])
- | _, TInst({ cl_path = ([], "Int") },[])
- | _, TInst( { cl_path = (["haxe"], "Int32") }, [] )
- | _, TInst( { cl_path = (["haxe"], "Int64") }, [] )
- | _, TEnum({ e_path = ([], "Bool") },[])
- | 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 }
- end
- )
- (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 }
- | _ ->
- 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({ e1 with eexpr = TField(e1, "compareTo"); etype = TFun(["anotherString",false,gen.gcon.basic.tstring], gen.gcon.basic.tint) }, [ 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));
- FilterClosures.configure gen (FilterClosures.traverse gen (fun e1 s -> true) closure_func);
- let base_exception = get_cl (get_type gen (["java"; "lang"], "Throwable")) 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 = 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
- { eexpr = TField(local, "obj"); epos = pos; etype = t_dynamic }
- )
- (fun rethrow ->
- let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], base_exception_t)) rethrow.epos in
- { rethrow with eexpr = TThrow { rethrow with eexpr = TCall(wrap_static, [rethrow]) }; }
- )
- (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));
- (*let v = alloc_var "$type_param" t_dynamic in*)
- TypeParams.configure gen (fun ecall efield params elist ->
- { ecall with eexpr = TCall(efield, elist) }
- );
- CastDetect.configure gen (CastDetect.default_implementation gen (Some (TEnum(empty_e, []))) 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 = (["haxe"], "Int32") }, [] )
- | TInst({ cl_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 );
- let native_arr_cl = get_cl ( get_type gen (["java"], "NativeArray") ) in
- 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 true true true true);
- 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 ->
- { e_loop with eexpr = TBlock( { eexpr = TCall( mk_local label_special e_loop.epos, [ mk_int gen n e_loop.epos ] ); etype = t_dynamic; epos = e_loop.epos } :: [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);
- JavaSpecificSynf.configure gen (JavaSpecificSynf.traverse gen runtime_cl);
- JavaSpecificESynf.configure gen (JavaSpecificESynf.traverse gen runtime_cl);
- (* add native String as a String superclass *)
- let str_cl = match gen.gcon.basic.tstring with | TInst(cl,_) -> cl | _ -> assert false in
- str_cl.cl_super <- Some (get_cl (get_type gen (["haxe";"lang"], "NativeString")), []);
- 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
- 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/" ^ 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;
- TypeParams.RenameTypeParameters.run gen;
- let t = Common.timer "code generation" in
- generate_modules_t gen "java" "src" change_path module_gen;
- dump_descriptor gen ("hxjava_build.txt") path_s;
- if ( not (Common.defined gen.gcon "no-compilation") ) then begin
- let old_dir = Sys.getcwd() in
- Sys.chdir gen.gcon.file;
- let cmd = "haxelib run hxjava hxjava_build.txt --haxe-version " ^ (string_of_int gen.gcon.version) in
- print_endline cmd;
- if Sys.command cmd <> 0 then failwith "Build failed";
- Sys.chdir old_dir;
- end;
- t()
- (* end of configure function *)
-
- let before_generate con =
- ()
- let generate con =
- let gen = new_ctx con in
- gen.gallow_tp_dynamic_conversion <- true;
- let basic = con.basic in
- (* make the basic functions in java *)
- 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 "hashCode" (TFun([], basic.tint)) 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;
- (try
- 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
|