123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818 |
- (*
- 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 Nast
- open Common
- type context = {
- version : int;
- com : Common.context;
- packages : (string list, unit) Hashtbl.t;
- globals : (string list * string, string) Hashtbl.t;
- mutable curglobal : int;
- mutable macros : bool;
- mutable curclass : string;
- mutable curmethod : string;
- mutable inits : (tclass * texpr) list;
- mutable label_count : int;
- }
- let files = Hashtbl.create 0
- let pos ctx p =
- if ctx.macros then
- {
- psource = p.pfile;
- pline = p.pmin lor ((p.pmax - p.pmin) lsl 20);
- }
- else let file = (match ctx.com.debug with
- | true -> ctx.curclass ^ "::" ^ ctx.curmethod
- | false ->
- try
- Hashtbl.find files p.pfile
- with Not_found ->
- let path = (match Common.defined ctx.com Common.Define.AbsolutePath with
- | true -> if (Filename.is_relative p.pfile)
- then Filename.concat (Sys.getcwd()) p.pfile
- else p.pfile
- | false -> try
- (* lookup relative path *)
- let len = String.length p.pfile in
- let base = List.find (fun path ->
- let l = String.length path in
- len > l && String.sub p.pfile 0 l = path
- ) ctx.com.Common.class_path in
- let l = String.length base in
- String.sub p.pfile l (len - l)
- with Not_found -> p.pfile
- ) in
- Hashtbl.add files p.pfile path;
- path
- ) in
- {
- psource = file;
- pline = Lexer.get_error_line p;
- }
- let gen_global_name ctx path =
- match path with
- | [], name -> name
- | _ ->
- try
- Hashtbl.find ctx.globals path
- with Not_found ->
- let name = "@G" ^ string_of_int ctx.curglobal in
- ctx.curglobal <- ctx.curglobal + 1;
- Hashtbl.add ctx.globals path name;
- name
- let null p =
- (EConst Null,p)
- let this p =
- (EConst This,p)
- let int p n =
- (EConst (Int n),p)
- let str p s =
- (EConst (String s),p)
- let ident p s =
- let l = String.length s in
- if l > 10 && String.sub s 0 10 = "__dollar__" then
- (EConst (Builtin (String.sub s 10 (l - 10))),p)
- else
- (EConst (Ident s),p)
- let field p e f =
- (EField (e,f),p)
- let builtin p n =
- (EConst (Builtin n),p)
- let call p e el =
- (ECall (e,el),p)
- let array p el =
- call p (builtin p "array") el
- let pmap_list f p =
- PMap.fold (fun v acc -> f v :: acc) p []
- let rec needs_return e =
- match e with
- | (EBlock l,_) ->
- let rec loop = function
- | [] -> true
- | [x] -> needs_return x
- | _ :: l -> loop l
- in
- loop l
- | (EReturn _,_) ->
- false
- | _ ->
- true
- let with_return e =
- if needs_return e then
- let p = snd e in
- let ret = EReturn (Some (null p)),p in
- match e with
- | (EBlock l,_) ->
- (EBlock (l @ [ret]),p)
- | _ ->
- (EBlock [e;ret] , p)
- else
- e
- let gen_type_path p (path,t) =
- match path with
- | [] ->
- ident p t
- | path :: l ->
- let epath = List.fold_left (fun e path -> field p e path) (ident p path) l in
- field p epath t
- let rec gen_big_string ctx p s =
- let max = 1 lsl 16 - 1 in
- if String.length s > max then
- (EBinop ("+",str p (String.sub s 0 max),gen_big_string ctx p (String.sub s max (String.length s - max))),p)
- else
- str p s
- let gen_constant ctx pe c =
- let p = pos ctx pe in
- match c with
- | TInt i ->
- (try
- let h = Int32.to_int (Int32.shift_right_logical i 24) in
- if (h land 128 = 0) <> (h land 64 = 0) then raise Exit;
- int p (Int32.to_int i)
- with _ ->
- if ctx.version < 2 then error "This integer is too big to be compiled to a Neko 31-bit integer. Please use a Float instead" pe;
- (EConst (Int32 i),p))
- | TFloat f -> (EConst (Float f),p)
- | TString s -> call p (field p (ident p "String") "new") [gen_big_string ctx p s]
- | TBool b -> (EConst (if b then True else False),p)
- | TNull -> null p
- | TThis -> this p
- | TSuper -> assert false
- let rec gen_binop ctx p op e1 e2 =
- (EBinop (Ast.s_binop op,gen_expr ctx e1,gen_expr ctx e2),p)
- and gen_unop ctx p op flag e =
- match op with
- | Increment -> (EBinop ((if flag = Prefix then "+=" else "++="), gen_expr ctx e , int p 1),p)
- | Decrement -> (EBinop ((if flag = Prefix then "-=" else "--="), gen_expr ctx e , int p 1),p)
- | Not -> call p (builtin p "not") [gen_expr ctx e]
- | Neg -> (EBinop ("-",int p 0, gen_expr ctx e),p)
- | NegBits -> (EBinop ("-",int p (-1), gen_expr ctx e),p)
- and gen_call ctx p e el =
- match e.eexpr , el with
- | TConst TSuper , _ ->
- let c = (match follow e.etype with TInst (c,_) -> c | _ -> assert false) in
- call p (builtin p "call") [
- field p (gen_type_path p c.cl_path) "__construct__";
- this p;
- array p (List.map (gen_expr ctx) el)
- ]
- | TLocal { v_name = "__resources__" }, [] ->
- call p (builtin p "array") (Hashtbl.fold (fun name data acc ->
- (EObject [("name",gen_constant ctx e.epos (TString name));("data",gen_big_string ctx p data)],p) :: acc
- ) ctx.com.resources [])
- | TField ({ eexpr = TConst TSuper; etype = t },f) , _ ->
- let c = (match follow t with TInst (c,_) -> c | _ -> assert false) in
- call p (builtin p "call") [
- field p (gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path)) (field_name f);
- this p;
- array p (List.map (gen_expr ctx) el)
- ]
- | _ , _ ->
- let e = (match gen_expr ctx e with EFunction _, _ as e -> (EBlock [e],p) | e -> e) in
- call p e (List.map (gen_expr ctx) el)
- and gen_expr ctx e =
- let p = pos ctx e.epos in
- match e.eexpr with
- | TConst c ->
- gen_constant ctx e.epos c
- | TLocal v when v.v_name.[0] = '$' ->
- (EConst (Builtin (String.sub v.v_name 1 (String.length v.v_name - 1))),p)
- | TLocal v ->
- if v.v_capture then
- (EArray (ident p v.v_name,int p 0),p)
- else
- ident p v.v_name
- | TArray (e1,e2) ->
- (EArray (gen_expr ctx e1,gen_expr ctx e2),p)
- | TBinop (OpAssign,{ eexpr = TField (e1,f) },e2) ->
- (EBinop ("=",field p (gen_expr ctx e1) (field_name f),gen_expr ctx e2),p)
- | TBinop (op,e1,e2) ->
- gen_binop ctx p op e1 e2
- | TField (e2,FClosure (_,f)) ->
- (match follow e.etype with
- | TFun (args,_) ->
- let n = List.length args in
- if n > 5 then error "Cannot create closure with more than 5 arguments" e.epos;
- let tmp = ident p "@tmp" in
- EBlock [
- (EVars ["@tmp", Some (gen_expr ctx e2); "@fun", Some (field p tmp f.cf_name)] , p);
- if ctx.macros then
- call p (builtin p "closure") [ident p "@fun";tmp]
- else
- call p (ident p ("@closure" ^ string_of_int n)) [tmp;ident p "@fun"]
- ] , p
- | _ -> assert false)
- | TEnumParameter (e,_,i) ->
- EArray (field p (gen_expr ctx e) "args",int p i),p
- | TField (e,f) ->
- field p (gen_expr ctx e) (field_name f)
- | TTypeExpr t ->
- gen_type_path p (t_path t)
- | TParenthesis e ->
- (EParenthesis (gen_expr ctx e),p)
- | TMeta (_,e) ->
- gen_expr ctx e
- | TObjectDecl fl ->
- let hasToString = ref false in
- let fl = List.map (fun (f,e) -> if f = "toString" then hasToString := (match follow e.etype with TFun ([],_) -> true | _ -> false); f , gen_expr ctx e) fl in
- (EObject (if !hasToString then ("__string",ident p "@default__string") :: fl else fl),p)
- | TArrayDecl el ->
- call p (field p (ident p "Array") "new1") [array p (List.map (gen_expr ctx) el); int p (List.length el)]
- | TCall (e,el) ->
- gen_call ctx p e el
- | TNew (c,_,params) ->
- call p (field p (gen_type_path p c.cl_path) "new") (List.map (gen_expr ctx) params)
- | TUnop (op,flag,e) ->
- gen_unop ctx p op flag e
- | TVar (v,eo) ->
- (EVars (
- let e = (match eo with
- | None ->
- if v.v_capture then
- Some (call p (builtin p "array") [null p])
- else
- None
- | Some e ->
- let e = gen_expr ctx e in
- if v.v_capture then
- Some (call p (builtin p "array") [e])
- else
- Some e
- ) in
- [v.v_name, e]
- ),p)
- | TFunction f ->
- let inits = List.fold_left (fun acc (a,c) ->
- let acc = if a.v_capture then
- (EBinop ("=",ident p a.v_name,call p (builtin p "array") [ident p a.v_name]),p) :: acc
- else
- acc
- in
- match c with
- | None | Some TNull -> acc
- | Some c -> gen_expr ctx (Codegen.set_default ctx.com a c e.epos) :: acc
- ) [] f.tf_args in
- let e = gen_expr ctx f.tf_expr in
- let e = (match inits with [] -> e | _ -> EBlock (List.rev (e :: inits)),p) in
- (EFunction (List.map arg_name f.tf_args, with_return e),p)
- | TBlock el ->
- (EBlock (List.map (gen_expr ctx) el), p)
- | TFor (v, it, e) ->
- let it = gen_expr ctx it in
- let e = gen_expr ctx e in
- let next = call p (field p (ident p "@tmp") "next") [] in
- let next = (if v.v_capture then call p (builtin p "array") [next] else next) in
- (EBlock
- [(EVars ["@tmp", Some it],p);
- (EWhile (call p (field p (ident p "@tmp") "hasNext") [],
- (EBlock [
- (EVars [v.v_name, Some next],p);
- e
- ],p)
- ,NormalWhile),p)]
- ,p)
- | TIf (cond,e1,e2) ->
- (* if(e)-1 is parsed as if( e - 1 ) *)
- let parent e = mk (TParenthesis e) e.etype e.epos in
- let e1 = (match e1.eexpr with TConst (TInt n) when n < 0l -> parent e1 | TConst (TFloat f) when f.[0] = '-' -> parent e1 | _ -> e1) in
- (EIf (gen_expr ctx cond,gen_expr ctx e1,(match e2 with None -> None | Some e -> Some (gen_expr ctx e))),p)
- | TWhile (econd,e,flag) ->
- (EWhile (gen_expr ctx econd, gen_expr ctx e, match flag with Ast.NormalWhile -> NormalWhile | Ast.DoWhile -> DoWhile),p)
- | TTry (e,catchs) ->
- let rec loop = function
- | [] -> call p (builtin p "rethrow") [ident p "@tmp"]
- | (v,e) :: l ->
- let e2 = loop l in
- let path = (match follow v.v_type with
- | TInst (c,_) -> Some c.cl_path
- | TEnum (e,_) -> Some e.e_path
- | TAbstract (a,_) -> Some a.a_path
- | TDynamic _ -> None
- | _ -> assert false
- ) in
- let cond = (match path with
- | None -> (EConst True,p)
- | Some path -> call p (field p (gen_type_path p (["neko"],"Boot")) "__instanceof") [ident p "@tmp"; gen_type_path p path]
- ) in
- let id = ident p "@tmp" in
- let id = (if v.v_capture then call p (builtin p "array") [id] else id) in
- let e = gen_expr ctx e in
- (EIf (cond,(EBlock [
- EVars [v.v_name,Some id],p;
- e;
- ],p),Some e2),p)
- in
- let catchs = loop catchs in
- let catchs = (EBlock [
- (EIf (
- (EBinop ("==",call p (builtin p "typeof") [ident p "@tmp"],builtin p "tstring"),p),
- (EBinop ("=",ident p "@tmp",call p (field p (ident p "String") "new") [ident p "@tmp"]),p),
- None
- ),p);
- catchs;
- ],p) in
- (ETry (gen_expr ctx e,"@tmp",catchs),p)
- | TReturn eo ->
- (EReturn (match eo with None -> Some (null p) | Some e -> Some (gen_expr ctx e)),p)
- | TBreak ->
- (EBreak None,p)
- | TContinue ->
- (EContinue,p)
- | TThrow e ->
- call p (builtin p "throw") [gen_expr ctx e]
- | TCast (e,None) ->
- gen_expr ctx e
- | TCast (e1,Some t) ->
- gen_expr ctx (Codegen.default_cast ~vtmp:"@tmp" ctx.com e1 t e.etype e.epos)
- | TSwitch (e,cases,eo) ->
- let e = gen_expr ctx e in
- let eo = (match eo with None -> None | Some e -> Some (gen_expr ctx e)) in
- try
- (ESwitch (
- e,
- List.map (fun (el,e2) ->
- match List.map (gen_expr ctx) el with
- | [] -> assert false
- | [e] -> e, gen_expr ctx e2
- | _ -> raise Exit
- ) cases,
- eo
- ),p)
- with
- Exit ->
- (EBlock [
- (EVars ["@tmp",Some e],p);
- List.fold_left (fun acc (el,e) ->
- let cond = (match el with
- | [] -> assert false
- | e :: l ->
- let eq e = (EBinop ("==",ident p "@tmp",gen_expr ctx e),p) in
- List.fold_left (fun acc e -> (EBinop ("||",acc,eq e),p)) (eq e) l
- ) in
- EIf (cond,gen_expr ctx e,Some acc),p
- ) (match eo with None -> null p | Some e -> e) (List.rev cases)
- ],p)
- let gen_method ctx p c acc =
- ctx.curmethod <- c.cf_name;
- if is_extern_field c then acc else
- match c.cf_expr with
- | None ->
- ((c.cf_name, null p) :: acc)
- | Some e ->
- match e.eexpr with
- | TCall ({ eexpr = TField (_,FStatic ({cl_path=["neko"],"Lib"},{cf_name="load" | "loadLazy" as load})) },[{ eexpr = TConst (TString m) };{ eexpr = TConst (TString f) };{ eexpr = TConst (TInt n) }]) ->
- let p = pos ctx e.epos in
- let e = call p (EField (builtin p "loader","loadprim"),p) [(EBinop ("+",(EBinop ("+",str p m,str p "@"),p),str p f),p); (EConst (Int (Int32.to_int n)),p)] in
- let e = (if load = "load" then e else (ETry (e,"@e",call p (ident p "@lazy_error") [ident p "@e"]),p)) in
- (c.cf_name, e) :: acc
- | TFunction _ -> ((if c.cf_name = "new" then "__construct__" else c.cf_name), gen_expr ctx e) :: acc
- | _ -> (c.cf_name, null p) :: acc
- let gen_class ctx c =
- ctx.curclass <- s_type_path c.cl_path;
- ctx.curmethod <- "$init";
- let p = pos ctx c.cl_pos in
- let clpath = gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path) in
- let stpath = gen_type_path p c.cl_path in
- let fnew = (match c.cl_constructor with
- | Some f ->
- (match f.cf_expr with
- | Some {eexpr = TFunction tf} ->
- let params = List.map (fun (v,_) -> v.v_name) tf.tf_args in
- gen_method ctx p f ["new",(EFunction (params,(EBlock [
- (EVars ["@o",Some (call p (builtin p "new") [null p])],p);
- (call p (builtin p "objsetproto") [ident p "@o"; clpath]);
- (call p (builtin p "call") [field p (this p) "__construct__"; ident p "@o"; array p (List.map (ident p) params)]);
- (EReturn (Some (ident p "@o")),p)
- ],p)),p)]
- | _ -> [])
- | None ->
- []
- ) in
- let fstring = (try
- let f = PMap.find "toString" c.cl_fields in
- match follow f.cf_type with
- | TFun ([],_) -> ["__string",ident p "@default__string"]
- | _ -> []
- with Not_found ->
- []
- ) in
- let fserialize = "__serialize" , ident p "@serialize" in
- let others = (match c.cl_implements with
- | [] -> []
- | l -> ["__interfaces__",array p (List.map (fun (c,_) -> gen_type_path p c.cl_path) l)]
- ) @ (match c.cl_super with
- | None -> []
- | Some (c,_) -> ["__super__", gen_type_path p c.cl_path]
- ) in
- let build (f,e) = (EBinop ("=",field p (ident p "@tmp") f,e),p) in
- let tmp = (EVars ["@tmp",Some (call p (builtin p "new") [null p])],p) in
- let estat = (EBinop ("=", stpath, ident p "@tmp"),p) in
- let gen_props props = (EObject (List.map (fun (n,s) -> n,str p s) props),p) in
- let sprops = (match Codegen.get_properties c.cl_ordered_statics with
- | [] -> []
- | l -> ["__properties__",gen_props l]
- ) in
- let sfields = List.map build
- (
- ("prototype",clpath) :: sprops @
- PMap.fold (gen_method ctx p) c.cl_statics (fnew @ others)
- )
- in
- let eclass = (EBinop ("=", clpath, ident p "@tmp"),p) in
- let mfields = List.map build
- (PMap.fold (gen_method ctx p) c.cl_fields (fserialize :: fstring))
- in
- let props = Codegen.get_properties c.cl_ordered_fields in
- let emeta = (EBinop ("=",field p clpath "__class__",stpath),p) ::
- (match props with
- | [] -> []
- | _ ->
- let props = gen_props props in
- let props = (match c.cl_super with
- | Some (csup,_) when Codegen.has_properties csup ->
- (EBlock [
- (EVars ["@tmp",Some props],p);
- call p (builtin p "objsetproto") [ident p "@tmp";field p (field p (gen_type_path p csup.cl_path) "prototype") "__properties__"];
- ident p "@tmp"
- ],p)
- | _ -> props
- ) in
- [EBinop ("=",field p clpath "__properties__",props),p])
- @ match c.cl_path with
- | [] , name -> [(EBinop ("=",field p (ident p "@classes") name,ident p name),p)]
- | _ -> []
- in
- let emeta = if ctx.macros then
- (EBinop ("=",field p stpath "__ct__",call p (builtin p "typewrap") [Obj.magic (TClassDecl c)]),p) :: emeta
- else
- emeta
- in
- let eextends = (match c.cl_super with
- | None -> []
- | Some (c,_) ->
- let esuper = gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path) in
- [call p (builtin p "objsetproto") [clpath; esuper]]
- ) in
- (EBlock (tmp :: eclass :: mfields @ tmp :: estat :: sfields @ eextends @ emeta),p)
- let gen_enum_constr ctx path c =
- ctx.curmethod <- c.ef_name;
- let p = pos ctx c.ef_pos in
- (EBinop ("=",field p path c.ef_name, match follow c.ef_type with
- | TFun (params,_) ->
- let params = List.map (fun (n,_,_) -> n) params in
- (EFunction (params,
- (EBlock [
- (EVars ["@tmp",Some (EObject [
- "tag" , str p c.ef_name;
- "index" , int p c.ef_index;
- "args" , array p (List.map (ident p) params);
- ],p)],p);
- call p (builtin p "objsetproto") [ident p "@tmp"; field p path "prototype"];
- ident p "@tmp";
- ],p)
- ),p)
- | _ ->
- (EBlock [
- (EVars ["@tmp",Some (EObject ["tag" , str p c.ef_name; "index", int p c.ef_index; "__serialize" , ident p "@tag_serialize"],p)],p);
- call p (builtin p "objsetproto") [ident p "@tmp"; field p path "prototype"];
- ident p "@tmp";
- ],p)
- ),p)
- let gen_enum ctx e =
- ctx.curclass <- s_type_path e.e_path;
- ctx.curmethod <- "$init";
- let p = pos ctx e.e_pos in
- let path = gen_type_path p e.e_path in
- let uname = (EConst (Ident (gen_global_name ctx e.e_path)),p) in
- (EBlock (
- (EBinop ("=",uname, call p (builtin p "new") [null p]),p) ::
- (EBinop ("=",path, uname),p) ::
- (EBinop ("=",field p uname "prototype", (EObject [
- "__enum__" , uname;
- "__serialize" , ident p "@serialize";
- "__string" , ident p "@enum_to_string"
- ],p)),p) ::
- pmap_list (gen_enum_constr ctx uname) e.e_constrs @
- (match e.e_path with
- | [] , name -> [EBinop ("=",field p (ident p "@classes") name,ident p name),p]
- | _ -> [])
- ),p)
- let gen_type ctx t acc =
- match t with
- | TClassDecl c ->
- (match c.cl_init with
- | None -> ()
- | Some e -> ctx.inits <- (c,e) :: ctx.inits);
- if c.cl_extern then
- acc
- else
- gen_class ctx c :: acc
- | TEnumDecl e ->
- if e.e_extern then
- acc
- else
- gen_enum ctx e :: acc
- | TTypeDecl _ | TAbstractDecl _ ->
- acc
- let gen_static_vars ctx t =
- match t with
- | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ -> []
- | TClassDecl c ->
- if c.cl_extern then
- []
- else
- List.fold_right (fun f acc ->
- match f.cf_expr with
- | None -> acc
- | Some e ->
- match e.eexpr with
- | TFunction _ -> acc
- | _ ->
- ctx.curclass <- s_type_path c.cl_path;
- ctx.curmethod <- "$statics";
- let p = pos ctx e.epos in
- (EBinop ("=",
- (field p (gen_type_path p c.cl_path) f.cf_name),
- gen_expr ctx e
- ),p) :: acc
- ) c.cl_ordered_statics []
- let gen_package ctx t =
- let rec loop acc p =
- match p with
- | [] -> []
- | x :: l ->
- let path = acc @ [x] in
- if not (Hashtbl.mem ctx.packages path) then begin
- let p = pos ctx (t_infos t).mt_pos in
- let e = (EBinop ("=",gen_type_path p (acc,x),call p (builtin p "new") [null p]),p) in
- Hashtbl.add ctx.packages path ();
- (match acc with
- | [] ->
- let reg = (EBinop ("=",field p (ident p "@classes") x,ident p x),p) in
- e :: reg :: loop path l
- | _ ->
- e :: loop path l)
- end else
- loop path l
- in
- loop [] (fst (t_path t))
- let gen_boot ctx =
- (EBlock [
- EBinop ("=",field null_pos (gen_type_path null_pos (["neko"],"Boot")) "__classes",ident null_pos "@classes"),null_pos;
- call null_pos (field null_pos (gen_type_path null_pos (["neko"],"Boot")) "__init") [];
- ],null_pos)
- let gen_name ctx acc t =
- match t with
- | TEnumDecl e when e.e_extern ->
- acc
- | TEnumDecl e ->
- let p = pos ctx e.e_pos in
- let name = fst e.e_path @ [snd e.e_path] in
- let arr = call p (field p (ident p "Array") "new1") [array p (List.map (fun n -> gen_constant ctx e.e_pos (TString n)) name); int p (List.length name)] in
- let path = gen_type_path p e.e_path in
- let setname = (EBinop ("=",field p path "__ename__",arr),p) in
- let arr = call p (field p (ident p "Array") "new1") [array p (List.map (fun n -> gen_constant ctx e.e_pos (TString n)) e.e_names); int p (List.length e.e_names)] in
- let setconstrs = (EBinop ("=", field p path "__constructs__", arr),p) in
- let meta = (match Codegen.build_metadata ctx.com (TEnumDecl e) with
- | None -> []
- | Some e -> [EBinop ("=",field p path "__meta__", gen_expr ctx e),p]
- ) in
- let meta = if ctx.macros then
- (EBinop ("=",field p path "__et__",call p (builtin p "typewrap") [Obj.magic t]),p) :: meta
- else
- meta
- in
- setname :: setconstrs :: meta @ acc
- | TClassDecl c ->
- if c.cl_extern || (match c.cl_kind with KTypeParameter _ -> true | _ -> false) then
- acc
- else
- let p = pos ctx c.cl_pos in
- let name = fst c.cl_path @ [snd c.cl_path] in
- let arr = call p (field p (ident p "Array") "new1") [array p (List.map (fun n -> gen_constant ctx c.cl_pos (TString n)) name); int p (List.length name)] in
- (EBinop ("=",field p (gen_type_path p c.cl_path) "__name__",arr),p) ::
- (match c.cl_implements with
- | [] -> acc
- | l ->
- let interf = field p (gen_type_path p c.cl_path) "__interfaces__" in
- (EBinop ("=",interf, call p (field p (ident p "Array") "new1") [interf; int p (List.length l)]),p) :: acc)
- | TTypeDecl _ | TAbstractDecl _ ->
- acc
- let generate_libs_init = function
- | [] -> []
- | libs ->
- (*
- var @s = $loader.loadprim("std@sys_string",0)();
- var @env = $loader.loadprim("std@get_env",1);
- var @b = if( @s == "Windows" )
- @env("HAXEPATH") + "\\lib\\"
- else try $loader.loadprim("std@file_contents",1)(@env("HOME")+"/.haxelib") + "/"
- catch e
- if( @s == "Linux" )
- if( $loader(loadprim("std@sys_exists",1))("/usr/lib/haxe/lib") )
- "/usr/lib/haxe/lib"
- else
- "/usr/share/haxe/lib/"
- else
- "/usr/local/lib/haxe/lib/";
- if( try $loader.loadprim("std@sys_file_type",1)(".haxelib") == "dir" catch e false ) @b = $loader.loadprim("std@file_full_path",1)(".haxelib") + "/";
- if( $loader.loadprim("std@sys_is64",0)() ) @s = @s + 64;
- @b = @b + "/"
- *)
- let p = null_pos in
- let es = ident p "@s" in
- let loadp n nargs =
- call p (field p (builtin p "loader") "loadprim") [str p ("std@" ^ n); int p nargs]
- in
- let op o e1 e2 =
- (EBinop (o,e1,e2),p)
- in
- let boot = [
- (EVars [
- "@s",Some (call p (loadp "sys_string" 0) []);
- "@env",Some (loadp "get_env" 1);
- "@b", Some (EIf (op "==" es (str p "Windows"),
- op "+" (call p (ident p "@env") [str p "HAXEPATH"]) (str p "\\lib\\"),
- Some (ETry (
- op "+" (call p (loadp "file_contents" 1) [op "+" (call p (ident p "@env") [str p "HOME"]) (str p "/.haxelib")]) (str p "/"),
- "e",
- (EIf (op "==" es (str p "Linux"),
- (EIf (call p (loadp "sys_exists" 1) [ str p "/usr/lib/haxe/lib" ],
- str p "/usr/lib/haxe/lib/",
- Some (str p "/usr/share/haxe/lib/")),p),
- Some (str p "/usr/local/lib/haxe/lib/")
- ),p)
- ),p)
- ),p);
- ],p);
- (EIf ((ETry (op "==" (call p (loadp "sys_file_type" 1) [str p ".haxelib"]) (str p "dir"),"e",(EConst False,p)),p),op "=" (ident p "@b") (op "+" (call p (loadp "file_full_path" 1) [str p ".haxelib"]) (str p "/")), None),p);
- (EIf (call p (loadp "sys_is64" 0) [],op "=" es (op "+" es (int p 64)),None),p);
- op "=" es (op "+" es (str p "/"));
- ] in
- let lpath = field p (builtin p "loader") "path" in
- boot @ List.map (fun dir ->
- let full_path = dir.[0] = '/' || dir.[1] = ':' in
- let dstr = str p dir in
- (*
- // for each lib dir
- $loader.path = $array($loader.path,@b+dir+@s);
- *)
- op "=" lpath (call p (builtin p "array") [op "+" (if full_path then dstr else op "+" (ident p "@b") dstr) (ident p "@s"); lpath])
- ) libs
- let new_context com ver macros =
- {
- version = ver;
- com = com;
- globals = Hashtbl.create 0;
- curglobal = 0;
- packages = Hashtbl.create 0;
- macros = macros;
- curclass = "$boot";
- curmethod = "$init";
- inits = [];
- label_count = 0;
- }
- let header() =
- let p = { psource = "<header>"; pline = 1 } in
- let fields l =
- let rec loop = function
- | [] -> assert false
- | [x] -> ident p x
- | x :: l -> field p (loop l) x
- in
- loop (List.rev l)
- in
- let func pl e =
- (EFunction (pl,(EReturn (Some e),p)),p)
- in
- let inits = [
- "@classes",call p (builtin p "new") [null p];
- "@enum_to_string",func [] (call p (fields ["neko";"Boot";"__enum_str"]) [this p]);
- "@serialize",func [] (call p (fields ["neko";"Boot";"__serialize"]) [this p]);
- "@tag_serialize",func [] (call p (fields ["neko";"Boot";"__tagserialize"]) [this p]);
- "@lazy_error",func ["e"] (call p (builtin p "varargs") [func ["_"] (call p (builtin p "throw") [ident p "e"])]);
- "@default__string",func [] (EBlock [
- EVars ["@s",Some (call p (field p (this p) "toString") [])] ,p;
- EIf ((EBinop ("!=",call p (builtin p "typeof") [ident p "@s"],builtin p "tobject"),p),(EReturn (Some (null p)),p),None),p;
- EReturn (Some (field p (ident p "@s") "__s")),p;
- ],p)
- ] in
- let inits = inits @ List.map (fun nargs ->
- let args = Array.to_list (Array.init nargs (fun i -> Printf.sprintf "%c" (char_of_int (int_of_char 'a' + i)))) in
- let efun = (EFunction (args,(EBlock [
- (EBinop ("=",(EConst This,p),ident p "@this"),p);
- call p (ident p "@fun") (List.map (ident p) args);
- ],p)),p) in
- let eif = EIf ((EBinop ("==",ident p "@fun",null p),p),null p,Some efun) in
- let e = func ["@this";"@fun"] (eif,p) in
- "@closure" ^ string_of_int nargs, e
- ) [0;1;2;3;4;5] in
- List.map (fun (v,e)-> EBinop ("=",ident p v,e),p) inits
- let build ctx types =
- let packs = List.concat (List.map (gen_package ctx) types) in
- let names = List.fold_left (gen_name ctx) [] types in
- let methods = List.rev (List.fold_left (fun acc t -> gen_type ctx t acc) [] types) in
- let boot = gen_boot ctx in
- let inits = List.map (fun (c,e) ->
- ctx.curclass <- s_type_path c.cl_path;
- ctx.curmethod <- "__init__";
- gen_expr ctx e
- ) (List.rev ctx.inits) in
- ctx.inits <- [];
- let vars = List.concat (List.map (gen_static_vars ctx) types) in
- packs @ methods @ boot :: names @ inits @ vars
- let generate com =
- let ctx = new_context com (if Common.defined com Define.NekoV1 then 1 else 2) false in
- let libs = (EBlock (generate_libs_init com.neko_libs) , { psource = "<header>"; pline = 1; }) in
- let el = build ctx com.types in
- let emain = (match com.main with None -> [] | Some e -> [gen_expr ctx e]) in
- let e = (EBlock ((header()) @ libs :: el @ emain), null_pos) in
- let source = Common.defined com Define.NekoSource in
- let use_nekoc = Common.defined com Define.UseNekoc in
- if not use_nekoc then begin
- try
- mkdir_from_path com.file;
- let ch = IO.output_channel (open_out_bin com.file) in
- Nbytecode.write ch (Ncompile.compile ctx.version e);
- IO.close_out ch;
- with Ncompile.Error (msg,pos) ->
- let pfile = Common.find_file com pos.psource in
- let rec loop p =
- let pp = { pfile = pfile; pmin = p; pmax = p; } in
- if Lexer.get_error_line pp >= pos.pline then
- pp
- else
- loop (p + 1)
- in
- error msg (loop 0)
- end;
- let command cmd = try com.run_command cmd with _ -> -1 in
- let neko_file = (try Filename.chop_extension com.file with _ -> com.file) ^ ".neko" in
- if source || use_nekoc then begin
- let ch = IO.output_channel (open_out_bin neko_file) in
- Binast.write ch e;
- IO.close_out ch;
- end;
- if use_nekoc && command ("nekoc" ^ (if ctx.version > 1 then " -version " ^ string_of_int ctx.version else "") ^ " \"" ^ neko_file ^ "\"") <> 0 then failwith "Neko compilation failure";
- if source then begin
- if command ("nekoc -p \"" ^ neko_file ^ "\"") <> 0 then failwith "Failed to print neko code";
- Sys.remove neko_file;
- Sys.rename ((try Filename.chop_extension com.file with _ -> com.file) ^ "2.neko") neko_file;
- end
|