From 0a3cd961d04c7ca60e0e061bcc69e671c3a81ab0 Mon Sep 17 00:00:00 2001 From: Nicolas Cannasse Date: Thu, 16 Sep 2010 16:51:26 +0000 Subject: [PATCH] refactoring + allow @:build for enums --- ast.ml | 2 +- codegen.ml | 29 ++-- common.ml | 28 ++-- genas3.ml | 2 +- genswf.ml | 2 +- genswf9.ml | 16 +-- genxml.ml | 4 +- main.ml | 17 ++- optimizer.ml | 14 +- typecore.ml | 11 +- typeload.ml | 88 ++++++++---- typer.ml | 387 +++++++++++++++++++++++++-------------------------- 12 files changed, 311 insertions(+), 289 deletions(-) diff --git a/ast.ml b/ast.ml index 888f83da031..632d6680629 100755 --- a/ast.ml +++ b/ast.ml @@ -270,7 +270,7 @@ let punion p p2 = let s_type_path (p,s) = match p with [] -> s | _ -> String.concat "." p ^ "." ^ s -let s_parse_path s = +let parse_path s = match List.rev (ExtString.String.nsplit s ".") with | [] -> failwith "Invalid empty path" | x :: l -> List.rev l, x diff --git a/codegen.ml b/codegen.ml index 5ad2d36e307..243c5d7a9e0 100644 --- a/codegen.ml +++ b/codegen.ml @@ -33,13 +33,13 @@ let fcall e name el ret p = mk (TCall (field e name ft p,el)) ret p let string com str p = - mk (TConst (TString str)) com.type_api.tstring p + mk (TConst (TString str)) com.basic.tstring p let binop op a b t p = mk (TBinop (op,a,b)) t p let index com e index t p = - mk (TArray (e,mk (TConst (TInt (Int32.of_int index))) com.type_api.tint p)) t p + mk (TArray (e,mk (TConst (TInt (Int32.of_int index))) com.basic.tint p)) t p let concat e1 e2 = let e = (match e1.eexpr, e2.eexpr with @@ -174,7 +174,7 @@ let rec build_generic ctx c p tl = match t with | TInst ({ cl_kind = KGeneric } as c2,tl2) -> (* maybe loop, or generate cascading generics *) - let _, _, f = ctx.api.build_instance (TClassDecl c2) p in + let _, _, f = ctx.g.do_build_instance ctx (TClassDecl c2) p in f (List.map build_type tl2) | _ -> try List.assq t subst with Not_found -> Type.map build_type t @@ -262,7 +262,7 @@ let extend_xml_proxy ctx c t file p = (* BUILD META DATA OBJECT *) let build_metadata com t = - let api = com.type_api in + let api = com.basic in let p, meta, fields, statics = (match t with | TClassDecl c -> let fields = List.map (fun f -> f.cf_name,f.cf_meta()) (c.cl_ordered_fields @ (match c.cl_constructor with None -> [] | Some f -> [{ f with cf_name = "_" }])) in @@ -357,11 +357,11 @@ let on_generate ctx t = | ":native",[{ eexpr = TConst (TString name) } as e] -> meta := (":real",[{ e with eexpr = TConst (TString (s_type_path c.cl_path)) }]) :: !meta; c.cl_meta <- (fun() -> !meta); - c.cl_path <- s_parse_path name; + c.cl_path <- parse_path name; | _ -> () ) (!meta); if has_rtti c && not (PMap.mem "__rtti" c.cl_statics) then begin - let f = mk_field "__rtti" ctx.api.tstring in + let f = mk_field "__rtti" ctx.t.tstring in let str = Genxml.gen_type_string ctx.com t in f.cf_expr <- Some (mk (TConst (TString str)) f.cf_type c.cl_pos); c.cl_ordered_statics <- f :: c.cl_ordered_statics; @@ -464,7 +464,7 @@ let rec local_usage f e = This way, each value is captured independantly. *) -let block_vars ctx e = +let block_vars com e = let uid = ref 0 in let gen_unique() = @@ -472,7 +472,7 @@ let block_vars ctx e = "$t" ^ string_of_int !uid; in - let t = ctx.type_api in + let t = com.basic in let rec mk_init v vt vtmp pos = let at = t.tarray vt in @@ -556,7 +556,7 @@ let block_vars ctx e = v, o, vt ) f.tf_args in let e = { e with eexpr = TFunction { f with tf_args = fargs; tf_expr = !fexpr } } in - (match ctx.platform with + (match com.platform with | Cpp -> e | _ -> let args = List.map (fun (v,t) -> v, None, t) vars in @@ -634,7 +634,7 @@ let block_vars ctx e = local_usage collect_vars e; if PMap.is_empty !used then e else wrap !used e in - match ctx.platform with + match com.platform with | Neko | Php | Cross -> e | Cpp -> all_vars e | _ -> out_loop e @@ -806,7 +806,7 @@ type stack_context = { } let stack_context_init com stack_var exc_var pos_var tmp_var use_add p = - let t = com.type_api in + let t = com.basic in let st = t.tarray t.tstring in let stack_e = mk (TLocal stack_var) st p in let exc_e = mk (TLocal exc_var) st p in @@ -1015,7 +1015,7 @@ let rec is_volatile t = let set_default ctx a c t p = let ve = mk (TLocal a) t p in - mk (TIf (mk (TBinop (OpEq,ve,mk (TConst TNull) t p)) ctx.type_api.tbool p, mk (TBinop (OpAssign,ve,mk (TConst c) t p)) t p,None)) ctx.type_api.tvoid p + mk (TIf (mk (TBinop (OpEq,ve,mk (TConst TNull) t p)) ctx.basic.tbool p, mk (TBinop (OpAssign,ve,mk (TConst c) t p)) t p,None)) ctx.basic.tvoid p let bytes_serialize data = let b64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789%:" in @@ -1103,7 +1103,7 @@ let dump_types com = { var $t = ; if( Std.is($t,) ) $t else throw "Class cast error"; } *) let default_cast ?(vtmp="$t") com e texpr t p = - let api = com.type_api in + let api = com.basic in 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) } @@ -1112,8 +1112,7 @@ let default_cast ?(vtmp="$t") com e texpr t p = let var = mk (TVars [(vtmp,e.etype,Some e)]) api.tvoid p in let vexpr = mk (TLocal vtmp) e.etype p in let texpr = mk (TTypeExpr texpr) (mk_texpr texpr) p in - let std = (match (api.load_module ([],"Std") p).mtypes with [std] -> std | _ -> assert false) in - (*Typeload.load_type_def ctx p { tpackage = []; tname = "Std"; tparams = []; tsub = None } in *) + let std = (try List.find (fun t -> t_path t = ([],"Std")) com.types with Not_found -> assert false) in let std = mk (TTypeExpr std) (mk_texpr std) p in let is = mk (TField (std,"is")) (tfun [t_dynamic;t_dynamic] api.tbool) p in let is = mk (TCall (is,[vexpr;texpr])) api.tbool p in diff --git a/common.ml b/common.ml index fee2638245e..7774675c93b 100644 --- a/common.ml +++ b/common.ml @@ -34,8 +34,7 @@ type platform = type pos = Ast.pos -type context_type_api = { - (* basic types *) +type basic_types = { mutable tvoid : t; mutable tint : t; mutable tfloat : t; @@ -43,13 +42,6 @@ type context_type_api = { mutable tnull : t -> t; mutable tstring : t; mutable tarray : t -> t; - (* api *) - mutable load_module : path -> pos -> module_def; - mutable build_instance : module_type -> pos -> ((string * t) list * path * (t list -> t)); - mutable on_generate : module_type -> unit; - mutable get_type_module : module_type -> module_def; - mutable optimize : texpr -> texpr; - mutable load_extern_type : (path -> pos -> Ast.package) list; } type context = { @@ -67,15 +59,17 @@ type context = { mutable error : string -> pos -> unit; mutable warning : string -> pos -> unit; mutable js_namespace : string option; + mutable load_extern_type : (path -> pos -> Ast.package option) list; (* allow finding types which are not in sources *) (* output *) mutable file : string; mutable flash_version : int; + mutable modules : Type.module_def list; mutable types : Type.module_type list; mutable resources : (string,string) Hashtbl.t; mutable php_front : string option; mutable swf_libs : (string * (unit -> Swf.swf) * (unit -> ((string list * string),As3hl.hl_class) Hashtbl.t)) list; (* typing *) - mutable type_api : context_type_api; + mutable basic : basic_types; mutable lines : Lexer.line_index; } @@ -98,14 +92,16 @@ let create v = package_rules = PMap.empty; file = ""; types = []; + modules = []; flash_version = 8; resources = Hashtbl.create 0; php_front = None; swf_libs = []; js_namespace = None; + load_extern_type = []; warning = (fun _ _ -> assert false); error = (fun _ _ -> assert false); - type_api = { + basic = { tvoid = m; tint = m; tfloat = m; @@ -113,19 +109,13 @@ let create v = tnull = (fun _ -> assert false); tstring = m; tarray = (fun _ -> assert false); - load_module = (fun _ _ -> assert false); - build_instance = (fun _ _ -> assert false); - on_generate = (fun _ -> ()); - get_type_module = (fun _ -> assert false); - optimize = (fun _ -> assert false); - load_extern_type = []; }; lines = Lexer.build_line_index(); } let clone com = - let t = com.type_api in - { com with type_api = { t with tvoid = t.tvoid } } + let t = com.basic in + { com with basic = { t with tvoid = t.tvoid } } let platforms = [ Flash; diff --git a/genas3.ml b/genas3.ml index 397a1fdadef..4cb95b70a3f 100644 --- a/genas3.ml +++ b/genas3.ml @@ -451,7 +451,7 @@ and gen_expr ctx e = | TEnumField (en,s) -> print ctx "%s.%s" (s_path ctx true en.e_path e.epos) (s_ident s) | TArray ({ eexpr = TLocal "__global__" },{ eexpr = TConst (TString s) }) -> - let path = Ast.s_parse_path s in + let path = Ast.parse_path s in spr ctx (s_path ctx false path e.epos) | TArray (e1,e2) -> gen_value ctx e1; diff --git a/genswf.ml b/genswf.ml index b74b9f1c560..db73e3d79e0 100644 --- a/genswf.ml +++ b/genswf.ml @@ -750,7 +750,7 @@ let merge com file priority (h1,tags1) (h2,tags2) = | TSetBgColor _ -> priority | TExport el when !nframe = 0 && com.flash_version >= 9 -> let el = List.filter (fun e -> - let path = s_parse_path e.exp_name in + let path = parse_path e.exp_name in List.exists (fun t -> t_path t = path) com.types ) el in classes := !classes @ List.map (fun e -> { f9_cid = Some e.exp_id; f9_classname = e.exp_name }) el; diff --git a/genswf9.ml b/genswf9.ml index c58ef6f0389..6a963fb48b8 100644 --- a/genswf9.ml +++ b/genswf9.ml @@ -686,7 +686,7 @@ let begin_fun ctx args tret el stat p = ) let empty_method ctx p = - let f = begin_fun ctx [] ctx.com.type_api.tvoid [] true p in + let f = begin_fun ctx [] ctx.com.basic.tvoid [] true p in write ctx HRetVoid; f() @@ -777,7 +777,7 @@ let gen_access ctx e (forset : 'a) : 'a access = VCast (id,classify ctx e.etype) ) | TArray ({ eexpr = TLocal "__global__" },{ eexpr = TConst (TString s) }) -> - let path = s_parse_path s in + let path = parse_path s in let id = type_path ctx path in if is_set forset then write ctx HGetGlobalScope; VGlobal id @@ -1782,10 +1782,10 @@ let generate_class ctx c = else generate_construct ctx { tf_args = []; - tf_type = ctx.com.type_api.tvoid; + tf_type = ctx.com.basic.tvoid; tf_expr = { eexpr = TBlock []; - etype = ctx.com.type_api.tvoid; + etype = ctx.com.basic.tvoid; epos = null_pos; } } c @@ -1872,7 +1872,7 @@ let generate_class ctx c = let generate_enum ctx e meta = let name_id = type_path ctx e.e_path in - let api = ctx.com.type_api in + let api = ctx.com.basic in let f = begin_fun ctx [("tag",None,api.tstring);("index",None,api.tint);("params",None,mk_mono())] api.tvoid [ethis] false e.e_pos in let tag_id = ident "tag" in let index_id = ident "index" in @@ -1981,7 +1981,7 @@ let generate_inits ctx = (* define flash.Boot.init method *) write ctx HGetGlobalScope; write ctx (HGetProp (type_path ctx (["flash"],"Boot"))); - let finit = begin_fun ctx [] ctx.com.type_api.tvoid [] true null_pos in + let finit = begin_fun ctx [] ctx.com.basic.tvoid [] true null_pos in List.iter (fun t -> match t with | TClassDecl c -> @@ -2007,7 +2007,7 @@ let generate_type ctx t = None else let hlc = generate_class ctx c in - let init = begin_fun ctx [] ctx.com.type_api.tvoid [ethis] false c.cl_pos in + let init = begin_fun ctx [] ctx.com.basic.tvoid [ethis] false c.cl_pos in generate_class_init ctx c hlc; if c.cl_path = (["flash"],"Boot") then generate_inits ctx; write ctx HRetVoid; @@ -2023,7 +2023,7 @@ let generate_type ctx t = else let meta = Codegen.build_metadata ctx.com t in let hlc = generate_enum ctx e meta in - let init = begin_fun ctx [] ctx.com.type_api.tvoid [ethis] false e.e_pos in + let init = begin_fun ctx [] ctx.com.basic.tvoid [ethis] false e.e_pos in generate_enum_init ctx e hlc meta; write ctx HRetVoid; Some (init(), { diff --git a/genxml.ml b/genxml.ml index 3b664961711..9db2f4393dc 100644 --- a/genxml.ml +++ b/genxml.ml @@ -52,7 +52,7 @@ let gen_arg_name (name,opt,_) = let cpath c = let rec loop = function | [] -> c.cl_path - | (":real",[{ eexpr = TConst (TString s) }]) :: _ -> s_parse_path s + | (":real",[{ eexpr = TConst (TString s) }]) :: _ -> parse_path s | _ :: l -> loop l in loop (c.cl_meta()) @@ -125,7 +125,7 @@ let rec exists f c = | Some (csup,_) -> exists f csup let gen_type_decl com t = - let m = com.type_api.get_type_module t in + let m = (try List.find (fun m -> List.memq t m.mtypes) com.modules with Not_found -> { mpath = t_path t; mtypes = [t] }) in match t with | TClassDecl c -> let stats = List.map (gen_field ["static","1"]) c.cl_ordered_statics in diff --git a/main.ml b/main.ml index 0c45e9de7f2..cab9ddebb9a 100755 --- a/main.ml +++ b/main.ml @@ -339,8 +339,12 @@ try ("-swf-lib",Arg.String (fun file -> let getSWF = Genswf.parse_swf com file in let extract = Genswf.extract_data getSWF in - let build cl p = Genswf.build_class com (Hashtbl.find (extract()) cl) file in - com.type_api.load_extern_type <- com.type_api.load_extern_type @ [build]; + let build cl p = + match (try Some (Hashtbl.find (extract()) cl) with Not_found -> None) with + | None -> None + | Some c -> Some (Genswf.build_class com c file) + in + com.load_extern_type <- com.load_extern_type @ [build]; com.swf_libs <- (file,getSWF,extract) :: com.swf_libs )," : add the SWF library to the compiled SWF"); ("-x", Arg.String (fun file -> @@ -378,7 +382,7 @@ try close_in ch; excludes := (List.map (fun l -> let l = ExtString.String.strip l in - if l = "" then ([],"") else Ast.s_parse_path l + if l = "" then ([],"") else Ast.parse_path l ) lines) @ !excludes; )," : don't generate code for classes listed in this file"); ("-prompt", Arg.Unit (fun() -> prompt := true),": prompt on error"); @@ -518,14 +522,15 @@ try if com.verbose then print_endline ("Classpath : " ^ (String.concat ";" com.class_path)); let t = Common.timer "typing" in Typecore.type_expr_ref := (fun ctx e need_val -> Typer.type_expr ~need_val ctx e); - Typecore.build_inheritance := Codegen.on_inherit; let ctx = Typer.create com in - List.iter (fun cpath -> ignore(com.type_api.load_module cpath Ast.null_pos)) (List.rev !classes); + List.iter (fun cpath -> ignore(ctx.Typecore.g.Typecore.do_load_module ctx cpath Ast.null_pos)) (List.rev !classes); Typer.finalize ctx; t(); if !has_error then do_exit(); if !no_output then com.platform <- Cross; - com.types <- Typer.types ctx com.main_class (!excludes); + let types, modules = Typer.generate ctx com.main_class (!excludes) in + com.types <- types; + com.modules <- modules; com.lines <- Lexer.build_line_index(); let filters = [ Codegen.check_local_vars_init; diff --git a/optimizer.ml b/optimizer.ml index 0fe137d0b4f..14bffbf68d5 100644 --- a/optimizer.ml +++ b/optimizer.ml @@ -168,7 +168,7 @@ let type_inline ctx cf f ethis params tret p = | _ -> Type.map_expr inline_params e in let e = (if PMap.is_empty subst then e else inline_params e) in - let init = (match vars with [] -> None | l -> Some (mk (TVars (List.rev l)) ctx.api.tvoid p)) in + let init = (match vars with [] -> None | l -> Some (mk (TVars (List.rev l)) ctx.t.tvoid p)) in if Common.defined ctx.com "js" && (init <> None || !has_vars) then None else @@ -200,8 +200,8 @@ let type_inline ctx cf f ethis params tret p = (* LOOPS *) let optimize_for_loop ctx i e1 e2 p = - let t_void = ctx.api.tvoid in - let t_int = ctx.api.tint in + let t_void = ctx.t.tvoid in + let t_int = ctx.t.tint in let lblock el = Some (mk (TBlock el) t_void p) in match e1.eexpr, follow e1.etype with | TNew ({ cl_path = ([],"IntIter") },[],[i1;i2]) , _ -> @@ -239,7 +239,7 @@ let optimize_for_loop ctx i e1 e2 p = lblock [ mk (TVars [tmp,i1.etype,Some i1]) t_void p; mk (TWhile ( - mk (TBinop (OpLt, etmp, i2)) ctx.api.tbool p, + mk (TBinop (OpLt, etmp, i2)) ctx.t.tbool p, block, NormalWhile )) t_void p; @@ -248,7 +248,7 @@ let optimize_for_loop ctx i e1 e2 p = lblock [ mk (TVars [tmp,i1.etype,Some i1;max,i2.etype,Some i2]) t_void p; mk (TWhile ( - mk (TBinop (OpLt, etmp, mk (TLocal max) i2.etype p)) ctx.api.tbool p, + mk (TBinop (OpLt, etmp, mk (TLocal max) i2.etype p)) ctx.t.tbool p, block, NormalWhile )) t_void p; @@ -275,7 +275,7 @@ let optimize_for_loop ctx i e1 e2 p = lblock [ mk (TVars (ivar :: avars)) t_void p; mk (TWhile ( - mk (TBinop (OpLt, iexpr, mk (TField (arr,"length")) t_int p)) ctx.api.tbool p, + mk (TBinop (OpLt, iexpr, mk (TField (arr,"length")) t_int p)) ctx.t.tbool p, block, NormalWhile )) t_void p; @@ -295,7 +295,7 @@ let optimize_for_loop ctx i e1 e2 p = lblock [ mk (TVars [cell,tcell,Some (mk (TField (e1,"head")) tcell p)]) t_void p; mk (TWhile ( - mk (TBinop (OpNotEq, cexpr, mk (TConst TNull) tcell p)) ctx.api.tbool p, + mk (TBinop (OpNotEq, cexpr, mk (TConst TNull) tcell p)) ctx.t.tbool p, block, NormalWhile )) t_void p diff --git a/typecore.ml b/typecore.ml index d91b2279d4f..b7b4fe9b3a2 100644 --- a/typecore.ml +++ b/typecore.ml @@ -29,12 +29,20 @@ type typer_globals = { mutable macros : ((unit -> unit) * typer) option; mutable std : module_def; mutable hook_generate : (unit -> unit) list; + (* api *) + do_inherit : typer -> Type.tclass -> Ast.pos -> Ast.class_flag -> bool; + do_create : Common.context -> typer; + do_macro : typer -> path -> string -> Ast.expr list -> Ast.pos -> Ast.expr option; + do_load_module : typer -> path -> pos -> module_def; + do_generate : typer -> module_type -> unit; + do_optimize : typer -> texpr -> texpr; + do_build_instance : typer -> module_type -> pos -> ((string * t) list * path * (t list -> t)); } and typer = { (* shared *) com : context; - mutable api : context_type_api; + mutable t : basic_types; g : typer_globals; (* per-module *) current : module_def; @@ -73,7 +81,6 @@ type error_msg = exception Error of error_msg * pos let type_expr_ref : (typer -> Ast.expr -> bool -> texpr) ref = ref (fun _ _ _ -> assert false) -let build_inheritance : (typer -> Type.tclass -> Ast.pos -> Ast.class_flag -> bool) ref = ref (fun _ _ _ _ -> true) let unify_error_msg ctx = function | Cannot_unify (t1,t2) -> diff --git a/typeload.ml b/typeload.ml index 41483bf619d..c43853540c9 100644 --- a/typeload.ml +++ b/typeload.ml @@ -21,8 +21,6 @@ open Type open Common open Typecore -let do_create = ref (fun com -> assert false) - (* make sure we don't access metadata at load time *) let has_meta m (ml:Ast.metadata) = List.exists (fun(m2,_) -> m = m2) ml @@ -32,20 +30,20 @@ let type_constant ctx c p = | Int s -> if String.length s > 10 && String.sub s 0 2 = "0x" then error "Invalid hexadecimal integer" p; (try - mk (TConst (TInt (Int32.of_string s))) ctx.api.tint p + mk (TConst (TInt (Int32.of_string s))) ctx.t.tint p with - _ -> mk (TConst (TFloat s)) ctx.api.tfloat p) - | Float f -> mk (TConst (TFloat f)) ctx.api.tfloat p - | String s -> mk (TConst (TString s)) ctx.api.tstring p - | Ident "true" -> mk (TConst (TBool true)) ctx.api.tbool p - | Ident "false" -> mk (TConst (TBool false)) ctx.api.tbool p - | Ident "null" -> mk (TConst TNull) (ctx.api.tnull (mk_mono())) p + _ -> mk (TConst (TFloat s)) ctx.t.tfloat p) + | Float f -> mk (TConst (TFloat f)) ctx.t.tfloat p + | String s -> mk (TConst (TString s)) ctx.t.tstring p + | Ident "true" -> mk (TConst (TBool true)) ctx.t.tbool p + | Ident "false" -> mk (TConst (TBool false)) ctx.t.tbool p + | Ident "null" -> mk (TConst TNull) (ctx.t.tnull (mk_mono())) p | _ -> assert false let type_function_param ctx t e opt p = match e with | None -> - if opt then ctx.api.tnull t, Some (EConst (Ident "null"),p) else t, None + if opt then ctx.t.tnull t, Some (EConst (Ident "null"),p) else t, None | Some e -> t, Some e @@ -58,6 +56,13 @@ let type_static_var ctx t e p = | TType ({ t_path = ([],"UInt") },[]) -> { e with etype = t } | _ -> e +let apply_macro ctx path el p = + let cpath, meth = (match List.rev (ExtString.String.nsplit path ".") with + | meth :: name :: pack -> (List.rev pack,name), meth + | _ -> error "Invalid macro path" p + ) in + ctx.g.do_macro ctx cpath meth el p + (** since load_type_def and load_instance are used in PASS2, they should not access the structure of a type **) (* @@ -74,7 +79,7 @@ let rec load_type_def ctx p t = with Not_found -> let next() = - let m = ctx.api.load_module (t.tpackage,t.tname) p in + let m = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in let tpath = (t.tpackage,tname) in try List.find (fun t -> not (t_private t) && t_path t = tpath) m.mtypes @@ -108,7 +113,7 @@ let rec load_instance ctx t p allow_no_params = if t.tparams <> [] then error ("Class type parameter " ^ t.tname ^ " can't have parameters") p; pt with Not_found -> - let types , path , f = ctx.api.build_instance (load_type_def ctx p t) p in + let types , path , f = ctx.g.do_build_instance ctx (load_type_def ctx p t) p in if allow_no_params && t.tparams = [] then f (List.map (fun (name,t) -> match follow t with @@ -269,7 +274,7 @@ let t_iterator ctx = *) let load_type_opt ?(opt=false) ctx p t = let t = (match t with None -> mk_mono() | Some t -> load_complex_type ctx p t) in - if opt then ctx.api.tnull t else t + if opt then ctx.t.tnull t else t (* ---------------------------------------------------------------------- *) (* Structure check *) @@ -461,7 +466,7 @@ let set_heritance ctx c herits p = | HImplements t -> HImplements (resolve_imports t) | h -> h ) herits in - List.iter loop (List.filter ((!build_inheritance) ctx c p) herits) + List.iter loop (List.filter (ctx.g.do_inherit ctx c p) herits) let type_type_params ctx path p (n,flags) = let c = mk_class (fst path @ [snd path],n) p in @@ -485,7 +490,7 @@ let type_function ctx args ret static constr f p = | None -> None | Some e -> let p = pos e in - let e = ctx.api.optimize (type_expr ctx e true) in + let e = ctx.g.do_optimize ctx (type_expr ctx e true) in unify ctx e.etype t p; match e.eexpr with | TConst c -> Some c @@ -513,7 +518,7 @@ let type_function ctx args ret static constr f p = if have_ret then (try return_flow ctx e with Exit -> ()) else - unify ctx ret ctx.api.tvoid p; + unify ctx ret ctx.t.tvoid p; let rec loop e = match e.eexpr with | TCall ({ eexpr = TConst TSuper },_) -> raise Exit @@ -573,7 +578,7 @@ let init_core_api ctx c = | None -> let com2 = Common.clone ctx.com in com2.class_path <- ctx.com.std_path; - let ctx2 = (!do_create) com2 in + let ctx2 = ctx.g.do_create com2 in ctx.g.core_api <- Some ctx2; ctx2 | Some c -> @@ -608,7 +613,7 @@ let init_core_api ctx c = (match follow f.cf_type, follow f2.cf_type with | TFun (pl1,_), TFun (pl2,_) -> if List.length pl1 != List.length pl2 then assert false; - List.iter2 (fun (n1,_,_) (n2,_,_) -> + List.iter2 (fun (n1,_,_) (n2,_,_) -> if n1 <> n2 then error ("Method parameter name '" ^ n2 ^ "' should be '" ^ n1 ^ "'") p; ) pl1 pl2; | _ -> ()); @@ -732,13 +737,21 @@ let init_class ctx c p herits fields meta = if inline && c.cl_interface then error "You can't declare inline methods in interfaces" p; let is_macro = (is_macro && stat) || has_meta ":macro" meta in if is_macro && not stat then error "Only static methods can be macros" p; - let f = if not is_macro then f else begin + let f = if not is_macro then + f + else if in_macro then let texpr = CTPath { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None } in - { f with + { + f_type = (match f.f_type with None -> Some texpr | t -> t); f_args = List.map (fun (a,o,t,e) -> a,o,(match t with None -> Some texpr | _ -> t),e) f.f_args; - f_expr = if in_macro then f.f_expr else (EReturn (Some (EConst (Ident "null"),p)),p); + f_expr = f.f_expr; } - end in + else { + f_type = None; + f_args = []; + f_expr = (EBlock [],p) + } + in let parent = (if not stat then get_parent c name else None) in let dynamic = List.mem ADynamic access || (match parent with Some { cf_kind = Method MethDynamic } -> true | _ -> false) in if inline && dynamic then error "You can't have both 'inline' and 'dynamic'" p; @@ -1011,7 +1024,7 @@ let type_module ctx m tdecls loadp = let ctx = { com = ctx.com; g = ctx.g; - api = ctx.api; + t = ctx.t; curclass = ctx.curclass; tthis = ctx.tthis; ret = ctx.ret; @@ -1065,7 +1078,7 @@ let type_module ctx m tdecls loadp = | EImport t -> (match t.tsub with | None -> - let md = ctx.api.load_module (t.tpackage,t.tname) p in + let md = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in let types = List.filter (fun t -> not (t_private t)) md.mtypes in ctx.local_types <- ctx.local_types @ types | Some _ -> @@ -1075,7 +1088,7 @@ let type_module ctx m tdecls loadp = | EUsing t -> (match t.tsub with | None -> - let md = ctx.api.load_module (t.tpackage,t.tname) p in + let md = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in let types = List.filter (fun t -> not (t_private t)) md.mtypes in ctx.local_using <- ctx.local_using @ (List.map (resolve_typedef ctx) types); | Some _ -> @@ -1090,6 +1103,22 @@ let type_module ctx m tdecls loadp = let et = TEnum (e,List.map snd e.e_types) in let names = ref [] in let index = ref 0 in + let rec loop = function + | (":build",[EConst (String s),p]) :: _ -> + (match apply_macro ctx s [] p with + | None -> error "Enum build failure" p + | Some (EArrayDecl el,_) -> + List.map (fun (e,p) -> + match e with + | EConst (Ident i) | EConst (Type i) -> i, None, [], [], p + | _ -> error "Invalid constructor" p + ) el + | _ -> error "Build macro must return an array" p + ) + | _ :: l -> loop l + | [] -> [] + in + let extra = loop d.d_meta in List.iter (fun (c,doc,meta,t,p) -> if c = "name" && Common.defined ctx.com "js" then error "This identifier cannot be used in Javascript" p; let t = (match t with @@ -1113,7 +1142,7 @@ let type_module ctx m tdecls loadp = } e.e_constrs; incr index; names := c :: !names; - ) d.d_data; + ) (d.d_data @ extra); e.e_names <- List.rev !names; | ETypedef d -> let t = get_tdef d.d_name in @@ -1200,8 +1229,11 @@ let load_module ctx m p = with Not_found -> let rec loop = function | [] -> raise (Error (Module_not_found m,p)) - | load :: l -> try snd (load m p) with Not_found -> loop l + | load :: l -> + match load m p with + | None -> loop l + | Some (_,a) -> a in - loop ctx.api.load_extern_type + loop ctx.com.load_extern_type ) in type_module ctx m decls p diff --git a/typer.ml b/typer.ml index 7d144c456bc..7473d44cebe 100644 --- a/typer.ml +++ b/typer.ml @@ -98,7 +98,6 @@ let classify t = | _ -> KOther let type_field_rec = ref (fun _ _ _ _ _ -> assert false) -let type_macro_rec = ref (fun _ _ _ _ -> assert false) (* ---------------------------------------------------------------------- *) (* PASS 3 : type expression & check structure *) @@ -372,8 +371,8 @@ let field_access ctx mode f t e p = else AKExpr (make_call ctx (mk (TField (e,m)) (tfun [] t) p) [] t p) | AccResolve -> - let fstring = mk (TConst (TString f.cf_name)) ctx.api.tstring p in - let tresolve = tfun [ctx.api.tstring] t in + let fstring = mk (TConst (TString f.cf_name)) ctx.t.tstring p in + let tresolve = tfun [ctx.t.tstring] t in AKExpr (make_call ctx (mk (TField (e,"resolve")) tresolve p) [fstring] t p) | AccNever -> AKNo f.cf_name @@ -407,12 +406,12 @@ let type_ident ctx i is_type p mode = match i with | "true" -> if mode = MGet then - AKExpr (mk (TConst (TBool true)) ctx.api.tbool p) + AKExpr (mk (TConst (TBool true)) ctx.t.tbool p) else AKNo i | "false" -> if mode = MGet then - AKExpr (mk (TConst (TBool false)) ctx.api.tbool p) + AKExpr (mk (TConst (TBool false)) ctx.t.tbool p) else AKNo i | "this" -> @@ -544,7 +543,7 @@ let rec type_field ctx e i p mode = | Some t -> let t = apply_params c.cl_types params t in if mode = MGet && PMap.mem "resolve" c.cl_fields then - AKExpr (make_call ctx (mk (TField (e,"resolve")) (tfun [ctx.api.tstring] t) p) [Typeload.type_constant ctx (String i) p] t p) + AKExpr (make_call ctx (mk (TField (e,"resolve")) (tfun [ctx.t.tstring] t) p) [Typeload.type_constant ctx (String i) p] t p) else AKExpr (mk (TField (e,i)) t p) | None -> @@ -653,10 +652,10 @@ let unify_int ctx e k = in match k with | KUnk | KDyn when maybe_dynamic_mono() -> - unify ctx e.etype ctx.api.tfloat e.epos; + unify ctx e.etype ctx.t.tfloat e.epos; false | _ -> - unify ctx e.etype ctx.api.tint e.epos; + unify ctx e.etype ctx.t.tint e.epos; true let rec type_binop ctx op e1 e2 p = @@ -700,7 +699,7 @@ let rec type_binop ctx op e1 e2 p = unify ctx get.etype t p; l(); mk (TBlock [ - mk (TVars [v,e.etype,Some e]) ctx.api.tvoid p; + mk (TVars [v,e.etype,Some e]) ctx.t.tvoid p; make_call ctx (mk (TField (ev,m)) (tfun [t] t) p) [get] t p ]) t p | AKInline _ | AKUsing _ | AKMacro _ -> @@ -708,24 +707,26 @@ let rec type_binop ctx op e1 e2 p = | _ -> let e1 = type_expr ctx e1 in let e2 = type_expr ctx e2 in + let tint = ctx.t.tint in + let tfloat = ctx.t.tfloat in let mk_op t = mk (TBinop (op,e1,e2)) t p in match op with | OpAdd -> mk_op (match classify e1.etype, classify e2.etype with | KInt , KInt -> - ctx.api.tint + tint | KFloat , KInt | KInt, KFloat | KFloat, KFloat -> - ctx.api.tfloat + tfloat | KUnk , KInt -> - if unify_int ctx e1 KUnk then ctx.api.tint else ctx.api.tfloat + if unify_int ctx e1 KUnk then tint else tfloat | KUnk , KFloat | KUnk , KString -> unify ctx e1.etype e2.etype e1.epos; e1.etype | KInt , KUnk -> - if unify_int ctx e2 KUnk then ctx.api.tint else ctx.api.tfloat + if unify_int ctx e2 KUnk then tint else tfloat | KFloat , KUnk | KString , KUnk -> unify ctx e2.etype e1.etype e2.epos; @@ -739,13 +740,13 @@ let rec type_binop ctx op e1 e2 p = | KUnk , KUnk -> let ok1 = unify_int ctx e1 KUnk in let ok2 = unify_int ctx e2 KUnk in - if ok1 && ok2 then ctx.api.tint else ctx.api.tfloat + if ok1 && ok2 then tint else tfloat | KParam t1, KParam t2 when t1 == t2 -> t1 | KParam t, KInt | KInt, KParam t -> t | KParam _, KFloat | KFloat, KParam _ | KParam _, KParam _ -> - ctx.api.tfloat + tfloat | KParam _, _ | _, KParam _ | KOther, _ @@ -759,7 +760,7 @@ let rec type_binop ctx op e1 e2 p = | OpShl | OpShr | OpUShr -> - let i = ctx.api.tint in + let i = tint in unify ctx e1.etype i e1.epos; unify ctx e2.etype i e2.epos; mk_op i @@ -767,28 +768,28 @@ let rec type_binop ctx op e1 e2 p = | OpMult | OpDiv | OpSub -> - let result = ref (if op = OpDiv then ctx.api.tfloat else ctx.api.tint) in + let result = ref (if op = OpDiv then tfloat else tint) in (match classify e1.etype, classify e2.etype with | KFloat, KFloat -> - result := ctx.api.tfloat + result := tfloat | KParam t1, KParam t2 when t1 == t2 -> if op <> OpDiv then result := t1 | KParam _, KParam _ -> - result := ctx.api.tfloat + result := tfloat | KParam t, KInt | KInt, KParam t -> if op <> OpDiv then result := t | KParam _, KFloat | KFloat, KParam _ -> - result := ctx.api.tfloat + result := tfloat | KFloat, k -> ignore(unify_int ctx e2 k); - result := ctx.api.tfloat + result := tfloat | k, KFloat -> ignore(unify_int ctx e1 k); - result := ctx.api.tfloat + result := tfloat | k1 , k2 -> let ok1 = unify_int ctx e1 k1 in let ok2 = unify_int ctx e2 k2 in - if not ok1 || not ok2 then result := ctx.api.tfloat; + if not ok1 || not ok2 then result := tfloat; ); mk_op !result | OpEq @@ -797,7 +798,7 @@ let rec type_binop ctx op e1 e2 p = unify_raise ctx e1.etype e2.etype p with Error (Unify _,_) -> unify ctx e2.etype e1.etype p); - mk_op ctx.api.tbool + mk_op ctx.t.tbool | OpGt | OpGte | OpLt @@ -828,18 +829,17 @@ let rec type_binop ctx op e1 e2 p = let pr = print_context() in error ("Cannot compare " ^ s_type pr e1.etype ^ " and " ^ s_type pr e2.etype) p ); - mk_op ctx.api.tbool + mk_op ctx.t.tbool | OpBoolAnd | OpBoolOr -> - let b = ctx.api.tbool in + let b = ctx.t.tbool in unify ctx e1.etype b p; unify ctx e2.etype b p; mk_op b | OpInterval -> - let i = ctx.api.tint in let t = Typeload.load_core_type ctx "IntIter" in - unify ctx e1.etype i e1.epos; - unify ctx e2.etype i e2.epos; + unify ctx e1.etype tint e1.epos; + unify ctx e2.etype tint e2.epos; mk (TNew ((match t with TInst (c,[]) -> c | _ -> assert false),[],[e1;e2])) t p | OpAssign | OpAssignOp _ -> @@ -851,20 +851,20 @@ and type_unop ctx op flag e p = let access e = let t = (match op with | Not -> - unify ctx e.etype ctx.api.tbool e.epos; - ctx.api.tbool + unify ctx e.etype ctx.t.tbool e.epos; + ctx.t.tbool | Increment | Decrement | Neg | NegBits -> if set then check_assign ctx e; (match classify e.etype with - | KFloat -> ctx.api.tfloat + | KFloat -> ctx.t.tfloat | KParam t -> - unify ctx e.etype ctx.api.tfloat e.epos; + unify ctx e.etype ctx.t.tfloat e.epos; t | k -> - if unify_int ctx e k then ctx.api.tint else ctx.api.tfloat) + if unify_int ctx e k then ctx.t.tint else ctx.t.tfloat) ) in match op, e.eexpr with | Neg , TConst (TInt i) -> mk (TConst (TInt (Int32.neg i))) t p @@ -891,7 +891,7 @@ and type_unop ctx op flag e p = unify ctx get.etype t p; l(); mk (TBlock [ - mk (TVars [v,e.etype,Some e]) ctx.api.tvoid p; + mk (TVars [v,e.etype,Some e]) ctx.t.tvoid p; make_call ctx (mk (TField (ev,m)) (tfun [t] t) p) [get] t p ]) t p | Postfix -> @@ -902,14 +902,14 @@ and type_unop ctx op flag e p = unify ctx get.etype t p; l(); mk (TBlock [ - mk (TVars [v,e.etype,Some e; v2,t,Some get]) ctx.api.tvoid p; + mk (TVars [v,e.etype,Some e; v2,t,Some get]) ctx.t.tvoid p; make_call ctx (mk (TField (ev,m)) (tfun [plusone.etype] t) p) [plusone] t p; ev2 ]) t p and type_switch ctx e cases def need_val p = let e = type_expr ctx e in - let t = ref (if need_val then mk_mono() else ctx.api.tvoid) in + let t = ref (if need_val then mk_mono() else ctx.t.tvoid) in let rec lookup_enum l = match l with | [] -> None @@ -944,13 +944,13 @@ and type_switch ctx e cases def need_val p = if need_val then begin try (match e.eexpr with - | TBlock [{ eexpr = TConst TNull }] -> t := ctx.api.tnull !t; + | TBlock [{ eexpr = TConst TNull }] -> t := ctx.t.tnull !t; | _ -> ()); unify_raise ctx e.etype (!t) e.epos; - if is_null e.etype then t := ctx.api.tnull !t; + if is_null e.etype then t := ctx.t.tnull !t; with Error (Unify _,_) -> try unify_raise ctx (!t) e.etype e.epos; - t := if is_null !t then ctx.api.tnull e.etype else e.etype; + t := if is_null !t then ctx.t.tnull e.etype else e.etype; with Error (Unify _,_) -> (* will display the error *) unify ctx e.etype (!t) e.epos; @@ -985,7 +985,7 @@ and type_switch ctx e cases def need_val p = ) el in if el = [] then error "Case must match at least one expression" (pos e2); let e2 = (match fst e2 with - | EBlock [] -> mk (TConst TNull) ctx.api.tvoid (pos e2) + | EBlock [] -> mk (TConst TNull) ctx.t.tvoid (pos e2) | _ -> type_expr ctx ~need_val e2 ) in locals(); @@ -1134,7 +1134,7 @@ and type_access ctx e p mode = | EArray (e1,e2) -> let e1 = type_expr ctx e1 in let e2 = type_expr ctx e2 in - unify ctx e2.etype ctx.api.tint e2.epos; + unify ctx e2.etype ctx.t.tint e2.epos; let rec loop et = match follow et with | TInst ({ cl_array_access = Some t; cl_types = pl },tl) -> @@ -1145,7 +1145,7 @@ and type_access ctx e p mode = t | _ -> let pt = mk_mono() in - let t = ctx.api.tarray pt in + let t = ctx.t.tarray pt in unify ctx e1.etype t e1.epos; pt in @@ -1158,7 +1158,7 @@ and type_expr ctx ?(need_val=true) (e,p) = match e with | EField ((EConst (String s),p),"code") -> if UTF8.length s <> 1 then error "String must be a single UTF8 char" p; - mk (TConst (TInt (Int32.of_int (UChar.code (UTF8.get s 0))))) ctx.api.tint p + mk (TConst (TInt (Int32.of_int (UChar.code (UTF8.get s 0))))) ctx.t.tint p | EField _ | EType _ | EArray _ @@ -1166,8 +1166,8 @@ and type_expr ctx ?(need_val=true) (e,p) = | EConst (Type _) -> acc_get ctx (type_access ctx e p MGet) p | EConst (Regexp (r,opt)) -> - let str = mk (TConst (TString r)) ctx.api.tstring p in - let opt = mk (TConst (TString opt)) ctx.api.tstring p in + let str = mk (TConst (TString r)) ctx.t.tstring p in + let opt = mk (TConst (TString opt)) ctx.t.tstring p in let t = Typeload.load_core_type ctx "EReg" in mk (TNew ((match t with TInst (c,[]) -> c | _ -> assert false),[],[str;opt])) t p | EConst c -> @@ -1195,7 +1195,7 @@ and type_expr ctx ?(need_val=true) (e,p) = let l = loop l in locals(); let rec loop = function - | [] -> ctx.api.tvoid + | [] -> ctx.t.tvoid | [e] -> e.etype | _ :: l -> loop l in @@ -1222,7 +1222,7 @@ and type_expr ctx ?(need_val=true) (e,p) = (match e.eexpr with | TConst TNull when not !is_null -> is_null := true; - t := ctx.api.tnull !t; + t := ctx.t.tnull !t; | _ -> ()); (try unify_raise ctx e.etype (!t) e.epos; @@ -1233,7 +1233,7 @@ and type_expr ctx ?(need_val=true) (e,p) = t := t_dynamic); e ) el in - mk (TArrayDecl el) (ctx.api.tarray !t) p + mk (TArrayDecl el) (ctx.t.tarray !t) p | EVars vl -> let vl = List.map (fun (v,t,e) -> try @@ -1254,7 +1254,7 @@ and type_expr ctx ?(need_val=true) (e,p) = let v = add_local ctx v t in v , t, None ) vl in - mk (TVars vl) ctx.api.tvoid p + mk (TVars vl) ctx.t.tvoid p | EFor (i,e1,e2) -> let e1 = type_expr ctx e1 in let old_loop = ctx.in_loop in @@ -1286,7 +1286,7 @@ and type_expr ctx ?(need_val=true) (e,p) = ) ) in let e2 = type_expr ~need_val:false ctx e2 in - mk (TFor (i,pt,e1,e2)) ctx.api.tvoid p + mk (TFor (i,pt,e1,e2)) ctx.t.tvoid p ) in ctx.in_loop <- old_loop; old_locals(); @@ -1295,52 +1295,52 @@ and type_expr ctx ?(need_val=true) (e,p) = type_expr ctx ~need_val (EIf (e1,e2,Some e3),p) | EIf (e,e1,e2) -> let e = type_expr ctx e in - unify ctx e.etype ctx.api.tbool e.epos; + unify ctx e.etype ctx.t.tbool e.epos; let e1 = type_expr ctx ~need_val e1 in (match e2 with | None -> if need_val then begin - let t = ctx.api.tnull e1.etype in + let t = ctx.t.tnull e1.etype in mk (TIf (e,e1,Some (null t p))) t p end else - mk (TIf (e,e1,None)) ctx.api.tvoid p + mk (TIf (e,e1,None)) ctx.t.tvoid p | Some e2 -> let e2 = type_expr ctx ~need_val e2 in - let t = if not need_val then ctx.api.tvoid else (try + let t = if not need_val then ctx.t.tvoid else (try (match e1.eexpr, e2.eexpr with - | _ , TConst TNull -> ctx.api.tnull e1.etype - | TConst TNull, _ -> ctx.api.tnull e2.etype + | _ , TConst TNull -> ctx.t.tnull e1.etype + | TConst TNull, _ -> ctx.t.tnull e2.etype | _ -> unify_raise ctx e1.etype e2.etype p; - if is_null e1.etype then ctx.api.tnull e2.etype else e2.etype) + if is_null e1.etype then ctx.t.tnull e2.etype else e2.etype) with Error (Unify _,_) -> unify ctx e2.etype e1.etype p; - if is_null e2.etype then ctx.api.tnull e1.etype else e1.etype + if is_null e2.etype then ctx.t.tnull e1.etype else e1.etype ) in mk (TIf (e,e1,Some e2)) t p) | EWhile (cond,e,NormalWhile) -> let old_loop = ctx.in_loop in let cond = type_expr ctx cond in - unify ctx cond.etype ctx.api.tbool cond.epos; + unify ctx cond.etype ctx.t.tbool cond.epos; ctx.in_loop <- true; let e = type_expr ~need_val:false ctx e in ctx.in_loop <- old_loop; - mk (TWhile (cond,e,NormalWhile)) ctx.api.tvoid p + mk (TWhile (cond,e,NormalWhile)) ctx.t.tvoid p | EWhile (cond,e,DoWhile) -> let old_loop = ctx.in_loop in ctx.in_loop <- true; let e = type_expr ~need_val:false ctx e in ctx.in_loop <- old_loop; let cond = type_expr ctx cond in - unify ctx cond.etype ctx.api.tbool cond.epos; - mk (TWhile (cond,e,DoWhile)) ctx.api.tvoid p + unify ctx cond.etype ctx.t.tbool cond.epos; + mk (TWhile (cond,e,DoWhile)) ctx.t.tvoid p | ESwitch (e,cases,def) -> type_switch ctx e cases def need_val p | EReturn e -> let e , t = (match e with | None -> - let v = ctx.api.tvoid in + let v = ctx.t.tvoid in unify ctx v ctx.ret p; None , v | Some e -> @@ -1378,7 +1378,7 @@ and type_expr ctx ?(need_val=true) (e,p) = if PMap.mem name ctx.locals then error ("Local variable " ^ name ^ " is preventing usage of this type here") e.epos; v , t , e ) catches in - mk (TTry (e1,catches)) (if not need_val then ctx.api.tvoid else e1.etype) p + mk (TTry (e1,catches)) (if not need_val then ctx.t.tvoid else e1.etype) p | EThrow e -> let e = type_expr ctx e in mk (TThrow e) (mk_mono()) p @@ -1544,7 +1544,7 @@ and type_call ctx e el p = match e, el with | (EConst (Ident "trace"),p) , e :: el -> if Common.defined ctx.com "no_traces" then - null ctx.api.tvoid p + null ctx.t.tvoid p else let params = (match el with [] -> [] | _ -> ["customParams",(EArrayDecl el , p)]) in let infos = mk_infos ctx p params in @@ -1606,7 +1606,7 @@ and type_call ctx e el p = ) in el , TInst (c,params) ) in - mk (TCall (mk (TConst TSuper) t sp,el)) ctx.api.tvoid p + mk (TCall (mk (TConst TSuper) t sp,el)) ctx.t.tvoid p | _ -> (match e with | EField ((EConst (Ident "super"),_),_) , _ | EType ((EConst (Ident "super"),_),_) , _ -> ctx.in_super_call <- true @@ -1628,28 +1628,9 @@ and type_call ctx e el p = | AKMacro (ethis,f) -> (match ethis.eexpr with | TTypeExpr (TClassDecl c) -> - let expr = Typeload.load_instance ctx { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None} p false in - let nargs = (match follow f.cf_type with - | TFun (args,ret) -> - unify ctx ret expr p; - (match args with - | [(_,_,t)] -> - (try - unify_raise ctx t expr p; - Some 1 - with Error (Unify _,_) -> - unify ctx t (ctx.api.tarray expr) p; - None) - | _ -> - List.iter (fun (_,_,t) -> unify ctx t expr p) args; - Some (List.length args)) - | _ -> - assert false - ) in - (match nargs with - | Some n -> if List.length el <> n then error ("This macro requires " ^ string_of_int n ^ " arguments") p - | None -> ()); - (!type_macro_rec) ctx c f.cf_name el (nargs = None) p + (match ctx.g.do_macro ctx c.cl_path f.cf_name el p with + | None -> type_expr ctx (EConst (Ident "null"),p) + | Some e -> type_expr ctx e) | _ -> assert false) | acc -> let e = acc_get ctx acc p in @@ -1685,30 +1666,14 @@ let rec finalize ctx = List.iter (fun f -> f()) l; finalize ctx -let get_type_module ctx t = - let mfound = ref ctx.current in - try - Hashtbl.iter (fun _ m -> - if List.mem t m.mtypes then begin - mfound := m; - raise Exit; - end; - ) ctx.g.modules; - (* @Main, other generated classes ? *) - { - mtypes = [t]; - mpath = t_path t; - } - with - Exit -> !mfound - type state = | Generating | Done | NotYet -let types ctx main excludes = +let generate ctx main excludes = let types = ref [] in + let modules = ref [] in let states = Hashtbl.create 0 in let state p = try Hashtbl.find states p with Not_found -> NotYet in let statics = ref PMap.empty in @@ -1721,7 +1686,7 @@ let types ctx main excludes = prerr_endline ("Warning : maybe loop in static generation of " ^ s_type_path p); | NotYet -> Hashtbl.add states p Generating; - ctx.api.on_generate t; + ctx.g.do_generate ctx t; let t = (match t with | TClassDecl c -> walk_class p c; @@ -1804,7 +1769,7 @@ let types ctx main excludes = ) c.cl_statics in - Hashtbl.iter (fun _ m -> List.iter loop m.mtypes) ctx.g.modules; + Hashtbl.iter (fun _ m -> modules := m :: !modules; List.iter loop m.mtypes) ctx.g.modules; (match main with | None -> () | Some cl -> @@ -1839,19 +1804,116 @@ let types ctx main excludes = c.cl_ordered_statics <- f :: c.cl_ordered_statics; types := TClassDecl c :: !types ); - List.rev !types + List.rev !types, List.rev !modules + +(* ---------------------------------------------------------------------- *) +(* MACROS *) + +let type_macro ctx cpath f el p = + let t = Common.timer "macro execution" in + let ctx2 = (match ctx.g.macros with + | Some (select,ctx) -> + select(); + ctx + | None -> + let com2 = Common.clone ctx.com in + com2.package_rules <- PMap.empty; + com2.main_class <- None; + List.iter (fun p -> com2.defines <- PMap.remove (platform_name p) com2.defines) platforms; + com2.class_path <- List.filter (fun s -> not (ExtString.String.exists s "/_std/")) com2.class_path; + com2.class_path <- List.map (fun p -> p ^ "neko" ^ "/_std/") com2.std_path @ com2.class_path; + Common.define com2 "macro"; + Common.init_platform com2 Neko; + let ctx2 = ctx.g.do_create com2 in + let mctx = Interp.create com2 in + let on_error = com2.error in + com2.error <- (fun e p -> Interp.set_error mctx true; on_error e p); + let macro = ((fun() -> Interp.select mctx), ctx2) in + ctx.g.macros <- Some macro; + ctx2.g.macros <- Some macro; + (* ctx2.g.core_api <- ctx.g.core_api; // causes some issues because of optional args and Null type in Flash9 *) + ignore(Typeload.load_module ctx2 (["haxe";"macro"],"Expr") p); + finalize ctx2; + let types, _ = generate ctx2 None [] in + Interp.add_types mctx types; + Interp.init mctx; + ctx2 + ) in + let mctx = Interp.get_ctx() in + let m = (try Hashtbl.find ctx.g.types_module cpath with Not_found -> cpath) in + ignore(Typeload.load_module ctx2 m p); + let meth = (match Typeload.load_instance ctx2 { tpackage = fst cpath; tname = snd cpath; tparams = []; tsub = None } p true with + | TInst (c,_) -> (try PMap.find f c.cl_statics with Not_found -> error ("Method " ^ f ^ " not found on class " ^ s_type_path cpath) p) + | _ -> error "Macro should be called on a class" p + ) in + let expr = Typeload.load_instance ctx2 { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None} p false in + let nargs = (match follow meth.cf_type with + | TFun (args,ret) -> + unify ctx2 ret expr p; + (match args with + | [(_,_,t)] -> + (try + unify_raise ctx2 t expr p; + Some 1 + with Error (Unify _,_) -> + unify ctx2 t (ctx2.t.tarray expr) p; + None) + | _ -> + List.iter (fun (_,_,t) -> unify ctx2 t expr p) args; + Some (List.length args)) + | _ -> + assert false + ) in + (match nargs with + | Some n -> if List.length el <> n then error ("This macro requires " ^ string_of_int n ^ " arguments") p + | None -> ()); + let call() = + let el = List.map Interp.encode_expr el in + match Interp.call_path mctx ((fst cpath) @ [snd cpath]) f (if nargs = None then [Interp.enc_array el] else el) p with + | None -> None + | Some v -> Some (try Interp.decode_expr v with Interp.Invalid_expr -> error "The macro didn't return a valid expression" p) + in + let e = (if Common.defined ctx.com "macro" then begin + (* + this is super-tricky : we can't evaluate a macro inside a macro because we might trigger some cycles. + So instead, we generate a haxe.macro.Context.delayedCalled(i) expression that will only evaluate the + macro if/when it is called. + + The tricky part is that the whole delayed-evaluation process has to use the same contextual informations + as if it was evaluated now. + *) + let ctx = { + ctx with locals = ctx.locals; + } in + let pos = Interp.alloc_delayed mctx (fun() -> + (* remove $delay_call calls from the stack *) + Interp.unwind_stack mctx; + match call() with + | None -> raise Interp.Abort + | Some e -> Interp.eval mctx (Genneko.gen_expr mctx.Interp.gen (type_expr ctx e)) + ) in + let e = (EConst (Ident "__dollar__delay_call"),p) in + Some (EUntyped (ECall (e,[EConst (Int (string_of_int pos)),p]),p),p) + end else begin + finalize ctx2; + let types, _ = generate ctx2 None [] in + Interp.add_types mctx types; + call() + end) in + t(); + e (* ---------------------------------------------------------------------- *) (* TYPER INITIALIZATION *) -let create com = +let rec create com = let empty = { mpath = [] , ""; mtypes = []; } in let ctx = { com = com; - api = com.type_api; + t = com.basic; g = { core_api = None; macros = None; @@ -1862,6 +1924,13 @@ let create com = doinline = not (Common.defined com "no_inline"); hook_generate = []; std = empty; + do_inherit = Codegen.on_inherit; + do_create = create; + do_macro = type_macro; + do_load_module = Typeload.load_module; + do_generate = Codegen.on_generate; + do_optimize = Optimizer.reduce_expression; + do_build_instance = Codegen.build_instance; }; untyped = false; in_constructor = false; @@ -1883,11 +1952,6 @@ let create com = opened = []; param_type = None; } in - ctx.api.load_module <- Typeload.load_module ctx; - ctx.api.build_instance <- Codegen.build_instance ctx; - ctx.api.on_generate <- Codegen.on_generate ctx; - ctx.api.get_type_module <- get_type_module ctx; - ctx.api.optimize <- Optimizer.reduce_expression ctx; ctx.g.std <- (try Typeload.load_module ctx ([],"StdTypes") null_pos with @@ -1897,106 +1961,31 @@ let create com = match t with | TEnumDecl e -> (match snd e.e_path with - | "Void" -> ctx.api.tvoid <- TEnum (e,[]) - | "Bool" -> ctx.api.tbool <- TEnum (e,[]) + | "Void" -> ctx.t.tvoid <- TEnum (e,[]) + | "Bool" -> ctx.t.tbool <- TEnum (e,[]) | _ -> ()) | TClassDecl c -> (match snd c.cl_path with - | "Float" -> ctx.api.tfloat <- TInst (c,[]) - | "Int" -> ctx.api.tint <- TInst (c,[]) + | "Float" -> ctx.t.tfloat <- TInst (c,[]) + | "Int" -> ctx.t.tint <- TInst (c,[]) | _ -> ()) | TTypeDecl td -> (match snd td.t_path with | "Null" -> let f9 = platform com Flash9 in let cpp = platform com Cpp in - ctx.api.tnull <- if not (f9 || cpp) then (fun t -> t) else (fun t -> if is_nullable t then TType (td,[t]) else t); + ctx.t.tnull <- if not (f9 || cpp) then (fun t -> t) else (fun t -> if is_nullable t then TType (td,[t]) else t); | _ -> ()); ) ctx.g.std.mtypes; let m = Typeload.load_module ctx ([],"String") null_pos in (match m.mtypes with - | [TClassDecl c] -> ctx.api.tstring <- TInst (c,[]) + | [TClassDecl c] -> ctx.t.tstring <- TInst (c,[]) | _ -> assert false); let m = Typeload.load_module ctx ([],"Array") null_pos in (match m.mtypes with - | [TClassDecl c] -> ctx.api.tarray <- (fun t -> TInst (c,[t])) + | [TClassDecl c] -> ctx.t.tarray <- (fun t -> TInst (c,[t])) | _ -> assert false); ctx -(* ---------------------------------------------------------------------- *) -(* MACROS *) - -let type_macro ctx c f el array p = - let t = Common.timer "macro execution" in - let ctx2 = (match ctx.g.macros with - | Some (select,ctx) -> - select(); - ctx - | None -> - let com2 = Common.clone ctx.com in - com2.package_rules <- PMap.empty; - List.iter (fun p -> com2.defines <- PMap.remove (platform_name p) com2.defines) platforms; - com2.class_path <- List.filter (fun s -> not (ExtString.String.exists s "/_std/")) com2.class_path; - com2.class_path <- List.map (fun p -> p ^ "neko" ^ "/_std/") com2.std_path @ com2.class_path; - Common.define com2 "macro"; - Common.init_platform com2 Neko; - let ctx2 = (!Typeload.do_create) com2 in - let mctx = Interp.create com2 in - let on_error = com2.error in - com2.error <- (fun e p -> Interp.set_error mctx true; on_error e p); - let macro = ((fun() -> Interp.select mctx), ctx2) in - ctx.g.macros <- Some macro; - ctx2.g.macros <- Some macro; - (* ctx2.g.core_api <- ctx.g.core_api; // causes some issues because of optional args and Null type in Flash9 *) - ignore(Typeload.load_module ctx2 (["haxe";"macro"],"Expr") p); - finalize ctx2; - let types = types ctx2 None [] in - Interp.add_types mctx types; - Interp.init mctx; - ctx2 - ) in - let mctx = Interp.get_ctx() in - let m = (try Hashtbl.find ctx.g.types_module c.cl_path with Not_found -> c.cl_path) in - ignore(Typeload.load_module ctx2 m p); - let call() = - let el = List.map Interp.encode_expr el in - match Interp.call_path mctx ((fst c.cl_path) @ [snd c.cl_path]) f (if array then [Interp.enc_array el] else el) p with - | None -> None - | Some v -> Some (try Interp.decode_expr v with Interp.Invalid_expr -> error "The macro didn't return a valid expression" p) - in - let e = (if Common.defined ctx.com "macro" then begin - (* - this is super-tricky : we can't evaluate a macro inside a macro because we might trigger some cycles. - So instead, we generate a haxe.macro.Context.delayedCalled(i) expression that will only evaluate the - macro if/when it is called. - - The tricky part is that the whole delayed-evaluation process has to use the same contextual informations - as if it was evaluated now. - *) - let ctx = { - ctx with locals = ctx.locals; - } in - let pos = Interp.alloc_delayed mctx (fun() -> - (* remove $delay_call calls from the stack *) - Interp.unwind_stack mctx; - match call() with - | None -> raise Interp.Abort - | Some e -> Interp.eval mctx (Genneko.gen_expr mctx.Interp.gen (type_expr ctx e)) - ) in - let e = (EConst (Ident "__dollar__delay_call"),p) in - (EUntyped (ECall (e,[EConst (Int (string_of_int pos)),p]),p),p) - end else begin - finalize ctx2; - let types = types ctx2 None [] in - Interp.add_types mctx types; - match call() with - | None -> (EConst (Ident "null"),p) - | Some e -> e - end) in - t(); - type_expr ctx e - ;; -Typeload.do_create := create; type_field_rec := type_field; -type_macro_rec := type_macro; \ No newline at end of file