123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352 |
- (*
- The Haxe Compiler
- Copyright (C) 2005-2015 Haxe Foundation
- This program is free software; you can redistribute it and/or
- modify it under the terms of the GNU General Public License
- as published by the Free Software Foundation; either version 2
- of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
- *)
- open Ast
- open Type
- open Common
- type method_name = {
- mutable mpath : path;
- mutable mname : string;
- }
- type inline_method = {
- iname : string;
- iindex : int;
- iexpr : texpr;
- ihasthis : bool;
- iin_block : bool;
- iarguments : string list;
- ilocals : (string,string) PMap.t;
- iinv_locals : (string,string) PMap.t;
- }
- type context = {
- com : Common.context;
- ch : out_channel;
- buf : Buffer.t;
- path : path;
- stack : Codegen.stack_context;
- mutable nested_loops : int;
- mutable inline_index : int;
- mutable curclass : tclass;
- mutable curmethod : string;
- mutable tabs : string;
- mutable in_value : string option;
- mutable in_loop : bool;
- mutable in_block : bool;
- mutable in_instance_method : bool;
- mutable imports : (string,string list list) Hashtbl.t;
- mutable extern_required_paths : (string list * string) list;
- mutable extern_classes_with_init : path list;
- mutable locals : (string,string) PMap.t;
- mutable inv_locals : (string,string) PMap.t;
- mutable local_types : t list;
- mutable inits : texpr list;
- mutable constructor_block : bool;
- mutable all_dynamic_methods: method_name list;
- mutable dynamic_methods: tclass_field list;
- mutable is_call : bool;
- mutable cwd : string;
- mutable inline_methods : inline_method list;
- mutable lib_path : string;
- }
- let join_class_path path separator =
- let result = match fst path, snd path with
- | [], s -> s
- | el, s -> String.concat separator el ^ separator ^ s in
- if (String.contains result '+') then begin
- let idx = String.index result '+' in
- (String.sub result 0 idx) ^ (String.sub result (idx+1) ((String.length result) - idx -1 ) )
- end else
- result;;
- (* Get a string to represent a type.
- The "suffix" will be nothing or "_obj", depending if we want the name of the
- pointer class or the pointee (_obj class *)
- let rec class_string klass suffix params =
- (match klass.cl_path with
- (* Array class *)
- | ([],"Array") -> (snd klass.cl_path) ^ suffix ^ "<" ^ (String.concat ","
- (List.map type_string params) ) ^ " >"
- | _ when (match klass.cl_kind with KTypeParameter _ -> true | _ -> false) -> "Dynamic"
- | ([],"#Int") -> "/* # */int"
- | (["haxe";"io"],"Unsigned_char__") -> "unsigned char"
- | ([],"Class") -> "Class"
- | ([],"Null") -> (match params with
- | [t] ->
- (match follow t with
- | TInst ({ cl_path = [],"Int" },_)
- | TInst ({ cl_path = [],"Float" },_)
- | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic"
- | _ -> "/*NULL*/" ^ (type_string t) )
- | _ -> assert false);
- (* Normal class *)
- | _ -> (join_class_path klass.cl_path "::") ^ suffix
- )
- and type_string_suff suffix haxe_type =
- (match haxe_type with
- | TMono r -> (match !r with None -> "Dynamic" | Some t -> type_string_suff suffix t)
- | TAbstract ({ a_path = [],"Int" },[]) -> "int"
- | TAbstract ({ a_path = [],"Float" },[]) -> "double"
- | TAbstract ({ a_path = [],"Bool" },[]) -> "bool"
- | TAbstract ({ a_path = [],"Void" },[]) -> "Void"
- | TEnum (enum,params) -> (join_class_path enum.e_path "::") ^ suffix
- | TInst (klass,params) -> (class_string klass suffix params)
- | TAbstract (abs,params) -> (join_class_path abs.a_path "::") ^ suffix
- | TType (type_def,params) ->
- (match type_def.t_path with
- | [] , "Null" ->
- (match params with
- | [t] ->
- (match follow t with
- | TInst ({ cl_path = [],"Int" },_)
- | TInst ({ cl_path = [],"Float" },_)
- | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic"
- | _ -> type_string_suff suffix t)
- | _ -> assert false);
- | [] , "Array" ->
- (match params with
- | [t] -> "Array<" ^ (type_string (follow t) ) ^ " >"
- | _ -> assert false)
- | _ -> type_string_suff suffix (apply_params type_def.t_params params type_def.t_type)
- )
- | TFun (args,haxe_type) -> "Dynamic"
- | TAnon anon -> "Dynamic"
- | TDynamic haxe_type -> "Dynamic"
- | TLazy func -> type_string_suff suffix ((!func)())
- )
- and type_string haxe_type =
- type_string_suff "" haxe_type;;
- let debug_expression expression type_too =
- "/* " ^ Type.s_expr_kind expression ^ (if (type_too) then " = " ^ (type_string (follow expression.etype)) else "") ^ " */";;
- let rec register_extern_required_path ctx path =
- if (List.exists(fun p -> p = path) ctx.extern_classes_with_init) && not (List.exists(fun p -> p = path) ctx.extern_required_paths) then
- ctx.extern_required_paths <- path :: ctx.extern_required_paths
- let s_expr_expr = Type.s_expr_kind
- let s_expr_name e =
- s_type (print_context()) (follow e.etype)
- let s_type_name t =
- s_type (print_context()) t
- and start_with s test =
- let len = String.length test in
- (String.length s > len && String.sub s 0 len = test)
- let rec is_uncertain_type t =
- match follow t with
- | TInst (c, _) -> c.cl_interface
- | TMono _ -> true
- | TAnon a ->
- (match !(a.a_status) with
- | Statics _
- | EnumStatics _ -> false
- | _ -> true)
- | TDynamic _ -> true
- | _ -> false
- let is_uncertain_expr e =
- is_uncertain_type e.etype
- let rec is_anonym_type t =
- match follow t with
- | TAnon a ->
- (match !(a.a_status) with
- | Statics _
- | EnumStatics _ -> false
- | _ -> true)
- | TDynamic _ -> true
- | _ -> false
- let is_anonym_expr e = is_anonym_type e.etype
- let rec is_unknown_type t =
- match follow t with
- | TMono r ->
- (match !r with
- | None -> true
- | Some t -> is_unknown_type t)
- | _ -> false
- let is_unknown_expr e = is_unknown_type e.etype
- let rec is_string_type t =
- match follow t with
- | TInst ({cl_path = ([], "String")}, _) -> true
- | TAnon a ->
- (match !(a.a_status) with
- | Statics ({cl_path = ([], "String")}) -> true
- | _ -> false)
- | TAbstract (a,pl) -> is_string_type (Abstract.get_underlying_type a pl)
- | _ -> false
- let is_string_expr e = is_string_type e.etype
- let to_string ctx e =
- let v = alloc_var "__call__" t_dynamic in
- let f = mk (TLocal v) t_dynamic e.epos in
- mk (TCall (f, [ Codegen.string ctx.com "_hx_string_rec" e.epos; e; Codegen.string ctx.com "" e.epos])) ctx.com.basic.tstring e.epos
- let as_string_expr ctx e =
- match e.eexpr with
- | TConst (TNull) ->
- to_string ctx e
- | _ when not (is_string_expr e) ->
- to_string ctx e
- | _ -> e
- (* for known String type that could have null value *)
- let to_string_null ctx e =
- let v = alloc_var "__call__" t_dynamic in
- let f = mk (TLocal v) t_dynamic e.epos in
- mk (TCall (f, [ Codegen.string ctx.com "_hx_string_or_null" e.epos; e])) ctx.com.basic.tstring e.epos
- let as_string_expr ctx e = match e.eexpr with
- | TConst (TNull) -> to_string ctx e
- | TConst (TString s) -> e
- | TBinop (op,_,_) when (is_string_expr e)-> e
- | TCall ({eexpr = TField({eexpr = TTypeExpr(TClassDecl {cl_path = ([],"Std")})},FStatic(c,f) )}, [_]) when (f.cf_name="string") -> e
- | TCall ({eexpr = TLocal _}, [{eexpr = TConst (TString ("_hx_string_rec" | "_hx_str_or_null"))}]) -> e
- | _ when not (is_string_expr e) -> to_string ctx e
- | _ -> to_string_null ctx e
- let spr ctx s = Buffer.add_string ctx.buf s
- let print ctx = Printf.kprintf (fun s -> Buffer.add_string ctx.buf s)
- (*--php-prefix - added by skial bainn*)
- let prefix_class com name =
- match com.php_prefix with
- | Some prefix_class (* when not (String.length name <= 2 || String.sub name 0 2 = "__") *) ->
- prefix_class ^ name
- | _ ->
- name
- let prefix_init_replace com code =
- let r = Str.regexp "php_Boot" in
- Str.global_replace r ("php_" ^ (prefix_class com "Boot")) code
- let s_path ctx path isextern p =
- if isextern then begin
- register_extern_required_path ctx path;
- snd path
- end else begin
- (match path with
- (*--php-prefix*)
- | ([],"List") -> (prefix_class ctx.com "HList")
- (*--php-prefix*)
- | ([],name) -> (prefix_class ctx.com name)
- | (pack,name) ->
- (try
- (match Hashtbl.find ctx.imports name with
- | [p] when p = pack ->
- ()
- | packs ->
- if not (List.mem pack packs) then Hashtbl.replace ctx.imports name (pack :: packs))
- with Not_found ->
- Hashtbl.add ctx.imports name [pack]);
- (*--php-prefix*)
- String.concat "_" pack ^ "_" ^ (prefix_class ctx.com name))
- end
- let s_path_haxe path =
- match fst path, snd path with
- | [], s -> s
- | el, s -> String.concat "." el ^ "." ^ s
- let escape_bin s =
- let b = Buffer.create 0 in
- for i = 0 to String.length s - 1 do
- match Char.code (String.unsafe_get s i) with
- | c when c = Char.code('\\') || c = Char.code('"') || c = Char.code('$') ->
- Buffer.add_string b "\\";
- Buffer.add_char b (Char.chr c)
- | c when c < 32 ->
- Buffer.add_string b (Printf.sprintf "\\x%.2X" c)
- | c ->
- Buffer.add_char b (Char.chr c)
- done;
- Buffer.contents b
- (*
- haxe reserved words that match php ones: break, case, class, continue, default, do, else, extends, for, function, if, new, return, static, switch, var, while, interface, implements, public, private, try, catch, throw
- *)
- (* PHP only (for future use): cfunction, old_function *)
- let is_keyword n =
- match String.lowercase n with
- | "and" | "or" | "xor" | "__file__" | "exception" | "__line__" | "array"
- | "as" | "const" | "declare" | "die" | "echo"| "elseif" | "empty"
- | "enddeclare" | "endfor" | "endforeach" | "endif" | "endswitch"
- | "endwhile" | "eval" | "exit" | "foreach"| "global" | "include"
- | "include_once" | "isset" | "list" | "namespace" | "print" | "require" | "require_once"
- | "unset" | "use" | "__function__" | "__class__" | "__method__" | "final"
- | "php_user_filter" | "protected" | "abstract" | "__set" | "__get" | "__call"
- | "clone" | "instanceof" | "break" | "case" | "class" | "continue" | "default"
- | "do" | "else" | "extends" | "for" | "function" | "if" | "new" | "return"
- | "static" | "switch" | "var" | "while" | "interface" | "implements" | "public"
- | "private" | "try" | "catch" | "throw" | "goto"
- -> true
- | _ -> false
- let s_ident n =
- let suf = "h" in
- if (is_keyword n) then (suf ^ n) else n
- let s_ident_field n =
- if (is_keyword n) then ("{\"" ^ (escape_bin n) ^ "\"}") else n
- let s_ident_local n =
- let suf = "h" in
- match String.lowercase n with
- | "globals" | "_server" | "_get" | "_post" | "_cookie" | "_files"
- | "_env" | "_request" | "_session" -> suf ^ n
- | _ -> n
- let create_directory com ldir =
- let atm_path = ref (String.create 0) in
- atm_path := com.file;
- if not (Sys.file_exists com.file) then (Unix.mkdir com.file 0o755);
- (List.iter (fun p -> atm_path := !atm_path ^ "/" ^ p; if not (Sys.file_exists !atm_path) then (Unix.mkdir !atm_path 0o755);) ldir)
- let write_resource dir name data =
- let rdir = dir ^ "/res" in
- if not (Sys.file_exists dir) then Unix.mkdir dir 0o755;
- if not (Sys.file_exists rdir) then Unix.mkdir rdir 0o755;
- let name = Codegen.escape_res_name name false in
- let ch = open_out_bin (rdir ^ "/" ^ name) in
- output_string ch data;
- close_out ch
- let stack_init com use_add =
- Codegen.stack_context_init com "GLOBALS['%s']" "GLOBALS['%e']" "__hx__spos" "tmp" use_add null_pos
- let init com cwd path def_type =
- let rec create acc = function
- | [] -> ()
- | d :: l ->
- let pdir = String.concat "/" (List.rev (d :: acc)) in
- if not (Sys.file_exists pdir) then Unix.mkdir pdir 0o755;
- create (d :: acc) l
- in
- let dir = if cwd <> "" then com.file :: (cwd :: fst path) else com.file :: fst path; in
- create [] dir;
- let filename path =
- prefix_class com (match path with
- | [], "List" -> "HList";
- | _, s -> s) in
- (*--php-prefix*)
- let ch = open_out (String.concat "/" dir ^ "/" ^ (filename path) ^ (if def_type = 0 then ".class" else if def_type = 1 then ".enum" else if def_type = 2 then ".interface" else ".extern") ^ ".php") in
- let imports = Hashtbl.create 0 in
- Hashtbl.add imports (snd path) [fst path];
- let ctx = {
- com = com;
- stack = stack_init com false;
- tabs = "";
- ch = ch;
- path = path;
- buf = Buffer.create (1 lsl 14);
- in_value = None;
- in_loop = false;
- in_instance_method = false;
- imports = imports;
- extern_required_paths = [];
- extern_classes_with_init = [];
- curclass = null_class;
- curmethod = "";
- locals = PMap.empty;
- inv_locals = PMap.empty;
- local_types = [];
- inits = [];
- constructor_block = false;
- dynamic_methods = [];
- all_dynamic_methods = [];
- is_call = false;
- cwd = cwd;
- inline_methods = [];
- nested_loops = 0;
- inline_index = 0;
- in_block = false;
- lib_path = match com.php_lib with None -> "lib" | Some s -> s;
- } in
- Codegen.map_source_header com (fun s -> print ctx "// %s\n" s);
- ctx
- let unsupported msg p = error ("This expression cannot be generated to PHP: " ^ msg) p
- let newline ctx =
- match Buffer.nth ctx.buf (Buffer.length ctx.buf - 1) with
- | '{' | ':' | ' '
- | '}' when Buffer.nth ctx.buf (Buffer.length ctx.buf - 2) != '"' ->
- print ctx "\n%s" ctx.tabs
- | _ ->
- print ctx ";\n%s" ctx.tabs
- let rec concat ctx s f = function
- | [] -> ()
- | [x] -> f x
- | x :: l ->
- f x;
- spr ctx s;
- concat ctx s f l
- let open_block ctx =
- let oldt = ctx.tabs in
- ctx.tabs <- "\t" ^ ctx.tabs;
- (fun() -> ctx.tabs <- oldt)
- let parent e =
- match e.eexpr with
- | TParenthesis _ -> e
- | _ -> mk (TParenthesis e) e.etype e.epos
- let inc_extern_path ctx path =
- let rec slashes n =
- if n = 0 then "" else ("../" ^ slashes (n-1))
- in
- let pre = if ctx.cwd = "" then ctx.lib_path ^ "/" else "" in
- match path with
- | ([],name) ->
- pre ^ (slashes (List.length (fst ctx.path))) ^ (prefix_class ctx.com name) ^ ".extern.php"
- | (pack,name) ->
- pre ^ (slashes (List.length (fst ctx.path))) ^ String.concat "/" pack ^ "/" ^ (prefix_class ctx.com name) ^ ".extern.php"
- let close ctx =
- output_string ctx.ch "<?php\n";
- List.iter (fun path ->
- if path <> ctx.path then output_string ctx.ch ("require_once dirname(__FILE__).'/" ^ (inc_extern_path ctx path) ^ "';\n");
- ) (List.rev ctx.extern_required_paths);
- output_string ctx.ch "\n";
- output_string ctx.ch (Buffer.contents ctx.buf);
- close_out ctx.ch
- let save_locals ctx =
- let old = ctx.locals in
- let old_inv = ctx.inv_locals in
- (fun() -> ctx.locals <- old; ctx.inv_locals <- old_inv)
- let define_local ctx l =
- let rec loop n =
- let name = (if n = 1 then s_ident_local l else s_ident_local (l ^ string_of_int n)) in
- if PMap.mem name ctx.inv_locals then
- loop (n+1)
- else begin
- ctx.locals <- PMap.add l name ctx.locals;
- ctx.inv_locals <- PMap.add name l ctx.inv_locals;
- name
- end
- in
- loop 1
- let this ctx =
- if ctx.in_value <> None then "$__hx__this" else "$this"
- let gen_constant ctx p = function
- | TInt i -> print ctx "%ld" i
- | TFloat s -> spr ctx s
- | TString s ->
- print ctx "\"%s\"" (escape_bin s)
- | TBool b -> spr ctx (if b then "true" else "false")
- | TNull -> spr ctx "null"
- | TThis -> spr ctx (this ctx)
- | TSuper -> spr ctx "ERROR /* unexpected call to super in gen_constant */"
- let arg_is_opt c =
- match c with
- | Some _ -> true
- | None -> false
- let s_funarg ctx arg t p o =
- let byref = if (String.length arg > 7 && String.sub arg 0 7 = "byref__") then "&" else "" in
- print ctx "%s$%s" byref (s_ident_local arg);
- if o then spr ctx " = null"
- (*
- match c with
- | _, Some _ -> spr ctx " = null"
- | _, None -> ()
- *)
- let is_in_dynamic_methods ctx e s =
- List.exists (fun dm ->
- (* TODO: I agree, this is a mess ... but after hours of trials and errors I gave up; maybe in a calmer day *)
- ((String.concat "." ((fst dm.mpath) @ ["#" ^ (snd dm.mpath)])) ^ "." ^ dm.mname) = (s_type_name e.etype ^ "." ^ s)
- ) ctx.all_dynamic_methods
- let is_dynamic_method f =
- (match f.cf_kind with
- | Var _ -> true
- | Method MethDynamic -> true
- | _ -> false)
- let fun_block ctx f p =
- let e = (match f.tf_expr with { eexpr = TBlock [{ eexpr = TBlock _ } as e] } -> e | e -> e) in
- let e = List.fold_left (fun e (v,c) ->
- match c with
- | None | Some TNull -> e
- | Some c -> Type.concat (Codegen.set_default ctx.com v c p) e
- ) e f.tf_args in
- if ctx.com.debug then begin
- Codegen.stack_block ctx.stack ctx.curclass ctx.curmethod e
- end else
- mk_block e
- let rec gen_array_args ctx lst =
- match lst with
- | [] -> ()
- | h :: t ->
- spr ctx "[";
- gen_value ctx h;
- spr ctx "]";
- gen_array_args ctx t
- and gen_call ctx e el =
- let rec genargs lst =
- (match lst with
- | [] -> ()
- | h :: [] ->
- spr ctx " = ";
- gen_value ctx h;
- | h :: t ->
- spr ctx "[";
- gen_value ctx h;
- spr ctx "]";
- genargs t)
- in
- match e.eexpr , el with
- | TConst TSuper , params ->
- (match ctx.curclass.cl_super with
- | None -> assert false
- | Some (c,_) ->
- spr ctx "parent::__construct(";
- concat ctx "," (gen_value ctx) params;
- spr ctx ")";
- );
- | TField ({ eexpr = TConst TSuper },f) , params ->
- (match ctx.curclass.cl_super with
- | None -> assert false
- | Some (c,_) ->
- print ctx "parent::%s(" (s_ident (field_name f));
- concat ctx "," (gen_value ctx) params;
- spr ctx ")";
- );
- | TLocal { v_name = "__set__" }, { eexpr = TConst (TString code) } :: el ->
- print ctx "$%s" code;
- genargs el;
- | TLocal { v_name = "__set__" }, e :: el ->
- gen_value ctx e;
- genargs el;
- | TLocal { v_name = "__setfield__" }, e :: (f :: el) ->
- gen_value ctx e;
- spr ctx "->{";
- gen_value ctx f;
- spr ctx "}";
- genargs el;
- | TLocal { v_name = "__field__" }, e :: ({ eexpr = TConst (TString code) } :: el) ->
- gen_value ctx e;
- spr ctx "->";
- spr ctx code;
- gen_array_args ctx el;
- | TLocal { v_name = "__field__" }, e :: (f :: el) ->
- gen_value ctx e;
- spr ctx "->";
- gen_value ctx f;
- gen_array_args ctx el;
- | TLocal { v_name = "__prefix__" }, [] ->
- (match ctx.com.php_prefix with
- | Some prefix ->
- print ctx "\"%s\"" prefix
- | None ->
- spr ctx "null")
- | TLocal { v_name = "__var__" }, { eexpr = TConst (TString code) } :: el ->
- print ctx "$%s" code;
- gen_array_args ctx el;
- | TLocal { v_name = "__var__" }, e :: el ->
- gen_value ctx e;
- gen_array_args ctx el;
- | TLocal { v_name = "__call__" }, { eexpr = TConst (TString code) } :: el ->
- spr ctx code;
- spr ctx "(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")";
- | TLocal { v_name = "__php__" }, [{ eexpr = TConst (TString code) }] ->
- (*--php-prefix*)
- spr ctx (prefix_init_replace ctx.com code)
- | TLocal { v_name = "__php__" }, { eexpr = TConst (TString code); epos = p } :: tl ->
- Codegen.interpolate_code ctx.com code tl (spr ctx) (gen_expr ctx) p
- | TLocal { v_name = "__instanceof__" }, [e1;{ eexpr = TConst (TString t) }] ->
- gen_value ctx e1;
- print ctx " instanceof %s" t;
- | TLocal { v_name = "__physeq__" }, [e1;e2] ->
- spr ctx "(";
- gen_value ctx e1;
- spr ctx " === ";
- gen_value ctx e2;
- spr ctx ")"
- | TLocal _, []
- | TFunction _, []
- | TCall _, []
- | TParenthesis _, []
- | TMeta _, []
- | TBlock _, [] ->
- ctx.is_call <- true;
- spr ctx "call_user_func(";
- gen_value ctx e;
- ctx.is_call <- false;
- spr ctx ")";
- | TLocal _, el
- | TFunction _, el
- | TCall _, el
- | TParenthesis _, el
- | TMeta _, el
- | TBlock _, el ->
- ctx.is_call <- true;
- spr ctx "call_user_func_array(";
- gen_value ctx e;
- ctx.is_call <- false;
- spr ctx ", array(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx "))"
- (*
- | TCall (x,_), el when (match x.eexpr with | TLocal _ -> false | _ -> true) ->
- ctx.is_call <- true;
- spr ctx "call_user_func_array(";
- gen_value ctx e;
- ctx.is_call <- false;
- spr ctx ", array(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx "))"
- *)
- | _ ->
- ctx.is_call <- true;
- gen_value ctx e;
- ctx.is_call <- false;
- spr ctx "(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")";
- and could_be_string_var s =
- s = "length"
- and gen_uncertain_string_var ctx s e =
- match s with
- | "length" ->
- spr ctx "_hx_len(";
- gen_value ctx e;
- spr ctx ")"
- | _ ->
- gen_field_access ctx true e s;
- and gen_string_var ctx s e =
- match s with
- | "length" ->
- spr ctx "strlen(";
- gen_value ctx e;
- spr ctx ")"
- | _ ->
- unsupported "gen_string_var " e.epos;
- and gen_string_static_call ctx s e el =
- match s with
- | "fromCharCode" ->
- spr ctx "chr(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")";
- | _ -> unsupported "gen_string_static_call " e.epos;
- and could_be_string_call s =
- s = "substr" || s = "substring" || s = "charAt" || s = "charCodeAt" || s = "indexOf" ||
- s = "lastIndexOf" || s = "split" || s = "toLowerCase" || s = "toString" || s = "toUpperCase"
- and gen_string_call ctx s e el =
- match s with
- | "substr" ->
- spr ctx "_hx_substr(";
- gen_value ctx e;
- spr ctx ", ";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")"
- | "substring" ->
- spr ctx "_hx_substring(";
- gen_value ctx e;
- spr ctx ", ";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")"
- | "charAt" ->
- spr ctx "_hx_char_at(";
- gen_value ctx e;
- spr ctx ", ";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")"
- | "cca" ->
- spr ctx "ord(substr(";
- gen_value ctx e;
- spr ctx ",";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ",1))"
- | "charCodeAt" ->
- spr ctx "_hx_char_code_at(";
- gen_value ctx e;
- spr ctx ", ";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")"
- | "indexOf" ->
- spr ctx "_hx_index_of(";
- gen_value ctx e;
- spr ctx ", ";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")"
- | "lastIndexOf" ->
- spr ctx "_hx_last_index_of(";
- gen_value ctx e;
- spr ctx ", ";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")"
- | "split" ->
- spr ctx "_hx_explode(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ", ";
- gen_value ctx e;
- spr ctx ")"
- | "toLowerCase" ->
- spr ctx "strtolower(";
- gen_value ctx e;
- spr ctx ")"
- | "toUpperCase" ->
- spr ctx "strtoupper(";
- gen_value ctx e;
- spr ctx ")"
- | "toString" ->
- gen_value ctx e;
- | _ ->
- unsupported "gen_string_call" e.epos;
- and gen_uncertain_string_call ctx s e el =
- spr ctx "_hx_string_call(";
- gen_value ctx e;
- print ctx ", \"%s\", array(" s;
- concat ctx ", " (gen_value ctx) el;
- spr ctx "))"
- and gen_field_op ctx e =
- match e.eexpr with
- | TField (f,s) ->
- (match follow e.etype with
- | TFun _ ->
- gen_field_access ctx true f (field_name s)
- | _ ->
- gen_value_op ctx e)
- | _ ->
- gen_value_op ctx e
- and gen_value_op ctx e =
- match e.eexpr with
- | TBinop (op,_,_) when op = Ast.OpAnd || op = Ast.OpOr || op = Ast.OpXor ->
- gen_value ctx e;
- | _ ->
- gen_value ctx e
- and is_static t =
- match follow t with
- | TAnon a -> (match !(a.a_status) with
- | Statics c -> true
- | _ -> false)
- | _ -> false
- and gen_member_access ctx isvar e s =
- match follow e.etype with
- | TAnon a ->
- (match !(a.a_status) with
- | EnumStatics _ ->
- print ctx "::%s%s" (if isvar then "$" else "") (s_ident s)
- | Statics _ ->
- print ctx "::%s%s" (if isvar then "$" else "") (s_ident s)
- | _ -> print ctx "->%s" (if isvar then s_ident_field s else s_ident s))
- | _ -> print ctx "->%s" (if isvar then s_ident_field s else s_ident s)
- and gen_field_access ctx isvar e s =
- match e.eexpr with
- | TTypeExpr t ->
- spr ctx (s_path ctx (t_path t) false e.epos);
- gen_member_access ctx isvar e s
- | TLocal _ ->
- gen_expr ctx e;
- print ctx "->%s" (if isvar then s_ident_field s else s_ident s)
- | TArray (e1,e2) ->
- spr ctx "_hx_array_get(";
- gen_value ctx e1;
- spr ctx ", ";
- gen_value ctx e2;
- spr ctx ")";
- gen_member_access ctx isvar e s
- | TBlock _
- | TParenthesis _
- | TMeta _
- | TObjectDecl _
- | TArrayDecl _
- | TNew _ ->
- spr ctx "_hx_deref(";
- ctx.is_call <- false;
- gen_value ctx e;
- spr ctx ")";
- gen_member_access ctx isvar e s
- | TCast (ec, _) when (match ec.eexpr with | TNew _ | TArrayDecl _ -> true | _ -> false) ->
- spr ctx "_hx_deref(";
- ctx.is_call <- false;
- gen_value ctx e;
- spr ctx ")";
- gen_member_access ctx isvar e s
- | _ ->
- gen_expr ctx e;
- gen_member_access ctx isvar e s
- and gen_dynamic_function ctx isstatic name f params p =
- let old = ctx.in_value in
- let old_l = ctx.locals in
- let old_li = ctx.inv_locals in
- let old_t = ctx.local_types in
- ctx.in_value <- None;
- ctx.local_types <- List.map snd params @ ctx.local_types;
- let byref = if (String.length name > 9 && String.sub name 0 9 = "__byref__") then "&" else "" in
- print ctx "function %s%s(" byref name;
- concat ctx ", " (fun (v,c) ->
- let arg = define_local ctx v.v_name in
- s_funarg ctx arg v.v_type p (arg_is_opt c);
- ) f.tf_args;
- spr ctx ") {";
- if (List.length f.tf_args) > 0 then begin
- if isstatic then
- print ctx " return call_user_func_array(self::$%s, array(" name
- else
- print ctx " return call_user_func_array($this->%s, array(" name;
- concat ctx ", " (fun (v,_) ->
- spr ctx ("$" ^ v.v_name)
- ) f.tf_args;
- print ctx ")); }";
- end else if isstatic then
- print ctx " return call_user_func(self::$%s); }" name
- else
- print ctx " return call_user_func($this->%s); }" name;
- newline ctx;
- if isstatic then
- print ctx "public static $%s = null" name
- else
- print ctx "public $%s = null" name;
- ctx.in_value <- old;
- ctx.locals <- old_l;
- ctx.inv_locals <- old_li;
- ctx.local_types <- old_t
- and gen_function ctx name f params p =
- let old = ctx.in_value in
- let old_l = ctx.locals in
- let old_li = ctx.inv_locals in
- let old_t = ctx.local_types in
- ctx.in_value <- None;
- ctx.local_types <- List.map snd params @ ctx.local_types;
- let byref = if (String.length name > 9 && String.sub name 0 9 = "__byref__") then "&" else "" in
- print ctx "function %s%s(" byref name;
- concat ctx ", " (fun (v,o) ->
- let arg = define_local ctx v.v_name in
- s_funarg ctx arg v.v_type p (arg_is_opt o);
- ) f.tf_args;
- print ctx ") ";
- gen_expr ctx (fun_block ctx f p);
- ctx.in_value <- old;
- ctx.locals <- old_l;
- ctx.inv_locals <- old_li;
- ctx.local_types <- old_t
- and gen_inline_function ctx f hasthis p =
- ctx.nested_loops <- ctx.nested_loops - 1;
- let old = ctx.in_value in
- let old_l = ctx.locals in
- let old_li = ctx.inv_locals in
- let old_t = ctx.local_types in
- ctx.in_value <- Some "closure";
- let args a = List.map (fun (v,_) -> v.v_name) a in
- let used_locals = ref PMap.empty in
- let rec loop e = match e.eexpr with
- | TLocal v when not (start_with v.v_name "__hx__") && PMap.mem v.v_name old_l ->
- used_locals := PMap.add v.v_name v.v_name !used_locals
- | _ ->
- Type.iter loop e
- in
- loop f.tf_expr;
- spr ctx "array(new _hx_lambda(array(";
- let c = ref 0 in
- let print_arg a =
- if !c > 0 then spr ctx ", ";
- incr c;
- print ctx "&$%s" a;
- in
- if hasthis then print_arg "this";
- PMap.iter (fun _ a -> print_arg a) !used_locals;
- spr ctx "), \"";
- spr ctx (inline_function ctx (args f.tf_args) hasthis !used_locals (fun_block ctx f p));
- print ctx "\"), 'execute')";
- ctx.in_value <- old;
- ctx.locals <- old_l;
- ctx.inv_locals <- old_li;
- ctx.local_types <- old_t;
- ctx.nested_loops <- ctx.nested_loops + 1;
- and unset_locals ctx old_l =
- let lst = ref [] in
- PMap.iter (fun n _ ->
- if not (PMap.exists n old_l) then
- lst := ["$" ^ n] @ !lst;
- ) ctx.inv_locals;
- if (List.length !lst) > 0 then begin
- newline ctx;
- spr ctx "unset(";
- concat ctx "," (fun (s) -> spr ctx s; ) !lst;
- spr ctx ")"
- end
- and gen_while_expr ctx e =
- let old_loop = ctx.in_loop in
- ctx.in_loop <- true;
- let old_nested_loops = ctx.nested_loops in
- ctx.nested_loops <- 1;
- let old_l = ctx.inv_locals in
- let b = save_locals ctx in
- (match e.eexpr with
- | TBlock (el) ->
- List.iter (fun e -> newline ctx; gen_expr ctx e) el;
- | _ ->
- newline ctx;
- gen_expr ctx e);
- unset_locals ctx old_l;
- b();
- ctx.nested_loops <- old_nested_loops;
- ctx.in_loop <- old_loop
- and gen_tfield ctx e e1 s =
- match follow e.etype with
- | TFun (args, _) ->
- (if ctx.is_call then begin
- gen_field_access ctx false e1 s
- end else if is_in_dynamic_methods ctx e1 s then begin
- gen_field_access ctx true e1 s;
- end else begin
- let ob ex =
- (match ex with
- | TTypeExpr t ->
- print ctx "\"";
- spr ctx (s_path ctx (t_path t) false e1.epos);
- print ctx "\""
- | _ ->
- gen_expr ctx e1) in
- spr ctx "(isset(";
- gen_field_access ctx true e1 s;
- spr ctx ") ? ";
- gen_field_access ctx true e1 s;
- spr ctx ": array(";
- ob e1.eexpr;
- print ctx ", \"%s\"))" (s_ident s);
- end)
- | TMono _ ->
- if ctx.is_call then
- gen_field_access ctx false e1 s
- else
- gen_uncertain_string_var ctx s e1
- | _ ->
- if is_string_expr e1 then
- gen_string_var ctx s e1
- else if is_uncertain_expr e1 then
- gen_uncertain_string_var ctx s e1
- else
- gen_field_access ctx true e1 s
- and gen_expr ctx e =
- let in_block = ctx.in_block in
- ctx.in_block <- false;
- let restore_in_block ctx inb =
- if inb then ctx.in_block <- true
- in
- match e.eexpr with
- | TConst c ->
- gen_constant ctx e.epos c
- | TLocal v ->
- spr ctx ("$" ^ (try PMap.find v.v_name ctx.locals with Not_found -> (s_ident_local v.v_name)))
- | TArray (e1,e2) ->
- (match e1.eexpr with
- | TCall _
- | TBlock _
- | TParenthesis _
- | TMeta _
- | TArrayDecl _ ->
- spr ctx "_hx_array_get(";
- gen_value ctx e1;
- spr ctx ", ";
- gen_value ctx e2;
- spr ctx ")";
- | TCast (ec, _) when (match ec.eexpr with | TArrayDecl _ | TBlock _ -> true | _ -> false) ->
- spr ctx "_hx_array_get(";
- gen_value ctx e1;
- spr ctx ", ";
- gen_value ctx e2;
- spr ctx ")";
- | _ ->
- gen_value ctx e1;
- spr ctx "[";
- gen_value ctx e2;
- spr ctx "]");
- | TBinop (op,e1,e2) ->
- (* these operators are non-assoc in php, let let's make sure to separate them with parenthesises *)
- let non_assoc = function
- | (Ast.OpEq | Ast.OpNotEq | Ast.OpGt | Ast.OpGte | Ast.OpLt | Ast.OpLte) -> true
- | _ -> false
- in
- (match e1.eexpr with
- | TBinop (op2,_,_) when non_assoc op && non_assoc op2 ->
- gen_expr ctx { e with eexpr = TBinop (op,mk (TParenthesis e1) e1.etype e1.epos,e2) }
- | _ ->
- let leftside e =
- (match e.eexpr with
- | TArray(te1, te2) ->
- gen_value ctx te1;
- spr ctx "->a[";
- gen_value ctx te2;
- spr ctx "]";
- | _ ->
- gen_field_op ctx e1;) in
- let leftsidec e =
- (match e.eexpr with
- | TArray(te1, te2) ->
- gen_value ctx te1;
- spr ctx "->a[";
- gen_value ctx te2;
- spr ctx "]";
- | TField (e1,s) ->
- gen_field_access ctx true e1 (field_name s)
- | _ ->
- gen_field_op ctx e1;) in
- let leftsidef e =
- (match e.eexpr with
- | TField (e1,s) ->
- gen_field_access ctx true e1 (field_name s)
- | _ ->
- gen_field_op ctx e1;
- ) in
- (match op with
- | Ast.OpMod ->
- spr ctx "_hx_mod(";
- gen_value_op ctx e1;
- spr ctx ", ";
- gen_value_op ctx e2;
- spr ctx ")";
- | Ast.OpAssign ->
- (match e1.eexpr with
- | TArray(te1, te2) when (match te1.eexpr with | TCall _ | TParenthesis _ -> true | _ -> false) ->
- spr ctx "_hx_array_assign(";
- gen_value ctx te1;
- spr ctx ", ";
- gen_value ctx te2;
- spr ctx ", ";
- gen_value_op ctx e2;
- spr ctx ")";
- | _ ->
- leftsidef e1;
- spr ctx " = ";
- gen_value_op ctx e2;
- )
- | Ast.OpAssignOp(Ast.OpAdd) when (is_uncertain_expr e1 && is_uncertain_expr e2) ->
- (match e1.eexpr with
- | TArray(te1, te2) ->
- let t1 = define_local ctx "__hx__t1" in
- let t2 = define_local ctx "__hx__t2" in
- print ctx "_hx_array_assign($%s = " t1;
- gen_value ctx te1;
- print ctx ", $%s = " t2;
- gen_value ctx te2;
- print ctx ", $%s->a[$%s] + " t1 t2;
- gen_value_op ctx e2;
- spr ctx ")";
- | _ ->
- leftside e1;
- spr ctx " = ";
- spr ctx "_hx_add(";
- gen_value_op ctx e1;
- spr ctx ", ";
- gen_value_op ctx e2;
- spr ctx ")";
- )
- | Ast.OpAssignOp(Ast.OpAdd) when (is_string_expr e1 || is_string_expr e2) ->
- leftside e1;
- spr ctx " .= ";
- gen_value_op ctx (as_string_expr ctx e2);
- | Ast.OpAssignOp(Ast.OpShl) ->
- leftside e1;
- spr ctx " <<= ";
- gen_value_op ctx e2;
- | Ast.OpAssignOp(Ast.OpUShr) ->
- leftside e1;
- spr ctx " = ";
- spr ctx "_hx_shift_right(";
- gen_value_op ctx e1;
- spr ctx ", ";
- gen_value_op ctx e2;
- spr ctx ")";
- | Ast.OpAssignOp(Ast.OpMod) ->
- leftside e1;
- spr ctx " = ";
- spr ctx "_hx_mod(";
- gen_value_op ctx e1;
- spr ctx ", ";
- gen_value_op ctx e2;
- spr ctx ")";
- | Ast.OpAssignOp(_) ->
- leftsidec e1;
- print ctx " %s " (Ast.s_binop op);
- gen_value_op ctx e2;
- | Ast.OpAdd when (is_uncertain_expr e1 && is_uncertain_expr e2) ->
- spr ctx "_hx_add(";
- gen_value_op ctx e1;
- spr ctx ", ";
- gen_value_op ctx e2;
- spr ctx ")";
- | Ast.OpAdd when (is_string_expr e1 || is_string_expr e2) ->
- gen_value_op ctx (as_string_expr ctx e1);
- spr ctx " . ";
- gen_value_op ctx (as_string_expr ctx e2);
- | Ast.OpShl ->
- gen_value_op ctx e1;
- spr ctx " << ";
- gen_value_op ctx e2;
- | Ast.OpUShr ->
- spr ctx "_hx_shift_right(";
- gen_value_op ctx e1;
- spr ctx ", ";
- gen_value_op ctx e2;
- spr ctx ")";
- | Ast.OpNotEq
- | Ast.OpEq ->
- let s_op = if op = Ast.OpNotEq then " != " else " == " in
- let s_phop = if op = Ast.OpNotEq then " !== " else " === " in
- let se1 = s_expr_name e1 in
- let se2 = s_expr_name e2 in
- if
- e1.eexpr = TConst (TNull)
- || e2.eexpr = TConst (TNull)
- then begin
- (match e1.eexpr with
- | TField (f, s) when is_anonym_expr e1 || is_unknown_expr e1 ->
- spr ctx "_hx_field(";
- gen_value ctx f;
- print ctx ", \"%s\")" (field_name s);
- | _ ->
- gen_field_op ctx e1;
- );
- spr ctx s_phop;
- (match e2.eexpr with
- | TField (f, s) when is_anonym_expr e2 || is_unknown_expr e2 ->
- spr ctx "_hx_field(";
- gen_value ctx f;
- print ctx ", \"%s\")" (field_name s);
- | _ ->
- gen_field_op ctx e2);
- end else if
- ((se1 = "Int" || se1 = "Null<Int>") && (se2 = "Int" || se2 = "Null<Int>"))
- || ((se1 = "Float" || se1 = "Null<Float>") && (se2 = "Float" || se2 = "Null<Float>"))
- then begin
- gen_field_op ctx e1;
- spr ctx s_phop;
- gen_field_op ctx e2;
- end else if
- ((se1 = "Int" || se1 = "Float" || se1 = "Null<Int>" || se1 = "Null<Float>")
- && (se1 = "Int" || se1 = "Float" || se1 = "Null<Int>" || se1 = "Null<Float>"))
- || (is_unknown_expr e1 && is_unknown_expr e2)
- || is_anonym_expr e1
- || is_anonym_expr e2
- then begin
- if op = Ast.OpNotEq then spr ctx "!";
- spr ctx "_hx_equal(";
- gen_field_op ctx e1;
- spr ctx ", ";
- gen_field_op ctx e2;
- spr ctx ")";
- end else if
- (
- se1 == se2
- || (match e1.eexpr with | TConst _ | TLocal _ | TArray _ | TNew _ -> true | _ -> false)
- || (match e2.eexpr with | TConst _ | TLocal _ | TArray _ | TNew _ -> true | _ -> false)
- || is_string_expr e1
- || is_string_expr e2
- || is_anonym_expr e1
- || is_anonym_expr e2
- || is_unknown_expr e1
- || is_unknown_expr e2
- )
- && (type_string (follow e1.etype)) <> "Dynamic"
- && (type_string (follow e2.etype)) <> "Dynamic"
- then begin
- gen_field_op ctx e1;
- spr ctx s_phop;
- gen_field_op ctx e2;
- end else begin
- let tmp = define_local ctx "_t" in
- print ctx "(is_object($%s = " tmp;
- gen_field_op ctx e1;
- print ctx ") && !($%s instanceof Enum) ? $%s%s" tmp tmp s_phop;
- gen_field_op ctx e2;
- print ctx " : $%s%s" tmp s_op;
- gen_field_op ctx e2;
- spr ctx ")";
- end
- | Ast.OpGt | Ast.OpGte | Ast.OpLt | Ast.OpLte when is_string_expr e1 ->
- spr ctx "(strcmp(";
- gen_field_op ctx e1;
- spr ctx ", ";
- gen_field_op ctx e2;
- spr ctx ")";
- let op_str = match op with
- | Ast.OpGt -> ">"
- | Ast.OpGte -> ">="
- | Ast.OpLt -> "<"
- | Ast.OpLte -> "<="
- | _ -> assert false
- in
- print ctx "%s 0)" op_str
- | _ ->
- leftside e1;
- print ctx " %s " (Ast.s_binop op);
- gen_value_op ctx e2;
- ));
- | TEnumParameter(e1,_,i) ->
- spr ctx "_hx_deref(";
- gen_value ctx e1;
- spr ctx ")";
- print ctx "->params[%d]" i;
- | TField (e1,s) ->
- gen_tfield ctx e e1 (field_name s)
- | TTypeExpr t ->
- print ctx "_hx_qtype(\"%s\")" (s_path_haxe (t_path t))
- | TParenthesis e ->
- (match e.eexpr with
- | TParenthesis _
- | TReturn _ ->
- gen_value ctx e;
- | _ ->
- spr ctx "(";
- gen_value ctx e;
- spr ctx ")"
- );
- | TMeta (_,e) ->
- gen_expr ctx e
- | TReturn eo ->
- (match eo with
- | None ->
- spr ctx "return"
- | Some e when (match follow e.etype with TEnum({ e_path = [],"Void" },[]) | TAbstract ({ a_path = [],"Void" },[]) -> true | _ -> false) ->
- gen_value ctx e;
- newline ctx;
- spr ctx "return"
- | Some e ->
- (match e.eexpr with
- | TThrow _ -> ()
- | _ -> spr ctx "return ");
- gen_value ctx e;
- );
- | TBreak ->
- if ctx.in_loop then spr ctx "break" else print ctx "break %d" ctx.nested_loops
- | TContinue ->
- if ctx.in_loop then spr ctx "continue" else print ctx "continue %d" ctx.nested_loops
- | TBlock [] ->
- spr ctx "{}"
- | TBlock el ->
- let old_l = ctx.inv_locals in
- let b = save_locals ctx in
- print ctx "{";
- let bend = open_block ctx in
- let cb = (
- if not ctx.constructor_block then
- (fun () -> ())
- else begin
- ctx.constructor_block <- false;
- if List.length ctx.dynamic_methods > 0 then newline ctx else spr ctx " ";
- List.iter (fun (f) ->
- let name = f.cf_name in
- match f.cf_expr with
- | Some { eexpr = TFunction fd } ->
- print ctx "if(!isset($this->%s)) $this->%s = " name name;
- gen_inline_function ctx fd true e.epos;
- newline ctx;
- | _ -> ()
- ) ctx.dynamic_methods;
- if Codegen.constructor_side_effects e then begin
- print ctx "if(!%s::$skip_constructor) {" (s_path ctx (["php"],"Boot") false e.epos);
- (fun() -> print ctx "}")
- end else
- (fun() -> ());
- end) in
- let remaining = ref (List.length el) in
- let build e =
- newline ctx;
- if (in_block && !remaining = 1) then begin
- (match e.eexpr with
- | TIf _
- | TSwitch _
- | TThrow _
- | TWhile _
- | TFor _
- | TTry _
- | TBreak
- | TBlock _ ->
- restore_in_block ctx in_block;
- gen_expr ctx e;
- unset_locals ctx old_l;
- | TReturn (Some e1) ->
- (match e1.eexpr with
- | TIf _
- | TSwitch _
- | TThrow _
- | TWhile _
- | TFor _
- | TTry _
- | TBlock _ -> ()
- | _ ->
- spr ctx "return "
- );
- gen_expr ctx e1;
- | _ ->
- spr ctx "return ";
- gen_value ctx e;
- )
- end else begin
- gen_expr ctx e;
- end;
- decr remaining;
- in
- List.iter build el;
- if ctx.in_loop then begin
- unset_locals ctx old_l;
- end;
- bend();
- newline ctx;
- cb();
- print ctx "}";
- b();
- | TFunction f ->
- let old = ctx.in_value, ctx.in_loop in
- let old_meth = ctx.curmethod in
- ctx.in_value <- None;
- ctx.in_loop <- false;
- ctx.curmethod <- ctx.curmethod ^ "@" ^ string_of_int (Lexer.get_error_line e.epos);
- gen_inline_function ctx f false e.epos;
- ctx.curmethod <- old_meth;
- ctx.in_value <- fst old;
- ctx.in_loop <- snd old;
- | TCall (ec,el) ->
- (match ec.eexpr with
- | TArray _ ->
- spr ctx "call_user_func_array(";
- gen_value ctx ec;
- spr ctx ", array(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx "))";
- | TField (ef,s) when is_static ef.etype && is_string_expr ef ->
- gen_string_static_call ctx (field_name s) ef el
- | TField (ef,s) when is_string_expr ef ->
- gen_string_call ctx (field_name s) ef el
- | TField (ef,s) when is_anonym_expr ef && could_be_string_call (field_name s) ->
- gen_uncertain_string_call ctx (field_name s) ef el
- | _ ->
- gen_call ctx ec el);
- | TArrayDecl el ->
- spr ctx "(new _hx_array(array(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx ")))";
- | TThrow e ->
- spr ctx "throw new HException(";
- gen_value ctx e;
- spr ctx ")";
- | TVar (v,eo) ->
- spr ctx "$";
- let restore = save_locals ctx in
- let n = define_local ctx v.v_name in
- let restore2 = save_locals ctx in
- restore();
- (match eo with
- | None ->
- print ctx "%s = null" (s_ident_local n)
- | Some e ->
- print ctx "%s = " (s_ident_local n);
- gen_value ctx e);
- restore2()
- | TNew (c,_,el) ->
- (match c.cl_path, el with
- | ([], "String"), _ ->
- concat ctx "" (gen_value ctx) el
- | ([], "Array"), el ->
- spr ctx "new _hx_array(array(";
- concat ctx ", " (gen_value ctx) el;
- spr ctx "))"
- | (_, _), _ ->
- print ctx "new %s(" (s_path ctx c.cl_path c.cl_extern e.epos);
- let count = ref (-1) in
- concat ctx ", " (fun e ->
- incr count;
- match c.cl_constructor with
- | Some f ->
- gen_value ctx e;
- | _ -> ();
- ) el;
- spr ctx ")")
- | TIf (cond,e,eelse) ->
- spr ctx "if";
- gen_value ctx (parent cond);
- spr ctx " ";
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e);
- (match eelse with
- | None -> ()
- | Some e when e.eexpr = TConst(TNull) -> ()
- | Some e ->
- spr ctx " else ";
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e));
- | TUnop (op,Ast.Prefix,e) ->
- (match e.eexpr with
- | TArray(te1, te2) ->
- (match op with
- | Increment ->
- spr ctx "_hx_array_increment(";
- gen_value ctx te1;
- spr ctx ",";
- gen_value ctx te2;
- spr ctx ")";
- | Decrement ->
- spr ctx "_hx_array_decrement(";
- gen_value ctx te1;
- spr ctx ",";
- gen_value ctx te2;
- spr ctx ")";
- | _ ->
- spr ctx (Ast.s_unop op);
- gen_value ctx te1;
- spr ctx "[";
- gen_value ctx te2;
- spr ctx "]";
- );
- | TField (e1,s) ->
- spr ctx (Ast.s_unop op);
- gen_tfield ctx e e1 (field_name s)
- | _ ->
- spr ctx (Ast.s_unop op);
- gen_value ctx e)
- | TUnop (op,Ast.Postfix,e) ->
- (match e.eexpr with
- | TArray(te1, te2) ->
- gen_value ctx te1;
- spr ctx "->a[";
- gen_value ctx te2;
- spr ctx "]";
- | TField (e1,s) ->
- gen_field_access ctx true e1 (field_name s)
- | _ ->
- gen_value ctx e);
- spr ctx (Ast.s_unop op)
- | TWhile (cond,e,Ast.NormalWhile) ->
- let old = save_locals ctx in
- spr ctx "while";
- gen_value ctx (parent cond);
- spr ctx " {";
- let bend = open_block ctx in
- gen_while_expr ctx e;
- bend();
- newline ctx;
- spr ctx "}";
- old()
- | TWhile (cond,e,Ast.DoWhile) ->
- let old = save_locals ctx in
- spr ctx "do {";
- let bend = open_block ctx in
- gen_while_expr ctx e;
- bend();
- newline ctx;
- spr ctx "} while";
- gen_value ctx (parent cond);
- old()
- | TObjectDecl fields ->
- spr ctx "_hx_anonymous(array(";
- concat ctx ", " (fun (f,e) -> print ctx "\"%s\" => " (escape_bin f); gen_value ctx e) fields;
- spr ctx "))"
- | TFor (v,it,e) ->
- let b = save_locals ctx in
- let tmp = define_local ctx "__hx__it" in
- let v = define_local ctx v.v_name in
- (match it.eexpr with
- | TCall (e,_) ->
- (match e.eexpr with
- | TField (e,f) ->
- spr ctx "if(null == ";
- gen_value ctx e;
- spr ctx ") throw new HException('null iterable')";
- newline ctx;
- | _ ->
- ());
- | _ -> ()
- );
- print ctx "$%s = " tmp;
- gen_value ctx it;
- newline ctx;
- print ctx "while($%s->hasNext()) {" tmp;
- let bend = open_block ctx in
- newline ctx;
- (* unset loop variable (issue #2900) *)
- print ctx "unset($%s)" v;
- newline ctx;
- print ctx "$%s = $%s->next()" v tmp;
- gen_while_expr ctx e;
- bend();
- newline ctx;
- spr ctx "}";
- b();
- | TTry (e,catchs) ->
- spr ctx "try ";
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e);
- let old = save_locals ctx in
- let ex = define_local ctx "__hx__e" in
- print ctx "catch(Exception $%s) {" ex;
- let bend = open_block ctx in
- let first = ref true in
- let catchall = ref false in
- let evar = define_local ctx "_ex_" in
- newline ctx;
- print ctx "$%s = ($%s instanceof HException) ? $%s->e : $%s" evar ex ex ex;
- old();
- List.iter (fun (v,e) ->
- let ev = define_local ctx v.v_name in
- newline ctx;
- let b = save_locals ctx in
- if not !first then spr ctx "else ";
- (match follow v.v_type with
- | TEnum (te,_) -> (match te.e_path with
- | [], "Bool" -> print ctx "if(is_bool($%s = $%s))" ev evar
- | _ -> print ctx "if(($%s = $%s) instanceof %s)" ev evar (s_path ctx te.e_path te.e_extern e.epos));
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e);
- | TInst (tc,_) -> (match tc.cl_path with
- | [], "Int" -> print ctx "if(is_int($%s = $%s))" ev evar
- | [], "Float" -> print ctx "if(is_numeric($%s = $%s))" ev evar
- | [], "String" -> print ctx "if(is_string($%s = $%s))" ev evar
- | [], "Array" -> print ctx "if(($%s = $%s) instanceof _hx_array)" ev evar
- | _ -> print ctx "if(($%s = $%s) instanceof %s)" ev evar (s_path ctx tc.cl_path tc.cl_extern e.epos));
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e);
- | TAbstract (ta,_) -> (match ta.a_path with
- | [], "Int" -> print ctx "if(is_int($%s = $%s))" ev evar
- | [], "Float" -> print ctx "if(is_numeric($%s = $%s))" ev evar
- | [], "Bool" -> print ctx "if(is_bool($%s = $%s))" ev evar
- | _ -> print ctx "if(($%s = $%s) instanceof %s)" ev evar (s_path ctx ta.a_path false e.epos));
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e);
- | TFun _
- | TLazy _
- | TType _
- | TAnon _ ->
- assert false
- | TMono _
- | TDynamic _ ->
- catchall := true;
- if not !first then spr ctx "{ ";
- print ctx "$%s = $%s" ev evar;
- newline ctx;
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e);
- if not !first then spr ctx "}"
- );
- b();
- first := false;
- ) catchs;
- if not !catchall then
- print ctx " else throw $%s;" ex;
- bend();
- newline ctx;
- spr ctx "}"
- | TSwitch (e,cases,def) ->
- let old_loop = ctx.in_loop in
- ctx.in_loop <- false;
- ctx.nested_loops <- ctx.nested_loops + 1;
- let old = save_locals ctx in
- spr ctx "switch";
- gen_value ctx (parent e);
- spr ctx " {";
- newline ctx;
- List.iter (fun (el,e2) ->
- List.iter (fun e ->
- spr ctx "case ";
- gen_value ctx e;
- spr ctx ":";
- ) el;
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e2);
- print ctx "break";
- newline ctx;
- ) cases;
- (match def with
- | None -> ()
- | Some e ->
- spr ctx "default:";
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e);
- print ctx "break";
- newline ctx;
- );
- spr ctx "}";
- ctx.nested_loops <- ctx.nested_loops - 1;
- ctx.in_loop <- old_loop;
- old()
- | TCast (e,None) ->
- gen_expr ctx e
- | TCast (e1,Some t) ->
- let mk_texpr = function
- | TClassDecl c -> TAnon { a_fields = PMap.empty; a_status = ref (Statics c) }
- | TEnumDecl e -> TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics e) }
- | TAbstractDecl a -> TAnon { a_fields = PMap.empty; a_status = ref (AbstractStatics a) }
- | TTypeDecl _ -> assert false
- in
- spr ctx "_hx_cast(";
- gen_expr ctx e1;
- spr ctx ", ";
- gen_expr ctx (mk (TTypeExpr t) (mk_texpr t) e1.epos);
- spr ctx ")"
- and argument_list_from_locals include_this in_var l =
- let lst = ref [] in
- if (include_this && in_var) then lst := "__hx__this" :: !lst
- else if include_this then lst := "this" :: !lst;
- PMap.iter (fun n _ ->
- lst := !lst @ [n];
- ) l;
- !lst
- and remove_internals args =
- List.filter (fun a -> a = "__hx__this" || not (start_with a "__hx__")) args;
- and inline_block ctx e =
- let index = ctx.inline_index in
- ctx.inline_index <- ctx.inline_index + 1;
- let block = {
- iname = (s_path ctx ctx.curclass.cl_path ctx.curclass.cl_extern ctx.curclass.cl_pos) ^ "_" ^ string_of_int index;
- iindex = index;
- ihasthis = ctx.in_instance_method; (* param this *)
- iarguments = [];
- iexpr = e;
- ilocals = ctx.locals;
- iin_block = true;
- iinv_locals = ctx.inv_locals;
- } in
- print ctx "%s(" block.iname;
- let in_value = (match ctx.in_value with Some _ -> true | _ -> false) in
- (match remove_internals (argument_list_from_locals ctx.in_instance_method in_value ctx.locals) with
- | [] -> ()
- | l -> print ctx "$%s" (String.concat ", $" l)
- );
- spr ctx ")";
- ctx.inline_methods <- ctx.inline_methods @ [block]
- and inline_function ctx args hasthis used_args e =
- let index = ctx.inline_index in
- ctx.inline_index <- ctx.inline_index + 1;
- let block = {
- iname = (s_path ctx ctx.curclass.cl_path ctx.curclass.cl_extern ctx.curclass.cl_pos) ^ "_" ^ string_of_int index;
- iindex = index;
- ihasthis = hasthis; (* param this *)
- iarguments = args;
- iexpr = e;
- ilocals = used_args;
- iin_block = false;
- iinv_locals = used_args;
- } in
- ctx.inline_methods <- ctx.inline_methods @ [block];
- block.iname
- and canbe_ternary_param e =
- match e.eexpr with
- | TTypeExpr _
- | TConst _
- | TLocal _
- | TField (_,FEnum _)
- | TParenthesis _
- | TMeta _
- | TObjectDecl _
- | TArrayDecl _
- | TCall _
- | TUnop _
- | TNew _
- | TCast (_, _)
- | TBlock [_] ->
- true
- | TIf (_,e,eelse) ->
- cangen_ternary e eelse
- | _ ->
- false
- and cangen_ternary e eelse =
- match eelse with
- | Some other ->
- (canbe_ternary_param e) && (canbe_ternary_param other)
- | _ ->
- false
- and gen_value ctx e =
- match e.eexpr with
- | TTypeExpr _
- | TConst _
- | TLocal _
- | TArray _
- | TBinop _
- | TEnumParameter _
- | TField _
- | TParenthesis _
- | TObjectDecl _
- | TArrayDecl _
- | TCall _
- | TUnop _
- | TNew _
- | TFunction _ ->
- gen_expr ctx e
- | TMeta (_,e1) ->
- gen_value ctx e1
- | TBlock [] ->
- ()
- | TCast (e, _)
- | TBlock [e] ->
- gen_value ctx e
- | TIf (cond,e,eelse) when (cangen_ternary e eelse) ->
- spr ctx "(";
- gen_value ctx cond;
- spr ctx " ? ";
- gen_value ctx e;
- (match eelse with
- | Some e ->
- spr ctx " : ";
- gen_value ctx e
- | _ ->());
- spr ctx ")";
- (*
- | TIf (cond,e,eelse) ->
- spr ctx "if";
- gen_value ctx (parent cond);
- spr ctx " ";
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e);
- (match eelse with
- | None -> ()
- | Some e when e.eexpr = TConst(TNull) -> ()
- | Some e ->
- spr ctx " else ";
- restore_in_block ctx in_block;
- gen_expr ctx (mk_block e));
- *)
- | TBlock _
- | TBreak
- | TContinue
- | TVar _
- | TReturn _
- | TWhile _
- | TThrow _
- | TSwitch _
- | TFor _
- | TIf _
- | TTry _ ->
- inline_block ctx e
- let rec is_instance_method_defined cls m =
- if PMap.exists m cls.cl_fields then
- true
- else
- match cls.cl_super with
- | Some (scls, _) ->
- is_instance_method_defined scls m
- | None ->
- false
- let is_method_defined ctx m static =
- if static then
- PMap.exists m ctx.curclass.cl_statics
- else
- is_instance_method_defined ctx.curclass m
- let generate_self_method ctx rights m static setter =
- if setter then (
- if static then
- print ctx "%s function %s($v) { return call_user_func(self::$%s, $v); }" rights (s_ident m) (s_ident m)
- else
- print ctx "%s function %s($v) { return call_user_func($this->%s, $v); }" rights (s_ident m) (s_ident m)
- ) else (
- if static then
- print ctx "%s function %s() { return call_user_func(self::$%s); }" rights (s_ident m) (s_ident m)
- else
- print ctx "%s function %s() { return call_user_func($this->%s); }" rights (s_ident m) (s_ident m)
- );
- newline ctx
- let gen_assigned_value ctx eo = match eo with
- | Some ({eexpr = TConst _} as e) ->
- print ctx " = ";
- gen_value ctx e
- | _ ->
- ()
- let generate_field ctx static f =
- if not (is_extern_field f) then
- newline ctx;
- ctx.locals <- PMap.empty;
- ctx.inv_locals <- PMap.empty;
- ctx.in_instance_method <- not static;
- let rights = if static then "static" else "public" in
- let p = ctx.curclass.cl_pos in
- match f.cf_expr with
- | Some { eexpr = TFunction fd } ->
- if f.cf_name = "__construct" then
- ctx.curmethod <- "new"
- else
- ctx.curmethod <- f.cf_name;
- spr ctx (rights ^ " ");
- if is_dynamic_method f then
- gen_dynamic_function ctx static (s_ident f.cf_name) fd f.cf_params p
- else
- gen_function ctx (s_ident f.cf_name) fd f.cf_params p
- | _ ->
- if (is_extern_field f) then
- ()
- else if ctx.curclass.cl_interface then
- match follow f.cf_type, f.cf_kind with
- | TFun (args,r), Method _ ->
- print ctx "function %s(" (s_ident f.cf_name);
- concat ctx ", " (fun (arg,o,t) ->
- s_funarg ctx arg t p o;
- ) args;
- print ctx ")";
- | _ -> spr ctx "//"; ()
- else if
- (match f.cf_kind with
- | Var v ->
- (match v.v_read, v.v_write with
- | AccCall, AccCall ->
- let m1 = "get_" ^ f.cf_name in
- let m2 = "set_" ^ f.cf_name in
- if not (is_method_defined ctx m1 static) then (
- generate_self_method ctx rights m1 static false;
- print ctx "%s $%s" rights (s_ident m1);
- if not (is_method_defined ctx m2 static) then
- newline ctx);
- if not (is_method_defined ctx m2 static) then (
- generate_self_method ctx rights m2 static true;
- print ctx "%s $%s" rights (s_ident m2);
- newline ctx);
- false
- | AccCall, _ ->
- let m = "get_" ^ f.cf_name in
- if not (is_method_defined ctx m static) then generate_self_method ctx rights m static false;
- print ctx "%s $%s" rights (s_ident_field f.cf_name);
- gen_assigned_value ctx f.cf_expr;
- true
- | _, AccCall ->
- let m = "set_" ^ f.cf_name in
- if not (is_method_defined ctx m static) then generate_self_method ctx rights m static true;
- print ctx "%s $%s" rights (s_ident_field f.cf_name);
- gen_assigned_value ctx f.cf_expr;
- true
- | _ ->
- false)
- | _ -> false) then
- ()
- else begin
- let name = if static then s_ident f.cf_name else f.cf_name in
- if static then
- (match f.cf_kind with
- | Var _ ->
- (match follow f.cf_type with
- | TFun _
- | TDynamic _ ->
- print ctx "static function %s() { $args = func_get_args(); return call_user_func_array(self::$%s, $args); }" name name;
- newline ctx;
- | _ ->
- ()
- )
- | _ ->
- ()
- );
- print ctx "%s $%s" rights name;
- gen_assigned_value ctx f.cf_expr
- end
- let generate_static_field_assign ctx path f =
- let p = ctx.curclass.cl_pos in
- if not ctx.curclass.cl_interface then
- (match f.cf_expr with
- | None -> ()
- | Some e ->
- match e.eexpr with
- | TConst _ -> ()
- | TFunction fd ->
- (match f.cf_kind with
- | Var _ when
- (match follow f.cf_type with
- | TFun _
- | TDynamic _ ->
- true;
- | _ ->
- false) ->
- newline ctx;
- print ctx "%s::$%s = " (s_path ctx path false p) (s_ident f.cf_name);
- gen_value ctx e
- | Method MethDynamic ->
- newline ctx;
- print ctx "%s::$%s = " (s_path ctx path false p) (s_ident f.cf_name);
- gen_value ctx e
- | _ -> ())
- | _ when is_extern_field f ->
- ()
- | _ ->
- newline ctx;
- print ctx "%s::$%s = " (s_path ctx path false p) (s_ident f.cf_name);
- gen_value ctx e)
- let rec super_has_dynamic c =
- match c.cl_super with
- | None -> false
- | Some (csup, _) -> (match csup.cl_dynamic with
- | Some _ -> true
- | _ -> super_has_dynamic csup)
- let generate_inline_method ctx c m =
- (match ctx.inline_methods with
- | [] -> ()
- | h :: t -> ctx.inline_methods <- t
- );
- ctx.curclass <- c;
- let old = save_locals ctx in
- ctx.in_value <- Some m.iname;
- ctx.in_block <- m.iin_block;
- ctx.in_loop <- false;
- ctx.locals <- m.ilocals;
- ctx.inv_locals <- m.iinv_locals;
- newline ctx;
- print ctx "function %s(" m.iname;
- (* arguments *)
- let in_value = (match ctx.in_value with Some _ -> true | _ -> false) in
- let arguments = remove_internals (argument_list_from_locals m.ihasthis in_value ctx.locals) in
- let arguments = match arguments with
- | [h] when h = "this" -> ["__hx__this"]
- | h :: t when h = "this" -> "__hx__this" :: t
- | _ -> arguments
- in
- let marguments = List.map (define_local ctx) m.iarguments in
- let arguments = (List.map (fun a -> "&$" ^ a) arguments) @ (List.map (fun a -> "$" ^ a) marguments) in
- (match arguments with
- | [] -> ()
- | l -> spr ctx (String.concat ", " arguments)
- );
- spr ctx ") {";
- ctx.nested_loops <- ctx.nested_loops - 1;
- let block = open_block ctx in
- newline ctx;
- gen_expr ctx m.iexpr;
- block();
- old();
- ctx.nested_loops <- ctx.nested_loops + 1;
- newline ctx;
- spr ctx "}"
- let generate_class ctx c =
- let requires_constructor = ref true in
- ctx.curclass <- c;
- ctx.local_types <- List.map snd c.cl_params;
- print ctx "%s %s " (if c.cl_interface then "interface" else "class") (s_path ctx c.cl_path c.cl_extern c.cl_pos);
- (match c.cl_super with
- | None -> ()
- | Some (csup,_) ->
- requires_constructor := false;
- print ctx "extends %s " (s_path ctx csup.cl_path csup.cl_extern c.cl_pos));
- let implements = ExtList.List.unique ~cmp:(fun a b -> (fst a).cl_path = (fst b).cl_path) c.cl_implements in
- (match implements with
- | [] -> ()
- | l ->
- spr ctx (if c.cl_interface then "extends " else "implements ");
- concat ctx ", " (fun (i,_) ->
- print ctx "%s" (s_path ctx i.cl_path i.cl_extern c.cl_pos)) l);
- spr ctx "{";
- let get_dynamic_methods = List.filter is_dynamic_method c.cl_ordered_fields in
- if not ctx.curclass.cl_interface then ctx.dynamic_methods <- get_dynamic_methods;
- let cl = open_block ctx in
- (match c.cl_constructor with
- | None ->
- if !requires_constructor && not c.cl_interface then begin
- newline ctx;
- spr ctx "public function __construct(){}"
- end;
- | Some f ->
- let f = { f with
- cf_name = "__construct";
- cf_public = true;
- } in
- ctx.constructor_block <- true;
- generate_field ctx false f;
- );
- List.iter (generate_field ctx false) c.cl_ordered_fields;
- (match c.cl_dynamic with
- | Some _ when not c.cl_interface && not (super_has_dynamic c) ->
- newline ctx;
- spr ctx "public $__dynamics = array();\n\tpublic function __get($n) {\n\t\tif(isset($this->__dynamics[$n]))\n\t\t\treturn $this->__dynamics[$n];\n\t}\n\tpublic function __set($n, $v) {\n\t\t$this->__dynamics[$n] = $v;\n\t}\n\tpublic function __call($n, $a) {\n\t\tif(isset($this->__dynamics[$n]) && is_callable($this->__dynamics[$n]))\n\t\t\treturn call_user_func_array($this->__dynamics[$n], $a);\n\t\tif('toString' == $n)\n\t\t\treturn $this->__toString();\n\t\tthrow new HException(\"Unable to call <\".$n.\">\");\n\t}"
- | Some _
- | _ ->
- if List.length ctx.dynamic_methods > 0 then begin
- newline ctx;
- spr ctx "public function __call($m, $a) {\n\t\tif(isset($this->$m) && is_callable($this->$m))\n\t\t\treturn call_user_func_array($this->$m, $a);\n\t\telse if(isset($this->__dynamics[$m]) && is_callable($this->__dynamics[$m]))\n\t\t\treturn call_user_func_array($this->__dynamics[$m], $a);\n\t\telse if('toString' == $m)\n\t\t\treturn $this->__toString();\n\t\telse\n\t\t\tthrow new HException('Unable to call <'.$m.'>');\n\t}";
- end;
- );
- List.iter (generate_field ctx true) c.cl_ordered_statics;
- let gen_props props =
- String.concat "," (List.map (fun (p,v) -> "\"" ^ p ^ "\" => \"" ^ v ^ "\"") props)
- in
- let rec fields c =
- let list = Codegen.get_properties (c.cl_ordered_statics @ c.cl_ordered_fields) in
- match c.cl_super with
- | Some (csup, _) ->
- list @ fields csup
- | None ->
- list
- in
- if not c.cl_interface then (match fields c with
- | [] ->
- ()
- | props ->
- newline ctx;
- print ctx "static $__properties__ = array(%s)" (gen_props props);
- );
- cl();
- newline ctx;
- if PMap.exists "__toString" c.cl_fields then
- ()
- else if PMap.exists "toString" c.cl_fields && (not c.cl_interface) && (not c.cl_extern) then begin
- print ctx "\tfunction __toString() { return $this->toString(); }";
- newline ctx
- end else if (not c.cl_interface) && (not c.cl_extern) then begin
- print ctx "\tfunction __toString() { return '%s'; }" (s_path_haxe c.cl_path) ;
- newline ctx
- end;
- print ctx "}"
- let createmain com e =
- let filename = match com.php_front with None -> "index.php" | Some n -> n in
- let ctx = {
- com = com;
- stack = stack_init com false;
- tabs = "";
- ch = open_out (com.file ^ "/" ^ filename);
- path = ([], "");
- buf = Buffer.create (1 lsl 14);
- in_value = None;
- in_loop = false;
- in_instance_method = false;
- imports = Hashtbl.create 0;
- extern_required_paths = [];
- extern_classes_with_init = [];
- curclass = null_class;
- curmethod = "";
- locals = PMap.empty;
- inv_locals = PMap.empty;
- local_types = [];
- inits = [];
- constructor_block = false;
- dynamic_methods = [];
- all_dynamic_methods = [];
- is_call = false;
- cwd = "";
- inline_methods = [];
- nested_loops = 0;
- inline_index = 0;
- in_block = false;
- lib_path = match com.php_lib with None -> "lib" | Some s -> s;
- } in
- spr ctx "if(version_compare(PHP_VERSION, '5.1.0', '<')) {
- exit('Your current PHP version is: ' . PHP_VERSION . '. Haxe/PHP generates code for version 5.1.0 or later');
- }";
- newline ctx;
- newline ctx;
- spr ctx ("require_once dirname(__FILE__).'/" ^ ctx.lib_path ^ "/php/" ^ (prefix_class com "Boot.class.php';\n\n"));
- gen_value ctx e;
- newline ctx;
- spr ctx "\n?>";
- close ctx
- let generate_main ctx c =
- (match c.cl_ordered_statics with
- | [{ cf_expr = Some e }] ->
- gen_value ctx e;
- | _ -> assert false);
- newline ctx
- let generate_enum ctx e =
- ctx.local_types <- List.map snd e.e_params;
- let pack = open_block ctx in
- let ename = s_path ctx e.e_path e.e_extern e.e_pos in
- print ctx "class %s extends Enum {" ename;
- PMap.iter (fun _ c ->
- newline ctx;
- match c.ef_type with
- | TFun (args,_) ->
- print ctx "public static function %s($" (s_ident c.ef_name);
- concat ctx ", $" (fun (a,o,t) ->
- spr ctx a;
- if o then spr ctx " = null";
- ) args;
- spr ctx ") {";
- print ctx " return new %s(\"%s\", %d, array($" ename (s_ident c.ef_name) c.ef_index;
- concat ctx ", $" (fun (a,_,_) -> spr ctx a) args;
- print ctx ")); }";
- | _ ->
- print ctx "public static $%s" (s_ident c.ef_name);
- ) e.e_constrs;
- newline ctx;
- spr ctx "public static $__constructors = array(";
- let first = ref true in
- PMap.iter (fun _ c ->
- if not !first then spr ctx ", ";
- print ctx "%d => '%s'" c.ef_index (s_ident c.ef_name);
- first := false;
- ) e.e_constrs;
- spr ctx ")";
- newline ctx;
- (match Codegen.build_metadata ctx.com (TEnumDecl e) with
- | None -> ()
- | Some _ ->
- spr ctx "public static $__meta__";
- newline ctx);
- pack();
- print ctx "}";
- PMap.iter (fun _ c ->
- match c.ef_type with
- | TFun (args,_) ->
- ();
- | _ ->
- newline ctx;
- print ctx "%s::$%s = new %s(\"%s\", %d)" ename (s_ident c.ef_name) ename c.ef_name c.ef_index;
- ) e.e_constrs;
- newline ctx;
- match Codegen.build_metadata ctx.com (TEnumDecl e) with
- | None -> ()
- | Some e ->
- print ctx "%s::$__meta__ = " ename;
- gen_expr ctx e;
- newline ctx
- let generate com =
- let all_dynamic_methods = ref [] in
- let extern_classes_with_init = ref [] in
- let php_lib_path = (match com.php_lib with None -> "lib" | Some n -> n) in
- create_directory com (Str.split (Str.regexp "/") php_lib_path);
- (* check for methods with the same name but different case *)
- let check_class_fields c =
- let lc_names = ref [] in
- let special_cases = ["toString"] in
- let loop c lst static =
- let in_special_cases name =
- (List.exists (fun n -> String.lowercase n = name) (special_cases @ List.map (fun f -> f.cf_name) c.cl_overrides))
- in
- List.iter(fun cf ->
- let name = String.lowercase cf.cf_name in
- let prefixed_name s = (if s then "s_" else "i_") ^ name in
- match cf.cf_kind, cf.cf_expr with
- | (Method _, Some e) when not (in_special_cases name) ->
- (try
- let lc = List.find (fun n ->
- let n = snd n in
- if static then
- (n = (prefixed_name false))
- else
- ((n = (prefixed_name false)) || (n = (prefixed_name true)))
- ) !lc_names in
- unsupported ("method '" ^ (s_type_path c.cl_path) ^ "." ^ cf.cf_name ^ "' already exists here '" ^ (fst lc) ^ "' (different case?)") c.cl_pos
- with Not_found ->
- lc_names := ((s_type_path c.cl_path) ^ "." ^ cf.cf_name, prefixed_name static) :: !lc_names)
- | _ ->
- ()
- ) lst
- in
- let rec _check_class_fields cl =
- (match cl.cl_super with
- | Some (s,_) -> _check_class_fields s
- | _ -> ());
- loop cl cl.cl_ordered_statics true;
- loop cl cl.cl_ordered_fields false
- in
- _check_class_fields c
- in
- List.iter (fun t ->
- (match t with
- | TClassDecl c ->
- check_class_fields c
- | TEnumDecl e ->
- let e_names = ref [] in
- List.iter(fun en -> (
- if List.exists (fun n -> n = String.lowercase en) !e_names then
- unsupported ("'" ^ en ^ "' constructor exists with different case") e.e_pos
- else
- e_names := (String.lowercase en) :: !e_names
- )) (e.e_names)
- | _ -> ())
- ) com.types;
- List.iter (fun t ->
- (match t with
- | TClassDecl c ->
- let dynamic_methods_names lst =
- List.map (fun fd -> {
- mpath = c.cl_path;
- mname = fd.cf_name;
- }) (List.filter is_dynamic_method lst)
- in
- all_dynamic_methods := dynamic_methods_names c.cl_ordered_fields @ !all_dynamic_methods;
- if c.cl_extern then
- (match c.cl_init with
- | Some _ ->
- extern_classes_with_init := c.cl_path :: !extern_classes_with_init;
- | _ ->
- ())
- else
- all_dynamic_methods := dynamic_methods_names c.cl_ordered_statics @ !all_dynamic_methods;
- | _ -> ())
- ) com.types;
- List.iter (Codegen.fix_abstract_inheritance com) com.types;
- List.iter (fun t ->
- (match t with
- | TClassDecl c ->
- if c.cl_extern then begin
- (match c.cl_init with
- | None -> ()
- | Some e ->
- let ctx = init com php_lib_path c.cl_path 3 in
- gen_expr ctx e;
- newline ctx;
- close ctx;
- );
- end else
- let ctx = init com php_lib_path c.cl_path (if c.cl_interface then 2 else 0) in
- ctx.extern_classes_with_init <- !extern_classes_with_init;
- ctx.all_dynamic_methods <- !all_dynamic_methods;
- generate_class ctx c;
- (match c.cl_init with
- | None -> ()
- | Some e ->
- newline ctx;
- gen_expr ctx e);
- List.iter (generate_static_field_assign ctx c.cl_path) c.cl_ordered_statics;
- if c.cl_path = (["php"], "Boot") && com.debug then begin
- newline ctx;
- print ctx "$%s = new _hx_array(array())" ctx.stack.Codegen.stack_var;
- newline ctx;
- print ctx "$%s = new _hx_array(array())" ctx.stack.Codegen.stack_exc_var;
- end;
- let rec loop l =
- match l with
- | [] -> ()
- | h :: _ ->
- generate_inline_method ctx c h;
- loop ctx.inline_methods
- in
- loop ctx.inline_methods;
- newline ctx;
- close ctx
- | TEnumDecl e ->
- if e.e_extern then
- ()
- else
- let ctx = init com php_lib_path e.e_path 1 in
- generate_enum ctx e;
- close ctx
- | TTypeDecl _ | TAbstractDecl _ ->
- ());
- ) com.types;
- (match com.main with
- | None -> ()
- | Some e -> createmain com e);
- Hashtbl.iter (fun name data ->
- write_resource com.file name data
- ) com.resources;
|