genneko.ml 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818
  1. (*
  2. The Haxe Compiler
  3. Copyright (C) 2005-2015 Haxe Foundation
  4. This program is free software; you can redistribute it and/or
  5. modify it under the terms of the GNU General Public License
  6. as published by the Free Software Foundation; either version 2
  7. of the License, or (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  15. *)
  16. open Ast
  17. open Type
  18. open Nast
  19. open Common
  20. type context = {
  21. version : int;
  22. com : Common.context;
  23. packages : (string list, unit) Hashtbl.t;
  24. globals : (string list * string, string) Hashtbl.t;
  25. mutable curglobal : int;
  26. mutable macros : bool;
  27. mutable curclass : string;
  28. mutable curmethod : string;
  29. mutable inits : (tclass * texpr) list;
  30. mutable label_count : int;
  31. }
  32. let files = Hashtbl.create 0
  33. let pos ctx p =
  34. if ctx.macros then
  35. {
  36. psource = p.pfile;
  37. pline = p.pmin lor ((p.pmax - p.pmin) lsl 20);
  38. }
  39. else let file = (match ctx.com.debug with
  40. | true -> ctx.curclass ^ "::" ^ ctx.curmethod
  41. | false ->
  42. try
  43. Hashtbl.find files p.pfile
  44. with Not_found ->
  45. let path = (match Common.defined ctx.com Common.Define.AbsolutePath with
  46. | true -> if (Filename.is_relative p.pfile)
  47. then Filename.concat (Sys.getcwd()) p.pfile
  48. else p.pfile
  49. | false -> try
  50. (* lookup relative path *)
  51. let len = String.length p.pfile in
  52. let base = List.find (fun path ->
  53. let l = String.length path in
  54. len > l && String.sub p.pfile 0 l = path
  55. ) ctx.com.Common.class_path in
  56. let l = String.length base in
  57. String.sub p.pfile l (len - l)
  58. with Not_found -> p.pfile
  59. ) in
  60. Hashtbl.add files p.pfile path;
  61. path
  62. ) in
  63. {
  64. psource = file;
  65. pline = Lexer.get_error_line p;
  66. }
  67. let gen_global_name ctx path =
  68. match path with
  69. | [], name -> name
  70. | _ ->
  71. try
  72. Hashtbl.find ctx.globals path
  73. with Not_found ->
  74. let name = "@G" ^ string_of_int ctx.curglobal in
  75. ctx.curglobal <- ctx.curglobal + 1;
  76. Hashtbl.add ctx.globals path name;
  77. name
  78. let null p =
  79. (EConst Null,p)
  80. let this p =
  81. (EConst This,p)
  82. let int p n =
  83. (EConst (Int n),p)
  84. let str p s =
  85. (EConst (String s),p)
  86. let ident p s =
  87. let l = String.length s in
  88. if l > 10 && String.sub s 0 10 = "__dollar__" then
  89. (EConst (Builtin (String.sub s 10 (l - 10))),p)
  90. else
  91. (EConst (Ident s),p)
  92. let field p e f =
  93. (EField (e,f),p)
  94. let builtin p n =
  95. (EConst (Builtin n),p)
  96. let call p e el =
  97. (ECall (e,el),p)
  98. let array p el =
  99. call p (builtin p "array") el
  100. let pmap_list f p =
  101. PMap.fold (fun v acc -> f v :: acc) p []
  102. let rec needs_return e =
  103. match e with
  104. | (EBlock l,_) ->
  105. let rec loop = function
  106. | [] -> true
  107. | [x] -> needs_return x
  108. | _ :: l -> loop l
  109. in
  110. loop l
  111. | (EReturn _,_) ->
  112. false
  113. | _ ->
  114. true
  115. let with_return e =
  116. if needs_return e then
  117. let p = snd e in
  118. let ret = EReturn (Some (null p)),p in
  119. match e with
  120. | (EBlock l,_) ->
  121. (EBlock (l @ [ret]),p)
  122. | _ ->
  123. (EBlock [e;ret] , p)
  124. else
  125. e
  126. let gen_type_path p (path,t) =
  127. match path with
  128. | [] ->
  129. ident p t
  130. | path :: l ->
  131. let epath = List.fold_left (fun e path -> field p e path) (ident p path) l in
  132. field p epath t
  133. let rec gen_big_string ctx p s =
  134. let max = 1 lsl 16 - 1 in
  135. if String.length s > max then
  136. (EBinop ("+",str p (String.sub s 0 max),gen_big_string ctx p (String.sub s max (String.length s - max))),p)
  137. else
  138. str p s
  139. let gen_constant ctx pe c =
  140. let p = pos ctx pe in
  141. match c with
  142. | TInt i ->
  143. (try
  144. let h = Int32.to_int (Int32.shift_right_logical i 24) in
  145. if (h land 128 = 0) <> (h land 64 = 0) then raise Exit;
  146. int p (Int32.to_int i)
  147. with _ ->
  148. 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;
  149. (EConst (Int32 i),p))
  150. | TFloat f -> (EConst (Float f),p)
  151. | TString s -> call p (field p (ident p "String") "new") [gen_big_string ctx p s]
  152. | TBool b -> (EConst (if b then True else False),p)
  153. | TNull -> null p
  154. | TThis -> this p
  155. | TSuper -> assert false
  156. let rec gen_binop ctx p op e1 e2 =
  157. (EBinop (Ast.s_binop op,gen_expr ctx e1,gen_expr ctx e2),p)
  158. and gen_unop ctx p op flag e =
  159. match op with
  160. | Increment -> (EBinop ((if flag = Prefix then "+=" else "++="), gen_expr ctx e , int p 1),p)
  161. | Decrement -> (EBinop ((if flag = Prefix then "-=" else "--="), gen_expr ctx e , int p 1),p)
  162. | Not -> call p (builtin p "not") [gen_expr ctx e]
  163. | Neg -> (EBinop ("-",int p 0, gen_expr ctx e),p)
  164. | NegBits -> (EBinop ("-",int p (-1), gen_expr ctx e),p)
  165. and gen_call ctx p e el =
  166. match e.eexpr , el with
  167. | TConst TSuper , _ ->
  168. let c = (match follow e.etype with TInst (c,_) -> c | _ -> assert false) in
  169. call p (builtin p "call") [
  170. field p (gen_type_path p c.cl_path) "__construct__";
  171. this p;
  172. array p (List.map (gen_expr ctx) el)
  173. ]
  174. | TLocal { v_name = "__resources__" }, [] ->
  175. call p (builtin p "array") (Hashtbl.fold (fun name data acc ->
  176. (EObject [("name",gen_constant ctx e.epos (TString name));("data",gen_big_string ctx p data)],p) :: acc
  177. ) ctx.com.resources [])
  178. | TField ({ eexpr = TConst TSuper; etype = t },f) , _ ->
  179. let c = (match follow t with TInst (c,_) -> c | _ -> assert false) in
  180. call p (builtin p "call") [
  181. field p (gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path)) (field_name f);
  182. this p;
  183. array p (List.map (gen_expr ctx) el)
  184. ]
  185. | _ , _ ->
  186. let e = (match gen_expr ctx e with EFunction _, _ as e -> (EBlock [e],p) | e -> e) in
  187. call p e (List.map (gen_expr ctx) el)
  188. and gen_expr ctx e =
  189. let p = pos ctx e.epos in
  190. match e.eexpr with
  191. | TConst c ->
  192. gen_constant ctx e.epos c
  193. | TLocal v when v.v_name.[0] = '$' ->
  194. (EConst (Builtin (String.sub v.v_name 1 (String.length v.v_name - 1))),p)
  195. | TLocal v ->
  196. if v.v_capture then
  197. (EArray (ident p v.v_name,int p 0),p)
  198. else
  199. ident p v.v_name
  200. | TArray (e1,e2) ->
  201. (EArray (gen_expr ctx e1,gen_expr ctx e2),p)
  202. | TBinop (OpAssign,{ eexpr = TField (e1,f) },e2) ->
  203. (EBinop ("=",field p (gen_expr ctx e1) (field_name f),gen_expr ctx e2),p)
  204. | TBinop (op,e1,e2) ->
  205. gen_binop ctx p op e1 e2
  206. | TField (e2,FClosure (_,f)) ->
  207. (match follow e.etype with
  208. | TFun (args,_) ->
  209. let n = List.length args in
  210. if n > 5 then error "Cannot create closure with more than 5 arguments" e.epos;
  211. let tmp = ident p "@tmp" in
  212. EBlock [
  213. (EVars ["@tmp", Some (gen_expr ctx e2); "@fun", Some (field p tmp f.cf_name)] , p);
  214. if ctx.macros then
  215. call p (builtin p "closure") [ident p "@fun";tmp]
  216. else
  217. call p (ident p ("@closure" ^ string_of_int n)) [tmp;ident p "@fun"]
  218. ] , p
  219. | _ -> assert false)
  220. | TEnumParameter (e,_,i) ->
  221. EArray (field p (gen_expr ctx e) "args",int p i),p
  222. | TField (e,f) ->
  223. field p (gen_expr ctx e) (field_name f)
  224. | TTypeExpr t ->
  225. gen_type_path p (t_path t)
  226. | TParenthesis e ->
  227. (EParenthesis (gen_expr ctx e),p)
  228. | TMeta (_,e) ->
  229. gen_expr ctx e
  230. | TObjectDecl fl ->
  231. let hasToString = ref false in
  232. 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
  233. (EObject (if !hasToString then ("__string",ident p "@default__string") :: fl else fl),p)
  234. | TArrayDecl el ->
  235. call p (field p (ident p "Array") "new1") [array p (List.map (gen_expr ctx) el); int p (List.length el)]
  236. | TCall (e,el) ->
  237. gen_call ctx p e el
  238. | TNew (c,_,params) ->
  239. call p (field p (gen_type_path p c.cl_path) "new") (List.map (gen_expr ctx) params)
  240. | TUnop (op,flag,e) ->
  241. gen_unop ctx p op flag e
  242. | TVar (v,eo) ->
  243. (EVars (
  244. let e = (match eo with
  245. | None ->
  246. if v.v_capture then
  247. Some (call p (builtin p "array") [null p])
  248. else
  249. None
  250. | Some e ->
  251. let e = gen_expr ctx e in
  252. if v.v_capture then
  253. Some (call p (builtin p "array") [e])
  254. else
  255. Some e
  256. ) in
  257. [v.v_name, e]
  258. ),p)
  259. | TFunction f ->
  260. let inits = List.fold_left (fun acc (a,c) ->
  261. let acc = if a.v_capture then
  262. (EBinop ("=",ident p a.v_name,call p (builtin p "array") [ident p a.v_name]),p) :: acc
  263. else
  264. acc
  265. in
  266. match c with
  267. | None | Some TNull -> acc
  268. | Some c -> gen_expr ctx (Codegen.set_default ctx.com a c e.epos) :: acc
  269. ) [] f.tf_args in
  270. let e = gen_expr ctx f.tf_expr in
  271. let e = (match inits with [] -> e | _ -> EBlock (List.rev (e :: inits)),p) in
  272. (EFunction (List.map arg_name f.tf_args, with_return e),p)
  273. | TBlock el ->
  274. (EBlock (List.map (gen_expr ctx) el), p)
  275. | TFor (v, it, e) ->
  276. let it = gen_expr ctx it in
  277. let e = gen_expr ctx e in
  278. let next = call p (field p (ident p "@tmp") "next") [] in
  279. let next = (if v.v_capture then call p (builtin p "array") [next] else next) in
  280. (EBlock
  281. [(EVars ["@tmp", Some it],p);
  282. (EWhile (call p (field p (ident p "@tmp") "hasNext") [],
  283. (EBlock [
  284. (EVars [v.v_name, Some next],p);
  285. e
  286. ],p)
  287. ,NormalWhile),p)]
  288. ,p)
  289. | TIf (cond,e1,e2) ->
  290. (* if(e)-1 is parsed as if( e - 1 ) *)
  291. let parent e = mk (TParenthesis e) e.etype e.epos in
  292. let e1 = (match e1.eexpr with TConst (TInt n) when n < 0l -> parent e1 | TConst (TFloat f) when f.[0] = '-' -> parent e1 | _ -> e1) in
  293. (EIf (gen_expr ctx cond,gen_expr ctx e1,(match e2 with None -> None | Some e -> Some (gen_expr ctx e))),p)
  294. | TWhile (econd,e,flag) ->
  295. (EWhile (gen_expr ctx econd, gen_expr ctx e, match flag with Ast.NormalWhile -> NormalWhile | Ast.DoWhile -> DoWhile),p)
  296. | TTry (e,catchs) ->
  297. let rec loop = function
  298. | [] -> call p (builtin p "rethrow") [ident p "@tmp"]
  299. | (v,e) :: l ->
  300. let e2 = loop l in
  301. let path = (match follow v.v_type with
  302. | TInst (c,_) -> Some c.cl_path
  303. | TEnum (e,_) -> Some e.e_path
  304. | TAbstract (a,_) -> Some a.a_path
  305. | TDynamic _ -> None
  306. | _ -> assert false
  307. ) in
  308. let cond = (match path with
  309. | None -> (EConst True,p)
  310. | Some path -> call p (field p (gen_type_path p (["neko"],"Boot")) "__instanceof") [ident p "@tmp"; gen_type_path p path]
  311. ) in
  312. let id = ident p "@tmp" in
  313. let id = (if v.v_capture then call p (builtin p "array") [id] else id) in
  314. let e = gen_expr ctx e in
  315. (EIf (cond,(EBlock [
  316. EVars [v.v_name,Some id],p;
  317. e;
  318. ],p),Some e2),p)
  319. in
  320. let catchs = loop catchs in
  321. let catchs = (EBlock [
  322. (EIf (
  323. (EBinop ("==",call p (builtin p "typeof") [ident p "@tmp"],builtin p "tstring"),p),
  324. (EBinop ("=",ident p "@tmp",call p (field p (ident p "String") "new") [ident p "@tmp"]),p),
  325. None
  326. ),p);
  327. catchs;
  328. ],p) in
  329. (ETry (gen_expr ctx e,"@tmp",catchs),p)
  330. | TReturn eo ->
  331. (EReturn (match eo with None -> Some (null p) | Some e -> Some (gen_expr ctx e)),p)
  332. | TBreak ->
  333. (EBreak None,p)
  334. | TContinue ->
  335. (EContinue,p)
  336. | TThrow e ->
  337. call p (builtin p "throw") [gen_expr ctx e]
  338. | TCast (e,None) ->
  339. gen_expr ctx e
  340. | TCast (e1,Some t) ->
  341. gen_expr ctx (Codegen.default_cast ~vtmp:"@tmp" ctx.com e1 t e.etype e.epos)
  342. | TSwitch (e,cases,eo) ->
  343. let e = gen_expr ctx e in
  344. let eo = (match eo with None -> None | Some e -> Some (gen_expr ctx e)) in
  345. try
  346. (ESwitch (
  347. e,
  348. List.map (fun (el,e2) ->
  349. match List.map (gen_expr ctx) el with
  350. | [] -> assert false
  351. | [e] -> e, gen_expr ctx e2
  352. | _ -> raise Exit
  353. ) cases,
  354. eo
  355. ),p)
  356. with
  357. Exit ->
  358. (EBlock [
  359. (EVars ["@tmp",Some e],p);
  360. List.fold_left (fun acc (el,e) ->
  361. let cond = (match el with
  362. | [] -> assert false
  363. | e :: l ->
  364. let eq e = (EBinop ("==",ident p "@tmp",gen_expr ctx e),p) in
  365. List.fold_left (fun acc e -> (EBinop ("||",acc,eq e),p)) (eq e) l
  366. ) in
  367. EIf (cond,gen_expr ctx e,Some acc),p
  368. ) (match eo with None -> null p | Some e -> e) (List.rev cases)
  369. ],p)
  370. let gen_method ctx p c acc =
  371. ctx.curmethod <- c.cf_name;
  372. if is_extern_field c then acc else
  373. match c.cf_expr with
  374. | None ->
  375. ((c.cf_name, null p) :: acc)
  376. | Some e ->
  377. match e.eexpr with
  378. | 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) }]) ->
  379. let p = pos ctx e.epos in
  380. 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
  381. let e = (if load = "load" then e else (ETry (e,"@e",call p (ident p "@lazy_error") [ident p "@e"]),p)) in
  382. (c.cf_name, e) :: acc
  383. | TFunction _ -> ((if c.cf_name = "new" then "__construct__" else c.cf_name), gen_expr ctx e) :: acc
  384. | _ -> (c.cf_name, null p) :: acc
  385. let gen_class ctx c =
  386. ctx.curclass <- s_type_path c.cl_path;
  387. ctx.curmethod <- "$init";
  388. let p = pos ctx c.cl_pos in
  389. let clpath = gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path) in
  390. let stpath = gen_type_path p c.cl_path in
  391. let fnew = (match c.cl_constructor with
  392. | Some f ->
  393. (match f.cf_expr with
  394. | Some {eexpr = TFunction tf} ->
  395. let params = List.map (fun (v,_) -> v.v_name) tf.tf_args in
  396. gen_method ctx p f ["new",(EFunction (params,(EBlock [
  397. (EVars ["@o",Some (call p (builtin p "new") [null p])],p);
  398. (call p (builtin p "objsetproto") [ident p "@o"; clpath]);
  399. (call p (builtin p "call") [field p (this p) "__construct__"; ident p "@o"; array p (List.map (ident p) params)]);
  400. (EReturn (Some (ident p "@o")),p)
  401. ],p)),p)]
  402. | _ -> [])
  403. | None ->
  404. []
  405. ) in
  406. let fstring = (try
  407. let f = PMap.find "toString" c.cl_fields in
  408. match follow f.cf_type with
  409. | TFun ([],_) -> ["__string",ident p "@default__string"]
  410. | _ -> []
  411. with Not_found ->
  412. []
  413. ) in
  414. let fserialize = "__serialize" , ident p "@serialize" in
  415. let others = (match c.cl_implements with
  416. | [] -> []
  417. | l -> ["__interfaces__",array p (List.map (fun (c,_) -> gen_type_path p c.cl_path) l)]
  418. ) @ (match c.cl_super with
  419. | None -> []
  420. | Some (c,_) -> ["__super__", gen_type_path p c.cl_path]
  421. ) in
  422. let build (f,e) = (EBinop ("=",field p (ident p "@tmp") f,e),p) in
  423. let tmp = (EVars ["@tmp",Some (call p (builtin p "new") [null p])],p) in
  424. let estat = (EBinop ("=", stpath, ident p "@tmp"),p) in
  425. let gen_props props = (EObject (List.map (fun (n,s) -> n,str p s) props),p) in
  426. let sprops = (match Codegen.get_properties c.cl_ordered_statics with
  427. | [] -> []
  428. | l -> ["__properties__",gen_props l]
  429. ) in
  430. let sfields = List.map build
  431. (
  432. ("prototype",clpath) :: sprops @
  433. PMap.fold (gen_method ctx p) c.cl_statics (fnew @ others)
  434. )
  435. in
  436. let eclass = (EBinop ("=", clpath, ident p "@tmp"),p) in
  437. let mfields = List.map build
  438. (PMap.fold (gen_method ctx p) c.cl_fields (fserialize :: fstring))
  439. in
  440. let props = Codegen.get_properties c.cl_ordered_fields in
  441. let emeta = (EBinop ("=",field p clpath "__class__",stpath),p) ::
  442. (match props with
  443. | [] -> []
  444. | _ ->
  445. let props = gen_props props in
  446. let props = (match c.cl_super with
  447. | Some (csup,_) when Codegen.has_properties csup ->
  448. (EBlock [
  449. (EVars ["@tmp",Some props],p);
  450. call p (builtin p "objsetproto") [ident p "@tmp";field p (field p (gen_type_path p csup.cl_path) "prototype") "__properties__"];
  451. ident p "@tmp"
  452. ],p)
  453. | _ -> props
  454. ) in
  455. [EBinop ("=",field p clpath "__properties__",props),p])
  456. @ match c.cl_path with
  457. | [] , name -> [(EBinop ("=",field p (ident p "@classes") name,ident p name),p)]
  458. | _ -> []
  459. in
  460. let emeta = if ctx.macros then
  461. (EBinop ("=",field p stpath "__ct__",call p (builtin p "typewrap") [Obj.magic (TClassDecl c)]),p) :: emeta
  462. else
  463. emeta
  464. in
  465. let eextends = (match c.cl_super with
  466. | None -> []
  467. | Some (c,_) ->
  468. let esuper = gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path) in
  469. [call p (builtin p "objsetproto") [clpath; esuper]]
  470. ) in
  471. (EBlock (tmp :: eclass :: mfields @ tmp :: estat :: sfields @ eextends @ emeta),p)
  472. let gen_enum_constr ctx path c =
  473. ctx.curmethod <- c.ef_name;
  474. let p = pos ctx c.ef_pos in
  475. (EBinop ("=",field p path c.ef_name, match follow c.ef_type with
  476. | TFun (params,_) ->
  477. let params = List.map (fun (n,_,_) -> n) params in
  478. (EFunction (params,
  479. (EBlock [
  480. (EVars ["@tmp",Some (EObject [
  481. "tag" , str p c.ef_name;
  482. "index" , int p c.ef_index;
  483. "args" , array p (List.map (ident p) params);
  484. ],p)],p);
  485. call p (builtin p "objsetproto") [ident p "@tmp"; field p path "prototype"];
  486. ident p "@tmp";
  487. ],p)
  488. ),p)
  489. | _ ->
  490. (EBlock [
  491. (EVars ["@tmp",Some (EObject ["tag" , str p c.ef_name; "index", int p c.ef_index; "__serialize" , ident p "@tag_serialize"],p)],p);
  492. call p (builtin p "objsetproto") [ident p "@tmp"; field p path "prototype"];
  493. ident p "@tmp";
  494. ],p)
  495. ),p)
  496. let gen_enum ctx e =
  497. ctx.curclass <- s_type_path e.e_path;
  498. ctx.curmethod <- "$init";
  499. let p = pos ctx e.e_pos in
  500. let path = gen_type_path p e.e_path in
  501. let uname = (EConst (Ident (gen_global_name ctx e.e_path)),p) in
  502. (EBlock (
  503. (EBinop ("=",uname, call p (builtin p "new") [null p]),p) ::
  504. (EBinop ("=",path, uname),p) ::
  505. (EBinop ("=",field p uname "prototype", (EObject [
  506. "__enum__" , uname;
  507. "__serialize" , ident p "@serialize";
  508. "__string" , ident p "@enum_to_string"
  509. ],p)),p) ::
  510. pmap_list (gen_enum_constr ctx uname) e.e_constrs @
  511. (match e.e_path with
  512. | [] , name -> [EBinop ("=",field p (ident p "@classes") name,ident p name),p]
  513. | _ -> [])
  514. ),p)
  515. let gen_type ctx t acc =
  516. match t with
  517. | TClassDecl c ->
  518. (match c.cl_init with
  519. | None -> ()
  520. | Some e -> ctx.inits <- (c,e) :: ctx.inits);
  521. if c.cl_extern then
  522. acc
  523. else
  524. gen_class ctx c :: acc
  525. | TEnumDecl e ->
  526. if e.e_extern then
  527. acc
  528. else
  529. gen_enum ctx e :: acc
  530. | TTypeDecl _ | TAbstractDecl _ ->
  531. acc
  532. let gen_static_vars ctx t =
  533. match t with
  534. | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ -> []
  535. | TClassDecl c ->
  536. if c.cl_extern then
  537. []
  538. else
  539. List.fold_right (fun f acc ->
  540. match f.cf_expr with
  541. | None -> acc
  542. | Some e ->
  543. match e.eexpr with
  544. | TFunction _ -> acc
  545. | _ ->
  546. ctx.curclass <- s_type_path c.cl_path;
  547. ctx.curmethod <- "$statics";
  548. let p = pos ctx e.epos in
  549. (EBinop ("=",
  550. (field p (gen_type_path p c.cl_path) f.cf_name),
  551. gen_expr ctx e
  552. ),p) :: acc
  553. ) c.cl_ordered_statics []
  554. let gen_package ctx t =
  555. let rec loop acc p =
  556. match p with
  557. | [] -> []
  558. | x :: l ->
  559. let path = acc @ [x] in
  560. if not (Hashtbl.mem ctx.packages path) then begin
  561. let p = pos ctx (t_infos t).mt_pos in
  562. let e = (EBinop ("=",gen_type_path p (acc,x),call p (builtin p "new") [null p]),p) in
  563. Hashtbl.add ctx.packages path ();
  564. (match acc with
  565. | [] ->
  566. let reg = (EBinop ("=",field p (ident p "@classes") x,ident p x),p) in
  567. e :: reg :: loop path l
  568. | _ ->
  569. e :: loop path l)
  570. end else
  571. loop path l
  572. in
  573. loop [] (fst (t_path t))
  574. let gen_boot ctx =
  575. (EBlock [
  576. EBinop ("=",field null_pos (gen_type_path null_pos (["neko"],"Boot")) "__classes",ident null_pos "@classes"),null_pos;
  577. call null_pos (field null_pos (gen_type_path null_pos (["neko"],"Boot")) "__init") [];
  578. ],null_pos)
  579. let gen_name ctx acc t =
  580. match t with
  581. | TEnumDecl e when e.e_extern ->
  582. acc
  583. | TEnumDecl e ->
  584. let p = pos ctx e.e_pos in
  585. let name = fst e.e_path @ [snd e.e_path] in
  586. 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
  587. let path = gen_type_path p e.e_path in
  588. let setname = (EBinop ("=",field p path "__ename__",arr),p) in
  589. 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
  590. let setconstrs = (EBinop ("=", field p path "__constructs__", arr),p) in
  591. let meta = (match Codegen.build_metadata ctx.com (TEnumDecl e) with
  592. | None -> []
  593. | Some e -> [EBinop ("=",field p path "__meta__", gen_expr ctx e),p]
  594. ) in
  595. let meta = if ctx.macros then
  596. (EBinop ("=",field p path "__et__",call p (builtin p "typewrap") [Obj.magic t]),p) :: meta
  597. else
  598. meta
  599. in
  600. setname :: setconstrs :: meta @ acc
  601. | TClassDecl c ->
  602. if c.cl_extern || (match c.cl_kind with KTypeParameter _ -> true | _ -> false) then
  603. acc
  604. else
  605. let p = pos ctx c.cl_pos in
  606. let name = fst c.cl_path @ [snd c.cl_path] in
  607. 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
  608. (EBinop ("=",field p (gen_type_path p c.cl_path) "__name__",arr),p) ::
  609. (match c.cl_implements with
  610. | [] -> acc
  611. | l ->
  612. let interf = field p (gen_type_path p c.cl_path) "__interfaces__" in
  613. (EBinop ("=",interf, call p (field p (ident p "Array") "new1") [interf; int p (List.length l)]),p) :: acc)
  614. | TTypeDecl _ | TAbstractDecl _ ->
  615. acc
  616. let generate_libs_init = function
  617. | [] -> []
  618. | libs ->
  619. (*
  620. var @s = $loader.loadprim("std@sys_string",0)();
  621. var @env = $loader.loadprim("std@get_env",1);
  622. var @b = if( @s == "Windows" )
  623. @env("HAXEPATH") + "\\lib\\"
  624. else try $loader.loadprim("std@file_contents",1)(@env("HOME")+"/.haxelib") + "/"
  625. catch e
  626. if( @s == "Linux" )
  627. if( $loader(loadprim("std@sys_exists",1))("/usr/lib/haxe/lib") )
  628. "/usr/lib/haxe/lib"
  629. else
  630. "/usr/share/haxe/lib/"
  631. else
  632. "/usr/local/lib/haxe/lib/";
  633. if( try $loader.loadprim("std@sys_file_type",1)(".haxelib") == "dir" catch e false ) @b = $loader.loadprim("std@file_full_path",1)(".haxelib") + "/";
  634. if( $loader.loadprim("std@sys_is64",0)() ) @s = @s + 64;
  635. @b = @b + "/"
  636. *)
  637. let p = null_pos in
  638. let es = ident p "@s" in
  639. let loadp n nargs =
  640. call p (field p (builtin p "loader") "loadprim") [str p ("std@" ^ n); int p nargs]
  641. in
  642. let op o e1 e2 =
  643. (EBinop (o,e1,e2),p)
  644. in
  645. let boot = [
  646. (EVars [
  647. "@s",Some (call p (loadp "sys_string" 0) []);
  648. "@env",Some (loadp "get_env" 1);
  649. "@b", Some (EIf (op "==" es (str p "Windows"),
  650. op "+" (call p (ident p "@env") [str p "HAXEPATH"]) (str p "\\lib\\"),
  651. Some (ETry (
  652. op "+" (call p (loadp "file_contents" 1) [op "+" (call p (ident p "@env") [str p "HOME"]) (str p "/.haxelib")]) (str p "/"),
  653. "e",
  654. (EIf (op "==" es (str p "Linux"),
  655. (EIf (call p (loadp "sys_exists" 1) [ str p "/usr/lib/haxe/lib" ],
  656. str p "/usr/lib/haxe/lib/",
  657. Some (str p "/usr/share/haxe/lib/")),p),
  658. Some (str p "/usr/local/lib/haxe/lib/")
  659. ),p)
  660. ),p)
  661. ),p);
  662. ],p);
  663. (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);
  664. (EIf (call p (loadp "sys_is64" 0) [],op "=" es (op "+" es (int p 64)),None),p);
  665. op "=" es (op "+" es (str p "/"));
  666. ] in
  667. let lpath = field p (builtin p "loader") "path" in
  668. boot @ List.map (fun dir ->
  669. let full_path = dir.[0] = '/' || dir.[1] = ':' in
  670. let dstr = str p dir in
  671. (*
  672. // for each lib dir
  673. $loader.path = $array($loader.path,@b+dir+@s);
  674. *)
  675. op "=" lpath (call p (builtin p "array") [op "+" (if full_path then dstr else op "+" (ident p "@b") dstr) (ident p "@s"); lpath])
  676. ) libs
  677. let new_context com ver macros =
  678. {
  679. version = ver;
  680. com = com;
  681. globals = Hashtbl.create 0;
  682. curglobal = 0;
  683. packages = Hashtbl.create 0;
  684. macros = macros;
  685. curclass = "$boot";
  686. curmethod = "$init";
  687. inits = [];
  688. label_count = 0;
  689. }
  690. let header() =
  691. let p = { psource = "<header>"; pline = 1 } in
  692. let fields l =
  693. let rec loop = function
  694. | [] -> assert false
  695. | [x] -> ident p x
  696. | x :: l -> field p (loop l) x
  697. in
  698. loop (List.rev l)
  699. in
  700. let func pl e =
  701. (EFunction (pl,(EReturn (Some e),p)),p)
  702. in
  703. let inits = [
  704. "@classes",call p (builtin p "new") [null p];
  705. "@enum_to_string",func [] (call p (fields ["neko";"Boot";"__enum_str"]) [this p]);
  706. "@serialize",func [] (call p (fields ["neko";"Boot";"__serialize"]) [this p]);
  707. "@tag_serialize",func [] (call p (fields ["neko";"Boot";"__tagserialize"]) [this p]);
  708. "@lazy_error",func ["e"] (call p (builtin p "varargs") [func ["_"] (call p (builtin p "throw") [ident p "e"])]);
  709. "@default__string",func [] (EBlock [
  710. EVars ["@s",Some (call p (field p (this p) "toString") [])] ,p;
  711. EIf ((EBinop ("!=",call p (builtin p "typeof") [ident p "@s"],builtin p "tobject"),p),(EReturn (Some (null p)),p),None),p;
  712. EReturn (Some (field p (ident p "@s") "__s")),p;
  713. ],p)
  714. ] in
  715. let inits = inits @ List.map (fun nargs ->
  716. let args = Array.to_list (Array.init nargs (fun i -> Printf.sprintf "%c" (char_of_int (int_of_char 'a' + i)))) in
  717. let efun = (EFunction (args,(EBlock [
  718. (EBinop ("=",(EConst This,p),ident p "@this"),p);
  719. call p (ident p "@fun") (List.map (ident p) args);
  720. ],p)),p) in
  721. let eif = EIf ((EBinop ("==",ident p "@fun",null p),p),null p,Some efun) in
  722. let e = func ["@this";"@fun"] (eif,p) in
  723. "@closure" ^ string_of_int nargs, e
  724. ) [0;1;2;3;4;5] in
  725. List.map (fun (v,e)-> EBinop ("=",ident p v,e),p) inits
  726. let build ctx types =
  727. let packs = List.concat (List.map (gen_package ctx) types) in
  728. let names = List.fold_left (gen_name ctx) [] types in
  729. let methods = List.rev (List.fold_left (fun acc t -> gen_type ctx t acc) [] types) in
  730. let boot = gen_boot ctx in
  731. let inits = List.map (fun (c,e) ->
  732. ctx.curclass <- s_type_path c.cl_path;
  733. ctx.curmethod <- "__init__";
  734. gen_expr ctx e
  735. ) (List.rev ctx.inits) in
  736. ctx.inits <- [];
  737. let vars = List.concat (List.map (gen_static_vars ctx) types) in
  738. packs @ methods @ boot :: names @ inits @ vars
  739. let generate com =
  740. let ctx = new_context com (if Common.defined com Define.NekoV1 then 1 else 2) false in
  741. let libs = (EBlock (generate_libs_init com.neko_libs) , { psource = "<header>"; pline = 1; }) in
  742. let el = build ctx com.types in
  743. let emain = (match com.main with None -> [] | Some e -> [gen_expr ctx e]) in
  744. let e = (EBlock ((header()) @ libs :: el @ emain), null_pos) in
  745. let source = Common.defined com Define.NekoSource in
  746. let use_nekoc = Common.defined com Define.UseNekoc in
  747. if not use_nekoc then begin
  748. try
  749. mkdir_from_path com.file;
  750. let ch = IO.output_channel (open_out_bin com.file) in
  751. Nbytecode.write ch (Ncompile.compile ctx.version e);
  752. IO.close_out ch;
  753. with Ncompile.Error (msg,pos) ->
  754. let pfile = Common.find_file com pos.psource in
  755. let rec loop p =
  756. let pp = { pfile = pfile; pmin = p; pmax = p; } in
  757. if Lexer.get_error_line pp >= pos.pline then
  758. pp
  759. else
  760. loop (p + 1)
  761. in
  762. error msg (loop 0)
  763. end;
  764. let command cmd = try com.run_command cmd with _ -> -1 in
  765. let neko_file = (try Filename.chop_extension com.file with _ -> com.file) ^ ".neko" in
  766. if source || use_nekoc then begin
  767. let ch = IO.output_channel (open_out_bin neko_file) in
  768. Binast.write ch e;
  769. IO.close_out ch;
  770. end;
  771. 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";
  772. if source then begin
  773. if command ("nekoc -p \"" ^ neko_file ^ "\"") <> 0 then failwith "Failed to print neko code";
  774. Sys.remove neko_file;
  775. Sys.rename ((try Filename.chop_extension com.file with _ -> com.file) ^ "2.neko") neko_file;
  776. end