haxe-3.0~svn6707/0000755000175000017500000000000012172015516014204 5ustar bdefreesebdefreesehaxe-3.0~svn6707/gencpp.ml0000644000175000017500000042463512172015135016025 0ustar bdefreesebdefreese(* * Copyright (C)2005-2013 Haxe Foundation * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. *) open Ast open Type open Common let unsupported p = error "This expression cannot be generated to Cpp" p (* Code for generating source files. It manages creating diretories, indents, blocks and only modifying files when the content changes. *) (* A class_path is made from a package (array of strings) and a class name. Join these together, inclding a separator. eg, "/" for includes : pack1/pack2/Name or "::" for namespace "pack1::pack2::Name" *) let join_class_path path separator = let result = match fst path, snd path with | [], s -> s | el, s -> String.concat separator el ^ separator ^ s in if (String.contains result '+') then begin let idx = String.index result '+' in (String.sub result 0 idx) ^ (String.sub result (idx+1) ((String.length result) - idx -1 ) ) end else result;; class source_writer write_func close_func= object(this) val indent_str = "\t" val mutable indent = "" val mutable indents = [] val mutable just_finished_block = false method close = close_func(); () method write x = write_func x; just_finished_block <- false method indent_one = this#write indent_str method push_indent = indents <- indent_str::indents; indent <- String.concat "" indents method pop_indent = match indents with | h::tail -> indents <- tail; indent <- String.concat "" indents | [] -> indent <- "/*?*/"; method write_i x = this#write (indent ^ x) method get_indent = indent method begin_block = this#write ("{\n"); this#push_indent method end_block = this#pop_indent; this#write_i "}\n"; just_finished_block <- true method end_block_line = this#pop_indent; this#write_i "}"; just_finished_block <- true method terminate_line = this#write (if just_finished_block then "" else ";\n") method add_include class_path = this#write ("#ifndef INCLUDED_" ^ (join_class_path class_path "_") ^ "\n"); this#write ("#include <" ^ (join_class_path class_path "/") ^ ".h>\n"); this#write ("#endif\n") end;; let file_source_writer filename = let out_file = open_out filename in new source_writer (output_string out_file) (fun ()-> close_out out_file);; let read_whole_file chan = Std.input_all chan;; (* The cached_source_writer will not write to the file if it has not changed, thus allowing the makefile dependencies to work correctly *) let cached_source_writer filename = try let in_file = open_in filename in let old_contents = read_whole_file in_file in close_in in_file; let buffer = Buffer.create 0 in let add_buf str = Buffer.add_string buffer str in let close = fun () -> let contents = Buffer.contents buffer in if (not (contents=old_contents) ) then begin let out_file = open_out filename in output_string out_file contents; close_out out_file; end; in new source_writer (add_buf) (close); with _ -> file_source_writer filename;; let rec make_class_directories base dir_list = ( match dir_list with | [] -> () | dir :: remaining -> let path = match base with | "" -> dir | "/" -> "/" ^ dir | _ -> base ^ "/" ^ dir in if ( not ( (path="") || ( ((String.length path)=2) && ((String.sub path 1 1)=":") ) ) ) then if not (Sys.file_exists path) then Unix.mkdir path 0o755; make_class_directories (if (path="") then "/" else path) remaining );; let new_source_file base_dir sub_dir extension class_path = make_class_directories base_dir ( sub_dir :: (fst class_path)); cached_source_writer ( base_dir ^ "/" ^ sub_dir ^ "/" ^ ( String.concat "/" (fst class_path) ) ^ "/" ^ (snd class_path) ^ extension);; let new_cpp_file base_dir = new_source_file base_dir "src" ".cpp";; let new_header_file base_dir = new_source_file base_dir "include" ".h";; let make_base_directory file = make_class_directories "" ( ( Str.split_delim (Str.regexp "[\\/]+") file ) ); (* CPP code generation context *) type context = { mutable ctx_common : Common.context; mutable ctx_output : string -> unit; mutable ctx_dbgout : string -> unit; mutable ctx_writer : source_writer; mutable ctx_calling : bool; mutable ctx_assigning : bool; mutable ctx_return_from_block : bool; mutable ctx_tcall_expand_args : bool; (* This is for returning from the child nodes of TMatch, TSwitch && TTry *) mutable ctx_return_from_internal_node : bool; mutable ctx_debug : bool; mutable ctx_debug_type : bool; mutable ctx_real_this_ptr : bool; mutable ctx_dynamic_this_ptr : bool; mutable ctx_dump_src_pos : unit -> unit; mutable ctx_dump_stack_line : bool; mutable ctx_static_id_curr : int; mutable ctx_static_id_used : int; mutable ctx_static_id_depth : int; mutable ctx_switch_id : int; mutable ctx_class_name : string; mutable ctx_class_super_name : string; mutable ctx_local_function_args : (string,string) Hashtbl.t; mutable ctx_local_return_block_args : (string,string) Hashtbl.t; mutable ctx_class_member_types : (string,string) Hashtbl.t; mutable ctx_file_info : (string,string) PMap.t ref; mutable ctx_for_extern : bool; } let new_context common_ctx writer debug file_info = { ctx_common = common_ctx; ctx_writer = writer; ctx_output = (writer#write); ctx_dbgout = if debug then (writer#write) else (fun _ -> ()); ctx_calling = false; ctx_assigning = false; ctx_debug = debug; ctx_debug_type = debug; ctx_dump_src_pos = (fun() -> ()); ctx_dump_stack_line = true; ctx_return_from_block = false; ctx_tcall_expand_args = false; ctx_return_from_internal_node = false; ctx_real_this_ptr = true; ctx_dynamic_this_ptr = false; ctx_static_id_curr = 0; ctx_static_id_used = 0; ctx_static_id_depth = 0; ctx_switch_id = 0; ctx_class_name = ""; ctx_class_super_name = ""; ctx_local_function_args = Hashtbl.create 0; ctx_local_return_block_args = Hashtbl.create 0; ctx_class_member_types = Hashtbl.create 0; ctx_file_info = file_info; ctx_for_extern = false; } let new_extern_context common_ctx writer debug file_info = let ctx = new_context common_ctx writer debug file_info in ctx.ctx_for_extern <- true; ctx ;; (* The internal classes are implemented by the core hxcpp system, so the cpp classes should not be generated *) let is_internal_class = function | ([],"Int") | ([],"Void") | ([],"String") | ([], "Null") | ([], "Float") | ([],"Array") | ([], "Class") | ([], "Enum") | ([], "Bool") | ([], "Dynamic") | ([], "ArrayAccess") | (["cpp"], "FastIterator")-> true | (["cpp"], "CppInt32__") | ([],"Math") | (["haxe";"io"], "Unsigned_char__") -> true | _ -> false (* The internal header files are also defined in the hx/Object.h file, so you do #include them separately. However, the Int32 and Math classes do have their own header files (these are under the hxcpp tree) so these should be included *) let include_class_header = function | ([],"@Main") -> false | (["cpp"], "CppInt32__") | ([],"Math") -> true | path -> not ( is_internal_class path ) let is_cpp_class = function | ("cpp"::_ , _) -> true | ( [] , "Xml" ) -> true | ( [] , "EReg" ) -> true | ( ["haxe"] , "Log" ) -> true | _ -> false;; let is_scalar typename = match typename with | "int" | "unsigned int" | "signed int" | "char" | "unsigned char" | "short" | "unsigned short" | "float" | "double" | "bool" -> true | _ -> false ;; let is_block exp = match exp.eexpr with | TBlock _ -> true | _ -> false ;; let to_block expression = if is_block expression then expression else (mk_block expression);; (* todo - is this how it's done? *) let hash_keys hash = let key_list = ref [] in Hashtbl.iter (fun key value -> key_list := key :: !key_list ) hash; !key_list;; let pmap_keys pmap = let key_list = ref [] in PMap.iter (fun key value -> key_list := key :: !key_list ) pmap; !key_list;; (* The Hashtbl structure seems a little odd - but here is a helper function *) let hash_iterate hash visitor = let result = ref [] in Hashtbl.iter (fun key value -> result := (visitor key value) :: !result ) hash; !result (* Convert function names that can't be written in c++ ... *) let keyword_remap name = match name with | "int" | "auto" | "char" | "const" | "delete" | "double" | "Float" | "enum" | "extern" | "float" | "friend" | "goto" | "long" | "operator" | "protected" | "register" | "short" | "signed" | "sizeof" | "template" | "typedef" | "union" | "unsigned" | "void" | "volatile" | "or" | "and" | "xor" | "or_eq" | "not" | "and_eq" | "xor_eq" | "typeof" | "stdin" | "stdout" | "stderr" | "BIG_ENDIAN" | "LITTLE_ENDIAN" | "assert" | "NULL" | "wchar_t" | "EOF" | "bool" | "const_cast" | "dynamic_cast" | "explicit" | "export" | "mutable" | "namespace" | "reinterpret_cast" | "static_cast" | "typeid" | "typename" | "virtual" | "_Complex" | "struct" -> "_" ^ name | "asm" -> "_asm_" | x -> x ;; let remap_class_path class_path = (List.map keyword_remap (fst class_path)) , (snd class_path) ;; let join_class_path_remap path separator = join_class_path (remap_class_path path) separator ;; let get_meta_string meta key = let rec loop = function | [] -> "" | (k,[Ast.EConst (Ast.String name),_],_) :: _ when k=key-> name | _ :: l -> loop l in loop meta ;; let has_meta_key meta key = List.exists (fun m -> match m with | (k,_,_) when k=key-> true | _ -> false ) meta ;; let get_code meta key = let code = get_meta_string meta key in if (code<>"") then code ^ "\n" else code ;; (* Add include to source code *) let add_include writer class_path = writer#add_include class_path;; (* This gets the class include order correct. In the header files, we forward declare the class types so the header file does not have any undefined variables. In the cpp files, we include all the required header files, providing the actual types for everything. This way there is no problem with circular class references. *) let gen_forward_decl writer class_path = if ( class_path = (["cpp"],"CppInt32__")) then writer#add_include class_path else begin let output = writer#write in let name = fst (remap_class_path class_path) in output ("HX_DECLARE_CLASS" ^ (string_of_int (List.length name ) ) ^ "("); List.iter (fun package_part -> output (package_part ^ ",") ) name; output ( (snd class_path) ^ ")\n") end;; let real_interfaces = List.filter (function (t,pl) -> match t, pl with | { cl_path = ["cpp";"rtti"],_ },[] -> false | _ -> true );; let rec is_function_expr expr = match expr.eexpr with | TParenthesis expr -> is_function_expr expr | TCast (e,None) -> is_function_expr e | TFunction _ -> true | _ -> false;; let is_var_field field = match field.cf_kind with | Var _ -> true | Method MethDynamic -> true | _ -> false ;; let rec has_rtti_interface c interface = List.exists (function (t,pl) -> (snd t.cl_path) = interface && (match fst t.cl_path with | ["cpp";"rtti"] -> true | _ -> false ) ) c.cl_implements || (match c.cl_super with None -> false | Some (c,_) -> has_rtti_interface c interface);; let has_field_integer_lookup class_def = has_rtti_interface class_def "FieldIntegerLookup";; let has_field_integer_numeric_lookup class_def = has_rtti_interface class_def "FieldNumericIntegerLookup";; (* Output required code to place contents in required namespace *) let gen_open_namespace output class_path = List.iter (fun namespace -> output ("namespace " ^ namespace ^ "{\n")) (List.map keyword_remap (fst class_path));; let gen_close_namespace output class_path = List.iter (fun namespace -> output ( "}" ^ " // end namespace " ^ namespace ^"\n")) (fst class_path);; (* The basic types can have default values and are passesby value *) let is_numeric = function | "Int" | "Bool" | "Float" | "::haxe::io::Unsigned_char__" | "unsigned char" -> true | "int" | "bool" | "double" | "float" -> true | _ -> false let cant_be_null type_string = is_numeric type_string ;; let is_object type_string = not (is_numeric type_string || type_string="::String"); ;; (* Get a string to represent a type. The "suffix" will be nothing or "_obj", depending if we want the name of the pointer class or the pointee (_obj class *) let rec class_string klass suffix params = (match klass.cl_path with (* Array class *) | ([],"Array") when is_dynamic_array_param (List.hd params) -> "Dynamic" | ([],"Array") -> (snd klass.cl_path) ^ suffix ^ "< " ^ (String.concat "," (List.map array_element_type params) ) ^ " >" (* FastIterator class *) | (["cpp"],"FastIterator") -> "::cpp::FastIterator" ^ suffix ^ "< " ^ (String.concat "," (List.map type_string params) ) ^ " >" | _ when (match klass.cl_kind with KTypeParameter _ -> true | _ -> false) -> "Dynamic" | ([],"#Int") -> "/* # */int" | (["haxe";"io"],"Unsigned_char__") -> "unsigned char" | ([],"Class") -> "::Class" | ([],"EnumValue") -> "Dynamic" | ([],"Null") -> (match params with | [t] -> (match follow t with | TAbstract ({ a_path = [],"Int" },_) | TAbstract ({ a_path = [],"Float" },_) | TAbstract ({ a_path = [],"Bool" },_) | TInst ({ cl_path = [],"Int" },_) | TInst ({ cl_path = [],"Float" },_) | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic" | _ -> "/*NULL*/" ^ (type_string t) ) | _ -> assert false); (* Normal class *) | path when klass.cl_extern && (not (is_internal_class path) )-> (join_class_path_remap klass.cl_path "::") ^ suffix | _ -> "::" ^ (join_class_path_remap klass.cl_path "::") ^ suffix ) and type_string_suff suffix haxe_type = (match haxe_type with | TMono r -> (match !r with None -> "Dynamic" ^ suffix | Some t -> type_string_suff suffix t) | TAbstract ({ a_path = ([],"Void") },[]) -> "Void" | TAbstract ({ a_path = ([],"Bool") },[]) -> "bool" | TAbstract ({ a_path = ([],"Float") },[]) -> "Float" | TAbstract ({ a_path = ([],"Int") },[]) -> "int" | TAbstract( { a_path = ([], "EnumValue") }, _ ) -> "Dynamic" | TEnum ({ e_path = ([],"Void") },[]) -> "Void" | TEnum ({ e_path = ([],"Bool") },[]) -> "bool" | TInst ({ cl_path = ([],"Float") },[]) -> "Float" | TInst ({ cl_path = ([],"Int") },[]) -> "int" | TEnum (enum,params) -> "::" ^ (join_class_path_remap enum.e_path "::") ^ suffix | TInst (klass,params) -> (class_string klass suffix params) | TType (type_def,params) -> (match type_def.t_path with | [] , "Null" -> (match params with | [t] -> (match follow t with | TAbstract ({ a_path = [],"Int" },_) | TAbstract ({ a_path = [],"Float" },_) | TAbstract ({ a_path = [],"Bool" },_) | TInst ({ cl_path = [],"Int" },_) | TInst ({ cl_path = [],"Float" },_) | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic" ^ suffix | _ -> type_string_suff suffix t) | _ -> assert false); | [] , "Array" -> (match params with | [t] when (type_string (follow t)) = "Dynamic" -> "Dynamic" | [t] -> "Array< " ^ (type_string (follow t) ) ^ " >" | _ -> assert false) | ["cpp"] , "FastIterator" -> (match params with | [t] -> "::cpp::FastIterator< " ^ (type_string (follow t) ) ^ " >" | _ -> assert false) | _ -> type_string_suff suffix (apply_params type_def.t_types params type_def.t_type) ) | TFun (args,haxe_type) -> "Dynamic" ^ suffix | TAnon a -> "Dynamic" (* (match !(a.a_status) with | Statics c -> type_string_suff suffix (TInst (c,List.map snd c.cl_types)) | EnumStatics e -> type_string_suff suffix (TEnum (e,List.map snd e.e_types)) | _ -> "Dynamic" ^ suffix ) *) | TDynamic haxe_type -> "Dynamic" ^ suffix | TLazy func -> type_string_suff suffix ((!func)()) | TAbstract (abs,pl) when abs.a_impl <> None -> type_string_suff suffix (Codegen.Abstract.get_underlying_type abs pl) | TAbstract (abs,pl) -> "::" ^ (join_class_path_remap abs.a_path "::") ^ suffix ) and type_string haxe_type = type_string_suff "" haxe_type and array_element_type haxe_type = match type_string haxe_type with | x when cant_be_null x -> x | "::String" -> "::String" | _ -> "::Dynamic" and is_dynamic_array_param haxe_type = if (type_string (follow haxe_type)) = "Dynamic" then true else (match follow haxe_type with | TInst (klass,params) -> (match klass.cl_path with | ([],"Array") | ([],"Class") | (["cpp"],"FastIterator") -> false | _ -> (match klass.cl_kind with KTypeParameter _ -> true | _ -> false) ) | _ -> false ) ;; let is_array haxe_type = match follow haxe_type with | TInst (klass,params) -> (match klass.cl_path with | [] , "Array" -> not (is_dynamic_array_param (List.hd params)) | _ -> false ) | TType (type_def,params) -> (match type_def.t_path with | [] , "Array" -> not (is_dynamic_array_param (List.hd params)) | _ -> false ) | _ -> false ;; let is_array_implementer haxe_type = match follow haxe_type with | TInst (klass,params) -> (match klass.cl_array_access with | Some _ -> true | _ -> false ) | _ -> false ;; let is_numeric_field field = match field.cf_kind with | Var _ -> is_numeric (type_string field.cf_type) | _ -> false; ;; (* Get the type and output it to the stream *) let gen_type ctx haxe_type = ctx.ctx_output (type_string haxe_type) ;; (* Get the type and output it to the stream *) let gen_type_suff ctx haxe_type suff = ctx.ctx_output (type_string_suff suff haxe_type);; let member_type ctx field_object member = let name = (if (is_array field_object.etype) then "::Array" else (type_string field_object.etype)) ^ "." ^ member in try ( Hashtbl.find ctx.ctx_class_member_types name ) with Not_found -> "?";; let is_interface_type t = match follow t with | TInst (klass,params) -> klass.cl_interface | _ -> false ;; let is_interface obj = is_interface_type obj.etype;; let should_implement_field x = not (is_extern_field x);; let is_function_member expression = match (follow expression.etype) with | TFun (_,_) -> true | _ -> false;; let is_internal_member member = match member with | "__Field" | "__IField" | "__Run" | "__Is" | "__GetClass" | "__GetType" | "__ToString" | "__s" | "__GetPtr" | "__SetField" | "__length" | "__IsArray" | "__SetThis" | "__Internal" | "__EnumParams" | "__Index" | "__Tag" | "__GetFields" | "toString" | "__HasField" -> true | _ -> false;; let rec is_dynamic_accessor name acc field class_def = ( ( acc ^ "_" ^ field.cf_name) = name ) && ( not (List.exists (fun f -> f.cf_name=name) class_def.cl_ordered_fields) ) && (match class_def.cl_super with None -> true | Some (parent,_) -> is_dynamic_accessor name acc field parent ) ;; let gen_arg_type_name name default_val arg_type prefix = let remap_name = keyword_remap name in let type_str = (type_string arg_type) in match default_val with | Some TNull -> (type_str,remap_name) | Some constant when (cant_be_null type_str) -> ("hx::Null< " ^ type_str ^ " > ",prefix ^ remap_name) | Some constant -> (type_str,prefix ^ remap_name) | _ -> (type_str,remap_name);; let gen_interface_arg_type_name name opt typ = let type_str = (type_string typ) in (if (opt && (cant_be_null type_str) ) then "hx::Null< " ^ type_str ^ " > " else type_str ) ^ " " ^ (keyword_remap name) ;; let gen_tfun_interface_arg_list args = String.concat "," (List.map (fun (name,opt,typ) -> gen_interface_arg_type_name name opt typ) args) ;; (* Generate prototype text, including allowing default values to be null *) let gen_arg name default_val arg_type prefix = let pair = gen_arg_type_name name default_val arg_type prefix in (fst pair) ^ " " ^ (snd pair);; let rec gen_arg_list arg_list prefix = String.concat "," (List.map (fun (v,o) -> (gen_arg v.v_name o v.v_type prefix) ) arg_list) let rec gen_tfun_arg_list arg_list = match arg_list with | [] -> "" | [(name,o,arg_type)] -> gen_arg name None arg_type "" | (name,o,arg_type) :: remaining -> (gen_arg name None arg_type "") ^ "," ^ (gen_tfun_arg_list remaining) (* Check to see if we are the first object in the parent tree to implement a dynamic interface *) let implement_dynamic_here class_def = let implements_dynamic c = match c.cl_dynamic with None -> false | _ -> true in let rec super_implements_dynamic c = match c.cl_super with | None -> false | Some (csup, _) -> if (implements_dynamic csup) then true else super_implements_dynamic csup; in ( (implements_dynamic class_def) && (not (super_implements_dynamic class_def) ) );; (* Make string printable for c++ code *) (* Here we know there are no utf8 characters, so use the L"" notation to avoid conversion *) let escape_stringw s l = let b = Buffer.create 0 in Buffer.add_char b 'L'; Buffer.add_char b '"'; let skip = ref 0 in for i = 0 to String.length s - 1 do if (!skip>0) then begin skip := !skip -1; l := !l-1; end else match Char.code (String.unsafe_get s i) with | c when (c>127) -> let encoded = ((c land 0x3F) lsl 6) lor ( Char.code ((String.unsafe_get s (i+1))) land 0x7F) in skip := 1; Buffer.add_string b (Printf.sprintf "\\x%X\"L\"" encoded) | c when (c < 32) -> Buffer.add_string b (Printf.sprintf "\\x%X\"L\"" c) | c -> Buffer.add_char b (Char.chr c) done; Buffer.add_char b '"'; Buffer.contents b;; let special_to_hex s = let l = String.length s in let b = Buffer.create 0 in for i = 0 to l - 1 do match Char.code (String.unsafe_get s i) with | c when (c>127) || (c<32) -> Buffer.add_string b (Printf.sprintf "\\x%02x\"\"" c) | c -> Buffer.add_char b (Char.chr c) done; Buffer.contents b;; let escape_extern s = let l = String.length s in let b = Buffer.create 0 in for i = 0 to l - 1 do match Char.code (String.unsafe_get s i) with | c when (c>127) || (c<32) || (c=34) || (c=92) -> Buffer.add_string b (Printf.sprintf "\\x%02x" c) | c -> Buffer.add_char b (Char.chr c) done; Buffer.contents b;; let has_utf8_chars s = let result = ref false in for i = 0 to String.length s - 1 do result := !result || ( Char.code (String.unsafe_get s i) > 127 ) done; !result;; let escape_command s = let b = Buffer.create 0 in String.iter (fun ch -> if (ch=='"' || ch=='\\' ) then Buffer.add_string b "\\"; Buffer.add_char b ch ) s; Buffer.contents b;; let str s = let escaped = Ast.s_escape s in ("HX_CSTRING(\"" ^ (special_to_hex escaped) ^ "\")") ;; (* When we are in a "real" object, we refer to ourselves as "this", but if we are in a local class that is used to generate return values, we use the fake "__this" pointer. If we are in an "Anon" object, then the "this" refers to the anon object (eg List iterator) *) let clear_real_this_ptr ctx dynamic_this = let old_flag = ctx.ctx_real_this_ptr in let old_dynamic = ctx.ctx_dynamic_this_ptr in ctx.ctx_real_this_ptr <- false; ctx.ctx_dynamic_this_ptr <- dynamic_this; fun () -> ( ctx.ctx_real_this_ptr <- old_flag; ctx.ctx_dynamic_this_ptr <- old_dynamic; );; (* Generate temp variable names *) let next_anon_function_name ctx = ctx.ctx_static_id_curr <- ctx.ctx_static_id_curr + 1; "_Function_" ^ (string_of_int ctx.ctx_static_id_depth) ^"_"^ (string_of_int ctx.ctx_static_id_curr);; let use_anon_function_name ctx = ctx.ctx_static_id_used <- ctx.ctx_static_id_used + 1; "_Function_" ^ (string_of_int ctx.ctx_static_id_depth) ^"_"^ (string_of_int ctx.ctx_static_id_used);; let push_anon_names ctx = let old_used = ctx.ctx_static_id_used in let old_curr = ctx.ctx_static_id_curr in let old_depth = ctx.ctx_static_id_depth in ctx.ctx_static_id_used <- 0; ctx.ctx_static_id_curr <- 0; ctx.ctx_static_id_depth <- ctx.ctx_static_id_depth + 1; ( function () -> ( ctx.ctx_static_id_used <- old_used; ctx.ctx_static_id_curr <- old_curr; ctx.ctx_static_id_depth <- old_depth; ) ) ;; let get_switch_var ctx = ctx.ctx_switch_id <- ctx.ctx_switch_id + 1; "_switch_" ^ (string_of_int ctx.ctx_switch_id) (* If you put on the "-debug" flag, you get extra comments in the source code *) let debug_expression expression type_too = "/* " ^ Type.s_expr_kind expression ^ (if (type_too) then " = " ^ (type_string expression.etype) else "") ^ " */";; (* This is like the Type.iter, but also keeps the "retval" flag up to date *) let rec iter_retval f retval e = match e.eexpr with | TConst _ | TLocal _ | TBreak | TContinue | TTypeExpr _ -> () | TArray (e1,e2) | TBinop (_,e1,e2) -> f true e1; f true e2; | TWhile (e1,e2,_) -> f true e1; f false e2; | TFor (_,e1,e2) -> f true e1; f false e2; | TThrow e | TField (e,_) | TUnop (_,_,e) -> f true e | TParenthesis e -> f retval e | TBlock expr_list when retval -> let rec return_last = function | [] -> () | expr :: [] -> f true expr | expr :: exprs -> f false expr; return_last exprs in return_last expr_list | TArrayDecl el | TNew (_,_,el) -> List.iter (f true ) el | TBlock el -> List.iter (f false ) el | TObjectDecl fl -> List.iter (fun (_,e) -> f true e) fl | TCall (e,el) -> f true e; List.iter (f true) el | TVars vl -> List.iter (fun (_,e) -> match e with None -> () | Some e -> f true e) vl | TFunction fu -> f false fu.tf_expr | TIf (e,e1,e2) -> f true e; f retval e1; (match e2 with None -> () | Some e -> f retval e) | TSwitch (e,cases,def) -> f true e; List.iter (fun (el,e2) -> List.iter (f true) el; f retval e2) cases; (match def with None -> () | Some e -> f retval e) | TMatch (e,_,cases,def) -> f true e; List.iter (fun (_,_,e) -> f false e) cases; (match def with None -> () | Some e -> f false e) | TTry (e,catches) -> f retval e; List.iter (fun (_,e) -> f false e) catches | TReturn eo -> (match eo with None -> () | Some e -> f true e) | TCast (e,None) -> f retval e | TCast (e,_) -> f true e ;; (* Convert an array to a comma separated list of values *) let array_arg_list inList = let i = ref (0-1) in String.concat "," (List.map (fun _ -> incr i; "inArgs[" ^ (string_of_int !i) ^ "]" ) inList) let list_num l = string_of_int (List.length l);; let only_int_cases cases = match cases with | [] -> false | _ -> not (List.exists (fun (cases,expression) -> List.exists (fun case -> match case.eexpr with TConst (TInt _) -> false | _ -> true ) cases ) cases );; (* See if there is a haxe break statement that will be swollowed by c++ break *) exception BreakFound;; let contains_break expression = try ( let rec check_all expression = Type.iter (fun expr -> match expr.eexpr with | TBreak -> raise BreakFound | TFor _ | TFunction _ | TWhile (_,_,_) -> () | _ -> check_all expr; ) expression in check_all expression; false; ) with BreakFound -> true;; (* Decide is we should look the field up by name *) let dynamic_internal = function | "__Is" -> true | _ -> false (* Get a list of variables to extract from a enum tmatch *) let tmatch_params_to_args params = (match params with | None | Some [] -> [] | Some l -> let n = ref (-1) in List.fold_left (fun acc v -> incr n; match v with None -> acc | Some v -> (v.v_name,v.v_type,!n) :: acc) [] l) let rec is_null expr = match expr.eexpr with | TConst TNull -> true | TParenthesis expr -> is_null expr | TCast (e,None) -> is_null e | _ -> false ;; let find_undeclared_variables_ctx ctx undeclared declarations this_suffix allow_this expression = let output = ctx.ctx_output in let rec find_undeclared_variables undeclared declarations this_suffix allow_this expression = match expression.eexpr with | TVars var_list -> List.iter (fun (tvar, optional_init) -> Hashtbl.add declarations (keyword_remap tvar.v_name) (); if (ctx.ctx_debug) then output ("/* found var " ^ tvar.v_name ^ "*/ "); match optional_init with | Some expression -> find_undeclared_variables undeclared declarations this_suffix allow_this expression | _ -> () ) var_list | TFunction func -> List.iter ( fun (tvar, opt_val) -> if (ctx.ctx_debug) then output ("/* found arg " ^ tvar.v_name ^ " = " ^ (type_string tvar.v_type) ^ " */ "); Hashtbl.add declarations (keyword_remap tvar.v_name) () ) func.tf_args; find_undeclared_variables undeclared declarations this_suffix false func.tf_expr | TTry (try_block,catches) -> find_undeclared_variables undeclared declarations this_suffix allow_this try_block; List.iter (fun (tvar,catch_expt) -> let old_decs = Hashtbl.copy declarations in Hashtbl.add declarations (keyword_remap tvar.v_name) (); find_undeclared_variables undeclared declarations this_suffix allow_this catch_expt; Hashtbl.clear declarations; Hashtbl.iter ( Hashtbl.add declarations ) old_decs ) catches; | TLocal tvar -> let name = keyword_remap tvar.v_name in if not (Hashtbl.mem declarations name) then Hashtbl.replace undeclared name (type_string expression.etype) | TMatch (condition, enum, cases, default) -> find_undeclared_variables undeclared declarations this_suffix allow_this condition; List.iter (fun (case_ids,params,expression) -> let old_decs = Hashtbl.copy declarations in (match params with | None -> () | Some l -> List.iter (fun (opt_var) -> match opt_var with | Some v -> Hashtbl.add declarations (keyword_remap v.v_name) () | _ -> () ) l ); find_undeclared_variables undeclared declarations this_suffix allow_this expression; Hashtbl.clear declarations; Hashtbl.iter ( Hashtbl.add declarations ) old_decs ) cases; (match default with | None -> () | Some expr -> find_undeclared_variables undeclared declarations this_suffix allow_this expr; ); | TFor (tvar, init, loop) -> let old_decs = Hashtbl.copy declarations in Hashtbl.add declarations (keyword_remap tvar.v_name) (); find_undeclared_variables undeclared declarations this_suffix allow_this init; find_undeclared_variables undeclared declarations this_suffix allow_this loop; Hashtbl.clear declarations; Hashtbl.iter ( Hashtbl.add declarations ) old_decs | TConst TSuper | TConst TThis -> if ((not (Hashtbl.mem declarations "this")) && allow_this) then Hashtbl.replace undeclared "this" (type_string_suff this_suffix expression.etype) | TBlock expr_list -> let old_decs = Hashtbl.copy declarations in List.iter (find_undeclared_variables undeclared declarations this_suffix allow_this ) expr_list; (* what is the best way for this ? *) Hashtbl.clear declarations; Hashtbl.iter ( Hashtbl.add declarations ) old_decs | _ -> Type.iter (find_undeclared_variables undeclared declarations this_suffix allow_this) expression in find_undeclared_variables undeclared declarations this_suffix allow_this expression ;; let rec is_dynamic_in_cpp ctx expr = let expr_type = type_string ( match follow expr.etype with TFun (args,ret) -> ret | _ -> expr.etype) in ctx.ctx_dbgout ( "/* idic: " ^ expr_type ^ " */" ); if ( expr_type="Dynamic" ) then true else begin let result = ( match expr.eexpr with | TField( obj, field ) -> let name = field_name field in ctx.ctx_dbgout ("/* ?tfield "^name^" */"); if (is_dynamic_member_lookup_in_cpp ctx obj name) then ( ctx.ctx_dbgout "/* tf=dynobj */"; true ) else if (is_dynamic_member_return_in_cpp ctx obj name) then ( ctx.ctx_dbgout "/* tf=dynret */"; true ) else ( ctx.ctx_dbgout "/* tf=notdyn */"; false ) | TConst TThis when ((not ctx.ctx_real_this_ptr) && ctx.ctx_dynamic_this_ptr) -> ctx.ctx_dbgout ("/* dthis */"); true | TArray (obj,index) -> let dyn = is_dynamic_in_cpp ctx obj in ctx.ctx_dbgout ("/* aidr:" ^ (if dyn then "Dyn" else "Not") ^ " */"); dyn; | TTypeExpr _ -> false | TCall(func,args) -> (match follow func.etype with | TFun (args,ret) -> ctx.ctx_dbgout ("/* ret = "^ (type_string ret) ^" */"); is_dynamic_in_cpp ctx func | _ -> ctx.ctx_dbgout "/* not TFun */"; true ); | TParenthesis(expr) -> is_dynamic_in_cpp ctx expr | TCast (e,None) -> is_dynamic_in_cpp ctx e | TLocal { v_name = "__global__" } -> false | TConst TNull -> true | _ -> ctx.ctx_dbgout "/* other */"; false (* others ? *) ) in ctx.ctx_dbgout (if result then "/* Y */" else "/* N */" ); result end and is_dynamic_member_lookup_in_cpp ctx field_object member = ctx.ctx_dbgout ("/*mem."^member^".*/"); if (is_internal_member member) then false else if (match field_object.eexpr with | TTypeExpr _ -> ctx.ctx_dbgout "/*!TTypeExpr*/"; true | _ -> false) then false else if (is_dynamic_in_cpp ctx field_object) then true else if (is_array field_object.etype) then false else ( let tstr = type_string field_object.etype in ctx.ctx_dbgout ("/* ts:"^tstr^"*/"); match tstr with (* Internal classes have no dynamic members *) | "::String" | "Null" | "::Class" | "::Enum" | "::Math" | "::ArrayAccess" -> ctx.ctx_dbgout ("/* ok:" ^ (type_string field_object.etype) ^ " */"); false | "Dynamic" -> true | name -> let full_name = name ^ "." ^ member in ctx.ctx_dbgout ("/* t:" ^ full_name ^ " */"); try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in ctx.ctx_dbgout ("/* =" ^ mem_type ^ "*/"); false ) with Not_found -> true ) and is_dynamic_member_return_in_cpp ctx field_object member = if (is_array field_object.etype) then false else if (is_internal_member member) then false else match field_object.eexpr with | TTypeExpr t -> let full_name = "::" ^ (join_class_path (t_path t) "::" ) ^ "." ^ member in ctx.ctx_dbgout ("/*static:"^ full_name^"*/"); ( try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in mem_type="Dynamic" ) with Not_found -> true ) | _ -> let tstr = type_string field_object.etype in (match tstr with (* Internal classes have no dynamic members *) | "::String" | "Null" | "::Class" | "::Enum" | "::Math" | "::ArrayAccess" -> false | "Dynamic" -> ctx.ctx_dbgout "/*D*/"; true | name -> let full_name = name ^ "." ^ member in ctx.ctx_dbgout ("/*R:"^full_name^"*/"); try ( let mem_type = (Hashtbl.find ctx.ctx_class_member_types full_name) in mem_type="Dynamic" ) with Not_found -> true ) ;; let cast_if_required ctx expr to_type = let expr_type = (type_string expr.etype) in ctx.ctx_dbgout ( "/* cir: " ^ expr_type ^ " */" ); if (is_dynamic_in_cpp ctx expr) then ctx.ctx_output (".Cast< " ^ to_type ^ " >()" ) ;; let default_value_string = function | TInt i -> Printf.sprintf "%ld" i | TFloat float_as_string -> float_as_string | TString s -> str s | TBool b -> (if b then "true" else "false") | TNull -> "null()" | _ -> "/* Hmmm */" ;; let generate_default_values ctx args prefix = List.iter ( fun (v,o) -> let type_str = type_string v.v_type in let name = (keyword_remap v.v_name) in match o with | Some TNull -> () | Some const -> ctx.ctx_output (type_str ^ " " ^ name ^ " = " ^ prefix ^ name ^ ".Default(" ^ (default_value_string const) ^ ");\n") | _ -> () ) args;; let return_type_string t = match t with | TFun (_,ret) -> type_string ret | _ -> "" ;; (* let rec has_side_effects expr = match expr.eexpr with | TConst _ | TLocal _ | TFunction _ | TTypeExpr _ -> false | TUnop(Increment,_,_) | TUnop(Decrement,_,_) | TBinop(OpAssign,_,_) | TBinop(OpAssignOp _,_,_) -> true | TUnop(_,_,e) -> has_side_effects e | TArray(e1,e2) | TBinop(_,e1,e2) -> has_side_effects e1 || has_side_effects e2 | TIf(cond,e1,Some e2) -> has_side_effects cond || has_side_effects e1 || has_side_effects e2 | TField(e,_) | TParenthesis e -> has_side_effects e | TArrayDecl el -> List.exists has_side_effects el | TObjectDecl decls -> List.exists (fun (_,e) -> has_side_effects e) decls | TCast(e,_) -> has_side_effects e | _ -> true ;; let rec can_be_affected expr = match expr.eexpr with | TConst _ | TFunction _ | TTypeExpr _ -> false | TLocal _ -> true | TUnop(Increment,_,_) | TUnop(Decrement,_,_) -> true | TUnop(_,_,e) -> can_be_affected e | TBinop(OpAssign,_,_) | TBinop(OpAssignOp _,_,_) -> true | TBinop(_,e1,e2) -> can_be_affected e1 || can_be_affected e2 | TField(e,_) -> can_be_affected e | TParenthesis e -> can_be_affected e | TCast(e,_) -> can_be_affected e | TArrayDecl el -> List.exists can_be_affected el | TObjectDecl decls -> List.exists (fun (_,e) -> can_be_affected e) decls | _ -> true ;; let call_has_side_effects func args = let effects = (if has_side_effects func then 1 else 0) + (List.length (List.filter has_side_effects args)) in let affected = (if can_be_affected func then 1 else 0) + (List.length (List.filter can_be_affected args)) in effects + affected > 22; ;; The above code may be overly pessimistic - will have to check performance *) let has_side_effects expr = false;; let call_has_side_effects func args = false;; let has_default_values args = List.exists ( fun (_,o) -> match o with | Some TNull -> false | Some _ -> true | _ -> false ) args ;; exception PathFound of string;; let hx_stack_push ctx output clazz func_name pos = let file = pos.pfile in let flen = String.length file in (* Not quite right - should probably test is file exists *) let stripped_file = try List.iter (fun path -> let plen = String.length path in if (flen>plen && path=(String.sub file 0 plen )) then raise (PathFound (String.sub file plen (flen-plen)) ) ) (ctx.ctx_common.class_path @ ctx.ctx_common.std_path); file; with PathFound tail -> tail in let qfile = "\"" ^ (Ast.s_escape stripped_file) ^ "\"" in ctx.ctx_file_info := PMap.add qfile qfile !(ctx.ctx_file_info); if (ctx.ctx_dump_stack_line) then output ("HX_STACK_PUSH(\"" ^ clazz ^ "::" ^ func_name ^ "\"," ^ qfile ^ "," ^ (string_of_int (Lexer.get_error_line pos) ) ^ ");\n") ;; (* This is the big one. Once you get inside a function, all code is generated (recursively) as a "expression". "retval" is tracked to determine whether the value on an expression is actually used. eg, if the result of a block (ie, the last expression in the list) is used, then we have to do some funky stuff to generate a local function. Some things that change less often are stored in the context and are extracted at the top for simplicity. *) let rec define_local_function_ctx ctx func_name func_def = let writer = ctx.ctx_writer in let output_i = writer#write_i in let output = ctx.ctx_output in let remap_this = function | "this" -> "__this" | other -> other in let rec define_local_function func_name func_def = let declarations = Hashtbl.create 0 in let undeclared = Hashtbl.create 0 in (* '__global__', '__cpp__' are always defined *) Hashtbl.add declarations "__global__" (); Hashtbl.add declarations "__cpp__" (); Hashtbl.add declarations "__trace" (); (* Add args as defined variables *) List.iter ( fun (arg_var, opt_val) -> if (ctx.ctx_debug) then output ("/* found arg " ^ arg_var.v_name ^ " = " ^ (type_string arg_var.v_type) ^" */ "); Hashtbl.add declarations (keyword_remap arg_var.v_name) () ) func_def.tf_args; find_undeclared_variables_ctx ctx undeclared declarations "" true func_def.tf_expr; let has_this = Hashtbl.mem undeclared "this" in if (has_this) then Hashtbl.remove undeclared "this"; let typed_vars = hash_iterate undeclared (fun key value -> value ^ "," ^ (keyword_remap key) ) in let func_name_sep = func_name ^ (if List.length typed_vars > 0 then "," else "") in output_i ("HX_BEGIN_LOCAL_FUNC_S" ^ (list_num typed_vars) ^ "(" ^ (if has_this then "hx::LocalThisFunc," else "hx::LocalFunc,") ^ func_name_sep ^ (String.concat "," typed_vars) ^ ")\n" ); (* actual function, called "run" *) let args_and_types = List.map (fun (v,_) -> (type_string v.v_type) ^ " " ^ (keyword_remap v.v_name) ) func_def.tf_args in let block = is_block func_def.tf_expr in let func_type = type_string func_def.tf_type in output_i (func_type ^ " run(" ^ (gen_arg_list func_def.tf_args "__o_") ^ ")"); let close_defaults = if (has_default_values func_def.tf_args) then begin writer#begin_block; output_i ""; generate_default_values ctx func_def.tf_args "__o_"; output_i ""; true; end else false in let pop_real_this_ptr = clear_real_this_ptr ctx true in writer#begin_block; hx_stack_push ctx output_i "*" func_name func_def.tf_expr.epos; if (has_this && ctx.ctx_dump_stack_line) then output_i ("HX_STACK_THIS(__this.mPtr);\n"); List.iter (fun (v,_) -> output_i ("HX_STACK_ARG(" ^ (keyword_remap v.v_name) ^ ",\"" ^ v.v_name ^"\");\n") ) func_def.tf_args; if (block) then begin output_i ""; gen_expression ctx false func_def.tf_expr; output_i "return null();\n"; end else begin (* Save old values, and equalize for new input ... *) let pop_names = push_anon_names ctx in find_local_functions_and_return_blocks_ctx ctx false func_def.tf_expr; (match func_def.tf_expr.eexpr with | TReturn (Some return_expression) when (func_type<>"Void") -> output_i "return "; gen_expression ctx true return_expression; | TReturn (Some return_expression) -> output_i ""; gen_expression ctx false return_expression; | _ -> output_i ""; gen_expression ctx false (to_block func_def.tf_expr); ); output ";\n"; output_i "return null();\n"; pop_names(); end; writer#end_block; if close_defaults then writer#end_block; pop_real_this_ptr(); let return = if (type_string func_def.tf_type ) = "Void" then "(void)" else "return" in output_i ("HX_END_LOCAL_FUNC" ^ (list_num args_and_types) ^ "(" ^ return ^ ")\n\n"); Hashtbl.replace ctx.ctx_local_function_args func_name (if (ctx.ctx_real_this_ptr) then String.concat "," (hash_keys undeclared) else String.concat "," (List.map remap_this (hash_keys undeclared)) ) in define_local_function func_name func_def and find_local_functions_and_return_blocks_ctx ctx retval expression = let output = ctx.ctx_output in let rec find_local_functions_and_return_blocks retval expression = match expression.eexpr with | TBlock _ -> if (retval) then begin define_local_return_block_ctx ctx expression (next_anon_function_name ctx) true; end (* else we are done *) | TMatch (_, _, _, _) | TTry (_, _) | TSwitch (_, _, _) when retval -> define_local_return_block_ctx ctx expression (next_anon_function_name ctx) true; | TObjectDecl ( ("fileName" , { eexpr = (TConst (TString file)) }) :: ("lineNumber" , { eexpr = (TConst (TInt line)) }) :: ("className" , { eexpr = (TConst (TString class_name)) }) :: ("methodName", { eexpr = (TConst (TString meth)) }) :: [] ) -> () | TObjectDecl decl_list -> let name = next_anon_function_name ctx in define_local_return_block_ctx ctx expression name true; | TCall(func,args) when call_has_side_effects func args -> define_local_return_block_ctx ctx expression (next_anon_function_name ctx) retval (*| TCall (e,el) -> (* visit function object first, then args *) find_local_functions_and_return_blocks e; List.iter find_local_functions_and_return_blocks el *) | TFunction func -> let func_name = next_anon_function_name ctx in output "\n"; define_local_function_ctx ctx func_name func | TField (obj,_) when (is_null obj) -> ( ) | TArray (obj,_) when (is_null obj) -> ( ) | TIf ( _ , _ , _ ) when retval -> (* ? operator style *) iter_retval find_local_functions_and_return_blocks retval expression | TMatch (_, _, _, _) | TSwitch (_, _, _) when retval -> ( ) | TMatch ( cond , _, _, _) | TWhile ( cond , _, _ ) | TIf ( cond , _, _ ) | TSwitch ( cond , _, _) -> iter_retval find_local_functions_and_return_blocks true cond | _ -> iter_retval find_local_functions_and_return_blocks retval expression in find_local_functions_and_return_blocks retval expression and define_local_return_block_ctx ctx expression name retval = let writer = ctx.ctx_writer in let output_i = writer#write_i in let output = ctx.ctx_output in let check_this = function | "this" when not ctx.ctx_real_this_ptr -> "__this" | x -> x in let reference = function | "this" -> " *__this" | "_this" -> " _this" | name -> " &" ^name in let rec define_local_return_block expression = let declarations = Hashtbl.create 0 in let undeclared = Hashtbl.create 0 in (* '__global__' is always defined *) Hashtbl.add declarations "__global__" (); Hashtbl.add declarations "__cpp__" (); Hashtbl.add declarations "__trace" (); find_undeclared_variables_ctx ctx undeclared declarations "_obj" true expression; let vars = (hash_keys undeclared) in let args = String.concat "," (List.map check_this (hash_keys undeclared)) in Hashtbl.replace ctx.ctx_local_return_block_args name args; output_i ("struct " ^ name); writer#begin_block; let ret_type = if (not retval) then "Void" else match expression.eexpr with | TObjectDecl _ -> "Dynamic" | _ -> type_string expression.etype in output_i ("inline static " ^ ret_type ^ " Block( "); output (String.concat "," ( (List.map (fun var -> (Hashtbl.find undeclared var) ^ (reference var)) ) vars)); output (")"); let return_data = ret_type <> "Void" in writer#begin_block; hx_stack_push ctx output_i "*" "closure" expression.epos; output_i ""; let pop_real_this_ptr = clear_real_this_ptr ctx false in (match expression.eexpr with | TObjectDecl decl_list -> writer#begin_block; output_i "hx::Anon __result = hx::Anon_obj::Create();\n"; let pop_names = push_anon_names ctx in List.iter (function (name,value) -> find_local_functions_and_return_blocks_ctx ctx true value; output_i ( "__result->Add(" ^ (str name) ^ " , "); gen_expression ctx true value; output (if is_function_expr value then ",true" else ",false" ); output (");\n"); ) decl_list; pop_names(); output_i "return __result;\n"; writer#end_block; | TBlock _ -> ctx.ctx_return_from_block <- return_data; ctx.ctx_return_from_internal_node <- false; gen_expression ctx false expression; | TCall(func,args) -> writer#begin_block; let pop_names = push_anon_names ctx in find_local_functions_and_return_blocks_ctx ctx true func; List.iter (find_local_functions_and_return_blocks_ctx ctx true) args; ctx.ctx_tcall_expand_args <- true; gen_expression ctx return_data expression; output ";\n"; pop_names(); writer#end_block; | _ -> ctx.ctx_return_from_block <- false; ctx.ctx_return_from_internal_node <- return_data; gen_expression ctx false (to_block expression); ); output_i "return null();\n"; writer#end_block; pop_real_this_ptr(); writer#end_block_line; output ";\n"; in define_local_return_block expression and gen_expression ctx retval expression = let output = ctx.ctx_output in let writer = ctx.ctx_writer in let output_i = writer#write_i in let calling = ctx.ctx_calling in ctx.ctx_calling <- false; let assigning = ctx.ctx_assigning in ctx.ctx_assigning <- false; let return_from_block = ctx.ctx_return_from_block in ctx.ctx_return_from_block <- false; let tcall_expand_args = ctx.ctx_tcall_expand_args in ctx.ctx_tcall_expand_args <- false; let return_from_internal_node = ctx.ctx_return_from_internal_node in ctx.ctx_return_from_internal_node <- false; let dump_src_pos = ctx.ctx_dump_src_pos in ctx.ctx_dump_src_pos <- (fun() -> ()); (* Annotate source code with debug - can get a bit verbose. Mainly for debugging code gen, rather than the run time *) if (ctx.ctx_debug) then begin (*if calling then output "/* Call */";*) (*if ctx.ctx_real_this_ptr then output "/* this */" else output "/* FAKE __this */";*) output (debug_expression expression ctx.ctx_debug_type); end; (* Write comma separated list of variables - useful for function args. *) let rec gen_expression_list expressions = (match expressions with | [] -> () | [single] -> gen_expression ctx true single | first :: remaining -> gen_expression ctx true first; output ","; gen_expression_list remaining ) in let rec gen_bin_op_string expr1 op expr2 = let cast = (match op with | ">>" | "<<" | "&" | "|" | "^" -> "int(" | "&&" | "||" -> "bool(" | "/" -> "Float(" | _ -> "") in if (op <> "=") then output "("; if ( cast <> "") then output cast; gen_expression ctx true expr1; if ( cast <> "") then output ")"; output (" " ^ op ^ " "); if ( cast <> "") then output cast; gen_expression ctx true expr2; if ( cast <> "") then output ")"; if (op <> "=") then output ")"; in let rec gen_bin_op op expr1 expr2 = match op with | Ast.OpAssign -> ctx.ctx_assigning <- true; gen_bin_op_string expr1 "=" expr2 | Ast.OpUShr -> output "hx::UShr("; gen_expression ctx true expr1; output ","; gen_expression ctx true expr2; output ")"; | Ast.OpMod -> output "hx::Mod("; gen_expression ctx true expr1; output ","; gen_expression ctx true expr2; output ")"; | Ast.OpAssignOp bin_op -> output (match bin_op with | Ast.OpAdd -> "hx::AddEq(" | Ast.OpMult -> "hx::MultEq(" | Ast.OpDiv -> "hx::DivEq(" | Ast.OpSub -> "hx::SubEq(" | Ast.OpAnd -> "hx::AndEq(" | Ast.OpOr -> "hx::OrEq(" | Ast.OpXor -> "hx::XorEq(" | Ast.OpShl -> "hx::ShlEq(" | Ast.OpShr -> "hx::ShrEq(" | Ast.OpUShr -> "hx::UShrEq(" | Ast.OpMod -> "hx::ModEq(" | _ -> error "Unknown OpAssignOp" expression.epos ); ctx.ctx_assigning <- true; gen_expression ctx true expr1; output ","; gen_expression ctx true expr2; output ")" | Ast.OpNotEq -> gen_bin_op_string expr1 "!=" expr2 | Ast.OpEq -> gen_bin_op_string expr1 "==" expr2 | _ -> gen_bin_op_string expr1 (Ast.s_binop op) expr2 in let gen_array_cast cast_name real_type call = output (cast_name ^ "< " ^ real_type ^ " >" ^ call) in let rec check_array_element_cast array_type cast_name call = match follow array_type with | TInst (klass,[element]) -> ( match type_string element with | x when cant_be_null x -> () | "::String" | "Dynamic" -> () | real_type -> gen_array_cast cast_name real_type call ) | TAbstract (abs,pl) when abs.a_impl <> None -> check_array_element_cast (Codegen.Abstract.get_underlying_type abs pl) cast_name call | _ -> () in let rec check_array_cast array_type = match follow array_type with | TInst (klass,[element]) -> let name = type_string element in if ( is_object name ) then gen_array_cast ".StaticCast" "Array" "()" else gen_array_cast ".StaticCast" (type_string array_type) "()" | TAbstract (abs,pl) when abs.a_impl <> None -> check_array_cast (Codegen.Abstract.get_underlying_type abs pl) | _ -> () in let rec gen_tfield field_object field = let member = (field_name field) in let remap_name = keyword_remap member in let already_dynamic = ref false in (match field_object.eexpr with (* static access ... *) | TTypeExpr type_def -> let class_name = "::" ^ (join_class_path_remap (t_path type_def) "::" ) in if (class_name="::String") then output ("::String::" ^ remap_name) else output (class_name ^ "_obj::" ^ remap_name); (* Special internal access *) | TLocal { v_name = "__global__" } -> output ("::" ^ member ) | TConst TSuper -> output (if ctx.ctx_real_this_ptr then "this" else "__this"); output ("->super::" ^ remap_name) | TConst TThis when ctx.ctx_real_this_ptr -> output ( "this->" ^ remap_name ) | TConst TNull -> output "null()" | _ -> gen_expression ctx true field_object; ctx.ctx_dbgout "/* TField */"; (* toString is the only internal member that can be set... *) let settingInternal = assigning && member="toString" in if (is_internal_member member && not settingInternal) then begin output ( "->" ^ member ); end else if (settingInternal || is_dynamic_member_lookup_in_cpp ctx field_object member) then begin if assigning then output ( "->__FieldRef(" ^ (str member) ^ ")" ) else output ( "->__Field(" ^ (str member) ^ ",true)" ); already_dynamic := true; end else begin if ((type_string field_object.etype)="::String" ) then output ( "." ^ remap_name ) else begin cast_if_required ctx field_object (type_string field_object.etype); output ( "->" ^ remap_name ); if (calling && (is_array field_object.etype) && remap_name="iterator" ) then check_array_element_cast field_object.etype "Fast" ""; already_dynamic := (match field with | FInstance(_,var) when is_var_field var -> true | _ -> false); end; end; ); if ( (not !already_dynamic) && (not calling) && (not assigning) && (is_function_member expression) ) then output "_dyn()"; in let gen_local_block_call () = let func_name = use_anon_function_name ctx in ( try output ( func_name ^ "::Block(" ^ (Hashtbl.find ctx.ctx_local_return_block_args func_name) ^ ")" ) with Not_found -> (*error ("Block function " ^ func_name ^ " not found" ) expression.epos;*) output ("/* Block function " ^ func_name ^ " not found */" ); ) in (match expression.eexpr with | TConst TNull when not retval -> output "Dynamic()"; | TCall (func, arg_list) when (match func.eexpr with | TLocal { v_name = "__cpp__" } -> true | _ -> false) -> ( match arg_list with | [{ eexpr = TConst (TString code) }] -> output code; | _ -> error "__cpp__ accepts only one string as an argument" func.epos; ) | TCall (func, arg_list) when tcall_expand_args-> let use_temp_func = has_side_effects func in if (use_temp_func) then begin output_i "Dynamic __func = "; gen_expression ctx true func; output ";\n"; end; let arg_string = ref "" in let idx = ref 0 in List.iter (fun arg -> let a_name = "__a" ^ string_of_int(!idx) in arg_string := !arg_string ^ (if !arg_string<>"" then "," else "") ^ a_name; idx := !idx + 1; output_i ( (type_string arg.etype) ^ " " ^ a_name ^ " = "); gen_expression ctx true arg; output ";\n"; ) arg_list; output_i (if retval then "return " else ""); if use_temp_func then output "__func" else begin ctx.ctx_calling <- true; gen_expression ctx true func; end; output ("(" ^ !arg_string ^ ");\n"); | TCall (func, arg_list) -> let rec is_variable e = match e.eexpr with | TField _ -> false | TLocal { v_name = "__global__" } -> false | TParenthesis p -> is_variable p | TCast (e,None) -> is_variable e | _ -> true in let expr_type = type_string expression.etype in let rec is_fixed_override e = (not (is_scalar expr_type)) && match e.eexpr with | TField(obj,FInstance(_,field) ) -> let cpp_type = member_type ctx obj field.cf_name in (not (is_scalar cpp_type)) && ( let fixed = (cpp_type<>"?") && (expr_type<>"Dynamic") && (cpp_type<>"Dynamic") && (cpp_type<>expr_type) && (expr_type<>"Void") in if (fixed && ctx.ctx_debug_type ) then begin output ("/* " ^ (cpp_type) ^ " != " ^ expr_type ^ " -> cast */"); (* print_endline (cpp_type ^ " != " ^ expr_type ^ " -> cast"); *) end; fixed ) | TParenthesis p -> is_fixed_override p | _ -> false in let is_super = (match func.eexpr with | TConst TSuper -> true | _ -> false ) in if (ctx.ctx_debug_type) then output ("/* TCALL ret=" ^ expr_type ^ "*/"); let is_block_call = call_has_side_effects func arg_list in let cast_result = (not is_super) && (is_fixed_override func) in if (cast_result) then output ("hx::TCast< " ^ expr_type ^ " >::cast("); if (is_block_call) then gen_local_block_call() else begin ctx.ctx_calling <- true; gen_expression ctx true func; output "("; gen_expression_list arg_list; output ")"; end; if (cast_result) then output (")"); if ( (is_variable func) && (expr_type<>"Dynamic") && (not is_super) && (not is_block_call)) then ctx.ctx_output (".Cast< " ^ expr_type ^ " >()" ); let rec cast_array_output func = match func.eexpr with | TField(obj,field) when is_array obj.etype -> (match field_name field with | "pop" | "shift" -> check_array_element_cast obj.etype ".StaticCast" "()" | "map" -> check_array_cast expression.etype | _ -> () ) | TParenthesis p -> cast_array_output p | _ -> () in cast_array_output func; | TBlock expr_list -> if (retval) then gen_local_block_call() else begin writer#begin_block; dump_src_pos(); (* Save old values, and equalize for new input ... *) let pop_names = push_anon_names ctx in let remaining = ref (List.length expr_list) in List.iter (fun expression -> let want_value = (return_from_block && !remaining = 1) in find_local_functions_and_return_blocks_ctx ctx want_value expression; if (ctx.ctx_dump_stack_line) then output_i ("HX_STACK_LINE(" ^ (string_of_int (Lexer.get_error_line expression.epos)) ^ ")\n" ); output_i ""; ctx.ctx_return_from_internal_node <- return_from_internal_node; if (want_value) then output "return "; gen_expression ctx want_value expression; decr remaining; writer#terminate_line ) expr_list; writer#end_block; pop_names() end | TTypeExpr type_expr -> let klass = "::" ^ (join_class_path_remap (t_path type_expr) "::" ) in let klass1 = if klass="::Array" then "Array" else klass in output ("hx::ClassOf< " ^ klass1 ^ " >()") | TReturn _ when retval -> unsupported expression.epos | TReturn optional_expr -> output ""; ( match optional_expr with | Some return_expression when ( (type_string expression.etype)="Void") -> output "return null("; gen_expression ctx true return_expression; output ")"; | Some return_expression -> output "return "; gen_expression ctx true return_expression | _ -> output "return null()" ) | TConst const -> (match const with | TInt i when ctx.ctx_for_extern -> output (Printf.sprintf "%ld" i) | TInt i -> output (Printf.sprintf "(int)%ld" i) | TFloat float_as_string -> output float_as_string | TString s when ctx.ctx_for_extern -> output ("\"" ^ (escape_extern s) ^ "\"") | TString s -> output (str s) | TBool b -> output (if b then "true" else "false") (*| TNull -> output ("((" ^ (type_string expression.etype) ^ ")null())")*) | TNull -> output (if ctx.ctx_for_extern then "null" else "null()") | TThis -> output (if ctx.ctx_real_this_ptr then "hx::ObjectPtr(this)" else "__this") | TSuper when calling -> output (if ctx.ctx_real_this_ptr then "super::__construct" else ("__this->" ^ ctx.ctx_class_super_name ^ "::__construct") ) | TSuper -> output ("hx::ObjectPtr(" ^ (if ctx.ctx_real_this_ptr then "this" else "__this.mPtr") ^ ")") ) | TLocal v -> output (keyword_remap v.v_name); | TArray (array_expr,_) when (is_null array_expr) -> output "Dynamic()" | TArray (array_expr,index) -> let dynamic = is_dynamic_in_cpp ctx array_expr in if ( assigning && (not dynamic) ) then begin if (is_array_implementer array_expr.etype) then begin output "hx::__ArrayImplRef("; gen_expression ctx true array_expr; output ","; gen_expression ctx true index; output ")"; end else begin gen_expression ctx true array_expr; output "["; gen_expression ctx true index; output "]"; end end else if (assigning) then begin (* output (" /*" ^ (type_string array_expr.etype) ^ " */ "); *) output "hx::IndexRef(("; gen_expression ctx true array_expr; output ").mPtr,"; gen_expression ctx true index; output ")"; end else if ( dynamic ) then begin gen_expression ctx true array_expr; output "->__GetItem("; gen_expression ctx true index; output ")"; end else begin gen_expression ctx true array_expr; output "->__get("; gen_expression ctx true index; output ")"; check_array_element_cast array_expr.etype ".StaticCast" "()"; end (* Get precidence matching haxe ? *) | TBinop (op,expr1,expr2) -> gen_bin_op op expr1 expr2 | TField (expr,name) when (is_null expr) -> output "Dynamic()" | TField (field_object,field) -> gen_tfield field_object field | TParenthesis expr when not retval -> gen_expression ctx retval expr; | TParenthesis expr -> output "("; gen_expression ctx retval expr; output ")" | TObjectDecl ( ("fileName" , { eexpr = (TConst (TString file)) }) :: ("lineNumber" , { eexpr = (TConst (TInt line)) }) :: ("className" , { eexpr = (TConst (TString class_name)) }) :: ("methodName", { eexpr = (TConst (TString meth)) }) :: [] ) -> output ("hx::SourceInfo(" ^ (str file) ^ "," ^ (Printf.sprintf "%ld" line) ^ "," ^ (str class_name) ^ "," ^ (str meth) ^ ")" ) | TObjectDecl decl_list -> gen_local_block_call() | TArrayDecl decl_list -> (* gen_type output expression.etype; *) let tstr = (type_string_suff "_obj" expression.etype) in if tstr="Dynamic" then output "Dynamic( Array_obj::__new()" else output ( (type_string_suff "_obj" expression.etype) ^ "::__new()"); List.iter ( fun elem -> output ".Add("; gen_expression ctx true elem; output ")" ) decl_list; if tstr="Dynamic" then output ")"; | TNew (klass,params,expressions) -> let is_param_array = match klass.cl_path with | ([],"Array") when is_dynamic_array_param (List.hd params) -> true | _ -> false in if is_param_array then output "Dynamic( Array_obj::__new() )" else begin if (klass.cl_path = ([],"String")) then output "::String(" else output ( ( class_string klass "_obj" params) ^ "::__new(" ); gen_expression_list expressions; output ")" end | TUnop (Ast.NegBits,Ast.Prefix,expr) -> output "~(int)("; gen_expression ctx true expr; output ")" | TUnop (op,Ast.Prefix,expr) -> ctx.ctx_assigning <- (match op with Ast.Increment | Ast.Decrement -> true | _ ->false); output (Ast.s_unop op); output "("; gen_expression ctx true expr; output ")" | TUnop (op,Ast.Postfix,expr) -> ctx.ctx_assigning <- true; output "("; gen_expression ctx true expr; output ")"; output (Ast.s_unop op) | TFunction func -> let func_name = use_anon_function_name ctx in ( try output ( " Dynamic(new " ^ func_name ^ "(" ^ (Hashtbl.find ctx.ctx_local_function_args func_name) ^ "))" ) with Not_found -> (*error ("function " ^ func_name ^ " not found.") expression.epos; *) output ("function " ^ func_name ^ " not found."); ) | TVars var_list -> let count = ref (List.length var_list) in List.iter (fun (tvar, optional_init) -> if (retval && !count==1) then (match optional_init with | None -> output "null()" | Some expression -> gen_expression ctx true expression ) else begin let type_name = (type_string tvar.v_type) in output (if type_name="Void" then "Dynamic" else type_name ); let name = (keyword_remap tvar.v_name) in output (" " ^ name ); (match optional_init with | None -> () | Some expression -> output " = "; gen_expression ctx true expression); count := !count -1; if (ctx.ctx_dump_stack_line) then output (";\t\tHX_STACK_VAR(" ^name ^",\""^ tvar.v_name ^"\")"); if (!count > 0) then begin output ";\n"; output_i "" end end ) var_list | TFor (tvar, init, loop) -> output ("for(::cpp::FastIterator_obj< " ^ (type_string tvar.v_type) ^ " > *__it = ::cpp::CreateFastIterator< "^(type_string tvar.v_type) ^ " >("); gen_expression ctx true init; output ("); __it->hasNext(); )"); ctx.ctx_writer#begin_block; output_i ( (type_string tvar.v_type) ^ " " ^ (keyword_remap tvar.v_name) ^ " = __it->next();\n" ); output_i ""; gen_expression ctx false loop; output ";\n"; ctx.ctx_writer#end_block; | TIf (condition, if_expr, optional_else_expr) -> (match optional_else_expr with | Some else_expr -> if (retval) then begin output "( ("; gen_expression ctx true condition; output ") ? "; let type_str = match (type_string expression.etype) with | "Void" -> "Dynamic" | other -> other in output (type_str ^ "("); gen_expression ctx true if_expr; output ") : "; output (type_str ^ "("); gen_expression ctx true else_expr; output ") )"; end else begin output "if ("; gen_expression ctx true condition; output ")"; gen_expression ctx false (to_block if_expr); output_i "else"; gen_expression ctx false (to_block else_expr); end | _ -> output "if ("; gen_expression ctx true condition; output ")"; gen_expression ctx false (to_block if_expr); ) | TWhile (condition, repeat, Ast.NormalWhile ) -> output "while("; gen_expression ctx true condition; output ")"; gen_expression ctx false (to_block repeat) | TWhile (condition, repeat, Ast.DoWhile ) -> output "do"; gen_expression ctx false (to_block repeat); output "while("; gen_expression ctx true condition; output ")" (* These have already been defined in find_local_return_blocks ... *) | TTry (_,_) | TSwitch (_,_,_) | TMatch (_, _, _, _) when (retval && (not return_from_internal_node) )-> gen_local_block_call() | TSwitch (condition,cases,optional_default) -> let switch_on_int_constants = (only_int_cases cases) && (not (contains_break expression)) in if (switch_on_int_constants) then begin output "switch( (int)"; gen_expression ctx true condition; output ")"; ctx.ctx_writer#begin_block; List.iter (fun (cases_list,expression) -> output_i ""; List.iter (fun value -> output "case "; gen_expression ctx true value; output ": " ) cases_list; ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block expression); output_i ";break;\n"; ) cases; (match optional_default with | None -> () | Some default -> output_i "default: "; ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block default); ); ctx.ctx_writer#end_block; end else begin let tmp_name = get_switch_var ctx in output ( (type_string condition.etype) ^ " " ^ tmp_name ^ " = " ); gen_expression ctx true condition; output ";\n"; let else_str = ref "" in if (List.length cases > 0) then List.iter (fun (cases,expression) -> output_i ( !else_str ^ "if ( "); else_str := "else "; let or_str = ref "" in List.iter (fun value -> output (!or_str ^ " ( " ^ tmp_name ^ "=="); gen_expression ctx true value; output ")"; or_str := " || "; ) cases; output (")"); ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block expression); ) cases; (match optional_default with | None -> () | Some default -> output_i ( !else_str ^ " "); ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block default); output ";\n"; ); end | TMatch (condition, enum, cases, default) -> let tmp_var = get_switch_var ctx in writer#begin_block; output_i ( "::" ^ (join_class_path_remap (fst enum).e_path "::") ^ " " ^ tmp_var ^ " = " ); gen_expression ctx true condition; output ";\n"; let use_if_statements = contains_break expression in let dump_condition = if (use_if_statements) then begin let tmp_name = get_switch_var ctx in output_i ( "int " ^ tmp_name ^ " = (" ^ tmp_var ^ ")->GetIndex();" ); let elif = ref "if" in ( fun case_ids -> output (!elif ^ " (" ); elif := "else if"; output (String.concat "||" (List.map (fun id -> (string_of_int id) ^ "==" ^ tmp_name ) case_ids ) ); output ") " ) end else begin output_i ("switch((" ^ tmp_var ^ ")->GetIndex())"); ( fun case_ids -> List.iter (fun id -> output ("case " ^ (string_of_int id) ^ ": ") ) case_ids; ) end in writer#begin_block; List.iter (fun (case_ids,params,expression) -> output_i ""; dump_condition case_ids; let has_params = match params with | Some _ -> true | _ -> false in if (has_params) then begin writer#begin_block; List.iter (fun (name,vtype,id) -> output_i ((type_string vtype) ^ " " ^ (keyword_remap name) ^ " = " ^ tmp_var ^ "->__Param(" ^ (string_of_int id) ^ ");\n")) (tmatch_params_to_args params); end; ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block expression); if (has_params) then writer#end_block; if (not use_if_statements) then output_i ";break;\n"; ) cases; (match default with | None -> () | Some e -> if (use_if_statements) then output_i "else " else output_i "default: "; ctx.ctx_return_from_block <- return_from_internal_node; gen_expression ctx false (to_block e); ); writer#end_block; writer#end_block; | TTry (expression, catch_list) -> output "try"; (* Move this "inside" the try call ... *) ctx.ctx_return_from_block <-return_from_internal_node; gen_expression ctx false (to_block expression); if (List.length catch_list > 0 ) then begin output_i "catch(Dynamic __e)"; ctx.ctx_writer#begin_block; let seen_dynamic = ref false in let else_str = ref "" in List.iter (fun (v,expression) -> let type_name = type_string v.v_type in if (type_name="Dynamic") then begin seen_dynamic := true; output_i !else_str; end else output_i (!else_str ^ "if (__e.IsClass< " ^ type_name ^ " >() )"); ctx.ctx_writer#begin_block; output_i "HX_STACK_BEGIN_CATCH\n"; output_i (type_name ^ " " ^ v.v_name ^ " = __e;"); (* Move this "inside" the catch call too ... *) ctx.ctx_return_from_block <-return_from_internal_node; gen_expression ctx false (to_block expression); ctx.ctx_writer#end_block; else_str := "else "; ) catch_list; if (not !seen_dynamic) then begin output_i "else throw(__e);\n"; end; ctx.ctx_writer#end_block; end; | TBreak -> output "break" | TContinue -> output "continue" | TThrow expression -> output "hx::Throw ("; gen_expression ctx true expression; output ")" | TCast (cast,None) -> let void_cast = retval && ((type_string expression.etype)="Void" ) in if (void_cast) then output "Void("; gen_expression ctx retval cast; if (void_cast) then output ")"; | TCast (e1,Some t) -> let class_name = (join_class_path_remap (t_path t) "::" ) in if (class_name="Array") then output ("hx::TCastToArray(" ) else output ("hx::TCast< " ^ class_name ^ " >::cast(" ); gen_expression ctx true e1; output ")"; );; (* let is_dynamic_haxe_method f = match follow f.cf_type with | TFun _ when f.cf_expr = None -> true | _ -> (match f.cf_expr with | Some { eexpr = TFunction fd } when f.cf_set = MethodAccess true -> true | Some { eexpr = TFunction fd } when f.cf_set = NormalAccess -> true | _ -> false);; *) let is_dynamic_haxe_method f = (match f.cf_expr, f.cf_kind with | Some { eexpr = TFunction _ }, (Var _ | Method MethDynamic) -> true | _ -> false);; let is_data_member field = match field.cf_expr with | Some { eexpr = TFunction function_def } -> is_dynamic_haxe_method field | _ -> true;; let is_override class_def field = List.exists (fun f -> f.cf_name = field) class_def.cl_overrides ;; let rec all_virtual_functions clazz = (List.fold_left (fun result elem -> match follow elem.cf_type, elem.cf_kind with | _, Method MethDynamic -> result | TFun (args,return_type), Method _ when not (is_override clazz elem.cf_name ) -> (elem,args,return_type) :: result | _,_ -> result ) [] clazz.cl_ordered_fields) @ (match clazz.cl_super with | Some def -> all_virtual_functions (fst def) | _ -> [] ) ;; (* external mem Dynamic & *) let gen_field ctx class_def class_name ptr_name is_static is_interface field = let output = ctx.ctx_output in ctx.ctx_real_this_ptr <- not is_static; let remap_name = keyword_remap field.cf_name in let decl = get_meta_string field.cf_meta Meta.Decl in let has_decl = decl <> "" in if (is_interface) then begin (* Just the dynamic glue ... *) match follow field.cf_type, field.cf_kind with | _, Method MethDynamic -> () | TFun (args,result), Method _ -> if (is_static) then output "STATIC_"; let ret = if ((type_string result ) = "Void" ) then "" else "return " in output ("HX_DEFINE_DYNAMIC_FUNC" ^ (string_of_int (List.length args)) ^ "(" ^ class_name ^ "," ^ remap_name ^ "," ^ ret ^ ")\n\n"); | _ -> () end else (match field.cf_expr with (* Function field *) | Some { eexpr = TFunction function_def } -> let return_type = (type_string function_def.tf_type) in let nargs = string_of_int (List.length function_def.tf_args) in let is_void = (type_string function_def.tf_type ) = "Void" in let ret = if is_void then "(void)" else "return " in let output_i = ctx.ctx_writer#write_i in let dump_src = if (Meta.has Meta.NoStack field.cf_meta) then begin ctx.ctx_dump_stack_line <- false; (fun()->()) end else begin ctx.ctx_dump_stack_line <- true; (fun() -> hx_stack_push ctx output_i ptr_name field.cf_name function_def.tf_expr.epos; if (not is_static) then output_i ("HX_STACK_THIS(this);\n"); List.iter (fun (v,_) -> output_i ("HX_STACK_ARG(" ^ (keyword_remap v.v_name) ^ ",\"" ^ v.v_name ^"\");\n") ) function_def.tf_args ) end in if (not (is_dynamic_haxe_method field)) then begin (* The actual function definition *) output return_type; output (" " ^ class_name ^ "::" ^ remap_name ^ "( " ); output (gen_arg_list function_def.tf_args "__o_"); output ")"; ctx.ctx_real_this_ptr <- true; ctx.ctx_dynamic_this_ptr <- false; let code = (get_code field.cf_meta Meta.FunctionCode) in let tail_code = (get_code field.cf_meta Meta.FunctionTailCode) in if (has_default_values function_def.tf_args) then begin ctx.ctx_writer#begin_block; generate_default_values ctx function_def.tf_args "__o_"; dump_src(); output code; gen_expression ctx false function_def.tf_expr; output tail_code; if (is_void) then output "return null();\n"; ctx.ctx_writer#end_block; end else begin let add_block = is_void || (code <> "") || (tail_code <> "") in if (add_block) then ctx.ctx_writer#begin_block; ctx.ctx_dump_src_pos <- dump_src; output code; gen_expression ctx false (to_block function_def.tf_expr); output tail_code; if (add_block) then begin if (is_void) then output "return null();\n"; ctx.ctx_writer#end_block; end; end; output "\n\n"; (* generate dynamic version too ... *) if ( not (is_override class_def field.cf_name ) ) then begin if (is_static) then output "STATIC_"; output ("HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," ^ remap_name ^ "," ^ ret ^ ")\n\n"); end; end else begin ctx.ctx_real_this_ptr <- false; ctx.ctx_dynamic_this_ptr <- false; let func_name = "__default_" ^ (remap_name) in output ("HX_BEGIN_DEFAULT_FUNC(" ^ func_name ^ "," ^ class_name ^ ")\n"); output return_type; output (" run(" ^ (gen_arg_list function_def.tf_args "") ^ ")"); ctx.ctx_dump_src_pos <- dump_src; if (is_void) then begin ctx.ctx_writer#begin_block; gen_expression ctx false function_def.tf_expr; output "return null();\n"; ctx.ctx_writer#end_block; end else gen_expression ctx false (to_block function_def.tf_expr); output ("HX_END_LOCAL_FUNC" ^ nargs ^ "(" ^ ret ^ ")\n"); output ("HX_END_DEFAULT_FUNC\n\n"); if (is_static) then output ( "Dynamic " ^ class_name ^ "::" ^ remap_name ^ ";\n\n"); end (* Data field *) | _ when has_decl -> if is_static then begin output ( class_name ^ "::" ^ remap_name ^ "_decl "); output ( " " ^ class_name ^ "::" ^ remap_name ^ ";\n\n"); end | _ -> if is_static && (not (is_extern_field field)) then begin gen_type ctx field.cf_type; output ( " " ^ class_name ^ "::" ^ remap_name ^ ";\n\n"); end ) ;; let gen_field_init ctx field = let output = ctx.ctx_output in let remap_name = keyword_remap field.cf_name in (match field.cf_expr with (* Function field *) | Some { eexpr = TFunction function_def } -> if (is_dynamic_haxe_method field) then begin let func_name = "__default_" ^ (remap_name) in output ( " " ^ remap_name ^ " = new " ^ func_name ^ ";\n\n" ); end (* Data field *) | _ -> (match field.cf_expr with | Some expr -> find_local_functions_and_return_blocks_ctx ctx true expr; output ( match remap_name with "__meta__" -> " __mClass->__meta__=" | _ -> " " ^ remap_name ^ "= "); gen_expression ctx true expr; output ";\n" | _ -> ( ) ); ) ;; let gen_member_def ctx class_def is_static is_interface field = let output = ctx.ctx_output in let remap_name = keyword_remap field.cf_name in if (is_interface) then begin match follow field.cf_type, field.cf_kind with | _, Method MethDynamic -> () | TFun (args,return_type), Method _ -> output ( (if (not is_static) then "virtual " else "" ) ^ type_string return_type); output (" " ^ remap_name ^ "( " ); output (gen_tfun_interface_arg_list args); output (if (not is_static) then ")=0;\n" else ");\n"); output (if is_static then " static " else " "); output ("Dynamic " ^ remap_name ^ "_dyn();\n" ); | _ -> ( ) end else begin let decl = get_meta_string field.cf_meta Meta.Decl in let has_decl = decl <> "" in if (has_decl) then output ( " typedef " ^ decl ^ ";\n" ); output (if is_static then " static " else " "); (match field.cf_expr with | Some { eexpr = TFunction function_def } -> if ( is_dynamic_haxe_method field ) then begin if ( not (is_override class_def field.cf_name ) ) then begin output ("Dynamic " ^ remap_name ^ ";\n"); output (if is_static then " static " else " "); output ("inline Dynamic &" ^ remap_name ^ "_dyn() " ^ "{return " ^ remap_name^ "; }\n") end end else begin let return_type = (type_string function_def.tf_type) in if (not is_static) then output "virtual "; output return_type; output (" " ^ remap_name ^ "( " ); output (gen_arg_list function_def.tf_args "" ); output ");\n"; if ( not (is_override class_def field.cf_name ) ) then begin output (if is_static then " static " else " "); output ("Dynamic " ^ remap_name ^ "_dyn();\n" ) end; end; output "\n"; | _ when has_decl -> output ( remap_name ^ "_decl " ^ remap_name ^ ";\n" ); (* Variable access *) | _ -> (* Variable access *) gen_type ctx field.cf_type; output (" " ^ remap_name ^ ";\n" ); (* Add a "dyn" function for variable to unify variable/function access *) (match follow field.cf_type with | TFun (_,_) -> output (if is_static then " static " else " "); gen_type ctx field.cf_type; output (" &" ^ remap_name ^ "_dyn() { return " ^ remap_name ^ ";}\n" ) | _ -> (match field.cf_kind with | Var { v_read = AccCall } when (not is_static) && (is_dynamic_accessor ("get_" ^ field.cf_name) "get" field class_def) -> output ("\t\tDynamic get_" ^ field.cf_name ^ ";\n" ) | _ -> () ); (match field.cf_kind with | Var { v_write = AccCall } when (not is_static) && (is_dynamic_accessor ("set_" ^ field.cf_name) "set" field class_def) -> output ("\t\tDynamic set_" ^ field.cf_name ^ ";\n" ) | _ -> () ) ) ); end ;; let path_of_string verbatim path = if verbatim then ( ["@verbatim"], path ) else match List.rev (Str.split_delim (Str.regexp "/") path ) with | [] -> ([],"") | [single] -> ([],single) | head :: rest -> (List.rev rest, head) ;; (* Get a list of all classes referred to by the class/enum definition These are used for "#include"ing the appropriate header files, or for building the dependencies in the Build.xml file *) let find_referenced_types ctx obj super_deps constructor_deps header_only for_depends include_super_args = let types = ref PMap.empty in let rec add_type in_path = if ( not (PMap.mem in_path !types)) then begin types := (PMap.add in_path () !types); try List.iter add_type (Hashtbl.find super_deps in_path); with Not_found -> () end in let add_extern_class klass = let include_file = get_meta_string klass.cl_meta (if for_depends then Meta.Depend else Meta.Include) in if (include_file<>"") then add_type ( path_of_string for_depends include_file ) else if (not for_depends) && (has_meta_key klass.cl_meta Meta.Include) then add_type klass.cl_path in let rec visit_type in_type = match (follow in_type) with | TMono r -> (match !r with None -> () | Some t -> visit_type t) (*| TEnum ({ e_path = ([],"Void") },[]) -> () | TEnum ({ e_path = ([],"Bool") },[]) -> () *) | TEnum (enum,params) -> add_type enum.e_path (* If a class has a template parameter, then we treat it as dynamic - except for the Array or Class class, for which we do a fully typed object *) | TInst (klass,params) -> (match klass.cl_path with | ([],"Array") | ([],"Class") | (["cpp"],"FastIterator") -> List.iter visit_type params | (["cpp"],"CppInt32__") -> add_type klass.cl_path; | _ when klass.cl_extern -> add_extern_class klass | _ -> (match klass.cl_kind with KTypeParameter _ -> () | _ -> add_type klass.cl_path); ) | TFun (args,haxe_type) -> visit_type haxe_type; List.iter (fun (_,_,t) -> visit_type t; ) args; | TAbstract (abs,pl) when abs.a_impl <> None -> visit_type (Codegen.Abstract.get_underlying_type abs pl) | _ -> () in let rec visit_types expression = begin let rec visit_expression = fun expression -> (* Expand out TTypeExpr (ie, the name of a class, as used for static access etc ... *) (match expression.eexpr with | TTypeExpr type_def -> ( match type_def with | TClassDecl class_def when class_def.cl_extern -> add_extern_class class_def | _ -> add_type (t_path type_def) ) (* Must visit the types, Type.iter will visit the expressions ... *) | TTry (e,catches) -> List.iter (fun (v,_) -> visit_type v.v_type) catches (* Must visit the enum param types, Type.iter will visit the rest ... *) | TMatch (_,enum,cases,_) -> add_type (fst enum).e_path; List.iter (fun (case_ids,params,expression) -> (match params with | None -> () | Some l -> List.iter (function None -> () | Some v -> visit_type v.v_type) l ) ) cases; (* Must visit type too, Type.iter will visit the expressions ... *) | TNew (klass,params,_) -> begin visit_type (TInst (klass,params)); try let construct_type = Hashtbl.find constructor_deps klass.cl_path in visit_type construct_type.cf_type with Not_found -> (); end (* Must visit type too, Type.iter will visit the expressions ... *) | TVars var_list -> List.iter (fun (v, _) -> visit_type v.v_type) var_list (* Must visit args too, Type.iter will visit the expressions ... *) | TFunction func_def -> List.iter (fun (v,_) -> visit_type v.v_type) func_def.tf_args; | TConst TSuper -> (match expression.etype with | TInst (klass,params) -> (try let construct_type = Hashtbl.find constructor_deps klass.cl_path in visit_type construct_type.cf_type with Not_found -> () ) | _ -> print_endline ("TSuper : Odd etype?") ) | _ -> () ); Type.iter visit_expression expression; visit_type (follow expression.etype) in visit_expression expression end in let visit_field field = (* Add the type of the expression ... *) visit_type field.cf_type; if (not header_only) then (match field.cf_expr with | Some expression -> visit_types expression | _ -> ()); in let visit_class class_def = let fields = List.append class_def.cl_ordered_fields class_def.cl_ordered_statics in let fields_and_constructor = List.append fields (match class_def.cl_constructor with | Some expr -> [expr] | _ -> [] ) in List.iter visit_field fields_and_constructor; if (include_super_args) then List.iter visit_field (List.map (fun (a,_,_) -> a ) (all_virtual_functions class_def )); (* Add super & interfaces *) add_type class_def.cl_path; in let visit_enum enum_def = add_type enum_def.e_path; PMap.iter (fun _ constructor -> (match constructor.ef_type with | TFun (args,_) -> List.iter (fun (_,_,t) -> visit_type t; ) args; | _ -> () ); ) enum_def.e_constrs; if (not header_only) then begin let meta = Codegen.build_metadata ctx (TEnumDecl enum_def) in match meta with Some expr -> visit_types expr | _ -> (); end; in let inc_cmp i1 i2 = String.compare (join_class_path i1 ".") (join_class_path i2 ".") in (* Body of main function *) (match obj with | TClassDecl class_def -> visit_class class_def; (match class_def.cl_init with Some expression -> visit_types expression | _ -> ()) | TEnumDecl enum_def -> visit_enum enum_def | TTypeDecl _ | TAbstractDecl _ -> (* These are expanded *) ()); List.sort inc_cmp (List.filter (fun path -> (include_class_header path) ) (pmap_keys !types)) ;; let generate_main common_ctx member_types super_deps class_def file_info = (* main routine should be a single static function *) let main_expression = (match class_def.cl_ordered_statics with | [{ cf_expr = Some expression }] -> expression; | _ -> assert false ) in ignore(find_referenced_types common_ctx (TClassDecl class_def) super_deps (Hashtbl.create 0) false false false); let depend_referenced = find_referenced_types common_ctx (TClassDecl class_def) super_deps (Hashtbl.create 0) false true false in let generate_startup filename is_main = (*make_class_directories base_dir ( "src" :: []);*) let cpp_file = new_cpp_file common_ctx.file ([],filename) in let output_main = (cpp_file#write) in output_main "#include \n\n"; output_main "#include \n\n"; List.iter ( add_include cpp_file ) depend_referenced; output_main "\n\n"; output_main ( if is_main then "HX_BEGIN_MAIN\n\n" else "HX_BEGIN_LIB_MAIN\n\n" ); gen_expression (new_context common_ctx cpp_file false file_info) false main_expression; output_main ";\n"; output_main ( if is_main then "HX_END_MAIN\n\n" else "HX_END_LIB_MAIN\n\n" ); cpp_file#close; in generate_startup "__main__" true; generate_startup "__lib__" false ;; let generate_dummy_main common_ctx = let generate_startup filename is_main = let main_file = new_cpp_file common_ctx.file ([],filename) in let output_main = (main_file#write) in output_main "#include \n\n"; output_main "#include \n\n"; output_main ( if is_main then "HX_BEGIN_MAIN\n\n" else "HX_BEGIN_LIB_MAIN\n\n" ); output_main ( if is_main then "HX_END_MAIN\n\n" else "HX_END_LIB_MAIN\n\n" ); main_file#close; in generate_startup "__main__" true; generate_startup "__lib__" false ;; let generate_boot common_ctx boot_classes init_classes = (* Write boot class too ... *) let base_dir = common_ctx.file in let boot_file = new_cpp_file base_dir ([],"__boot__") in let output_boot = (boot_file#write) in output_boot "#include \n\n"; List.iter ( fun class_path -> output_boot ("#include <" ^ ( join_class_path class_path "/" ) ^ ".h>\n") ) boot_classes; output_boot "\nvoid __boot_all()\n{\n"; output_boot "hx::RegisterResources( hx::GetResources() );\n"; List.iter ( fun class_path -> output_boot ("::" ^ ( join_class_path_remap class_path "::" ) ^ "_obj::__register();\n") ) boot_classes; List.iter ( fun class_path -> output_boot ("::" ^ ( join_class_path_remap class_path "::" ) ^ "_obj::__init__();\n") ) (List.rev init_classes); let dump_boot = List.iter ( fun class_path -> output_boot ("::" ^ ( join_class_path_remap class_path "::" ) ^ "_obj::__boot();\n") ) in dump_boot (List.filter (fun path -> is_cpp_class path ) (List.rev boot_classes)); dump_boot (List.filter (fun path -> not (is_cpp_class path) ) (List.rev boot_classes)); output_boot "}\n\n"; boot_file#close;; let generate_files common_ctx file_info = (* Write __files__ class too ... *) let base_dir = common_ctx.file in let files_file = new_cpp_file base_dir ([],"__files__") in let output_files = (files_file#write) in output_files "#include \n\n"; output_files "namespace hx {\n"; output_files "const char *__hxcpp_all_files[] = {\n"; output_files "#ifdef HXCPP_DEBUGGER\n"; List.iter ( fun file -> output_files (" " ^ file ^ ",\n" ) ) ( List.sort String.compare ( pmap_keys !file_info) ); output_files "#endif\n"; output_files " 0 };\n"; output_files "const char *__hxcpp_class_path[] = {\n"; output_files "#ifdef HXCPP_DEBUGGER\n"; List.iter ( fun file -> output_files (" \"" ^ file ^ "\",\n" ) ) (common_ctx.class_path @ common_ctx.std_path); output_files "#endif\n"; output_files " 0 };\n"; output_files "} // namespace hx\n"; files_file#close;; let begin_header_file output_h def_string = output_h ("#ifndef INCLUDED_" ^ def_string ^ "\n"); output_h ("#define INCLUDED_" ^ def_string ^ "\n\n"); output_h "#ifndef HXCPP_H\n"; output_h "#include \n"; output_h "#endif\n\n";; let end_header_file output_h def_string = output_h ("\n#endif /* INCLUDED_" ^ def_string ^ " */ \n");; let new_placed_cpp_file common_ctx class_path = let base_dir = common_ctx.file in if (Common.defined common_ctx Define.Vcproj ) then begin make_class_directories base_dir ("src"::[]); cached_source_writer ( base_dir ^ "/src/" ^ ( String.concat "-" (fst class_path) ) ^ "-" ^ (snd class_path) ^ ".cpp") end else new_cpp_file common_ctx.file class_path;; let generate_enum_files common_ctx enum_def super_deps meta file_info = let class_path = enum_def.e_path in let just_class_name = (snd class_path) in let class_name = just_class_name ^ "_obj" in let smart_class_name = ("::" ^ (join_class_path class_path "::") ) in (*let cpp_file = new_cpp_file common_ctx.file class_path in*) let cpp_file = new_placed_cpp_file common_ctx class_path in let output_cpp = (cpp_file#write) in let debug = false in let ctx = new_context common_ctx cpp_file debug file_info in if (debug) then print_endline ("Found enum definition:" ^ (join_class_path class_path "::" )); output_cpp "#include \n\n"; let referenced = find_referenced_types common_ctx (TEnumDecl enum_def) super_deps (Hashtbl.create 0) false false false in List.iter (add_include cpp_file) referenced; gen_open_namespace output_cpp class_path; output_cpp "\n"; PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in match constructor.ef_type with | TFun (args,_) -> output_cpp (smart_class_name ^ " " ^ class_name ^ "::" ^ name ^ "(" ^ (gen_tfun_arg_list args) ^")\n"); output_cpp (" { return hx::CreateEnum< " ^ class_name ^ " >(" ^ (str name) ^ "," ^ (string_of_int constructor.ef_index) ^ ",hx::DynamicArray(0," ^ (string_of_int (List.length args)) ^ ")" ); List.iter (fun (arg,_,_) -> output_cpp (".Add(" ^ (keyword_remap arg) ^ ")")) args; output_cpp "); }\n\n" | _ -> output_cpp ( smart_class_name ^ " " ^ class_name ^ "::" ^ name ^ ";\n\n" ) ) enum_def.e_constrs; output_cpp ("HX_DEFINE_CREATE_ENUM(" ^ class_name ^ ")\n\n"); output_cpp ("int " ^ class_name ^ "::__FindIndex(::String inName)\n{\n"); PMap.iter (fun _ constructor -> let name = constructor.ef_name in let idx = string_of_int constructor.ef_index in output_cpp (" if (inName==" ^ (str name) ^ ") return " ^ idx ^ ";\n") ) enum_def.e_constrs; output_cpp (" return super::__FindIndex(inName);\n"); output_cpp ("}\n\n"); let constructor_arg_count constructor = (match constructor.ef_type with | TFun(args,_) -> List.length args | _ -> 0 ) in (* Dynamic versions of constructors *) let dump_dynamic_constructor _ constr = let count = constructor_arg_count constr in if (count>0) then begin let nargs = string_of_int count in output_cpp ("STATIC_HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," ^ (keyword_remap constr.ef_name) ^ ",return)\n\n"); end in PMap.iter dump_dynamic_constructor enum_def.e_constrs; output_cpp ("int " ^ class_name ^ "::__FindArgCount(::String inName)\n{\n"); PMap.iter (fun _ constructor -> let name = constructor.ef_name in let count = string_of_int (constructor_arg_count constructor) in output_cpp (" if (inName==" ^ (str name) ^ ") return " ^ count ^ ";\n") ) enum_def.e_constrs; output_cpp (" return super::__FindArgCount(inName);\n"); output_cpp ("}\n\n"); (* Dynamic "Get" Field function - string version *) output_cpp ("Dynamic " ^ class_name ^ "::__Field(const ::String &inName,bool inCallProp)\n{\n"); let dump_constructor_test _ constr = output_cpp (" if (inName==" ^ (str constr.ef_name) ^ ") return " ^ (keyword_remap constr.ef_name) ); if ( (constructor_arg_count constr) > 0 ) then output_cpp "_dyn()"; output_cpp (";\n") in PMap.iter dump_constructor_test enum_def.e_constrs; output_cpp (" return super::__Field(inName,inCallProp);\n}\n\n"); output_cpp "static ::String sStaticFields[] = {\n"; let sorted = List.sort (fun f1 f2 -> (PMap.find f1 enum_def.e_constrs ).ef_index - (PMap.find f2 enum_def.e_constrs ).ef_index ) (pmap_keys enum_def.e_constrs) in List.iter (fun name -> output_cpp (" " ^ (str name) ^ ",\n") ) sorted; output_cpp " ::String(null()) };\n\n"; (* ENUM - Mark static as used by GC *) output_cpp "static void sMarkStatics(HX_MARK_PARAMS) {\n"; PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in match constructor.ef_type with | TFun (_,_) -> () | _ -> output_cpp (" HX_MARK_MEMBER_NAME(" ^ class_name ^ "::" ^ name ^ ",\"" ^ name ^ "\");\n") ) enum_def.e_constrs; output_cpp "};\n\n"; (* ENUM - Visit static as used by GC *) output_cpp "static void sVisitStatic(HX_VISIT_PARAMS) {\n"; output_cpp (" HX_VISIT_MEMBER_NAME(" ^ class_name ^ "::__mClass,\"__mClass\");\n"); PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in match constructor.ef_type with | TFun (_,_) -> () | _ -> output_cpp (" HX_VISIT_MEMBER_NAME(" ^ class_name ^ "::" ^ name ^ ",\"" ^ name ^ "\");\n") ) enum_def.e_constrs; output_cpp "};\n\n"; output_cpp "static ::String sMemberFields[] = { ::String(null()) };\n"; output_cpp ("Class " ^ class_name ^ "::__mClass;\n\n"); output_cpp ("Dynamic __Create_" ^ class_name ^ "() { return new " ^ class_name ^ "; }\n\n"); output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); let text_name = str (join_class_path class_path ".") in output_cpp ("\nhx::Static(__mClass) = hx::RegisterClass(" ^ text_name ^ ", hx::TCanCast< " ^ class_name ^ " >,sStaticFields,sMemberFields,\n"); output_cpp (" &__Create_" ^ class_name ^ ", &__Create,\n"); output_cpp (" &super::__SGetClass(), &Create" ^ class_name ^ ", sMarkStatics, sVisitStatic);\n"); output_cpp ("}\n\n"); output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); (match meta with | Some expr -> let ctx = new_context common_ctx cpp_file false file_info in find_local_functions_and_return_blocks_ctx ctx true expr; output_cpp ("__mClass->__meta__ = "); gen_expression ctx true expr; output_cpp ";\n" | _ -> () ); PMap.iter (fun _ constructor -> let name = constructor.ef_name in match constructor.ef_type with | TFun (_,_) -> () | _ -> output_cpp ( "hx::Static(" ^ (keyword_remap name) ^ ") = hx::CreateEnum< " ^ class_name ^ " >(" ^ (str name) ^ "," ^ (string_of_int constructor.ef_index) ^ ");\n" ) ) enum_def.e_constrs; output_cpp ("}\n\n"); output_cpp "\n"; gen_close_namespace output_cpp class_path; cpp_file#close; let h_file = new_header_file common_ctx.file class_path in let super = "hx::EnumBase_obj" in let output_h = (h_file#write) in let def_string = join_class_path class_path "_" in ctx.ctx_output <- output_h; begin_header_file output_h def_string; List.iter (gen_forward_decl h_file ) referenced; gen_open_namespace output_h class_path; output_h "\n\n"; output_h ("class " ^ class_name ^ " : public " ^ super ^ "\n"); output_h ("{\n typedef " ^ super ^ " super;\n"); output_h (" typedef " ^ class_name ^ " OBJ_;\n"); output_h "\n public:\n"; output_h (" " ^ class_name ^ "() {};\n"); output_h (" HX_DO_ENUM_RTTI;\n"); output_h (" static void __boot();\n"); output_h (" static void __register();\n"); output_h (" ::String GetEnumName( ) const { return " ^ (str (join_class_path class_path ".")) ^ "; }\n" ); output_h (" ::String __ToString() const { return " ^ (str (just_class_name ^ ".") )^ " + tag; }\n\n"); PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in output_h ( " static " ^ smart_class_name ^ " " ^ name ); match constructor.ef_type with | TFun (args,_) -> output_h ( "(" ^ (gen_tfun_arg_list args) ^");\n"); output_h ( " static Dynamic " ^ name ^ "_dyn();\n"); | _ -> output_h ";\n"; output_h ( " static inline " ^ smart_class_name ^ " " ^ name ^ "_dyn() { return " ^name ^ "; }\n" ); ) enum_def.e_constrs; output_h "};\n\n"; gen_close_namespace output_h class_path; end_header_file output_h def_string; h_file#close; let depend_referenced = find_referenced_types common_ctx (TEnumDecl enum_def) super_deps (Hashtbl.create 0) false true false in depend_referenced;; let list_iteri func in_list = let idx = ref 0 in List.iter (fun elem -> func !idx elem; idx := !idx + 1 ) in_list ;; let has_init_field class_def = match class_def.cl_init with | Some _ -> true | _ -> false;; let is_macro meta = Meta.has Meta.Macro meta ;; let access_str a = match a with | AccNormal -> "AccNormal" | AccNo -> "AccNo" | AccNever -> "AccNever" | AccResolve -> "AccResolve" | AccCall -> "AccCall" | AccInline -> "AccInline" | AccRequire(_,_) -> "AccRequire" ;; let generate_class_files common_ctx member_types super_deps constructor_deps class_def file_info scriptable = let class_path = class_def.cl_path in let class_name = (snd class_path) ^ "_obj" in let is_abstract_impl = match class_def.cl_kind with | KAbstractImpl _ -> true | _ -> false in let smart_class_name = (snd class_path) in (*let cpp_file = new_cpp_file common_ctx.file class_path in*) let cpp_file = new_placed_cpp_file common_ctx class_path in let output_cpp = (cpp_file#write) in let debug = false in let ctx = new_context common_ctx cpp_file debug file_info in ctx.ctx_class_name <- "::" ^ (join_class_path class_def.cl_path "::"); ctx.ctx_class_super_name <- (match class_def.cl_super with | Some (klass, params) -> class_string klass "_obj" params | _ -> ""); ctx.ctx_class_member_types <- member_types; if debug then print_endline ("Found class definition:" ^ ctx.ctx_class_name); let ptr_name = "hx::ObjectPtr< " ^ class_name ^ " >" in let constructor_type_var_list = match class_def.cl_constructor with | Some definition -> (match definition.cf_expr with | Some { eexpr = TFunction function_def } -> List.map (fun (v,o) -> gen_arg_type_name v.v_name o v.v_type "__o_") function_def.tf_args; | _ -> (match follow definition.cf_type with | TFun (args,_) -> List.map (fun (a,_,t) -> (type_string t,a) ) args | _ -> []) ) | _ -> [] in let constructor_var_list = List.map snd constructor_type_var_list in let constructor_type_args = String.concat "," (List.map (fun (t,a) -> t ^ " " ^ a) constructor_type_var_list) in let constructor_args = String.concat "," constructor_var_list in let implement_dynamic = implement_dynamic_here class_def in output_cpp "#include \n\n"; let field_integer_dynamic = scriptable || (has_field_integer_lookup class_def) in let field_integer_numeric = scriptable || (has_field_integer_numeric_lookup class_def) in let all_referenced = find_referenced_types ctx.ctx_common (TClassDecl class_def) super_deps constructor_deps false false scriptable in List.iter ( add_include cpp_file ) all_referenced; (* All interfaces (and sub-interfaces) implemented *) let implemented_hash = Hashtbl.create 0 in List.iter (fun imp -> let rec descend_interface interface = let imp_path = (fst interface).cl_path in let interface_name = "::" ^ (join_class_path imp_path "::" ) in if ( not (Hashtbl.mem implemented_hash interface_name) ) then begin Hashtbl.add implemented_hash interface_name (); List.iter descend_interface (fst interface).cl_implements; end in descend_interface imp ) (real_interfaces class_def.cl_implements); let implemented = hash_keys implemented_hash in if (scriptable) then output_cpp "#include \n"; output_cpp ( get_code class_def.cl_meta Meta.CppFileCode ); gen_open_namespace output_cpp class_path; output_cpp "\n"; output_cpp ( get_code class_def.cl_meta Meta.CppNamespaceCode ); if (not class_def.cl_interface) then begin output_cpp ("Void " ^ class_name ^ "::__construct(" ^ constructor_type_args ^ ")\n{\n"); (match class_def.cl_constructor with | Some definition -> (match definition.cf_expr with | Some { eexpr = TFunction function_def } -> hx_stack_push ctx output_cpp smart_class_name "new" function_def.tf_expr.epos; if (has_default_values function_def.tf_args) then begin generate_default_values ctx function_def.tf_args "__o_"; gen_expression ctx false (to_block function_def.tf_expr); output_cpp ";\n"; end else begin gen_expression ctx false (to_block function_def.tf_expr); output_cpp ";\n"; (*gen_expression (new_context common_ctx cpp_file debug ) false function_def.tf_expr;*) end | _ -> () ) | _ -> ()); output_cpp " return null();\n"; output_cpp "}\n\n"; (* Destructor goes in the cpp file so we can "see" the full definition of the member vars *) output_cpp ( class_name ^ "::~" ^ class_name ^ "() { }\n\n"); output_cpp ("Dynamic " ^ class_name ^ "::__CreateEmpty() { return new " ^ class_name ^ "; }\n"); output_cpp (ptr_name ^ " " ^ class_name ^ "::__new(" ^constructor_type_args ^")\n"); let create_result () = output_cpp ("{ " ^ ptr_name ^ " result = new " ^ class_name ^ "();\n"); in create_result (); output_cpp (" result->__construct(" ^ constructor_args ^ ");\n"); output_cpp (" return result;}\n\n"); output_cpp ("Dynamic " ^ class_name ^ "::__Create(hx::DynamicArray inArgs)\n"); create_result (); output_cpp (" result->__construct(" ^ (array_arg_list constructor_var_list) ^ ");\n"); output_cpp (" return result;}\n\n"); if ( (List.length implemented) > 0 ) then begin output_cpp ("hx::Object *" ^ class_name ^ "::__ToInterface(const hx::type_info &inType) {\n"); List.iter (fun interface_name -> output_cpp (" if (inType==typeid( " ^ interface_name ^ "_obj)) " ^ "return operator " ^ interface_name ^ "_obj *();\n"); ) implemented; output_cpp (" return super::__ToInterface(inType);\n}\n\n"); end; end; (match class_def.cl_init with | Some expression -> output_cpp ("void " ^ class_name^ "::__init__() {\n"); hx_stack_push ctx output_cpp smart_class_name "__init__" expression.epos; gen_expression (new_context common_ctx cpp_file debug file_info) false (to_block expression); output_cpp "}\n\n"; | _ -> ()); let statics_except_meta = (List.filter (fun static -> static.cf_name <> "__meta__") class_def.cl_ordered_statics) in let implemented_fields = List.filter should_implement_field statics_except_meta in let dump_field_name = (fun field -> output_cpp (" " ^ (str field.cf_name) ^ ",\n")) in let implemented_instance_fields = List.filter should_implement_field class_def.cl_ordered_fields in List.iter (gen_field ctx class_def class_name smart_class_name false class_def.cl_interface) class_def.cl_ordered_fields; List.iter (gen_field ctx class_def class_name smart_class_name true class_def.cl_interface) statics_except_meta; output_cpp "\n"; (* Initialise non-static variables *) if (not class_def.cl_interface) then begin output_cpp (class_name ^ "::" ^ class_name ^ "()\n{\n"); if (implement_dynamic) then output_cpp " HX_INIT_IMPLEMENT_DYNAMIC;\n"; List.iter (fun field -> let remap_name = keyword_remap field.cf_name in match field.cf_expr with | Some { eexpr = TFunction function_def } -> if (is_dynamic_haxe_method field) then output_cpp (" " ^ remap_name ^ " = new __default_" ^ remap_name ^ "(this);\n") | _ -> () ) class_def.cl_ordered_fields; output_cpp "}\n\n"; let dump_field_iterator macro field = if (is_data_member field) then begin let remap_name = keyword_remap field.cf_name in output_cpp (" " ^ macro ^ "(" ^ remap_name ^ ",\"" ^ field.cf_name^ "\");\n"); (match field.cf_kind with Var { v_read = AccCall } when (is_dynamic_accessor ("get_" ^ field.cf_name) "get" field class_def) -> let name = "get_" ^ field.cf_name in output_cpp ("\t" ^ macro ^ "(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n" ) | _ -> ()); (match field.cf_kind with Var { v_write = AccCall } when (is_dynamic_accessor ("set_" ^ field.cf_name) "set" field class_def) -> let name = "set_" ^ field.cf_name in output_cpp ("\t" ^ macro ^ "(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n" ) | _ -> ()); end in (* MARK function - explicitly mark all child pointers *) output_cpp ("void " ^ class_name ^ "::__Mark(HX_MARK_PARAMS)\n{\n"); output_cpp (" HX_MARK_BEGIN_CLASS(" ^ smart_class_name ^ ");\n"); if (implement_dynamic) then output_cpp " HX_MARK_DYNAMIC;\n"; List.iter (dump_field_iterator "HX_MARK_MEMBER_NAME") implemented_instance_fields; (match class_def.cl_super with Some _ -> output_cpp " super::__Mark(HX_MARK_ARG);\n" | _ -> () ); output_cpp " HX_MARK_END_CLASS();\n"; output_cpp "}\n\n"; (* Visit function - explicitly visit all child pointers *) output_cpp ("void " ^ class_name ^ "::__Visit(HX_VISIT_PARAMS)\n{\n"); if (implement_dynamic) then output_cpp " HX_VISIT_DYNAMIC;\n"; List.iter (dump_field_iterator "HX_VISIT_MEMBER_NAME") implemented_instance_fields; (match class_def.cl_super with Some _ -> output_cpp " super::__Visit(HX_VISIT_ARG);\n" | _ -> () ); output_cpp "}\n\n"; let variable_field field = (match field.cf_expr with | Some { eexpr = TFunction function_def } -> is_dynamic_haxe_method field | _ -> true) in let is_readable field = (match field.cf_kind with | Var { v_read = AccNever } | Var { v_read = AccInline } -> false | Var _ when is_abstract_impl -> false | _ -> true) in let is_writable field = (match field.cf_kind with | Var { v_write = AccNever } | Var { v_read = AccInline } -> false | Var _ when is_abstract_impl -> false | _ -> true) in let reflective field = not (Meta.has Meta.Unreflective field.cf_meta) in let reflect_fields = List.filter reflective (statics_except_meta @ class_def.cl_ordered_fields) in let reflect_writable = List.filter is_writable reflect_fields in let reflect_readable = List.filter is_readable reflect_fields in let reflect_write_variables = List.filter variable_field reflect_writable in let dump_quick_field_test fields = if ( (List.length fields) > 0) then begin let len = function (_,l,_) -> l in let sfields = List.sort (fun f1 f2 -> (len f1)-(len f2)) fields in let len_case = ref (-1) in output_cpp " switch(inName.length) {\n"; List.iter (fun (field,l,result) -> if (l <> !len_case) then begin if (!len_case>=0) then output_cpp " break;\n"; output_cpp (" case " ^ (string_of_int l) ^ ":\n"); len_case := l; end; output_cpp (" if (HX_FIELD_EQ(inName,\"" ^ (Ast.s_escape field) ^ "\") ) { " ^ result ^ " }\n"); ) sfields; output_cpp " }\n"; end; in (* Dynamic "Get" Field function - string version *) output_cpp ("Dynamic " ^ class_name ^ "::__Field(const ::String &inName,bool inCallProp)\n{\n"); let get_field_dat = List.map (fun f -> (f.cf_name, String.length f.cf_name, "return " ^ (match f.cf_kind with | Var { v_read = AccCall } when is_extern_field f -> (keyword_remap ("get_" ^ f.cf_name)) ^ "()" | Var { v_read = AccCall } -> "inCallProp ? " ^ (keyword_remap ("get_" ^ f.cf_name)) ^ "() : " ^ ((keyword_remap f.cf_name) ^ if (variable_field f) then "" else "_dyn()") | _ -> ((keyword_remap f.cf_name) ^ if (variable_field f) then "" else "_dyn()") ) ^ ";" ) ) in dump_quick_field_test (get_field_dat reflect_readable); if (implement_dynamic) then output_cpp " HX_CHECK_DYNAMIC_GET_FIELD(inName);\n"; output_cpp (" return super::__Field(inName,inCallProp);\n}\n\n"); (* Dynamic "Get" Field function - int version *) if ( field_integer_numeric || field_integer_dynamic) then begin let dump_static_ids = (fun field -> let remap_name = keyword_remap field.cf_name in output_cpp ("static int __id_" ^ remap_name ^ " = __hxcpp_field_to_id(\"" ^ (field.cf_name) ^ "\");\n"); ) in List.iter dump_static_ids reflect_readable; output_cpp "\n\n"; let output_ifield return_type function_name all_fields = output_cpp (return_type ^" " ^ class_name ^ "::" ^ function_name ^ "(int inFieldID)\n{\n"); let dump_field_test = (fun f -> let remap_name = keyword_remap f.cf_name in output_cpp (" if (inFieldID==__id_" ^ remap_name ^ ") return " ^ ( if (return_type="Float") then "hx::ToDouble( " else "" ) ^ (match f.cf_kind with | Var { v_read = AccCall } -> (keyword_remap ("get_" ^ f.cf_name)) ^ "()" | _ -> (remap_name ^ if ( variable_field f) then "" else "_dyn()") ) ^ ( if (return_type="Float") then " ) " else "" ) ^ ";\n"); ) in List.iter dump_field_test (List.filter (fun f -> all_fields || (is_numeric_field f)) reflect_readable); if (implement_dynamic) then output_cpp " HX_CHECK_DYNAMIC_GET_INT_FIELD(inFieldID);\n"; output_cpp (" return super::" ^ function_name ^ "(inFieldID);\n}\n\n"); in if (field_integer_dynamic) then output_ifield "Dynamic" "__IField" true; if (field_integer_numeric) then output_ifield "double" "__INumField" false; end; (* Dynamic "Set" Field function *) output_cpp ("Dynamic " ^ class_name ^ "::__SetField(const ::String &inName,const Dynamic &inValue,bool inCallProp)\n{\n"); let set_field_dat = List.map (fun f -> let default_action = (keyword_remap f.cf_name) ^ "=inValue.Cast< " ^ (type_string f.cf_type) ^ " >();" ^ " return inValue;" in (f.cf_name, String.length f.cf_name, (match f.cf_kind with | Var { v_write = AccCall } when is_extern_field f -> "return " ^ (keyword_remap ("set_" ^ f.cf_name)) ^ "(inValue);" | Var { v_write = AccCall } -> "if (inCallProp) return " ^ (keyword_remap ("set_" ^ f.cf_name)) ^ "(inValue);" ^ default_action | _ -> default_action ) ) ) in dump_quick_field_test (set_field_dat reflect_write_variables); if (implement_dynamic) then begin output_cpp (" try { return super::__SetField(inName,inValue,inCallProp); }\n"); output_cpp (" catch(Dynamic e) { HX_DYNAMIC_SET_FIELD(inName,inValue); }\n"); output_cpp " return inValue;\n}\n\n"; end else output_cpp (" return super::__SetField(inName,inValue,inCallProp);\n}\n\n"); (* For getting a list of data members (eg, for serialization) *) let append_field = (fun field -> output_cpp (" outFields->push(" ^( str field.cf_name )^ ");\n")) in let is_data_field field = (match follow field.cf_type with | TFun _ -> false | _ -> true) in output_cpp ("void " ^ class_name ^ "::__GetFields(Array< ::String> &outFields)\n{\n"); List.iter append_field (List.filter is_data_field class_def.cl_ordered_fields); if (implement_dynamic) then output_cpp " HX_APPEND_DYNAMIC_FIELDS(outFields);\n"; output_cpp " super::__GetFields(outFields);\n"; output_cpp "};\n\n"; output_cpp "static ::String sStaticFields[] = {\n"; List.iter dump_field_name implemented_fields; output_cpp " String(null()) };\n\n"; end; (* cl_interface *) output_cpp "static ::String sMemberFields[] = {\n"; List.iter dump_field_name implemented_instance_fields; output_cpp " String(null()) };\n\n"; (* Mark static variables as used *) output_cpp "static void sMarkStatics(HX_MARK_PARAMS) {\n"; output_cpp (" HX_MARK_MEMBER_NAME(" ^ class_name ^ "::__mClass,\"__mClass\");\n"); List.iter (fun field -> if (is_data_member field) then output_cpp (" HX_MARK_MEMBER_NAME(" ^ class_name ^ "::" ^ (keyword_remap field.cf_name) ^ ",\"" ^ field.cf_name ^ "\");\n") ) implemented_fields; output_cpp "};\n\n"; (* Visit static variables *) output_cpp "static void sVisitStatics(HX_VISIT_PARAMS) {\n"; output_cpp (" HX_VISIT_MEMBER_NAME(" ^ class_name ^ "::__mClass,\"__mClass\");\n"); List.iter (fun field -> if (is_data_member field) then output_cpp (" HX_VISIT_MEMBER_NAME(" ^ class_name ^ "::" ^ (keyword_remap field.cf_name) ^ ",\"" ^ field.cf_name ^ "\");\n") ) implemented_fields; output_cpp "};\n\n"; if (scriptable ) then begin let dump_script_field idx (field,f_args,return_t) = let args = if (class_def.cl_interface) then gen_tfun_interface_arg_list f_args else gen_tfun_arg_list f_args in let names = List.map (fun (n,_,_) -> keyword_remap n) f_args in let return_type = type_string return_t in let ret = if (return_type="Void") then " " else "return " in let name = keyword_remap field.cf_name in let vtable = "__scriptVTable[" ^ (string_of_int idx) ^ "] " in let args_varray = (List.fold_left (fun l n -> l ^ ".Add(" ^ n ^ ")") "Array()" names) in let args_comma = List.fold_left (fun l n -> l ^ "," ^ n) "" names in output_cpp (" " ^ return_type ^ " " ^ name ^ "( " ^ args ^ " ) { "); if (class_def.cl_interface) then begin output_cpp (" " ^ ret ^ "mDelegate->__Field(HX_CSTRING(\"" ^ field.cf_name ^ "\"),false)"); if (List.length names <= 5) then output_cpp ("->__run(" ^ (String.concat "," names) ^ ")") else output_cpp ("->__Run(" ^ args_varray ^ ")"); output_cpp ";return null(); }\n"; end else begin output_cpp (" if (" ^ vtable ^ ") " ^ ret); if (List.length names <= 5) then output_cpp("hx::ScriptableCall" ^ (string_of_int (List.length names)) ^ "("^ vtable ^ ",this" ^ args_comma ^ ");") else output_cpp("hx::ScriptableCallMult("^ vtable ^ ",this," ^ args_varray^ "->Pointer());"); output_cpp (" else " ^ ret ^ class_name ^ "::" ^ name ^ "(" ^ (String.concat "," names)^ "); return null(); }\n"); end in let sctipt_name = class_name ^ "__scriptable" in output_cpp ("class " ^ sctipt_name ^ " : public " ^ class_name ^ " {\n" ); output_cpp (" typedef "^sctipt_name ^" __ME;\n"); if (class_def.cl_interface) then output_cpp (" HX_DEFINE_SCRIPTABLE_INTERFACE\n") else begin output_cpp (" HX_DEFINE_SCRIPTABLE(HX_ARR_LIST" ^ (string_of_int (List.length constructor_var_list) ) ^ ")\n"); if (not implement_dynamic) then output_cpp " HX_DEFINE_SCRIPTABLE_DYNAMIC;\n"; end; let functions = all_virtual_functions class_def in list_iteri dump_script_field functions; output_cpp ("};\n\n"); if (not class_def.cl_interface) then begin output_cpp "static String __scriptableFunctionNames[] = {\n"; List.iter (fun (f,_,_) -> output_cpp (" HX_CSTRING(\"" ^ f.cf_name ^ "\"),\n" ) ) functions; output_cpp " String(null()) };\n"; end; end; (* Initialise static in boot function ... *) if (not class_def.cl_interface) then begin (* Remap the specialised "extern" classes back to the generic names *) let class_name_text = match class_path with | path -> join_class_path path "." in output_cpp ("Class " ^ class_name ^ "::__mClass;\n\n"); output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); output_cpp (" hx::Static(__mClass) = hx::RegisterClass(" ^ (str class_name_text) ^ ", hx::TCanCast< " ^ class_name ^ "> ,sStaticFields,sMemberFields,\n"); output_cpp (" &__CreateEmpty, &__Create,\n"); output_cpp (" &super::__SGetClass(), 0, sMarkStatics, sVisitStatics);\n"); if (scriptable) then output_cpp (" HX_SCRIPTABLE_REGISTER_CLASS(\""^class_name_text^"\"," ^ class_name ^ ");\n"); output_cpp ("}\n\n"); end else begin let class_name_text = join_class_path class_path "." in output_cpp ("Class " ^ class_name ^ "::__mClass;\n\n"); output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); output_cpp (" hx::Static(__mClass) = hx::RegisterClass(" ^ (str class_name_text) ^ ", hx::TCanCast< " ^ class_name ^ "> ,0,sMemberFields,\n"); output_cpp (" 0, 0,\n"); output_cpp (" &super::__SGetClass(), 0, sMarkStatics, sVisitStatics);\n"); if (scriptable) then output_cpp (" HX_SCRIPTABLE_REGISTER_INTERFACE(\""^class_name_text^"\"," ^ class_name ^ ");\n"); output_cpp ("}\n\n"); end; output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); List.iter (gen_field_init ctx ) (List.filter should_implement_field class_def.cl_ordered_statics); output_cpp ("}\n\n"); gen_close_namespace output_cpp class_path; cpp_file#close; let h_file = new_header_file common_ctx.file class_path in let super = match class_def.cl_super with | Some (klass,params) -> (class_string klass "_obj" params) | _ -> if (class_def.cl_interface) then "hx::Interface" else "hx::Object" in let output_h = (h_file#write) in let def_string = join_class_path class_path "_" in ctx.ctx_output <- output_h; begin_header_file output_h def_string; (* Include the real header file for the super class *) (match class_def.cl_super with | Some super -> let super_path = (fst super).cl_path in output_h ("#include <" ^ ( join_class_path super_path "/" ) ^ ".h>\n") | _ -> () ); (* And any interfaces ... *) List.iter (fun imp-> let imp_path = (fst imp).cl_path in output_h ("#include <" ^ ( join_class_path imp_path "/" ) ^ ".h>\n") ) (real_interfaces class_def.cl_implements); (* Only need to foreward-declare classes that are mentioned in the header file (ie, not the implementation) *) let referenced = find_referenced_types ctx.ctx_common (TClassDecl class_def) super_deps (Hashtbl.create 0) true false scriptable in List.iter ( gen_forward_decl h_file ) referenced; output_h ( get_code class_def.cl_meta Meta.HeaderCode ); gen_open_namespace output_h class_path; output_h "\n\n"; output_h ( get_code class_def.cl_meta Meta.HeaderNamespaceCode ); let extern_class = Common.defined common_ctx Define.DllExport in let attribs = "HXCPP_" ^ (if extern_class then "EXTERN_" else "") ^ "CLASS_ATTRIBUTES " in output_h ("class " ^ attribs ^ " " ^ class_name ^ " : public " ^ super ); output_h "{\n public:\n"; output_h (" typedef " ^ super ^ " super;\n"); output_h (" typedef " ^ class_name ^ " OBJ_;\n"); if (not class_def.cl_interface) then begin output_h (" " ^ class_name ^ "();\n"); output_h (" Void __construct(" ^ constructor_type_args ^ ");\n"); output_h "\n public:\n"; output_h (" static " ^ptr_name^ " __new(" ^constructor_type_args ^");\n"); output_h (" static Dynamic __CreateEmpty();\n"); output_h (" static Dynamic __Create(hx::DynamicArray inArgs);\n"); output_h (" ~" ^ class_name ^ "();\n\n"); output_h (" HX_DO_RTTI;\n"); if (field_integer_dynamic) then output_h " Dynamic __IField(int inFieldID);\n"; if (field_integer_numeric) then output_h " double __INumField(int inFieldID);\n"; if (implement_dynamic) then output_h (" HX_DECLARE_IMPLEMENT_DYNAMIC;\n"); output_h (" static void __boot();\n"); output_h (" static void __register();\n"); output_h (" void __Mark(HX_MARK_PARAMS);\n"); output_h (" void __Visit(HX_VISIT_PARAMS);\n"); List.iter (fun interface_name -> output_h (" inline operator " ^ interface_name ^ "_obj *()\n " ^ "{ return new " ^ interface_name ^ "_delegate_< " ^ class_name ^" >(this); }\n" ); ) implemented; if ( (List.length implemented) > 0 ) then output_h " hx::Object *__ToInterface(const hx::type_info &inType);\n"; if (has_init_field class_def) then output_h " static void __init__();\n\n"; output_h (" ::String __ToString() const { return " ^ (str smart_class_name) ^ "; }\n\n"); end else begin output_h (" HX_DO_INTERFACE_RTTI;\n"); output_h (" static void __boot();\n"); end; (match class_def.cl_array_access with | Some t -> output_h (" typedef " ^ (type_string t) ^ " __array_access;\n") | _ -> ()); let interface = class_def.cl_interface in List.iter (gen_member_def ctx class_def false interface) (List.filter should_implement_field class_def.cl_ordered_fields); List.iter (gen_member_def ctx class_def true interface) (List.filter should_implement_field class_def.cl_ordered_statics); output_h ( get_code class_def.cl_meta Meta.HeaderClassCode ); output_h "};\n\n"; if (class_def.cl_interface) then begin output_h ("#define DELEGATE_" ^ (join_class_path class_path "_" ) ^ " \\\n"); List.iter (fun field -> match follow field.cf_type, field.cf_kind with | _, Method MethDynamic -> () | TFun (args,return_type), Method _ -> (* TODO : virtual ? *) let remap_name = keyword_remap field.cf_name in output_h ( "virtual " ^ (type_string return_type) ^ " " ^ remap_name ^ "( " ); output_h (gen_tfun_interface_arg_list args); output_h (") { return mDelegate->" ^ remap_name^ "("); output_h (String.concat "," (List.map (fun (name,opt,typ) -> (keyword_remap name)) args)); output_h ");} \\\n"; output_h ("virtual Dynamic " ^ remap_name ^ "_dyn() { return mDelegate->" ^ remap_name ^ "_dyn();} \\\n"); | _ -> () ) class_def.cl_ordered_fields; output_h ("\n\n"); output_h ("template\n"); output_h ("class " ^ smart_class_name ^ "_delegate_ : public " ^ class_name^"\n"); output_h "{\n protected:\n"; output_h (" IMPL *mDelegate;\n"); output_h " public:\n"; output_h (" " ^ smart_class_name ^ "_delegate_(IMPL *inDelegate) : mDelegate(inDelegate) {}\n"); output_h (" hx::Object *__GetRealObject() { return mDelegate; }\n"); output_h (" void __Visit(HX_VISIT_PARAMS) { HX_VISIT_OBJECT(mDelegate); }\n"); let rec dump_delegate interface = output_h (" DELEGATE_" ^ (join_class_path interface.cl_path "_" ) ^ "\n"); match interface.cl_super with | Some super -> dump_delegate (fst super) | _ -> (); in dump_delegate class_def; output_h "};\n\n"; end; gen_close_namespace output_h class_path; end_header_file output_h def_string; h_file#close; let depend_referenced = find_referenced_types ctx.ctx_common (TClassDecl class_def) super_deps constructor_deps false true false in depend_referenced;; let write_resources common_ctx = let resource_file = new_cpp_file common_ctx.file ([],"__resources__") in resource_file#write "#include \n\n"; let idx = ref 0 in Hashtbl.iter (fun _ data -> resource_file#write_i ("static unsigned char __res_" ^ (string_of_int !idx) ^ "[] = {\n"); for i = 0 to String.length data - 1 do let code = Char.code (String.unsafe_get data i) in resource_file#write (Printf.sprintf "0x%.2x, " code); if ( (i mod 10) = 9) then resource_file#write "\n"; done; resource_file#write ("};\n"); incr idx; ) common_ctx.resources; idx := 0; resource_file#write "hx::Resource __Resources[] ="; resource_file#begin_block; Hashtbl.iter (fun name data -> resource_file#write_i ("{ " ^ (str name) ^ "," ^ (string_of_int (String.length data)) ^ "," ^ "__res_" ^ (string_of_int !idx) ^ " },\n"); incr idx; ) common_ctx.resources; resource_file#write_i "{String(null()),0,0}"; resource_file#end_block_line; resource_file#write ";\n\n"; resource_file#write "namespace hx { Resource *GetResources() { return __Resources; } } \n\n"; resource_file#close;; let write_build_data filename classes main_deps build_extra exe_name = let buildfile = open_out filename in let add_class_to_buildfile class_def = let class_path = fst class_def in let deps = snd class_def in let cpp = (join_class_path class_path "/") ^ ".cpp" in output_string buildfile ( " \n" ); let project_deps = List.filter (fun path -> not (is_internal_class path) ) deps in List.iter (fun path-> output_string buildfile (" file | _ -> "include/" ^ (join_class_path path "/") ^ ".h" ) ^ "\"/>\n") ) project_deps; output_string buildfile ( " \n" ) in output_string buildfile "\n"; output_string buildfile "\n"; output_string buildfile "\n"; List.iter add_class_to_buildfile classes; add_class_to_buildfile ( ( [] , "__boot__") , [] ); add_class_to_buildfile ( ( [] , "__files__") , [] ); add_class_to_buildfile ( ( [] , "__resources__") , [] ); output_string buildfile "\n"; output_string buildfile "\n"; output_string buildfile "\n"; add_class_to_buildfile ( ( [] , "__lib__") , main_deps ); output_string buildfile "\n"; output_string buildfile "\n"; output_string buildfile "\n"; add_class_to_buildfile ( ( [] , "__main__") , main_deps ); output_string buildfile "\n"; output_string buildfile ("\n"); output_string buildfile "\n"; output_string buildfile build_extra; output_string buildfile "\n"; close_out buildfile;; let write_build_options filename defines = let writer = cached_source_writer filename in writer#write ( defines ^ "\n"); let cmd = Unix.open_process_in "haxelib path hxcpp" in writer#write (Pervasives.input_line cmd); Pervasives.ignore (Unix.close_process_in cmd); writer#close;; let create_member_types common_ctx = let result = Hashtbl.create 0 in let add_member class_name interface member = match follow member.cf_type, member.cf_kind with | _, Var _ when interface -> () | _, Method MethDynamic when interface -> () | TFun (_,ret), _ -> (*print_endline (class_name ^ "." ^ member.cf_name ^ "=" ^ (type_string ret) );*) Hashtbl.add result (class_name ^ "." ^ member.cf_name) (type_string ret) | _,_ when not interface -> Hashtbl.add result (class_name ^ "." ^ member.cf_name) (type_string member.cf_type) | _ -> () in List.iter (fun object_def -> (match object_def with | TClassDecl class_def -> let class_name = "::" ^ (join_class_path class_def.cl_path "::") in let rec add_all_fields class_def = (match class_def.cl_super with Some super -> add_all_fields (fst super) | _->();); List.iter (add_member class_name class_def.cl_interface) class_def.cl_ordered_fields; List.iter (add_member class_name class_def.cl_interface) class_def.cl_ordered_statics in add_all_fields class_def | _ -> ( ) ) ) common_ctx.types; result;; (* Builds inheritance tree, so header files can include parents defs. *) let create_super_dependencies common_ctx = let result = Hashtbl.create 0 in List.iter (fun object_def -> (match object_def with | TClassDecl class_def when not class_def.cl_extern -> let deps = ref [] in (match class_def.cl_super with Some super -> if not (fst super).cl_extern then deps := ((fst super).cl_path) :: !deps | _ ->() ); List.iter (fun imp -> deps := (fst imp).cl_path :: !deps) (real_interfaces class_def.cl_implements); Hashtbl.add result class_def.cl_path !deps; | TEnumDecl enum_def when not enum_def.e_extern -> Hashtbl.add result enum_def.e_path []; | _ -> () ); ) common_ctx.types; result;; let create_constructor_dependencies common_ctx = let result = Hashtbl.create 0 in List.iter (fun object_def -> (match object_def with | TClassDecl class_def when not class_def.cl_extern -> (match class_def.cl_constructor with | Some func_def -> Hashtbl.add result class_def.cl_path func_def | _ -> () ) | _ -> () ); ) common_ctx.types; result;; let rec s_type t = let result = match follow t with | TMono r -> (match !r with | None -> "Dynamic" | Some t -> s_type t) | TEnum (e,tl) -> Ast.s_type_path e.e_path ^ s_type_params tl | TInst (c,tl) -> Ast.s_type_path c.cl_path ^ s_type_params tl | TType (t,tl) -> Ast.s_type_path t.t_path ^ s_type_params tl | TAbstract (a,tl) -> Ast.s_type_path a.a_path ^ s_type_params tl | TFun ([],t) -> "Void -> " ^ s_fun t false | TFun (l,t) -> String.concat " -> " (List.map (fun (s,b,t) -> (if b then "?" else "") ^ (""(*if s = "" then "" else s ^ " : "*)) ^ s_fun t true ) l) ^ " -> " ^ s_fun t false | TAnon a -> let fl = PMap.fold (fun f acc -> ((if Meta.has Meta.Optional f.cf_meta then " ?" else " ") ^ f.cf_name ^ " : " ^ s_type f.cf_type) :: acc) a.a_fields [] in "{" ^ (if not (is_closed a) then "+" else "") ^ String.concat "," fl ^ " }" | TDynamic t2 -> "Dynamic" ^ s_type_params (if t == t2 then [] else [t2]) | TLazy f -> s_type (!f()) in if result="Array" then "haxe.io.BytesData" else result and s_fun t void = match follow t with | TFun _ -> "(" ^ s_type t ^ ")" | TEnum ({ e_path = ([],"Void") },[]) when void -> "(" ^ s_type t ^ ")" | TAbstract ({ a_path = ([],"Void") },[]) when void -> "(" ^ s_type t ^ ")" | TMono r -> (match !r with | None -> s_type t | Some t -> s_fun t void) | TLazy f -> s_fun (!f()) void | _ -> (s_type t) and s_type_params = function | [] -> "" | l -> "<" ^ String.concat ", " (List.map s_type l) ^ ">" ;; let gen_extern_class common_ctx class_def file_info = let file = new_source_file common_ctx.file "extern" ".hx" class_def.cl_path in let path = class_def.cl_path in let filterPath = fst path @ [snd path] in let rec remove_prefix field t = match t with | TInst ({cl_path=[f],suffix } as cval ,tl) when f=field -> TInst ( { cval with cl_path = ([],suffix) }, List.map (remove_prefix field) tl) | TInst ({cl_path=cpath,suffix } as cval ,tl) when cpath=filterPath -> TInst ( { cval with cl_path = ([],suffix) }, List.map (remove_prefix field) tl) | TInst (cval,tl) -> TInst ( cval, List.map (remove_prefix field) tl) (*| TInst ({cl_path=prefix} as cval ,tl) -> TInst ( { cval with cl_path = ([],snd cval.cl_path) }, List.map (remove_prefix field) tl)*) | t -> Type.map (remove_prefix field) t in let params = function [] -> "" | l -> "<" ^ (String.concat "," (List.map (fun (n,t) -> n) l) ^ ">") in let output = file#write in let print_field stat f = let s_type t = s_type (remove_prefix f.cf_name t) in let args = function TFun (args,_) -> String.concat "," (List.map (fun (name,opt,t) -> (if opt then "?" else "") ^ name ^":"^ (s_type t)) args) | _ -> "" in let ret = function TFun (_,ret) -> s_type ret | _ -> "Dynamic" in let override = if (is_override class_def f.cf_name ) then "override " else "" in output ("\t" ^ (if stat then "static " else "") ^ (if f.cf_public then "public " else "") ); let s_access mode op name = match mode with | AccNormal -> "default" | AccNo -> "null" | AccNever -> "never" | AccResolve -> "resolve" | AccCall -> op ^ "_" ^ name | AccInline -> "default" | AccRequire (n,_) -> "require " ^ n in (match f.cf_kind, f.cf_name with | Var { v_read = AccInline; v_write = AccNever },_ -> (match f.cf_expr with Some expr -> output ("inline var " ^ f.cf_name ^ ":" ^ (s_type f.cf_type) ^ "=" ); let ctx = (new_extern_context common_ctx file false file_info) in gen_expression ctx true expr; | _ -> () ) | Var { v_read = AccNormal; v_write = AccNormal },_ -> output ("var " ^ f.cf_name ^ ":" ^ (s_type f.cf_type)) | Var v,_ -> output ("var " ^ f.cf_name ^ "(" ^ (s_access v.v_read "get" f.cf_name) ^ "," ^ (s_access v.v_write "set" f.cf_name) ^ "):" ^ (s_type f.cf_type)) | Method _, "new" -> output ("function new(" ^ (args f.cf_type) ^ "):Void") | Method MethDynamic, _ -> output ("dynamic function " ^ f.cf_name ^ (params f.cf_params) ^ "(" ^ (args f.cf_type) ^ "):" ^ (ret f.cf_type) ) | Method _, _ -> output (override ^ "function " ^ f.cf_name ^ (params f.cf_params) ^ "(" ^ (args f.cf_type) ^ "):" ^ (ret f.cf_type) ) ); output ";\n\n"; in let s_type t = s_type (remove_prefix "*" t) in let c = class_def in output ( "package " ^ (String.concat "." (fst path)) ^ ";\n" ); output ( "@:include extern " ^ (if c.cl_private then "private " else "") ^ (if c.cl_interface then "interface" else "class") ^ " " ^ (snd path) ^ (params c.cl_types) ); (match c.cl_super with None -> () | Some (c,pl) -> output (" extends " ^ (s_type (TInst (c,pl))))); List.iter (fun (c,pl) -> output ( " implements " ^ (s_type (TInst (c,pl))))) (real_interfaces c.cl_implements); (match c.cl_dynamic with None -> () | Some t -> output (" implements Dynamic<" ^ (s_type t) ^ ">")); (match c.cl_array_access with None -> () | Some t -> output (" implements ArrayAccess<" ^ (s_type t) ^ ">")); output "{\n"; (match c.cl_constructor with | None -> () | Some f -> print_field false f); let is_public f = f.cf_public in List.iter (print_field false) (List.filter is_public c.cl_ordered_fields); List.iter (print_field true) (List.filter is_public c.cl_ordered_statics); output "}"; output "\n"; file#close ;; let gen_extern_enum common_ctx enum_def file_info = let path = enum_def.e_path in let file = new_source_file common_ctx.file "extern" ".hx" path in let output = file#write in let params = function [] -> "" | l -> "<" ^ (String.concat "," (List.map (fun (n,t) -> n) l) ^ ">") in output ( "package " ^ (String.concat "." (fst path)) ^ ";\n" ); output ( "@:include extern " ^ (if enum_def.e_private then "private " else "") ^ " enum " ^ (snd path) ^ (params enum_def.e_types) ); output " {\n"; PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in match constructor.ef_type with | TFun (args,_) -> output ( name ^ "(" ); output ( String.concat "," (List.map (fun (arg,_,t) -> arg ^ ":" ^ (s_type t) ) args) ); output ");\n\n"; | _ -> output ( name ^ ";\n\n" ) ) enum_def.e_constrs; output "}\n"; file#close ;; (* The common_ctx contains the haxe AST in the "types" field and the resources *) let generate common_ctx = make_base_directory common_ctx.file; let debug = false in let exe_classes = ref [] in let boot_classes = ref [] in let init_classes = ref [] in let file_info = ref PMap.empty in let class_text path = join_class_path path "::" in let member_types = create_member_types common_ctx in let super_deps = create_super_dependencies common_ctx in let constructor_deps = create_constructor_dependencies common_ctx in let main_deps = ref [] in let build_xml = ref "" in let scriptable = (Common.defined common_ctx Define.Scriptable) in let gen_externs = scriptable || (Common.defined common_ctx Define.DllExport) in if (gen_externs) then begin make_base_directory (common_ctx.file ^ "/extern"); end; List.iter (fun object_def -> (match object_def with | TClassDecl class_def when class_def.cl_extern -> () (*if (gen_externs) then gen_extern_class common_ctx class_def;*) | TClassDecl class_def -> let name = class_text class_def.cl_path in if (gen_externs) then gen_extern_class common_ctx class_def file_info; let is_internal = is_internal_class class_def.cl_path in let is_generic_def = match class_def.cl_kind with KGeneric -> true | _ -> false in if (is_internal || (is_macro class_def.cl_meta) || is_generic_def) then ( if debug then print_endline (" internal class " ^ name )) else begin build_xml := !build_xml ^ (get_code class_def.cl_meta Meta.BuildXml); boot_classes := class_def.cl_path :: !boot_classes; if (has_init_field class_def) then init_classes := class_def.cl_path :: !init_classes; let deps = generate_class_files common_ctx member_types super_deps constructor_deps class_def file_info scriptable in exe_classes := (class_def.cl_path, deps) :: !exe_classes; end | TEnumDecl enum_def when enum_def.e_extern -> () | TEnumDecl enum_def -> let name = class_text enum_def.e_path in if (gen_externs) then gen_extern_enum common_ctx enum_def file_info; let is_internal = is_internal_class enum_def.e_path in if (is_internal) then (if debug then print_endline (" internal enum " ^ name )) else begin let meta = Codegen.build_metadata common_ctx object_def in if (enum_def.e_extern) then (if debug then print_endline ("external enum " ^ name )); boot_classes := enum_def.e_path :: !boot_classes; let deps = generate_enum_files common_ctx enum_def super_deps meta file_info in exe_classes := (enum_def.e_path, deps) :: !exe_classes; end | TTypeDecl _ | TAbstractDecl _ -> (* already done *) () ); ) common_ctx.types; (match common_ctx.main with | None -> generate_dummy_main common_ctx | Some e -> let main_field = { cf_name = "__main__"; cf_type = t_dynamic; cf_expr = Some e; cf_pos = e.epos; cf_public = true; cf_meta = []; cf_overloads = []; cf_doc = None; cf_kind = Var { v_read = AccNormal; v_write = AccNormal; }; cf_params = [] } in let class_def = { null_class with cl_path = ([],"@Main"); cl_ordered_statics = [main_field] } in main_deps := find_referenced_types common_ctx (TClassDecl class_def) super_deps constructor_deps false true false; generate_main common_ctx member_types super_deps class_def file_info ); generate_boot common_ctx !boot_classes !init_classes; generate_files common_ctx file_info; write_resources common_ctx; let output_name = match common_ctx.main_class with | Some path -> (snd path) | _ -> "output" in write_build_data (common_ctx.file ^ "/Build.xml") !exe_classes !main_deps !build_xml output_name; let cmd_defines = ref "" in PMap.iter ( fun name value -> match name with | "true" | "sys" | "dce" | "cpp" | "debug" -> () | _ -> cmd_defines := !cmd_defines ^ " -D" ^ name ^ "=\"" ^ (escape_command value) ^ "\"" ) common_ctx.defines; write_build_options (common_ctx.file ^ "/Options.txt") !cmd_defines; if ( not (Common.defined common_ctx Define.NoCompilation) ) then begin let old_dir = Sys.getcwd() in Sys.chdir common_ctx.file; let cmd = ref "haxelib run hxcpp Build.xml haxe" in if (common_ctx.debug) then cmd := !cmd ^ " -Ddebug"; cmd := !cmd ^ !cmd_defines; print_endline !cmd; if common_ctx.run_command !cmd <> 0 then failwith "Build failed"; Sys.chdir old_dir; end ;; haxe-3.0~svn6707/codegen.ml0000644000175000017500000021503112172015135016141 0ustar bdefreesebdefreese(* * Copyright (C)2005-2013 Haxe Foundation * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. *) open Ast open Type open Common open Typecore (* -------------------------------------------------------------------------- *) (* TOOLS *) let field e name t p = mk (TField (e,try quick_field e.etype name with Not_found -> assert false)) t p let fcall e name el ret p = let ft = tfun (List.map (fun e -> e.etype) el) ret in mk (TCall (field e name ft p,el)) ret p let mk_parent e = mk (TParenthesis e) e.etype e.epos let string com str 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.basic.tint p)) t p let concat e1 e2 = let e = (match e1.eexpr, e2.eexpr with | TBlock el1, TBlock el2 -> TBlock (el1@el2) | TBlock el, _ -> TBlock (el @ [e2]) | _, TBlock el -> TBlock (e1 :: el) | _ , _ -> TBlock [e1;e2] ) in mk e e2.etype (punion e1.epos e2.epos) let type_constant com c p = let t = com.basic in match c with | 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))) t.tint p with _ -> mk (TConst (TFloat s)) t.tfloat p) | Float f -> mk (TConst (TFloat f)) t.tfloat p | String s -> mk (TConst (TString s)) t.tstring p | Ident "true" -> mk (TConst (TBool true)) t.tbool p | Ident "false" -> mk (TConst (TBool false)) t.tbool p | Ident "null" -> mk (TConst TNull) (t.tnull (mk_mono())) p | Ident t -> error ("Invalid constant : " ^ t) p | Regexp _ -> error "Invalid constant" p let rec type_constant_value com (e,p) = match e with | EConst c -> type_constant com c p | EParenthesis e -> type_constant_value com e | EObjectDecl el -> mk (TObjectDecl (List.map (fun (n,e) -> n, type_constant_value com e) el)) (TAnon { a_fields = PMap.empty; a_status = ref Closed }) p | EArrayDecl el -> mk (TArrayDecl (List.map (type_constant_value com) el)) (com.basic.tarray t_dynamic) p | _ -> error "Constant value expected" p let rec has_properties c = List.exists (fun f -> match f.cf_kind with | Var { v_read = AccCall } -> true | Var { v_write = AccCall } -> true | _ -> false ) c.cl_ordered_fields || (match c.cl_super with Some (c,_) -> has_properties c | _ -> false) let get_properties fields = List.fold_left (fun acc f -> let acc = (match f.cf_kind with | Var { v_read = AccCall } -> ("get_" ^ f.cf_name , "get_" ^ f.cf_name) :: acc | _ -> acc) in match f.cf_kind with | Var { v_write = AccCall } -> ("set_" ^ f.cf_name , "set_" ^ f.cf_name) :: acc | _ -> acc ) [] fields let add_property_field com c = let p = c.cl_pos in let props = get_properties (c.cl_ordered_statics @ c.cl_ordered_fields) in match props with | [] -> () | _ -> let fields,values = List.fold_left (fun (fields,values) (n,v) -> let cf = mk_field n com.basic.tstring p in PMap.add n cf fields,(n, string com v p) :: values ) (PMap.empty,[]) props in let t = mk_anon fields in let e = mk (TObjectDecl values) t p in let cf = mk_field "__properties__" t p in cf.cf_expr <- Some e; c.cl_statics <- PMap.add cf.cf_name cf c.cl_statics; c.cl_ordered_statics <- cf :: c.cl_ordered_statics (* -------------------------------------------------------------------------- *) (* REMOTING PROXYS *) let extend_remoting ctx c t p async prot = if c.cl_super <> None then error "Cannot extend several classes" p; (* remove forbidden packages *) let rules = ctx.com.package_rules in ctx.com.package_rules <- PMap.foldi (fun key r acc -> match r with Forbidden -> acc | _ -> PMap.add key r acc) rules PMap.empty; (* parse module *) let path = (t.tpackage,t.tname) in let new_name = (if async then "Async_" else "Remoting_") ^ t.tname in (* check if the proxy already exists *) let t = (try Typeload.load_type_def ctx p { tpackage = fst path; tname = new_name; tparams = []; tsub = None } with Error (Module_not_found _,p2) when p == p2 -> (* build it *) Common.log ctx.com ("Building proxy for " ^ s_type_path path); let file, decls = (try Typeload.parse_module ctx path p with | Not_found -> ctx.com.package_rules <- rules; error ("Could not load proxy module " ^ s_type_path path ^ (if fst path = [] then " (try using absolute path)" else "")) p | e -> ctx.com.package_rules <- rules; raise e) in ctx.com.package_rules <- rules; let base_fields = [ { cff_name = "__cnx"; cff_pos = p; cff_doc = None; cff_meta = []; cff_access = []; cff_kind = FVar (Some (CTPath { tpackage = ["haxe";"remoting"]; tname = if async then "AsyncConnection" else "Connection"; tparams = []; tsub = None }),None) }; { cff_name = "new"; cff_pos = p; cff_doc = None; cff_meta = []; cff_access = [APublic]; cff_kind = FFun { f_args = ["c",false,None,None]; f_type = None; f_expr = Some (EBinop (OpAssign,(EConst (Ident "__cnx"),p),(EConst (Ident "c"),p)),p); f_params = [] } }; ] in let tvoid = CTPath { tpackage = []; tname = "Void"; tparams = []; tsub = None } in let build_field is_public acc f = if f.cff_name = "new" then acc else match f.cff_kind with | FFun fd when (is_public || List.mem APublic f.cff_access) && not (List.mem AStatic f.cff_access) -> if List.exists (fun (_,_,t,_) -> t = None) fd.f_args then error ("Field " ^ f.cff_name ^ " type is not complete and cannot be used by RemotingProxy") p; let eargs = [EArrayDecl (List.map (fun (a,_,_,_) -> (EConst (Ident a),p)) fd.f_args),p] in let ftype = (match fd.f_type with Some (CTPath { tpackage = []; tname = "Void" }) -> None | _ -> fd.f_type) in let fargs, eargs = if async then match ftype with | Some tret -> fd.f_args @ ["__callb",true,Some (CTFunction ([tret],tvoid)),None], eargs @ [EConst (Ident "__callb"),p] | _ -> fd.f_args, eargs @ [EConst (Ident "null"),p] else fd.f_args, eargs in let id = (EConst (String f.cff_name), p) in let id = if prot then id else ECall ((EConst (Ident "__unprotect__"),p),[id]),p in let expr = ECall ( (EField ( (ECall ((EField ((EConst (Ident "__cnx"),p),"resolve"),p),[id]),p), "call") ,p),eargs),p in let expr = if async || ftype = None then expr else (EReturn (Some expr),p) in let fd = { f_params = fd.f_params; f_args = fargs; f_type = if async then None else ftype; f_expr = Some (EBlock [expr],p); } in { cff_name = f.cff_name; cff_pos = p; cff_doc = None; cff_meta = []; cff_access = [APublic]; cff_kind = FFun fd } :: acc | _ -> acc in let decls = List.map (fun d -> match d with | EClass c, p when c.d_name = t.tname -> let is_public = List.mem HExtern c.d_flags || List.mem HInterface c.d_flags in let fields = List.rev (List.fold_left (build_field is_public) base_fields c.d_data) in (EClass { c with d_flags = []; d_name = new_name; d_data = fields },p) | _ -> d ) decls in let m = Typeload.type_module ctx (t.tpackage,new_name) file decls p in add_dependency ctx.m.curmod m; try List.find (fun tdecl -> snd (t_path tdecl) = new_name) m.m_types with Not_found -> error ("Module " ^ s_type_path path ^ " does not define type " ^ t.tname) p ) in match t with | TClassDecl c2 when c2.cl_types = [] -> c2.cl_build(); c.cl_super <- Some (c2,[]); | _ -> error "Remoting proxy must be a class without parameters" p (* -------------------------------------------------------------------------- *) (* HAXE.RTTI.GENERIC *) exception Generic_Exception of string * Ast.pos type generic_context = { ctx : typer; subst : (t * t) list; name : string; p : pos; mutable mg : module_def option; } let make_generic ctx ps pt p = let rec loop l1 l2 = match l1, l2 with | [] , [] -> [] | (x,TLazy f) :: l1, _ -> loop ((x,(!f)()) :: l1) l2 | (_,t1) :: l1 , t2 :: l2 -> (t1,t2) :: loop l1 l2 | _ -> assert false in let name = String.concat "_" (List.map2 (fun (s,_) t -> let path = (match follow t with | TInst (ct,_) -> ct.cl_path | TEnum (e,_) -> e.e_path | TAbstract (a,_) when Meta.has Meta.RuntimeValue a.a_meta -> a.a_path | TMono _ -> raise (Generic_Exception (("Could not determine type for parameter " ^ s), p)) | t -> raise (Generic_Exception (("Type parameter must be a class or enum instance (found " ^ (s_type (print_context()) t) ^ ")"), p)) ) in match path with | [] , name -> name | l , name -> String.concat "_" l ^ "_" ^ name ) ps pt) in { ctx = ctx; subst = loop ps pt; name = name; p = p; mg = None; } let rec generic_substitute_type gctx t = match t with | TInst ({ cl_kind = KGeneric } as c2,tl2) -> (* maybe loop, or generate cascading generics *) let _, _, f = gctx.ctx.g.do_build_instance gctx.ctx (TClassDecl c2) gctx.p in let t = f (List.map (generic_substitute_type gctx) tl2) in (match follow t,gctx.mg with TInst(c,_), Some m -> add_dependency m c.cl_module | _ -> ()); t | _ -> try List.assq t gctx.subst with Not_found -> Type.map (generic_substitute_type gctx) t let generic_substitute_expr gctx e = let vars = Hashtbl.create 0 in let build_var v = try Hashtbl.find vars v.v_id with Not_found -> let v2 = alloc_var v.v_name (generic_substitute_type gctx v.v_type) in Hashtbl.add vars v.v_id v2; v2 in let rec build_expr e = match e.eexpr with | TField(e1, FInstance({cl_kind = KGeneric},cf)) -> build_expr {e with eexpr = TField(e1,quick_field_dynamic (generic_substitute_type gctx (e1.etype)) cf.cf_name)} | _ -> map_expr_type build_expr (generic_substitute_type gctx) build_var e in build_expr e let is_generic_parameter ctx c = (* first check field parameters, then class parameters *) try ignore (List.assoc (snd c.cl_path) ctx.curfield.cf_params); Meta.has Meta.Generic ctx.curfield.cf_meta with Not_found -> try ignore(List.assoc (snd c.cl_path) ctx.type_params); (match ctx.curclass.cl_kind with | KGeneric -> true | _ -> false); with Not_found -> false let has_ctor_constraint c = match c.cl_kind with | KTypeParameter tl -> List.exists (fun t -> match follow t with | TAnon a when PMap.mem "new" a.a_fields -> true | _ -> false ) tl; | _ -> false let rec build_generic ctx c p tl = let pack = fst c.cl_path in let recurse = ref false in let rec check_recursive t = match follow t with | TInst (c2,tl) -> (match c2.cl_kind with | KTypeParameter tl -> if not (is_generic_parameter ctx c2) && has_ctor_constraint c2 then error "Type parameters with a constructor cannot be used non-generically" p; recurse := true | _ -> ()); List.iter check_recursive tl; | _ -> () in List.iter check_recursive tl; let gctx = try make_generic ctx c.cl_types tl p with Generic_Exception (msg,p) -> error msg p in let name = (snd c.cl_path) ^ "_" ^ gctx.name in if !recurse then begin TInst (c,tl) (* build a normal instance *) end else try Typeload.load_instance ctx { tpackage = pack; tname = name; tparams = []; tsub = None } p false with Error(Module_not_found path,_) when path = (pack,name) -> let m = (try Hashtbl.find ctx.g.modules (Hashtbl.find ctx.g.types_module c.cl_path) with Not_found -> assert false) in let ctx = { ctx with m = { ctx.m with module_types = m.m_types @ ctx.m.module_types } } in c.cl_build(); (* make sure the super class is already setup *) let mg = { m_id = alloc_mid(); m_path = (pack,name); m_types = []; m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake; } in gctx.mg <- Some mg; let cg = mk_class mg (pack,name) c.cl_pos in mg.m_types <- [TClassDecl cg]; Hashtbl.add ctx.g.modules mg.m_path mg; add_dependency mg m; add_dependency ctx.m.curmod mg; (* ensure that type parameters are set in dependencies *) let dep_stack = ref [] in let rec loop t = if not (List.memq t !dep_stack) then begin dep_stack := t :: !dep_stack; match t with | TInst (c,tl) -> add_dep c.cl_module tl | TEnum (e,tl) -> add_dep e.e_module tl | TType (t,tl) -> add_dep t.t_module tl | TAbstract (a,tl) -> add_dep a.a_module tl | TMono r -> (match !r with | None -> () | Some t -> loop t) | TLazy f -> loop ((!f)()); | TDynamic t2 -> if t == t2 then () else loop t2 | TAnon a -> PMap.iter (fun _ f -> loop f.cf_type) a.a_fields | TFun (args,ret) -> List.iter (fun (_,_,t) -> loop t) args; loop ret end and add_dep m tl = add_dependency mg m; List.iter loop tl in List.iter loop tl; let delays = ref [] in let build_field f = let t = generic_substitute_type gctx f.cf_type in let f = { f with cf_type = t} in (* delay the expression mapping to make sure all cf_type fields are set correctly first *) (delays := (fun () -> try (match f.cf_expr with None -> () | Some e -> f.cf_expr <- Some (generic_substitute_expr gctx e)) with Unify_error l -> error (error_msg (Unify l)) f.cf_pos) :: !delays); f in if c.cl_init <> None || c.cl_dynamic <> None then error "This class can't be generic" p; if c.cl_ordered_statics <> [] then error "A generic class can't have static fields" p; cg.cl_super <- (match c.cl_super with | None -> None | Some (cs,pl) -> (match apply_params c.cl_types tl (TInst (cs,pl)) with | TInst (cs,pl) when cs.cl_kind = KGeneric -> (match build_generic ctx cs p pl with | TInst (cs,pl) -> Some (cs,pl) | _ -> assert false) | TInst (cs,pl) -> Some (cs,pl) | _ -> assert false) ); cg.cl_kind <- KGenericInstance (c,tl); cg.cl_interface <- c.cl_interface; cg.cl_constructor <- (match c.cl_constructor, c.cl_super with | None, None -> None | Some c, _ -> Some (build_field c) | _ -> error "Please define a constructor for this class in order to use it as generic" c.cl_pos ); cg.cl_implements <- List.map (fun (i,tl) -> (match follow (generic_substitute_type gctx (TInst (i, List.map (generic_substitute_type gctx) tl))) with | TInst (i,tl) -> i, tl | _ -> assert false) ) c.cl_implements; cg.cl_ordered_fields <- List.map (fun f -> let f = build_field f in cg.cl_fields <- PMap.add f.cf_name f cg.cl_fields; f ) c.cl_ordered_fields; List.iter (fun f -> f()) !delays; TInst (cg,[]) (* -------------------------------------------------------------------------- *) (* HAXE.XML.PROXY *) let extend_xml_proxy ctx c t file p = let t = Typeload.load_complex_type ctx p t in let file = (try Common.find_file ctx.com file with Not_found -> file) in add_dependency c.cl_module (create_fake_module ctx file); let used = ref PMap.empty in let print_results() = PMap.iter (fun id used -> if not used then ctx.com.warning (id ^ " is not used") p; ) (!used) in let check_used = Common.defined ctx.com Define.CheckXmlProxy in if check_used then ctx.g.hook_generate <- print_results :: ctx.g.hook_generate; try let rec loop = function | Xml.Element (_,attrs,childs) -> (try let id = List.assoc "id" attrs in if PMap.mem id c.cl_fields then error ("Duplicate id " ^ id) p; let t = if not check_used then t else begin used := PMap.add id false (!used); let ft() = used := PMap.add id true (!used); t in TLazy (ref ft) end in let f = { cf_name = id; cf_type = t; cf_public = true; cf_pos = p; cf_doc = None; cf_meta = no_meta; cf_kind = Var { v_read = AccResolve; v_write = AccNo }; cf_params = []; cf_expr = None; cf_overloads = []; } in c.cl_fields <- PMap.add id f c.cl_fields; with Not_found -> ()); List.iter loop childs; | Xml.PCData _ -> () in loop (Xml.parse_file file) with | Xml.Error e -> error ("XML error " ^ Xml.error e) p | Xml.File_not_found f -> error ("XML File not found : " ^ f) p (* -------------------------------------------------------------------------- *) (* BUILD META DATA OBJECT *) let build_metadata com t = 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 let statics = List.map (fun f -> f.cf_name,f.cf_meta) c.cl_ordered_statics in (c.cl_pos, ["",c.cl_meta],fields,statics) | TEnumDecl e -> (e.e_pos, ["",e.e_meta],List.map (fun n -> n, (PMap.find n e.e_constrs).ef_meta) e.e_names, []) | TTypeDecl t -> (t.t_pos, ["",t.t_meta],(match follow t.t_type with TAnon a -> PMap.fold (fun f acc -> (f.cf_name,f.cf_meta) :: acc) a.a_fields [] | _ -> []),[]) | TAbstractDecl a -> (a.a_pos, ["",a.a_meta],[],[]) ) in let filter l = let l = List.map (fun (n,ml) -> n, ExtList.List.filter_map (fun (m,el,p) -> match m with Meta.Custom s when String.length s > 0 && s.[0] <> ':' -> Some (s,el,p) | _ -> None) ml) l in List.filter (fun (_,ml) -> ml <> []) l in let meta, fields, statics = filter meta, filter fields, filter statics in let make_meta_field ml = let h = Hashtbl.create 0 in mk (TObjectDecl (List.map (fun (f,el,p) -> if Hashtbl.mem h f then error ("Duplicate metadata '" ^ f ^ "'") p; Hashtbl.add h f (); f, mk (match el with [] -> TConst TNull | _ -> TArrayDecl (List.map (type_constant_value com) el)) (api.tarray t_dynamic) p ) ml)) (api.tarray t_dynamic) p in let make_meta l = mk (TObjectDecl (List.map (fun (f,ml) -> f,make_meta_field ml) l)) t_dynamic p in if meta = [] && fields = [] && statics = [] then None else let meta_obj = [] in let meta_obj = (if fields = [] then meta_obj else ("fields",make_meta fields) :: meta_obj) in let meta_obj = (if statics = [] then meta_obj else ("statics",make_meta statics) :: meta_obj) in let meta_obj = (try ("obj", make_meta_field (List.assoc "" meta)) :: meta_obj with Not_found -> meta_obj) in Some (mk (TObjectDecl meta_obj) t_dynamic p) (* -------------------------------------------------------------------------- *) (* MACRO TYPE *) let build_macro_type ctx pl p = let path, field, args = (match pl with | [TInst ({ cl_kind = KExpr (ECall (e,args),_) },_)] | [TInst ({ cl_kind = KExpr (EArrayDecl [ECall (e,args),_],_) },_)] -> let rec loop e = match fst e with | EField (e,f) -> f :: loop e | EConst (Ident i) -> [i] | _ -> error "Invalid macro call" p in (match loop e with | meth :: cl :: path -> (List.rev path,cl), meth, args | _ -> error "Invalid macro call" p) | _ -> error "MacroType require a single expression call parameter" p ) in let old = ctx.ret in let t = (match ctx.g.do_macro ctx MMacroType path field args p with | None -> mk_mono() | Some _ -> ctx.ret ) in ctx.ret <- old; t (* -------------------------------------------------------------------------- *) (* API EVENTS *) let build_instance ctx mtype p = match mtype with | TClassDecl c -> if ctx.pass > PBuildClass then c.cl_build(); let ft = (fun pl -> match c.cl_kind with | KGeneric -> let r = exc_protect ctx (fun r -> let t = mk_mono() in r := (fun() -> t); unify_raise ctx (build_generic ctx c p pl) t p; t ) "build_generic" in delay ctx PForce (fun() -> ignore ((!r)())); TLazy r | KMacroType -> let r = exc_protect ctx (fun r -> let t = mk_mono() in r := (fun() -> t); unify_raise ctx (build_macro_type ctx pl p) t p; t ) "macro_type" in delay ctx PForce (fun() -> ignore ((!r)())); TLazy r | _ -> TInst (c,pl) ) in c.cl_types , c.cl_path , ft | TEnumDecl e -> e.e_types , e.e_path , (fun t -> TEnum (e,t)) | TTypeDecl t -> t.t_types , t.t_path , (fun tl -> TType(t,tl)) | TAbstractDecl a -> a.a_types, a.a_path, (fun tl -> TAbstract(a,tl)) let on_inherit ctx c p h = match h with | HExtends { tpackage = ["haxe";"remoting"]; tname = "Proxy"; tparams = [TPType(CTPath t)] } -> extend_remoting ctx c t p false true; false | HExtends { tpackage = ["haxe";"remoting"]; tname = "AsyncProxy"; tparams = [TPType(CTPath t)] } -> extend_remoting ctx c t p true true; false | HExtends { tpackage = ["mt"]; tname = "AsyncProxy"; tparams = [TPType(CTPath t)] } -> extend_remoting ctx c t p true false; false | HExtends { tpackage = ["haxe";"xml"]; tname = "Proxy"; tparams = [TPExpr(EConst (String file),p);TPType t] } -> extend_xml_proxy ctx c t file p; true | _ -> true (* -------------------------------------------------------------------------- *) (* FINAL GENERATION *) (* Saves a class state so it can be restored later, e.g. after DCE or native path rewrite *) let save_class_state ctx t = match t with | TClassDecl c -> let meta = c.cl_meta and path = c.cl_path and ext = c.cl_extern in let fl = c.cl_fields and ofl = c.cl_ordered_fields and st = c.cl_statics and ost = c.cl_ordered_statics in let cst = c.cl_constructor and over = c.cl_overrides in let oflk = List.map (fun f -> f.cf_kind,f.cf_expr,f.cf_type) ofl in let ostk = List.map (fun f -> f.cf_kind,f.cf_expr,f.cf_type) ost in c.cl_restore <- (fun() -> c.cl_meta <- meta; c.cl_extern <- ext; c.cl_path <- path; c.cl_fields <- fl; c.cl_ordered_fields <- ofl; c.cl_statics <- st; c.cl_ordered_statics <- ost; c.cl_constructor <- cst; c.cl_overrides <- over; (* DCE might modify the cf_kind, so let's restore it as well *) List.iter2 (fun f (k,e,t) -> f.cf_kind <- k; f.cf_expr <- e; f.cf_type <- t;) ofl oflk; List.iter2 (fun f (k,e,t) -> f.cf_kind <- k; f.cf_expr <- e; f.cf_type <- t;) ost ostk; ) | _ -> () (* Checks if a private class' path clashes with another path *) let check_private_path ctx t = match t with | TClassDecl c when c.cl_private -> let rpath = (fst c.cl_module.m_path,"_" ^ snd c.cl_module.m_path) in if Hashtbl.mem ctx.g.types_module rpath then error ("This private class name will clash with " ^ s_type_path rpath) c.cl_pos; | _ -> () (* Removes generic base classes *) let remove_generic_base ctx t = match t with | TClassDecl c when c.cl_kind = KGeneric && has_ctor_constraint c -> c.cl_extern <- true | _ -> () (* Rewrites class or enum paths if @:native metadata is set *) let apply_native_paths ctx t = let get_real_path meta path = let (_,e,mp) = Meta.get Meta.Native meta in match e with | [Ast.EConst (Ast.String name),p] -> (Meta.RealPath,[Ast.EConst (Ast.String (s_type_path path)),p],mp),parse_path name | _ -> error "String expected" mp in try (match t with | TClassDecl c -> let meta,path = get_real_path c.cl_meta c.cl_path in c.cl_meta <- meta :: c.cl_meta; c.cl_path <- path; | TEnumDecl e -> let meta,path = get_real_path e.e_meta e.e_path in e.e_meta <- meta :: e.e_meta; e.e_path <- path; | _ -> ()) with Not_found -> () (* Adds the __rtti field if required *) let add_rtti ctx t = let rec has_rtti c = Meta.has Meta.Rtti c.cl_meta || match c.cl_super with None -> false | Some (csup,_) -> has_rtti csup in match t with | TClassDecl c when has_rtti c && not (PMap.mem "__rtti" c.cl_statics) -> let f = mk_field "__rtti" ctx.t.tstring c.cl_pos 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; c.cl_statics <- PMap.add f.cf_name f c.cl_statics; | _ -> () (* Removes extern and macro fields, also checks for Void fields *) let remove_extern_fields ctx t = match t with | TClassDecl c -> let do_remove f = Meta.has Meta.Extern f.cf_meta || Meta.has Meta.Generic f.cf_meta || (match f.cf_kind with | Var {v_read = AccRequire (s,_)} -> true | Method MethMacro -> not ctx.in_macro | _ -> false) in if not (Common.defined ctx.com Define.DocGen) then begin c.cl_ordered_fields <- List.filter (fun f -> let b = do_remove f in if b then c.cl_fields <- PMap.remove f.cf_name c.cl_fields; not b ) c.cl_ordered_fields; c.cl_ordered_statics <- List.filter (fun f -> let b = do_remove f in if b then c.cl_statics <- PMap.remove f.cf_name c.cl_statics; not b ) c.cl_ordered_statics; end | _ -> () (* Adds member field initializations as assignments to the constructor *) let add_field_inits ctx t = let apply c = let ethis = mk (TConst TThis) (TInst (c,List.map snd c.cl_types)) c.cl_pos in (* TODO: we have to find a variable name which is not used in any of the functions *) let v = alloc_var "_g" ethis.etype in let need_this = ref false in let inits,fields = List.fold_left (fun (inits,fields) cf -> match cf.cf_kind,cf.cf_expr with | Var _, Some _ -> if ctx.com.config.pf_can_init_member cf then (inits, cf :: fields) else (cf :: inits, cf :: fields) | Method MethDynamic, Some e when Common.defined ctx.com Define.As3 -> (* TODO : this would have a better place in genSWF9 I think - NC *) (* we move the initialization of dynamic functions to the constructor and also solve the 'this' problem along the way *) let rec use_this v e = match e.eexpr with | TConst TThis -> need_this := true; mk (TLocal v) v.v_type e.epos | _ -> Type.map_expr (use_this v) e in let e = Type.map_expr (use_this v) e in let cf2 = {cf with cf_expr = Some e} in (* if the method is an override, we have to remove the class field to not get invalid overrides *) let fields = if List.memq cf c.cl_overrides then begin c.cl_fields <- PMap.remove cf.cf_name c.cl_fields; fields end else cf2 :: fields in (cf2 :: inits, fields) | _ -> (inits, cf :: fields) ) ([],[]) c.cl_ordered_fields in c.cl_ordered_fields <- fields; match inits with | [] -> () | _ -> let el = List.map (fun cf -> match cf.cf_expr with | None -> assert false | Some e -> let lhs = mk (TField(ethis,FInstance (c,cf))) cf.cf_type e.epos in cf.cf_expr <- None; let eassign = mk (TBinop(OpAssign,lhs,e)) e.etype e.epos in if Common.defined ctx.com Define.As3 then begin let echeck = mk (TBinop(OpEq,lhs,(mk (TConst TNull) lhs.etype e.epos))) ctx.com.basic.tbool e.epos in mk (TIf(echeck,eassign,None)) eassign.etype e.epos end else eassign; ) inits in let el = if !need_this then (mk (TVars([v, Some ethis])) ethis.etype ethis.epos) :: el else el in match c.cl_constructor with | None -> let ct = TFun([],ctx.com.basic.tvoid) in let ce = mk (TFunction { tf_args = []; tf_type = ctx.com.basic.tvoid; tf_expr = mk (TBlock el) ctx.com.basic.tvoid c.cl_pos; }) ct c.cl_pos in let ctor = mk_field "new" ct c.cl_pos in ctor.cf_kind <- Method MethNormal; c.cl_constructor <- Some { ctor with cf_expr = Some ce }; | Some cf -> match cf.cf_expr with | Some { eexpr = TFunction f } -> let bl = match f.tf_expr with {eexpr = TBlock b } -> b | x -> [x] in let ce = mk (TFunction {f with tf_expr = mk (TBlock (el @ bl)) ctx.com.basic.tvoid c.cl_pos }) cf.cf_type cf.cf_pos in c.cl_constructor <- Some {cf with cf_expr = Some ce } | _ -> assert false in match t with | TClassDecl c -> apply c | _ -> () (* Adds the __meta__ field if required *) let add_meta_field ctx t = match t with | TClassDecl c -> (match build_metadata ctx.com t with | None -> () | Some e -> let f = mk_field "__meta__" t_dynamic c.cl_pos in f.cf_expr <- Some e; c.cl_ordered_statics <- f :: c.cl_ordered_statics; c.cl_statics <- PMap.add f.cf_name f c.cl_statics) | _ -> () (* Removes interfaces tagged with @:remove metadata *) let check_remove_metadata ctx t = match t with | TClassDecl c -> c.cl_implements <- List.filter (fun (c,_) -> not (Meta.has Meta.Remove c.cl_meta)) c.cl_implements; | _ -> () (* Checks for Void class fields *) let check_void_field ctx t = match t with | TClassDecl c -> let check f = match follow f.cf_type with TAbstract({a_path=[],"Void"},_) -> error "Fields of type Void are not allowed" f.cf_pos | _ -> (); in List.iter check c.cl_ordered_fields; List.iter check c.cl_ordered_statics; | _ -> () (* Promotes type parameters of abstracts to their implementation fields *) let promote_abstract_parameters ctx t = match t with | TClassDecl ({cl_kind = KAbstractImpl a} as c) when a.a_types <> [] -> List.iter (fun f -> List.iter (fun (n,t) -> match t with | TInst({cl_kind = KTypeParameter _; cl_path=p,n} as cp,[]) when not (List.mem_assoc n f.cf_params) -> let path = List.rev ((snd c.cl_path) :: List.rev (fst c.cl_path)),n in f.cf_params <- (n,TInst({cp with cl_path = path},[])) :: f.cf_params | _ -> () ) a.a_types; ) c.cl_ordered_statics; | _ -> () (* -------------------------------------------------------------------------- *) (* LOCAL VARIABLES USAGE *) type usage = | Block of ((usage -> unit) -> unit) | Loop of ((usage -> unit) -> unit) | Function of ((usage -> unit) -> unit) | Declare of tvar | Use of tvar let rec local_usage f e = match e.eexpr with | TLocal v -> f (Use v) | TVars l -> List.iter (fun (v,e) -> (match e with None -> () | Some e -> local_usage f e); f (Declare v); ) l | TFunction tf -> let cc f = List.iter (fun (v,_) -> f (Declare v)) tf.tf_args; local_usage f tf.tf_expr; in f (Function cc) | TBlock l -> f (Block (fun f -> List.iter (local_usage f) l)) | TFor (v,it,e) -> local_usage f it; f (Loop (fun f -> f (Declare v); local_usage f e; )) | TWhile _ -> f (Loop (fun f -> iter (local_usage f) e )) | TTry (e,catchs) -> local_usage f e; List.iter (fun (v,e) -> f (Block (fun f -> f (Declare v); local_usage f e; )) ) catchs; | TMatch (e,_,cases,def) -> local_usage f e; List.iter (fun (_,vars,e) -> let cc f = (match vars with | None -> () | Some l -> List.iter (function None -> () | Some v -> f (Declare v)) l); local_usage f e; in f (Block cc) ) cases; (match def with None -> () | Some e -> local_usage f e); | _ -> iter (local_usage f) e (* -------------------------------------------------------------------------- *) (* BLOCK VARIABLES CAPTURE *) (* For some platforms, it will simply mark the variables which are used in closures using the v_capture flag so it can be processed in a more optimized For Flash/JS platforms, it will ensure that variables used in loop sub-functions have an unique scope. It transforms the following expression : for( x in array ) funs.push(function() return x++); Into the following : for( _x in array ) { var x = [_x]; funs.push(function(x) { function() return x[0]++; }(x)); } *) let captured_vars com e = let t = com.basic in let rec mk_init av v pos = mk (TVars [av,Some (mk (TArrayDecl [mk (TLocal v) v.v_type pos]) av.v_type pos)]) t.tvoid pos and mk_var v used = alloc_var v.v_name (PMap.find v.v_id used) and wrap used e = match e.eexpr with | TVars vl -> let vl = List.map (fun (v,ve) -> if PMap.mem v.v_id used then v, Some (mk (TArrayDecl (match ve with None -> [] | Some e -> [wrap used e])) v.v_type e.epos) else v, (match ve with None -> None | Some e -> Some (wrap used e)) ) vl in { e with eexpr = TVars vl } | TLocal v when PMap.mem v.v_id used -> mk (TArray ({ e with etype = v.v_type },mk (TConst (TInt 0l)) t.tint e.epos)) e.etype e.epos | TFor (v,it,expr) when PMap.mem v.v_id used -> let vtmp = mk_var v used in let it = wrap used it in let expr = wrap used expr in mk (TFor (vtmp,it,concat (mk_init v vtmp e.epos) expr)) e.etype e.epos | TTry (expr,catchs) -> let catchs = List.map (fun (v,e) -> let e = wrap used e in try let vtmp = mk_var v used in vtmp, concat (mk_init v vtmp e.epos) e with Not_found -> v, e ) catchs in mk (TTry (wrap used expr,catchs)) e.etype e.epos | TMatch (expr,enum,cases,def) -> let cases = List.map (fun (il,vars,e) -> let pos = e.epos in let e = ref (wrap used e) in let vars = match vars with | None -> None | Some l -> Some (List.map (fun v -> match v with | Some v when PMap.mem v.v_id used -> let vtmp = mk_var v used in e := concat (mk_init v vtmp pos) !e; Some vtmp | _ -> v ) l) in il, vars, !e ) cases in let def = match def with None -> None | Some e -> Some (wrap used e) in mk (TMatch (wrap used expr,enum,cases,def)) e.etype e.epos | TFunction f -> (* list variables that are marked as used, but also used in that function and which are not declared inside it ! *) let fused = ref PMap.empty in let tmp_used = ref used in let rec browse = function | Block f | Loop f | Function f -> f browse | Use v -> if PMap.mem v.v_id !tmp_used then fused := PMap.add v.v_id v !fused; | Declare v -> tmp_used := PMap.remove v.v_id !tmp_used in local_usage browse e; let vars = PMap.fold (fun v acc -> v :: acc) !fused [] in (* in case the variable has been marked as used in a parallel scope... *) let fexpr = ref (wrap used f.tf_expr) in let fargs = List.map (fun (v,o) -> if PMap.mem v.v_id used then let vtmp = mk_var v used in fexpr := concat (mk_init v vtmp e.epos) !fexpr; vtmp, o else v, o ) f.tf_args in let e = { e with eexpr = TFunction { f with tf_args = fargs; tf_expr = !fexpr } } in (* Create a new function scope to make sure that the captured loop variable will not be overwritten in next loop iteration *) if com.config.pf_capture_policy = CPLoopVars then mk (TCall ( mk_parent (mk (TFunction { tf_args = List.map (fun v -> v, None) vars; tf_type = e.etype; tf_expr = mk_block (mk (TReturn (Some e)) e.etype e.epos); }) (TFun (List.map (fun v -> v.v_name,false,v.v_type) vars,e.etype)) e.epos), List.map (fun v -> mk (TLocal v) v.v_type e.epos) vars) ) e.etype e.epos else e | _ -> map_expr (wrap used) e and do_wrap used e = if PMap.is_empty used then e else let used = PMap.map (fun v -> let vt = v.v_type in v.v_type <- t.tarray vt; v.v_capture <- true; vt ) used in wrap used e and out_loop e = match e.eexpr with | TFor _ | TWhile _ -> (* collect variables that are declared in loop but used in subfunctions *) let vars = ref PMap.empty in let used = ref PMap.empty in let depth = ref 0 in let rec collect_vars in_loop = function | Block f -> let old = !vars in f (collect_vars in_loop); vars := old; | Loop f -> let old = !vars in f (collect_vars true); vars := old; | Function f -> incr depth; f (collect_vars false); decr depth; | Declare v -> if in_loop then vars := PMap.add v.v_id !depth !vars; | Use v -> try let d = PMap.find v.v_id !vars in if d <> !depth then used := PMap.add v.v_id v !used; with Not_found -> () in local_usage (collect_vars false) e; do_wrap !used e | _ -> map_expr out_loop e and all_vars e = let vars = ref PMap.empty in let used = ref PMap.empty in let depth = ref 0 in let rec collect_vars = function | Block f -> let old = !vars in f collect_vars; vars := old; | Loop f -> let old = !vars in f collect_vars; vars := old; | Function f -> incr depth; f collect_vars; decr depth; | Declare v -> vars := PMap.add v.v_id !depth !vars; | Use v -> try let d = PMap.find v.v_id !vars in if d <> !depth then used := PMap.add v.v_id v !used; with Not_found -> () in local_usage collect_vars e; !used in (* mark all capture variables - also used in rename_local_vars at later stage *) let captured = all_vars e in PMap.iter (fun _ v -> v.v_capture <- true) captured; match com.config.pf_capture_policy with | CPNone -> e | CPWrapRef -> do_wrap captured e | CPLoopVars -> out_loop e (* -------------------------------------------------------------------------- *) (* RENAME LOCAL VARS *) let rename_local_vars com e = let cfg = com.config in let all_scope = (not cfg.pf_captured_scope) || (not cfg.pf_locals_scope) in let vars = ref PMap.empty in let all_vars = ref PMap.empty in let vtemp = alloc_var "~" t_dynamic in let rebuild_vars = ref false in let rebuild m = PMap.fold (fun v acc -> PMap.add v.v_name v acc) m PMap.empty in let save() = let old = !vars in if cfg.pf_unique_locals then (fun() -> ()) else (fun() -> vars := if !rebuild_vars then rebuild old else old) in let rename vars v = let count = ref 1 in while PMap.mem (v.v_name ^ string_of_int !count) vars do incr count; done; v.v_name <- v.v_name ^ string_of_int !count; in let declare v p = (match follow v.v_type with | TAbstract ({a_path = [],"Void"},_) -> error "Arguments and variables of type Void are not allowed" p | _ -> ()); (* chop escape char for all local variables generated *) if String.unsafe_get v.v_name 0 = String.unsafe_get gen_local_prefix 0 then v.v_name <- "_g" ^ String.sub v.v_name 1 (String.length v.v_name - 1); let look_vars = (if not cfg.pf_captured_scope && v.v_capture then !all_vars else !vars) in (try let v2 = PMap.find v.v_name look_vars in (* block_vars will create some wrapper-functions that are declaring the same variable twice. In that case do not perform a rename since we are sure it's actually the same variable *) if v == v2 then raise Not_found; rename look_vars v; with Not_found -> ()); vars := PMap.add v.v_name v !vars; if all_scope then all_vars := PMap.add v.v_name v !all_vars; in (* This is quite a rare case, when a local variable would otherwise prevent accessing a type because it masks the type value or the package name. *) let check t = match (t_infos t).mt_path with | [], name | name :: _, _ -> let vars = if cfg.pf_locals_scope then vars else all_vars in (try let v = PMap.find name !vars in if v == vtemp then raise Not_found; (* ignore *) rename (!vars) v; rebuild_vars := true; vars := PMap.add v.v_name v !vars with Not_found -> ()); vars := PMap.add name vtemp !vars in let check_type t = match follow t with | TInst (c,_) -> check (TClassDecl c) | TEnum (e,_) -> check (TEnumDecl e) | TType (t,_) -> check (TTypeDecl t) | TAbstract (a,_) -> check (TAbstractDecl a) | TMono _ | TLazy _ | TAnon _ | TDynamic _ | TFun _ -> () in let rec loop e = match e.eexpr with | TVars l -> List.iter (fun (v,eo) -> if not cfg.pf_locals_scope then declare v e.epos; (match eo with None -> () | Some e -> loop e); if cfg.pf_locals_scope then declare v e.epos; ) l | TFunction tf -> let old = save() in List.iter (fun (v,_) -> declare v e.epos) tf.tf_args; loop tf.tf_expr; old() | TBlock el -> let old = save() in List.iter loop el; old() | TFor (v,it,e1) -> loop it; let old = save() in declare v e.epos; loop e1; old() | TTry (e,catchs) -> loop e; List.iter (fun (v,e) -> let old = save() in declare v e.epos; check_type v.v_type; loop e; old() ) catchs; | TMatch (e,_,cases,def) -> loop e; List.iter (fun (_,vars,e) -> let old = save() in (match vars with | None -> () | Some l -> List.iter (function None -> () | Some v -> declare v e.epos) l); loop e; old(); ) cases; (match def with None -> () | Some e -> loop e); | TTypeExpr t -> check t | TNew (c,_,_) -> Type.iter loop e; check (TClassDecl c); | TCast (e,Some t) -> loop e; check t; | _ -> Type.iter loop e in declare (alloc_var "this" t_dynamic) Ast.null_pos; (* force renaming of 'this' vars in abstract *) loop e; e (* -------------------------------------------------------------------------- *) (* CHECK LOCAL VARS INIT *) let check_local_vars_init e = let intersect vl1 vl2 = PMap.mapi (fun v t -> t && PMap.find v vl2) vl1 in let join vars cvars = List.iter (fun v -> vars := intersect !vars v) cvars in let restore vars old_vars declared = (* restore variables declared in this block to their previous state *) vars := List.fold_left (fun acc v -> try PMap.add v (PMap.find v old_vars) acc with Not_found -> PMap.remove v acc ) !vars declared; in let declared = ref [] in let rec loop vars e = match e.eexpr with | TLocal v -> let init = (try PMap.find v.v_id !vars with Not_found -> true) in if not init then begin if v.v_name = "this" then error "Missing this = value" e.epos else error ("Local variable " ^ v.v_name ^ " used without being initialized") e.epos end | TVars vl -> List.iter (fun (v,eo) -> match eo with | None -> declared := v.v_id :: !declared; vars := PMap.add v.v_id false !vars | Some e -> loop vars e ) vl | TBlock el -> let old = !declared in let old_vars = !vars in declared := []; List.iter (loop vars) el; restore vars old_vars (List.rev !declared); declared := old; | TBinop (OpAssign,{ eexpr = TLocal v },e) when PMap.mem v.v_id !vars -> loop vars e; vars := PMap.add v.v_id true !vars | TIf (e1,e2,eo) -> loop vars e1; let vbase = !vars in loop vars e2; (match eo with | None -> vars := vbase | Some e -> let v1 = !vars in vars := vbase; loop vars e; vars := intersect !vars v1) | TWhile (cond,e,flag) -> (match flag with | NormalWhile -> loop vars cond; let old = !vars in loop vars e; vars := old; | DoWhile -> loop vars e; loop vars cond) | TTry (e,catches) -> let cvars = List.map (fun (v,e) -> let old = !vars in loop vars e; let v = !vars in vars := old; v ) catches in loop vars e; join vars cvars; | TSwitch (e,cases,def) -> loop vars e; let cvars = List.map (fun (ec,e) -> let old = !vars in List.iter (loop vars) ec; vars := old; loop vars e; let v = !vars in vars := old; v ) cases in (match def with | None -> () | Some e -> loop vars e; join vars cvars) | TMatch (e,_,cases,def) -> loop vars e; let old = !vars in let cvars = List.map (fun (_,vl,e) -> vars := old; loop vars e; restore vars old []; !vars ) cases in (match def with None -> () | Some e -> vars := old; loop vars e); join vars cvars (* mark all reachable vars as initialized, since we don't exit the block *) | TBreak | TContinue | TReturn None -> vars := PMap.map (fun _ -> true) !vars | TThrow e | TReturn (Some e) -> loop vars e; vars := PMap.map (fun _ -> true) !vars | _ -> Type.iter (loop vars) e in loop (ref PMap.empty) e; e (* -------------------------------------------------------------------------- *) (* ABSTRACT CASTS *) module Abstract = struct let find_to ab pl b = List.find (Type.unify_to_field ab pl b) ab.a_to let find_from ab pl a b = List.find (Type.unify_from_field ab pl a b) ab.a_from let cast_stack = ref [] let get_underlying_type a pl = try if not (Meta.has Meta.MultiType a.a_meta) then raise Not_found; let m = mk_mono() in let _ = find_to a pl m in follow m with Not_found -> apply_params a.a_types pl a.a_this let rec make_static_call ctx c cf a pl args t p = let ta = TAnon { a_fields = c.cl_statics; a_status = ref (Statics c) } in let ethis = mk (TTypeExpr (TClassDecl c)) ta p in let monos = List.map (fun _ -> mk_mono()) cf.cf_params in let map t = apply_params a.a_types pl (apply_params cf.cf_params monos t) in let tcf = match follow (map cf.cf_type),args with | TFun((_,_,ta) :: args,r) as tf,e :: el when Meta.has Meta.From cf.cf_meta -> unify ctx e.etype ta p; tf | t,_ -> t in let def () = let e = mk (TField (ethis,(FStatic (c,cf)))) tcf p in loop ctx (mk (TCall(e,args)) (map t) p) in match cf.cf_expr with | Some { eexpr = TFunction fd } when cf.cf_kind = Method MethInline -> let config = if Meta.has Meta.Impl cf.cf_meta then (Some (a.a_types <> [] || cf.cf_params <> [], map)) else None in (match Optimizer.type_inline ctx cf fd ethis args t config p true with | Some e -> (match e.eexpr with TCast(e,None) -> e | _ -> e) | None -> def()) | _ -> def() and check_cast ctx tleft eright p = let tright = follow eright.etype in let tleft = follow tleft in if tleft == tright then eright else let recurse cf f = if cf == ctx.curfield || List.mem cf !cast_stack then error "Recursive implicit cast" p; cast_stack := cf :: !cast_stack; let r = f() in cast_stack := List.tl !cast_stack; r in try (match tright,tleft with | (TAbstract({a_impl = Some c1} as a1,pl1) as t1),(TAbstract({a_impl = Some c2} as a2,pl2) as t2) -> if a1 == a2 then eright else begin let c,cfo,a,pl = try if Meta.has Meta.MultiType a1.a_meta then raise Not_found; c1,snd (find_to a1 pl1 t2),a1,pl1 with Not_found -> if Meta.has Meta.MultiType a2.a_meta then raise Not_found; c2,snd (find_from a2 pl2 t1 t2),a2,pl2 in match cfo with | None -> eright | Some cf -> recurse cf (fun () -> make_static_call ctx c cf a pl [eright] tleft p) end | TDynamic _,_ | _,TDynamic _ -> eright | TAbstract({a_impl = Some c} as a,pl),t2 when not (Meta.has Meta.MultiType a.a_meta) -> begin match find_to a pl t2 with | tcf,None -> let tcf = apply_params a.a_types pl tcf in if type_iseq tcf tleft then eright else check_cast ctx tcf eright p | _,Some cf -> recurse cf (fun () -> make_static_call ctx c cf a pl [eright] tleft p) end | t1,(TAbstract({a_impl = Some c} as a,pl) as t2) when not (Meta.has Meta.MultiType a.a_meta) -> begin match find_from a pl t1 t2 with | tcf,None -> let tcf = apply_params a.a_types pl tcf in if type_iseq tcf tleft then eright else check_cast ctx tcf eright p | _,Some cf -> recurse cf (fun () -> make_static_call ctx c cf a pl [eright] tleft p) end | _ -> eright) with Not_found -> eright and call_args ctx el tl = match el,tl with | [],_ -> [] | e :: el, [] -> (loop ctx e) :: call_args ctx el [] | e :: el, (_,_,t) :: tl -> (check_cast ctx t (loop ctx e) e.epos) :: call_args ctx el tl and loop ctx e = match e.eexpr with | TBinop(OpAssign,e1,e2) -> let e2 = check_cast ctx e1.etype (loop ctx e2) e.epos in { e with eexpr = TBinop(OpAssign,loop ctx e1,e2) } | TVars vl -> let vl = List.map (fun (v,eo) -> match eo with | None -> (v,eo) | Some e -> let is_generic_abstract = match e.etype with TAbstract ({a_impl = Some _} as a,_) -> Meta.has Meta.MultiType a.a_meta | _ -> false in let e = check_cast ctx v.v_type (loop ctx e) e.epos in (* we can rewrite this for better field inference *) if is_generic_abstract then v.v_type <- e.etype; v, Some e ) vl in { e with eexpr = TVars vl } | TNew({cl_kind = KAbstractImpl a} as c,pl,el) -> (* a TNew of an abstract implementation is only generated if it is a generic abstract *) let at = apply_params a.a_types pl a.a_this in let m = mk_mono() in let _,cfo = try find_to a pl m with Not_found -> let st = s_type (print_context()) at in if has_mono at then error ("Type parameters of multi type abstracts must be known (for " ^ st ^ ")") e.epos else error ("Abstract " ^ (s_type_path a.a_path) ^ " has no @:to function that accepts " ^ st) e.epos; in begin match cfo with | None -> assert false | Some cf -> let m = follow m in let e = make_static_call ctx c cf a pl ((mk (TConst TNull) at e.epos) :: el) m e.epos in {e with etype = m} end | TNew(c,pl,el) -> begin try let t,_ = (!get_constructor_ref) ctx c pl e.epos in begin match follow t with | TFun(args,_) -> { e with eexpr = TNew(c,pl,call_args ctx el args)} | _ -> Type.map_expr (loop ctx) e end with Error _ -> (* TODO: when does this happen? *) Type.map_expr (loop ctx) e end | TCall(e1, el) -> let e1 = loop ctx e1 in begin try begin match e1.eexpr with | TField(_,FStatic(_,cf)) when Meta.has Meta.To cf.cf_meta -> (* do not recurse over @:to functions to avoid infinite recursion *) { e with eexpr = TCall(e1,el)} | TField(e2,fa) -> begin match follow e2.etype with | TAbstract(a,pl) when Meta.has Meta.MultiType a.a_meta -> let m = get_underlying_type a pl in let fname = field_name fa in let el = List.map (loop ctx) el in begin try let ef = mk (TField({e2 with etype = m},quick_field m fname)) e1.etype e2.epos in make_call ctx ef el e.etype e.epos with Not_found -> (* quick_field raises Not_found if m is an abstract, we have to replicate the 'using' call here *) match follow m with | TAbstract({a_impl = Some c} as a,pl) -> let cf = PMap.find fname c.cl_statics in make_static_call ctx c cf a pl (e2 :: el) e.etype e.epos | _ -> raise Not_found end | _ -> raise Not_found end | _ -> raise Not_found end with Not_found -> begin match follow e1.etype with | TFun(args,_) -> { e with eexpr = TCall(loop ctx e1,call_args ctx el args)} | _ -> Type.map_expr (loop ctx) e end end | TArrayDecl el -> begin match e.etype with | TInst(_,[t]) -> let el = List.map (fun e -> check_cast ctx t (loop ctx e) e.epos) el in { e with eexpr = TArrayDecl el} | _ -> Type.map_expr (loop ctx) e end | TObjectDecl fl -> begin match follow e.etype with | TAnon a -> let fl = List.map (fun (n,e) -> try let cf = PMap.find n a.a_fields in let e = match e.eexpr with TCast(e1,None) -> e1 | _ -> e in (n,check_cast ctx cf.cf_type (loop ctx e) e.epos) with Not_found -> (n,loop ctx e) ) fl in { e with eexpr = TObjectDecl fl } | _ -> Type.map_expr (loop ctx) e end | _ -> Type.map_expr (loop ctx) e let handle_abstract_casts ctx e = loop ctx e end (* -------------------------------------------------------------------------- *) (* USAGE *) let detect_usage com = let usage = ref [] in List.iter (fun t -> match t with | TClassDecl c -> let rec expr e = match e.eexpr with | TField(_,fa) -> (match extract_field fa with | Some cf when Meta.has Meta.Usage cf.cf_meta -> let p = {e.epos with pmin = e.epos.pmax - (String.length cf.cf_name)} in usage := p :: !usage; | _ -> ()); Type.iter expr e | _ -> Type.iter expr e in let field cf = match cf.cf_expr with None -> () | Some e -> expr e in (match c.cl_constructor with None -> () | Some cf -> field cf); (match c.cl_init with None -> () | Some e -> expr e); List.iter field c.cl_ordered_statics; List.iter field c.cl_ordered_fields; | _ -> () ) com.types; let usage = List.sort (fun p1 p2 -> let c = compare p1.pfile p2.pfile in if c <> 0 then c else compare p1.pmin p2.pmin ) !usage in raise (Typecore.DisplayPosition usage) (* -------------------------------------------------------------------------- *) (* POST PROCESS *) let pp_counter = ref 1 let post_process filters t = (* ensure that we don't process twice the same (cached) module *) let m = (t_infos t).mt_module.m_extra in if m.m_processed = 0 then m.m_processed <- !pp_counter; if m.m_processed = !pp_counter then match t with | TClassDecl c -> let process_field f = match f.cf_expr with | None -> () | Some e -> Abstract.cast_stack := f :: !Abstract.cast_stack; f.cf_expr <- Some (List.fold_left (fun e f -> f e) e filters); Abstract.cast_stack := List.tl !Abstract.cast_stack; in List.iter process_field c.cl_ordered_fields; List.iter process_field c.cl_ordered_statics; (match c.cl_constructor with | None -> () | Some f -> process_field f); (match c.cl_init with | None -> () | Some e -> c.cl_init <- Some (List.fold_left (fun e f -> f e) e filters)); | TEnumDecl _ -> () | TTypeDecl _ -> () | TAbstractDecl _ -> () let post_process_end() = incr pp_counter (* -------------------------------------------------------------------------- *) (* STACK MANAGEMENT EMULATION *) type stack_context = { stack_var : string; stack_exc_var : string; stack_pos_var : string; stack_pos : pos; stack_expr : texpr; stack_pop : texpr; stack_save_pos : texpr; stack_restore : texpr list; stack_push : tclass -> string -> texpr; stack_return : texpr -> texpr; } let stack_context_init com stack_var exc_var pos_var tmp_var use_add p = let t = com.basic in let st = t.tarray t.tstring in let stack_var = alloc_var stack_var st in let exc_var = alloc_var exc_var st in let pos_var = alloc_var pos_var t.tint in let stack_e = mk (TLocal stack_var) st p in let exc_e = mk (TLocal exc_var) st p in let stack_pop = fcall stack_e "pop" [] t.tstring p in let stack_push c m = fcall stack_e "push" [ if use_add then binop OpAdd (string com (s_type_path c.cl_path ^ "::") p) (string com m p) t.tstring p else string com (s_type_path c.cl_path ^ "::" ^ m) p ] t.tvoid p in let stack_return e = let tmp = alloc_var tmp_var e.etype in mk (TBlock [ mk (TVars [tmp, Some e]) t.tvoid e.epos; stack_pop; mk (TReturn (Some (mk (TLocal tmp) e.etype e.epos))) e.etype e.epos ]) e.etype e.epos in { stack_var = stack_var.v_name; stack_exc_var = exc_var.v_name; stack_pos_var = pos_var.v_name; stack_pos = p; stack_expr = stack_e; stack_pop = stack_pop; stack_save_pos = mk (TVars [pos_var, Some (field stack_e "length" t.tint p)]) t.tvoid p; stack_push = stack_push; stack_return = stack_return; stack_restore = [ binop OpAssign exc_e (mk (TArrayDecl []) st p) st p; mk (TWhile ( mk_parent (binop OpGte (field stack_e "length" t.tint p) (mk (TLocal pos_var) t.tint p) t.tbool p), fcall exc_e "unshift" [fcall stack_e "pop" [] t.tstring p] t.tvoid p, NormalWhile )) t.tvoid p; fcall stack_e "push" [index com exc_e 0 t.tstring p] t.tvoid p ]; } let stack_init com use_add = stack_context_init com "$s" "$e" "$spos" "$tmp" use_add null_pos let rec stack_block_loop ctx e = match e.eexpr with | TFunction _ -> e | TReturn None | TReturn (Some { eexpr = TConst _ }) | TReturn (Some { eexpr = TLocal _ }) -> mk (TBlock [ ctx.stack_pop; e; ]) e.etype e.epos | TReturn (Some e) -> ctx.stack_return (stack_block_loop ctx e) | TTry (v,cases) -> let v = stack_block_loop ctx v in let cases = List.map (fun (v,e) -> let e = stack_block_loop ctx e in let e = (match (mk_block e).eexpr with | TBlock l -> mk (TBlock (ctx.stack_restore @ l)) e.etype e.epos | _ -> assert false ) in v , e ) cases in mk (TTry (v,cases)) e.etype e.epos | _ -> map_expr (stack_block_loop ctx) e let stack_block ctx c m e = match (mk_block e).eexpr with | TBlock l -> mk (TBlock ( ctx.stack_push c m :: ctx.stack_save_pos :: List.map (stack_block_loop ctx) l @ [ctx.stack_pop] )) e.etype e.epos | _ -> assert false (* -------------------------------------------------------------------------- *) (* FIX OVERRIDES *) (* on some platforms which doesn't support type parameters, we must have the exact same type for overriden/implemented function as the original one *) let rec find_field c f = try (match c.cl_super with | None -> raise Not_found | Some ( {cl_path = (["cpp"],"FastIterator")}, _ ) -> raise Not_found (* This is a strongly typed 'extern' and the usual rules don't apply *) | Some (c,_) -> find_field c f) with Not_found -> try let rec loop = function | [] -> raise Not_found | (c,_) :: l -> try find_field c f with Not_found -> loop l in loop c.cl_implements with Not_found -> let f = PMap.find f.cf_name c.cl_fields in (match f.cf_kind with Var { v_read = AccRequire _ } -> raise Not_found | _ -> ()); f let fix_override com c f fd = let f2 = (try Some (find_field c f) with Not_found -> None) in match f2,fd with | Some (f2), Some(fd) -> let targs, tret = (match follow f2.cf_type with TFun (args,ret) -> args, ret | _ -> assert false) in let changed_args = ref [] in let prefix = "_tmp_" in let nargs = List.map2 (fun ((v,c) as cur) (_,_,t2) -> try type_eq EqStrict v.v_type t2; cur with Unify_error _ -> let v2 = alloc_var (prefix ^ v.v_name) t2 in changed_args := (v,v2) :: !changed_args; v2,c ) fd.tf_args targs in let fd2 = { tf_args = nargs; tf_type = tret; tf_expr = (match List.rev !changed_args with | [] -> fd.tf_expr | args -> let e = fd.tf_expr in let el = (match e.eexpr with TBlock el -> el | _ -> [e]) in let p = (match el with [] -> e.epos | e :: _ -> e.epos) in let v = mk (TVars (List.map (fun (v,v2) -> (v,Some (mk (TCast (mk (TLocal v2) v2.v_type p,None)) v.v_type p)) ) args)) com.basic.tvoid p in { e with eexpr = TBlock (v :: el) } ); } in (* as3 does not allow wider visibility, so the base method has to be made public *) if Common.defined com Define.As3 && f.cf_public then f2.cf_public <- true; let targs = List.map (fun(v,c) -> (v.v_name, Option.is_some c, v.v_type)) nargs in let fde = (match f.cf_expr with None -> assert false | Some e -> e) in f.cf_expr <- Some { fde with eexpr = TFunction fd2 }; f.cf_type <- TFun(targs,tret); | Some(f2), None when c.cl_interface -> let targs, tret = (match follow f2.cf_type with TFun (args,ret) -> args, ret | _ -> assert false) in f.cf_type <- TFun(targs,tret) | _ -> () let fix_overrides com t = match t with | TClassDecl c -> (* overrides can be removed from interfaces *) if c.cl_interface then c.cl_ordered_fields <- List.filter (fun f -> try if find_field c f == f then raise Not_found; c.cl_fields <- PMap.remove f.cf_name c.cl_fields; false; with Not_found -> true ) c.cl_ordered_fields; List.iter (fun f -> match f.cf_expr, f.cf_kind with | Some { eexpr = TFunction fd }, Method (MethNormal | MethInline) -> fix_override com c f (Some fd) | None, Method (MethNormal | MethInline) when c.cl_interface -> fix_override com c f None | _ -> () ) c.cl_ordered_fields | _ -> () (* PHP does not allow abstract classes extending other abstract classes to override any fields, so these duplicates must be removed from the child interface *) let fix_abstract_inheritance com t = match t with | TClassDecl c when c.cl_interface -> c.cl_ordered_fields <- List.filter (fun f -> let b = try (find_field c f) == f with Not_found -> false in if not b then c.cl_fields <- PMap.remove f.cf_name c.cl_fields; b; ) c.cl_ordered_fields | _ -> () (* -------------------------------------------------------------------------- *) (* MISC FEATURES *) let rec is_volatile t = match t with | TMono r -> (match !r with | Some t -> is_volatile t | _ -> false) | TLazy f -> is_volatile (!f()) | TType (t,tl) -> (match t.t_path with | ["mt";"flash"],"Volatile" -> true | _ -> is_volatile (apply_params t.t_types tl t.t_type)) | _ -> false let set_default ctx a c p = let t = a.v_type in let ve = mk (TLocal a) t p in let cond = TBinop (OpEq,ve,mk (TConst TNull) t p) in mk (TIf (mk_parent (mk cond 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 let tbl = Array.init (String.length b64) (fun i -> String.get b64 i) in let str = Base64.str_encode ~tbl data in "s" ^ string_of_int (String.length str) ^ ":" ^ str (* Tells if the constructor might be called without any issue whatever its parameters *) let rec constructor_side_effects e = match e.eexpr with | TBinop (op,_,_) when op <> OpAssign -> true | TField (_,FEnum _) -> false | TUnop _ | TArray _ | TField _ | TCall _ | TNew _ | TFor _ | TWhile _ | TSwitch _ | TMatch _ | TReturn _ | TThrow _ -> true | TBinop _ | TTry _ | TIf _ | TBlock _ | TVars _ | TFunction _ | TArrayDecl _ | TObjectDecl _ | TParenthesis _ | TTypeExpr _ | TLocal _ | TConst _ | TContinue | TBreak | TCast _ -> try Type.iter (fun e -> if constructor_side_effects e then raise Exit) e; false; with Exit -> true (* Make a dump of the full typed AST of all types *) let rec create_dumpfile acc = function | [] -> assert false | d :: [] -> let ch = open_out (String.concat "/" (List.rev (d :: acc)) ^ ".dump") in let buf = Buffer.create 0 in buf, (fun () -> output_string ch (Buffer.contents buf); close_out ch) | d :: l -> let dir = String.concat "/" (List.rev (d :: acc)) in if not (Sys.file_exists dir) then Unix.mkdir dir 0o755; create_dumpfile (d :: acc) l let dump_types com = let s_type = s_type (Type.print_context()) in let params = function [] -> "" | l -> Printf.sprintf "<%s>" (String.concat "," (List.map (fun (n,t) -> n ^ " : " ^ s_type t) l)) in let s_expr = try if Common.defined_value com Define.Dump = "pretty" then Type.s_expr_pretty "\t" else Type.s_expr with Not_found -> Type.s_expr in List.iter (fun mt -> let path = Type.t_path mt in let buf,close = create_dumpfile [] ("dump" :: (Common.platform_name com.platform) :: fst path @ [snd path]) in let print fmt = Printf.kprintf (fun s -> Buffer.add_string buf s) fmt in (match mt with | Type.TClassDecl c -> let rec print_field stat f = print "\t%s%s%s%s" (if stat then "static " else "") (if f.cf_public then "public " else "") f.cf_name (params f.cf_params); print "(%s) : %s" (s_kind f.cf_kind) (s_type f.cf_type); (match f.cf_expr with | None -> () | Some e -> print "\n\n\t = %s" (s_expr s_type e)); print ";\n\n"; List.iter (fun f -> print_field stat f) f.cf_overloads in print "%s%s%s %s%s" (if c.cl_private then "private " else "") (if c.cl_extern then "extern " else "") (if c.cl_interface then "interface" else "class") (s_type_path path) (params c.cl_types); (match c.cl_super with None -> () | Some (c,pl) -> print " extends %s" (s_type (TInst (c,pl)))); List.iter (fun (c,pl) -> print " implements %s" (s_type (TInst (c,pl)))) c.cl_implements; (match c.cl_dynamic with None -> () | Some t -> print " implements Dynamic<%s>" (s_type t)); (match c.cl_array_access with None -> () | Some t -> print " implements ArrayAccess<%s>" (s_type t)); print "{\n"; (match c.cl_constructor with | None -> () | Some f -> print_field false f); List.iter (print_field false) c.cl_ordered_fields; List.iter (print_field true) c.cl_ordered_statics; print "}"; | Type.TEnumDecl e -> print "%s%senum %s%s {\n" (if e.e_private then "private " else "") (if e.e_extern then "extern " else "") (s_type_path path) (params e.e_types); List.iter (fun n -> let f = PMap.find n e.e_constrs in print "\t%s : %s;\n" f.ef_name (s_type f.ef_type); ) e.e_names; print "}" | Type.TTypeDecl t -> print "%stype %s%s = %s" (if t.t_private then "private " else "") (s_type_path path) (params t.t_types) (s_type t.t_type); | Type.TAbstractDecl a -> print "%sabstract %s%s {}" (if a.a_private then "private " else "") (s_type_path path) (params a.a_types); ); close(); ) com.types let dump_dependencies com = let buf,close = create_dumpfile [] ["dump";Common.platform_name com.platform;".dependencies"] in let print fmt = Printf.kprintf (fun s -> Buffer.add_string buf s) fmt in let dep = Hashtbl.create 0 in List.iter (fun m -> print "%s:\n" m.m_extra.m_file; PMap.iter (fun _ m2 -> print "\t%s\n" (m2.m_extra.m_file); let l = try Hashtbl.find dep m2.m_extra.m_file with Not_found -> [] in Hashtbl.replace dep m2.m_extra.m_file (m :: l) ) m.m_extra.m_deps; ) com.Common.modules; close(); let buf,close = create_dumpfile [] ["dump";Common.platform_name com.platform;".dependants"] in let print fmt = Printf.kprintf (fun s -> Buffer.add_string buf s) fmt in Hashtbl.iter (fun n ml -> print "%s:\n" n; List.iter (fun m -> print "\t%s\n" (m.m_extra.m_file); ) ml; ) dep; close() (* Build a default safe-cast expression : { 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.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) } | TAbstractDecl a -> TAnon { a_fields = PMap.empty; a_status = ref (AbstractStatics a) } | TTypeDecl _ -> assert false in let vtmp = alloc_var vtmp e.etype in let var = mk (TVars [vtmp,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 = (try List.find (fun t -> t_path t = ([],"Std")) com.types with Not_found -> assert false) in let fis = (try let c = (match std with TClassDecl c -> c | _ -> assert false) in FStatic (c, PMap.find "is" c.cl_statics) with Not_found -> assert false ) in let std = mk (TTypeExpr std) (mk_texpr std) p in let is = mk (TField (std,fis)) (tfun [t_dynamic;t_dynamic] api.tbool) p in let is = mk (TCall (is,[vexpr;texpr])) api.tbool p in let exc = mk (TThrow (mk (TConst (TString "Class cast error")) api.tstring p)) t p in let check = mk (TIf (mk_parent is,mk (TCast (vexpr,None)) t p,Some exc)) t p in mk (TBlock [var;check;vexpr]) t p (** Overload resolution **) module Overloads = struct let rec simplify_t t = match t with | TInst _ | TEnum _ | TAbstract({ a_impl = None }, _) -> t | TAbstract(a,tl) -> simplify_t (Abstract.get_underlying_type a tl) | TType(({ t_path = [],"Null" } as t), [t2]) -> (match simplify_t t2 with | (TAbstract({ a_impl = None }, _) | TEnum _ as t2) -> TType(t, [simplify_t t2]) | t2 -> t2) | TType(t, tl) -> simplify_t (apply_params t.t_types tl t.t_type) | TMono r -> (match !r with | Some t -> simplify_t t | None -> t_dynamic) | TAnon _ -> t_dynamic | TDynamic _ -> t | TLazy f -> simplify_t (!f()) | TFun _ -> t (* rate type parameters *) let rate_tp tlfun tlarg = let acc = ref 0 in List.iter2 (fun f a -> if not (type_iseq f a) then incr acc) tlfun tlarg; !acc let rec rate_conv cacc tfun targ = match simplify_t tfun, simplify_t targ with | TInst({ cl_interface = true } as cf, tlf), TInst(ca, tla) -> (* breadth-first *) let stack = ref [0,ca,tla] in let cur = ref (0, ca,tla) in let rec loop () = match !stack with | [] -> (let acc, ca, tla = !cur in match ca.cl_super with | None -> raise Not_found | Some (sup,tls) -> cur := (acc+1,sup,List.map (apply_params ca.cl_types tla) tls); stack := [!cur]; loop()) | (acc,ca,tla) :: _ when ca == cf -> acc,tla | (acc,ca,tla) :: s -> stack := s @ List.map (fun (c,tl) -> (acc+1,c,List.map (apply_params ca.cl_types tla) tl)) ca.cl_implements; loop() in let acc, tla = loop() in (cacc + acc, rate_tp tlf tla) | TInst(cf,tlf), TInst(ca,tla) -> let rec loop acc ca tla = if cf == ca then acc, tla else match ca.cl_super with | None -> raise Not_found | Some(sup,stl) -> loop (acc+1) sup (List.map (apply_params ca.cl_types tla) stl) in let acc, tla = loop 0 ca tla in (cacc + acc, rate_tp tlf tla) | TEnum(ef,tlf), TEnum(ea, tla) -> if ef != ea then raise Not_found; (cacc, rate_tp tlf tla) | TDynamic _, TDynamic _ -> (cacc, 0) | TDynamic _, _ -> (max_int, 0) (* a function with dynamic will always be worst of all *) | TAbstract({ a_impl = None }, _), TDynamic _ -> (cacc + 2, 0) (* a dynamic to a basic type will have an "unboxing" penalty *) | _, TDynamic _ -> (cacc + 1, 0) | TAbstract(af,tlf), TAbstract(aa,tla) -> (if af == aa then (cacc, rate_tp tlf tla) else let ret = ref None in if List.exists (fun (t,_) -> try ret := Some (rate_conv (cacc+1) (apply_params af.a_types tlf t) targ); true with | Not_found -> false ) af.a_from then Option.get !ret else if List.exists (fun (t,_) -> try ret := Some (rate_conv (cacc+1) tfun (apply_params aa.a_types tla t)); true with | Not_found -> false ) aa.a_to then Option.get !ret else raise Not_found) | TType({ t_path = [], "Null" }, [tf]), TType({ t_path = [], "Null" }, [ta]) -> rate_conv (cacc+0) tf ta | TType({ t_path = [], "Null" }, [tf]), ta -> rate_conv (cacc+1) tf ta | tf, TType({ t_path = [], "Null" }, [ta]) -> rate_conv (cacc+1) tf ta | TFun _, TFun _ -> (* unify will make sure they are compatible *) cacc,0 | tfun,targ -> raise Not_found let is_best arg1 arg2 = (List.for_all2 (fun v1 v2 -> v1 <= v2) arg1 arg2) && (List.exists2 (fun v1 v2 -> v1 < v2) arg1 arg2) let rec rm_duplicates acc ret = match ret with | [] -> acc | ( el, t ) :: ret when List.exists (fun (_,t2) -> type_iseq t t2) acc -> rm_duplicates acc ret | r :: ret -> rm_duplicates (r :: acc) ret let s_options rated = String.concat ",\n" (List.map (fun ((_,t),rate) -> "( " ^ (String.concat "," (List.map (fun (i,i2) -> string_of_int i ^ ":" ^ string_of_int i2) rate)) ^ " ) => " ^ (s_type (print_context()) t) ) rated) let count_optionals elist = List.fold_left (fun acc (_,is_optional) -> if is_optional then acc + 1 else acc) 0 elist let rec fewer_optionals acc compatible = match acc, compatible with | _, [] -> acc | [], c :: comp -> fewer_optionals [c] comp | (elist_acc, _) :: _, ((elist, _) as cur) :: comp -> let acc_opt = count_optionals elist_acc in let comp_opt = count_optionals elist in if acc_opt = comp_opt then fewer_optionals (cur :: acc) comp else if acc_opt < comp_opt then fewer_optionals acc comp else fewer_optionals [cur] comp let reduce_compatible compatible = match fewer_optionals [] (rm_duplicates [] compatible) with | [] -> [] | [v] -> [v] | compatible -> (* convert compatible into ( rate * compatible_type ) list *) let rec mk_rate acc elist args = match elist, args with | [], [] -> acc | (_,true) :: elist, _ :: args -> mk_rate acc elist args | (e,false) :: elist, (n,o,t) :: args -> mk_rate (rate_conv 0 t e.etype :: acc) elist args | _ -> assert false in let rated = ref [] in List.iter (function | (elist,TFun(args,ret)) -> (try rated := ( (elist,TFun(args,ret)), mk_rate [] elist args ) :: !rated with | Not_found -> ()) | _ -> assert false ) compatible; let rec loop best rem = match best, rem with | _, [] -> best | [], r1 :: rem -> loop [r1] rem | (bover, bargs) :: b1, (rover, rargs) :: rem -> if is_best bargs rargs then loop best rem else if is_best rargs bargs then loop (loop b1 [rover,rargs]) rem else (* equally specific *) loop ( (rover,rargs) :: best ) rem in List.map fst (loop [] !rated) end;; haxe-3.0~svn6707/genjava.ml0000644000175000017500000037376312172015135016171 0ustar bdefreesebdefreese(* * Copyright (C)2005-2013 Haxe Foundation * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. *) open JData open Unix open Ast open Common open Gencommon open Gencommon.SourceWriter open Type open Printf open Option open ExtString let is_boxed_type t = match follow t with | TInst ({ cl_path = (["java";"lang"], "Boolean") }, []) | TInst ({ cl_path = (["java";"lang"], "Double") }, []) | TInst ({ cl_path = (["java";"lang"], "Integer") }, []) | TInst ({ cl_path = (["java";"lang"], "Byte") }, []) | TInst ({ cl_path = (["java";"lang"], "Short") }, []) | TInst ({ cl_path = (["java";"lang"], "Character") }, []) | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> true | _ -> false let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with | TInst ({ cl_path = (["java";"lang"], "Boolean") }, []) -> gen.gcon.basic.tbool | TInst ({ cl_path = (["java";"lang"], "Double") }, []) -> gen.gcon.basic.tfloat | TInst ({ cl_path = (["java";"lang"], "Integer") }, []) -> gen.gcon.basic.tint | TInst ({ cl_path = (["java";"lang"], "Byte") }, []) -> tbyte | TInst ({ cl_path = (["java";"lang"], "Short") }, []) -> tshort | TInst ({ cl_path = (["java";"lang"], "Character") }, []) -> tchar | TInst ({ cl_path = (["java";"lang"], "Float") }, []) -> tfloat | _ -> assert false let rec t_has_type_param t = match follow t with | TInst({ cl_kind = KTypeParameter _ }, []) -> true | TEnum(_, params) | TInst(_, params) -> List.exists t_has_type_param params | TFun(f,ret) -> t_has_type_param ret || List.exists (fun (_,_,t) -> t_has_type_param t) f | _ -> false let rec t_has_type_param_shallow last t = match follow t with | TInst({ cl_kind = KTypeParameter _ }, []) -> true | TEnum(_, params) | TInst(_, params) when not last -> List.exists (t_has_type_param_shallow true) params | TFun(f,ret) when not last -> t_has_type_param_shallow true ret || List.exists (fun (_,_,t) -> t_has_type_param_shallow true t) f | _ -> false let is_java_basic_type t = match follow t with | TInst( { cl_path = (["haxe"], "Int32") }, [] ) | TInst( { cl_path = (["haxe"], "Int64") }, [] ) | TAbstract( { a_path = ([], "Single") }, [] ) | TAbstract( { a_path = (["java"], ("Int8" | "Int16" | "Char16")) }, [] ) | TInst( { cl_path = ([], "Int") }, [] ) | TAbstract( { a_path = ([], "Int") }, [] ) | TInst( { cl_path = ([], "Float") }, [] ) | TAbstract( { a_path = ([], "Float") }, [] ) | TEnum( { e_path = ([], "Bool") }, [] ) | TAbstract( { a_path = ([], "Bool") }, [] ) -> true | _ -> false let is_bool t = match follow t with | TEnum( { e_path = ([], "Bool") }, [] ) | TAbstract ({ a_path = ([], "Bool") },[]) -> true | _ -> false let is_int_float gen t = match follow (gen.greal_type t) with | TInst( { cl_path = (["haxe"], "Int64") }, [] ) | TInst( { cl_path = (["haxe"], "Int32") }, [] ) | TInst( { cl_path = ([], "Int") }, [] ) | TAbstract( { a_path = ([], "Int") }, [] ) | TInst( { cl_path = ([], "Float") }, [] ) | TAbstract( { a_path = ([], "Float") }, [] ) -> true | (TAbstract _ as t) when like_float t -> true | _ -> false let parse_explicit_iface = let regex = Str.regexp "\\." in let parse_explicit_iface str = let split = Str.split regex str in let rec get_iface split pack = match split with | clname :: fn_name :: [] -> fn_name, (List.rev pack, clname) | pack_piece :: tl -> get_iface tl (pack_piece :: pack) | _ -> assert false in get_iface split [] in parse_explicit_iface let is_string t = match follow t with | TInst( { cl_path = ([], "String") }, [] ) -> true | _ -> false let is_cl t = match follow t with | TInst({ cl_path = ["java";"lang"],"Class" },_) | TAbstract({ a_path = [], ("Class"|"Enum") },_) -> true | TAnon(a) when is_some (anon_class t) -> true | _ -> false (* ******************************************* *) (* JavaSpecificESynf *) (* ******************************************* *) (* Some Java-specific syntax filters that must run before ExpressionUnwrap dependencies: It must run before ExprUnwrap, as it may not return valid Expr/Statement expressions It must run before ClassInstance, as it will detect expressions that need unchanged TTypeExpr It must run after CastDetect, as it changes casts It must run after TryCatchWrapper, to change Std.is() calls inside there *) module JavaSpecificESynf = struct let name = "java_specific_e" let priority = solve_deps name [ DBefore ExpressionUnwrap.priority; DBefore ClassInstance.priority; DAfter CastDetect.priority; DAfter TryCatchWrapper.priority ] let get_cl_from_t t = match follow t with | TInst(cl,_) -> cl | _ -> assert false let traverse gen runtime_cl = let basic = gen.gcon.basic in let float_cl = get_cl ( get_type gen (["java";"lang"], "Double")) in let i8_md = ( get_type gen (["java";"lang"], "Byte")) in let i16_md = ( get_type gen (["java";"lang"], "Short")) in let i64_md = ( get_type gen (["java";"lang"], "Long")) in let c16_md = ( get_type gen (["java";"lang"], "Character")) in let f_md = ( get_type gen (["java";"lang"], "Float")) in let bool_md = get_type gen (["java";"lang"], "Boolean") in let is_var = alloc_var "__is__" t_dynamic in let rec run e = match e.eexpr with (* Math changes *) | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "NaN" }) ) -> mk_static_field_access_infer float_cl "NaN" e.epos [] | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "NEGATIVE_INFINITY" }) ) -> mk_static_field_access_infer float_cl "NEGATIVE_INFINITY" e.epos [] | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "POSITIVE_INFINITY" }) ) -> mk_static_field_access_infer float_cl "POSITIVE_INFINITY" e.epos [] | TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "isNaN"}) ) -> mk_static_field_access_infer float_cl "_isNaN" e.epos [] | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("ffloor" as f) }) ) } as fe), p) | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("fceil" as f) }) ) } as fe), p) -> Type.map_expr run { e with eexpr = TCall({ fe with eexpr = TField(ef, FDynamic (String.sub f 1 (String.length f - 1))) }, p) } | TCall( ({ eexpr = TField( (_ as ef), FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = ("fround") }) ) } as fe), p) -> Type.map_expr run { e with eexpr = TCall({ fe with eexpr = TField(ef, FDynamic "rint") }, p) } | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "floor" }) ) }, _) | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "round" }) ) }, _) | TCall( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "ceil" }) ) }, _) -> mk_cast basic.tint (Type.map_expr run { e with etype = basic.tfloat }) | TCall( ( { eexpr = TField( _, FStatic({ cl_path = (["java";"lang"], "Math") }, { cf_name = "isFinite" }) ) } as efield ), [v]) -> { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "isFinite" efield.epos [], [run v] ) } (* end of math changes *) (* Std.is() *) | TCall( { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "is" })) }, [ obj; { eexpr = TTypeExpr(md) } ] ) -> let mk_is is_basic obj md = let obj = if is_basic then mk_cast t_dynamic obj else obj in { e with eexpr = TCall( { eexpr = TLocal is_var; etype = t_dynamic; epos = e.epos }, [ run obj; { eexpr = TTypeExpr md; etype = t_dynamic (* this is after all a syntax filter *); epos = e.epos } ] ) } in (match follow_module follow md with | TClassDecl({ cl_path = ([], "Float") }) | TAbstractDecl({ a_path = ([], "Float") }) -> { eexpr = TCall( mk_static_field_access_infer runtime_cl "isDouble" e.epos [], [ run obj ] ); etype = basic.tbool; epos = e.epos } | TClassDecl{ cl_path = ([], "Int") } | TAbstractDecl{ a_path = ([], "Int") } -> { eexpr = TCall( mk_static_field_access_infer runtime_cl "isInt" e.epos [], [ run obj ] ); etype = basic.tbool; epos = e.epos } | TAbstractDecl{ a_path = ([], "Bool") } | TEnumDecl{ e_path = ([], "Bool") } -> mk_is true obj bool_md | TAbstractDecl{ a_path = ([], "Single") } -> mk_is true obj f_md | TAbstractDecl{ a_path = (["java"], "Int8") } -> mk_is true obj i8_md | TAbstractDecl{ a_path = (["java"], "Int16") } -> mk_is true obj i16_md | TAbstractDecl{ a_path = (["java"], "Char16") } -> mk_is true obj c16_md | TClassDecl{ cl_path = (["haxe"], "Int64") } -> mk_is true obj i64_md | TAbstractDecl{ a_path = ([], "Dynamic") } | TClassDecl{ cl_path = ([], "Dynamic") } -> (match obj.eexpr with | TLocal _ | TConst _ -> { e with eexpr = TConst(TBool true) } | _ -> { e with eexpr = TBlock([run obj; { e with eexpr = TConst(TBool true) }]) } ) | _ -> mk_is false obj md ) (* end Std.is() *) | _ -> Type.map_expr run e in run let configure gen (mapping_func:texpr->texpr) = let map e = Some(mapping_func e) in gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map end;; (* ******************************************* *) (* JavaSpecificSynf *) (* ******************************************* *) (* Some Java-specific syntax filters that can run after ExprUnwrap dependencies: Runs after ExprUnwarp *) module JavaSpecificSynf = struct let name = "java_specific" let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority; DBefore IntDivisionSynf.priority ] let java_hash s = let h = ref Int32.zero in let thirtyone = Int32.of_int 31 in for i = 0 to String.length s - 1 do h := Int32.add (Int32.mul thirtyone !h) (Int32.of_int (int_of_char (String.unsafe_get s i))); done; !h let rec is_final_return_expr is_switch e = let is_final_return_expr = is_final_return_expr is_switch in match e.eexpr with | TReturn _ | TThrow _ -> true (* this is hack to not use 'break' on switch cases *) | TLocal { v_name = "__fallback__" } when is_switch -> true | TCall( { eexpr = TLocal { v_name = "__goto__" } }, _ ) -> true | TParenthesis p -> is_final_return_expr p | TBlock bl -> is_final_return_block is_switch bl | TSwitch (_, el_e_l, edef) -> List.for_all (fun (_,e) -> is_final_return_expr e) el_e_l && Option.map_default is_final_return_expr false edef | TMatch (_, _, il_vl_e_l, edef) -> List.for_all (fun (_,_,e) -> is_final_return_expr e)il_vl_e_l && Option.map_default is_final_return_expr false edef | TIf (_,eif, Some eelse) -> is_final_return_expr eif && is_final_return_expr eelse | TFor (_,_,e) -> is_final_return_expr e | TWhile (_,e,_) -> is_final_return_expr e | TFunction tf -> is_final_return_expr tf.tf_expr | TTry (e, ve_l) -> is_final_return_expr e && List.for_all (fun (_,e) -> is_final_return_expr e) ve_l | _ -> false and is_final_return_block is_switch el = match el with | [] -> false | final :: [] -> is_final_return_expr is_switch final | hd :: tl -> is_final_return_block is_switch tl let is_null e = match e.eexpr with | TConst(TNull) -> true | _ -> false let rec is_equatable gen t = match follow t with | TInst(cl,_) -> if cl.cl_path = (["haxe";"lang"], "IEquatable") then true else List.exists (fun (cl,p) -> is_equatable gen (TInst(cl,p))) cl.cl_implements || (match cl.cl_super with | Some(cl,p) -> is_equatable gen (TInst(cl,p)) | None -> false) | _ -> false (* Changing string switch will take an expression like switch(str) { case "a": case "b": } and modify it to: { var execute_def = true; switch(str.hashCode()) { case (hashcode of a): if (str == "a") { execute_def = false; ..code here } //else if (str == otherVariableWithSameHashCode) { ... } ... } if (execute_def) { ..default code } } this might actually be slower in some cases than a if/else approach, but it scales well and as a bonus, hashCode in java are cached, so we only have the performance hit once to cache it. *) let change_string_switch gen eswitch e1 ecases edefault = let basic = gen.gcon.basic in let is_final_ret = is_final_return_expr false eswitch in let has_default = is_some edefault in let block = ref [] in let local = match e1.eexpr with | TLocal _ -> e1 | _ -> let var = mk_temp gen "svar" e1.etype in let added = { e1 with eexpr = TVars([var, Some(e1)]); etype = basic.tvoid } in let local = mk_local var e1.epos in block := added :: !block; local in let execute_def_var = mk_temp gen "executeDef" gen.gcon.basic.tbool in let execute_def = mk_local execute_def_var e1.epos in let execute_def_set = { eexpr = TBinop(Ast.OpAssign, execute_def, { eexpr = TConst(TBool false); etype = basic.tbool; epos = e1.epos }); etype = basic.tbool; epos = e1.epos } in let hash_cache = ref None in let local_hashcode = ref { local with eexpr = TCall({ local with eexpr = TField(local, FDynamic "hashCode"); etype = TFun([], basic.tint); }, []); etype = basic.tint } in let get_hash_cache () = match !hash_cache with | Some c -> c | None -> let var = mk_temp gen "hash" basic.tint in let cond = !local_hashcode in block := { eexpr = TVars([var, Some cond]); etype = basic.tvoid; epos = local.epos } :: !block; let local = mk_local var local.epos in local_hashcode := local; hash_cache := Some local; local in let has_case = ref false in (* first we need to reorder all cases so all collisions are close to each other *) let get_str e = match e.eexpr with | TConst(TString s) -> s | _ -> assert false in let has_conflict = ref false in let rec reorder_cases unordered ordered = match unordered with | [] -> ordered | (el, e) :: tl -> let current = Hashtbl.create 1 in List.iter (fun e -> let str = get_str e in let hash = java_hash str in Hashtbl.add current hash true ) el; let rec extract_fields cases found_cases ret_cases = match cases with | [] -> found_cases, ret_cases | (el, e) :: tl -> if List.exists (fun e -> Hashtbl.mem current (java_hash (get_str e)) ) el then begin has_conflict := true; List.iter (fun e -> Hashtbl.add current (java_hash (get_str e)) true) el; extract_fields tl ( (el, e) :: found_cases ) ret_cases end else extract_fields tl found_cases ( (el, e) :: ret_cases ) in let found, remaining = extract_fields tl [] [] in let ret = if found <> [] then let ret = List.sort (fun (e1,_) (e2,_) -> compare (List.length e2) (List.length e1) ) ( (el, e) :: found ) in let rec loop ret acc = match ret with | (el, e) :: ( (_,_) :: _ as tl ) -> loop tl ( (true, el, e) :: acc ) | (el, e) :: [] -> ( (false, el, e) :: acc ) | _ -> assert false in List.rev (loop ret []) else (false, el, e) :: [] in reorder_cases remaining (ordered @ ret) in let already_in_cases = Hashtbl.create 0 in let change_case (has_fallback, el, e) = let conds, el = List.fold_left (fun (conds,el) e -> has_case := true; match e.eexpr with | TConst(TString s) -> let hashed = java_hash s in let equals_test = { eexpr = TCall({ e with eexpr = TField(local, FDynamic "equals"); etype = TFun(["obj",false,t_dynamic],basic.tbool) }, [ e ]); etype = basic.tbool; epos = e.epos } in let hashed_expr = { eexpr = TConst(TInt hashed); etype = basic.tint; epos = e.epos } in let hashed_exprs = if !has_conflict then begin if Hashtbl.mem already_in_cases hashed then el else begin Hashtbl.add already_in_cases hashed true; hashed_expr :: el end end else hashed_expr :: el in let conds = match conds with | None -> equals_test | Some c -> (* if there is more than one case, we should test first if hash equals to the one specified. This way we can save a heavier string compare *) let equals_test = mk_paren { eexpr = TBinop(Ast.OpBoolAnd, { eexpr = TBinop(Ast.OpEq, get_hash_cache(), hashed_expr); etype = basic.tbool; epos = e.epos }, equals_test); etype = basic.tbool; epos = e.epos; } in { eexpr = TBinop(Ast.OpBoolOr, equals_test, c); etype = basic.tbool; epos = e1.epos } in Some conds, hashed_exprs | _ -> assert false ) (None,[]) el in let e = if has_default then Codegen.concat execute_def_set e else e in let e = if !has_conflict then Codegen.concat e { e with eexpr = TBreak; etype = basic.tvoid } else e in let e = { eexpr = TIf(get conds, e, None); etype = basic.tvoid; epos = e.epos } in let e = if has_fallback then { e with eexpr = TBlock([ e; mk_local (alloc_var "__fallback__" t_dynamic) e.epos]) } else e in (el, e) in let switch = { eswitch with eexpr = TSwitch(!local_hashcode, List.map change_case (reorder_cases ecases []), None); } in (if !has_case then begin (if has_default then block := { e1 with eexpr = TVars([execute_def_var, Some({ e1 with eexpr = TConst(TBool true); etype = basic.tbool })]); etype = basic.tvoid } :: !block); block := switch :: !block end); (match edefault with | None -> () | Some edef when not !has_case -> block := edef :: !block | Some edef -> let eelse = if is_final_ret then Some { eexpr = TThrow { eexpr = TConst(TNull); etype = t_dynamic; epos = edef.epos }; etype = basic.tvoid; epos = edef.epos } else None in block := { edef with eexpr = TIf(execute_def, edef, eelse); etype = basic.tvoid } :: !block ); { eswitch with eexpr = TBlock(List.rev !block) } let get_cl_from_t t = match follow t with | TInst(cl,_) -> cl | _ -> assert false let traverse gen runtime_cl = let basic = gen.gcon.basic in let tchar = mt_to_t_dyn ( get_type gen (["java"], "Char16") ) in let tbyte = mt_to_t_dyn ( get_type gen (["java"], "Int8") ) in let tshort = mt_to_t_dyn ( get_type gen (["java"], "Int16") ) in let tsingle = mt_to_t_dyn ( get_type gen ([], "Single") ) in let string_ext = get_cl ( get_type gen (["haxe";"lang"], "StringExt")) in let is_string t = match follow t with | TInst({ cl_path = ([], "String") }, []) -> true | _ -> false in let rec run e = match e.eexpr with (* for new NativeArray issues *) | TNew(({ cl_path = (["java"], "NativeArray") } as cl), [t], el) when t_has_type_param t -> mk_cast (TInst(cl,[t])) (mk_cast t_dynamic ({ e with eexpr = TNew(cl, [t_empty], List.map run el) })) (* Std.int() *) | TCall( { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "int" })) }, [obj] ) -> run (mk_cast basic.tint obj) (* end Std.int() *) | TField( ef, FInstance({ cl_path = ([], "String") }, { cf_name = "length" }) ) -> { e with eexpr = TCall(Type.map_expr run e, []) } | TField( ef, field ) when field_name field = "length" && is_string ef.etype -> { e with eexpr = TCall(Type.map_expr run e, []) } | TCall( ( { eexpr = TField(ef, field) } as efield ), args ) when is_string ef.etype && String.get (field_name field) 0 = '_' -> let field = field_name field in { e with eexpr = TCall({ efield with eexpr = TField(run ef, FDynamic (String.sub field 1 ( (String.length field) - 1)) )}, List.map run args) } | TCall( ( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, field )) } as efield ), args ) -> let field = field.cf_name in (match field with | "charAt" | "charCodeAt" | "split" | "indexOf" | "lastIndexOf" | "substring" | "substr" -> { e with eexpr = TCall(mk_static_field_access_infer string_ext field e.epos [], [run ef] @ (List.map run args)) } | _ -> { e with eexpr = TCall(run efield, List.map run args) } ) | TCast(expr, m) when is_boxed_type e.etype -> (* let unboxed_type gen t tbyte tshort tchar tfloat = match follow t with *) run { e with etype = unboxed_type gen e.etype tbyte tshort tchar tsingle } | TCast(expr, _) when is_bool e.etype -> { eexpr = TCall( mk_static_field_access_infer runtime_cl "toBool" expr.epos [], [ run expr ] ); etype = basic.tbool; epos = e.epos } | TCast(expr, _) when is_int_float gen e.etype && not (is_int_float gen expr.etype) -> let needs_cast = match gen.gfollow#run_f e.etype with | TInst _ -> false | _ -> true in let fun_name = if like_int e.etype then "toInt" else "toDouble" in let ret = { eexpr = TCall( mk_static_field_access_infer runtime_cl fun_name expr.epos [], [ run expr ] ); etype = if fun_name = "toDouble" then basic.tfloat else basic.tint; epos = expr.epos } in if needs_cast then mk_cast e.etype ret else ret (*| TCast(expr, c) when is_int_float gen e.etype -> (* cases when float x = (float) (java.lang.Double val); *) (* FIXME: this fix is broken since it will fail on cases where float x = (float) (java.lang.Float val) or similar. FIX THIS *) let need_second_cast = match gen.gfollow#run_f e.etype with | TInst _ -> false | _ -> true in if need_second_cast then { e with eexpr = TCast(mk_cast (follow e.etype) (run expr), c) } else Type.map_expr run e*) | TBinop( (Ast.OpAssignOp OpAdd as op), e1, e2) | TBinop( (Ast.OpAdd as op), e1, e2) when is_string e.etype || is_string e1.etype || is_string e2.etype -> let is_assign = match op with Ast.OpAssignOp _ -> true | _ -> false in let mk_to_string e = { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "toString" e.epos [], [run e] ); etype = gen.gcon.basic.tstring } in let check_cast e = match gen.greal_type e.etype with | TDynamic _ | TAbstract({ a_path = ([], "Float") }, []) | TAbstract({ a_path = ([], "Single") }, []) -> mk_to_string e | _ -> run e in { e with eexpr = TBinop(op, (if is_assign then run e1 else check_cast e1), check_cast e2) } | TCast(expr, _) when is_string e.etype -> { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "toString" expr.epos [], [run expr] ) } | TSwitch(cond, ecases, edefault) when is_string cond.etype -> (*let change_string_switch gen eswitch e1 ecases edefault =*) change_string_switch gen e (run cond) (List.map (fun (el,e) -> (el, run e)) ecases) (Option.map run edefault) | TBinop( (Ast.OpNotEq as op), e1, e2) | TBinop( (Ast.OpEq as op), e1, e2) when not (is_null e2 || is_null e1) && (is_string e1.etype || is_string e2.etype || is_equatable gen e1.etype || is_equatable gen e2.etype) -> let static = mk_static_field_access_infer (runtime_cl) "valEq" e1.epos [] in let eret = { eexpr = TCall(static, [run e1; run e2]); etype = gen.gcon.basic.tbool; epos=e.epos } in if op = Ast.OpNotEq then { eret with eexpr = TUnop(Ast.Not, Ast.Prefix, eret) } else eret | TBinop( (Ast.OpNotEq | Ast.OpEq as op), e1, e2) when is_cl e1.etype && is_cl e2.etype -> { e with eexpr = TBinop(op, mk_cast t_empty (run e1), mk_cast t_empty (run e2)) } | _ -> Type.map_expr run e in run let configure gen (mapping_func:texpr->texpr) = (if java_hash "Testing string hashCode implementation from haXe" <> (Int32.of_int 545883604) then assert false); let map e = Some(mapping_func e) in gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map end;; let connecting_string = "?" (* ? see list here http://www.fileformat.info/info/unicode/category/index.htm and here for C# http://msdn.microsoft.com/en-us/library/aa664670.aspx *) let default_package = "java" (* I'm having this separated as I'm still not happy with having a cs package. Maybe dotnet would be better? *) let strict_mode = ref false (* strict mode is so we can check for unexpected information *) (* reserved c# words *) let reserved = let res = Hashtbl.create 120 in List.iter (fun lst -> Hashtbl.add res lst ("_" ^ lst)) ["abstract"; "assert"; "boolean"; "break"; "byte"; "case"; "catch"; "char"; "class"; "const"; "continue"; "default"; "do"; "double"; "else"; "enum"; "extends"; "final"; "false"; "finally"; "float"; "for"; "goto"; "if"; "implements"; "import"; "instanceof"; "int"; "interface"; "long"; "native"; "new"; "null"; "package"; "private"; "protected"; "public"; "return"; "short"; "static"; "strictfp"; "super"; "switch"; "synchronized"; "this"; "throw"; "throws"; "transient"; "true"; "try"; "void"; "volatile"; "while"; ]; res let dynamic_anon = TAnon( { a_fields = PMap.empty; a_status = ref Closed } ) let rec get_class_modifiers meta cl_type cl_access cl_modifiers = match meta with | [] -> cl_type,cl_access,cl_modifiers (*| (Meta.Struct,[],_) :: meta -> get_class_modifiers meta "struct" cl_access cl_modifiers*) | (Meta.Protected,[],_) :: meta -> get_class_modifiers meta cl_type "protected" cl_modifiers | (Meta.Internal,[],_) :: meta -> get_class_modifiers meta cl_type "" cl_modifiers (* no abstract for now | (":abstract",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("abstract" :: cl_modifiers) | (Meta.Static,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("static" :: cl_modifiers) TODO: support those types *) | (Meta.Final,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("final" :: cl_modifiers) | _ :: meta -> get_class_modifiers meta cl_type cl_access cl_modifiers let rec get_fun_modifiers meta access modifiers = match meta with | [] -> access,modifiers | (Meta.Protected,[],_) :: meta -> get_fun_modifiers meta "protected" modifiers | (Meta.Internal,[],_) :: meta -> get_fun_modifiers meta "" modifiers (*| (Meta.ReadOnly,[],_) :: meta -> get_fun_modifiers meta access ("readonly" :: modifiers)*) (*| (Meta.Unsafe,[],_) :: meta -> get_fun_modifiers meta access ("unsafe" :: modifiers)*) | (Meta.Volatile,[],_) :: meta -> get_fun_modifiers meta access ("volatile" :: modifiers) | (Meta.Transient,[],_) :: meta -> get_fun_modifiers meta access ("transient" :: modifiers) | _ :: meta -> get_fun_modifiers meta access modifiers (* this was the way I found to pass the generator context to be accessible across all functions here *) (* so 'configure' is almost 'top-level' and will have all functions needed to make this work *) let configure gen = let basic = gen.gcon.basic in let fn_cl = get_cl (get_type gen (["haxe";"lang"],"Function")) in let runtime_cl = get_cl (get_type gen (["haxe";"lang"],"Runtime")) in (*let string_ref = get_cl ( get_type gen (["haxe";"lang"], "StringRefl")) in*) let ti64 = match ( get_type gen (["haxe";"_Int64"], "NativeInt64") ) with | TTypeDecl t -> TType(t,[]) | _ -> assert false in let has_tdynamic params = List.exists (fun e -> match run_follow gen e with | TDynamic _ -> true | _ -> false) params in (* The type parameters always need to be changed to their boxed counterparts *) let change_param_type md params = match md with | TClassDecl( { cl_path = (["java"], "NativeArray") } ) -> params | _ -> match params with | [] -> [] | _ -> if has_tdynamic params then List.map (fun _ -> t_dynamic) params else List.map (fun t -> let f_t = gen.gfollow#run_f t in match f_t with | TEnum ({ e_path = ([], "Bool") }, []) | TAbstract ({ a_path = ([], "Bool") },[]) | TInst ({ cl_path = ([],"Float") },[]) | TAbstract ({ a_path = ([],"Float") },[]) | TInst ({ cl_path = ["haxe"],"Int32" },[]) | TInst ({ cl_path = ["haxe"],"Int64" },[]) | TInst ({ cl_path = ([],"Int") },[]) | TAbstract ({ a_path = ([],"Int") },[]) | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[]) | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) | TType ({ t_path = ["java"],"Int8" },[]) | TAbstract ({ a_path = ["java"],"Int8" },[]) | TType ({ t_path = ["java"],"Int16" },[]) | TAbstract ({ a_path = ["java"],"Int16" },[]) | TType ({ t_path = ["java"],"Char16" },[]) | TAbstract ({ a_path = ["java"],"Char16" },[]) | TType ({ t_path = [],"Single" },[]) | TAbstract ({ a_path = [],"Single" },[]) -> basic.tnull f_t (*| TType ({ t_path = [], "Null"*) | TInst (cl, ((_ :: _) as p)) -> TInst(cl, List.map (fun _ -> t_dynamic) p) | TEnum (e, ((_ :: _) as p)) -> TEnum(e, List.map (fun _ -> t_dynamic) p) | _ -> t ) params in let change_clname name = String.map (function | '$' -> '.' | c -> c) name in let change_id name = try Hashtbl.find reserved name with | Not_found -> name in let rec change_ns ns = match ns with | [] -> ["haxe"; "root"] | _ -> List.map change_id ns in let change_field = change_id in let write_id w name = write w (change_id name) in let write_field w name = write w (change_field name) in gen.gfollow#add ~name:"follow_basic" (fun t -> match t with | TEnum ({ e_path = ([], "Bool") }, []) | TAbstract ({ a_path = ([], "Bool") },[]) | TEnum ({ e_path = ([], "Void") }, []) | TAbstract ({ a_path = ([], "Void") },[]) | TInst ({ cl_path = ([],"Float") },[]) | TAbstract ({ a_path = ([],"Float") },[]) | TInst ({ cl_path = ([],"Int") },[]) | TAbstract ({ a_path = ([],"Int") },[]) | TInst( { cl_path = (["haxe"], "Int32") }, [] ) | TInst( { cl_path = (["haxe"], "Int64") }, [] ) | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[]) | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) | TType ({ t_path = ["java"],"Int8" },[]) | TAbstract ({ a_path = ["java"],"Int8" },[]) | TType ({ t_path = ["java"],"Int16" },[]) | TAbstract ({ a_path = ["java"],"Int16" },[]) | TType ({ t_path = ["java"],"Char16" },[]) | TAbstract ({ a_path = ["java"],"Char16" },[]) | TType ({ t_path = [],"Single" },[]) | TAbstract ({ a_path = [],"Single" },[]) | TType ({ t_path = [],"Null" },[_]) -> Some t | TAbstract ({ a_impl = Some _ } as a, pl) -> Some (gen.gfollow#run_f ( Codegen.Abstract.get_underlying_type a pl) ) | TAbstract( { a_path = ([], "EnumValue") }, _ ) | TInst( { cl_path = ([], "EnumValue") }, _ ) -> Some t_dynamic | _ -> None); let change_path path = (change_ns (fst path), change_clname (snd path)) in let path_s path = match path with | (ns,clname) -> path_s (change_ns ns, change_clname clname) in let cl_cl = get_cl (get_type gen (["java";"lang"],"Class")) in let rec real_type t = let t = gen.gfollow#run_f t in match t with | TAbstract ({ a_impl = Some _ } as a, pl) -> real_type (Codegen.Abstract.get_underlying_type a pl) | TInst( { cl_path = (["haxe"], "Int32") }, [] ) -> gen.gcon.basic.tint | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> ti64 | TAbstract( { a_path = ([], "Class") }, p ) | TAbstract( { a_path = ([], "Enum") }, p ) | TInst( { cl_path = ([], "Class") }, p ) | TInst( { cl_path = ([], "Enum") }, p ) -> TInst(cl_cl,p) | TEnum(e,params) -> TEnum(e, List.map (fun _ -> t_dynamic) params) | TInst(c,params) when Meta.has Meta.Enum c.cl_meta -> TInst(c, List.map (fun _ -> t_dynamic) params) | TInst _ -> t | TType({ t_path = ([], "Null") }, [t]) when is_java_basic_type t -> t_dynamic | TType({ t_path = ([], "Null") }, [t]) -> (match follow t with | TInst( { cl_kind = KTypeParameter _ }, []) -> (* t_dynamic *) real_type t | _ -> real_type t ) | TType _ | TAbstract _ -> t | TAnon (anon) -> (match !(anon.a_status) with | Statics _ | EnumStatics _ | AbstractStatics _ -> t | _ -> t_dynamic) | TFun _ -> TInst(fn_cl,[]) | _ -> t_dynamic in let scope = ref PMap.empty in let imports = ref [] in let clear_scope () = scope := PMap.empty; imports := []; in let add_scope name = scope := PMap.add name () !scope in let add_import pos path = let name = snd path in let rec loop = function | (pack, n) :: _ when name = n -> if path <> (pack,n) then gen.gcon.error ("This expression cannot be generated because " ^ path_s path ^ " is shadowed by the current scope and ") pos | _ :: tl -> loop tl | [] -> (* add import *) imports := path :: !imports in loop !imports in let path_s_import pos path = match path with | [], name when PMap.mem name !scope -> gen.gcon.error ("This expression cannot be generated because " ^ name ^ " is shadowed by the current scope") pos; name | pack1 :: _, name when PMap.mem pack1 !scope -> (* exists in scope *) add_import pos path; (* check if name exists in scope *) if PMap.mem name !scope then gen.gcon.error ("This expression cannot be generated because " ^ pack1 ^ " and " ^ name ^ " are both shadowed by the current scope") pos; name | _ -> path_s path in let is_dynamic t = match real_type t with | TMono _ | TDynamic _ -> true | TAnon anon -> (match !(anon.a_status) with | EnumStatics _ | Statics _ | AbstractStatics _ -> false | _ -> true ) | _ -> false in let rec t_s pos t = match real_type t with (* basic types *) | TEnum ({ e_path = ([], "Bool") }, []) | TAbstract ({ a_path = ([], "Bool") },[]) -> "boolean" | TEnum ({ e_path = ([], "Void") }, []) | TAbstract ({ a_path = ([], "Void") },[]) -> path_s_import pos (["java";"lang"], "Object") | TInst ({ cl_path = ([],"Float") },[]) | TAbstract ({ a_path = ([],"Float") },[]) -> "double" | TInst ({ cl_path = ([],"Int") },[]) | TAbstract ({ a_path = ([],"Int") },[]) -> "int" | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[]) | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) -> "long" | TType ({ t_path = ["java"],"Int8" },[]) | TAbstract ({ a_path = ["java"],"Int8" },[]) -> "byte" | TType ({ t_path = ["java"],"Int16" },[]) | TAbstract ({ a_path = ["java"],"Int16" },[]) -> "short" | TType ({ t_path = ["java"],"Char16" },[]) | TAbstract ({ a_path = ["java"],"Char16" },[]) -> "char" | TType ({ t_path = [],"Single" },[]) | TAbstract ({ a_path = [],"Single" },[]) -> "float" | TInst ({ cl_path = ["haxe"],"Int32" },[]) | TAbstract ({ a_path = ["haxe"],"Int32" },[]) -> "int" | TInst ({ cl_path = ["haxe"],"Int64" },[]) | TAbstract ({ a_path = ["haxe"],"Int64" },[]) -> "long" | TInst({ cl_path = (["java"], "NativeArray") }, [param]) -> let rec check_t_s t = match real_type t with | TInst({ cl_path = (["java"], "NativeArray") }, [param]) -> (check_t_s param) ^ "[]" | _ -> t_s pos (run_follow gen t) in (check_t_s param) ^ "[]" (* end of basic types *) | TInst ({ cl_kind = KTypeParameter _; cl_path=p }, []) -> snd p | TAbstract ({ a_path = [], "Dynamic" },[]) -> path_s_import pos (["java";"lang"], "Object") | TMono r -> (match !r with | None -> "java.lang.Object" | Some t -> t_s pos (run_follow gen t)) | TInst ({ cl_path = [], "String" }, []) -> path_s_import pos (["java";"lang"], "String") | TAbstract ({ a_path = [], "Class" }, [p]) | TAbstract ({ a_path = [], "Enum" }, [p]) | TInst ({ cl_path = [], "Class" }, [p]) | TInst ({ cl_path = [], "Enum" }, [p]) -> path_param_s pos (TClassDecl cl_cl) (["java";"lang"], "Class") [p] | TAbstract ({ a_path = [], "Class" }, _) | TAbstract ({ a_path = [], "Enum" }, _) | TInst ({ cl_path = [], "Class" }, _) | TInst ({ cl_path = [], "Enum" }, _) -> path_s_import pos (["java";"lang"], "Class") | TEnum ({e_path = p}, _) -> path_s_import pos p | TInst (({cl_path = p;} as cl), _) when Meta.has Meta.Enum cl.cl_meta -> path_s_import pos p | TInst (({cl_path = p;} as cl), params) -> (path_param_s pos (TClassDecl cl) p params) | TType (({t_path = p;} as t), params) -> (path_param_s pos (TTypeDecl t) p params) | TAnon (anon) -> (match !(anon.a_status) with | Statics _ | EnumStatics _ | AbstractStatics _ -> path_s_import pos (["java";"lang"], "Class") | _ -> path_s_import pos (["java";"lang"], "Object")) | TDynamic _ -> path_s_import pos (["java";"lang"], "Object") (* No Lazy type nor Function type made. That's because function types will be at this point be converted into other types *) | _ -> if !strict_mode then begin trace ("[ !TypeError " ^ (Type.s_type (Type.print_context()) t) ^ " ]"); assert false end else "[ !TypeError " ^ (Type.s_type (Type.print_context()) t) ^ " ]" and param_t_s pos t = match run_follow gen t with | TEnum ({ e_path = ([], "Bool") }, []) | TAbstract ({ a_path = ([], "Bool") },[]) -> path_s_import pos (["java";"lang"], "Boolean") | TInst ({ cl_path = ([],"Float") },[]) | TAbstract ({ a_path = ([],"Float") },[]) -> path_s_import pos (["java";"lang"], "Double") | TInst ({ cl_path = ([],"Int") },[]) | TAbstract ({ a_path = ([],"Int") },[]) -> path_s_import pos (["java";"lang"], "Integer") | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[]) | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) -> path_s_import pos (["java";"lang"], "Long") | TInst ({ cl_path = ["haxe"],"Int64" },[]) | TAbstract ({ a_path = ["haxe"],"Int64" },[]) -> path_s_import pos (["java";"lang"], "Long") | TInst ({ cl_path = ["haxe"],"Int32" },[]) | TAbstract ({ a_path = ["haxe"],"Int32" },[]) -> path_s_import pos (["java";"lang"], "Integer") | TType ({ t_path = ["java"],"Int8" },[]) | TAbstract ({ a_path = ["java"],"Int8" },[]) -> path_s_import pos (["java";"lang"], "Byte") | TType ({ t_path = ["java"],"Int16" },[]) | TAbstract ({ a_path = ["java"],"Int16" },[]) -> path_s_import pos (["java";"lang"], "Short") | TType ({ t_path = ["java"],"Char16" },[]) | TAbstract ({ a_path = ["java"],"Char16" },[]) -> path_s_import pos (["java";"lang"], "Character") | TType ({ t_path = [],"Single" },[]) | TAbstract ({ a_path = [],"Single" },[]) -> path_s_import pos (["java";"lang"], "Float") | TDynamic _ -> "?" | TInst (cl, params) -> t_s pos (TInst(cl, change_param_type (TClassDecl cl) params)) | TType (cl, params) -> t_s pos (TType(cl, change_param_type (TTypeDecl cl) params)) | TEnum (e, params) -> t_s pos (TEnum(e, change_param_type (TEnumDecl e) params)) | _ -> t_s pos t and path_param_s pos md path params = match params with | [] -> path_s_import pos path | _ when has_tdynamic (change_param_type md params) -> path_s_import pos path | _ -> sprintf "%s<%s>" (path_s_import pos path) (String.concat ", " (List.map (fun t -> param_t_s pos t) (change_param_type md params))) in let rett_s pos t = match t with | TEnum ({e_path = ([], "Void")}, []) | TAbstract ({ a_path = ([], "Void") },[]) -> "void" | _ -> t_s pos t in let escape ichar b = match ichar with | 92 (* \ *) -> Buffer.add_string b "\\\\" | 39 (* ' *) -> Buffer.add_string b "\\\'" | 34 -> Buffer.add_string b "\\\"" | 13 (* \r *) -> Buffer.add_string b "\\r" | 10 (* \n *) -> Buffer.add_string b "\\n" | 9 (* \t *) -> Buffer.add_string b "\\t" | c when c < 32 || c >= 127 -> Buffer.add_string b (Printf.sprintf "\\u%.4x" c) | c -> Buffer.add_char b (Char.chr c) in let escape s = let b = Buffer.create 0 in (try UTF8.validate s; UTF8.iter (fun c -> escape (UChar.code c) b) s with UTF8.Malformed_code -> String.iter (fun c -> escape (Char.code c) b) s ); Buffer.contents b in let has_semicolon e = match e.eexpr with | TLocal { v_name = "__fallback__" } | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt _) } ] ) -> false | TBlock _ | TFor _ | TSwitch _ | TMatch _ | TTry _ | TIf _ -> false | TWhile (_,_,flag) when flag = Ast.NormalWhile -> false | _ -> true in let in_value = ref false in let rec md_s pos md = let md = follow_module (gen.gfollow#run_f) md in match md with | TClassDecl (cl) -> t_s pos (TInst(cl,[])) | TEnumDecl (e) -> t_s pos (TEnum(e,[])) | TTypeDecl t -> t_s pos (TType(t, [])) | TAbstractDecl a -> t_s pos (TAbstract(a, [])) in (* it seems that Java doesn't like when you create a new array with the type parameter defined so we'll just ignore all type parameters, and hope for the best! *) let rec transform_nativearray_t t = match real_type t with | TInst( ({ cl_path = (["java"], "NativeArray") } as narr), [t]) -> TInst(narr, [transform_nativearray_t t]) | TInst(cl, params) -> TInst(cl, List.map (fun _ -> t_dynamic) params) | TEnum(e, params) -> TEnum(e, List.map (fun _ -> t_dynamic) params) | TType(t, params) -> TType(t, List.map (fun _ -> t_dynamic) params) | _ -> t in let expr_s w e = in_value := false; let rec expr_s w e = let was_in_value = !in_value in in_value := true; match e.eexpr with | TConst c -> (match c with | TInt i32 -> print w "%ld" i32; (match real_type e.etype with | TType( { t_path = (["haxe";"_Int64"], "NativeInt64") }, [] ) -> write w "L"; | _ -> () ) | TFloat s -> write w s; (* fix for Int notation, which only fit in a Float *) (if not (String.contains s '.' || String.contains s 'e' || String.contains s 'E') then write w ".0"); (match real_type e.etype with | TType( { t_path = ([], "Single") }, [] ) -> write w "f" | _ -> () ) | TString s -> print w "\"%s\"" (escape s) | TBool b -> write w (if b then "true" else "false") | TNull -> (match real_type e.etype with | TType( { t_path = (["haxe";"_Int64"], "NativeInt64") }, [] ) | TInst( { cl_path = (["haxe"], "Int64") }, [] ) -> write w "0L" | TInst( { cl_path = (["haxe"], "Int32") }, [] ) | TInst({ cl_path = ([], "Int") },[]) | TAbstract ({ a_path = ([], "Int") },[]) -> expr_s w ({ e with eexpr = TConst(TInt Int32.zero) }) | TInst({ cl_path = ([], "Float") },[]) | TAbstract ({ a_path = ([], "Float") },[]) -> expr_s w ({ e with eexpr = TConst(TFloat "0.0") }) | TEnum({ e_path = ([], "Bool") }, []) | TAbstract ({ a_path = ([], "Bool") },[]) -> write w "false" | TAbstract _ when like_int e.etype -> expr_s w { e with eexpr = TConst(TInt Int32.zero) } | TAbstract _ when like_float e.etype -> expr_s w { e with eexpr = TConst(TFloat "0.0") } | _ -> write w "null") | TThis -> write w "this" | TSuper -> write w "super") | TLocal { v_name = "__fallback__" } -> () | TLocal { v_name = "__sbreak__" } -> write w "break" | TLocal { v_name = "__undefined__" } -> write w (t_s e.epos (TInst(runtime_cl, List.map (fun _ -> t_dynamic) runtime_cl.cl_types))); write w ".undefined"; | TLocal var -> write_id w var.v_name | TField(_, FEnum(en,ef)) -> let s = ef.ef_name in print w "%s." (path_s_import e.epos en.e_path); write_field w s | TArray (e1, e2) -> expr_s w e1; write w "["; expr_s w e2; write w "]" | TBinop ((Ast.OpAssign as op), e1, e2) | TBinop ((Ast.OpAssignOp _ as op), e1, e2) -> expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2 | TBinop (op, e1, e2) -> write w "( "; expr_s w e1; write w ( " " ^ (Ast.s_binop op) ^ " " ); expr_s w e2; write w " )" | TField (e, FStatic(_, cf)) when Meta.has Meta.Native cf.cf_meta -> let rec loop meta = match meta with | (Meta.Native, [EConst (String s), _],_) :: _ -> expr_s w e; write w "."; write_field w s | _ :: tl -> loop tl | [] -> expr_s w e; write w "."; write_field w (cf.cf_name) in loop cf.cf_meta | TField (e, s) -> expr_s w e; write w "."; write_field w (field_name s) | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int32") }) -> write w (path_s_import e.epos (["haxe"], "Int32")) | TTypeExpr (TClassDecl { cl_path = (["haxe"], "Int64") }) -> write w (path_s_import e.epos (["haxe"], "Int64")) | TTypeExpr mt -> write w (md_s e.epos mt) | TParenthesis e -> write w "("; expr_s w e; write w ")" | TArrayDecl el when t_has_type_param_shallow false e.etype -> print w "( (%s) (new java.lang.Object[] " (t_s e.epos e.etype); write w "{"; ignore (List.fold_left (fun acc e -> (if acc <> 0 then write w ", "); expr_s w e; acc + 1 ) 0 el); write w "}) )" | TArrayDecl el -> print w "new %s" (param_t_s e.epos (transform_nativearray_t e.etype)); let is_double = match follow e.etype with | TInst(_,[ t ]) -> if like_float t && not (like_int t) then Some t else None | _ -> None in write w "{"; ignore (List.fold_left (fun acc e -> (if acc <> 0 then write w ", "); (* this is a hack so we are able to convert ints to boxed Double / Float when needed *) let e = if is_some is_double then mk_cast (get is_double) e else e in expr_s w e; acc + 1 ) 0 el); write w "}" | TCall( ( { eexpr = TField(_, FStatic({ cl_path = ([], "String") }, { cf_name = "fromCharCode" })) } ), [cc] ) -> write w "Character.toString((char) "; expr_s w cc; write w ")" | TCall ({ eexpr = TLocal( { v_name = "__is__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) -> write w "( "; expr_s w expr; write w " instanceof "; write w (md_s e.epos md); write w " )" | TCall ({ eexpr = TLocal( { v_name = "__java__" } ) }, [ { eexpr = TConst(TString(s)) } ] ) -> write w s | TCall ({ eexpr = TLocal( { v_name = "__lock__" } ) }, [ eobj; eblock ] ) -> write w "synchronized("; expr_s w eobj; write w ")"; expr_s w (mk_block eblock) | TCall ({ eexpr = TLocal( { v_name = "__goto__" } ) }, [ { eexpr = TConst(TInt v) } ] ) -> print w "break label%ld" v | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt v) } ] ) -> print w "label%ld:" v | TCall ({ eexpr = TLocal( { v_name = "__typeof__" } ) }, [ { eexpr = TTypeExpr md } as expr ] ) -> expr_s w expr; write w ".class" | TCall (e, el) -> let rec extract_tparams params el = match el with | ({ eexpr = TLocal({ v_name = "$type_param" }) } as tp) :: tl -> extract_tparams (tp.etype :: params) tl | _ -> (params, el) in let params, el = extract_tparams [] el in expr_s w e; (*(match params with | [] -> () | params -> let md = match e.eexpr with | TField(ef, _) -> t_to_md (run_follow gen ef.etype) | _ -> assert false in write w "<"; ignore (List.fold_left (fun acc t -> (if acc <> 0 then write w ", "); write w (param_t_s (change_param_type md t)); acc + 1 ) 0 params); write w ">" );*) write w "("; ignore (List.fold_left (fun acc e -> (if acc <> 0 then write w ", "); expr_s w e; acc + 1 ) 0 el); write w ")" | TNew (({ cl_path = (["java"], "NativeArray") } as cl), params, [ size ]) -> let rec check_t_s t times = match real_type t with | TInst({ cl_path = (["java"], "NativeArray") }, [param]) -> (check_t_s param (times+1)) | _ -> print w "new %s[" (t_s e.epos (transform_nativearray_t t)); expr_s w size; print w "]"; let rec loop i = if i <= 0 then () else (write w "[]"; loop (i-1)) in loop (times - 1) in check_t_s (TInst(cl, params)) 0 | TNew ({ cl_path = ([], "String") } as cl, [], el) -> write w "new "; write w (t_s e.epos (TInst(cl, []))); write w "("; ignore (List.fold_left (fun acc e -> (if acc <> 0 then write w ", "); expr_s w e; acc + 1 ) 0 el); write w ")" | TNew (cl, params, el) -> write w "new "; write w (path_param_s e.epos (TClassDecl cl) cl.cl_path params); write w "("; ignore (List.fold_left (fun acc e -> (if acc <> 0 then write w ", "); expr_s w e; acc + 1 ) 0 el); write w ")" | TUnop ((Ast.Increment as op), flag, e) | TUnop ((Ast.Decrement as op), flag, e) -> (match flag with | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " " ); expr_s w e | Ast.Postfix -> expr_s w e; write w (Ast.s_unop op)) | TUnop (op, flag, e) -> (match flag with | Ast.Prefix -> write w ( " " ^ (Ast.s_unop op) ^ " (" ); expr_s w e; write w ") " | Ast.Postfix -> write w "("; expr_s w e; write w (") " ^ Ast.s_unop op)) | TVars (v_eop_l) -> ignore (List.fold_left (fun acc (var, eopt) -> (if acc <> 0 then write w "; "); print w "%s " (t_s e.epos var.v_type); write_id w var.v_name; (match eopt with | None -> write w " = "; expr_s w (null var.v_type e.epos) | Some e -> write w " = "; expr_s w e ); acc + 1 ) 0 v_eop_l); | TBlock [e] when was_in_value -> expr_s w e | TBlock el -> begin_block w; (*let last_line = ref (-1) in let line_directive p = let cur_line = Lexer.get_error_line p in let is_relative_path = (String.sub p.pfile 0 1) = "." in let file = if is_relative_path then "../" ^ p.pfile else p.pfile in if cur_line <> ((!last_line)+1) then begin print w "//#line %d \"%s\"" cur_line (Ast.s_escape file); newline w end; last_line := cur_line in*) List.iter (fun e -> (*line_directive e.epos;*) in_value := false; (match e.eexpr with | TConst _ -> () | _ -> expr_s w e; (if has_semicolon e then write w ";"); newline w); ) el; end_block w | TIf (econd, e1, Some(eelse)) when was_in_value -> write w "( "; expr_s w (mk_paren econd); write w " ? "; expr_s w (mk_paren e1); write w " : "; expr_s w (mk_paren eelse); write w " )"; | TIf (econd, e1, eelse) -> write w "if "; expr_s w (mk_paren econd); write w " "; in_value := false; expr_s w (mk_block e1); (match eelse with | None -> () | Some e -> write w " else "; in_value := false; expr_s w (mk_block e) ) | TWhile (econd, eblock, flag) -> (match flag with | Ast.NormalWhile -> write w "while "; expr_s w (mk_paren econd); write w ""; in_value := false; expr_s w (mk_block eblock) | Ast.DoWhile -> write w "do "; in_value := false; expr_s w (mk_block eblock); write w "while "; in_value := true; expr_s w (mk_paren econd); ) | TSwitch (econd, ele_l, default) -> write w "switch "; expr_s w (mk_paren econd); begin_block w; List.iter (fun (el, e) -> List.iter (fun e -> write w "case "; in_value := true; expr_s w e; write w ":"; ) el; newline w; in_value := false; expr_s w (mk_block e); newline w; newline w ) ele_l; if is_some default then begin write w "default:"; newline w; in_value := false; expr_s w (get default); newline w; end; end_block w | TTry (tryexpr, ve_l) -> write w "try "; in_value := false; expr_s w (mk_block tryexpr); let pos = e.epos in List.iter (fun (var, e) -> print w "catch (%s %s)" (t_s pos var.v_type) (var.v_name); in_value := false; expr_s w (mk_block e); newline w ) ve_l | TReturn eopt -> write w "return "; if is_some eopt then expr_s w (get eopt) | TBreak -> write w "break" | TContinue -> write w "continue" | TThrow e -> write w "throw "; expr_s w e | TCast (e1,md_t) -> ((*match gen.gfollow#run_f e.etype with | TType({ t_path = ([], "UInt") }, []) -> write w "( unchecked ((uint) "; expr_s w e1; write w ") )" | _ ->*) (* FIXME I'm ignoring module type *) print w "((%s) (" (t_s e.epos e.etype); expr_s w e1; write w ") )" ) | TFor (_,_,content) -> write w "[ for not supported "; expr_s w content; write w " ]"; if !strict_mode then assert false | TObjectDecl _ -> write w "[ obj decl not supported ]"; if !strict_mode then assert false | TFunction _ -> write w "[ func decl not supported ]"; if !strict_mode then assert false | TMatch _ -> write w "[ match not supported ]"; if !strict_mode then assert false in expr_s w e in let get_string_params cl_types = match cl_types with | [] -> ("","") | _ -> let params = sprintf "<%s>" (String.concat ", " (List.map (fun (_, tcl) -> match follow tcl with | TInst(cl, _) -> snd cl.cl_path | _ -> assert false) cl_types)) in let params_extends = List.fold_left (fun acc (name, t) -> match run_follow gen t with | TInst (cl, p) -> (match cl.cl_implements with | [] -> acc | _ -> acc) (* TODO | _ -> (sprintf " where %s : %s" name (String.concat ", " (List.map (fun (cl,p) -> path_param_s (TClassDecl cl) cl.cl_path p) cl.cl_implements))) :: acc ) *) | _ -> trace (t_s Ast.null_pos t); assert false (* FIXME it seems that a cl_types will never be anything other than cl.cl_types. I'll take the risk and fail if not, just to see if that confirms *) ) [] cl_types in (params, String.concat " " params_extends) in let rec gen_class_field w ?(is_overload=false) is_static cl is_final cf = let is_interface = cl.cl_interface in let name, is_new, is_explicit_iface = match cf.cf_name with | "new" -> snd cl.cl_path, true, false | name when String.contains name '.' -> let fn_name, path = parse_explicit_iface name in (path_s path) ^ "." ^ fn_name, false, true | name -> name, false, false in (match cf.cf_kind with | Var _ | Method (MethDynamic) when not (Type.is_extern_field cf) -> (if is_overload || List.exists (fun cf -> cf.cf_expr <> None) cf.cf_overloads then gen.gcon.error "Only normal (non-dynamic) methods can be overloaded" cf.cf_pos); if not is_interface then begin let access, modifiers = get_fun_modifiers cf.cf_meta "public" [] in print w "%s %s%s %s %s" access (if is_static then "static " else "") (String.concat " " modifiers) (t_s cf.cf_pos (run_follow gen cf.cf_type)) (change_field name); (match cf.cf_expr with | Some e -> write w " = "; expr_s w e; write w ";" | None -> write w ";" ) end (* TODO see how (get,set) variable handle when they are interfaces *) | Method _ when Type.is_extern_field cf || (match cl.cl_kind, cf.cf_expr with | KAbstractImpl _, None -> true | _ -> false) -> List.iter (fun cf -> if cl.cl_interface || cf.cf_expr <> None then gen_class_field w ~is_overload:true is_static cl (Meta.has Meta.Final cf.cf_meta) cf ) cf.cf_overloads | Var _ | Method MethDynamic -> () | Method mkind -> List.iter (fun cf -> if cl.cl_interface || cf.cf_expr <> None then gen_class_field w ~is_overload:true is_static cl (Meta.has Meta.Final cf.cf_meta) cf ) cf.cf_overloads; let is_virtual = is_new || (not is_final && match mkind with | MethInline -> false | _ when not is_new -> true | _ -> false) in let is_override = match cf.cf_name with | "equals" when not is_static -> (match cf.cf_type with | TFun([_,_,t], ret) -> (match (real_type t, real_type ret) with | TDynamic _, TEnum( { e_path = ([], "Bool") }, []) | TDynamic _, TAbstract ({ a_path = ([], "Bool") },[]) | TAnon _, TEnum( { e_path = ([], "Bool") }, []) | TAnon _, TAbstract ({ a_path = ([], "Bool") },[]) -> true | _ -> List.memq cf cl.cl_overrides ) | _ -> List.memq cf cl.cl_overrides) | "toString" when not is_static -> (match cf.cf_type with | TFun([], ret) -> (match real_type ret with | TInst( { cl_path = ([], "String") }, []) -> true | _ -> gen.gcon.error "A toString() function should return a String!" cf.cf_pos; false ) | _ -> List.memq cf cl.cl_overrides ) | "hashCode" when not is_static -> (match cf.cf_type with | TFun([], ret) -> (match real_type ret with | TInst( { cl_path = ([], "Int") }, []) | TAbstract ({ a_path = ([], "Int") },[]) -> true | _ -> gen.gcon.error "A hashCode() function should return an Int!" cf.cf_pos; false ) | _ -> List.memq cf cl.cl_overrides ) | _ -> List.memq cf cl.cl_overrides in let visibility = if is_interface then "" else "public" in let visibility, modifiers = get_fun_modifiers cf.cf_meta visibility [] in let visibility, is_virtual = if is_explicit_iface then "",false else visibility, is_virtual in let v_n = if is_static then "static " else if is_override && not is_interface then "" else if not is_virtual then "final " else "" in let cf_type = if is_override && not is_overload && not (Meta.has Meta.Overload cf.cf_meta) then match field_access gen (TInst(cl, List.map snd cl.cl_types)) cf.cf_name with | FClassField(_,_,_,_,_,actual_t,_) -> actual_t | _ -> assert false else cf.cf_type in let params = List.map snd cl.cl_types in let ret_type, args = match follow cf_type, follow cf.cf_type with | TFun (strbtl, t), TFun(rargs, _) -> (apply_params cl.cl_types params (real_type t), List.map2 (fun(_,_,t) (n,o,_) -> (n,o,apply_params cl.cl_types params (real_type t))) strbtl rargs) | _ -> assert false in (if is_override && not is_interface then write w "@Override "); (* public static void funcName *) let params, _ = get_string_params cf.cf_params in print w "%s %s%s %s %s %s" (visibility) v_n (String.concat " " modifiers) params (if is_new then "" else rett_s cf.cf_pos (run_follow gen ret_type)) (change_field name); (* (string arg1, object arg2) with T : object *) (match cf.cf_expr with | Some { eexpr = TFunction tf } -> print w "(%s)" (String.concat ", " (List.map2 (fun (var,_) (_,_,t) -> sprintf "%s %s" (t_s cf.cf_pos (run_follow gen t)) (change_id var.v_name)) tf.tf_args args)) | _ -> print w "(%s)" (String.concat ", " (List.map (fun (name, _, t) -> sprintf "%s %s" (t_s cf.cf_pos (run_follow gen t)) (change_id name)) args)) ); if is_interface then write w ";" else begin let rec loop meta = match meta with | [] -> let expr = match cf.cf_expr with | None -> mk (TBlock([])) t_dynamic Ast.null_pos | Some s -> match s.eexpr with | TFunction tf -> mk_block (tf.tf_expr) | _ -> assert false (* FIXME *) in (if is_new then begin (*let rec get_super_call el = match el with | ( { eexpr = TCall( { eexpr = TConst(TSuper) }, _) } as call) :: rest -> Some call, rest | ( { eexpr = TBlock(bl) } as block ) :: rest -> let ret, mapped = get_super_call bl in ret, ( { block with eexpr = TBlock(mapped) } :: rest ) | _ -> None, el in*) expr_s w expr end else begin expr_s w expr; end) | (Meta.Throws, [Ast.EConst (Ast.String t), _], _) :: tl -> print w " throws %s" t; loop tl | (Meta.FunctionCode, [Ast.EConst (Ast.String contents),_],_) :: tl -> begin_block w; write w contents; end_block w | _ :: tl -> loop tl in loop cf.cf_meta end); newline w; newline w in let gen_class w cl = let should_close = match change_ns (fst cl.cl_path) with | [] -> false | ns -> print w "package %s;" (String.concat "." (change_ns ns)); newline w; false in let rec loop_meta meta acc = match meta with | (Meta.SuppressWarnings, [Ast.EConst (Ast.String w),_],_) :: meta -> loop_meta meta (w :: acc) | _ :: meta -> loop_meta meta acc | _ -> acc in let suppress_warnings = loop_meta cl.cl_meta [ "rawtypes"; "unchecked" ] in write w "import haxe.root.*;"; newline w; let w_header = w in let w = new_source_writer () in clear_scope(); (* add all haxe.root.* to imports *) List.iter (function | TClassDecl { cl_path = ([],c) } -> imports := ([],c) :: !imports | TEnumDecl { e_path = ([],c) } -> imports := ([],c) :: !imports | TAbstractDecl { a_path = ([],c) } -> imports := ([],c) :: !imports | _ -> () ) gen.gcon.types; newline w; write w "@SuppressWarnings(value={"; let first = ref true in List.iter (fun s -> (if !first then first := false else write w ", "); print w "\"%s\"" (escape s) ) suppress_warnings; write w "})"; newline w; let clt, access, modifiers = get_class_modifiers cl.cl_meta (if cl.cl_interface then "interface" else "class") "public" [] in let is_final = Meta.has Meta.Final cl.cl_meta in print w "%s %s %s %s" access (String.concat " " modifiers) clt (change_clname (snd cl.cl_path)); (* type parameters *) let params, _ = get_string_params cl.cl_types in let cl_p_to_string (c,p) = path_param_s cl.cl_pos (TClassDecl c) c.cl_path p in print w "%s" params; (if is_some cl.cl_super then print w " extends %s" (cl_p_to_string (get cl.cl_super))); (match cl.cl_implements with | [] -> () | _ -> print w " %s %s" (if cl.cl_interface then "extends" else "implements") (String.concat ", " (List.map cl_p_to_string cl.cl_implements)) ); (* class head ok: *) (* public class Test : X, Y, Z where A : Y *) begin_block w; (* our constructor is expected to be a normal "new" function * if !strict_mode && is_some cl.cl_constructor then assert false;*) let rec loop cl = List.iter (fun cf -> add_scope cf.cf_name) cl.cl_ordered_fields; List.iter (fun cf -> add_scope cf.cf_name) cl.cl_ordered_statics; match cl.cl_super with | Some(c,_) -> loop c | None -> () in loop cl; let rec loop meta = match meta with | [] -> () | (Meta.ClassCode, [Ast.EConst (Ast.String contents),_],_) :: tl -> write w contents | _ :: tl -> loop tl in loop cl.cl_meta; (match gen.gcon.main_class with | Some path when path = cl.cl_path -> write w "public static void main(String[] args)"; begin_block w; (try let t = Hashtbl.find gen.gtypes ([], "Sys") in match t with | TClassDecl(cl) when PMap.mem "_args" cl.cl_statics -> write w "Sys._args = args;"; newline w | _ -> () with | Not_found -> () ); write w "main();"; end_block w | _ -> () ); (match cl.cl_init with | None -> () | Some init -> write w "static "; expr_s w (mk_block init)); (if is_some cl.cl_constructor then gen_class_field w false cl is_final (get cl.cl_constructor)); (if not cl.cl_interface then List.iter (gen_class_field w true cl is_final) cl.cl_ordered_statics); List.iter (gen_class_field w false cl is_final) cl.cl_ordered_fields; end_block w; if should_close then end_block w; (* add imports *) List.iter (function | ["haxe";"root"], _ | [], _ -> () | path -> write w_header "import "; write w_header (path_s path); write w_header ";\n" ) !imports; add_writer w w_header in let gen_enum w e = let should_close = match change_ns (fst e.e_path) with | [] -> false | ns -> print w "package %s;" (String.concat "." (change_ns ns)); newline w; false in print w "public enum %s" (change_clname (snd e.e_path)); begin_block w; write w (String.concat ", " (List.map (change_id) e.e_names)); end_block w; if should_close then end_block w in let module_type_gen w md_tp = match md_tp with | TClassDecl cl -> if not cl.cl_extern then begin gen_class w cl; newline w; newline w end; (not cl.cl_extern) | TEnumDecl e -> if not e.e_extern then begin gen_enum w e; newline w; newline w end; (not e.e_extern) | TTypeDecl e -> false | TAbstractDecl a -> false in let module_gen w md = module_type_gen w md in (* generate source code *) init_ctx gen; Hashtbl.add gen.gspecial_vars "__label__" true; Hashtbl.add gen.gspecial_vars "__goto__" true; Hashtbl.add gen.gspecial_vars "__is__" true; Hashtbl.add gen.gspecial_vars "__typeof__" true; Hashtbl.add gen.gspecial_vars "__java__" true; Hashtbl.add gen.gspecial_vars "__lock__" true; gen.greal_type <- real_type; gen.greal_type_param <- change_param_type; SetHXGen.run_filter gen SetHXGen.default_hxgen_func; (* before running the filters, follow all possible types *) (* this is needed so our module transformations don't break some core features *) (* like multitype selection *) let run_follow_gen = run_follow gen in let rec type_map e = Type.map_expr_type (fun e->type_map e) (run_follow_gen) (fun tvar-> tvar.v_type <- (run_follow_gen tvar.v_type); tvar) e in let super_map (cl,tl) = (cl, List.map run_follow_gen tl) in List.iter (function | TClassDecl cl -> let all_fields = (Option.map_default (fun cf -> [cf]) [] cl.cl_constructor) @ cl.cl_ordered_fields @ cl.cl_ordered_statics in List.iter (fun cf -> cf.cf_type <- run_follow_gen cf.cf_type; cf.cf_expr <- Option.map type_map cf.cf_expr ) all_fields; cl.cl_dynamic <- Option.map run_follow_gen cl.cl_dynamic; cl.cl_array_access <- Option.map run_follow_gen cl.cl_array_access; cl.cl_init <- Option.map type_map cl.cl_init; cl.cl_super <- Option.map super_map cl.cl_super; cl.cl_implements <- List.map super_map cl.cl_implements | _ -> () ) gen.gcon.types; let closure_t = ClosuresToClass.DoubleAndDynamicClosureImpl.get_ctx gen 6 in (*let closure_t = ClosuresToClass.create gen 10 float_cl (fun l -> l) (fun l -> l) (fun args -> args) (fun args -> []) in ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (fun e _ _ -> e)); StubClosureImpl.configure gen (StubClosureImpl.default_implementation gen float_cl 10 (fun e _ _ -> e));*) FixOverrides.configure gen; NormalizeType.configure gen; AbstractImplementationFix.configure gen; IteratorsInterface.configure gen (fun e -> e); ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (get_cl (get_type gen (["haxe";"lang"],"Function")) )); EnumToClass.configure gen (None) false true (get_cl (get_type gen (["haxe";"lang"],"Enum")) ) false false; InterfaceVarsDeleteModf.configure gen; let dynamic_object = (get_cl (get_type gen (["haxe";"lang"],"DynamicObject")) ) in let object_iface = get_cl (get_type gen (["haxe";"lang"],"IHxObject")) in (*fixme: THIS IS A HACK. take this off *) let empty_e = match (get_type gen (["haxe";"lang"], "EmptyObject")) with | TEnumDecl e -> e | _ -> assert false in (*OverloadingCtor.set_new_create_empty gen ({eexpr=TEnumField(empty_e, "EMPTY"); etype=TEnum(empty_e,[]); epos=null_pos;});*) let empty_expr = { eexpr = (TTypeExpr (TEnumDecl empty_e)); etype = (TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics empty_e) }); epos = null_pos } in let empty_ef = try PMap.find "EMPTY" empty_e.e_constrs with Not_found -> gen.gcon.error "Required enum field EMPTY was not found" empty_e.e_pos; assert false in OverloadingConstructor.configure ~empty_ctor_type:(TEnum(empty_e, [])) ~empty_ctor_expr:({ eexpr=TField(empty_expr, FEnum(empty_e, empty_ef)); etype=TEnum(empty_e,[]); epos=null_pos; }) ~supports_ctor_inheritance:false gen; let rcf_static_find = mk_static_field_access_infer (get_cl (get_type gen (["haxe";"lang"], "FieldLookup"))) "findHash" Ast.null_pos [] in (*let rcf_static_lookup = mk_static_field_access_infer (get_cl (get_type gen (["haxe";"lang"], "FieldLookup"))) "lookupHash" Ast.null_pos [] in*) let can_be_float t = like_float (real_type t) in let rcf_on_getset_field main_expr field_expr field may_hash may_set is_unsafe = let is_float = can_be_float (if is_none may_set then main_expr.etype else (get may_set).etype) in let fn_name = if is_some may_set then "setField" else "getField" in let fn_name = if is_float then fn_name ^ "_f" else fn_name in let pos = field_expr.epos in let is_unsafe = { eexpr = TConst(TBool is_unsafe); etype = basic.tbool; epos = pos } in let should_cast = match main_expr.etype with | TInst({ cl_path = ([], "Float") }, []) -> false | _ -> true in let infer = mk_static_field_access_infer runtime_cl fn_name field_expr.epos [] in let first_args = [ field_expr; { eexpr = TConst(TString field); etype = basic.tstring; epos = pos } ] @ if is_some may_hash then [ { eexpr = TConst(TInt (get may_hash)); etype = basic.tint; epos = pos } ] else [] in let args = first_args @ match is_float, may_set with | true, Some(set) -> [ if should_cast then mk_cast basic.tfloat set else set ] | false, Some(set) -> [ set ] | _ -> [ is_unsafe ] in let call = { main_expr with eexpr = TCall(infer,args) } in let call = if is_float && should_cast then mk_cast main_expr.etype call else call in call in let rcf_on_call_field ecall field_expr field may_hash args = let infer = mk_static_field_access_infer runtime_cl "callField" field_expr.epos [] in let hash_arg = match may_hash with | None -> [] | Some h -> [ { eexpr = TConst(TInt h); etype = basic.tint; epos = field_expr.epos } ] in let arr_call = if args <> [] then { eexpr = TArrayDecl args; etype = basic.tarray t_dynamic; epos = ecall.epos } else null (basic.tarray t_dynamic) ecall.epos in let call_args = [field_expr; { field_expr with eexpr = TConst(TString field); etype = basic.tstring } ] @ hash_arg @ [ arr_call ] in mk_cast ecall.etype { ecall with eexpr = TCall(infer, call_args); etype = t_dynamic } in let rcf_ctx = ReflectionCFs.new_ctx gen closure_t object_iface false rcf_on_getset_field rcf_on_call_field (fun hash hash_array -> { hash with eexpr = TCall(rcf_static_find, [hash; hash_array]); etype=basic.tint } ) (fun hash -> hash ) false in ReflectionCFs.UniversalBaseClass.default_config gen (get_cl (get_type gen (["haxe";"lang"],"HxObject")) ) object_iface dynamic_object; ReflectionCFs.configure_dynamic_field_access rcf_ctx false; (* let closure_func = ReflectionCFs.implement_closure_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"],"Closure")) ) in *) let closure_cl = get_cl (get_type gen (["haxe";"lang"],"Closure")) in let closure_func = ReflectionCFs.get_closure_func rcf_ctx closure_cl in ReflectionCFs.implement_varargs_cl rcf_ctx ( get_cl (get_type gen (["haxe";"lang"], "VarArgsBase")) ); let slow_invoke = mk_static_field_access_infer (runtime_cl) "slowCallField" Ast.null_pos [] in ReflectionCFs.configure rcf_ctx ~slow_invoke:(fun ethis efield eargs -> { eexpr = TCall(slow_invoke, [ethis; efield; eargs]); etype = t_dynamic; epos = ethis.epos; } ) object_iface; let objdecl_fn = ReflectionCFs.implement_dynamic_object_ctor rcf_ctx dynamic_object in ObjectDeclMap.configure gen (ObjectDeclMap.traverse gen objdecl_fn); InitFunction.configure gen true; TArrayTransform.configure gen (TArrayTransform.default_implementation gen ( fun e -> match e.eexpr with | TArray(e1, e2) -> ( match run_follow gen e1.etype with | TInst({ cl_path = (["java"], "NativeArray") }, _) -> false | _ -> true ) | _ -> assert false ) "__get" "__set" ); let field_is_dynamic t field = match field_access gen (gen.greal_type t) field with | FClassField (cl,p,_,_,_,t,_) -> is_dynamic (apply_params cl.cl_types p t) | FEnumField _ -> false | _ -> true in let is_type_param e = match follow e with | TInst( { cl_kind = KTypeParameter _ },[]) -> true | _ -> false in let is_dynamic_expr e = is_dynamic e.etype || match e.eexpr with | TField(tf, f) -> field_is_dynamic tf.etype (field_name f) | _ -> false in let may_nullable t = match gen.gfollow#run_f t with | TType({ t_path = ([], "Null") }, [t]) -> (match follow t with | TInst({ cl_path = ([], "String") }, []) | TInst({ cl_path = ([], "Float") }, []) | TAbstract ({ a_path = ([], "Float") },[]) | TInst({ cl_path = (["haxe"], "Int32")}, [] ) | TInst({ cl_path = (["haxe"], "Int64")}, [] ) | TInst({ cl_path = ([], "Int") }, []) | TAbstract ({ a_path = ([], "Int") },[]) | TEnum({ e_path = ([], "Bool") }, []) | TAbstract ({ a_path = ([], "Bool") },[]) -> Some t | _ -> None ) | _ -> None in let is_double t = like_float t && not (like_int t) in let is_int t = like_int t in DynamicOperators.configure gen (DynamicOperators.abstract_implementation gen (fun e -> match e.eexpr with | TBinop (Ast.OpEq, e1, e2) | TBinop (Ast.OpAdd, e1, e2) | TBinop (Ast.OpNotEq, e1, e2) -> is_dynamic e1.etype or is_dynamic e2.etype or is_type_param e1.etype or is_type_param e2.etype | TBinop (Ast.OpLt, e1, e2) | TBinop (Ast.OpLte, e1, e2) | TBinop (Ast.OpGte, e1, e2) | TBinop (Ast.OpGt, e1, e2) -> is_dynamic e.etype or is_dynamic_expr e1 or is_dynamic_expr e2 or is_string e1.etype or is_string e2.etype | TBinop (_, e1, e2) -> is_dynamic e.etype or is_dynamic_expr e1 or is_dynamic_expr e2 | TUnop (_, _, e1) -> is_dynamic_expr e1 | _ -> false) (fun e1 e2 -> let is_null e = match e.eexpr with | TConst(TNull) | TLocal({ v_name = "__undefined__" }) -> true | _ -> false in if is_null e1 || is_null e2 then match e1.eexpr, e2.eexpr with | TConst c1, TConst c2 -> { e1 with eexpr = TConst(TBool (c1 = c2)); etype = basic.tbool } | _ -> { e1 with eexpr = TBinop(Ast.OpEq, e1, e2); etype = basic.tbool } else begin let is_ref = match follow e1.etype, follow e2.etype with | TDynamic _, _ | _, TDynamic _ | TInst({ cl_path = ([], "Float") },[]), _ | TAbstract ({ a_path = ([], "Float") },[]) , _ | TInst( { cl_path = (["haxe"], "Int32") }, [] ), _ | TInst( { cl_path = (["haxe"], "Int64") }, [] ), _ | TInst({ cl_path = ([], "Int") },[]), _ | TAbstract ({ a_path = ([], "Int") },[]) , _ | TEnum({ e_path = ([], "Bool") },[]), _ | TAbstract ({ a_path = ([], "Bool") },[]) , _ | _, TInst({ cl_path = ([], "Float") },[]) | _, TAbstract ({ a_path = ([], "Float") },[]) | _, TInst({ cl_path = ([], "Int") },[]) | _, TAbstract ({ a_path = ([], "Int") },[]) | _, TInst( { cl_path = (["haxe"], "Int32") }, [] ) | _, TInst( { cl_path = (["haxe"], "Int64") }, [] ) | _, TEnum({ e_path = ([], "Bool") },[]) | _, TAbstract ({ a_path = ([], "Bool") },[]) | TInst( { cl_kind = KTypeParameter _ }, [] ), _ | _, TInst( { cl_kind = KTypeParameter _ }, [] ) -> false | _, _ -> true in let static = mk_static_field_access_infer (runtime_cl) (if is_ref then "refEq" else "eq") e1.epos [] in { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tbool; epos=e1.epos } end ) (fun e e1 e2 -> match may_nullable e1.etype, may_nullable e2.etype with | Some t1, Some t2 -> let t1, t2 = if is_string t1 || is_string t2 then basic.tstring, basic.tstring else if is_double t1 || is_double t2 then basic.tfloat, basic.tfloat else if is_int t1 || is_int t2 then basic.tint, basic.tint else t1, t2 in { eexpr = TBinop(Ast.OpAdd, mk_cast t1 e1, mk_cast t2 e2); etype = e.etype; epos = e1.epos } | _ -> let static = mk_static_field_access_infer (runtime_cl) "plus" e1.epos [] in mk_cast e.etype { eexpr = TCall(static, [e1; e2]); etype = t_dynamic; epos=e1.epos }) (fun e1 e2 -> if is_string e1.etype then begin { e1 with eexpr = TCall(mk_field_access gen e1 "compareTo" e1.epos, [ e2 ]); etype = gen.gcon.basic.tint } end else begin let static = mk_static_field_access_infer (runtime_cl) "compare" e1.epos [] in { eexpr = TCall(static, [e1; e2]); etype = gen.gcon.basic.tint; epos=e1.epos } end)); FilterClosures.configure gen (FilterClosures.traverse gen (fun e1 s -> true) closure_func); let base_exception = get_cl (get_type gen (["java"; "lang"], "Throwable")) in let base_exception_t = TInst(base_exception, []) in let hx_exception = get_cl (get_type gen (["haxe";"lang"], "HaxeException")) in let hx_exception_t = TInst(hx_exception, []) in let rec is_exception t = match follow t with | TInst(cl,_) -> if cl == base_exception then true else (match cl.cl_super with | None -> false | Some (cl,arg) -> is_exception (TInst(cl,arg))) | _ -> false in TryCatchWrapper.configure gen ( TryCatchWrapper.traverse gen (fun t -> not (is_exception (real_type t))) (fun throwexpr expr -> let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], base_exception_t)) expr.epos in { throwexpr with eexpr = TThrow { expr with eexpr = TCall(wrap_static, [expr]); etype = hx_exception_t }; etype = gen.gcon.basic.tvoid } ) (fun v_to_unwrap pos -> let local = mk_cast hx_exception_t { eexpr = TLocal(v_to_unwrap); etype = v_to_unwrap.v_type; epos = pos } in mk_field_access gen local "obj" pos ) (fun rethrow -> let wrap_static = mk_static_field_access (hx_exception) "wrap" (TFun([("obj",false,t_dynamic)], base_exception_t)) rethrow.epos in { rethrow with eexpr = TThrow { rethrow with eexpr = TCall(wrap_static, [rethrow]) }; } ) (base_exception_t) (hx_exception_t) (fun v e -> e) ); let get_typeof e = { e with eexpr = TCall( { eexpr = TLocal( alloc_var "__typeof__" t_dynamic ); etype = t_dynamic; epos = e.epos }, [e] ) } in ClassInstance.configure gen (ClassInstance.traverse gen (fun e mt -> get_typeof e)); (*let v = alloc_var "$type_param" t_dynamic in*) TypeParams.configure gen (fun ecall efield params elist -> { ecall with eexpr = TCall(efield, elist) } ); CastDetect.configure gen (CastDetect.default_implementation gen ~native_string_cast:false (Some (TEnum(empty_e, []))) false); (*FollowAll.configure gen;*) SwitchToIf.configure gen (SwitchToIf.traverse gen (fun e -> match e.eexpr with | TSwitch(cond, cases, def) -> (match gen.gfollow#run_f cond.etype with | TInst( { cl_path = (["haxe"], "Int32") }, [] ) | TInst({ cl_path = ([], "Int") },[]) | TAbstract ({ a_path = ([], "Int") },[]) | TInst({ cl_path = ([], "String") },[]) -> (List.exists (fun (c,_) -> List.exists (fun expr -> match expr.eexpr with | TConst _ -> false | _ -> true ) c ) cases) | _ -> true ) | _ -> assert false ) true ); let native_arr_cl = get_cl ( get_type gen (["java"], "NativeArray") ) in ExpressionUnwrap.configure gen (ExpressionUnwrap.traverse gen (fun e -> Some { eexpr = TVars([mk_temp gen "expr" e.etype, Some e]); etype = gen.gcon.basic.tvoid; epos = e.epos })); UnnecessaryCastsRemoval.configure gen; IntDivisionSynf.configure gen (IntDivisionSynf.default_implementation gen true); UnreachableCodeEliminationSynf.configure gen (UnreachableCodeEliminationSynf.traverse gen false true true true); ArrayDeclSynf.configure gen (ArrayDeclSynf.default_implementation gen native_arr_cl); let goto_special = alloc_var "__goto__" t_dynamic in let label_special = alloc_var "__label__" t_dynamic in SwitchBreakSynf.configure gen (SwitchBreakSynf.traverse gen (fun e_loop n api -> { e_loop with eexpr = TBlock( { eexpr = TCall( mk_local label_special e_loop.epos, [ mk_int gen n e_loop.epos ] ); etype = t_dynamic; epos = e_loop.epos } :: [e_loop] ) }; ) (fun e_break n api -> { eexpr = TCall( mk_local goto_special e_break.epos, [ mk_int gen n e_break.epos ] ); etype = t_dynamic; epos = e_break.epos } ) ); DefaultArguments.configure gen (DefaultArguments.traverse gen); JavaSpecificSynf.configure gen (JavaSpecificSynf.traverse gen runtime_cl); JavaSpecificESynf.configure gen (JavaSpecificESynf.traverse gen runtime_cl); (* add native String as a String superclass *) let str_cl = match gen.gcon.basic.tstring with | TInst(cl,_) -> cl | _ -> assert false in str_cl.cl_super <- Some (get_cl (get_type gen (["haxe";"lang"], "NativeString")), []); let mkdir dir = if not (Sys.file_exists dir) then Unix.mkdir dir 0o755 in mkdir gen.gcon.file; mkdir (gen.gcon.file ^ "/src"); (* add resources array *) (try let res = get_cl (Hashtbl.find gen.gtypes (["haxe"], "Resource")) in let cf = PMap.find "content" res.cl_statics in let res = ref [] in Hashtbl.iter (fun name v -> res := { eexpr = TConst(TString name); etype = gen.gcon.basic.tstring; epos = Ast.null_pos } :: !res; let f = open_out (gen.gcon.file ^ "/src/" ^ name) in output_string f v; close_out f ) gen.gcon.resources; cf.cf_expr <- Some ({ eexpr = TArrayDecl(!res); etype = gen.gcon.basic.tarray gen.gcon.basic.tstring; epos = Ast.null_pos }) with | Not_found -> ()); run_filters gen; TypeParams.RenameTypeParameters.run gen; let t = Common.timer "code generation" in generate_modules_t gen "java" "src" change_path module_gen; dump_descriptor gen ("hxjava_build.txt") path_s (fun md -> path_s (t_infos md).mt_path); if ( not (Common.defined gen.gcon Define.NoCompilation) ) then begin let old_dir = Sys.getcwd() in Sys.chdir gen.gcon.file; let cmd = "haxelib run hxjava hxjava_build.txt --haxe-version " ^ (string_of_int gen.gcon.version) in print_endline cmd; if gen.gcon.run_command cmd <> 0 then failwith "Build failed"; Sys.chdir old_dir; end; t() (* end of configure function *) let before_generate con = let java_ver = try int_of_string (PMap.find "java_ver" con.defines) with | Not_found -> Common.define_value con Define.JavaVer "7"; 7 in if java_ver < 5 then failwith ("Java version is defined to target Java " ^ string_of_int java_ver ^ ", but the compiler can only output code to versions equal or superior to Java 5"); let rec loop i = Common.raw_define con ("java" ^ (string_of_int i)); if i > 0 then loop (i - 1) in loop java_ver; () let generate con = let exists = ref false in con.java_libs <- List.map (fun (file,std,close,la,gr) -> if String.ends_with file "hxjava-std.jar" then begin exists := true; (file,true,close,la,gr) end else (file,std,close,la,gr)) con.java_libs; if not !exists then failwith "Your version of hxjava is outdated. Please update it by running: `haxelib update hxjava`"; let gen = new_ctx con in gen.gallow_tp_dynamic_conversion <- true; let basic = con.basic in (* make the basic functions in java *) let basic_fns = [ mk_class_field "equals" (TFun(["obj",false,t_dynamic], basic.tbool)) true Ast.null_pos (Method MethNormal) []; mk_class_field "toString" (TFun([], basic.tstring)) true Ast.null_pos (Method MethNormal) []; mk_class_field "hashCode" (TFun([], basic.tint)) true Ast.null_pos (Method MethNormal) []; ] in List.iter (fun cf -> gen.gbase_class_fields <- PMap.add cf.cf_name cf gen.gbase_class_fields) basic_fns; (try configure gen with | TypeNotFound path -> con.error ("Error. Module '" ^ (path_s path) ^ "' is required and was not included in build.") Ast.null_pos); debug_mode := false (** Java lib *) open JData type java_lib_ctx = { jcom : Common.context; (* current tparams context *) mutable jtparams : jtypes list; } exception ConversionError of string * pos let error s p = raise (ConversionError (s, p)) let jname_to_hx name = (* handle non-inner classes with same final name as non-inner *) let name = String.concat "__" (String.nsplit name "_") in (* handle with inner classes *) String.map (function | '$' -> '_' | c -> c) name let jpath_to_hx (pack,name) = match pack, name with | ["haxe";"root"], name -> [], name | "com" :: ("oracle" | "sun") :: _, _ | "javax" :: _, _ | "org" :: ("ietf" | "jcp" | "omg" | "w3c" | "xml") :: _, _ | "sun" :: _, _ | "sunw" :: _, _ -> "java" :: pack, jname_to_hx name | pack, name -> pack, jname_to_hx name let hxname_to_j name = let name = String.implode (List.rev (String.explode name)) in let fl = String.nsplit name "__" in let fl = List.map (String.map (fun c -> if c = '_' then '$' else c)) fl in let ret = String.concat "_" fl in String.implode (List.rev (String.explode ret)) let hxpath_to_j (pack,name) = match pack, name with | "java" :: "com" :: ("oracle" | "sun") :: _, _ | "java" :: "javax" :: _, _ | "java" :: "org" :: ("ietf" | "jcp" | "omg" | "w3c" | "xml") :: _, _ | "java" :: "sun" :: _, _ | "java" :: "sunw" :: _, _ -> List.tl pack, hxname_to_j name | pack, name -> pack, hxname_to_j name let real_java_path ctx (pack,name) = path_s (pack, name) let lookup_jclass com path = let path = jpath_to_hx path in List.fold_right (fun (_,_,_,_,get_raw_class) acc -> match acc with | None -> get_raw_class path | Some p -> Some p ) com.java_libs None let mk_type_path ctx path params = let name, sub = try let p, _ = String.split (snd path) "$" in jname_to_hx p, Some (jname_to_hx (snd path)) with | Invalid_string -> jname_to_hx (snd path), None in CTPath { tpackage = fst (jpath_to_hx path); tname = name; tparams = params; tsub = sub; } let has_tparam name params = List.exists(fun (n,_,_) -> n = name) params let rec convert_arg ctx p arg = match arg with | TAny | TType (WSuper, _) -> TPType (mk_type_path ctx ([], "Dynamic") []) | TType (_, jsig) -> TPType (convert_signature ctx p jsig) and convert_signature ctx p jsig = match jsig with | TByte -> mk_type_path ctx (["java"; "types"], "Int8") [] | TChar -> mk_type_path ctx (["java"; "types"], "Char16") [] | TDouble -> mk_type_path ctx ([], "Float") [] | TFloat -> mk_type_path ctx ([], "Single") [] | TInt -> mk_type_path ctx ([], "Int") [] | TLong -> mk_type_path ctx (["haxe"], "Int64") [] | TShort -> mk_type_path ctx (["java"; "types"], "Int16") [] | TBool -> mk_type_path ctx ([], "Bool") [] | TObject ( (["haxe";"root"], name), args ) -> mk_type_path ctx ([], name) (List.map (convert_arg ctx p) args) (** nullable types *) | TObject ( (["java";"lang"], "Integer"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Int") []) ] | TObject ( (["java";"lang"], "Double"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Float") []) ] | TObject ( (["java";"lang"], "Single"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Single") []) ] | TObject ( (["java";"lang"], "Boolean"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx ([], "Bool") []) ] | TObject ( (["java";"lang"], "Byte"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Int8") []) ] | TObject ( (["java";"lang"], "Character"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Char16") []) ] | TObject ( (["java";"lang"], "Short"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["java";"types"], "Int16") []) ] | TObject ( (["java";"lang"], "Long"), [] ) -> mk_type_path ctx ([], "Null") [ TPType (mk_type_path ctx (["haxe"], "Int64") []) ] (** other std types *) | TObject ( (["java";"lang"], "Object"), [] ) -> mk_type_path ctx ([], "Dynamic") [] | TObject ( (["java";"lang"], "String"), [] ) -> mk_type_path ctx ([], "String") [] (** other types *) | TObject ( path, [] ) -> (match lookup_jclass ctx.jcom path with | Some (jcl, _, _) -> mk_type_path ctx path (List.map (fun _ -> convert_arg ctx p TAny) jcl.ctypes) | None -> mk_type_path ctx path []) | TObject ( path, args ) -> mk_type_path ctx path (List.map (convert_arg ctx p) args) | TObjectInner (pack, (name, params) :: inners) -> let actual_param = match List.rev inners with | (_, p) :: _ -> p | _ -> assert false in mk_type_path ctx (pack, name ^ "$" ^ String.concat "$" (List.map fst inners)) (List.map (fun param -> convert_arg ctx p param) actual_param) | TObjectInner (pack, inners) -> assert false | TArray (jsig, _) -> mk_type_path ctx (["java"], "NativeArray") [ TPType (convert_signature ctx p jsig) ] | TMethod _ -> JReader.error "TMethod cannot be converted directly into Complex Type" | TTypeParameter s -> (match ctx.jtparams with | cur :: others -> if has_tparam s cur then mk_type_path ctx ([], s) [] else begin if ctx.jcom.verbose && not(List.exists (has_tparam s) others) then print_endline ("Type parameter " ^ s ^ " was not found while building type!"); mk_type_path ctx ([], "Dynamic") [] end | _ -> if ctx.jcom.verbose then print_endline ("Empty type parameter stack!"); mk_type_path ctx ([], "Dynamic") []) let convert_constant ctx p const = Option.map_default (function | ConstString s -> Some (EConst (String s), p) | ConstInt i -> Some (EConst (Int (Printf.sprintf "%ld" i)), p) | ConstFloat f | ConstDouble f -> Some (EConst (Float (Printf.sprintf "%E" f)), p) | _ -> None) None const let rec same_sig parent jsig = match jsig with | TObject (p,targs) -> parent = p || List.exists (function | TType (_,s) -> same_sig parent s | _ -> false) targs | TObjectInner(p, ntargs) -> parent = (p, String.concat "$" (List.map fst ntargs)) || List.exists (fun (_,targs) -> List.exists (function | TType(_,s) -> same_sig parent s | _ -> false) targs) ntargs | TArray(s,_) -> same_sig parent s | _ -> false let convert_param ctx p parent param = let name, constraints = match param with | (name, Some extends_sig, implem_sig) -> name, extends_sig :: implem_sig | (name, None, implemem_sig) -> name, implemem_sig in let constraints = List.map (fun s -> if same_sig parent s then (TObject( (["java";"lang"], "Object"), [])) else s) constraints in { tp_name = name; tp_params = []; tp_constraints = List.map (convert_signature ctx p) constraints; } let get_type_path ctx ct = match ct with | CTPath p -> p | _ -> assert false let is_override field = List.exists (function | AttrVisibleAnnotations [{ ann_type = TObject( (["java";"lang"], "Override"), _ ) }] -> true | _ -> false) field.jf_attributes let mk_override field = { field with jf_attributes = ((AttrVisibleAnnotations [{ ann_type = TObject( (["java";"lang"], "Override"), [] ); ann_elements = [] }]) :: field.jf_attributes) } let del_override field = { field with jf_attributes = List.filter (fun a -> not (is_override_attrib a)) field.jf_attributes } let convert_java_enum ctx p pe = let meta = ref [Meta.Native, [EConst (String (real_java_path ctx pe.cpath) ), p], p ] in let data = ref [] in List.iter (fun f -> if List.mem JEnum f.jf_flags then data := { ec_name = f.jf_name; ec_doc = None; ec_meta = []; ec_args = []; ec_pos = p; ec_params = []; ec_type = None; } :: !data; ) pe.cfields; EEnum { d_name = jname_to_hx (snd pe.cpath); d_doc = None; d_params = []; (* enums never have type parameters *) d_meta = !meta; d_flags = [EExtern]; d_data = !data; } let convert_java_field ctx p jc field = let p = { p with pfile = p.pfile ^" (" ^field.jf_name ^")" } in let cff_doc = None in let cff_pos = p in let cff_meta = ref [] in let cff_access = ref [] in let cff_name = match field.jf_name with | "" -> "new" | ""-> raise Exit (* __init__ field *) | name when String.length name > 5 -> (match String.sub name 0 5 with | "__hx_" | "this$" -> raise Exit | _ -> name) | name -> name in let jf_constant = ref field.jf_constant in let readonly = ref false in List.iter (function | JPublic -> cff_access := APublic :: !cff_access | JPrivate -> raise Exit (* private instances aren't useful on externs *) | JProtected -> cff_access := APrivate :: !cff_access | JStatic -> cff_access := AStatic :: !cff_access | JFinal -> cff_meta := (Meta.Final, [], p) :: !cff_meta; (match field.jf_kind, field.jf_vmsignature, field.jf_constant with | JKField, TObject _, _ -> jf_constant := None | JKField, _, Some _ -> readonly := true; jf_constant := None; | _ -> jf_constant := None) (* | JSynchronized -> cff_meta := (Meta.Synchronized, [], p) :: !cff_meta *) | JVolatile -> cff_meta := (Meta.Volatile, [], p) :: !cff_meta | JTransient -> cff_meta := (Meta.Transient, [], p) :: !cff_meta (* | JVarArgs -> cff_meta := (Meta.VarArgs, [], p) :: !cff_meta *) | _ -> () ) field.jf_flags; List.iter (function | AttrDeprecated -> cff_meta := (Meta.Deprecated, [], p) :: !cff_meta (* TODO: pass anotations as @:meta *) | AttrVisibleAnnotations ann -> List.iter (function | { ann_type = TObject( (["java";"lang"], "Override"), [] ) } -> cff_access := AOverride :: !cff_access | _ -> () ) ann | _ -> () ) field.jf_attributes; let kind = match field.jf_kind with | JKField when !readonly -> FProp ("default", "null", Some (convert_signature ctx p field.jf_signature), None) | JKField -> FVar (Some (convert_signature ctx p field.jf_signature), None) | JKMethod -> match field.jf_signature with | TMethod (args, ret) -> let old_types = ctx.jtparams in (match ctx.jtparams with | c :: others -> ctx.jtparams <- (c @ field.jf_types) :: others | [] -> ctx.jtparams <- field.jf_types :: []); let i = ref 0 in let args = List.map (fun s -> incr i; "param" ^ string_of_int !i, false, Some(convert_signature ctx p s), None ) args in let t = Option.map_default (convert_signature ctx p) (mk_type_path ctx ([], "Void") []) ret in cff_meta := (Meta.Overload, [], p) :: !cff_meta; let types = List.map (function | (name, Some ext, impl) -> { tp_name = name; tp_params = []; tp_constraints = List.map (convert_signature ctx p) (ext :: impl); } | (name, None, impl) -> { tp_name = name; tp_params = []; tp_constraints = List.map (convert_signature ctx p) (impl); } ) field.jf_types in ctx.jtparams <- old_types; FFun ({ f_params = types; f_args = args; f_type = Some t; f_expr = None }) | _ -> error "Method signature was expected" p in let cff_name, cff_meta = if String.get cff_name 0 = '%' then let name = (String.sub cff_name 1 (String.length cff_name - 1)) in "_" ^ name, (Meta.Native, [EConst (String (name) ), cff_pos], cff_pos) :: !cff_meta else cff_name, !cff_meta in { cff_name = cff_name; cff_doc = cff_doc; cff_pos = cff_pos; cff_meta = cff_meta; cff_access = !cff_access; cff_kind = kind } let rec japply_params params jsig = match params with | [] -> jsig | _ -> match jsig with | TTypeParameter s -> (try List.assoc s params with | Not_found -> jsig) | TObject(p,tl) -> TObject(p, args params tl) | TObjectInner(sl, stll) -> TObjectInner(sl, List.map (fun (s,tl) -> (s, args params tl)) stll) | TArray(s,io) -> TArray(japply_params params s, io) | TMethod(sl, sopt) -> TMethod(List.map (japply_params params) sl, Option.map (japply_params params) sopt) | _ -> jsig and args params tl = match params with | [] -> tl | _ -> List.map (function | TAny -> TAny | TType(w,s) -> TType(w,japply_params params s)) tl let mk_params jtypes = List.map (fun (s,_,_) -> (s,TTypeParameter s)) jtypes let convert_java_class ctx p jc = match List.mem JEnum jc.cflags with | true -> (* is enum *) convert_java_enum ctx p jc | false -> let flags = ref [HExtern] in (* todo: instead of JavaNative, use more specific definitions *) let meta = ref [Meta.JavaNative, [], p; Meta.Native, [EConst (String (real_java_path ctx jc.cpath) ), p], p] in let is_interface = ref false in List.iter (fun f -> match f with | JFinal -> meta := (Meta.Final, [], p) :: !meta | JInterface -> is_interface := true; flags := HInterface :: !flags | JAbstract -> meta := (Meta.Abstract, [], p) :: !meta | JAnnotation -> meta := (Meta.Annotation, [], p) :: !meta | _ -> () ) jc.cflags; (match jc.csuper with | TObject( (["java";"lang"], "Object"), _ ) -> () | TObject( (["haxe";"lang"], "HxObject"), _ ) -> meta := (Meta.HxGen,[],p) :: !meta | _ -> flags := HExtends (get_type_path ctx (convert_signature ctx p jc.csuper)) :: !flags ); List.iter (fun i -> match i with | TObject ( (["haxe";"lang"], "IHxObject"), _ ) -> meta := (Meta.HxGen,[],p) :: !meta | _ -> flags := if !is_interface then HExtends (get_type_path ctx (convert_signature ctx p i)) :: !flags else HImplements (get_type_path ctx (convert_signature ctx p i)) :: !flags ) jc.cinterfaces; let fields = ref [] in let jfields = ref [] in if jc.cpath <> (["java";"lang"], "CharSequence") then List.iter (fun f -> try if !is_interface && List.mem JStatic f.jf_flags then () else begin fields := convert_java_field ctx p jc f :: !fields; jfields := f :: !jfields end with | Exit -> () ) (jc.cfields @ jc.cmethods); EClass { d_name = jname_to_hx (snd jc.cpath); d_doc = None; d_params = List.map (convert_param ctx p jc.cpath) jc.ctypes; d_meta = !meta; d_flags = !flags; d_data = !fields; } let create_ctx com = { jcom = com; jtparams = []; } let rec has_type_param = function | TTypeParameter _ -> true | TMethod (lst, opt) -> List.exists has_type_param lst || Option.map_default has_type_param false opt | TArray (s,_) -> has_type_param s | TObjectInner (_, stpl) -> List.exists (fun (_,sigs) -> List.exists has_type_param_arg sigs) stpl | TObject(_, pl) -> List.exists has_type_param_arg pl | _ -> false and has_type_param_arg = function | TType(_,s) -> has_type_param s | _ -> false let rec japply_params jparams jsig = match jparams with | [] -> jsig | _ -> match jsig with | TObject(path,p) -> TObject(path, List.map (japply_params_tp jparams ) p) | TObjectInner(sl,stargl) -> TObjectInner(sl,List.map (fun (s,targ) -> (s, List.map (japply_params_tp jparams) targ)) stargl) | TArray(jsig,io) -> TArray(japply_params jparams jsig,io) | TMethod(args,ret) -> TMethod(List.map (japply_params jparams ) args, Option.map (japply_params jparams ) ret) | TTypeParameter s -> (try List.assoc s jparams with | Not_found -> jsig) | _ -> jsig and japply_params_tp jparams jtype_argument = match jtype_argument with | TAny -> TAny | TType(w,jsig) -> TType(w,japply_params jparams jsig) let mk_jparams jtypes params = match jtypes, params with | [], [] -> [] | _, [] -> List.map (fun (s,_,_) -> s, TObject( (["java";"lang"], "Object"), [] ) ) jtypes | _ -> List.map2 (fun (s,_,_) jt -> match jt with | TAny -> s, TObject((["java";"lang"],"Object"),[]) | TType(_,jsig) -> s, jsig) jtypes params let rec compatible_signature_arg ?arg_test f1 f2 = let arg_test = match arg_test with | None -> (fun _ _ -> true) | Some a -> a in if f1 = f2 then true else match f1, f2 with | TObject(p,a), TObject(p2,a2) -> p = p2 && arg_test a a2 | TObjectInner(sl, stal), TObjectInner(sl2, stal2) -> sl = sl2 && List.map fst stal = List.map fst stal2 | TArray(s,_) , TArray(s2,_) -> compatible_signature_arg s s2 | TTypeParameter t1 , TTypeParameter t2 -> t1 = t2 | _ -> false let rec compatible_param p1 p2 = match p1, p2 with | TType (_,s1), TType(_,s2) -> compatible_signature_arg ~arg_test:compatible_tparams s1 s2 | TAny, TType(_, TObject( (["java";"lang"],"Object"), _ )) -> true | TType(_, TObject( (["java";"lang"],"Object"), _ )), TAny -> true | _ -> false and compatible_tparams p1 p2 = try match p1, p2 with | [], [] -> true | _, [] -> let p2 = List.map (fun _ -> TAny) p1 in List.for_all2 compatible_param p1 p2 | [], _ -> let p1 = List.map (fun _ -> TAny) p2 in List.for_all2 compatible_param p1 p2 | _, _ -> List.for_all2 compatible_param p1 p2 with | Invalid_argument("List.for_all2") -> false let get_adapted_sig f f2 = match f.jf_types with | [] -> f.jf_signature | _ -> let jparams = mk_jparams f.jf_types (List.map (fun (s,_,_) -> TType(WNone, TTypeParameter s)) f2.jf_types) in japply_params jparams f.jf_signature let compatible_methods f1 f2 = if List.length f1.jf_types <> List.length f2.jf_types then false else match (get_adapted_sig f1 f2), f2.jf_signature with | TMethod(a1,_), TMethod(a2,_) when List.length a1 = List.length a2 -> List.for_all2 compatible_signature_arg a1 a2 | _ -> false let jcl_from_jsig com jsig = let path, params = match jsig with | TObject(path, params) -> path,params | TObjectInner(sl, stll) -> let last_params = ref [] in let real_path = sl, String.concat "$" (List.map (fun (s,p) -> last_params := p; s) stll) in real_path, !last_params | _ -> raise Not_found in match lookup_jclass com path with | None -> raise Not_found | Some(c,_,_) -> c,params let jclass_with_params com cls params = try match cls.ctypes with | [] -> cls | _ -> let jparams = mk_jparams cls.ctypes params in { cls with cfields = List.map (fun f -> { f with jf_signature = japply_params jparams f.jf_signature }) cls.cfields; cmethods = List.map (fun f -> { f with jf_signature = japply_params jparams f.jf_signature }) cls.cmethods; csuper = japply_params jparams cls.csuper; cinterfaces = List.map (japply_params jparams) cls.cinterfaces; } with Invalid_argument("List.map2") -> if com.verbose then prerr_endline ("Differing parameters for class: " ^ path_s cls.cpath); cls let is_object = function | TObject( (["java";"lang"], "Object"), [] ) -> true | _ -> false let is_tobject = function | TObject _ | TObjectInner _ -> true | _ -> false let simplify_args args = if List.for_all (function | TAny -> true | _ -> false) args then [] else args let compare_type com s1 s2 = if s1 = s2 then 0 else if not (is_tobject s1) then if is_tobject s2 then (* Dynamic *) 1 else if compatible_signature_arg s1 s2 then 0 else raise Exit else if not (is_tobject s2) then -1 else begin let rec loop ?(first_error=true) s1 s2 : bool = if is_object s1 then s1 = s2 else if compatible_signature_arg s1 s2 then begin let p1, p2 = match s1, s2 with | TObject(_, p1), TObject(_,p2) -> p1, p2 | TObjectInner(_, npl1), TObjectInner(_, npl2) -> snd (List.hd (List.rev npl1)), snd (List.hd (List.rev npl2)) | _ -> assert false (* not tobject *) in let p1, p2 = simplify_args p1, simplify_args p2 in let lp1 = List.length p1 in let lp2 = List.length p2 in if lp1 > lp2 then true else if lp2 > lp1 then false else begin (* if compatible tparams, it's fine *) if not (compatible_tparams p1 p2) then raise Exit; (* meaning: found, but incompatible type parameters *) true end end else try let c, p = jcl_from_jsig com s1 in let jparams = mk_jparams c.ctypes p in let super = japply_params jparams c.csuper in let implements = List.map (japply_params jparams) c.cinterfaces in loop ~first_error:first_error super s2 || List.exists (fun super -> loop ~first_error:first_error super s2) implements with | Not_found -> if com.verbose then begin prerr_endline ("-java-lib: The type " ^ (s_sig s1) ^ " is referred but was not found. Compilation may not occur correctly."); prerr_endline "Did you forget to include a needed lib?" end; if first_error then not (loop ~first_error:false s2 s1) else false in if loop s1 s2 then if loop s2 s1 then 0 else 1 else if loop s2 s1 then -1 else -2 end (* given a list of same overload functions, choose the best (or none) *) let select_best com flist = let rec loop cur_best = function | [] -> Some cur_best | f :: flist -> match get_adapted_sig f cur_best, cur_best.jf_signature with | TMethod(_,Some r), TMethod(_, Some r2) -> (try match compare_type com r r2 with | 0 -> (* same type - select any of them *) loop cur_best flist | 1 -> loop f flist | -1 -> loop cur_best flist | -2 -> (* error - no type is compatible *) if com.verbose then prerr_endline (f.jf_name ^ ": The types " ^ (s_sig r) ^ " and " ^ (s_sig r2) ^ " are incompatible"); (* bet that the current best has "beaten" other types *) loop cur_best flist | _ -> assert false with | Exit -> (* incompatible type parameters *) (* error mode *) if com.verbose then prerr_endline (f.jf_name ^ ": Incompatible argument return signatures: " ^ (s_sig r) ^ " and " ^ (s_sig r2)); None) | TMethod _, _ -> (* select the method *) loop f flist | _ -> loop cur_best flist in match loop (List.hd flist) (List.tl flist) with | Some f -> Some f | None -> match List.filter (fun f -> not (is_override f)) flist with (* error mode; take off all override methods *) | [] -> None | f :: [] -> Some f | f :: flist -> Some f (* pick one *) let normalize_jclass com cls = (* search static / non-static name clash *) let nonstatics = ref [] in List.iter (fun f -> if not(List.mem JStatic f.jf_flags) then nonstatics := f :: !nonstatics ) (cls.cfields @ cls.cmethods); (* we won't be able to deal correctly with field's type parameters *) (* since java sometimes overrides / implements crude (ie no type parameters) versions *) (* and interchanges between them *) (* let methods = List.map (fun f -> let f = del_override f in if f.jf_types <> [] then { f with jf_types = []; jf_signature = f.jf_vmsignature } else f ) cls.cmethods in *) (* let pth = path_s cls.cpath in *) let methods = List.map (fun f -> del_override f ) cls.cmethods in (* take off duplicate overload signature class fields from current class *) let cmethods = ref methods in let all_methods = ref methods in let all_fields = ref cls.cfields in let super_methods = ref [] in (* fix overrides *) let rec loop cls = try match cls.csuper with | TObject((["java";"lang"],"Object"),_) -> () | _ -> let cls, params = jcl_from_jsig com cls.csuper in let cls = jclass_with_params com cls params in List.iter (fun f -> if not (List.mem JStatic f.jf_flags) then nonstatics := f :: !nonstatics) (cls.cfields @ cls.cmethods); super_methods := cls.cmethods @ !super_methods; all_methods := cls.cmethods @ !all_methods; all_fields := cls.cfields @ !all_fields; let overriden = ref [] in cmethods := List.map (fun jm -> (* TODO rewrite/standardize empty spaces *) if not (is_override jm) && not(List.mem JStatic jm.jf_flags) && List.exists (fun msup -> let ret = msup.jf_name = jm.jf_name && not(List.mem JStatic msup.jf_flags) && compatible_methods msup jm in if ret then begin let f = mk_override msup in overriden := { f with jf_flags = jm.jf_flags } :: !overriden end; ret ) cls.cmethods then mk_override jm else jm ) !cmethods; cmethods := !overriden @ !cmethods; loop cls with | Not_found -> () in if not (List.mem JInterface cls.cflags) then begin cmethods := List.filter (fun f -> List.exists (function | JPublic | JProtected -> true | _ -> false) f.jf_flags) !cmethods; all_fields := List.filter (fun f -> List.exists (function | JPublic | JProtected -> true | _ -> false) f.jf_flags) !all_fields; end; loop cls; (* look for interfaces and add missing implementations (may happen on abstracts or by vmsig differences *) let added_interface_fields = ref [] in let rec loop_interface abstract cls iface = try match iface with | TObject ((["java";"lang"],"Object"), _) -> () | TObject (path,_) when path = cls.cpath -> () | _ -> let cif, params = jcl_from_jsig com iface in let cif = jclass_with_params com cif params in List.iter (fun jf -> if not(List.mem JStatic jf.jf_flags) && not (List.exists (fun jf2 -> jf.jf_name = jf2.jf_name && not (List.mem JStatic jf2.jf_flags) && jf.jf_signature = jf2.jf_signature) !all_methods) then begin let jf = if abstract then del_override jf else jf in let jf = { jf with jf_flags = JPublic :: jf.jf_flags } in (* interfaces implementations are always public *) added_interface_fields := jf :: !added_interface_fields; cmethods := jf :: !cmethods; all_methods := jf :: !all_methods; nonstatics := jf :: !nonstatics; end ) cif.cmethods; List.iter (loop_interface abstract cif) cif.cinterfaces; with Not_found -> () in (* another pass: *) (* if List.mem JAbstract cls.cflags then List.iter loop_interface cls.cinterfaces; *) (* if not (List.mem JInterface cls.cflags) then *) List.iter (loop_interface (List.mem JAbstract cls.cflags) cls) cls.cinterfaces; (* for each added field in the interface, lookup in super_methods possible methods to include *) (* so we can choose the better method still *) List.iter (fun im -> let f = List.find_all (fun jf -> jf.jf_name = im.jf_name && compatible_methods jf im) !super_methods in let f = List.map mk_override f in cmethods := f @ !cmethods ) !added_interface_fields; (* take off equals, hashCode and toString from interface *) if List.mem JInterface cls.cflags then cmethods := List.filter (fun jf -> match jf.jf_name, jf.jf_vmsignature with | "equals", TMethod([TObject( (["java";"lang"],"Object"), _)],_) | "hashCode", TMethod([], _) | "toString", TMethod([], _) -> false | _ -> true ) !cmethods; (* change field name to not collide with haxe keywords *) let map_field f = let change = match f.jf_name with | "callback" | "cast" | "extern" | "function" | "in" | "typedef" | "using" | "var" | "untyped" | "inline" -> true | _ when List.mem JStatic f.jf_flags && List.exists (fun f2 -> f.jf_name = f2.jf_name) !nonstatics -> true | _ -> false in if change then { f with jf_name = "%" ^ f.jf_name } else f in (* change static fields that have the same name as methods *) let cfields = List.map map_field cls.cfields in let cmethods = List.map map_field !cmethods in (* take off variable fields that have the same name as methods *) (* and take off variables that already have been declared *) let filter_field f f2 = f != f2 && (List.mem JStatic f.jf_flags = List.mem JStatic f2.jf_flags) && f.jf_name = f2.jf_name && f2.jf_kind <> f.jf_kind in let cfields = List.filter (fun f -> if List.mem JStatic f.jf_flags then not (List.exists (filter_field f) cmethods) else not (List.exists (filter_field f) !nonstatics) && not (List.exists (fun f2 -> f != f2 && f.jf_name = f2.jf_name && not (List.mem JStatic f2.jf_flags)) !all_fields) ) cfields in (* removing duplicate fields. They are there because of return type covariance in Java *) (* Also, if a method overrides a previous definition, and changes a type parameters' variance, *) (* we will take it off *) (* this means that some rare codes will never compile on Haxe, but unless Haxe adds variance support *) (* I can't see how this can be any different *) let rec loop acc = function | [] -> acc | f :: cmeths -> match List.partition (fun f2 -> f.jf_name = f2.jf_name && compatible_methods f f2) cmeths with | [], cmeths -> loop (f :: acc) cmeths | flist, cmeths -> match select_best com (f :: flist) with | None -> loop acc cmeths | Some f -> loop (f :: acc) cmeths in (* last pass: take off all cfields that are internal / private (they won't be accessible anyway) *) let cfields = List.filter(fun f -> List.exists (fun f -> f = JPublic || f = JProtected) f.jf_flags) cfields in let cmethods = loop [] cmethods in { cls with cfields = cfields; cmethods = cmethods } let rec get_classes_dir pack dir ret = Array.iter (fun f -> match (Unix.stat (dir ^"/"^ f)).st_kind with | S_DIR -> get_classes_dir (pack @ [f]) (dir ^"/"^ f) ret | _ when (String.sub (String.uncapitalize f) (String.length f - 6) 6) = ".class" -> let path = jpath_to_hx (pack,f) in ret := path :: !ret; | _ -> () ) (Sys.readdir dir) let get_classes_zip zip = let ret = ref [] in List.iter (function | { Zip.is_directory = false; Zip.filename = f } when (String.sub (String.uncapitalize f) (String.length f - 6) 6) = ".class" -> (match List.rev (String.nsplit f "/") with | clsname :: pack -> let path = jpath_to_hx (List.rev pack, clsname) in ret := path :: !ret | _ -> ret := ([], jname_to_hx f) :: !ret) | _ -> () ) (Zip.entries zip); !ret let add_java_lib com file std = let file = try Common.find_file com file with | Not_found -> try Common.find_file com (file ^ ".jar") with | Not_found -> failwith ("Java lib " ^ file ^ " not found") in let get_raw_class, close, list_all_files = (* check if it is a directory or jar file *) match (Unix.stat file).st_kind with | S_DIR -> (* open classes directly from directory *) (fun (pack, name) -> let pack, name = hxpath_to_j (pack,name) in let real_path = file ^ "/" ^ (String.concat "/" pack) ^ "/" ^ (name ^ ".class") in try let data = Std.input_file ~bin:true real_path in Some(JReader.parse_class (IO.input_string data), real_path, real_path) with | _ -> None), (fun () -> ()), (fun () -> let ret = ref [] in get_classes_dir [] file ret; !ret) | _ -> (* open zip file *) let closed = ref false in let zip = ref (Zip.open_in file) in let check_open () = if !closed then begin prerr_endline ("JAR file " ^ file ^ " already closed"); (* if this happens, find when *) zip := Zip.open_in file; closed := false end in (fun (pack, name) -> let pack, name = hxpath_to_j (pack,name) in check_open(); try let location = (String.concat "/" (pack @ [name]) ^ ".class") in let entry = Zip.find_entry !zip location in let data = Zip.read_entry !zip entry in Some(JReader.parse_class (IO.input_string data), file, file ^ "@" ^ location) with | Not_found -> None), (fun () -> if not !closed then begin closed := true; Zip.close_in !zip end), (fun () -> check_open(); get_classes_zip !zip) in let cached_types = Hashtbl.create 12 in let get_raw_class path = try Hashtbl.find cached_types path with | Not_found -> match get_raw_class path with | None -> Hashtbl.add cached_types path None; None | Some (i, p1, p2) -> Hashtbl.add cached_types path (Some(i,p1,p2)); (* type loop normalization *) let ret = Some (normalize_jclass com i, p1, p2) in Hashtbl.replace cached_types path ret; ret in let rec build ctx path p types = try if List.mem path !types then None else begin types := path :: !types; match get_raw_class path, path with | None, ([], c) -> build ctx (["haxe";"root"], c) p types | None, _ -> None | Some (cls, real_path, pos_path), _ -> if com.verbose then print_endline ("Parsed Java class " ^ (path_s cls.cpath)); let old_types = ctx.jtparams in ctx.jtparams <- cls.ctypes :: ctx.jtparams; let pos = { pfile = pos_path; pmin = 0; pmax = 0; } in let pack = match fst path with | ["haxe";"root"] -> [] | p -> p in let ppath = hxpath_to_j path in let inner = List.fold_left (fun acc (path,out,_,_) -> let path = jpath_to_hx path in (if out <> Some ppath then acc else match build ctx path p types with | Some(_,(_, classes)) -> classes @ acc | _ -> acc); ) [] cls.cinner_types in (* build anonymous classes also * let rec loop inner n = match build ctx (fst path, snd path ^ "$" ^ (string_of_int n)) p types with | Some(_,(_, classes)) -> loop (classes @ inner) (n + 1) | _ -> inner in let inner = loop inner 1 in*) (* add _Statics class *) let inner = try if not (List.mem JInterface cls.cflags) then raise Not_found; let smethods = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cmethods in let sfields = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cfields in if not (smethods <> [] || sfields <> []) then raise Not_found; let obj = TObject( (["java";"lang"],"Object"), []) in let ncls = convert_java_class ctx pos { cls with cmethods = smethods; cfields = sfields; cflags = []; csuper = obj; cinterfaces = []; cinner_types = []; ctypes = [] } in match ncls with | EClass c -> (EClass { c with d_name = c.d_name ^ "_Statics" }, pos) :: inner | _ -> assert false with | Not_found -> inner in let ret = Some ( real_path, (pack, (convert_java_class ctx pos cls, pos) :: inner) ) in ctx.jtparams <- old_types; ret end with | JReader.Error_message msg -> if com.verbose then prerr_endline ("Class reader failed: " ^ msg); None | e -> if com.verbose then begin (* prerr_endline (Printexc.get_backtrace ()); requires ocaml 3.11 *) prerr_endline (Printexc.to_string e) end; None in let build path p = build (create_ctx com) path p (ref [["java";"lang"], "String"]) in let cached_files = ref None in let list_all_files () = match !cached_files with | None -> let ret = list_all_files () in cached_files := Some ret; ret | Some r -> r in (* TODO: add_dependency m mdep *) com.load_extern_type <- com.load_extern_type @ [build]; com.java_libs <- (file, std, close, list_all_files, get_raw_class) :: com.java_libs haxe-3.0~svn6707/Makefile0000644000175000017500000001241112172015135015640 0ustar bdefreesebdefreese# Haxe compiler Makefile # # - use 'make' to build all # - use 'make haxe' to build only the compiler (not the libraries) # - if you want to build quickly, install 'ocamlopt.opt' and change OCAMLOPT=ocamlopt.top # # Windows users : # - use 'make -f Makefile.win' to build for Windows # - use 'make MSVC=1 -f Makefile.win' to build for Windows with OCaml/MSVC # .SUFFIXES : .ml .mli .cmo .cmi .cmx .mll .mly INSTALL_DIR=/usr OUTPUT=haxe EXTENSION= OCAMLOPT=ocamlopt CFLAGS= -g -I libs/extlib -I libs/extc -I libs/neko -I libs/javalib -I libs/ziplib -I libs/swflib -I libs/xml-light -I libs/ttflib CC_CMD = $(OCAMLOPT) $(CFLAGS) -c $< CC_PARSER_CMD = $(OCAMLOPT) -pp camlp4o $(CFLAGS) -c parser.ml LIBS=unix.cmxa str.cmxa libs/extlib/extLib.cmxa libs/xml-light/xml-light.cmxa libs/swflib/swflib.cmxa \ libs/extc/extc.cmxa libs/neko/neko.cmxa libs/javalib/java.cmxa libs/ziplib/zip.cmxa libs/ttflib/ttf.cmxa NATIVE_LIBS=-cclib libs/extc/extc_stubs.o -cclib -lz RELDIR=../../.. EXPORT=../../../projects/motionTools/haxe MODULES=ast type lexer common genxml parser typecore optimizer typeload \ codegen gencommon genas3 gencpp genjs genneko genphp genswf8 \ genswf9 genswf genjava gencs interp typer matcher dce main export HAXE_STD_PATH=$(CURDIR)/std all: libs haxe libs: make -C libs/extlib opt make -C libs/extc native make -C libs/neko make -C libs/javalib make -C libs/ziplib make -C libs/swflib make -C libs/xml-light xml-light.cmxa make -C libs/ttflib haxe: $(MODULES:=.cmx) $(OCAMLOPT) -o $(OUTPUT) $(NATIVE_LIBS) $(LIBS) $(MODULES:=.cmx) haxelib: $(CURDIR)/$(OUTPUT) --cwd "$(CURDIR)/std/tools/haxelib" haxelib.hxml cp std/tools/haxelib/haxelib$(EXTENSION) haxelib$(EXTENSION) haxedoc: $(CURDIR)/$(OUTPUT) --cwd "$(CURDIR)/std/tools/haxedoc" haxedoc.hxml cp std/tools/haxedoc/haxedoc$(EXTENSION) haxedoc$(EXTENSION) tools: haxelib haxedoc install: cp haxe $(INSTALL_DIR)/bin/haxe rm -rf $(INSTALL_DIR)/lib/haxe/std -mkdir -p $(INSTALL_DIR)/lib/haxe svn export std/ $(INSTALL_DIR)/lib/haxe/std -mkdir -p $(INSTALL_DIR)/lib/haxe/lib chmod -R a+rx $(INSTALL_DIR)/lib/haxe chmod 777 $(INSTALL_DIR)/lib/haxe/lib cp std/tools/haxelib/haxelib.sh $(INSTALL_DIR)/bin/haxelib cp std/tools/haxedoc/haxedoc.sh $(INSTALL_DIR)/bin/haxedoc chmod a+rx $(INSTALL_DIR)/bin/haxe $(INSTALL_DIR)/bin/haxelib $(INSTALL_DIR)/bin/haxedoc # will install native version of the tools instead of script ones install_tools: tools cp haxelib ${INSTALL_DIR}/bin/haxelib cp haxedoc ${INSTALL_DIR}/bin/haxedoc chmod a+rx $(INSTALL_DIR)/bin/haxelib $(INSTALL_DIR)/bin/haxedoc uninstall: rm -rf $(INSTALL_DIR)/bin/haxe $(INSTALL_DIR)/bin/haxelib $(INSTALL_DIR)/lib/haxe export: cp haxe*.exe doc/CHANGES.txt $(EXPORT) rsync -a --exclude .svn --exclude *.n --exclude std/libs --delete std $(EXPORT) codegen.cmx: optimizer.cmx typeload.cmx typecore.cmx type.cmx genxml.cmx common.cmx ast.cmx common.cmx: type.cmx ast.cmx dce.cmx: ast.cmx common.cmx type.cmx genas3.cmx: type.cmx common.cmx codegen.cmx ast.cmx gencommon.cmx: type.cmx common.cmx codegen.cmx ast.cmx gencpp.cmx: type.cmx lexer.cmx common.cmx codegen.cmx ast.cmx gencs.cmx: type.cmx lexer.cmx gencommon.cmx common.cmx codegen.cmx ast.cmx genjava.cmx: type.cmx gencommon.cmx common.cmx codegen.cmx ast.cmx genjs.cmx: type.cmx optimizer.cmx lexer.cmx common.cmx codegen.cmx ast.cmx genneko.cmx: type.cmx lexer.cmx common.cmx codegen.cmx ast.cmx genphp.cmx: type.cmx lexer.cmx common.cmx codegen.cmx ast.cmx genswf.cmx: type.cmx genswf9.cmx genswf8.cmx common.cmx ast.cmx genswf8.cmx: type.cmx lexer.cmx common.cmx codegen.cmx ast.cmx genswf9.cmx: type.cmx lexer.cmx genswf8.cmx common.cmx codegen.cmx ast.cmx genxml.cmx: type.cmx lexer.cmx common.cmx ast.cmx interp.cmx: typecore.cmx type.cmx lexer.cmx genneko.cmx common.cmx codegen.cmx ast.cmx genswf.cmx parser.cmx matcher.cmx: optimizer.cmx codegen.cmx typecore.cmx type.cmx typer.cmx common.cmx ast.cmx main.cmx: dce.cmx matcher.cmx typer.cmx typeload.cmx typecore.cmx type.cmx parser.cmx optimizer.cmx lexer.cmx interp.cmx genxml.cmx genswf.cmx genphp.cmx genneko.cmx genjs.cmx gencpp.cmx genas3.cmx common.cmx codegen.cmx ast.cmx gencommon.cmx genjava.cmx gencs.cmx optimizer.cmx: typecore.cmx type.cmx parser.cmx common.cmx ast.cmx parser.cmx: parser.ml lexer.cmx common.cmx ast.cmx $(CC_PARSER_CMD) type.cmx: ast.cmx typecore.cmx: type.cmx common.cmx ast.cmx typeload.cmx: typecore.cmx type.cmx parser.cmx optimizer.cmx lexer.cmx common.cmx ast.cmx typer.cmx: typeload.cmx typecore.cmx type.cmx parser.cmx optimizer.cmx lexer.cmx interp.cmx genneko.cmx genjs.cmx common.cmx codegen.cmx ast.cmx lexer.cmx: lexer.ml lexer.cmx: ast.cmx clean: clean_libs clean_haxe clean_tools clean_libs: make -C libs/extlib clean make -C libs/extc clean make -C libs/neko clean make -C libs/ziplib clean make -C libs/javalib clean make -C libs/swflib clean make -C libs/xml-light clean make -C libs/ttflib clean clean_haxe: rm -f $(MODULES:=.obj) $(MODULES:=.o) $(MODULES:=.cmx) $(MODULES:=.cmi) lexer.ml clean_tools: rm -f $(OUTPUT) haxelib haxedoc # SUFFIXES .ml.cmx: $(CC_CMD) .mli.cmi: $(CC_CMD) .mll.ml: ocamllex $< .PHONY: haxe libs haxe-3.0~svn6707/typer.ml0000644000175000017500000043654012172015135015712 0ustar bdefreesebdefreese(* * Copyright (C)2005-2013 Haxe Foundation * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. *) open Ast open Type open Common open Typecore (* ---------------------------------------------------------------------- *) (* TOOLS *) type switch_mode = | CMatch of (tenum_field * (string * t) option list option * pos) | CExpr of texpr type access_mode = | MGet | MSet | MCall exception DisplayFields of (string * t * documentation) list exception DisplayMetadata of metadata_entry list exception WithTypeError of unify_error list * pos type access_kind = | AKNo of string | AKExpr of texpr | AKSet of texpr * t * tclass_field | AKInline of texpr * tclass_field * tfield_access * t | AKMacro of texpr * tclass_field | AKUsing of texpr * tclass * tclass_field * texpr | AKAccess of texpr * texpr let mk_infos ctx p params = let file = if ctx.in_macro then p.pfile else if Common.defined ctx.com Define.AbsolutePath then Common.get_full_path p.pfile else Filename.basename p.pfile in (EObjectDecl ( ("fileName" , (EConst (String file) , p)) :: ("lineNumber" , (EConst (Int (string_of_int (Lexer.get_error_line p))),p)) :: ("className" , (EConst (String (s_type_path ctx.curclass.cl_path)),p)) :: if ctx.curfield.cf_name = "" then params else ("methodName", (EConst (String ctx.curfield.cf_name),p)) :: params ) ,p) let check_assign ctx e = match e.eexpr with | TLocal _ | TArray _ | TField _ -> () | TConst TThis | TTypeExpr _ when ctx.untyped -> () | _ -> error "Invalid assign" e.epos type type_class = | KInt | KFloat | KString | KUnk | KDyn | KOther | KParam of t | KAbstract of tabstract let rec classify t = match follow t with | TInst ({ cl_path = ([],"String") },[]) -> KString | TAbstract({a_impl = Some _} as a,_) -> KAbstract a | TAbstract ({ a_path = [],"Int" },[]) -> KInt | TAbstract ({ a_path = [],"Float" },[]) -> KFloat | TAbstract (a,[]) when List.exists (fun (t,_) -> match classify t with KInt | KFloat -> true | _ -> false) a.a_to -> KParam t | TInst ({ cl_kind = KTypeParameter ctl },_) when List.exists (fun t -> match classify t with KInt | KFloat -> true | _ -> false) ctl -> KParam t | TMono r when !r = None -> KUnk | TDynamic _ -> KDyn | _ -> KOther let object_field f = let pf = Parser.quoted_ident_prefix in let pflen = String.length pf in if String.length f >= pflen && String.sub f 0 pflen = pf then String.sub f pflen (String.length f - pflen), false else f, true let get_iterator_param t = match follow t with | TAnon a -> if !(a.a_status) <> Closed then raise Not_found; (match follow (PMap.find "hasNext" a.a_fields).cf_type, follow (PMap.find "next" a.a_fields).cf_type with | TFun ([],tb), TFun([],t) when (match follow tb with TAbstract ({ a_path = [],"Bool" },[]) -> true | _ -> false) -> if PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 <> 2 then raise Not_found; t | _ -> raise Not_found) | _ -> raise Not_found let get_iterable_param t = match follow t with | TAnon a -> if !(a.a_status) <> Closed then raise Not_found; (match follow (PMap.find "iterator" a.a_fields).cf_type with | TFun ([],it) -> let t = get_iterator_param it in if PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 <> 1 then raise Not_found; t | _ -> raise Not_found) | _ -> raise Not_found (* temporally remove the constant flag from structures to allow larger unification *) let remove_constant_flag t callb = let tmp = ref [] in let rec loop t = match follow t with | TAnon a -> if !(a.a_status) = Const then begin a.a_status := Closed; tmp := a :: !tmp; end; PMap.iter (fun _ f -> loop f.cf_type) a.a_fields; | _ -> () in let restore() = List.iter (fun a -> a.a_status := Const) (!tmp) in try loop t; let ret = callb (!tmp <> []) in restore(); ret with e -> restore(); raise e let rec is_pos_infos = function | TMono r -> (match !r with | Some t -> is_pos_infos t | _ -> false) | TLazy f -> is_pos_infos (!f()) | TType ({ t_path = ["haxe"] , "PosInfos" },[]) -> true | TType (t,tl) -> is_pos_infos (apply_params t.t_types tl t.t_type) | _ -> false let add_constraint_checks ctx ctypes pl f tl p = List.iter2 (fun m (name,t) -> match follow t with | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] -> let constr = List.map (fun t -> let t = apply_params f.cf_params tl t in (* only apply params if not static : in that case no param is passed *) let t = (if pl = [] then t else apply_params ctypes pl t) in t ) constr in delay ctx PCheckConstraint (fun() -> List.iter (fun ct -> try Type.unify m ct with Unify_error l -> display_error ctx (error_msg (Unify (Constraint_failure (f.cf_name ^ "." ^ name) :: l))) p; ) constr ); | _ -> () ) tl f.cf_params let field_type ctx c pl f p = match f.cf_params with | [] -> f.cf_type | l -> let monos = List.map (fun _ -> mk_mono()) l in if not (Meta.has Meta.Generic f.cf_meta) then add_constraint_checks ctx c.cl_types pl f monos p; apply_params l monos f.cf_type let class_field ctx c pl name p = raw_class_field (fun f -> field_type ctx c pl f p) c name (* checks if we can access to a given class field using current context *) let rec can_access ctx c cf stat = if cf.cf_public then true else (* has metadata path *) let make_path c f = fst c.cl_path @ [snd c.cl_path; f.cf_name] in let rec expr_path acc e = match fst e with | EField (e,f) -> expr_path (f :: acc) e | EConst (Ident n) -> n :: acc | _ -> [] in let rec chk_path psub pfull = match psub, pfull with | [], _ -> true | a :: l1, b :: l2 when a = b -> chk_path l1 l2 | _ -> false in let has m c f path = let rec loop = function | (m2,[e],_) :: l when m = m2 -> let p = expr_path [] e in (p <> [] && chk_path p path) || loop l | _ :: l -> loop l | [] -> false in loop c.cl_meta || loop f.cf_meta in let cur_path = make_path ctx.curclass ctx.curfield in let is_constr = cf.cf_name = "new" in let rec loop c = (try (* if our common ancestor declare/override the field, then we can access it *) let f = if is_constr then (match c.cl_constructor with None -> raise Not_found | Some c -> c) else PMap.find cf.cf_name (if stat then c.cl_statics else c.cl_fields) in is_parent c ctx.curclass || has Meta.Allow c f cur_path with Not_found -> false ) || (match c.cl_super with | Some (csup,_) -> loop csup | None -> false) || has Meta.Access ctx.curclass ctx.curfield (make_path c cf) in let b = loop c (* access is also allowed of we access a type parameter which is constrained to our (base) class *) || (match c.cl_kind with | KTypeParameter tl -> List.exists (fun t -> match follow t with TInst(c,_) -> loop c | _ -> false) tl | _ -> false) || (Meta.has Meta.PrivateAccess ctx.meta) in if b && Common.defined ctx.com Common.Define.As3 && not (Meta.has Meta.Public cf.cf_meta) then cf.cf_meta <- (Meta.Public,[],cf.cf_pos) :: cf.cf_meta; b (* removes the first argument of the class field's function type and all its overloads *) let prepare_using_field cf = match cf.cf_type with | TFun((_,_,tf) :: args,ret) -> let rec loop acc overloads = match overloads with | ({cf_type = TFun((_,_,tfo) :: args,ret)} as cfo) :: l -> let tfo = apply_params cfo.cf_params (List.map snd cfo.cf_params) tfo in (* ignore overloads which have a different first argument *) if Type.type_iseq tf tfo then loop ({cfo with cf_type = TFun(args,ret)} :: acc) l else loop acc l | _ :: l -> loop acc l | [] -> acc in {cf with cf_overloads = loop [] cf.cf_overloads; cf_type = TFun(args,ret)} | _ -> cf let find_array_access a pl c t1 t2 is_set = let ta = apply_params a.a_types pl a.a_this in let rec loop cfl = match cfl with | [] -> raise Not_found | cf :: cfl when not (Meta.has Meta.ArrayAccess cf.cf_meta) -> loop cfl | cf :: cfl -> match follow (apply_params a.a_types pl (monomorphs cf.cf_params cf.cf_type)) with | TFun([(_,_,tab);(_,_,ta1);(_,_,ta2)],r) as tf when is_set && type_iseq tab ta && type_iseq ta1 t1 && type_iseq ta2 t2 -> cf,tf,r | TFun([(_,_,tab);(_,_,ta1)],r) as tf when not is_set && type_iseq tab ta && type_iseq ta1 t1 -> cf,tf,r | _ -> loop cfl in loop a.a_array let parse_string ctx s p inlined = let old = Lexer.save() in let old_file = (try Some (Hashtbl.find Lexer.all_files p.pfile) with Not_found -> None) in let old_display = !Parser.resume_display in let old_de = !Parser.display_error in let restore() = (match old_file with | None -> () | Some f -> Hashtbl.replace Lexer.all_files p.pfile f); if not inlined then Parser.resume_display := old_display; Lexer.restore old; Parser.display_error := old_de in Lexer.init p.pfile; Parser.display_error := (fun e p -> raise (Parser.Error (e,p))); if not inlined then Parser.resume_display := null_pos; let _, decls = try Parser.parse ctx.com (Lexing.from_string s) with Parser.Error (e,pe) -> restore(); error (Parser.error_msg e) (if inlined then pe else p) | Lexer.Error (e,pe) -> restore(); error (Lexer.error_msg e) (if inlined then pe else p) in restore(); match decls with | [(d,_)] -> d | _ -> assert false let parse_expr_string ctx s p inl = let head = "class X{static function main() " in let head = (if p.pmin > String.length head then head ^ String.make (p.pmin - String.length head) ' ' else head) in let rec loop e = let e = Ast.map_expr loop e in (fst e,p) in match parse_string ctx (head ^ s ^ ";}") p inl with | EClass { d_data = [{ cff_name = "main"; cff_kind = FFun { f_expr = Some e } }]} -> if inl then e else loop e | _ -> assert false (* ---------------------------------------------------------------------- *) (* PASS 3 : type expression & check structure *) let rec base_types t = let tl = ref [] in let rec loop t = (match t with | TInst(cl, params) -> (match cl.cl_kind with | KTypeParameter tl -> List.iter loop tl | _ -> ()); List.iter (fun (ic, ip) -> let t = apply_params cl.cl_types params (TInst (ic,ip)) in loop t ) cl.cl_implements; (match cl.cl_super with None -> () | Some (csup, pl) -> let t = apply_params cl.cl_types params (TInst (csup,pl)) in loop t); tl := t :: !tl; | TType (td,pl) -> loop (apply_params td.t_types pl td.t_type); (* prioritize the most generic definition *) tl := t :: !tl; | TLazy f -> loop (!f()) | TMono r -> (match !r with None -> () | Some t -> loop t) | _ -> tl := t :: !tl) in loop t; !tl let rec unify_min_raise ctx (el:texpr list) : t = match el with | [] -> mk_mono() | [e] -> e.etype | _ -> let rec chk_null e = is_null e.etype || match e.eexpr with | TConst TNull -> true | TBlock el -> (match List.rev el with | [] -> false | e :: _ -> chk_null e) | TParenthesis e -> chk_null e | _ -> false in (* First pass: Try normal unification and find out if null is involved. *) let rec loop t = function | [] -> false, t | e :: el -> let t = if chk_null e then ctx.t.tnull t else t in try unify_raise ctx e.etype t e.epos; loop t el with Error (Unify _,_) -> try unify_raise ctx t e.etype e.epos; loop (if is_null t then ctx.t.tnull e.etype else e.etype) el with Error (Unify _,_) -> true, t in let has_error, t = loop (mk_mono()) el in if not has_error then t else try (* specific case for const anon : we don't want to hide fields but restrict their common type *) let fcount = ref (-1) in let field_count a = PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 in let expr f = match f.cf_expr with None -> mk (TBlock []) f.cf_type f.cf_pos | Some e -> e in let fields = List.fold_left (fun acc e -> match follow e.etype with | TAnon a when !(a.a_status) = Const -> a.a_status := Closed; if !fcount = -1 then begin fcount := field_count a; PMap.map (fun f -> [expr f]) a.a_fields end else begin if !fcount <> field_count a then raise Not_found; PMap.mapi (fun n el -> expr (PMap.find n a.a_fields) :: el) acc end | _ -> raise Not_found ) PMap.empty el in let fields = PMap.foldi (fun n el acc -> let t = try unify_min_raise ctx el with Error (Unify _, _) -> raise Not_found in PMap.add n (mk_field n t (List.hd el).epos) acc ) fields PMap.empty in TAnon { a_fields = fields; a_status = ref Closed } with Not_found -> (* Second pass: Get all base types (interfaces, super classes and their interfaces) of most general type. Then for each additional type filter all types that do not unify. *) let common_types = base_types t in let dyn_types = List.fold_left (fun acc t -> let rec loop c = Meta.has Meta.UnifyMinDynamic c.cl_meta || (match c.cl_super with None -> false | Some (c,_) -> loop c) in match t with | TInst (c,params) when params <> [] && loop c -> TInst (c,List.map (fun _ -> t_dynamic) params) :: acc | _ -> acc ) [] common_types in let common_types = ref (match List.rev dyn_types with [] -> common_types | l -> common_types @ l) in let loop e = let first_error = ref None in let filter t = (try unify_raise ctx e.etype t e.epos; true with Error (Unify l, p) as err -> if !first_error = None then first_error := Some(err); false) in common_types := List.filter filter !common_types; match !common_types, !first_error with | [], Some err -> raise err | _ -> () in match !common_types with | [] -> error "No common base type found" (punion (List.hd el).epos (List.hd (List.rev el)).epos) | _ -> List.iter loop (List.tl el); List.hd !common_types let unify_min ctx el = try unify_min_raise ctx el with Error (Unify l,p) -> if not ctx.untyped then display_error ctx (error_msg (Unify l)) p; (List.hd el).etype let rec unify_call_params ctx ?(overloads=None) cf el args r p inline = (* 'overloads' will carry a ( return_result ) list, called 'compatible' *) (* it's used to correctly support an overload selection algorithm *) let overloads, compatible, legacy = match cf, overloads with | Some(TInst(c,pl),f), None when ctx.com.config.pf_overload && Meta.has Meta.Overload f.cf_meta -> let overloads = List.filter (fun (_,f2) -> not (f == f2)) (Typeload.get_overloads c f.cf_name) in if overloads = [] then (* is static function *) List.map (fun f -> f.cf_type, f) f.cf_overloads, [], false else overloads, [], false | Some(_,f), None -> List.map (fun f -> f.cf_type, f) f.cf_overloads, [], true | _, Some s -> s | _ -> [], [], true in let next ?retval () = let compatible = Option.map_default (fun r -> r :: compatible) compatible retval in match cf, overloads with | Some (TInst(c,pl),_), (ft,o) :: l -> let o = { o with cf_type = ft } in let args, ret = (match follow (apply_params c.cl_types pl (field_type ctx c pl o p)) with (* I'm getting non-followed types here. Should it happen? *) | TFun (tl,t) -> tl, t | _ -> assert false ) in Some (unify_call_params ctx ~overloads:(Some (l,compatible,legacy)) (Some (TInst(c,pl),o)) el args ret p inline) | Some (t,_), (ft,o) :: l -> let o = { o with cf_type = ft } in let args, ret = (match Type.field_type o with | TFun (tl,t) -> tl, t | _ -> assert false ) in Some (unify_call_params ctx ~overloads:(Some (l,compatible,legacy)) (Some (t, o)) el args ret p inline) | _ -> match compatible with | [] -> None | [acc,t] -> Some (List.map fst acc, t) | comp -> match Codegen.Overloads.reduce_compatible compatible with | [acc,t] -> Some (List.map fst acc, t) | (acc,t) :: _ -> (* ambiguous overload *) let name = match cf with | Some(_,f) -> "'" ^ f.cf_name ^ "' " | _ -> "" in let format_amb = String.concat "\n" (List.map (fun (_,t) -> "Function " ^ name ^ "with type " ^ (s_type (print_context()) t) ) compatible) in display_error ctx ("This call is ambiguous between the following methods:\n" ^ format_amb) p; Some (List.map fst acc,t) | [] -> None in let fun_details() = let format_arg = (fun (name,opt,_) -> (if opt then "?" else "") ^ name) in "Function " ^ (match cf with None -> "" | Some (_,f) -> "'" ^ f.cf_name ^ "' ") ^ "requires " ^ (if args = [] then "no arguments" else "arguments : " ^ String.concat ", " (List.map format_arg args)) in let error acc txt = match next() with | Some l -> l | None -> display_error ctx (txt ^ " arguments\n" ^ (fun_details())) p; List.rev (List.map fst acc), (TFun(args,r)) in let arg_error ul name opt p = match next() with | Some l -> l | None -> raise (Error (Stack (Unify ul,Custom ("For " ^ (if opt then "optional " else "") ^ "function argument '" ^ name ^ "'")), p)) in let rec no_opt = function | [] -> [] | ({ eexpr = TConst TNull },true) :: l -> no_opt l | l -> l in let rec default_value t = if is_pos_infos t then let infos = mk_infos ctx p [] in let e = type_expr ctx infos (WithType t) in (e, true) else (null (ctx.t.tnull t) p, true) in let rec loop acc l l2 skip = match l , l2 with | [] , [] -> let args,tf = if not (inline && ctx.g.doinline) && not ctx.com.config.pf_pad_nulls then List.rev (no_opt acc), (TFun(args,r)) else List.rev (acc), (TFun(args,r)) in if not legacy && ctx.com.config.pf_overload then match next ~retval:(args,tf) () with | Some l -> l | None -> display_error ctx ("No overloaded function matches the arguments. Are the arguments correctly typed?") p; List.map fst args, tf else List.map fst args, tf | [] , (_,false,_) :: _ -> error (List.fold_left (fun acc (_,_,t) -> default_value t :: acc) acc l2) "Not enough" | [] , (name,true,t) :: l -> loop (default_value t :: acc) [] l skip | _ , [] -> (match List.rev skip with | [] -> error acc "Too many" | [name,ul] -> arg_error ul name true p | (name,ul) :: _ -> arg_error (Unify_custom ("Invalid arguments\n" ^ fun_details()) :: ul) name true p) | ee :: l, (name,opt,t) :: l2 -> try let e = type_expr ctx ee (WithTypeResume t) in (try unify_raise ctx e.etype t e.epos with Error (Unify l,p) -> raise (WithTypeError (l,p))); loop ((e,false) :: acc) l l2 skip with WithTypeError (ul,p) -> if opt then loop (default_value t :: acc) (ee :: l) l2 ((name,ul) :: skip) else arg_error ul name false p in loop [] el args [] let fast_enum_field e ef p = let et = mk (TTypeExpr (TEnumDecl e)) (TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics e) }) p in TField (et,FEnum (e,ef)) let rec type_module_type ctx t tparams p = match t with | TClassDecl c -> let t_tmp = { t_path = fst c.cl_path, "#" ^ snd c.cl_path; t_module = c.cl_module; t_doc = None; t_pos = c.cl_pos; t_type = TAnon { a_fields = c.cl_statics; a_status = ref (Statics c); }; t_private = true; t_types = []; t_meta = no_meta; } in mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p | TEnumDecl e -> let types = (match tparams with None -> List.map (fun _ -> mk_mono()) e.e_types | Some l -> l) in let fl = PMap.fold (fun f acc -> PMap.add f.ef_name { cf_name = f.ef_name; cf_public = true; cf_type = f.ef_type; cf_kind = (match follow f.ef_type with | TFun _ -> Method MethNormal | _ -> Var { v_read = AccNormal; v_write = AccNo } ); cf_pos = e.e_pos; cf_doc = None; cf_meta = no_meta; cf_expr = None; cf_params = f.ef_params; cf_overloads = []; } acc ) e.e_constrs PMap.empty in let t_tmp = { t_path = fst e.e_path, "#" ^ snd e.e_path; t_module = e.e_module; t_doc = None; t_pos = e.e_pos; t_type = TAnon { a_fields = fl; a_status = ref (EnumStatics e); }; t_private = true; t_types = e.e_types; t_meta = no_meta; } in mk (TTypeExpr (TEnumDecl e)) (TType (t_tmp,types)) p | TTypeDecl s -> let t = apply_params s.t_types (List.map (fun _ -> mk_mono()) s.t_types) s.t_type in (match follow t with | TEnum (e,params) -> type_module_type ctx (TEnumDecl e) (Some params) p | TInst (c,params) -> type_module_type ctx (TClassDecl c) (Some params) p | TAbstract (a,params) -> type_module_type ctx (TAbstractDecl a) (Some params) p | _ -> error (s_type_path s.t_path ^ " is not a value") p) | TAbstractDecl { a_impl = Some c } -> type_module_type ctx (TClassDecl c) tparams p | TAbstractDecl a -> if not (Meta.has Meta.RuntimeValue a.a_meta) then error (s_type_path a.a_path ^ " is not a value") p; let t_tmp = { t_path = fst a.a_path, "#" ^ snd a.a_path; t_module = a.a_module; t_doc = None; t_pos = a.a_pos; t_type = TAnon { a_fields = PMap.empty; a_status = ref (AbstractStatics a); }; t_private = true; t_types = []; t_meta = no_meta; } in mk (TTypeExpr (TAbstractDecl a)) (TType (t_tmp,[])) p let type_type ctx tpath p = type_module_type ctx (Typeload.load_type_def ctx p { tpackage = fst tpath; tname = snd tpath; tparams = []; tsub = None }) None p let get_constructor ctx c params p = match c.cl_kind with | KAbstractImpl a -> let f = (try PMap.find "_new" c.cl_statics with Not_found -> error (s_type_path a.a_path ^ " does not have a constructor") p) in let ct = field_type ctx c params f p in apply_params a.a_types params ct, f | _ -> let ct, f = (try Type.get_constructor (fun f -> field_type ctx c params f p) c with Not_found -> error (s_type_path c.cl_path ^ " does not have a constructor") p) in apply_params c.cl_types params ct, f let make_call ctx e params t p = try let ethis, fname = (match e.eexpr with TField (ethis,f) -> ethis, field_name f | _ -> raise Exit) in let f, cl = (match follow ethis.etype with | TInst (c,params) -> (try let _,_,f = Type.class_field c fname in f with Not_found -> raise Exit), Some c | TAnon a -> (try PMap.find fname a.a_fields with Not_found -> raise Exit), (match !(a.a_status) with Statics c -> Some c | _ -> None) | _ -> raise Exit ) in if f.cf_kind <> Method MethInline then raise Exit; let is_extern = (match cl with | Some { cl_extern = true } -> true | Some { cl_kind = KAbstractImpl _ } -> true | _ when Meta.has Meta.Extern f.cf_meta -> true | _ -> false ) in let config = match cl with | Some ({cl_kind = KAbstractImpl _ }) when Meta.has Meta.Impl f.cf_meta -> (match if fname = "_new" then t else if params = [] then error "Invalid abstract implementation function" f.cf_pos else follow (List.hd params).etype with | TAbstract(a,pl) -> Some (a.a_types <> [] || f.cf_params <> [], fun t -> apply_params a.a_types pl (monomorphs f.cf_params t)) | _ -> None); | _ -> None in ignore(follow f.cf_type); (* force evaluation *) let params = List.map (ctx.g.do_optimize ctx) params in (match f.cf_expr with | Some { eexpr = TFunction fd } -> (match Optimizer.type_inline ctx f fd ethis params t config p is_extern with | None -> if is_extern then error "Inline could not be done" p; raise Exit; | Some e -> e) | _ -> (* we can't inline because there is most likely a loop in the typing. this can be caused by mutually recursive vars/functions, some of them being inlined or not. In that case simply ignore inlining. *) raise Exit) with Exit -> mk (TCall (e,params)) t p let rec acc_get ctx g p = match g with | AKNo f -> error ("Field " ^ f ^ " cannot be accessed for reading") p | AKExpr e -> e | AKSet _ | AKAccess _ -> assert false | AKUsing (et,_,_,e) -> (* build a closure with first parameter applied *) (match follow et.etype with | TFun (_ :: args,ret) -> let tcallb = TFun (args,ret) in let twrap = TFun ([("_e",false,e.etype)],tcallb) in let args = List.map (fun (n,_,t) -> alloc_var n t) args in let ve = alloc_var "_e" e.etype in let ecall = make_call ctx et (List.map (fun v -> mk (TLocal v) v.v_type p) (ve :: args)) ret p in let ecallb = mk (TFunction { tf_args = List.map (fun v -> v,None) args; tf_type = ret; tf_expr = mk (TReturn (Some ecall)) t_dynamic p; }) tcallb p in let ewrap = mk (TFunction { tf_args = [ve,None]; tf_type = tcallb; tf_expr = mk (TReturn (Some ecallb)) t_dynamic p; }) twrap p in make_call ctx ewrap [e] tcallb p | _ -> assert false) | AKInline (e,f,fmode,t) -> (* do not create a closure for static calls *) let cmode = (match fmode with FStatic _ -> fmode | FInstance (c,f) -> FClosure (Some c,f) | _ -> assert false) in ignore(follow f.cf_type); (* force computing *) (match f.cf_expr with | None -> if ctx.com.display then mk (TField (e,cmode)) t p else error "Recursive inline is not supported" p | Some { eexpr = TFunction _ } -> let chk_class c = if (c.cl_extern || Meta.has Meta.Extern f.cf_meta) && not (Meta.has Meta.Runtime f.cf_meta) then display_error ctx "Can't create closure on an inline extern method" p in (match follow e.etype with | TInst (c,_) -> chk_class c | TAnon a -> (match !(a.a_status) with Statics c -> chk_class c | _ -> ()) | _ -> ()); mk (TField (e,cmode)) t p | Some e -> let rec loop e = Type.map_expr loop { e with epos = p } in loop e) | AKMacro _ -> assert false let error_require r p = let r = if r = "sys" then "a system platform (php,neko,cpp,etc.)" else try if String.sub r 0 5 <> "flash" then raise Exit; let _, v = ExtString.String.replace (String.sub r 5 (String.length r - 5)) "_" "." in "flash version " ^ v ^ " (use -swf-version " ^ v ^ ")" with _ -> "'" ^ r ^ "' to be enabled" in error ("Accessing this field requires " ^ r) p let get_this ctx p = match ctx.curfun with | FunStatic -> error "Cannot access this from a static function" p | FunMemberLocal -> let v = (match ctx.vthis with | None -> (* we might be in a closure of an abstract member, so check for local "this" first *) let v = try PMap.find "this" ctx.locals with Not_found -> gen_local ctx ctx.tthis in ctx.vthis <- Some v; v | Some v -> ctx.locals <- PMap.add v.v_name v ctx.locals; v ) in mk (TLocal v) ctx.tthis p | FunMemberAbstract -> let v = (try PMap.find "this" ctx.locals with Not_found -> assert false) in mk (TLocal v) v.v_type p | FunConstructor | FunMember -> mk (TConst TThis) ctx.tthis p let field_access ctx mode f fmode t e p = let fnormal() = AKExpr (mk (TField (e,fmode)) t p) in let normal() = match follow e.etype with | TAnon a -> (match !(a.a_status) with | EnumStatics en -> let c = (try PMap.find f.cf_name en.e_constrs with Not_found -> assert false) in let fmode = FEnum (en,c) in AKExpr (mk (TField (e,fmode)) t p) | _ -> fnormal()) | _ -> fnormal() in match f.cf_kind with | Method m -> if mode = MSet && m <> MethDynamic && not ctx.untyped then error "Cannot rebind this method : please use 'dynamic' before method declaration" p; (match m, mode with | _ when (match e.eexpr with TTypeExpr(TClassDecl ({cl_kind = KAbstractImpl a} as c)) -> c == ctx.curclass && ctx.curfun = FunMemberAbstract && Meta.has Meta.Impl f.cf_meta | _ -> false) -> let e = mk (TField(e,fmode)) t p in AKUsing(e,ctx.curclass,f,get_this ctx p) | MethInline, _ -> AKInline (e,f,fmode,t) | MethMacro, MGet -> display_error ctx "Macro functions must be called immediately" p; normal() | MethMacro, MCall -> AKMacro (e,f) | _ , MGet -> let cmode = (match fmode with | FInstance (c,cf) -> FClosure (Some c,cf) | FStatic _ | FEnum _ -> fmode | FAnon f -> FClosure (None, f) | FDynamic _ | FClosure _ -> assert false ) in AKExpr (mk (TField (e,cmode)) t p) | _ -> normal()) | Var v -> match (match mode with MGet | MCall -> v.v_read | MSet -> v.v_write) with | AccNo -> (match follow e.etype with | TInst (c,_) when is_parent c ctx.curclass || can_access ctx c { f with cf_public = false } false -> normal() | TAnon a -> (match !(a.a_status) with | Opened when mode = MSet -> f.cf_kind <- Var { v with v_write = AccNormal }; normal() | Statics c2 when ctx.curclass == c2 || can_access ctx c2 { f with cf_public = false } true -> normal() | _ -> if ctx.untyped then normal() else AKNo f.cf_name) | _ -> if ctx.untyped then normal() else AKNo f.cf_name) | AccNormal -> (* if we are reading from a read-only variable on an anonymous object, it might actually be a method, so make sure to create a closure *) let is_maybe_method() = match v.v_write, follow t, follow e.etype with | (AccNo | AccNever), TFun _, TAnon a -> (match !(a.a_status) with | Statics _ | EnumStatics _ -> false | _ -> true) | _ -> false in if mode = MGet && is_maybe_method() then AKExpr (mk (TField (e,FClosure (None,f))) t p) else normal() | AccCall -> let m = (match mode with MSet -> "set_" | _ -> "get_") ^ f.cf_name in if m = ctx.curfield.cf_name && (match e.eexpr with TConst TThis -> true | TTypeExpr (TClassDecl c) when c == ctx.curclass -> true | _ -> false) then let prefix = (match ctx.com.platform with Flash when Common.defined ctx.com Define.As3 -> "$" | _ -> "") in if is_extern_field f then begin display_error ctx "This field cannot be accessed because it is not a real variable" p; display_error ctx "Add @:isVar here to enable it" f.cf_pos; end; AKExpr (mk (TField (e,if prefix = "" then fmode else FDynamic (prefix ^ f.cf_name))) t p) else if (match e.eexpr with TTypeExpr (TClassDecl ({cl_kind = KAbstractImpl _} as c)) when c == ctx.curclass -> true | _ -> false) then begin let this = get_this ctx p in if mode = MSet then begin let c,a = match ctx.curclass with {cl_kind = KAbstractImpl a} as c -> c,a | _ -> assert false in let f = PMap.find m c.cl_statics in (* we don't have access to the type parameters here, right? *) (* let t = apply_params a.a_types pl (field_type ctx c [] f p) in *) let t = (field_type ctx c [] f p) in let ef = mk (TField (e,FStatic (c,f))) t p in AKUsing (ef,c,f,this) end else AKExpr (make_call ctx (mk (TField (e,quick_field_dynamic e.etype m)) (tfun [this.etype] t) p) [this] t p) end else if mode = MSet then AKSet (e,t,f) else AKExpr (make_call ctx (mk (TField (e,quick_field_dynamic e.etype m)) (tfun [] t) p) [] t p) | AccResolve -> 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,FDynamic "resolve")) tresolve p) [fstring] t p) | AccNever -> if ctx.untyped then normal() else AKNo f.cf_name | AccInline -> AKInline (e,f,fmode,t) | AccRequire (r,msg) -> match msg with | None -> error_require r p | Some msg -> error msg p let rec using_field ctx mode e i p = if mode = MSet then raise Not_found; (* do not try to find using fields if the type is a monomorph, which could lead to side-effects *) let is_dynamic = match follow e.etype with | TMono _ -> raise Not_found | t -> t == t_dynamic in let check_constant_struct = ref false in let rec loop = function | [] -> raise Not_found | c :: l -> try let cf = PMap.find i c.cl_statics in if Meta.has Meta.NoUsing cf.cf_meta then raise Not_found; let monos = List.map (fun _ -> mk_mono()) cf.cf_params in let map = apply_params cf.cf_params monos in let t = map cf.cf_type in begin match follow t with | TFun((_,_,(TType({t_path = ["haxe";"macro"],"ExprOf"},[t0]) | t0)) :: args,r) -> if is_dynamic && follow t0 != t_dynamic then raise Not_found; Type.unify e.etype t0; (* early constraints check is possible because e.etype has no monomorphs *) List.iter2 (fun m (name,t) -> match follow t with | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] -> List.iter (fun tc -> Type.unify m (map tc)) constr | _ -> () ) monos cf.cf_params; let et = type_module_type ctx (TClassDecl c) None p in AKUsing (mk (TField (et,FStatic (c,cf))) t p,c,cf,e) | _ -> raise Not_found end with Not_found -> loop l | Unify_error el -> if List.exists (function Has_extra_field _ -> true | _ -> false) el then check_constant_struct := true; loop l in try loop ctx.m.module_using with Not_found -> try loop ctx.g.global_using with Not_found -> if not !check_constant_struct then raise Not_found; remove_constant_flag e.etype (fun ok -> if ok then using_field ctx mode e i p else raise Not_found) let rec type_ident_raise ?(imported_enums=true) ctx i p mode = match i with | "true" -> if mode = MGet then AKExpr (mk (TConst (TBool true)) ctx.t.tbool p) else AKNo i | "false" -> if mode = MGet then AKExpr (mk (TConst (TBool false)) ctx.t.tbool p) else AKNo i | "this" -> (match mode, ctx.curclass.cl_kind with | MSet, KAbstractImpl _ -> (match ctx.curfield.cf_kind with | Method MethInline -> () | Method _ when ctx.curfield.cf_name = "_new" -> () | _ -> error "You can only modify 'this' inside an inline function" p); AKExpr (get_this ctx p) | _ -> if mode = MGet then AKExpr (get_this ctx p) else AKNo i) | "super" -> let t = (match ctx.curclass.cl_super with | None -> error "Current class does not have a superclass" p | Some (c,params) -> TInst(c,params) ) in (match ctx.curfun with | FunMember | FunConstructor -> () | FunMemberAbstract -> error "Cannot access super inside an abstract function" p | FunStatic -> error "Cannot access super inside a static function" p; | FunMemberLocal -> error "Cannot access super inside a local function" p); if mode <> MSet && ctx.in_super_call then ctx.in_super_call <- false; AKExpr (mk (TConst TSuper) t p) | "null" -> if mode = MGet then AKExpr (null (mk_mono()) p) else AKNo i | _ -> try let v = PMap.find i ctx.locals in (match v.v_extra with | Some (params,e) -> let t = monomorphs params v.v_type in (match e with | Some ({ eexpr = TFunction f } as e) -> (* create a fake class with a fake field to emulate inlining *) let c = mk_class ctx.m.curmod (["local"],v.v_name) e.epos in let cf = { (mk_field v.v_name v.v_type e.epos) with cf_params = params; cf_expr = Some e; cf_kind = Method MethInline } in c.cl_extern <- true; c.cl_fields <- PMap.add cf.cf_name cf PMap.empty; AKInline (mk (TConst TNull) (TInst (c,[])) p, cf, FInstance(c,cf), t) | _ -> AKExpr (mk (TLocal v) t p)) | _ -> AKExpr (mk (TLocal v) v.v_type p)) with Not_found -> try (* member variable lookup *) if ctx.curfun = FunStatic then raise Not_found; let c , t , f = class_field ctx ctx.curclass [] i p in field_access ctx mode f (match c with None -> FAnon f | Some c -> FInstance (c,f)) t (get_this ctx p) p with Not_found -> try (* lookup using on 'this' *) if ctx.curfun = FunStatic then raise Not_found; (match using_field ctx mode (mk (TConst TThis) ctx.tthis p) i p with | AKUsing (et,c,f,_) -> AKUsing (et,c,f,get_this ctx p) | _ -> assert false) with Not_found -> try (* static variable lookup *) let f = PMap.find i ctx.curclass.cl_statics in let e = type_type ctx ctx.curclass.cl_path p in (* check_locals_masking already done in type_type *) field_access ctx mode f (FStatic (ctx.curclass,f)) (field_type ctx ctx.curclass [] f p) e p with Not_found -> try if not imported_enums then raise Not_found; (* lookup imported enums *) let rec loop l = match l with | [] -> raise Not_found | t :: l -> match t with | TClassDecl _ | TAbstractDecl _ -> loop l | TTypeDecl t -> (match follow t.t_type with | TEnum (e,_) -> loop ((TEnumDecl e) :: l) | _ -> loop l) | TEnumDecl e -> try let ef = PMap.find i e.e_constrs in let et = type_module_type ctx t None p in mk (TField (et,FEnum (e,ef))) (monomorphs ef.ef_params (monomorphs e.e_types ef.ef_type)) p with Not_found -> loop l in let e = (try loop (List.rev ctx.m.curmod.m_types) with Not_found -> loop ctx.m.module_types) in if mode = MSet then AKNo i else AKExpr e with Not_found -> (* lookup imported globals *) let t, name = PMap.find i ctx.m.module_globals in let e = type_module_type ctx t None p in type_field ctx e name p mode and type_field ctx e i p mode = let no_field() = let t = match follow e.etype with | TAnon a -> (match !(a.a_status) with | Statics {cl_kind = KAbstractImpl a} -> TAbstract(a,[]) | _ -> e.etype) | TInst({cl_kind = KAbstractImpl a},_) -> TAbstract(a,[]) | _ -> e.etype in if not ctx.untyped then display_error ctx (string_error i (string_source t) (s_type (print_context()) t ^ " has no field " ^ i)) p; AKExpr (mk (TField (e,FDynamic i)) (mk_mono()) p) in match follow e.etype with | TInst (c,params) -> let rec loop_dyn c params = match c.cl_dynamic with | Some t -> let t = apply_params c.cl_types params t in if (mode = MGet || mode = MCall) && PMap.mem "resolve" c.cl_fields then begin let f = PMap.find "resolve" c.cl_fields in AKExpr (make_call ctx (mk (TField (e,FInstance (c,f))) (tfun [ctx.t.tstring] t) p) [Codegen.type_constant ctx.com (String i) p] t p) end else AKExpr (mk (TField (e,FDynamic i)) t p) | None -> match c.cl_super with | None -> raise Not_found | Some (c,params) -> loop_dyn c params in (try let c2, t , f = class_field ctx c params i p in if e.eexpr = TConst TSuper then (match mode,f.cf_kind with | MGet,Var {v_read = AccCall } | MSet,Var {v_write = AccCall } | MCall,Var {v_read = AccCall } -> () | MCall, Var _ -> error "Cannot access superclass variable for calling: needs to be a proper method" p | MCall, _ -> () | MGet,Var _ | MSet,Var _ when (match c2 with Some { cl_extern = true; cl_path = ("flash" :: _,_) } -> true | _ -> false) -> () | _, Method _ -> error "Cannot create closure on super method" p | _ -> error "Normal variables cannot be accessed with 'super', use 'this' instead" p); if not (can_access ctx c f false) && not ctx.untyped then display_error ctx ("Cannot access private field " ^ i) p; field_access ctx mode f (match c2 with None -> FAnon f | Some c -> FInstance (c,f)) (apply_params c.cl_types params t) e p with Not_found -> try using_field ctx mode e i p with Not_found -> try loop_dyn c params with Not_found -> if PMap.mem i c.cl_statics then error ("Cannot access static field " ^ i ^ " from a class instance") p; (* This is a fix to deal with optimize_completion which will call iterator() on the expression for/in, which vectors do no have. *) if ctx.com.display && i = "iterator" && c.cl_path = (["flash"],"Vector") then begin let it = TAnon { a_fields = PMap.add "next" (mk_field "next" (TFun([],List.hd params)) p) PMap.empty; a_status = ref Closed; } in AKExpr (mk (TField (e,FDynamic i)) (TFun([],it)) p) end else no_field()) | TDynamic t -> (try using_field ctx mode e i p with Not_found -> AKExpr (mk (TField (e,FDynamic i)) t p)) | TAnon a -> (try let f = PMap.find i a.a_fields in if not f.cf_public && not ctx.untyped then begin match !(a.a_status) with | Closed -> () (* always allow anon private fields access *) | Statics c when can_access ctx c f true -> () | _ -> display_error ctx ("Cannot access private field " ^ i) p end; let fmode, ft = (match !(a.a_status) with | Statics c -> FStatic (c,f), field_type ctx c [] f p | EnumStatics e -> FEnum (e,try PMap.find f.cf_name e.e_constrs with Not_found -> assert false), Type.field_type f | _ -> match f.cf_params with | [] -> FAnon f, Type.field_type f | l -> (* handle possible constraints *) let monos = List.map (fun _ -> mk_mono()) l in let t = apply_params f.cf_params monos f.cf_type in add_constraint_checks ctx [] [] f monos p; FAnon f, t ) in field_access ctx mode f fmode ft e p with Not_found -> if is_closed a then try using_field ctx mode e i p with Not_found -> no_field() else let f = { cf_name = i; cf_type = mk_mono(); cf_doc = None; cf_meta = no_meta; cf_public = true; cf_pos = p; cf_kind = Var { v_read = AccNormal; v_write = (match mode with MSet -> AccNormal | MGet | MCall -> AccNo) }; cf_expr = None; cf_params = []; cf_overloads = []; } in a.a_fields <- PMap.add i f a.a_fields; field_access ctx mode f (FAnon f) (Type.field_type f) e p ) | TMono r -> if ctx.untyped && (match ctx.com.platform with Flash8 -> Common.defined ctx.com Define.SwfMark | _ -> false) then ctx.com.warning "Mark" p; let f = { cf_name = i; cf_type = mk_mono(); cf_doc = None; cf_meta = no_meta; cf_public = true; cf_pos = p; cf_kind = Var { v_read = AccNormal; v_write = (match mode with MSet -> AccNormal | MGet | MCall -> AccNo) }; cf_expr = None; cf_params = []; cf_overloads = []; } in let x = ref Opened in let t = TAnon { a_fields = PMap.add i f PMap.empty; a_status = x } in ctx.opened <- x :: ctx.opened; r := Some t; field_access ctx mode f (FAnon f) (Type.field_type f) e p | TAbstract (a,pl) -> (try let c = (match a.a_impl with None -> raise Not_found | Some c -> c) in let f = PMap.find i c.cl_statics in let field_type f = let t = field_type ctx c [] f p in apply_params a.a_types pl t in let et = type_module_type ctx (TClassDecl c) None p in let field_expr f t = mk (TField (et,FStatic (c,f))) t p in (match mode, f.cf_kind with | MGet, Var {v_read = AccCall } -> (* getter call *) let f = PMap.find ("get_" ^ f.cf_name) c.cl_statics in let t = field_type f in let r = match follow t with TFun(_,r) -> r | _ -> raise Not_found in let ef = field_expr f t in AKExpr(make_call ctx ef [e] r p) | MSet, Var {v_write = AccCall } -> let f = PMap.find ("set_" ^ f.cf_name) c.cl_statics in let t = field_type f in let ef = field_expr f t in AKUsing (ef,c,f,e) | MCall, Var {v_read = AccCall} -> error (i ^ " cannot be called") p | MGet, Var {v_read = AccNever} -> AKNo f.cf_name | MCall, _ -> let t = field_type f in begin match follow t with | TFun((_,_,t1) :: _,_) -> (match f.cf_kind with Method MethMacro -> () | _ -> unify ctx (apply_params a.a_types pl a.a_this) t1 p) | _ -> error (i ^ " cannot be called") p end; let ef = field_expr f t in AKUsing (ef,c,f,e) | MGet, _ -> let t = field_type f in let ef = field_expr f t in AKUsing (ef,c,f,e) | MSet, _ -> error "This operation is unsupported" p) with Not_found -> try using_field ctx mode e i p with Not_found -> try (match ctx.curfun, e.eexpr with | FunMemberAbstract, TConst (TThis) -> type_field ctx {e with etype = apply_params a.a_types pl a.a_this} i p mode; | _ -> raise Not_found) with Not_found -> no_field()) | _ -> try using_field ctx mode e i p with Not_found -> no_field() let type_bind ctx (e : texpr) params p = let args,ret = match follow e.etype with TFun(args, ret) -> args, ret | _ -> error "First parameter of callback is not a function" p in let vexpr v = mk (TLocal v) v.v_type p in let acount = ref 0 in let alloc_name n = if n = "" || String.length n > 2 then begin incr acount; "a" ^ string_of_int !acount; end else n in let rec loop args params given_args missing_args ordered_args = match args, params with | [], [] -> given_args,missing_args,ordered_args | [], _ -> error "Too many callback arguments" p | (n,o,t) :: args , [] when o -> let a = if is_pos_infos t then let infos = mk_infos ctx p [] in ordered_args @ [type_expr ctx infos (WithType t)] else if ctx.com.config.pf_pad_nulls then (ordered_args @ [(mk (TConst TNull) t_dynamic p)]) else ordered_args in loop args [] given_args missing_args a | (n,o,t) :: _ , (EConst(Ident "_"),p) :: _ when ctx.com.platform = Flash && o && not (is_nullable t) -> error "Usage of _ is currently not supported for optional non-nullable arguments on flash9" p | (n,o,t) :: args , ([] as params) | (n,o,t) :: args , (EConst(Ident "_"),_) :: params -> let v = alloc_var (alloc_name n) (if o then ctx.t.tnull t else t) in loop args params given_args (missing_args @ [v,o]) (ordered_args @ [vexpr v]) | (n,o,t) :: args , param :: params -> let e = type_expr ctx param (WithType t) in unify ctx e.etype t p; let v = alloc_var (alloc_name n) t in loop args params (given_args @ [v,o,Some e]) missing_args (ordered_args @ [vexpr v]) in let given_args,missing_args,ordered_args = loop args params [] [] [] in let rec gen_loc_name n = let name = if n = 0 then "f" else "f" ^ (string_of_int n) in if List.exists (fun (n,_,_) -> name = n) args then gen_loc_name (n + 1) else name in let loc = alloc_var (gen_loc_name 0) e.etype in let given_args = (loc,false,Some e) :: given_args in let inner_fun_args l = List.map (fun (v,o) -> v.v_name, o, v.v_type) l in let t_inner = TFun(inner_fun_args missing_args, ret) in let call = make_call ctx (vexpr loc) ordered_args ret p in let func = mk (TFunction { tf_args = List.map (fun (v,o) -> v, if o then Some TNull else None) missing_args; tf_type = ret; tf_expr = mk (TReturn (Some call)) ret p; }) t_inner p in let outer_fun_args l = List.map (fun (v,o,_) -> v.v_name, o, v.v_type) l in let func = mk (TFunction { tf_args = List.map (fun (v,_,_) -> v,None) given_args; tf_type = t_inner; tf_expr = mk (TReturn (Some func)) t_inner p; }) (TFun(outer_fun_args given_args, t_inner)) p in make_call ctx func (List.map (fun (_,_,e) -> (match e with Some e -> e | None -> assert false)) given_args) t_inner p (* We want to try unifying as an integer and apply side effects. However, in case the value is not a normal Monomorph but one issued from a Dynamic relaxation, we will instead unify with float since we don't want to accidentaly truncate the value *) let unify_int ctx e k = let is_dynamic t = match follow t with | TDynamic _ -> true | _ -> false in let is_dynamic_array t = match follow t with | TInst (_,[p]) -> is_dynamic p | _ -> true in let is_dynamic_field t f = match follow t with | TAnon a -> (try is_dynamic (PMap.find f a.a_fields).cf_type with Not_found -> false) | TInst (c,pl) -> (try is_dynamic (apply_params c.cl_types pl ((let _,t,_ = Type.class_field c f in t))) with Not_found -> false) | _ -> true in let is_dynamic_return t = match follow t with | TFun (_,r) -> is_dynamic r | _ -> true in (* This is some quick analysis that matches the most common cases of dynamic-to-mono convertions *) let rec maybe_dynamic_mono e = match e.eexpr with | TLocal _ -> is_dynamic e.etype | TArray({ etype = t } as e,_) -> is_dynamic_array t || maybe_dynamic_rec e t | TField({ etype = t } as e,f) -> is_dynamic_field t (field_name f) || maybe_dynamic_rec e t | TCall({ etype = t } as e,_) -> is_dynamic_return t || maybe_dynamic_rec e t | TParenthesis e -> maybe_dynamic_mono e | TIf (_,a,Some b) -> maybe_dynamic_mono a || maybe_dynamic_mono b | _ -> false and maybe_dynamic_rec e t = match follow t with | TMono _ | TDynamic _ -> maybe_dynamic_mono e (* we might have inferenced a tmono into a single field *) | TAnon a when !(a.a_status) = Opened -> maybe_dynamic_mono e | _ -> false in match k with | KUnk | KDyn when maybe_dynamic_mono e -> unify ctx e.etype ctx.t.tfloat e.epos; false | _ -> unify ctx e.etype ctx.t.tint e.epos; true let type_generic_function ctx (e,cf) el ?(using_param=None) p = if cf.cf_params = [] then error "Function has no type parameters and cannot be generic" p; let monos = List.map (fun _ -> mk_mono()) cf.cf_params in let c,stat = match follow e.etype with | (TInst (c,_)) -> c,false | (TAnon a) -> (match !(a.a_status) with Statics c -> c,true | _ -> assert false) | _ -> assert false in let t = apply_params cf.cf_params monos cf.cf_type in add_constraint_checks ctx c.cl_types [] cf monos p; let args,ret = match t,using_param with | TFun((_,_,ta) :: args,ret),Some e -> (* manually unify first argument *) unify ctx e.etype ta p; args,ret | TFun(args,ret),None -> args,ret | _ -> error "Invalid field type for generic call" p in let el,_ = unify_call_params ctx None el args ret p false in let el = match using_param with None -> el | Some e -> e :: el in (try let gctx = Codegen.make_generic ctx cf.cf_params monos p in let name = cf.cf_name ^ "_" ^ gctx.Codegen.name in let cf2 = try let cf2 = PMap.find name (if stat then c.cl_statics else c.cl_fields) in unify ctx cf2.cf_type t cf2.cf_pos; cf2 with Not_found -> let cf2 = mk_field name t cf.cf_pos in if stat then begin c.cl_statics <- PMap.add name cf2 c.cl_statics; c.cl_ordered_statics <- cf2 :: c.cl_ordered_statics end else begin c.cl_fields <- PMap.add name cf2 c.cl_fields; c.cl_ordered_fields <- cf2 :: c.cl_ordered_fields end; ignore(follow cf.cf_type); cf2.cf_expr <- (match cf.cf_expr with | None -> None | Some e -> Some (Codegen.generic_substitute_expr gctx e)); cf2.cf_kind <- cf.cf_kind; cf2.cf_public <- cf.cf_public; let metadata = List.filter (fun (m,_,_) -> match m with | Meta.Generic -> false | _ -> true ) cf.cf_meta in cf2.cf_meta <- (Meta.NoCompletion,[],p) :: (Meta.NoUsing,[],p) :: metadata; cf2 in let e = if stat then type_type ctx c.cl_path p else e in let e = acc_get ctx (field_access ctx MCall cf2 (if stat then FStatic (c,cf2) else FInstance (c,cf2)) cf2.cf_type e p) p in (el,ret,e) with Codegen.Generic_Exception (msg,p) -> error msg p) let call_to_string ctx c e = let et = type_module_type ctx (TClassDecl c) None e.epos in let cf = PMap.find "toString" c.cl_statics in make_call ctx (mk (TField(et,FStatic(c,cf))) cf.cf_type e.epos) [e] ctx.t.tstring e.epos let rec type_binop ctx op e1 e2 is_assign_op p = match op with | OpAssign -> let e1 = type_access ctx (fst e1) (snd e1) MSet in let tt = (match e1 with AKNo _ | AKInline _ | AKUsing _ | AKMacro _ | AKAccess _ -> Value | AKSet(_,t,_) -> WithType t | AKExpr e -> WithType e.etype) in let e2 = type_expr ctx e2 tt in (match e1 with | AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p | AKExpr e1 -> unify ctx e2.etype e1.etype p; check_assign ctx e1; (match e1.eexpr , e2.eexpr with | TLocal i1 , TLocal i2 when i1 == i2 -> error "Assigning a value to itself" p | TField ({ eexpr = TConst TThis },FInstance (_,f1)) , TField ({ eexpr = TConst TThis },FInstance (_,f2)) when f1 == f2 -> error "Assigning a value to itself" p | _ , _ -> ()); mk (TBinop (op,e1,e2)) e1.etype p | AKSet (e,t,cf) -> unify ctx e2.etype t p; make_call ctx (mk (TField (e,quick_field_dynamic e.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [e2] t p | AKAccess(ebase,ekey) -> let a,pl,c = match follow ebase.etype with TAbstract({a_impl = Some c} as a,pl) -> a,pl,c | _ -> error "Invalid operation" p in let cf,tf,r = try find_array_access a pl c ekey.etype e2.etype true with Not_found -> error ("No @:arrayAccess function accepts arguments of " ^ (s_type (print_context()) ekey.etype) ^ " and " ^ (s_type (print_context()) e2.etype)) p in let et = type_module_type ctx (TClassDecl c) None p in let ef = mk (TField(et,(FStatic(c,cf)))) tf p in make_call ctx ef [ebase;ekey;e2] r p | AKUsing(ef,_,_,et) -> (* this must be an abstract setter *) let ret = match follow ef.etype with | TFun([_;(_,_,t)],ret) -> unify ctx e2.etype t p; ret | _ -> error "Invalid field type for abstract setter" p in make_call ctx ef [et;e2] ret p | AKInline _ | AKMacro _ -> assert false) | OpAssignOp op -> (match type_access ctx (fst e1) (snd e1) MSet with | AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p | AKExpr e -> let eop = type_binop ctx op e1 e2 true p in (match eop.eexpr with | TBinop (_,_,e2) -> unify ctx eop.etype e.etype p; check_assign ctx e; mk (TBinop (OpAssignOp op,e,e2)) e.etype p; | TField(e2,FDynamic ":needsAssign") -> unify ctx e2.etype e.etype p; check_assign ctx e; mk (TBinop (OpAssign,e,e2)) e.etype p; | _ -> (* this must be an abstract cast *) check_assign ctx e; eop) | AKSet (e,t,cf) -> let l = save_locals ctx in let v = gen_local ctx e.etype in let ev = mk (TLocal v) e.etype p in let get = type_binop ctx op (EField ((EConst (Ident v.v_name),p),cf.cf_name),p) e2 true p in unify ctx get.etype t p; l(); mk (TBlock [ mk (TVars [v,Some e]) ctx.t.tvoid p; make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [get] t p ]) t p | AKUsing(ef,c,cf,et) -> (* abstract setter + getter *) let ta = match c.cl_kind with KAbstractImpl a -> TAbstract(a, List.map (fun _ -> mk_mono()) a.a_types) | _ -> assert false in let ret = match follow ef.etype with | TFun([_;_],ret) -> ret | _ -> error "Invalid field type for abstract setter" p in let l = save_locals ctx in let v = gen_local ctx ta in let ev = mk (TLocal v) ta p in (* this relies on the fact that cf_name is set_name *) let getter_name = String.sub cf.cf_name 4 (String.length cf.cf_name - 4) in let get = type_binop ctx op (EField ((EConst (Ident v.v_name),p),getter_name),p) e2 true p in unify ctx get.etype ret p; l(); mk (TBlock [ mk (TVars [v,Some et]) ctx.t.tvoid p; make_call ctx ef [ev;get] ret p ]) ret p | AKAccess(ebase,ekey) -> let a,pl,c = match follow ebase.etype with TAbstract({a_impl = Some c} as a,pl) -> a,pl,c | _ -> error "Invalid operation" p in let et = type_module_type ctx (TClassDecl c) None p in let cf_get,tf_get,r_get = try find_array_access a pl c ekey.etype t_dynamic false with Not_found -> error ("No @:arrayAccess function accepts an argument of " ^ (s_type (print_context()) ekey.etype)) p in (* bind complex keys to a variable so they do not make it into the output twice *) let ekey,l = match Optimizer.make_constant_expression ctx ekey with | Some e -> e, fun () -> None | None -> let save = save_locals ctx in let v = gen_local ctx ekey.etype in let e = mk (TLocal v) ekey.etype p in e, fun () -> (save(); Some (mk (TVars [v,Some ekey]) ctx.t.tvoid p)) in let ast_call = ECall((EField(Interp.make_ast ebase,cf_get.cf_name),p),[Interp.make_ast ekey]),p in let eget = type_binop ctx op ast_call e2 true p in unify ctx eget.etype r_get p; let cf_set,tf_set,r_set = try find_array_access a pl c ekey.etype eget.etype true with Not_found -> error ("No @:arrayAccess function accepts arguments of " ^ (s_type (print_context()) ekey.etype) ^ " and " ^ (s_type (print_context()) eget.etype)) p in let ef_set = mk (TField(et,(FStatic(c,cf_set)))) tf_set p in (match l() with | None -> make_call ctx ef_set [ebase;ekey;eget] r_set p | Some e -> mk (TBlock [ e; make_call ctx ef_set [ebase;ekey;eget] r_set p ]) r_set p) | AKInline _ | AKMacro _ -> assert false) | _ -> let e1 = type_expr ctx e1 Value in let e2 = type_expr ctx e2 (if op == OpEq || op == OpNotEq then WithType e1.etype else Value) in let tint = ctx.t.tint in let tfloat = ctx.t.tfloat in let tstring = ctx.t.tstring in let to_string e = match classify e.etype with | KAbstract {a_impl = Some c} when PMap.mem "toString" c.cl_statics -> call_to_string ctx c e | KUnk | KDyn | KParam _ | KOther | KAbstract _ -> let std = type_type ctx ([],"Std") e.epos in let acc = acc_get ctx (type_field ctx std "string" e.epos MCall) e.epos in ignore(follow acc.etype); let acc = (match acc.eexpr with TField (e,FClosure (Some c,f)) -> { acc with eexpr = TField (e,FInstance (c,f)) } | _ -> acc) in make_call ctx acc [e] ctx.t.tstring e.epos | KInt | KFloat | KString -> e in let mk_op t = if op = OpAdd && (classify t) = KString then let e1 = to_string e1 in let e2 = to_string e2 in mk (TBinop (op,e1,e2)) t p else mk (TBinop (op,e1,e2)) t p in let make e1 e2 = match op with | OpAdd -> mk_op (match classify e1.etype, classify e2.etype with | KInt , KInt -> tint | KFloat , KInt | KInt, KFloat | KFloat, KFloat -> tfloat | KUnk , KInt -> 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 tint else tfloat | KFloat , KUnk | KString , KUnk -> unify ctx e2.etype e1.etype e2.epos; e2.etype | _ , KString | KString , _ -> tstring | _ , KDyn -> e2.etype | KDyn , _ -> e1.etype | KUnk , KUnk -> let ok1 = unify_int ctx e1 KUnk in let ok2 = unify_int ctx e2 KUnk in if ok1 && ok2 then tint else tfloat | KParam t1, KParam t2 when Type.type_iseq t1 t2 -> t1 | KParam t, KInt | KInt, KParam t -> t | KParam _, KFloat | KFloat, KParam _ | KParam _, KParam _ -> tfloat | KParam t, KUnk -> unify ctx e2.etype tfloat e2.epos; tfloat | KUnk, KParam t -> unify ctx e1.etype tfloat e1.epos; tfloat | KAbstract _,_ | _,KAbstract _ | KParam _, _ | _, KParam _ | KOther, _ | _ , KOther -> let pr = print_context() in error ("Cannot add " ^ s_type pr e1.etype ^ " and " ^ s_type pr e2.etype) p ) | OpAnd | OpOr | OpXor | OpShl | OpShr | OpUShr -> let i = tint in unify ctx e1.etype i e1.epos; unify ctx e2.etype i e2.epos; mk_op i | OpMod | OpMult | OpDiv | OpSub -> let result = ref (if op = OpDiv then tfloat else tint) in (match classify e1.etype, classify e2.etype with | KFloat, KFloat -> result := tfloat | KParam t1, KParam t2 when Type.type_iseq t1 t2 -> if op <> OpDiv then result := t1 | KParam _, KParam _ -> result := tfloat | KParam t, KInt | KInt, KParam t -> if op <> OpDiv then result := t | KParam _, KFloat | KFloat, KParam _ -> result := tfloat | KFloat, k -> ignore(unify_int ctx e2 k); result := tfloat | k, KFloat -> ignore(unify_int ctx e1 k); 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 := tfloat; ); mk_op !result | OpEq | OpNotEq -> (try unify_raise ctx e1.etype e2.etype p; (* we only have to check one type here, because unification fails if one is Void and the other is not *) (match follow e2.etype with TAbstract({a_path=[],"Void"},_) -> error "Cannot compare Void" p | _ -> ()) with Error (Unify _,_) -> unify ctx e2.etype e1.etype p); mk_op ctx.t.tbool | OpGt | OpGte | OpLt | OpLte -> (match classify e1.etype, classify e2.etype with | KInt , KInt | KInt , KFloat | KFloat , KInt | KFloat , KFloat | KString , KString -> () | KInt , KUnk -> ignore(unify_int ctx e2 KUnk) | KFloat , KUnk | KString , KUnk -> unify ctx e2.etype e1.etype e2.epos | KUnk , KInt -> ignore(unify_int ctx e1 KUnk) | KUnk , KFloat | KUnk , KString -> unify ctx e1.etype e2.etype e1.epos | KUnk , KUnk -> ignore(unify_int ctx e1 KUnk); ignore(unify_int ctx e2 KUnk); | KDyn , KInt | KDyn , KFloat | KDyn , KString -> () | KInt , KDyn | KFloat , KDyn | KString , KDyn -> () | KDyn , KDyn -> () | KParam _ , x | x , KParam _ when x <> KString && x <> KOther -> () | KAbstract _,_ | _,KAbstract _ | KDyn , KUnk | KUnk , KDyn | KString , KInt | KString , KFloat | KInt , KString | KFloat , KString | KParam _ , _ | _ , KParam _ | KOther , _ | _ , KOther -> let pr = print_context() in error ("Cannot compare " ^ s_type pr e1.etype ^ " and " ^ s_type pr e2.etype) p ); mk_op ctx.t.tbool | OpBoolAnd | OpBoolOr -> let b = ctx.t.tbool in unify ctx e1.etype b p; unify ctx e2.etype b p; mk_op b | OpInterval -> let t = Typeload.load_core_type ctx "IntIterator" in 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 | OpArrow -> error "Unexpected =>" p | OpAssign | OpAssignOp _ -> assert false in let find_overload a pl c t left = let rec loop ops = match ops with | [] -> raise Not_found | (o,cf) :: ops when is_assign_op && o = OpAssignOp(op) || o == op -> (match follow (monomorphs cf.cf_params cf.cf_type) with | TFun([(_,_,t1);(_,_,t2)],r) -> let t1,t2 = if left || Meta.has Meta.Commutative cf.cf_meta then t1,t2 else t2,t1 in if type_iseq t t2 && (if Meta.has Meta.Impl cf.cf_meta then type_iseq (apply_params a.a_types pl a.a_this) t1 else type_iseq (TAbstract(a,pl)) t1) then begin if not (can_access ctx c cf true) then display_error ctx ("Cannot access operator function " ^ (s_type_path a.a_path) ^ "." ^ cf.cf_name) p; cf,r,o = OpAssignOp(op),Meta.has Meta.Commutative cf.cf_meta end else loop ops | _ -> loop ops) | _ :: ops -> loop ops in loop a.a_ops in let mk_cast_op c f a pl e1 e2 r assign = let t = field_type ctx c [] f p in let t = apply_params a.a_types pl t in let et = type_module_type ctx (TClassDecl c) None p in let ef = mk (TField (et,FStatic (c,f))) t p in let ec = make_call ctx ef [e1;e2] r p in (* obviously a hack to report back that we need an assignment *) if is_assign_op && not assign then mk (TField(ec,FDynamic ":needsAssign")) t_dynamic p else ec in let cast_rec e1t e2t r = let e = make e1t e2t in begin try unify_raise ctx e.etype r p with Error (Unify _,_) -> error ("The result of this operation (" ^ (s_type (print_context()) e.etype) ^ ") is not compatible with declared return type " ^ (s_type (print_context()) r)) p; end; {e with etype = r} in try (match follow e1.etype with | TAbstract ({a_impl = Some c} as a,pl) -> let f,r,assign,commutative = find_overload a pl c e2.etype true in begin match f.cf_expr with | None -> let e2 = match follow e2.etype with TAbstract(a,pl) -> {e2 with etype = apply_params a.a_types pl a.a_this} | _ -> e2 in cast_rec {e1 with etype = apply_params a.a_types pl a.a_this} e2 r | Some _ -> mk_cast_op c f a pl e1 e2 r assign end | _ -> raise Not_found) with Not_found -> try (match follow e2.etype with | TAbstract ({a_impl = Some c} as a,pl) -> let f,r,assign,commutative = find_overload a pl c e1.etype false in begin match f.cf_expr with | None -> let e1 = match follow e1.etype with TAbstract(a,pl) -> {e1 with etype = apply_params a.a_types pl a.a_this} | _ -> e1 in let e1,e2 = if commutative then e2,e1 else e1,e2 in cast_rec e1 {e2 with etype = apply_params a.a_types pl a.a_this} r | Some _ -> let e1,e2 = if commutative then e2,e1 else e1,e2 in mk_cast_op c f a pl e1 e2 r assign end | _ -> raise Not_found) with Not_found -> make e1 e2 and type_unop ctx op flag e p = let set = (op = Increment || op = Decrement) in let acc = type_access ctx (fst e) (snd e) (if set then MSet else MGet) in let access e = let make e = let t = (match op with | Not -> 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.t.tfloat | KParam t -> unify ctx e.etype ctx.t.tfloat e.epos; t | k -> if unify_int ctx e k then ctx.t.tint else ctx.t.tfloat) ) in mk (TUnop (op,flag,e)) t p in try (match follow e.etype with | TAbstract ({a_impl = Some c} as a,pl) -> let rec loop opl = match opl with | [] -> raise Not_found | (op2,flag2,cf) :: opl when op == op2 && flag == flag2 -> let m = mk_mono() in let tcf = apply_params c.cl_types pl (monomorphs cf.cf_params cf.cf_type) in if Meta.has Meta.Impl cf.cf_meta then begin if type_iseq (tfun [apply_params a.a_types pl a.a_this] m) tcf then cf,tcf,m else loop opl end else if type_iseq (tfun [e.etype] m) tcf then cf,tcf,m else loop opl | _ :: opl -> loop opl in let cf,t,r = loop a.a_unops in if not (can_access ctx c cf true) then error ("Cannot access " ^ cf.cf_name) p; (match cf.cf_expr with | None -> let e = make {e with etype = apply_params a.a_types pl a.a_this} in unify ctx r e.etype p; {e with etype = r} | Some _ -> let et = type_module_type ctx (TClassDecl c) None p in let ef = mk (TField (et,FStatic (c,cf))) t p in make_call ctx ef [e] r p) | _ -> raise Not_found ) with Not_found -> make e in match acc with | AKExpr e -> access e | AKInline _ | AKUsing _ when not set -> access (acc_get ctx acc p) | AKNo s -> error ("The field or identifier " ^ s ^ " is not accessible for " ^ (if set then "writing" else "reading")) p | AKInline _ | AKUsing _ | AKMacro _ | AKAccess _ -> error "This kind of operation is not supported" p | AKSet (e,t,cf) -> let l = save_locals ctx in let v = gen_local ctx e.etype in let ev = mk (TLocal v) e.etype p in let op = (match op with Increment -> OpAdd | Decrement -> OpSub | _ -> assert false) in let one = (EConst (Int "1"),p) in let eget = (EField ((EConst (Ident v.v_name),p),cf.cf_name),p) in match flag with | Prefix -> let get = type_binop ctx op eget one false p in unify ctx get.etype t p; l(); mk (TBlock [ mk (TVars [v,Some e]) ctx.t.tvoid p; make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [t] t) p) [get] t p ]) t p | Postfix -> let v2 = gen_local ctx t in let ev2 = mk (TLocal v2) t p in let get = type_expr ctx eget Value in let plusone = type_binop ctx op (EConst (Ident v2.v_name),p) one false p in unify ctx get.etype t p; l(); mk (TBlock [ mk (TVars [v,Some e; v2,Some get]) ctx.t.tvoid p; make_call ctx (mk (TField (ev,quick_field_dynamic ev.etype ("set_" ^ cf.cf_name))) (tfun [plusone.etype] t) p) [plusone] t p; ev2 ]) t p and type_switch_old ctx e cases def with_type p = let eval = type_expr ctx e Value in let old_m = ctx.m in let enum = ref None in let used_cases = Hashtbl.create 0 in let is_fake_enum e = e.e_path = ([],"Bool") || Meta.has Meta.FakeEnum e.e_meta in (match follow eval.etype with | TEnum (e,_) when is_fake_enum e -> () | TEnum (e,params) -> enum := Some (Some (e,params)); (* hack to prioritize enum lookup *) ctx.m <- { ctx.m with module_types = TEnumDecl e :: ctx.m.module_types } | TMono _ -> enum := Some None; | t -> if t == t_dynamic then enum := Some None ); let case_expr c = enum := None; (* this inversion is needed *) unify ctx eval.etype c.etype c.epos; CExpr c in let type_match e en s pl = let p = e.epos in let params = (match !enum with | None -> assert false | Some None when is_fake_enum en -> raise Exit | Some None -> let params = List.map (fun _ -> mk_mono()) en.e_types in enum := Some (Some (en,params)); unify ctx eval.etype (TEnum (en,params)) p; params | Some (Some (en2,params)) -> if en != en2 then error ("This constructor is part of enum " ^ s_type_path en.e_path ^ " but is matched with enum " ^ s_type_path en2.e_path) p; params ) in if Hashtbl.mem used_cases s then error "This constructor has already been used" p; Hashtbl.add used_cases s (); let cst = (try PMap.find s en.e_constrs with Not_found -> assert false) in let et = apply_params en.e_types params (monomorphs cst.ef_params cst.ef_type) in let pl, rt = (match et with | TFun (l,rt) -> let pl = (if List.length l = List.length pl then pl else match pl with | [None] -> List.map (fun _ -> None) l | _ -> error ("This constructor requires " ^ string_of_int (List.length l) ^ " arguments") p ) in Some (List.map2 (fun p (_,_,t) -> match p with None -> None | Some p -> Some (p, t)) pl l), rt | TEnum _ -> if pl <> [] then error "This constructor does not require any argument" p; None, et | _ -> assert false ) in unify ctx rt eval.etype p; CMatch (cst,pl,p) in let type_case efull e pl p = try let e = (match !enum, e with | None, _ -> raise Exit | Some (Some (en,params)), (EConst (Ident i),p) -> let ef = (try PMap.find i en.e_constrs with Not_found -> display_error ctx ("This constructor is not part of the enum " ^ s_type_path en.e_path) p; raise Exit ) in mk (fast_enum_field en ef p) (apply_params en.e_types params ef.ef_type) (snd e) | _ -> type_expr ctx e Value ) in let pl = List.map (fun e -> match fst e with | EConst (Ident "_") -> None | EConst (Ident i) -> Some i | _ -> raise Exit ) pl in (match e.eexpr with | TField (_,FEnum (en,c)) -> type_match e en c.ef_name pl | _ -> if pl = [] then case_expr e else raise Exit) with Exit -> case_expr (type_expr ctx efull Value) in let cases = List.map (fun (el,eg,e2) -> if el = [] then error "Case must match at least one expression" (punion_el el); let el = List.map (fun e -> match e with | (ECall (c,pl),p) -> type_case e c pl p | e -> type_case e e [] (snd e) ) el in el, e2 ) cases in ctx.m <- old_m; let el = ref [] in let type_case_code e = let e = (match e with | Some e -> type_expr ctx e with_type | None -> mk (TBlock []) ctx.com.basic.tvoid Ast.null_pos ) in el := e :: !el; e in let def() = (match def with | None -> None | Some e -> let locals = save_locals ctx in let e = type_case_code e in locals(); Some e ) in match !enum with | Some (Some (enum,enparams)) -> let same_params p1 p2 = let l1 = (match p1 with None -> [] | Some l -> l) in let l2 = (match p2 with None -> [] | Some l -> l) in let rec loop = function | [] , [] -> true | None :: l , [] | [] , None :: l -> loop (l,[]) | None :: l1, None :: l2 -> loop (l1,l2) | Some (n1,t1) :: l1, Some (n2,t2) :: l2 -> n1 = n2 && type_iseq t1 t2 && loop (l1,l2) | _ -> false in loop (l1,l2) in let matchs (el,e) = match el with | CMatch (c,params,p1) :: l -> let params = ref params in let cl = List.map (fun c -> match c with | CMatch (c,p,p2) -> if not (same_params p !params) then display_error ctx "Constructors parameters differs : should be same name, same type, and same position" p2; if p <> None then params := p; c | _ -> assert false ) l in let locals = save_locals ctx in let params = (match !params with | None -> None | Some l -> let has = ref false in let l = List.map (fun v -> match v with | None -> None | Some (v,t) -> has := true; Some (add_local ctx v t) ) l in if !has then Some l else None ) in let e = type_case_code e in locals(); (c :: cl) , params, e | _ -> assert false in let indexes (el,vars,e) = List.map (fun c -> c.ef_index) el, vars, e in let cases = List.map matchs cases in let def = def() in (match def with | Some _ -> () | None -> let tenum = TEnum(enum,enparams) in let l = PMap.fold (fun c acc -> let t = monomorphs enum.e_types (monomorphs c.ef_params (match c.ef_type with TFun (_,t) -> t | t -> t)) in if Hashtbl.mem used_cases c.ef_name || not (try unify_raise ctx t tenum c.ef_pos; true with Error (Unify _,_) -> false) then acc else c.ef_name :: acc ) enum.e_constrs [] in match l with | [] -> () | _ -> display_error ctx ("Some constructors are not matched : " ^ String.concat "," l) p ); let t = if with_type = NoValue then (mk_mono()) else unify_min ctx (List.rev !el) in mk (TMatch (eval,(enum,enparams),List.map indexes cases,def)) t p | _ -> let consts = Hashtbl.create 0 in let exprs (el,e) = let el = List.map (fun c -> match c with | CExpr (({ eexpr = TConst c }) as e) -> if Hashtbl.mem consts c then error "Duplicate constant in switch" e.epos; Hashtbl.add consts c true; e | CExpr c -> c | CMatch (_,_,p) -> error "You cannot use a normal switch on an enum constructor" p ) el in let locals = save_locals ctx in let e = type_case_code e in locals(); el, e in let cases = List.map exprs cases in let def = def() in let t = if with_type = NoValue then (mk_mono()) else unify_min ctx (List.rev !el) in mk (TSwitch (eval,cases,def)) t p and type_switch ctx e cases def (with_type:with_type) p = try if (Common.defined ctx.com Common.Define.NoPatternMatching) then raise Exit; match_expr ctx e cases def with_type p with Exit -> type_switch_old ctx e cases def with_type p and type_ident ctx i p mode = try type_ident_raise ctx i p mode with Not_found -> try (* lookup type *) if is_lower_ident i then raise Not_found; let e = (try type_type ctx ([],i) p with Error (Module_not_found ([],name),_) when name = i -> raise Not_found) in AKExpr e with Not_found -> if ctx.untyped then begin if i = "__this__" then AKExpr (mk (TConst TThis) ctx.tthis p) else let t = mk_mono() in AKExpr (mk (TLocal (alloc_var i t)) t p) end else begin if ctx.curfun = FunStatic && PMap.mem i ctx.curclass.cl_fields then error ("Cannot access " ^ i ^ " in static function") p; let err = Unknown_ident i in if ctx.in_display then raise (Error (err,p)); if ctx.com.display then begin display_error ctx (error_msg err) p; let t = mk_mono() in AKExpr (mk (TLocal (add_local ctx i t)) t p) end else begin if List.exists (fun (i2,_) -> i2 = i) ctx.type_params then display_error ctx ("Type parameter " ^ i ^ " is only available at compilation and is not a runtime value") p else display_error ctx (error_msg err) p; AKExpr (mk (TConst TNull) t_dynamic p) end end and type_access ctx e p mode = match e with | EConst (Ident s) -> type_ident ctx s p mode | EField _ -> let fields path e = List.fold_left (fun e (f,_,p) -> let e = acc_get ctx (e MGet) p in type_field ctx e f p ) e path in let type_path path = let rec loop acc path = match path with | [] -> (match List.rev acc with | [] -> assert false | (name,flag,p) :: path -> try fields path (type_access ctx (EConst (Ident name)) p) with Error (Unknown_ident _,p2) as e when p = p2 -> try let path = ref [] in let name , _ , _ = List.find (fun (name,flag,p) -> if flag then true else begin path := name :: !path; false end ) (List.rev acc) in raise (Error (Module_not_found (List.rev !path,name),p)) with Not_found -> if ctx.in_display then raise (Parser.TypePath (List.map (fun (n,_,_) -> n) (List.rev acc),None)); raise e) | (_,false,_) as x :: path -> loop (x :: acc) path | (name,true,p) as x :: path -> let pack = List.rev_map (fun (x,_,_) -> x) acc in let def() = try let e = type_type ctx (pack,name) p in fields path (fun _ -> AKExpr e) with Error (Module_not_found m,_) when m = (pack,name) -> loop ((List.rev path) @ x :: acc) [] in match path with | (sname,true,p) :: path -> let get_static t = fields ((sname,true,p) :: path) (fun _ -> AKExpr (type_module_type ctx t None p)) in let check_module m v = try let md = Typeload.load_module ctx m p in (* first look for existing subtype *) (try let t = List.find (fun t -> not (t_infos t).mt_private && t_path t = (fst m,sname)) md.m_types in Some (fields path (fun _ -> AKExpr (type_module_type ctx t None p))) with Not_found -> try (* then look for main type statics *) if fst m = [] then raise Not_found; (* ensure that we use def() to resolve local types first *) let t = List.find (fun t -> not (t_infos t).mt_private && t_path t = m) md.m_types in Some (get_static t) with Not_found -> None) with Error (Module_not_found m2,_) when m = m2 -> None in let rec loop pack = match check_module (pack,name) sname with | Some r -> r | None -> match List.rev pack with | [] -> def() | _ :: l -> loop (List.rev l) in (match pack with | [] -> (try let t = List.find (fun t -> snd (t_infos t).mt_path = name) (ctx.m.curmod.m_types @ ctx.m.module_types) in get_static t with Not_found -> loop (fst ctx.m.curmod.m_path)) | _ -> match check_module (pack,name) sname with | Some r -> r | None -> def()); | _ -> def() in match path with | [] -> assert false | (name,_,p) :: pnext -> try fields pnext (fun _ -> type_ident_raise ctx name p MGet) with Not_found -> loop [] path in let rec loop acc e = match fst e with | EField (e,s) -> loop ((s,not (is_lower_ident s),p) :: acc) e | EConst (Ident i) -> type_path ((i,not (is_lower_ident i),p) :: acc) | _ -> fields acc (type_access ctx (fst e) (snd e)) in loop [] (e,p) mode | EArray (e1,e2) -> let e1 = type_expr ctx e1 Value in let e2 = type_expr ctx e2 Value in (try (match follow e1.etype with | TAbstract ({a_impl = Some c} as a,pl) when a.a_array <> [] -> (match mode with | MSet -> (* resolve later *) AKAccess (e1, e2) | _ -> let cf,tf,r = find_array_access a pl c e2.etype t_dynamic false in let et = type_module_type ctx (TClassDecl c) None p in let ef = mk (TField(et,(FStatic(c,cf)))) tf p in AKExpr (make_call ctx ef [e1;e2] r p)) | _ -> raise Not_found) with Not_found -> 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) -> apply_params pl tl t | TInst ({ cl_super = Some (c,stl); cl_types = pl },tl) -> apply_params pl tl (loop (TInst (c,stl))) | TInst ({ cl_path = [],"ArrayAccess" },[t]) -> t | TAbstract(a,tl) when Meta.has Meta.ArrayAccess a.a_meta -> loop (apply_params a.a_types tl a.a_this) | _ -> let pt = mk_mono() in let t = ctx.t.tarray pt in (try unify_raise ctx et t p with Error(Unify _,_) -> if not ctx.untyped then error ("Array access is not allowed on " ^ (s_type (print_context()) e1.etype)) e1.epos); pt in let pt = loop e1.etype in AKExpr (mk (TArray (e1,e2)) pt p)) | _ -> AKExpr (type_expr ctx (e,p) Value) and type_vars ctx vl p in_block = let save = if in_block then (fun() -> ()) else save_locals ctx in let vl = List.map (fun (v,t,e) -> try let t = Typeload.load_type_opt ctx p t in let e = (match e with | None -> None | Some e -> let e = type_expr ctx e (WithType t) in unify ctx e.etype t p; Some e ) in if v.[0] = '$' && not ctx.com.display then error "Variables names starting with a dollar are not allowed" p; add_local ctx v t, e with Error (e,p) -> display_error ctx (error_msg e) p; add_local ctx v t_dynamic, None ) vl in save(); mk (TVars vl) ctx.t.tvoid p and with_type_error ctx with_type msg p = match with_type with | WithTypeResume _ -> raise (WithTypeError ([Unify_custom msg],p)) | _ -> display_error ctx msg p and type_expr ctx (e,p) (with_type:with_type) = 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.t.tint p | EField(_,n) when n.[0] = '$' -> error "Field names starting with $ are not allowed" p | EConst (Ident s) -> (try acc_get ctx (type_ident_raise ~imported_enums:false ctx s p MGet) p with Not_found -> try (match with_type with | WithType t | WithTypeResume t -> (match follow t with | TEnum (e,pl) -> (try let ef = PMap.find s e.e_constrs in mk (fast_enum_field e ef p) (apply_params e.e_types pl (monomorphs ef.ef_params ef.ef_type)) p with Not_found -> if ctx.untyped then raise Not_found; with_type_error ctx with_type (string_error s e.e_names ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path e.e_path)) p; mk (TConst TNull) t p) | _ -> raise Not_found) | _ -> raise Not_found) with Not_found -> acc_get ctx (type_access ctx e p MGet) p) | EField _ | EArray _ -> acc_get ctx (type_access ctx e p MGet) p | EConst (Regexp (r,opt)) -> 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 (String s) when Lexer.is_fmt_string p -> let e = ref None in let pmin = ref p.pmin in let min = ref (p.pmin + 1) in let add enext len = let p = { p with pmin = !min; pmax = !min + len } in min := !min + len; match !e with | None -> e := Some (enext,p) | Some prev -> e := Some (EBinop (OpAdd,prev,(enext,p)),punion (pos prev) p) in let add_sub start pos = let len = pos - start in if len > 0 || !e = None then add (EConst (String (String.sub s start len))) len in let warn_escape = Common.defined ctx.com Define.FormatWarning in let warn pos len = ctx.com.warning "This string is formated" { p with pmin = !pmin + 1 + pos; pmax = !pmin + 1 + pos + len } in let len = String.length s in let rec parse start pos = if pos = len then add_sub start pos else let c = String.unsafe_get s pos in let pos = pos + 1 in if c = '\'' then begin incr pmin; incr min; end; if c <> '$' || pos = len then parse start pos else match String.unsafe_get s pos with | '$' -> if warn_escape then warn pos 1; (* double $ *) add_sub start pos; parse (pos + 1) (pos + 1) | '{' -> parse_group start pos '{' '}' "brace" | 'a'..'z' | 'A'..'Z' | '_' -> add_sub start (pos - 1); incr min; let rec loop i = if i = len then i else let c = String.unsafe_get s i in match c with | 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' -> loop (i+1) | _ -> i in let iend = loop (pos + 1) in let len = iend - pos in if warn_escape then warn pos len; add (EConst (Ident (String.sub s pos len))) len; parse (pos + len) (pos + len) | _ -> (* keep as-it *) parse start pos and parse_group start pos gopen gclose gname = add_sub start (pos - 1); let rec loop groups i = if i = len then match groups with | [] -> assert false | g :: _ -> error ("Unclosed " ^ gname) { p with pmin = !pmin + g + 1; pmax = !pmin + g + 2 } else let c = String.unsafe_get s i in if c = gopen then loop (i :: groups) (i + 1) else if c = gclose then begin let groups = List.tl groups in if groups = [] then i else loop groups (i + 1) end else loop groups (i + 1) in let send = loop [pos] (pos + 1) in let slen = send - pos - 1 in let scode = String.sub s (pos + 1) slen in if warn_escape then warn (pos + 1) slen; min := !min + 2; add (fst (parse_expr_string ctx scode { p with pmin = !pmin + pos + 2; pmax = !pmin + send + 1 } true)) slen; min := !min + 1; parse (send + 1) (send + 1) in parse 0 0; (match !e with | None -> assert false | Some e -> type_expr ctx e with_type); | EConst c -> Codegen.type_constant ctx.com c p | EBinop (op,e1,e2) -> type_binop ctx op e1 e2 false p | EBlock [] when with_type <> NoValue -> type_expr ctx (EObjectDecl [],p) with_type | EBlock l -> let locals = save_locals ctx in let rec loop = function | [] -> [] | (EVars vl,p) :: l -> let e = type_vars ctx vl p true in e :: loop l | [e] -> (try [type_expr ctx e with_type] with Error (e,p) -> display_error ctx (error_msg e) p; []) | e :: l -> try let e = type_expr ctx e NoValue in e :: loop l with Error (e,p) -> display_error ctx (error_msg e) p; loop l in let l = loop l in locals(); let rec loop = function | [] -> ctx.t.tvoid | [e] -> e.etype | _ :: l -> loop l in mk (TBlock l) (loop l) p | EParenthesis e -> let e = type_expr ctx e with_type in mk (TParenthesis e) e.etype p | EObjectDecl fl -> let a = (match with_type with | WithType t | WithTypeResume t -> (match follow t with | TAnon a when not (PMap.is_empty a.a_fields) -> Some a | _ -> None) | _ -> None ) in (match a with | None -> let rec loop (l,acc) (f,e) = let f,add = object_field f in if PMap.mem f acc then error ("Duplicate field in object declaration : " ^ f) p; let e = type_expr ctx e Value in (match follow e.etype with TAbstract({a_path=[],"Void"},_) -> error "Fields of type Void are not allowed in structures" e.epos | _ -> ()); let cf = mk_field f e.etype e.epos in ((f,e) :: l, if add then PMap.add f cf acc else acc) in let fields , types = List.fold_left loop ([],PMap.empty) fl in let x = ref Const in ctx.opened <- x :: ctx.opened; mk (TObjectDecl (List.rev fields)) (TAnon { a_fields = types; a_status = x }) p | Some a -> let fields = ref PMap.empty in let extra_fields = ref [] in let fl = List.map (fun (n, e) -> let n,add = object_field n in if PMap.mem n !fields then error ("Duplicate field in object declaration : " ^ n) p; let e = try let t = (PMap.find n a.a_fields).cf_type in let e = type_expr ctx e (match with_type with WithTypeResume _ -> WithTypeResume t | _ -> WithType t) in unify ctx e.etype t e.epos; (try type_eq EqStrict e.etype t; e with Unify_error _ -> mk (TCast (e,None)) t e.epos) with Not_found -> extra_fields := n :: !extra_fields; type_expr ctx e Value in if add then begin let cf = mk_field n e.etype e.epos in fields := PMap.add n cf !fields; end; (n,e) ) fl in let t = (TAnon { a_fields = !fields; a_status = ref Const }) in if not ctx.untyped then begin let unify_error l p = match with_type with | WithTypeResume _ -> raise (WithTypeError (l,p)) | _ -> raise (Error (Unify l,p)) in PMap.iter (fun n cf -> if not (Meta.has Meta.Optional cf.cf_meta) && not (PMap.mem n !fields) then unify_error [has_no_field t n] p; ) a.a_fields; (match !extra_fields with | [] -> () | _ -> unify_error (List.map (fun n -> has_extra_field t n) !extra_fields) p); end; a.a_status := Closed; mk (TObjectDecl fl) t p) | EArrayDecl [(EFor _,_) | (EWhile _,_) as e] -> let v = gen_local ctx (mk_mono()) in let et = ref (EConst(Ident "null"),p) in let rec map_compr (e,p) = match e with | EFor(it,e2) -> (EFor (it, map_compr e2),p) | EWhile(cond,e2,flag) -> (EWhile (cond,map_compr e2,flag),p) | EIf (cond,e2,None) -> (EIf (cond,map_compr e2,None),p) | EBlock [e] -> (EBlock [map_compr e],p) | EParenthesis e2 -> (EParenthesis (map_compr e2),p) | EBinop(OpArrow,a,b) -> et := (ENew({tpackage=[];tname="Map";tparams=[];tsub=None},[]),p); (ECall ((EField ((EConst (Ident v.v_name),p),"set"),p),[a;b]),p) | _ -> et := (EArrayDecl [],p); (ECall ((EField ((EConst (Ident v.v_name),p),"push"),p),[(e,p)]),p) in let e = map_compr e in let ea = type_expr ctx !et with_type in unify ctx v.v_type ea.etype p; let efor = type_expr ctx e NoValue in mk (TBlock [ mk (TVars [v,Some ea]) ctx.t.tvoid p; efor; mk (TLocal v) v.v_type p; ]) v.v_type p | EArrayDecl ((EBinop(OpArrow,_,_),_) as e1 :: el) -> let keys = Hashtbl.create 0 in let tkey,tval,resume = match with_type with | WithType (TAbstract({a_path=[],"Map"},[tk;tv])) -> tk,tv,false | WithTypeResume (TAbstract({a_path=[],"Map"},[tk;tv])) -> tk,tv,true | _ -> mk_mono(),mk_mono(),false in let unify_with_resume ctx a b p = if resume then try unify_raise ctx a b p with Error (Unify l,p) -> raise (WithTypeError(l,p)) else unify ctx a b p in let type_arrow e1 e2 = let e1 = type_expr ctx e1 (WithType tkey) in try let p = Hashtbl.find keys e1.eexpr in display_error ctx "Duplicate key" e1.epos; error "Previously defined here" p with Not_found -> Hashtbl.add keys e1.eexpr e1.epos; unify_with_resume ctx e1.etype tkey e1.epos; let e2 = type_expr ctx e2 (WithType tval) in unify_with_resume ctx e2.etype tval e2.epos; e1,e2 in let m = Typeload.load_module ctx ([],"Map") null_pos in let a,c = match m.m_types with | (TAbstractDecl ({a_impl = Some c} as a)) :: _ -> a,c | _ -> assert false in let tmap = TAbstract(a,[tkey;tval]) in let cf = PMap.find "set" c.cl_statics in let el = e1 :: el in let v = gen_local ctx tmap in let ev = mk (TLocal v) tmap p in let ef = mk (TField(ev,FInstance(c,cf))) (tfun [tkey;tval] ctx.t.tvoid) p in let el = ev :: List.fold_left (fun acc e -> match fst e with | EBinop(OpArrow,e1,e2) -> let e1,e2 = type_arrow e1 e2 in (make_call ctx ef [e1;e2] ctx.com.basic.tvoid p) :: acc | _ -> error "Expected a => b" (snd e) ) [] el in let enew = mk (TNew(c,[tkey;tval],[])) tmap p in let el = (mk (TVars [v,Some enew]) t_dynamic p) :: (List.rev el) in mk (TBlock el) tmap p | EArrayDecl el -> let tp = (match with_type with | WithType t | WithTypeResume t -> (match follow t with | TInst ({ cl_path = [],"Array" },[tp]) -> (match follow tp with | TMono _ -> None | _ -> Some tp) | TAnon _ -> (try Some (get_iterable_param t) with Not_found -> None) | _ -> if t == t_dynamic then Some t else None) | _ -> None ) in (match tp with | None -> let el = List.map (fun e -> type_expr ctx e Value) el in let t = try unify_min_raise ctx el with Error (Unify l,p) -> if ctx.untyped then t_dynamic else begin display_error ctx "Arrays of mixed types are only allowed if the type is forced to Array" p; raise (Error (Unify l, p)) end in mk (TArrayDecl el) (ctx.t.tarray t) p | Some t -> let el = List.map (fun e -> let e = type_expr ctx e (match with_type with WithTypeResume _ -> WithTypeResume t | _ -> WithType t) in (match with_type with | WithTypeResume _ -> (try unify_raise ctx e.etype t e.epos with Error (Unify l,p) -> raise (WithTypeError (l,p))) | _ -> unify ctx e.etype t e.epos); e ) el in mk (TArrayDecl el) (ctx.t.tarray t) p) | EVars vl -> type_vars ctx vl p false | EFor (it,e2) -> let i, e1 = (match it with | (EIn ((EConst (Ident i),_),e),_) -> i, e | _ -> error "For expression should be 'v in expr'" (snd it) ) in let e1 = type_expr ctx e1 Value in let old_loop = ctx.in_loop in let old_locals = save_locals ctx in ctx.in_loop <- true; let e = (match Optimizer.optimize_for_loop ctx i e1 e2 p with | Some e -> e | None -> let t, pt = Typeload.t_iterator ctx in let i = add_local ctx i pt in let e1 = (match follow e1.etype with | TMono _ | TDynamic _ -> display_error ctx "You can't iterate on a Dynamic value, please specify Iterator or Iterable" e1.epos; e1 | TLazy _ -> assert false | _ -> (try unify_raise ctx e1.etype t e1.epos; e1 with Error (Unify _,_) -> let acc = acc_get ctx (type_field ctx e1 "iterator" e1.epos MCall) e1.epos in let acc = (match acc.eexpr with TField (e,FClosure (c,f)) -> { acc with eexpr = TField (e,match c with None -> FAnon f | Some c -> FInstance (c,f)) } | _ -> acc) in try unify_raise ctx acc.etype (tfun [] t) acc.epos; make_call ctx acc [] t e1.epos with Error (Unify(l),p) -> display_error ctx "Field iterator has an invalid type" acc.epos; display_error ctx (error_msg (Unify l)) p; mk (TConst TNull) t_dynamic p ) ) in let e2 = type_expr ctx e2 NoValue in (* can we inline hasNext() ? *) (try let c,pl = (match follow e1.etype with TInst (c,pl) -> c,pl | _ -> raise Exit) in let _, ft, fhasnext = (try class_field ctx c pl "hasNext" p with Not_found -> raise Exit) in if fhasnext.cf_kind <> Method MethInline then raise Exit; let tmp = gen_local ctx e1.etype in let eit = mk (TLocal tmp) e1.etype p in let ehasnext = make_call ctx (mk (TField (eit,FInstance (c, fhasnext))) (TFun([],ctx.t.tbool)) p) [] ctx.t.tbool p in let enext = mk (TVars [i,Some (make_call ctx (mk (TField (eit,FDynamic "next")) (TFun ([],pt)) p) [] pt p)]) ctx.t.tvoid p in let eblock = (match e2.eexpr with | TBlock el -> { e2 with eexpr = TBlock (enext :: el) } | _ -> mk (TBlock [enext;e2]) ctx.t.tvoid p ) in mk (TBlock [ mk (TVars [tmp,Some e1]) ctx.t.tvoid p; mk (TWhile (ehasnext,eblock,NormalWhile)) ctx.t.tvoid p ]) ctx.t.tvoid p with Exit -> mk (TFor (i,e1,e2)) ctx.t.tvoid p) ) in ctx.in_loop <- old_loop; old_locals(); e | EIn _ -> error "This expression is not allowed outside a for loop" p | ETernary (e1,e2,e3) -> type_expr ctx (EIf (e1,e2,Some e3),p) with_type | EIf (e,e1,e2) -> let e = type_expr ctx e Value in unify ctx e.etype ctx.t.tbool e.epos; let e1 = type_expr ctx e1 with_type in (match e2 with | None -> mk (TIf (e,e1,None)) ctx.t.tvoid p | Some e2 -> let e2 = type_expr ctx e2 with_type in let e1,e2,t = match with_type with | NoValue -> e1,e2,ctx.t.tvoid | Value -> e1,e2,unify_min ctx [e1; e2] | WithType t | WithTypeResume t when (match follow t with TMono _ -> true | _ -> false) -> e1,e2,unify_min ctx [e1; e2] | WithType t | WithTypeResume t -> begin try unify_raise ctx e1.etype t e1.epos; unify_raise ctx e2.etype t e2.epos; with Error (Unify l,p) -> match with_type with | WithTypeResume _ -> raise (WithTypeError (l,p)) | _ -> display_error ctx (error_msg (Unify l)) p end; let e1 = Codegen.Abstract.check_cast ctx t e1 e1.epos in let e2 = Codegen.Abstract.check_cast ctx t e2 e2.epos in e1,e2,t 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 Value in unify ctx cond.etype ctx.t.tbool cond.epos; ctx.in_loop <- true; let e = type_expr ctx e NoValue in ctx.in_loop <- old_loop; 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 ctx e NoValue in ctx.in_loop <- old_loop; let cond = type_expr ctx cond Value in 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 with_type p | EReturn e -> let e , t = (match e with | None -> let v = ctx.t.tvoid in unify ctx v ctx.ret p; None , v | Some e -> let e = type_expr ctx e (WithType ctx.ret) in unify ctx e.etype ctx.ret e.epos; let e = Codegen.Abstract.check_cast ctx ctx.ret e p in Some e , e.etype ) in mk (TReturn e) t_dynamic p | EBreak -> if not ctx.in_loop then display_error ctx "Break outside loop" p; mk TBreak t_dynamic p | EContinue -> if not ctx.in_loop then display_error ctx "Continue outside loop" p; mk TContinue t_dynamic p | ETry (e1,catches) -> let e1 = type_expr ctx e1 with_type in let catches = List.map (fun (v,t,e) -> let t = Typeload.load_complex_type ctx (pos e) t in let name = (match follow t with | TInst ({ cl_path = path },params) | TEnum ({ e_path = path },params) -> List.iter (fun pt -> if pt != t_dynamic then error "Catch class parameter must be Dynamic" p; ) params; add_feature ctx.com "typed_catch"; (match path with | x :: _ , _ -> x | [] , name -> name) | TDynamic _ -> "" | _ -> error "Catch type must be a class" p ) in let locals = save_locals ctx in let v = add_local ctx v t in let e = type_expr ctx e with_type in locals(); if with_type <> NoValue then unify ctx e.etype e1.etype e.epos; if PMap.mem name ctx.locals then error ("Local variable " ^ name ^ " is preventing usage of this type here") e.epos; v , e ) catches in mk (TTry (e1,catches)) (if with_type = NoValue then ctx.t.tvoid else e1.etype) p | EThrow e -> let e = type_expr ctx e Value in mk (TThrow e) (mk_mono()) p | ECall (((EConst (Ident s),_) as e),el) -> (try let t, e, pl = (match with_type with | WithType t | WithTypeResume t -> (match follow t with | TEnum (e,pl) -> t, e, pl | _ -> raise Exit) | _ -> raise Exit ) in try ignore(type_ident_raise ~imported_enums:false ctx s p MCall); raise Exit with Not_found -> try let ef = PMap.find s e.e_constrs in let et = apply_params e.e_types pl (monomorphs ef.ef_params ef.ef_type) in let constr = mk (fast_enum_field e ef p) et p in build_call ctx (AKExpr constr) el (match with_type with WithTypeResume _ -> WithTypeResume t | _ -> WithType t) p with Not_found -> if ctx.untyped then raise Exit; (* __js__, etc. *) with_type_error ctx with_type (string_error s e.e_names ("Identifier '" ^ s ^ "' is not part of enum " ^ s_type_path e.e_path)) p; mk (TConst TNull) t p with Exit -> type_call ctx e el with_type p) | ECall (e,el) -> type_call ctx e el with_type p | ENew (t,el) -> let t = Typeload.load_instance ctx t p true in let ct = (match follow t with | TAbstract (a,pl) -> (match a.a_impl with | None -> t | Some c -> TInst (c,pl)) | _ -> t ) in (match follow ct with | TInst ({cl_kind = KTypeParameter tl} as c,params) -> if not (Codegen.is_generic_parameter ctx c) then error "Only generic type parameters can be constructed" p; let el = List.map (fun e -> type_expr ctx e Value) el in let ct = (tfun (List.map (fun e -> e.etype) el) ctx.t.tvoid) in if not (List.exists (fun t -> match follow t with | TAnon a -> (try unify ctx (PMap.find "new" a.a_fields).cf_type ct p; true with Not_found -> false) | _ -> false ) tl) then error (s_type_path c.cl_path ^ " does not have a constructor") p; mk (TNew (c,params,el)) t p | TInst (c,params) -> let ct, f = get_constructor ctx c params p in if not (can_access ctx c f true || is_parent c ctx.curclass) && not ctx.untyped then display_error ctx "Cannot access private constructor" p; (match f.cf_kind with | Var { v_read = AccRequire (r,msg) } -> (match msg with Some msg -> error msg p | None -> error_require r p) | _ -> ()); let el = (match follow ct with | TFun (args,r) -> (try fst (unify_call_params ctx (Some (TInst(c,params),f)) el args r p false) with Error (e,p) -> display_error ctx (error_msg e) p; []) | _ -> error "Constructor is not a function" p ) in (match c.cl_kind with | KAbstractImpl a when not (Meta.has Meta.MultiType a.a_meta) -> let ta = TAnon { a_fields = c.cl_statics; a_status = ref (Statics c) } in let e = mk (TTypeExpr (TClassDecl c)) ta p in let e = mk (TField (e,(FStatic (c,f)))) ct p in make_call ctx e el t p | _ -> mk (TNew (c,params,el)) t p) | _ -> error (s_type (print_context()) t ^ " cannot be constructed") p) | EUnop (op,flag,e) -> type_unop ctx op flag e p | EFunction (name,f) -> let params = Typeload.type_function_params ctx f (match name with None -> "localfun" | Some n -> n) p in if params <> [] then begin if name = None then display_error ctx "Type parameters not supported in unnamed local functions" p; if with_type <> NoValue then error "Type parameters are not supported for rvalue functions" p end else List.iter (fun tp -> if tp.tp_constraints <> [] then display_error ctx "Type parameters constraints are not supported for local functions" p) f.f_params; let old = ctx.type_params in ctx.type_params <- params @ ctx.type_params; let rt = Typeload.load_type_opt ctx p f.f_type in let args = List.map (fun (s,opt,t,c) -> let t = Typeload.load_type_opt ctx p t in let t, c = Typeload.type_function_param ctx t c opt p in s , c, t ) f.f_args in (match with_type with | WithType t | WithTypeResume t -> let rec loop t = (match follow t with | TFun (args2,_) when List.length args2 = List.length args -> List.iter2 (fun (_,_,t1) (_,_,t2) -> match follow t1 with | TMono _ -> unify ctx t2 t1 p | _ -> () ) args args2; | TAbstract({a_this = ta} as a,tl) -> loop (apply_params a.a_types tl ta) | _ -> ()) in loop t | _ -> ()); let ft = TFun (fun_args args,rt) in let inline, v = (match name with | None -> false, None | Some v when ExtString.String.starts_with v "inline_" -> true, Some (String.sub v 7 (String.length v - 7)) | Some v -> false, Some v ) in let v = (match v with | None -> None | Some v -> if v.[0] = '$' then display_error ctx "Variables names starting with a dollar are not allowed" p; Some (add_local ctx v ft) ) in let e , fargs = Typeload.type_function ctx args rt (match ctx.curfun with FunStatic -> FunStatic | _ -> FunMemberLocal) f false p in ctx.type_params <- old; let f = { tf_args = fargs; tf_type = rt; tf_expr = e; } in let e = mk (TFunction f) ft p in (match v with | None -> e | Some v -> if params <> [] || inline then v.v_extra <- Some (params,if inline then Some e else None); let rec loop = function | Codegen.Block f | Codegen.Loop f | Codegen.Function f -> f loop | Codegen.Use v2 when v == v2 -> raise Exit | Codegen.Use _ | Codegen.Declare _ -> () in let is_rec = (try Codegen.local_usage loop e; false with Exit -> true) in let decl = (if is_rec then begin if inline then display_error ctx "Inline function cannot be recursive" e.epos; let vnew = add_local ctx v.v_name ft in mk (TVars [vnew,Some (mk (TBlock [ mk (TVars [v,Some (mk (TConst TNull) ft p)]) ctx.t.tvoid p; mk (TBinop (OpAssign,mk (TLocal v) ft p,e)) ft p; mk (TLocal v) ft p ]) ft p)]) ctx.t.tvoid p end else if inline then mk (TBlock []) ctx.t.tvoid p (* do not add variable since it will be inlined *) else mk (TVars [v,Some e]) ctx.t.tvoid p ) in if with_type <> NoValue && not inline then mk (TBlock [decl;mk (TLocal v) v.v_type p]) v.v_type p else decl) | EUntyped e -> let old = ctx.untyped in ctx.untyped <- true; let e = type_expr ctx e with_type in ctx.untyped <- old; { eexpr = e.eexpr; etype = mk_mono(); epos = e.epos; } | ECast (e,None) -> let e = type_expr ctx e Value in mk (TCast (e,None)) (mk_mono()) p | ECast (e, Some t) -> add_feature ctx.com "typed_cast"; let t = Typeload.load_complex_type ctx (pos e) t in let texpr = (match follow t with | TInst (_,params) | TEnum (_,params) -> List.iter (fun pt -> if follow pt != t_dynamic then error "Cast type parameters must be Dynamic" p; ) params; (match follow t with | TInst (c,_) -> (match c.cl_kind with KTypeParameter _ -> error "Can't cast to a type parameter" p | _ -> ()); TClassDecl c | TEnum (e,_) -> TEnumDecl e | _ -> assert false); | TAbstract (a,params) when Meta.has Meta.RuntimeValue a.a_meta -> List.iter (fun pt -> if follow pt != t_dynamic then error "Cast type parameters must be Dynamic" p; ) params; TAbstractDecl a | _ -> error "Cast type must be a class or an enum" p ) in mk (TCast (type_expr ctx e Value,Some texpr)) t p | EDisplay (e,iscall) when Common.defined_value_safe ctx.com Define.DisplayMode = "usage" -> let e = try type_expr ctx e Value with Error (Unknown_ident n,_) -> raise (Parser.TypePath ([n],None)) in (match e.eexpr with | TField(_,fa) -> (match extract_field fa with | None -> e | Some cf -> cf.cf_meta <- (Meta.Usage,[],p) :: cf.cf_meta; e) | _ -> e) | EDisplay (e,iscall) -> let old = ctx.in_display in let opt_args args ret = TFun(List.map(fun (n,o,t) -> n,true,t) args,ret) in ctx.in_display <- true; let e = (try type_expr ctx e Value with Error (Unknown_ident n,_) -> raise (Parser.TypePath ([n],None))) in let e = match e.eexpr with | TField (e1,fa) -> let mode = Common.defined_value_safe ctx.com Define.DisplayMode in if field_name fa = "bind" then (match follow e1.etype with | TFun(args,ret) -> {e1 with etype = opt_args args ret} | _ -> e) else if mode = "position" then (match extract_field fa with | None -> e | Some cf -> raise (Typecore.DisplayPosition [cf.cf_pos])) else if mode = "metadata" then (match fa with | FStatic (c,cf) | FInstance (c,cf) | FClosure(Some c,cf) -> raise (DisplayMetadata (c.cl_meta @ cf.cf_meta)) | _ -> e) else e | TTypeExpr mt when Common.defined_value_safe ctx.com Define.DisplayMode = "position" -> raise (DisplayPosition [match mt with | TClassDecl c -> c.cl_pos | TEnumDecl en -> en.e_pos | TTypeDecl t -> t.t_pos | TAbstractDecl a -> a.a_pos]) | TTypeExpr mt when Common.defined_value_safe ctx.com Define.DisplayMode = "metadata" -> raise (DisplayMetadata (match mt with | TClassDecl c -> c.cl_meta | TEnumDecl en -> en.e_meta | TTypeDecl t -> t.t_meta | TAbstractDecl a -> a.a_meta)) | _ -> e in ctx.in_display <- old; let opt_type t = match t with | TLazy f -> Typeload.return_partial_type := true; let t = (!f)() in Typeload.return_partial_type := false; t | _ -> t in let rec get_fields t = match follow t with | TInst (c,params) -> let priv = is_parent c ctx.curclass in let merge ?(cond=(fun _ -> true)) a b = PMap.foldi (fun k f m -> if cond f then PMap.add k f m else m) a b in let rec loop c params = let m = List.fold_left (fun m (i,params) -> merge m (loop i params) ) PMap.empty c.cl_implements in let m = (match c.cl_super with | None -> m | Some (csup,cparams) -> merge m (loop csup cparams) ) in let m = merge ~cond:(fun f -> priv || can_access ctx c f false) c.cl_fields m in let m = (match c.cl_kind with | KTypeParameter pl -> List.fold_left (fun acc t -> merge acc (get_fields t)) m pl | _ -> m ) in PMap.map (fun f -> { f with cf_type = apply_params c.cl_types params (opt_type f.cf_type); cf_public = true; }) m in loop c params | TAbstract({a_impl = Some c} as a,pl) -> ctx.m.module_using <- c :: ctx.m.module_using; PMap.fold (fun f acc -> if f.cf_name <> "_new" && can_access ctx c f true && Meta.has Meta.Impl f.cf_meta then begin let f = prepare_using_field f in let t = apply_params a.a_types pl (follow f.cf_type) in PMap.add f.cf_name { f with cf_public = true; cf_type = opt_type t } acc end else acc ) c.cl_statics PMap.empty | TAnon a -> (match !(a.a_status) with | Statics c -> PMap.fold (fun f acc -> if can_access ctx c f true then PMap.add f.cf_name { f with cf_public = true; cf_type = opt_type f.cf_type } acc else acc) a.a_fields PMap.empty | _ -> a.a_fields) | TFun (args,ret) -> let t = opt_args args ret in let cf = mk_field "bind" (tfun [t] t) p in PMap.add "bind" cf PMap.empty | _ -> PMap.empty in let fields = get_fields e.etype in (* add 'using' methods compatible with this type *) let rec loop acc = function | [] -> acc | c :: l -> let acc = ref (loop acc l) in let rec dup t = Type.map dup t in List.iter (fun f -> if not (Meta.has Meta.NoUsing f.cf_meta) then let f = { f with cf_type = opt_type f.cf_type } in let monos = List.map (fun _ -> mk_mono()) f.cf_params in let map = apply_params f.cf_params monos in match follow (map f.cf_type) with | TFun((_,_,TType({t_path=["haxe";"macro"], "ExprOf"}, [t])) :: args, ret) | TFun((_,_,t) :: args, ret) -> (try unify_raise ctx (dup e.etype) t e.epos; List.iter2 (fun m (name,t) -> match follow t with | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] -> List.iter (fun tc -> unify_raise ctx (dup e.etype) (map tc) e.epos) constr | _ -> () ) monos f.cf_params; if not (can_access ctx c f true) || follow e.etype == t_dynamic && follow t != t_dynamic then () else begin let f = prepare_using_field f in let f = { f with cf_params = []; cf_public = true; cf_type = TFun(args,ret) } in acc := PMap.add f.cf_name f (!acc) end with Error (Unify _,_) -> ()) | _ -> () ) c.cl_ordered_statics; !acc in let use_methods = match follow e.etype with TMono _ -> PMap.empty | _ -> loop (loop PMap.empty ctx.g.global_using) ctx.m.module_using in let fields = PMap.fold (fun f acc -> PMap.add f.cf_name f acc) fields use_methods in let fields = PMap.fold (fun f acc -> if Meta.has Meta.NoCompletion f.cf_meta then acc else f :: acc) fields [] in let t = (if iscall then match follow e.etype with | TFun _ -> e.etype | _ -> t_dynamic else match fields with | [] -> e.etype | _ -> let get_field acc f = List.fold_left (fun acc f -> if f.cf_public then (f.cf_name,f.cf_type,f.cf_doc) :: acc else acc) acc (f :: f.cf_overloads) in raise (DisplayFields (List.fold_left get_field [] fields)) ) in (match follow t with | TMono _ | TDynamic _ when ctx.in_macro -> mk (TConst TNull) t p | _ -> raise (DisplayTypes [t])) | EDisplayNew t -> let t = Typeload.load_instance ctx t p true in (match follow t with | TInst (c,params) | TAbstract({a_impl = Some c},params) -> let ct, f = get_constructor ctx c params p in raise (DisplayTypes (ct :: List.map (fun f -> f.cf_type) f.cf_overloads)) | _ -> error "Not a class" p) | ECheckType (e,t) -> let t = Typeload.load_complex_type ctx p t in let e = type_expr ctx e (WithType t) in let e = Codegen.Abstract.check_cast ctx t e p in unify ctx e.etype t e.epos; if e.etype == t then e else mk (TCast (e,None)) t p | EMeta (m,e) -> let old = ctx.meta in ctx.meta <- m :: ctx.meta; let e = type_expr ctx e with_type in let e = match m with | (Meta.ToString,_,_) -> (match follow e.etype with | TAbstract({a_impl = Some c},_) when PMap.mem "toString" c.cl_statics -> call_to_string ctx c e | _ -> e) | _ -> e in ctx.meta <- old; e and type_call ctx e el (with_type:with_type) p = let def () = (match e with | EField ((EConst (Ident "super"),_),_) , _ -> ctx.in_super_call <- true | _ -> ()); build_call ctx (type_access ctx (fst e) (snd e) MCall) el with_type p in match e, el with | (EConst (Ident "trace"),p) , e :: el -> if Common.defined ctx.com Define.NoTraces then null ctx.t.tvoid p else let params = (match el with [] -> [] | _ -> ["customParams",(EArrayDecl el , p)]) in let infos = mk_infos ctx p params in if platform ctx.com Js && el = [] && has_dce ctx.com then let e = type_expr ctx e Value in let infos = type_expr ctx infos Value in mk (TCall (mk (TLocal (alloc_var "`trace" t_dynamic)) t_dynamic p,[e;infos])) ctx.t.tvoid p else let me = Meta.ToString,[],pos e in type_expr ctx (ECall ((EField ((EField ((EConst (Ident "haxe"),p),"Log"),p),"trace"),p),[(EMeta (me,e),pos e);EUntyped infos,p]),p) NoValue | (EConst(Ident "callback"),p1),args -> let ecb = try Some (type_ident_raise ctx "callback" p1 MCall) with Not_found -> None in (match ecb with | Some ecb -> build_call ctx ecb args with_type p | None -> display_error ctx "callback syntax has changed to func.bind(args)" p; let e = type_expr ctx e Value in type_bind ctx e args p) | (EField (e,"bind"),p), args -> let e = type_expr ctx e Value in (match follow e.etype with | TFun _ -> type_bind ctx e args p | _ -> def ()) | (EConst (Ident "$type"),_) , [e] -> let e = type_expr ctx e Value in ctx.com.warning (s_type (print_context()) e.etype) e.epos; e | (EConst (Ident "__unprotect__"),_) , [(EConst (String _),_) as e] -> let e = type_expr ctx e Value in if Common.platform ctx.com Flash then let t = tfun [e.etype] e.etype in mk (TCall (mk (TLocal (alloc_var "__unprotect__" t)) t p,[e])) e.etype e.epos else e | (EConst (Ident "super"),sp) , el -> if ctx.curfun <> FunConstructor then error "Cannot call super constructor outside class constructor" p; let el, t = (match ctx.curclass.cl_super with | None -> error "Current class does not have a super" p | Some (c,params) -> let ct, f = get_constructor ctx c params p in let el, _ = (match follow ct with | TFun (args,r) -> unify_call_params ctx (Some (TInst(c,params),f)) el args r p false | _ -> error "Constructor is not a function" p ) in el , TInst (c,params) ) in mk (TCall (mk (TConst TSuper) t sp,el)) ctx.t.tvoid p | _ -> def () and build_call ctx acc el (with_type:with_type) p = let fopts t f = match follow t with | (TInst (c,pl) as t) -> Some (t,f) | (TAnon a) as t -> (match !(a.a_status) with Statics c -> Some (TInst(c,[]),f) | _ -> Some (t,f)) | _ -> None in match acc with | AKInline (ethis,f,fmode,t) -> let params, tfunc = (match follow t with | TFun (args,r) -> unify_call_params ctx (fopts ethis.etype f) el args r p true | _ -> error (s_type (print_context()) t ^ " cannot be called") p ) in make_call ctx (mk (TField (ethis,fmode)) t p) params (match tfunc with TFun(_,r) -> r | _ -> assert false) p | AKUsing (et,cl,ef,eparam) when Meta.has Meta.Generic ef.cf_meta -> (match et.eexpr with | TField(ec,_) -> let el,t,e = type_generic_function ctx (ec,ef) el ~using_param:(Some eparam) p in make_call ctx e el t p | _ -> assert false) | AKUsing (et,cl,ef,eparam) -> let ef = prepare_using_field ef in (match et.eexpr with | TField (ec,_) -> let acc = type_field ctx ec ef.cf_name p MCall in (match acc with | AKMacro _ -> build_call ctx acc (Interp.make_ast eparam :: el) with_type p | AKExpr _ | AKInline _ | AKUsing _ -> let params, tfunc = (match follow et.etype with | TFun ( _ :: args,r) -> unify_call_params ctx (Some (TInst(cl,[]),ef)) el args r p (ef.cf_kind = Method MethInline) | _ -> assert false ) in let args,r = match tfunc with TFun(args,r) -> args,r | _ -> assert false in let et = {et with etype = TFun(("",false,eparam.etype) :: args,r)} in make_call ctx et (eparam::params) r p | _ -> assert false) | _ -> assert false) | AKMacro (ethis,f) -> if ctx.macro_depth > 300 then error "Stack overflow" p; ctx.macro_depth <- ctx.macro_depth + 1; let f = (match ethis.eexpr with | TTypeExpr (TClassDecl c) -> (match ctx.g.do_macro ctx MExpr c.cl_path f.cf_name el p with | None -> (fun() -> type_expr ctx (EConst (Ident "null"),p) Value) | Some (EVars vl,p) -> (fun() -> type_vars ctx vl p true) | Some e -> (fun() -> type_expr ctx (EMeta((Meta.PrivateAccess,[],snd e),e),snd e) with_type)) | _ -> (* member-macro call : since we will make a static call, let's found the actual class and not its subclass *) (match follow ethis.etype with | TInst (c,_) -> let rec loop c = if PMap.mem f.cf_name c.cl_fields then match ctx.g.do_macro ctx MExpr c.cl_path f.cf_name (Interp.make_ast ethis :: el) p with | None -> (fun() -> type_expr ctx (EConst (Ident "null"),p) Value) | Some e -> (fun() -> type_expr ctx e Value) else match c.cl_super with | None -> assert false | Some (csup,_) -> loop csup in loop c | _ -> assert false)) in ctx.macro_depth <- ctx.macro_depth - 1; let old = ctx.on_error in ctx.on_error <- (fun ctx msg ep -> old ctx msg ep; (* display additional info in the case the error is not part of our original call *) if ep.pfile <> p.pfile || ep.pmax < p.pmin || ep.pmin > p.pmax then old ctx "Called from macro here" p ); let e = try f() with Error (m,p) -> display_error ctx (error_msg m) p; ctx.on_error <- old; raise Fatal_error in ctx.on_error <- old; e | AKNo _ | AKSet _ | AKAccess _ -> ignore(acc_get ctx acc p); assert false | AKExpr e -> let el , t, e = (match follow e.etype with | TFun (args,r) -> let fopts = (match acc with | AKExpr {eexpr = TField(e, (FStatic (_,f) | FInstance(_,f) | FAnon(f)))} -> fopts e.etype f | _ -> None ) in (match fopts,acc with | Some (_,cf),AKExpr({eexpr = TField(e,_)}) when Meta.has Meta.Generic cf.cf_meta -> type_generic_function ctx (e,cf) el p | _ -> let el, tfunc = unify_call_params ctx fopts el args r p false in el,(match tfunc with TFun(_,r) -> r | _ -> assert false), {e with etype = tfunc}) | TMono _ -> let t = mk_mono() in let el = List.map (fun e -> type_expr ctx e Value) el in unify ctx (tfun (List.map (fun e -> e.etype) el) t) e.etype e.epos; el, t, e | t -> let el = List.map (fun e -> type_expr ctx e Value) el in el, (if t == t_dynamic then t_dynamic else if ctx.untyped then mk_mono() else error (s_type (print_context()) e.etype ^ " cannot be called") e.epos), e ) in mk (TCall (e,el)) t p and check_to_string ctx t = match follow t with | TInst (c,_) -> (try let _, _, f = Type.class_field c "toString" in ignore(follow f.cf_type); with Not_found -> ()) | _ -> () (* ---------------------------------------------------------------------- *) (* FINALIZATION *) let get_main ctx = match ctx.com.main_class with | None -> None | Some cl -> let t = Typeload.load_type_def ctx null_pos { tpackage = fst cl; tname = snd cl; tparams = []; tsub = None } in let fmode, ft, r = (match t with | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ -> error ("Invalid -main : " ^ s_type_path cl ^ " is not a class") null_pos | TClassDecl c -> try let f = PMap.find "main" c.cl_statics in let t = Type.field_type f in (match follow t with | TFun ([],r) -> FStatic (c,f), t, r | _ -> error ("Invalid -main : " ^ s_type_path cl ^ " has invalid main function") c.cl_pos); with Not_found -> error ("Invalid -main : " ^ s_type_path cl ^ " does not have static function main") c.cl_pos ) in let emain = type_type ctx cl null_pos in Some (mk (TCall (mk (TField (emain,fmode)) ft null_pos,[])) r null_pos) let finalize ctx = flush_pass ctx PFinal "final" type state = | Generating | Done | NotYet let generate ctx = let types = 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 let rec loop t = let p = t_path t in match state p with | Done -> () | Generating -> ctx.com.warning ("Warning : maybe loop in static generation of " ^ s_type_path p) (t_infos t).mt_pos; | NotYet -> Hashtbl.add states p Generating; let t = (match t with | TClassDecl c -> walk_class p c; t | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ -> t ) in Hashtbl.replace states p Done; types := t :: !types and loop_class p c = if c.cl_path <> p then loop (TClassDecl c) and loop_enum p e = if e.e_path <> p then loop (TEnumDecl e) and loop_abstract p a = if a.a_path <> p then loop (TAbstractDecl a) and walk_static_call p c name = try let f = PMap.find name c.cl_statics in match f.cf_expr with | None -> () | Some e -> if PMap.mem (c.cl_path,name) (!statics) then () else begin statics := PMap.add (c.cl_path,name) () (!statics); walk_expr p e; end with Not_found -> () and walk_expr p e = match e.eexpr with | TTypeExpr t -> (match t with | TClassDecl c -> loop_class p c | TEnumDecl e -> loop_enum p e | TAbstractDecl a -> loop_abstract p a | TTypeDecl _ -> assert false) | TNew (c,_,_) -> iter (walk_expr p) e; loop_class p c; let rec loop c = if PMap.mem (c.cl_path,"new") (!statics) then () else begin statics := PMap.add (c.cl_path,"new") () !statics; (match c.cl_constructor with | Some { cf_expr = Some e } -> walk_expr p e | _ -> ()); match c.cl_super with | None -> () | Some (csup,_) -> loop csup end in loop c | TMatch (_,(enum,_),_,_) -> loop_enum p enum; iter (walk_expr p) e | TCall (f,_) -> iter (walk_expr p) e; (* static call for initializing a variable *) let rec loop f = match f.eexpr with | TField ({ eexpr = TTypeExpr t },name) -> (match t with | TEnumDecl _ -> () | TAbstractDecl _ -> () | TTypeDecl _ -> assert false | TClassDecl c -> walk_static_call p c (field_name name)) | _ -> () in loop f | _ -> iter (walk_expr p) e and walk_class p c = (match c.cl_super with None -> () | Some (c,_) -> loop_class p c); List.iter (fun (c,_) -> loop_class p c) c.cl_implements; (match c.cl_init with | None -> () | Some e -> walk_expr p e); PMap.iter (fun _ f -> match f.cf_expr with | None -> () | Some e -> match e.eexpr with | TFunction _ -> () | _ -> walk_expr p e ) c.cl_statics in let sorted_modules = List.sort (fun m1 m2 -> compare m1.m_path m2.m_path) (Hashtbl.fold (fun _ m acc -> m :: acc) ctx.g.modules []) in List.iter (fun m -> List.iter loop m.m_types) sorted_modules; get_main ctx, List.rev !types, sorted_modules (* ---------------------------------------------------------------------- *) (* MACROS *) let macro_enable_cache = ref false let macro_interp_cache = ref None let delayed_macro_result = ref ((fun() -> assert false) : unit -> unit -> Interp.value) let get_type_patch ctx t sub = let new_patch() = { tp_type = None; tp_remove = false; tp_meta = [] } in let path = Ast.parse_path t in let h, tp = (try Hashtbl.find ctx.g.type_patches path with Not_found -> let h = Hashtbl.create 0 in let tp = new_patch() in Hashtbl.add ctx.g.type_patches path (h,tp); h, tp ) in match sub with | None -> tp | Some k -> try Hashtbl.find h k with Not_found -> let tp = new_patch() in Hashtbl.add h k tp; tp let macro_timer ctx path = Common.timer (if Common.defined ctx.com Define.MacroTimes then "macro " ^ path else "macro execution") let typing_timer ctx f = let t = Common.timer "typing" in let old = ctx.com.error and oldp = ctx.pass in (* disable resumable errors... unless we are in display mode (we want to reach point of completion) *) if not ctx.com.display then ctx.com.error <- (fun e p -> raise (Error(Custom e,p))); if ctx.pass < PTypeField then ctx.pass <- PTypeField; let exit() = t(); ctx.com.error <- old; ctx.pass <- oldp; in try let r = f() in exit(); r with Error (ekind,p) -> exit(); Interp.compiler_error (Typecore.error_msg ekind) p | WithTypeError (l,p) -> exit(); Interp.compiler_error (Typecore.error_msg (Unify l)) p | e -> exit(); raise e let make_macro_api ctx p = let make_instance = function | TClassDecl c -> TInst (c,List.map snd c.cl_types) | TEnumDecl e -> TEnum (e,List.map snd e.e_types) | TTypeDecl t -> TType (t,List.map snd t.t_types) | TAbstractDecl a -> TAbstract (a,List.map snd a.a_types) in let parse_expr_string s p inl = typing_timer ctx (fun() -> parse_expr_string ctx s p inl) in { Interp.pos = p; Interp.get_com = (fun() -> ctx.com); Interp.get_type = (fun s -> typing_timer ctx (fun() -> let path = parse_path s in try let m = Some (Typeload.load_instance ctx { tpackage = fst path; tname = snd path; tparams = []; tsub = None } p true) in m with Error (Module_not_found _,p2) when p == p2 -> None ) ); Interp.get_module = (fun s -> typing_timer ctx (fun() -> let path = parse_path s in let m = List.map make_instance (Typeload.load_module ctx path p).m_types in m ) ); Interp.on_generate = (fun f -> Common.add_filter ctx.com (fun() -> let t = macro_timer ctx "onGenerate" in f (List.map make_instance ctx.com.types); t() ) ); Interp.on_type_not_found = (fun f -> ctx.com.load_extern_type <- (fun path p -> match f (s_type_path path) with | Interp.VNull -> None | td -> let (pack,name),tdef,p = Interp.decode_type_def td in Some (name,(pack,[tdef,p])) ) :: ctx.com.load_extern_type; ); Interp.parse_string = parse_expr_string; Interp.typeof = (fun e -> typing_timer ctx (fun() -> (type_expr ctx e Value).etype) ); Interp.get_display = (fun s -> let is_displaying = ctx.com.display in let old_resume = !Parser.resume_display in let old_error = ctx.on_error in let restore () = if not is_displaying then begin ctx.com.defines <- PMap.remove (fst (Define.infos Define.Display)) ctx.com.defines; ctx.com.display <- false end; Parser.resume_display := old_resume; ctx.on_error <- old_error; in (* temporarily enter display mode with a fake position *) if not is_displaying then begin Common.define ctx.com Define.Display; ctx.com.display <- true; end; Parser.resume_display := { Ast.pfile = "macro"; Ast.pmin = 0; Ast.pmax = 0; }; ctx.on_error <- (fun ctx msg p -> raise (Error(Custom msg,p))); let str = try let e = parse_expr_string s Ast.null_pos true in let e = Optimizer.optimize_completion_expr e in ignore (type_expr ctx e Value); "NO COMPLETION" with DisplayFields fields -> let pctx = print_context() in String.concat "," (List.map (fun (f,t,_) -> f ^ ":" ^ s_type pctx t) fields) | DisplayTypes tl -> let pctx = print_context() in String.concat "," (List.map (s_type pctx) tl) | Parser.TypePath (p,sub) -> (match sub with | None -> "path(" ^ String.concat "." p ^ ")" | Some (c,_) -> "path(" ^ String.concat "." p ^ ":" ^ c ^ ")") | Typecore.Error (msg,p) -> "error(" ^ error_msg msg ^ ")" in restore(); str ); Interp.allow_package = (fun v -> Common.allow_package ctx.com v); Interp.type_patch = (fun t f s v -> typing_timer ctx (fun() -> let v = (match v with None -> None | Some s -> match parse_string ctx ("typedef T = " ^ s) null_pos false with | ETypedef { d_data = ct } -> Some ct | _ -> assert false ) in let tp = get_type_patch ctx t (Some (f,s)) in match v with | None -> tp.tp_remove <- true | Some _ -> tp.tp_type <- v ); ); Interp.meta_patch = (fun m t f s -> let m = (match parse_string ctx (m ^ " typedef T = T") null_pos false with | ETypedef t -> t.d_meta | _ -> assert false ) in let tp = get_type_patch ctx t (match f with None -> None | Some f -> Some (f,s)) in tp.tp_meta <- tp.tp_meta @ m; ); Interp.set_js_generator = (fun gen -> let js_ctx = Genjs.alloc_ctx ctx.com in ctx.com.js_gen <- Some (fun() -> let jsctx = Interp.enc_obj [ "outputFile", Interp.enc_string ctx.com.file; "types", Interp.enc_array (List.map (fun t -> Interp.encode_type (make_instance t)) ctx.com.types); "main", (match ctx.com.main with None -> Interp.VNull | Some e -> Interp.encode_texpr e); "generateValue", Interp.VFunction (Interp.Fun1 (fun v -> match v with | Interp.VAbstract (Interp.ATExpr e) -> let str = Genjs.gen_single_expr js_ctx e false in Interp.enc_string str | _ -> failwith "Invalid expression"; )); "isKeyword", Interp.VFunction (Interp.Fun1 (fun v -> Interp.VBool (Hashtbl.mem Genjs.kwds (Interp.dec_string v)) )); "quoteString", Interp.VFunction (Interp.Fun1 (fun v -> Interp.enc_string ("\"" ^ Ast.s_escape (Interp.dec_string v) ^ "\"") )); "buildMetaData", Interp.VFunction (Interp.Fun1 (fun t -> match Codegen.build_metadata ctx.com (Interp.decode_tdecl t) with | None -> Interp.VNull | Some e -> Interp.encode_texpr e )); "generateStatement", Interp.VFunction (Interp.Fun1 (fun v -> match v with | Interp.VAbstract (Interp.ATExpr e) -> let str = Genjs.gen_single_expr js_ctx e true in Interp.enc_string str | _ -> failwith "Invalid expression"; )); "setTypeAccessor", Interp.VFunction (Interp.Fun1 (fun callb -> js_ctx.Genjs.type_accessor <- (fun t -> let v = Interp.encode_type (make_instance t) in let ret = Interp.call (Interp.get_ctx()) Interp.VNull callb [v] Nast.null_pos in Interp.dec_string ret ); Interp.VNull )); "setCurrentClass", Interp.VFunction (Interp.Fun1 (fun c -> Genjs.set_current_class js_ctx (match Interp.decode_tdecl c with TClassDecl c -> c | _ -> assert false); Interp.VNull )); ] in let t = macro_timer ctx "jsGenerator" in gen jsctx; t() ); ); Interp.get_local_type = (fun() -> match ctx.g.get_build_infos() with | Some (mt,_) -> Some (match mt with | TClassDecl c -> TInst (c,[]) | TEnumDecl e -> TEnum (e,[]) | TTypeDecl t -> TType (t,[]) | TAbstractDecl a -> TAbstract(a,[])) | None -> if ctx.curclass == null_class then None else Some (TInst (ctx.curclass,[])) ); Interp.get_local_method = (fun() -> ctx.curfield.cf_name; ); Interp.get_local_using = (fun() -> ctx.m.module_using; ); Interp.get_local_vars = (fun () -> ctx.locals; ); Interp.get_build_fields = (fun() -> match ctx.g.get_build_infos() with | None -> Interp.VNull | Some (_,fields) -> Interp.enc_array (List.map Interp.encode_field fields) ); Interp.get_pattern_locals = (fun e t -> !get_pattern_locals_ref ctx e t ); Interp.define_type = (fun v -> let m, tdef, pos = (try Interp.decode_type_def v with Interp.Invalid_expr -> Interp.exc (Interp.VString "Invalid type definition")) in let mdep = Typeload.type_module ctx m ctx.m.curmod.m_extra.m_file [tdef,pos] pos in mdep.m_extra.m_kind <- MFake; mdep.m_extra.m_time <- -1.; add_dependency ctx.m.curmod mdep; ); Interp.module_dependency = (fun mpath file ismacro -> let m = typing_timer ctx (fun() -> Typeload.load_module ctx (parse_path mpath) p) in if ismacro then m.m_extra.m_macro_calls <- file :: List.filter ((<>) file) m.m_extra.m_macro_calls else add_dependency m (create_fake_module ctx file); ); Interp.current_module = (fun() -> ctx.m.curmod ); Interp.delayed_macro = (fun i -> let mctx = (match ctx.g.macros with None -> assert false | Some (_,mctx) -> mctx) in let f = (try DynArray.get mctx.g.delayed_macros i with _ -> failwith "Delayed macro retrieve failure") in f(); let ret = !delayed_macro_result in delayed_macro_result := (fun() -> assert false); ret ); Interp.use_cache = (fun() -> !macro_enable_cache ); } let rec init_macro_interp ctx mctx mint = let p = Ast.null_pos in ignore(Typeload.load_module mctx (["haxe";"macro"],"Expr") p); ignore(Typeload.load_module mctx (["haxe";"macro"],"Type") p); flush_macro_context mint ctx; Interp.init mint; if !macro_enable_cache && not (Common.defined mctx.com Define.NoMacroCache) then macro_interp_cache := Some mint and flush_macro_context mint ctx = let mctx = (match ctx.g.macros with None -> assert false | Some (_,mctx) -> mctx) in finalize mctx; let _, types, modules = generate mctx in mctx.com.types <- types; mctx.com.Common.modules <- modules; (* if one of the type we are using has been modified, we need to create a new macro context from scratch *) let mint = if not (Interp.can_reuse mint types) then begin let com2 = mctx.com in let mint = Interp.create com2 (make_macro_api ctx Ast.null_pos) in let macro = ((fun() -> Interp.select mint), mctx) in ctx.g.macros <- Some macro; mctx.g.macros <- Some macro; init_macro_interp ctx mctx mint; mint end else mint in (* we should maybe ensure that all filters in Main are applied. Not urgent atm *) (try Interp.add_types mint types (Codegen.post_process [Codegen.Abstract.handle_abstract_casts mctx; Codegen.captured_vars mctx.com; Codegen.rename_local_vars mctx.com]) with Error (e,p) -> display_error ctx (error_msg e) p; raise Fatal_error); Codegen.post_process_end() let create_macro_interp ctx mctx = let com2 = mctx.com in let mint, init = (match !macro_interp_cache with | None -> let mint = Interp.create com2 (make_macro_api ctx Ast.null_pos) in mint, (fun() -> init_macro_interp ctx mctx mint) | Some mint -> Interp.do_reuse mint; mint, (fun() -> ()) ) in let on_error = com2.error in com2.error <- (fun e p -> Interp.set_error (Interp.get_ctx()) true; macro_interp_cache := None; on_error e p ); let macro = ((fun() -> Interp.select mint), mctx) in ctx.g.macros <- Some macro; mctx.g.macros <- Some macro; (* mctx.g.core_api <- ctx.g.core_api; // causes some issues because of optional args and Null type in Flash9 *) init() let get_macro_context ctx p = let api = make_macro_api ctx p in match ctx.g.macros with | Some (select,ctx) -> select(); api, ctx | None -> let com2 = Common.clone ctx.com in ctx.com.get_macros <- (fun() -> Some com2); com2.package_rules <- PMap.empty; com2.main_class <- None; com2.display <- false; List.iter (fun p -> com2.defines <- PMap.remove (platform_name p) com2.defines) platforms; com2.defines_signature <- None; 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; let to_remove = List.map (fun d -> fst (Define.infos d)) [Define.NoTraces] in let to_remove = to_remove @ List.map (fun (_,d) -> "flash" ^ d) Common.flash_versions in com2.defines <- PMap.foldi (fun k v acc -> if List.mem k to_remove then acc else PMap.add k v acc) com2.defines PMap.empty; Common.define com2 Define.Macro; Common.init_platform com2 Neko; let mctx = ctx.g.do_create com2 in create_macro_interp ctx mctx; api, mctx let load_macro ctx cpath f p = (* The time measured here takes into account both macro typing an init, but benchmarks shows that - unless you re doing heavy statics vars init - the time is mostly spent in typing the classes needed for macro execution. *) let t = macro_timer ctx "typing (+init)" in let api, mctx = get_macro_context ctx p in let mint = Interp.get_ctx() in let m = (try Hashtbl.find ctx.g.types_module cpath with Not_found -> cpath) in let mloaded = Typeload.load_module mctx m p in mctx.m <- { curmod = mloaded; module_types = []; module_using = []; module_globals = PMap.empty; wildcard_packages = []; }; add_dependency ctx.m.curmod mloaded; let cl, meth = (match Typeload.load_instance mctx { tpackage = fst cpath; tname = snd cpath; tparams = []; tsub = None } p true with | TInst (c,_) -> finalize mctx; 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 meth = (match follow meth.cf_type with TFun (args,ret) -> args,ret,cl,meth | _ -> error "Macro call should be a method" p) in if not ctx.in_macro then flush_macro_context mint ctx; t(); let call args = let t = macro_timer ctx (s_type_path cpath ^ "." ^ f) in incr stats.s_macros_called; let r = Interp.call_path (Interp.get_ctx()) ((fst cpath) @ [snd cpath]) f args api in t(); r in mctx, meth, call let type_macro ctx mode cpath f (el:Ast.expr list) p = let mctx, (margs,mret,mclass,mfield), call_macro = load_macro ctx cpath f p in let mpos = mfield.cf_pos in let ctexpr = { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None } in let expr = Typeload.load_instance mctx ctexpr p false in (match mode with | MExpr -> unify mctx mret expr mpos; | MBuild -> let ctfields = { tpackage = []; tname = "Array"; tparams = [TPType (CTPath { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = Some "Field" })]; tsub = None } in let tfields = Typeload.load_instance mctx ctfields p false in unify mctx mret tfields mpos | MMacroType -> let cttype = { tpackage = ["haxe";"macro"]; tname = "Type"; tparams = []; tsub = None } in let ttype = Typeload.load_instance mctx cttype p false in unify mctx mret ttype mpos ); (* if the function's last argument is of Array, split the argument list and use [] for unify_call_params *) let el,el2 = match List.rev margs with | (_,_,TInst({cl_path=([], "Array")},[e])) :: rest when (try Type.type_eq EqStrict e expr; true with Unify_error _ -> false) -> let rec loop (acc1,acc2) el1 el2 = match el1,el2 with | [],[] -> List.rev acc1, List.rev acc2 | [], e2 :: [] -> (List.rev ((EArrayDecl [],p) :: acc1), []) | [], _ -> (* not enough arguments, will be handled by unify_call_params *) List.rev acc1, List.rev acc2 | e1 :: l1, e2 :: [] -> loop (((EArrayDecl [],p) :: acc1), [e1]) l1 [] | e1 :: l1, [] -> loop (acc1, e1 :: acc2) l1 [] | e1 :: l1, e2 :: l2 -> loop (e1 :: acc1, acc2) l1 l2 in loop ([],[]) el margs | _ -> el,[] in let todo = ref [] in let args = (* force default parameter types to haxe.macro.Expr, and if success allow to pass any value type since it will be encoded *) let eargs = List.map (fun (n,o,t) -> try unify_raise mctx t expr p; (n, o, t_dynamic), true with Error (Unify _,_) -> (n,o,t), false) margs in (* this is quite tricky here : we want to use unify_call_params which will type our AST expr but we want to be able to get it back after it's been padded with nulls *) let index = ref (-1) in let constants = List.map (fun e -> let p = snd e in let e = (try (match Codegen.type_constant_value ctx.com e with | { eexpr = TConst (TString _); epos = p } when Lexer.is_fmt_string p -> Lexer.remove_fmt_string p; todo := (fun() -> Lexer.add_fmt_string p) :: !todo; | _ -> ()); e with Error (Custom _,_) -> (* if it's not a constant, let's make something that is typed as haxe.macro.Expr - for nice error reporting *) (EBlock [ (EVars ["__tmp",Some (CTPath ctexpr),Some (EConst (Ident "null"),p)],p); (EConst (Ident "__tmp"),p); ],p) ) in (* let's track the index by doing [e][index] (we will keep the expression type this way) *) incr index; (EArray ((EArrayDecl [e],p),(EConst (Int (string_of_int (!index))),p)),p) ) el in let elt, _ = unify_call_params mctx (Some (TInst(mclass,[]),mfield)) constants (List.map fst eargs) t_dynamic p false in List.iter (fun f -> f()) (!todo); List.map2 (fun (_,ise) e -> let e, et = (match e.eexpr with (* get back our index and real expression *) | TArray ({ eexpr = TArrayDecl [e] }, { eexpr = TConst (TInt index) }) -> List.nth el (Int32.to_int index), e (* added by unify_call_params *) | TConst TNull -> (EConst (Ident "null"),e.epos), e | _ -> assert false ) in if ise then Interp.encode_expr e else match Interp.eval_expr (Interp.get_ctx()) et with | None -> assert false | Some v -> v ) eargs elt in let args = match el2 with | [] -> args | _ -> (match List.rev args with _::args -> List.rev args | [] -> []) @ [Interp.enc_array (List.map Interp.encode_expr el2)] in let call() = match call_macro args with | None -> None | Some v -> try Some (match mode with | MExpr -> Interp.decode_expr v | MBuild -> let fields = (match v with | Interp.VNull -> (match ctx.g.get_build_infos() with | None -> assert false | Some (_,fields) -> fields) | _ -> List.map Interp.decode_field (Interp.dec_array v) ) in (EVars ["fields",Some (CTAnonymous fields),None],p) | MMacroType -> ctx.ret <- Interp.decode_type v; (EBlock [],p) ) with Interp.Invalid_expr -> error "The macro didn't return a valid result" p in let e = (if ctx.in_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 = DynArray.length mctx.g.delayed_macros in DynArray.add mctx.g.delayed_macros (fun() -> delayed_macro_result := (fun() -> let mint = Interp.get_ctx() in match call() with | None -> (fun() -> raise Interp.Abort) | Some e -> Interp.eval mint (Genneko.gen_expr mint.Interp.gen (type_expr ctx e Value)) ); ); ctx.m.curmod.m_extra.m_time <- -1.; (* disable caching for modules having macro-in-macro *) let e = (EConst (Ident "__dollar__delay_call"),p) in Some (EUntyped (ECall (e,[EConst (Int (string_of_int pos)),p]),p),p) end else call() ) in e let call_macro ctx path meth args p = let mctx, (margs,_,mclass,mfield), call = load_macro ctx path meth p in let el, _ = unify_call_params mctx (Some (TInst(mclass,[]),mfield)) args margs t_dynamic p false in call (List.map (fun e -> try Interp.make_const e with Exit -> error "Parameter should be a constant" e.epos) el) let call_init_macro ctx e = let p = { pfile = "--macro"; pmin = 0; pmax = 0 } in let api = make_macro_api ctx p in let e = api.Interp.parse_string e p false in match fst e with | ECall (e,args) -> let rec loop e = match fst e with | EField (e,f) -> f :: loop e | EConst (Ident i) -> [i] | _ -> error "Invalid macro call" p in let path, meth = (match loop e with | [meth] -> (["haxe";"macro"],"Compiler"), meth | meth :: cl :: path -> (List.rev path,cl), meth | _ -> error "Invalid macro call" p) in ignore(call_macro ctx path meth args p); | _ -> error "Invalid macro call" p (* ---------------------------------------------------------------------- *) (* TYPER INITIALIZATION *) let rec create com = let ctx = { com = com; t = com.basic; g = { core_api = None; macros = None; modules = Hashtbl.create 0; types_module = Hashtbl.create 0; type_patches = Hashtbl.create 0; delayed = []; debug_delayed = []; delayed_macros = DynArray.create(); doinline = not (Common.defined com Define.NoInline || com.display); hook_generate = []; get_build_infos = (fun() -> None); std = null_module; global_using = []; do_inherit = Codegen.on_inherit; do_create = create; do_macro = type_macro; do_load_module = Typeload.load_module; do_optimize = Optimizer.reduce_expression; do_build_instance = Codegen.build_instance; }; m = { curmod = null_module; module_types = []; module_using = []; module_globals = PMap.empty; wildcard_packages = []; }; meta = []; pass = PBuildModule; macro_depth = 0; untyped = false; curfun = FunStatic; in_loop = false; in_super_call = false; in_display = false; in_macro = Common.defined com Define.Macro; ret = mk_mono(); locals = PMap.empty; type_params = []; curclass = null_class; curfield = null_field; tthis = mk_mono(); opened = []; vthis = None; on_error = (fun ctx msg p -> ctx.com.error msg p); } in ctx.g.std <- (try Typeload.load_module ctx ([],"StdTypes") null_pos with Error (Module_not_found ([],"StdTypes"),_) -> error "Standard library not found" null_pos ); List.iter (fun t -> match t with | TAbstractDecl a -> (match snd a.a_path with | "Void" -> ctx.t.tvoid <- TAbstract (a,[]); | "Float" -> ctx.t.tfloat <- TAbstract (a,[]); | "Int" -> ctx.t.tint <- TAbstract (a,[]) | "Bool" -> ctx.t.tbool <- TAbstract (a,[]) | _ -> ()); | TEnumDecl e -> () | TClassDecl c -> () | TTypeDecl td -> (match snd td.t_path with | "Null" -> let mk_null t = try if not (is_nullable ~no_lazy:true t) then TType (td,[t]) else t with Exit -> (* don't force lazy evaluation *) let r = ref (fun() -> assert false) in r := (fun() -> let t = (if not (is_nullable t) then TType (td,[t]) else t) in r := (fun() -> t); t ); TLazy r in ctx.t.tnull <- if not com.config.pf_static then (fun t -> t) else mk_null; | _ -> ()); ) ctx.g.std.m_types; let m = Typeload.load_module ctx ([],"String") null_pos in (match m.m_types with | [TClassDecl c] -> ctx.t.tstring <- TInst (c,[]) | _ -> assert false); let m = Typeload.load_module ctx ([],"Array") null_pos in (match m.m_types with | [TClassDecl c] -> ctx.t.tarray <- (fun t -> TInst (c,[t])) | _ -> assert false); let m = Typeload.load_module ctx (["haxe"],"EnumTools") null_pos in (match m.m_types with | [TClassDecl c1;TClassDecl c2] -> ctx.g.global_using <- c1 :: c2 :: ctx.g.global_using | [TClassDecl c1] -> let m = Typeload.load_module ctx (["haxe"],"EnumValueTools") null_pos in (match m.m_types with | [TClassDecl c2 ] -> ctx.g.global_using <- c1 :: c2 :: ctx.g.global_using | _ -> assert false); | _ -> assert false); ctx ;; unify_min_ref := unify_min; make_call_ref := make_call; get_constructor_ref := get_constructor; check_abstract_cast_ref := Codegen.Abstract.check_cast; haxe-3.0~svn6707/Makefile.win0000644000175000017500000000152112172015135016434 0ustar bdefreesebdefreeseinclude Makefile OUTPUT=haxe.exe EXTENSION=.exe OCAMLOPT=ocamlopt.opt kill: -@taskkill /F /IM haxe.exe 2>/dev/null # allow Ocaml/Mingw as well NATIVE_LIBS += -I "c:/program files/mingw/lib/" # use make MSVC=1 -f Makefile.win to build for OCaml/MSVC ifeq (${MSVC}, 1) NATIVE_LIBS = shell32.lib libs/extc/extc_stubs.obj libs/extc/zlib/zlib.lib endif ifeq (${MSVC_OUTPUT}, 1) FILTER=sed 's/File "\([^"]\+\)", line \([0-9]\+\), \(.*\)/\1(\2): \3/' tmp.cmi endif ifeq (${FD_OUTPUT}, 1) FILTER=sed '/File/{ N; s/File "\([^"]\+\)", line \([0-9]\+\), characters \([0-9-]\+\):[\r\n]*\(.*\)/\1:\2: characters \3 : \4/ }' tmp.cmi endif ifdef FILTER CC_CMD=($(OCAMLOPT) $(CFLAGS) -c $< 2>tmp.cmi && $(FILTER)) || ($(FILTER) && exit 1) CC_PARSER_CMD=($(OCAMLOPT) -pp camlp4o $(CFLAGS) -c parser.ml 2>tmp.cmi && $(FILTER)) || ($(FILTER) && exit 1) endifhaxe-3.0~svn6707/interp.ml0000644000175000017500000042327212172015135016046 0ustar bdefreesebdefreese(* * Copyright (C)2005-2013 Haxe Foundation * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. *) open Common open Nast open Unix open Type (* ---------------------------------------------------------------------- *) (* TYPES *) type value = | VNull | VBool of bool | VInt of int | VFloat of float | VString of string | VObject of vobject | VArray of value array | VAbstract of vabstract | VFunction of vfunction | VClosure of value list * (value list -> value list -> value) | VInt32 of int32 and vobject = { mutable ofields : (int * value) array; mutable oproto : vobject option; } and vabstract = | AKind of vabstract | AHash of (value, value) Hashtbl.t | ARandom of Random.State.t ref | ABuffer of Buffer.t | APos of Ast.pos | AFRead of in_channel | AFWrite of out_channel | AReg of regexp | AZipI of zlib | AZipD of zlib | AUtf8 of UTF8.Buf.buf | ASocket of Unix.file_descr | ATExpr of texpr | ATDecl of module_type | AUnsafe of Obj.t | ALazyType of (unit -> Type.t) ref | ANekoAbstract of Extc.value | ANekoBuffer of value | ACacheRef of value | AInt32Kind and vfunction = | Fun0 of (unit -> value) | Fun1 of (value -> value) | Fun2 of (value -> value -> value) | Fun3 of (value -> value -> value -> value) | Fun4 of (value -> value -> value -> value -> value) | Fun5 of (value -> value -> value -> value -> value -> value) | FunVar of (value list -> value) and regexp = { r : Str.regexp; mutable r_string : string; mutable r_groups : (int * int) option array; } and zlib = { z : Extc.zstream; mutable z_flush : Extc.zflush; } type cmp = | CEq | CSup | CInf | CUndef type extern_api = { pos : Ast.pos; get_com : unit -> Common.context; get_type : string -> Type.t option; get_module : string -> Type.t list; on_generate : (Type.t list -> unit) -> unit; on_type_not_found : (string -> value) -> unit; parse_string : string -> Ast.pos -> bool -> Ast.expr; typeof : Ast.expr -> Type.t; get_display : string -> string; allow_package : string -> unit; type_patch : string -> string -> bool -> string option -> unit; meta_patch : string -> string -> string option -> bool -> unit; set_js_generator : (value -> unit) -> unit; get_local_type : unit -> t option; get_local_method : unit -> string; get_local_using : unit -> tclass list; get_local_vars : unit -> (string, Type.tvar) PMap.t; get_build_fields : unit -> value; get_pattern_locals : Ast.expr -> Type.t -> (string,Type.tvar) PMap.t; define_type : value -> unit; module_dependency : string -> string -> bool -> unit; current_module : unit -> module_def; delayed_macro : int -> (unit -> (unit -> value)); use_cache : unit -> bool; } type callstack = { cpos : pos; cthis : value; cstack : int; cenv : value array; } type context = { gen : Genneko.context; types : (Type.path,int) Hashtbl.t; prototypes : (string list, vobject) Hashtbl.t; fields_cache : (int,string) Hashtbl.t; mutable error : bool; mutable error_proto : vobject; mutable enums : (value * string) array array; mutable do_call : value -> value -> value list -> pos -> value; mutable do_string : value -> string; mutable do_loadprim : value -> value -> value; mutable do_compare : value -> value -> cmp; mutable loader : value; mutable exports : value; (* runtime *) mutable stack : value DynArray.t; mutable callstack : callstack list; mutable callsize : int; mutable exc : pos list; mutable vthis : value; mutable venv : value array; (* context *) mutable curapi : extern_api; mutable on_reused : (unit -> bool) list; mutable is_reused : bool; (* eval *) mutable locals_map : (string, int) PMap.t; mutable locals_count : int; mutable locals_barrier : int; mutable locals_env : string DynArray.t; mutable globals : (string, value ref) PMap.t; } type access = | AccThis | AccLocal of int | AccGlobal of value ref | AccEnv of int | AccField of (unit -> value) * string | AccArray of (unit -> value) * (unit -> value) exception Runtime of value exception Builtin_error exception Error of string * Ast.pos list exception Abort exception Continue exception Break of value exception Return of value exception Invalid_expr (* ---------------------------------------------------------------------- *) (* UTILS *) let get_ctx_ref = ref (fun() -> assert false) let encode_complex_type_ref = ref (fun t -> assert false) let encode_type_ref = ref (fun t -> assert false) let decode_type_ref = ref (fun t -> assert false) let encode_expr_ref = ref (fun e -> assert false) let decode_expr_ref = ref (fun e -> assert false) let encode_clref_ref = ref (fun c -> assert false) let enc_hash_ref = ref (fun h -> assert false) let enc_array_ref = ref (fun l -> assert false) let enc_string_ref = ref (fun s -> assert false) let make_ast_ref = ref (fun _ -> assert false) let make_complex_type_ref = ref (fun _ -> assert false) let get_ctx() = (!get_ctx_ref)() let enc_array (l:value list) : value = (!enc_array_ref) l let encode_complex_type (t:Ast.complex_type) : value = (!encode_complex_type_ref) t let encode_type (t:Type.t) : value = (!encode_type_ref) t let decode_type (v:value) : Type.t = (!decode_type_ref) v let encode_expr (e:Ast.expr) : value = (!encode_expr_ref) e let decode_expr (e:value) : Ast.expr = (!decode_expr_ref) e let encode_clref (c:tclass) : value = (!encode_clref_ref) c let enc_hash (h:('a,'b) Hashtbl.t) : value = (!enc_hash_ref) h let make_ast (e:texpr) : Ast.expr = (!make_ast_ref) e let enc_string (s:string) : value = (!enc_string_ref) s let make_complex_type (t:Type.t) : Ast.complex_type = (!make_complex_type_ref) t let to_int f = Int32.of_float (mod_float f 2147483648.0) let need_32_bits i = Int32.compare (Int32.logand (Int32.add i 0x40000000l) 0x80000000l) Int32.zero <> 0 let best_int i = if need_32_bits i then VInt32 i else VInt (Int32.to_int i) let make_pos p = let low = p.pline land 0xFFFFF in { Ast.pfile = p.psource; Ast.pmin = low; Ast.pmax = low + (p.pline lsr 20); } let warn ctx msg p = (ctx.curapi.get_com()).Common.warning msg (make_pos p) let rec pop ctx n = if n > 0 then begin DynArray.delete_last ctx.stack; pop ctx (n - 1); end let pop_ret ctx f n = let v = f() in pop ctx n; v let push ctx v = DynArray.add ctx.stack v let hash f = let h = ref 0 in for i = 0 to String.length f - 1 do h := !h * 223 + int_of_char (String.unsafe_get f i); done; if Sys.word_size = 64 then Int32.to_int (Int32.shift_right (Int32.shift_left (Int32.of_int !h) 1) 1) else !h let constants = let h = Hashtbl.create 0 in List.iter (fun f -> Hashtbl.add h (hash f) f) ["done";"read";"write";"min";"max";"file";"args";"loadprim";"loadmodule";"__a";"__s";"h"; "tag";"index";"length";"message";"pack";"name";"params";"sub";"doc";"kind";"meta";"access"; "constraints";"opt";"type";"value";"ret";"expr";"field";"values";"get";"__string";"toString"; "$";"add";"remove";"has";"__t";"module";"isPrivate";"isPublic";"isExtern";"isInterface";"exclude"; "constructs";"names";"superClass";"interfaces";"fields";"statics";"constructor";"init";"t"; "gid";"uid";"atime";"mtime";"ctime";"dev";"ino";"nlink";"rdev";"size";"mode";"pos";"len"; "binops";"unops";"from";"to";"array";"op";"isPostfix";"impl"]; h let h_get = hash "__get" and h_set = hash "__set" and h_add = hash "__add" and h_radd = hash "__radd" and h_sub = hash "__sub" and h_rsub = hash "__rsub" and h_mult = hash "__mult" and h_rmult = hash "__rmult" and h_div = hash "__div" and h_rdiv = hash "__rdiv" and h_mod = hash "__mod" and h_rmod = hash "__rmod" and h_string = hash "__string" and h_compare = hash "__compare" and h_constructs = hash "__constructs__" and h_a = hash "__a" and h_s = hash "__s" and h_class = hash "__class__" let exc v = raise (Runtime v) let hash_field ctx f = let h = hash f in (try let f2 = Hashtbl.find ctx.fields_cache h in if f <> f2 then exc (VString ("Field conflict between " ^ f ^ " and " ^ f2)); with Not_found -> Hashtbl.add ctx.fields_cache h f); h let field_name ctx fid = try Hashtbl.find ctx.fields_cache fid with Not_found -> "???" let obj hash fields = let fields = Array.of_list (List.map (fun (k,v) -> hash k, v) fields) in Array.sort (fun (k1,_) (k2,_) -> compare k1 k2) fields; { ofields = fields; oproto = None; } let parse_int s = let rec loop_hex i = if i = String.length s then s else match String.unsafe_get s i with | '0'..'9' | 'a'..'f' | 'A'..'F' -> loop_hex (i + 1) | _ -> String.sub s 0 i in let rec loop sp i = if i = String.length s then (if sp = 0 then s else String.sub s sp (i - sp)) else match String.unsafe_get s i with | '0'..'9' -> loop sp (i + 1) | ' ' when sp = i -> loop (sp + 1) (i + 1) | '-' when i = 0 -> loop sp (i + 1) | ('x' | 'X') when i = 1 && String.get s 0 = '0' -> loop_hex (i + 1) | _ -> String.sub s sp (i - sp) in best_int (Int32.of_string (loop 0 0)) let parse_float s = let rec loop sp i = if i = String.length s then (if sp = 0 then s else String.sub s sp (i - sp)) else match String.unsafe_get s i with | ' ' when sp = i -> loop (sp + 1) (i + 1) | '0'..'9' | '-' | 'e' | 'E' | '.' -> loop sp (i + 1) | _ -> String.sub s sp (i - sp) in float_of_string (loop 0 0) let find_sub str sub start = let sublen = String.length sub in if sublen = 0 then 0 else let found = ref 0 in let len = String.length str in try for i = start to len - sublen do let j = ref 0 in while String.unsafe_get str (i + !j) = String.unsafe_get sub !j do incr j; if !j = sublen then begin found := i; raise Exit; end; done; done; raise Not_found with Exit -> !found let nargs = function | Fun0 _ -> 0 | Fun1 _ -> 1 | Fun2 _ -> 2 | Fun3 _ -> 3 | Fun4 _ -> 4 | Fun5 _ -> 5 | FunVar _ -> -1 let rec get_field o fid = let rec loop min max = if min < max then begin let mid = (min + max) lsr 1 in let cid, v = Array.unsafe_get o.ofields mid in if cid < fid then loop (mid + 1) max else if cid > fid then loop min mid else v end else match o.oproto with | None -> VNull | Some p -> get_field p fid in loop 0 (Array.length o.ofields) let set_field o fid v = let rec loop min max = let mid = (min + max) lsr 1 in if min < max then begin let cid, _ = Array.unsafe_get o.ofields mid in if cid < fid then loop (mid + 1) max else if cid > fid then loop min mid else Array.unsafe_set o.ofields mid (cid,v) end else let fields = Array.make (Array.length o.ofields + 1) (fid,v) in Array.blit o.ofields 0 fields 0 mid; Array.blit o.ofields mid fields (mid + 1) (Array.length o.ofields - mid); o.ofields <- fields in loop 0 (Array.length o.ofields) let rec remove_field o fid = let rec loop min max = let mid = (min + max) lsr 1 in if min < max then begin let cid, v = Array.unsafe_get o.ofields mid in if cid < fid then loop (mid + 1) max else if cid > fid then loop min mid else begin let fields = Array.make (Array.length o.ofields - 1) (fid,VNull) in Array.blit o.ofields 0 fields 0 mid; Array.blit o.ofields (mid + 1) fields mid (Array.length o.ofields - mid - 1); o.ofields <- fields; true end end else false in loop 0 (Array.length o.ofields) let rec get_field_opt o fid = let rec loop min max = if min < max then begin let mid = (min + max) lsr 1 in let cid, v = Array.unsafe_get o.ofields mid in if cid < fid then loop (mid + 1) max else if cid > fid then loop min mid else Some v end else match o.oproto with | None -> None | Some p -> get_field_opt p fid in loop 0 (Array.length o.ofields) let catch_errors ctx ?(final=(fun() -> ())) f = let n = DynArray.length ctx.stack in try let v = f() in final(); Some v with Runtime v -> pop ctx (DynArray.length ctx.stack - n); final(); let rec loop o = if o == ctx.error_proto then true else match o.oproto with None -> false | Some p -> loop p in (match v with | VObject o when loop o -> (match get_field o (hash "message"), get_field o (hash "pos") with | VObject msg, VAbstract (APos pos) -> (match get_field msg h_s with | VString msg -> raise (Typecore.Error (Typecore.Custom msg,pos)) | _ -> ()); | _ -> ()); | _ -> ()); raise (Error (ctx.do_string v,List.map (fun s -> make_pos s.cpos) ctx.callstack)) | Abort -> pop ctx (DynArray.length ctx.stack - n); final(); None let make_library fl = let h = Hashtbl.create 0 in List.iter (fun (n,f) -> Hashtbl.add h n f) fl; h (* ---------------------------------------------------------------------- *) (* NEKO INTEROP *) type primitive = (string * Extc.value * int) type neko_context = { load : string -> int -> primitive; call : primitive -> value list -> value; } let neko = let is_win = Sys.os_type = "Win32" || Sys.os_type = "Cygwin" in let neko = Extc.dlopen (if is_win then "neko.dll" else "libneko.so") in let null = Extc.dlint 0 in let neko = if Obj.magic neko == null && not is_win then Extc.dlopen "libneko.dylib" else neko in if Obj.magic neko == null then None else let load v = let s = Extc.dlsym neko v in if (Obj.magic s) == null then failwith ("Could not load neko." ^ v); s in ignore(Extc.dlcall0 (load "neko_global_init")); let vm = Extc.dlcall1 (load "neko_vm_alloc") null in ignore(Extc.dlcall1 (load "neko_vm_select") vm); let loader = Extc.dlcall2 (load "neko_default_loader") null null in let loadprim = Extc.dlcall2 (load "neko_val_field") loader (Extc.dlcall1 (load "neko_val_id") (Extc.dlstring "loadprim")) in let callN = load "neko_val_callN" in let callEx = load "neko_val_callEx" in let copy_string = load "neko_copy_string" in let alloc_root = load "neko_alloc_root" in let free_root = load "neko_free_root" in let alloc_root v = let r = Extc.dlcall1 alloc_root (Extc.dlint 1) in Extc.dlsetptr r v; r in let free_root r = ignore(Extc.dlcall1 free_root r) in ignore(alloc_root vm); ignore(alloc_root loader); ignore(alloc_root loadprim); let alloc_string s = Extc.dlcall2 copy_string (Extc.dlstring s) (Extc.dlint (String.length s)) in let alloc_int (i:int) : Extc.value = Obj.magic i in let loadprim n args = let exc = ref null in let vargs = [|alloc_string n;alloc_int args|] in let p = Extc.dlcall5 callEx loader loadprim (Obj.magic vargs) (Extc.dlint 2) (Obj.magic exc) in if !exc != null then failwith ("Failed to load " ^ n ^ ":" ^ string_of_int args); ignore(alloc_root p); (n,p,args) in let call_raw_prim (_,p,nargs) (args:Extc.value array) = Extc.dlcall3 callN p (Obj.magic args) (Extc.dlint nargs) in (* a bit tricky since load "val_true" does not work as expected on Windows *) let unser = try loadprim "std@unserialize" 2 with _ -> ("",null,0) in (* did we fail to load std.ndll ? *) if (match unser with ("",_,_) -> true | _ -> false) then None else let val_true = call_raw_prim unser [|alloc_string "T";loader|] in let val_false = call_raw_prim unser [|alloc_string "F";loader|] in let val_null = call_raw_prim unser [|alloc_string "N";loader|] in let is_64 = call_raw_prim (loadprim "std@sys_is64" 0) [||] == val_true in let alloc_i32, is_v2 = (try load "neko_alloc_int32", true with _ -> Obj.magic 0, false) in let alloc_i32 = if is_v2 then (fun i -> Extc.dlcall1 alloc_i32 (Extc.dlint32 i)) else (fun i -> alloc_int (Int32.to_int (if Int32.compare i Int32.zero < 0 then Int32.logand i 0x7FFFFFFFl else Int32.logor i 0x80000000l))) in let tag_bits = if is_v2 then 4 else 3 in let tag_mask = (1 lsl tag_bits) - 1 in let ptr_size = if is_64 then 8 else 4 in let val_field v i = Extc.dladdr v ((i + 1) * ptr_size) in let val_str v = Extc.dladdr v 4 in let val_fun_env v = Extc.dladdr v (8 + ptr_size) in (* alloc support *) let alloc_function = load "neko_alloc_function" in let alloc_array = load "neko_alloc_array" in let alloc_float = load "neko_alloc_float" in let alloc_object = load "neko_alloc_object" in let alloc_field = load "neko_alloc_field" in let alloc_abstract = load "neko_alloc_abstract" in let val_gc = load "neko_val_gc" in let val_field_name = load "neko_val_field_name" in let val_iter_fields = load "neko_val_iter_fields" in let gen_callback = Extc.dlcaml_callback 2 in (* roots *) let on_abstract_gc = Extc.dlcaml_callback 1 in let root_index = ref 0 in let roots = Hashtbl.create 0 in Callback.register "dlcallb1" (fun a -> let index : int = Obj.magic (Extc.dlptr (val_field a 1)) in Hashtbl.remove roots index; null ); (* wrapping *) let copy_string v = let head = Extc.dltoint (Extc.dlptr v) in let size = head asr tag_bits in let s = String.create size in Extc.dlmemcpy (Extc.dlstring s) (val_str v) size; s in let buffers = ref [] in let rec value_neko ?(obj=VNull) = function | VNull -> val_null | VBool b -> if b then val_true else val_false | VInt i -> alloc_int i | VAbstract (ANekoAbstract a) -> a | VAbstract (ANekoBuffer (VString buf)) -> let v = value_neko (VString buf) in buffers := (buf,v) :: !buffers; v | VString s -> let v = alloc_string s in (* make a copy *) ignore(copy_string v); v | VObject o as obj -> let vo = Extc.dlcall1 alloc_object null in Array.iter (fun (id,v) -> ignore(Extc.dlcall3 alloc_field vo (Extc.dlint id) (value_neko ~obj v)) ) o.ofields; vo | VClosure _ -> failwith "Closure not supported" | VFunction f -> let callb = Extc.dlcall3 alloc_function gen_callback (Extc.dlint (-1)) (Obj.magic "") in let index = !root_index in incr root_index; Hashtbl.add roots index (f,obj); let a = Extc.dlcall2 alloc_abstract null (Obj.magic index) in if Extc.dlptr (val_field a 1) != Obj.magic index then assert false; ignore(Extc.dlcall2 val_gc a on_abstract_gc); Extc.dlsetptr (val_fun_env callb) a; callb | VArray a -> let va = Extc.dlcall1 alloc_array (Extc.dlint (Array.length a)) in Array.iteri (fun i v -> Extc.dlsetptr (val_field va i) (value_neko v) ) a; va | VFloat f -> Extc.dlcall1 alloc_float (Obj.magic f) | VAbstract _ -> failwith "Abstract not supported" | VInt32 i -> alloc_i32 i in let obj_r = ref [] in let obj_fun = (fun v id -> obj_r := (v,id) :: !obj_r; val_null) in let rec neko_value (v:Extc.value) = if Obj.is_int (Obj.magic v) then VInt (Obj.magic v) else let head = Extc.dltoint (Extc.dlptr v) in match head land tag_mask with | 0 -> VNull | 2 -> VBool (v == val_true) | 3 -> VString (copy_string v) | 4 -> ignore(Extc.dlcall3 val_iter_fields v (Extc.dlcallback 2) (Obj.magic obj_fun)); let r = !obj_r in obj_r := []; let ctx = get_ctx() in let fields = List.rev_map (fun (v,id) -> let iid = Extc.dltoint id in if not (Hashtbl.mem ctx.fields_cache iid) then begin let name = copy_string (Extc.dlcall1 val_field_name id) in ignore(hash_field ctx name); end; iid, neko_value v ) r in VObject { ofields = Array.of_list fields; oproto = None } | 5 -> VArray (Array.init (head asr tag_bits) (fun i -> neko_value (Extc.dlptr (val_field v i)))) | 7 -> let r = alloc_root v in let a = ANekoAbstract v in Gc.finalise (fun _ -> free_root r) a; VAbstract a | t -> failwith ("Unsupported Neko value tag " ^ string_of_int t) in Callback.register "dlcallb2" (fun args nargs -> (* get back the VM env, which was set in value_neko *) let env = Extc.dlptr (Extc.dladdr vm (2 * ptr_size)) in (* extract the index stored in abstract data *) let index : int = Obj.magic (Extc.dlptr (val_field env 1)) in let f, obj = (try Hashtbl.find roots index with Not_found -> assert false) in let nargs = Extc.dltoint nargs in let rec loop i = if i = nargs then [] else neko_value (Extc.dlptr (Extc.dladdr args (i * ptr_size))) :: loop (i + 1) in let v = (get_ctx()).do_call obj (VFunction f) (loop 0) { psource = ""; pline = 0; } in value_neko v ); let callprim (n,p,nargs) args = let arr = Array.of_list (List.map value_neko args) in let exc = ref null in if Array.length arr <> nargs then failwith n; let ret = Extc.dlcall5 callEx val_null p (Obj.magic arr) (Extc.dlint nargs) (Obj.magic exc) in if !exc != null then raise (Runtime (neko_value !exc)); (match !buffers with | [] -> () | l -> buffers := []; (* copy back data *) List.iter (fun (buf,v) -> Extc.dlmemcpy (Extc.dlstring buf) (val_str v) (String.length buf); ) l); neko_value ret in Some { load = loadprim; call = callprim; } (* ---------------------------------------------------------------------- *) (* BUILTINS *) let builtins = let p = { psource = ""; pline = 0 } in let error() = raise Builtin_error in let vint = function | VInt n -> n | _ -> error() in let varray = function | VArray a -> a | _ -> error() in let vstring = function | VString s -> s | _ -> error() in let vobj = function | VObject o -> o | _ -> error() in let vfun = function | VFunction f -> f | VClosure (cl,f) -> FunVar (f cl) | _ -> error() in let vhash = function | VAbstract (AHash h) -> h | _ -> error() in let build_stack sl = let make p = let p = make_pos p in VArray [|VString p.Ast.pfile;VInt (Lexer.get_error_line p)|] in VArray (Array.of_list (List.map make sl)) in let do_closure args args2 = match args with | f :: obj :: args -> (get_ctx()).do_call obj f (args @ args2) p | _ -> assert false in let funcs = [ (* array *) "array", FunVar (fun vl -> VArray (Array.of_list vl)); "amake", Fun1 (fun v -> VArray (Array.create (vint v) VNull)); "acopy", Fun1 (fun a -> VArray (Array.copy (varray a))); "asize", Fun1 (fun a -> VInt (Array.length (varray a))); "asub", Fun3 (fun a p l -> VArray (Array.sub (varray a) (vint p) (vint l))); "ablit", Fun5 (fun dst dstp src p l -> Array.blit (varray src) (vint p) (varray dst) (vint dstp) (vint l); VNull ); "aconcat", Fun1 (fun arr -> let arr = Array.map varray (varray arr) in VArray (Array.concat (Array.to_list arr)) ); (* string *) "string", Fun1 (fun v -> VString ((get_ctx()).do_string v)); "smake", Fun1 (fun l -> VString (String.make (vint l) '\000')); "ssize", Fun1 (fun s -> VInt (String.length (vstring s))); "scopy", Fun1 (fun s -> VString (String.copy (vstring s))); "ssub", Fun3 (fun s p l -> VString (String.sub (vstring s) (vint p) (vint l))); "sget", Fun2 (fun s p -> try VInt (int_of_char (String.get (vstring s) (vint p))) with Invalid_argument _ -> VNull ); "sset", Fun3 (fun s p c -> let c = char_of_int ((vint c) land 0xFF) in try String.set (vstring s) (vint p) c; VInt (int_of_char c) with Invalid_argument _ -> VNull); "sblit", Fun5 (fun dst dstp src p l -> String.blit (vstring src) (vint p) (vstring dst) (vint dstp) (vint l); VNull ); "sfind", Fun3 (fun src pos pat -> try VInt (find_sub (vstring src) (vstring pat) (vint pos)) with Not_found -> VNull ); (* object *) "new", Fun1 (fun o -> match o with | VNull -> VObject { ofields = [||]; oproto = None } | VObject o -> VObject { ofields = Array.copy o.ofields; oproto = o.oproto } | _ -> error() ); "objget", Fun2 (fun o f -> match o with | VObject o -> get_field o (vint f) | _ -> VNull ); "objset", Fun3 (fun o f v -> match o with | VObject o -> set_field o (vint f) v; v | _ -> VNull ); "objcall", Fun3 (fun o f pl -> match o with | VObject oo -> (get_ctx()).do_call o (get_field oo (vint f)) (Array.to_list (varray pl)) p | _ -> VNull ); "objfield", Fun2 (fun o f -> match o with | VObject o -> let p = o.oproto in o.oproto <- None; let v = get_field_opt o (vint f) in o.oproto <- p; VBool (v <> None) | _ -> VBool false ); "objremove", Fun2 (fun o f -> VBool (remove_field (vobj o) (vint f)) ); "objfields", Fun1 (fun o -> VArray (Array.map (fun (fid,_) -> VInt fid) (vobj o).ofields) ); "hash", Fun1 (fun v -> VInt (hash_field (get_ctx()) (vstring v))); "fasthash", Fun1 (fun v -> VInt (hash (vstring v))); "field", Fun1 (fun v -> try VString (Hashtbl.find (get_ctx()).fields_cache (vint v)) with Not_found -> VNull ); "objsetproto", Fun2 (fun o p -> let o = vobj o in (match p with | VNull -> o.oproto <- None | VObject p -> o.oproto <- Some p | _ -> error()); VNull; ); "objgetproto", Fun1 (fun o -> match (vobj o).oproto with | None -> VNull | Some p -> VObject p ); (* function *) "nargs", Fun1 (fun f -> VInt (nargs (vfun f)) ); "call", Fun3 (fun f o args -> (get_ctx()).do_call o f (Array.to_list (varray args)) p ); "closure", FunVar (fun vl -> match vl with | VFunction f :: _ :: _ -> VClosure (vl, do_closure) | _ -> exc (VString "Can't create closure : value is not a function") ); "apply", FunVar (fun vl -> match vl with | f :: args -> let f = vfun f in VFunction (FunVar (fun args2 -> (get_ctx()).do_call VNull (VFunction f) (args @ args2) p)) | _ -> exc (VString "Invalid closure arguments number") ); "varargs", Fun1 (fun f -> match f with | VFunction (FunVar _) | VFunction (Fun1 _) | VClosure _ -> VFunction (FunVar (fun vl -> (get_ctx()).do_call VNull f [VArray (Array.of_list vl)] p)) | _ -> error() ); (* numbers *) (* skip iadd, isub, idiv, imult *) "isnan", Fun1 (fun f -> match f with | VFloat f -> VBool (f <> f) | _ -> VBool false ); "isinfinite", Fun1 (fun f -> match f with | VFloat f -> VBool (f = infinity || f = neg_infinity) | _ -> VBool false ); "int", Fun1 (fun v -> match v with | VInt _ | VInt32 _ -> v | VFloat f -> best_int (to_int f) | VString s -> (try parse_int s with _ -> VNull) | _ -> VNull ); "float", Fun1 (fun v -> match v with | VInt i -> VFloat (float_of_int i) | VInt32 i -> VFloat (Int32.to_float i) | VFloat _ -> v | VString s -> (try VFloat (parse_float s) with _ -> VNull) | _ -> VNull ); (* abstract *) "getkind", Fun1 (fun v -> match v with | VAbstract a -> VAbstract (AKind a) | VInt32 _ -> VAbstract (AKind AInt32Kind) | _ -> error() ); "iskind", Fun2 (fun v k -> match v, k with | VAbstract a, VAbstract (AKind k) -> VBool (Obj.tag (Obj.repr a) = Obj.tag (Obj.repr k)) | VInt32 _, VAbstract (AKind AInt32Kind) -> VBool true | _, VAbstract (AKind _) -> VBool false | _ -> error() ); (* hash *) "hkey", Fun1 (fun v -> VInt (Hashtbl.hash v)); "hnew", Fun1 (fun v -> VAbstract (AHash (match v with | VNull -> Hashtbl.create 0 | VInt n -> Hashtbl.create n | _ -> error())) ); "hresize", Fun1 (fun v -> VNull); "hget", Fun3 (fun h k cmp -> if cmp <> VNull then assert false; (try Hashtbl.find (vhash h) k with Not_found -> VNull) ); "hmem", Fun3 (fun h k cmp -> if cmp <> VNull then assert false; VBool (Hashtbl.mem (vhash h) k) ); "hremove", Fun3 (fun h k cmp -> if cmp <> VNull then assert false; let h = vhash h in let old = Hashtbl.mem h k in if old then Hashtbl.remove h k; VBool old ); "hset", Fun4 (fun h k v cmp -> if cmp <> VNull then assert false; let h = vhash h in let old = Hashtbl.mem h k in Hashtbl.replace h k v; VBool (not old); ); "hadd", Fun4 (fun h k v cmp -> if cmp <> VNull then assert false; let h = vhash h in let old = Hashtbl.mem h k in Hashtbl.add h k v; VBool (not old); ); "hiter", Fun2 (fun h f -> Hashtbl.iter (fun k v -> ignore ((get_ctx()).do_call VNull f [k;v] p)) (vhash h); VNull); "hcount", Fun1 (fun h -> VInt (Hashtbl.length (vhash h))); "hsize", Fun1 (fun h -> VInt (Hashtbl.length (vhash h))); (* misc *) "print", FunVar (fun vl -> List.iter (fun v -> let ctx = get_ctx() in let com = ctx.curapi.get_com() in com.print (ctx.do_string v) ) vl; VNull); "throw", Fun1 (fun v -> exc v); "rethrow", Fun1 (fun v -> let ctx = get_ctx() in ctx.callstack <- List.rev (List.map (fun p -> { cpos = p; cthis = ctx.vthis; cstack = DynArray.length ctx.stack; cenv = ctx.venv }) ctx.exc) @ ctx.callstack; exc v ); "istrue", Fun1 (fun v -> match v with | VNull | VInt 0 | VBool false | VInt32 0l -> VBool false | _ -> VBool true ); "not", Fun1 (fun v -> match v with | VNull | VInt 0 | VBool false | VInt32 0l -> VBool true | _ -> VBool false ); "typeof", Fun1 (fun v -> VInt (match v with | VNull -> 0 | VInt _ | VInt32 _ -> 1 | VFloat _ -> 2 | VBool _ -> 3 | VString _ -> 4 | VObject _ -> 5 | VArray _ -> 6 | VFunction _ | VClosure _ -> 7 | VAbstract _ -> 8) ); "compare", Fun2 (fun a b -> match (get_ctx()).do_compare a b with | CUndef -> VNull | CEq -> VInt 0 | CSup -> VInt 1 | CInf -> VInt (-1) ); "pcompare", Fun2 (fun a b -> assert false ); "excstack", Fun0 (fun() -> build_stack (get_ctx()).exc ); "callstack", Fun0 (fun() -> build_stack (List.map (fun s -> s.cpos) (get_ctx()).callstack) ); "version", Fun0 (fun() -> VInt 200 ); (* extra *) "use_neko_dll", Fun0 (fun() -> VBool (neko <> None) ); ] in let vals = [ "tnull", VInt 0; "tint", VInt 1; "tfloat", VInt 2; "tbool", VInt 3; "tstring", VInt 4; "tobject", VInt 5; "tarray", VInt 6; "tfunction", VInt 7; "tabstract", VInt 8; ] in let h = Hashtbl.create 0 in List.iter (fun (n,f) -> Hashtbl.add h n (VFunction f)) funcs; List.iter (fun (n,v) -> Hashtbl.add h n v) vals; h (* ---------------------------------------------------------------------- *) (* STD LIBRARY *) let std_lib = let p = { psource = ""; pline = 0 } in let error() = raise Builtin_error in let make_list l = let rec loop acc = function | [] -> acc | x :: l -> loop (VArray [|x;acc|]) l in loop VNull (List.rev l) in let num = function | VInt i -> float_of_int i | VInt32 i -> Int32.to_float i | VFloat f -> f | _ -> error() in let make_date f = VInt32 (Int32.of_float f) in let date = function | VInt32 i -> Int32.to_float i | VInt i -> float_of_int i | _ -> error() in let make_i32 i = VInt32 i in let int32 = function | VInt i -> Int32.of_int i | VInt32 i -> i | _ -> error() in let vint = function | VInt n -> n | _ -> error() in let vstring = function | VString s -> s | _ -> error() in let int32_addr h = let base = Int32.to_int (Int32.logand h 0xFFFFFFl) in let str = Printf.sprintf "%ld.%d.%d.%d" (Int32.shift_right_logical h 24) (base lsr 16) ((base lsr 8) land 0xFF) (base land 0xFF) in Unix.inet_addr_of_string str in let int32_op op = Fun2 (fun a b -> make_i32 (op (int32 a) (int32 b))) in make_library ([ (* math *) "math_atan2", Fun2 (fun a b -> VFloat (atan2 (num a) (num b))); "math_pow", Fun2 (fun a b -> VFloat ((num a) ** (num b))); "math_abs", Fun1 (fun v -> match v with | VInt i -> VInt (abs i) | VInt32 i -> VInt32 (Int32.abs i) | VFloat f -> VFloat (abs_float f) | _ -> error() ); "math_ceil", Fun1 (fun v -> match v with VInt _ | VInt32 _ -> v | _ -> best_int (to_int (ceil (num v)))); "math_floor", Fun1 (fun v -> match v with VInt _ | VInt32 _ -> v | _ -> best_int (to_int (floor (num v)))); "math_round", Fun1 (fun v -> match v with VInt _ | VInt32 _ -> v | _ -> best_int (to_int (floor (num v +. 0.5)))); "math_pi", Fun0 (fun() -> VFloat (4.0 *. atan 1.0)); "math_sqrt", Fun1 (fun v -> VFloat (sqrt (num v))); "math_atan", Fun1 (fun v -> VFloat (atan (num v))); "math_cos", Fun1 (fun v -> VFloat (cos (num v))); "math_sin", Fun1 (fun v -> VFloat (sin (num v))); "math_tan", Fun1 (fun v -> VFloat (tan (num v))); "math_log", Fun1 (fun v -> VFloat (Pervasives.log (num v))); "math_exp", Fun1 (fun v -> VFloat (exp (num v))); "math_acos", Fun1 (fun v -> VFloat (acos (num v))); "math_asin", Fun1 (fun v -> VFloat (asin (num v))); "math_fceil", Fun1 (fun v -> VFloat (ceil (num v))); "math_ffloor", Fun1 (fun v -> VFloat (floor (num v))); "math_fround", Fun1 (fun v -> VFloat (floor (num v +. 0.5))); "math_int", Fun1 (fun v -> match v with | VInt _ | VInt32 _ -> v | VFloat f -> best_int (to_int (if f < 0. then ceil f else floor f)) | _ -> error() ); (* buffer *) "buffer_new", Fun0 (fun() -> VAbstract (ABuffer (Buffer.create 0)) ); "buffer_add", Fun2 (fun b v -> match b with | VAbstract (ABuffer b) -> Buffer.add_string b ((get_ctx()).do_string v); VNull | _ -> error() ); "buffer_add_char", Fun2 (fun b v -> match b, v with | VAbstract (ABuffer b), VInt n when n >= 0 && n < 256 -> Buffer.add_char b (char_of_int n); VNull | _ -> error() ); "buffer_add_sub", Fun4 (fun b s p l -> match b, s, p, l with | VAbstract (ABuffer b), VString s, VInt p, VInt l -> (try Buffer.add_substring b s p l; VNull with _ -> error()) | _ -> error() ); "buffer_string", Fun1 (fun b -> match b with | VAbstract (ABuffer b) -> VString (Buffer.contents b) | _ -> error() ); "buffer_reset", Fun1 (fun b -> match b with | VAbstract (ABuffer b) -> Buffer.reset b; VNull; | _ -> error() ); (* date *) "date_now", Fun0 (fun () -> make_date (Unix.time()) ); "date_new", Fun1 (fun v -> make_date (match v with | VNull -> Unix.time() | VString s -> (match String.length s with | 19 -> let r = Str.regexp "^\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\) \\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)$" in if not (Str.string_match r s 0) then exc (VString ("Invalid date format : " ^ s)); let t = Unix.localtime (Unix.time()) in let t = { t with tm_year = int_of_string (Str.matched_group 1 s) - 1900; tm_mon = int_of_string (Str.matched_group 2 s) - 1; tm_mday = int_of_string (Str.matched_group 3 s); tm_hour = int_of_string (Str.matched_group 4 s); tm_min = int_of_string (Str.matched_group 5 s); tm_sec = int_of_string (Str.matched_group 6 s); } in fst (Unix.mktime t) | 10 -> assert false | 8 -> assert false | _ -> exc (VString ("Invalid date format : " ^ s))); | _ -> error()) ); "date_set_hour", Fun4 (fun d h m s -> let d = date d in let t = Unix.localtime d in make_date (fst (Unix.mktime { t with tm_hour = vint h; tm_min = vint m; tm_sec = vint s })) ); "date_set_day", Fun4 (fun d y m da -> let d = date d in let t = Unix.localtime d in make_date (fst (Unix.mktime { t with tm_year = vint y - 1900; tm_mon = vint m - 1; tm_mday = vint da })) ); "date_format", Fun2 (fun d fmt -> match fmt with | VNull -> let t = Unix.localtime (date d) in VString (Printf.sprintf "%.4d-%.2d-%.2d %.2d:%.2d:%.2d" (t.tm_year + 1900) (t.tm_mon + 1) t.tm_mday t.tm_hour t.tm_min t.tm_sec) | VString "%w" -> (* week day *) let t = Unix.localtime (date d) in VString (string_of_int t.tm_wday) | VString _ -> exc (VString "Custom date format is not supported") (* use native Haxe implementation *) | _ -> error() ); "date_get_hour", Fun1 (fun d -> let t = Unix.localtime (date d) in let o = obj (hash_field (get_ctx())) [ "h", VInt t.tm_hour; "m", VInt t.tm_min; "s", VInt t.tm_sec; ] in VObject o ); "date_get_day", Fun1 (fun d -> let t = Unix.localtime (date d) in let o = obj (hash_field (get_ctx())) [ "d", VInt t.tm_mday; "m", VInt (t.tm_mon + 1); "y", VInt (t.tm_year + 1900); ] in VObject o ); (* string *) "string_split", Fun2 (fun s d -> make_list (match s, d with | VString "", VString _ -> [VString ""] | VString s, VString "" -> Array.to_list (Array.init (String.length s) (fun i -> VString (String.make 1 (String.get s i)))) | VString s, VString d -> List.map (fun s -> VString s) (ExtString.String.nsplit s d) | _ -> error()) ); "url_encode", Fun1 (fun s -> let s = vstring s in let b = Buffer.create 0 in let hex = "0123456789ABCDEF" in for i = 0 to String.length s - 1 do let c = String.unsafe_get s i in match c with | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '-' | '.' -> Buffer.add_char b c | _ -> Buffer.add_char b '%'; Buffer.add_char b (String.unsafe_get hex (int_of_char c lsr 4)); Buffer.add_char b (String.unsafe_get hex (int_of_char c land 0xF)); done; VString (Buffer.contents b) ); "url_decode", Fun1 (fun s -> let s = vstring s in let b = Buffer.create 0 in let len = String.length s in let decode c = match c with | '0'..'9' -> Some (int_of_char c - int_of_char '0') | 'a'..'f' -> Some (int_of_char c - int_of_char 'a' + 10) | 'A'..'F' -> Some (int_of_char c - int_of_char 'A' + 10) | _ -> None in let rec loop i = if i = len then () else let c = String.unsafe_get s i in match c with | '%' -> let p1 = (try decode (String.get s (i + 1)) with _ -> None) in let p2 = (try decode (String.get s (i + 2)) with _ -> None) in (match p1, p2 with | Some c1, Some c2 -> Buffer.add_char b (char_of_int ((c1 lsl 4) lor c2)); loop (i + 3) | _ -> loop (i + 1)); | '+' -> Buffer.add_char b ' '; loop (i + 1) | c -> Buffer.add_char b c; loop (i + 1) in loop 0; VString (Buffer.contents b) ); "base_encode", Fun2 (fun s b -> match s, b with | VString s, VString "0123456789abcdef" when String.length s = 16 -> VString (Digest.to_hex s) | VString s, VString b -> if String.length b <> 64 then assert false; let tbl = Array.init 64 (String.unsafe_get b) in VString (Base64.str_encode ~tbl s) | _ -> error() ); "base_decode", Fun2 (fun s b -> let s = vstring s in let b = vstring b in if String.length b <> 64 then assert false; let tbl = Array.init 64 (String.unsafe_get b) in VString (Base64.str_decode ~tbl:(Base64.make_decoding_table tbl) s) ); "make_md5", Fun1 (fun s -> VString (Digest.string (vstring s)) ); (* sprintf *) (* int32 *) "int32_new", Fun1 (fun v -> match v with | VInt32 _ -> v | VInt i -> make_i32 (Int32.of_int i) | VFloat f -> make_i32 (Int32.of_float f) | _ -> error() ); "int32_to_int", Fun1 (fun v -> let v = int32 v in let i = Int32.to_int v in if Int32.compare (Int32.of_int i) v <> 0 then error(); VInt i ); "int32_to_float", Fun1 (fun v -> VFloat (Int32.to_float (int32 v)) ); "int32_compare", Fun2 (fun a b -> VInt (Int32.compare (int32 a) (int32 b)) ); "int32_add", int32_op Int32.add; "int32_sub", int32_op Int32.sub; "int32_mul", int32_op Int32.mul; "int32_div", int32_op Int32.div; "int32_shl", int32_op (fun a b -> Int32.shift_left a (Int32.to_int b)); "int32_shr", int32_op (fun a b -> Int32.shift_right a (Int32.to_int b)); "int32_ushr", int32_op (fun a b -> Int32.shift_right_logical a (Int32.to_int b)); "int32_mod", int32_op Int32.rem; "int32_or", int32_op Int32.logor; "int32_and", int32_op Int32.logand; "int32_xor", int32_op Int32.logxor; "int32_neg", Fun1 (fun v -> make_i32 (Int32.neg (int32 v))); "int32_complement", Fun1 (fun v -> make_i32 (Int32.lognot (int32 v))); (* misc *) "same_closure", Fun2 (fun a b -> VBool (match a, b with | VClosure (la,fa), VClosure (lb,fb) -> fa == fb && List.length la = List.length lb && List.for_all2 (fun a b -> (get_ctx()).do_compare a b = CEq) la lb | VFunction a, VFunction b -> a == b | _ -> false) ); "double_bytes", Fun2 (fun f big -> let f = (match f with VFloat f -> f | VInt i -> float_of_int i | _ -> error()) in match big with | VBool big -> let ch = IO.output_string() in if big then IO.BigEndian.write_double ch f else IO.write_double ch f; VString (IO.close_out ch) | _ -> error() ); "float_bytes", Fun2 (fun f big -> let f = (match f with VFloat f -> f | VInt i -> float_of_int i | _ -> error()) in match big with | VBool big -> let ch = IO.output_string() in let i = Int32.bits_of_float f in if big then IO.BigEndian.write_real_i32 ch i else IO.write_real_i32 ch i; VString (IO.close_out ch) | _ -> error() ); "double_of_bytes", Fun2 (fun s big -> match s, big with | VString s, VBool big when String.length s = 8 -> let ch = IO.input_string s in VFloat (if big then IO.BigEndian.read_double ch else IO.read_double ch) | _ -> error() ); "float_of_bytes", Fun2 (fun s big -> match s, big with | VString s, VBool big when String.length s = 4 -> let ch = IO.input_string s in VFloat (Int32.float_of_bits (if big then IO.BigEndian.read_real_i32 ch else IO.read_real_i32 ch)) | _ -> error() ); (* random *) "random_new", Fun0 (fun() -> VAbstract (ARandom (ref (Random.State.make_self_init())))); "random_set_seed", Fun2 (fun r s -> match r, s with | VAbstract (ARandom r), VInt seed -> r := Random.State.make [|seed|]; VNull | VAbstract (ARandom r), VInt32 seed -> r := Random.State.make [|Int32.to_int seed|]; VNull | _ -> error() ); "random_int", Fun2 (fun r s -> match r, s with | VAbstract (ARandom r), VInt max -> VInt (Random.State.int (!r) (if max <= 0 then 1 else max)) | _ -> error() ); "random_float", Fun1 (fun r -> match r with | VAbstract (ARandom r) -> VFloat (Random.State.float (!r) 1.0) | _ -> error() ); (* file *) "file_open", Fun2 (fun f r -> match f, r with | VString f, VString r -> let perms = 0o666 in VAbstract (match r with | "r" -> AFRead (open_in_gen [Open_rdonly] 0 f) | "rb" -> AFRead (open_in_gen [Open_rdonly;Open_binary] 0 f) | "w" -> AFWrite (open_out_gen [Open_wronly;Open_creat;Open_trunc] perms f) | "wb" -> AFWrite (open_out_gen [Open_wronly;Open_creat;Open_trunc;Open_binary] perms f) | "a" -> AFWrite (open_out_gen [Open_append] perms f) | "ab" -> AFWrite (open_out_gen [Open_append;Open_binary] perms f) | _ -> error()) | _ -> error() ); "file_close", Fun1 (fun f -> (match f with | VAbstract (AFRead f) -> close_in f | VAbstract (AFWrite f) -> close_out f | _ -> error()); VNull ); (* file_name *) "file_write", Fun4 (fun f s p l -> match f, s, p, l with | VAbstract (AFWrite f), VString s, VInt p, VInt l -> output f s p l; VInt l | _ -> error() ); "file_read", Fun4 (fun f s p l -> match f, s, p, l with | VAbstract (AFRead f), VString s, VInt p, VInt l -> let n = input f s p l in if n = 0 then exc (VArray [|VString "file_read"|]); VInt n | _ -> error() ); "file_write_char", Fun2 (fun f c -> match f, c with | VAbstract (AFWrite f), VInt c -> output_char f (char_of_int c); VNull | _ -> error() ); "file_read_char", Fun1 (fun f -> match f with | VAbstract (AFRead f) -> VInt (int_of_char (try input_char f with _ -> exc (VArray [|VString "file_read_char"|]))) | _ -> error() ); "file_seek", Fun3 (fun f pos mode -> match f, pos, mode with | VAbstract (AFRead f), VInt pos, VInt mode -> seek_in f (match mode with 0 -> pos | 1 -> pos_in f + pos | 2 -> in_channel_length f - pos | _ -> error()); VNull; | VAbstract (AFWrite f), VInt pos, VInt mode -> seek_out f (match mode with 0 -> pos | 1 -> pos_out f + pos | 2 -> out_channel_length f - pos | _ -> error()); VNull; | _ -> error() ); "file_tell", Fun1 (fun f -> match f with | VAbstract (AFRead f) -> VInt (pos_in f) | VAbstract (AFWrite f) -> VInt (pos_out f) | _ -> error() ); "file_eof", Fun1 (fun f -> match f with | VAbstract (AFRead f) -> VBool (try ignore(input_char f); seek_in f (pos_in f - 1); false with End_of_file -> true) | _ -> error() ); "file_flush", Fun1 (fun f -> (match f with | VAbstract (AFWrite f) -> flush f | _ -> error()); VNull ); "file_contents", Fun1 (fun f -> match f with | VString f -> VString (Std.input_file ~bin:true f) | _ -> error() ); "file_stdin", Fun0 (fun() -> VAbstract (AFRead Pervasives.stdin)); "file_stdout", Fun0 (fun() -> VAbstract (AFWrite Pervasives.stdout)); "file_stderr", Fun0 (fun() -> VAbstract (AFWrite Pervasives.stderr)); (* serialize *) (* TODO *) (* socket *) "socket_init", Fun0 (fun() -> VNull); "socket_new", Fun1 (fun v -> match v with | VBool b -> VAbstract (ASocket (Unix.socket PF_INET (if b then SOCK_DGRAM else SOCK_STREAM) 0)); | _ -> error() ); "socket_close", Fun1 (fun s -> match s with | VAbstract (ASocket s) -> Unix.close s; VNull | _ -> error() ); "socket_send_char", Fun2 (fun s c -> match s, c with | VAbstract (ASocket s), VInt c when c >= 0 && c <= 255 -> ignore(Unix.send s (String.make 1 (char_of_int c)) 0 1 []); VNull | _ -> error() ); "socket_send", Fun4 (fun s buf pos len -> match s, buf, pos, len with | VAbstract (ASocket s), VString buf, VInt pos, VInt len -> VInt (Unix.send s buf pos len []) | _ -> error() ); "socket_recv", Fun4 (fun s buf pos len -> match s, buf, pos, len with | VAbstract (ASocket s), VString buf, VInt pos, VInt len -> VInt (Unix.recv s buf pos len []) | _ -> error() ); "socket_recv_char", Fun1 (fun s -> match s with | VAbstract (ASocket s) -> let buf = String.make 1 '\000' in ignore(Unix.recv s buf 0 1 []); VInt (int_of_char (String.unsafe_get buf 0)) | _ -> error() ); "socket_write", Fun2 (fun s str -> match s, str with | VAbstract (ASocket s), VString str -> let pos = ref 0 in let len = ref (String.length str) in while !len > 0 do let k = Unix.send s str (!pos) (!len) [] in pos := !pos + k; len := !len - k; done; VNull | _ -> error() ); "socket_read", Fun1 (fun s -> match s with | VAbstract (ASocket s) -> let tmp = String.make 1024 '\000' in let buf = Buffer.create 0 in let rec loop() = let k = (try Unix.recv s tmp 0 1024 [] with Unix_error _ -> 0) in if k > 0 then begin Buffer.add_substring buf tmp 0 k; loop(); end in loop(); VString (Buffer.contents buf) | _ -> error() ); "host_resolve", Fun1 (fun s -> let h = (try Unix.gethostbyname (vstring s) with Not_found -> error()) in let addr = Unix.string_of_inet_addr h.h_addr_list.(0) in let a, b, c, d = Scanf.sscanf addr "%d.%d.%d.%d" (fun a b c d -> a,b,c,d) in VInt32 (Int32.logor (Int32.shift_left (Int32.of_int a) 24) (Int32.of_int (d lor (c lsl 8) lor (b lsl 16)))) ); "host_to_string", Fun1 (fun h -> match h with | VInt32 h -> VString (Unix.string_of_inet_addr (int32_addr h)); | _ -> error() ); "host_reverse", Fun1 (fun h -> match h with | VInt32 h -> VString (gethostbyaddr (int32_addr h)).h_name | _ -> error() ); "host_local", Fun0 (fun() -> VString (Unix.gethostname()) ); "socket_connect", Fun3 (fun s h p -> match s, h, p with | VAbstract (ASocket s), VInt32 h, VInt p -> Unix.connect s (ADDR_INET (int32_addr h,p)); VNull | _ -> error() ); "socket_listen", Fun2 (fun s l -> match s, l with | VAbstract (ASocket s), VInt l -> Unix.listen s l; VNull | _ -> error() ); "socket_set_timeout", Fun2 (fun s t -> match s with | VAbstract (ASocket s) -> let t = (match t with VNull -> 0. | VInt t -> float_of_int t | VFloat f -> f | _ -> error()) in Unix.setsockopt_float s SO_RCVTIMEO t; Unix.setsockopt_float s SO_SNDTIMEO t; VNull | _ -> error() ); "socket_shutdown", Fun3 (fun s r w -> match s, r, w with | VAbstract (ASocket s), VBool r, VBool w -> Unix.shutdown s (match r, w with true, true -> SHUTDOWN_ALL | true, false -> SHUTDOWN_RECEIVE | false, true -> SHUTDOWN_SEND | _ -> error()); VNull | _ -> error() ); (* TODO : select, bind, accept, peer, host *) (* poll_alloc, poll : not planned *) (* system *) "get_env", Fun1 (fun v -> try VString (Unix.getenv (vstring v)) with _ -> VNull ); "put_env", Fun2 (fun e v -> Unix.putenv (vstring e) (vstring v); VNull ); "sys_sleep", Fun1 (fun f -> match f with | VFloat f -> ignore(Unix.select [] [] [] f); VNull | _ -> error() ); "set_time_locale", Fun1 (fun l -> match l with | VString s -> VBool false (* always fail *) | _ -> error() ); "get_cwd", Fun0 (fun() -> let dir = Unix.getcwd() in let l = String.length dir in VString (if l = 0 then "./" else match dir.[l - 1] with '/' | '\\' -> dir | _ -> dir ^ "/") ); "set_cwd", Fun1 (fun s -> Unix.chdir (vstring s); VNull; ); "sys_string", Fun0 (fun() -> VString (match Sys.os_type with | "Unix" -> "Linux" | "Win32" | "Cygwin" -> "Windows" | s -> s) ); "sys_is64", Fun0 (fun() -> VBool (Sys.word_size = 64) ); "sys_command", Fun1 (fun cmd -> VInt (((get_ctx()).curapi.get_com()).run_command (vstring cmd)) ); "sys_exit", Fun1 (fun code -> if (get_ctx()).curapi.use_cache() then raise Typecore.Fatal_error; exit (vint code); ); "sys_exists", Fun1 (fun file -> VBool (Sys.file_exists (vstring file)) ); "file_delete", Fun1 (fun file -> Sys.remove (vstring file); VNull; ); "sys_rename", Fun2 (fun file target -> Sys.rename (vstring file) (vstring target); VNull; ); "sys_stat", Fun1 (fun file -> let s = Unix.stat (vstring file) in VObject (obj (hash_field (get_ctx())) [ "gid", VInt s.st_gid; "uid", VInt s.st_uid; "atime", VInt32 (Int32.of_float s.st_atime); "mtime", VInt32 (Int32.of_float s.st_mtime); "ctime", VInt32 (Int32.of_float s.st_ctime); "dev", VInt s.st_dev; "ino", VInt s.st_ino; "nlink", VInt s.st_nlink; "rdev", VInt s.st_rdev; "size", VInt s.st_size; "mode", VInt s.st_perm; ]) ); "sys_file_type", Fun1 (fun file -> VString (match (Unix.stat (vstring file)).st_kind with | S_REG -> "file" | S_DIR -> "dir" | S_CHR -> "char" | S_BLK -> "block" | S_LNK -> "symlink" | S_FIFO -> "fifo" | S_SOCK -> "sock") ); "sys_create_dir", Fun2 (fun dir mode -> Unix.mkdir (vstring dir) (vint mode); VNull ); "sys_remove_dir", Fun1 (fun dir -> Unix.rmdir (vstring dir); VNull; ); "sys_time", Fun0 (fun() -> VFloat (Unix.gettimeofday()) ); "sys_cpu_time", Fun0 (fun() -> VFloat (Sys.time()) ); "sys_read_dir", Fun1 (fun dir -> let d = Sys.readdir (vstring dir) in let rec loop acc i = if i < 0 then acc else loop (VArray [|VString d.(i);acc|]) (i - 1) in loop VNull (Array.length d - 1) ); "file_full_path", Fun1 (fun file -> VString (try Extc.get_full_path (vstring file) with _ -> error()) ); "sys_exe_path", Fun0 (fun() -> VString (Extc.executable_path()) ); "sys_env", Fun0 (fun() -> let env = Unix.environment() in let rec loop acc i = if i < 0 then acc else let e, v = ExtString.String.split "=" env.(i) in loop (VArray [|VString e;VString v;acc|]) (i - 1) in loop VNull (Array.length env - 1) ); "sys_getch", Fun1 (fun echo -> match echo with | VBool b -> VInt (Extc.getch b) | _ -> error() ); "sys_get_pid", Fun0 (fun() -> VInt (Unix.getpid()) ); (* utf8 *) "utf8_buf_alloc", Fun1 (fun v -> VAbstract (AUtf8 (UTF8.Buf.create (vint v))) ); "utf8_buf_add", Fun2 (fun b c -> match b with | VAbstract (AUtf8 buf) -> UTF8.Buf.add_char buf (UChar.chr_of_uint (vint c)); VNull | _ -> error() ); "utf8_buf_content", Fun1 (fun b -> match b with | VAbstract (AUtf8 buf) -> VString (UTF8.Buf.contents buf); | _ -> error() ); "utf8_buf_length", Fun1 (fun b -> match b with | VAbstract (AUtf8 buf) -> VInt (UTF8.length (UTF8.Buf.contents buf)); | _ -> error() ); "utf8_buf_size", Fun1 (fun b -> match b with | VAbstract (AUtf8 buf) -> VInt (String.length (UTF8.Buf.contents buf)); | _ -> error() ); "utf8_validate", Fun1 (fun s -> VBool (try UTF8.validate (vstring s); true with UTF8.Malformed_code -> false) ); "utf8_length", Fun1 (fun s -> VInt (UTF8.length (vstring s)) ); "utf8_sub", Fun3 (fun s p l -> let buf = UTF8.Buf.create 0 in let pos = ref (-1) in let p = vint p and l = vint l in UTF8.iter (fun c -> incr pos; if !pos >= p && !pos < p + l then UTF8.Buf.add_char buf c; ) (vstring s); if !pos < p + l then error(); VString (UTF8.Buf.contents buf) ); "utf8_get", Fun2 (fun s p -> VInt (UChar.uint_code (try UTF8.look (vstring s) (vint p) with _ -> error())) ); "utf8_iter", Fun2 (fun s f -> let ctx = get_ctx() in UTF8.iter (fun c -> ignore(ctx.do_call VNull f [VInt (UChar.uint_code c)] p); ) (vstring s); VNull; ); "utf8_compare", Fun2 (fun s1 s2 -> VInt (UTF8.compare (vstring s1) (vstring s2)) ); (* xml *) "parse_xml", (match neko with | None -> Fun2 (fun str o -> match str, o with | VString str, VObject events -> let ctx = get_ctx() in let p = { psource = "parse_xml"; pline = 0 } in let xml = get_field events (hash "xml") in let don = get_field events (hash "done") in let pcdata = get_field events (hash "pcdata") in (* Since we use the Xml parser, we don't have support for - CDATA - comments, prolog, doctype (allowed but skipped) let cdata = get_field events (hash "cdata") in let comment = get_field events (hash "comment") in *) let rec loop = function | Xml.Element (node, attribs, children) -> ignore(ctx.do_call o xml [VString node;VObject (obj (hash_field ctx) (List.map (fun (a,v) -> a, VString v) attribs))] p); List.iter loop children; ignore(ctx.do_call o don [] p); | Xml.PCData s -> ignore(ctx.do_call o pcdata [VString s] p); in let x = XmlParser.make() in XmlParser.check_eof x false; loop (try XmlParser.parse x (XmlParser.SString str) with Xml.Error e -> failwith ("Parser failure (" ^ Xml.error e ^ ")") | e -> failwith ("Parser failure (" ^ Printexc.to_string e ^ ")")); VNull | _ -> error()) | Some neko -> let parse_xml = neko.load "std@parse_xml" 2 in Fun2 (fun str o -> neko.call parse_xml [str;o]) ); (* memory, module, thread : not planned *) ] (* process *) @ (match neko with | None -> [] | Some neko -> let p_run = neko.load "std@process_run" 2 in let p_stdout_read = neko.load "std@process_stdout_read" 4 in let p_stderr_read = neko.load "std@process_stderr_read" 4 in let p_stdin_write = neko.load "std@process_stdin_write" 4 in let p_stdin_close = neko.load "std@process_stdin_close" 1 in let p_exit = neko.load "std@process_exit" 1 in let p_pid = neko.load "std@process_pid" 1 in let p_close = neko.load "std@process_close" 1 in let win_ec = (try Some (neko.load "std@win_env_changed" 0) with _ -> None) in [ "process_run", (Fun2 (fun a b -> neko.call p_run [a;b])); "process_stdout_read", (Fun4 (fun a b c d -> neko.call p_stdout_read [a;VAbstract (ANekoBuffer b);c;d])); "process_stderr_read", (Fun4 (fun a b c d -> neko.call p_stderr_read [a;VAbstract (ANekoBuffer b);c;d])); "process_stdin_write", (Fun4 (fun a b c d -> neko.call p_stdin_write [a;b;c;d])); "process_stdin_close", (Fun1 (fun p -> neko.call p_stdin_close [p])); "process_exit", (Fun1 (fun p -> neko.call p_exit [p])); "process_pid", (Fun1 (fun p -> neko.call p_pid [p])); "process_close", (Fun1 (fun p -> neko.call p_close [p])); "win_env_changed", (Fun0 (fun() -> match win_ec with None -> error() | Some f -> neko.call f [])); ])) (* ---------------------------------------------------------------------- *) (* REGEXP LIBRARY *) let reg_lib = let error() = raise Builtin_error in (* try to load regexp first : we might fail if pcre is not installed *) let neko = (match neko with | None -> None | Some neko -> (try ignore(neko.load "regexp@regexp_new_options" 2); Some neko with _ -> None) ) in match neko with | None -> make_library [ (* regexp_new : deprecated *) "regexp_new_options", Fun2 (fun str opt -> match str, opt with | VString str, VString opt -> let case_sensitive = ref true in List.iter (function | 'm' -> () (* always ON ? *) | 'i' -> case_sensitive := false | c -> failwith ("Unsupported regexp option '" ^ String.make 1 c ^ "'") ) (ExtString.String.explode opt); let buf = Buffer.create 0 in let rec loop prev esc = function | [] -> () | c :: l when esc -> (match c with | 'n' -> Buffer.add_char buf '\n' | 'r' -> Buffer.add_char buf '\r' | 't' -> Buffer.add_char buf '\t' | 'd' -> Buffer.add_string buf "[0-9]" | '\\' -> Buffer.add_string buf "\\\\" | '(' | ')' -> Buffer.add_char buf c | '1'..'9' | '+' | '$' | '^' | '*' | '?' | '.' | '[' | ']' -> Buffer.add_char buf '\\'; Buffer.add_char buf c; | _ -> failwith ("Unsupported escaped char '" ^ String.make 1 c ^ "'")); loop c false l | c :: l -> match c with | '\\' -> loop prev true l | '(' | '|' | ')' -> Buffer.add_char buf '\\'; Buffer.add_char buf c; loop c false l | '?' when prev = '(' && (match l with ':' :: _ -> true | _ -> false) -> failwith "Non capturing groups '(?:' are not supported in macros" | '?' when prev = '*' -> failwith "Ungreedy *? are not supported in macros" | _ -> Buffer.add_char buf c; loop c false l in loop '\000' false (ExtString.String.explode str); let str = Buffer.contents buf in let r = { r = if !case_sensitive then Str.regexp str else Str.regexp_case_fold str; r_string = ""; r_groups = [||]; } in VAbstract (AReg r) | _ -> error() ); "regexp_match", Fun4 (fun r str pos len -> match r, str, pos, len with | VAbstract (AReg r), VString str, VInt pos, VInt len -> let nstr, npos, delta = (if len = String.length str - pos then str, pos, 0 else String.sub str pos len, 0, pos) in (try ignore(Str.search_forward r.r nstr npos); let rec loop n = if n = 9 then [] else try (Some (Str.group_beginning n + delta, Str.group_end n + delta)) :: loop (n + 1) with Not_found -> None :: loop (n + 1) | Invalid_argument _ -> [] in r.r_string <- str; r.r_groups <- Array.of_list (loop 0); VBool true; with Not_found -> VBool false) | _ -> error() ); "regexp_matched", Fun2 (fun r n -> match r, n with | VAbstract (AReg r), VInt n -> (match (try r.r_groups.(n) with _ -> failwith ("Invalid group " ^ string_of_int n)) with | None -> VNull | Some (pos,pend) -> VString (String.sub r.r_string pos (pend - pos))) | _ -> error() ); "regexp_matched_pos", Fun2 (fun r n -> match r, n with | VAbstract (AReg r), VInt n -> (match (try r.r_groups.(n) with _ -> failwith ("Invalid group " ^ string_of_int n)) with | None -> VNull | Some (pos,pend) -> VObject (obj (hash_field (get_ctx())) ["pos",VInt pos;"len",VInt (pend - pos)])) | _ -> error() ); (* regexp_replace : not used by Haxe *) (* regexp_replace_all : not used by Haxe *) (* regexp_replace_fun : not used by Haxe *) ] | Some neko -> let regexp_new_options = neko.load "regexp@regexp_new_options" 2 in let regexp_match = neko.load "regexp@regexp_match" 4 in let regexp_matched = neko.load "regexp@regexp_matched" 2 in let regexp_matched_pos = neko.load "regexp@regexp_matched_pos" 2 in make_library [ "regexp_new_options", Fun2 (fun str opt -> neko.call regexp_new_options [str;opt]); "regexp_match", Fun4 (fun r str pos len -> neko.call regexp_match [r;str;pos;len]); "regexp_matched", Fun2 (fun r n -> neko.call regexp_matched [r;n]); "regexp_matched_pos", Fun2 (fun r n -> neko.call regexp_matched_pos [r;n]); ] (* ---------------------------------------------------------------------- *) (* ZLIB LIBRARY *) let z_lib = let error() = raise Builtin_error in make_library [ "inflate_init", Fun1 (fun f -> let z = Extc.zlib_inflate_init2 (match f with VNull -> 15 | VInt i -> i | _ -> error()) in VAbstract (AZipI { z = z; z_flush = Extc.Z_NO_FLUSH }) ); "deflate_init", Fun1 (fun f -> let z = Extc.zlib_deflate_init (match f with VInt i -> i | _ -> error()) in VAbstract (AZipD { z = z; z_flush = Extc.Z_NO_FLUSH }) ); "deflate_end", Fun1 (fun z -> match z with | VAbstract (AZipD z) -> Extc.zlib_deflate_end z.z; VNull; | _ -> error() ); "inflate_end", Fun1 (fun z -> match z with | VAbstract (AZipI z) -> Extc.zlib_inflate_end z.z; VNull; | _ -> error() ); "set_flush_mode", Fun2 (fun z f -> match z, f with | VAbstract (AZipI z | AZipD z), VString s -> z.z_flush <- (match s with | "NO" -> Extc.Z_NO_FLUSH | "SYNC" -> Extc.Z_SYNC_FLUSH | "FULL" -> Extc.Z_FULL_FLUSH | "FINISH" -> Extc.Z_FINISH | "BLOCK" -> Extc.Z_PARTIAL_FLUSH | _ -> error()); VNull; | _ -> error() ); "inflate_buffer", Fun5 (fun z src pos dst dpos -> match z, src, pos, dst, dpos with | VAbstract (AZipI z), VString src, VInt pos, VString dst, VInt dpos -> let r = Extc.zlib_inflate z.z src pos (String.length src - pos) dst dpos (String.length dst - dpos) z.z_flush in VObject (obj (hash_field (get_ctx())) [ "done", VBool r.Extc.z_finish; "read", VInt r.Extc.z_read; "write", VInt r.Extc.z_wrote; ]) | _ -> error() ); "deflate_buffer", Fun5 (fun z src pos dst dpos -> match z, src, pos, dst, dpos with | VAbstract (AZipD z), VString src, VInt pos, VString dst, VInt dpos -> let r = Extc.zlib_deflate z.z src pos (String.length src - pos) dst dpos (String.length dst - dpos) z.z_flush in VObject (obj (hash_field (get_ctx())) [ "done", VBool r.Extc.z_finish; "read", VInt r.Extc.z_read; "write", VInt r.Extc.z_wrote; ]) | _ -> error() ); "deflate_bound", Fun2 (fun z size -> match z, size with | VAbstract (AZipD z), VInt size -> VInt (size + 1024) | _ -> error() ); ] (* ---------------------------------------------------------------------- *) (* MACRO LIBRARY *) let macro_lib = let error() = raise Builtin_error in let ccom() = (get_ctx()).curapi.get_com() in make_library [ "curpos", Fun0 (fun() -> VAbstract (APos (get_ctx()).curapi.pos)); "error", Fun2 (fun msg p -> match msg, p with | VString s, VAbstract (APos p) -> (ccom()).Common.error s p; raise Abort | _ -> error() ); "warning", Fun2 (fun msg p -> match msg, p with | VString s, VAbstract (APos p) -> (ccom()).warning s p; VNull; | _ -> error() ); "class_path", Fun0 (fun() -> VArray (Array.of_list (List.map (fun s -> VString s) (ccom()).class_path)); ); "resolve", Fun1 (fun file -> match file with | VString s -> VString (try Common.find_file (ccom()) s with Not_found -> failwith ("File not found '" ^ s ^ "'")) | _ -> error(); ); "define", Fun1 (fun s -> match s with | VString s -> Common.raw_define (ccom()) s; VNull | _ -> error(); ); "defined", Fun1 (fun s -> match s with | VString s -> VBool (Common.raw_defined (ccom()) s) | _ -> error(); ); "defined_value", Fun1 (fun s -> match s with | VString s -> (try VString (Common.raw_defined_value (ccom()) s) with Not_found -> VNull) | _ -> error(); ); "get_type", Fun1 (fun s -> match s with | VString s -> (match (get_ctx()).curapi.get_type s with | None -> failwith ("Type not found '" ^ s ^ "'") | Some t -> encode_type t) | _ -> error() ); "get_module", Fun1 (fun s -> match s with | VString s -> enc_array (List.map encode_type ((get_ctx()).curapi.get_module s)) | _ -> error() ); "on_generate", Fun1 (fun f -> match f with | VFunction (Fun1 _) -> let ctx = get_ctx() in ctx.curapi.on_generate (fun tl -> ignore(catch_errors ctx (fun() -> ctx.do_call VNull f [enc_array (List.map encode_type tl)] null_pos)); ); VNull | _ -> error() ); "on_type_not_found", Fun1 (fun f -> match f with | VFunction (Fun1 _) -> let ctx = get_ctx() in ctx.curapi.on_type_not_found (fun path -> ctx.do_call VNull f [enc_string path] null_pos ); VNull | _ -> error() ); "parse", Fun3 (fun s p b -> match s, p, b with | VString s, VAbstract (APos p), VBool b -> encode_expr ((get_ctx()).curapi.parse_string s p b) | _ -> error() ); "make_expr", Fun2 (fun v p -> match p with | VAbstract (APos p) -> let h_enum = hash "__enum__" and h_et = hash "__et__" and h_ct = hash "__ct__" in let h_tag = hash "tag" and h_args = hash "args" in let h_length = hash "length" in let ctx = get_ctx() in let error v = failwith ("Unsupported value " ^ ctx.do_string v) in let make_path t = let rec loop = function | [] -> assert false | [name] -> (Ast.EConst (Ast.Ident name),p) | name :: l -> (Ast.EField (loop l,name),p) in let t = t_infos t in loop (List.rev (if t.mt_module.m_path = t.mt_path then fst t.mt_path @ [snd t.mt_path] else fst t.mt_module.m_path @ [snd t.mt_module.m_path;snd t.mt_path])) in let rec loop = function | VNull -> (Ast.EConst (Ast.Ident "null"),p) | VBool b -> (Ast.EConst (Ast.Ident (if b then "true" else "false")),p) | VInt i -> (Ast.EConst (Ast.Int (string_of_int i)),p) | VInt32 i -> (Ast.EConst (Ast.Int (Int32.to_string i)),p) | VFloat f -> (Ast.EConst (Ast.Float (string_of_float f)),p) | VAbstract (APos p) -> (Ast.EObjectDecl ( ("fileName" , (Ast.EConst (Ast.String p.Ast.pfile) , p)) :: ("lineNumber" , (Ast.EConst (Ast.Int (string_of_int (Lexer.get_error_line p))),p)) :: ("className" , (Ast.EConst (Ast.String ("")),p)) :: [] ), p) | VString _ | VArray _ | VAbstract _ | VFunction _ | VClosure _ as v -> error v | VObject o as v -> match o.oproto with | None -> (match get_field_opt o h_ct with | Some (VAbstract (ATDecl t)) -> make_path t | _ -> let fields = List.fold_left (fun acc (fid,v) -> (field_name ctx fid, loop v) :: acc) [] (Array.to_list o.ofields) in (Ast.EObjectDecl fields, p)) | Some proto -> match get_field_opt proto h_enum, get_field_opt o h_a, get_field_opt o h_s, get_field_opt o h_length with | _, Some (VArray a), _, Some (VInt len) -> (Ast.EArrayDecl (List.map loop (Array.to_list (Array.sub a 0 len))),p) | _, _, Some (VString s), _ -> (Ast.EConst (Ast.String s),p) | Some (VObject en), _, _, _ -> (match get_field en h_et, get_field o h_tag with | VAbstract (ATDecl t), VString tag -> let e = (Ast.EField (make_path t,tag),p) in (match get_field_opt o h_args with | Some (VArray args) -> let args = List.map loop (Array.to_list args) in (Ast.ECall (e,args),p) | _ -> e) | _ -> error v) | _ -> error v in encode_expr (loop v) | _ -> error() ); "signature", Fun1 (fun v -> let cache = ref [] in let cache_count = ref 0 in let hfiles = Hashtbl.create 0 in let get_file f = try Hashtbl.find hfiles f with Not_found -> let ff = Common.unique_full_path f in Hashtbl.add hfiles f ff; ff in let do_cache (v:value) (v2:value) = (* tricky : we need to have a quick not-linear cache based on objects address but we can't use address since the GC might be triggered here. Instead let's mutate the object temporary. *) let vt = Obj.repr v in let old = Obj.tag vt in let old_val = Obj.field vt 0 in let abstract_tag = 7 in Obj.set_tag vt abstract_tag; Obj.set_field vt 0 (Obj.repr (ACacheRef v2)); cache := (vt,old,old_val) :: !cache; incr cache_count in let rec loop v = match v with | VNull | VBool _ | VInt _ | VFloat _ | VString _ | VInt32 _ -> v | VObject o -> let o2 = { ofields = [||]; oproto = None } in let v2 = VObject o2 in do_cache v v2; Array.iter (fun (f,v) -> if f <> h_class then set_field o2 f (loop v)) o.ofields; (match o.oproto with | None -> () | Some p -> (match loop (VObject p) with VObject p2 -> o2.oproto <- Some p2 | _ -> assert false)); v2 | VArray a -> let a2 = Array.create (Array.length a) VNull in let v2 = VArray a2 in do_cache v v2; for i = 0 to Array.length a - 1 do a2.(i) <- loop a.(i); done; v2 | VFunction f -> let v2 = VFunction (Obj.magic !cache_count) in do_cache v v2; v2 | VClosure (vl,f) -> let rl = ref [] in let v2 = VClosure (Obj.magic rl, Obj.magic !cache_count) in do_cache v v2; rl := List.map loop vl; v2 | VAbstract (APos p) -> VAbstract (APos { p with Ast.pfile = get_file p.Ast.pfile }) | VAbstract (ACacheRef v) -> v | VAbstract (AHash h) -> let h2 = Hashtbl.create 0 in let v2 = VAbstract (AHash h2) in do_cache v v2; Hashtbl.iter (fun k v -> Hashtbl.add h2 k (loop v)) h2; v2 | VAbstract _ -> let v2 = VAbstract (Obj.magic !cache_count) in do_cache v v2; v2 in let v = loop v in (* restore *) List.iter (fun (vt,tag,field) -> Obj.set_tag vt tag; Obj.set_field vt 0 field; ) !cache; VString (Digest.to_hex (Digest.string (Marshal.to_string v [Marshal.Closures]))) ); "to_complex", Fun1 (fun v -> try encode_complex_type (make_complex_type (decode_type v)) with Exit -> VNull ); "unify", Fun2 (fun t1 t2 -> try Type.unify (decode_type t1) (decode_type t2); VBool true with Unify_error _ -> VBool false ); "typeof", Fun1 (fun v -> encode_type ((get_ctx()).curapi.typeof (decode_expr v)) ); "s_type", Fun1 (fun v -> VString (Type.s_type (print_context()) (decode_type v)) ); "display", Fun1 (fun v -> match v with | VString s -> VString ((get_ctx()).curapi.get_display s) | _ -> error() ); "allow_package", Fun1 (fun v -> match v with | VString s -> (get_ctx()).curapi.allow_package s; VNull | _ -> error()); "type_patch", Fun4 (fun t f s v -> let p = (get_ctx()).curapi.type_patch in (match t, f, s, v with | VString t, VString f, VBool s, VString v -> p t f s (Some v) | VString t, VString f, VBool s, VNull -> p t f s None | _ -> error()); VNull ); "meta_patch", Fun4 (fun m t f s -> let p = (get_ctx()).curapi.meta_patch in (match m, t, f, s with | VString m, VString t, VString f, VBool s -> p m t (Some f) s | VString m, VString t, VNull, VBool s -> p m t None s | _ -> error()); VNull ); "custom_js", Fun1 (fun f -> match f with | VFunction (Fun1 _) -> let ctx = get_ctx() in ctx.curapi.set_js_generator (fun api -> ignore(catch_errors ctx (fun() -> ctx.do_call VNull f [api] null_pos)); ); VNull | _ -> error() ); "get_pos_infos", Fun1 (fun p -> match p with | VAbstract (APos p) -> VObject (obj (hash_field (get_ctx())) ["min",VInt p.Ast.pmin;"max",VInt p.Ast.pmax;"file",VString p.Ast.pfile]) | _ -> error() ); "make_pos", Fun3 (fun min max file -> match min, max, file with | VInt min, VInt max, VString file -> VAbstract (APos { Ast.pmin = min; Ast.pmax = max; Ast.pfile = file }) | _ -> error() ); "add_resource", Fun2 (fun name data -> match name, data with | VString name, VString data -> Hashtbl.replace (ccom()).resources name data; let m = (get_ctx()).curapi.current_module() in m.m_extra.m_binded_res <- PMap.add name data m.m_extra.m_binded_res; VNull | _ -> error() ); "local_type", Fun0 (fun() -> match (get_ctx()).curapi.get_local_type() with | None -> VNull | Some t -> encode_type t ); "local_method", Fun0 (fun() -> VString ((get_ctx()).curapi.get_local_method()) ); "local_using", Fun0 (fun() -> enc_array (List.map encode_clref ((get_ctx()).curapi.get_local_using())) ); "local_vars", Fun0 (fun() -> let vars = (get_ctx()).curapi.get_local_vars() in let h = Hashtbl.create 0 in PMap.iter (fun n v -> Hashtbl.replace h (VString n) (encode_type v.v_type)) vars; enc_hash h ); "follow", Fun2 (fun v once -> let t = decode_type v in let follow_once t = match t with | TMono r -> (match !r with | None -> t | Some t -> t) | TAbstract _ | TEnum _ | TInst _ | TFun _ | TAnon _ | TDynamic _ -> t | TType (t,tl) -> apply_params t.t_types tl t.t_type | TLazy f -> (!f)() in encode_type (match once with VNull | VBool false -> follow t | VBool true -> follow_once t | _ -> error()) ); "build_fields", Fun0 (fun() -> (get_ctx()).curapi.get_build_fields() ); "define_type", Fun1 (fun v -> (get_ctx()).curapi.define_type v; VNull ); "add_class_path", Fun1 (fun v -> match v with | VString cp -> let com = ccom() in com.class_path <- (Common.normalize_path cp) :: com.class_path; VNull | _ -> error() ); "add_native_lib", Fun1 (fun v -> match v with | VString file -> let com = ccom() in (match com.platform with | Flash -> Genswf.add_swf_lib com file false | _ -> failwith "Unsupported platform"); VNull | _ -> error() ); "module_dependency", Fun2 (fun m file -> match m, file with | VString m, VString file -> (get_ctx()).curapi.module_dependency m file false; VNull | _ -> error() ); "module_reuse_call", Fun2 (fun m mcall -> match m, mcall with | VString m, VString mcall -> (get_ctx()).curapi.module_dependency m mcall true; VNull | _ -> error() ); "get_typed_expr", Fun1 (fun e -> match e with | VAbstract (ATExpr e) -> encode_expr (make_ast e) | _ -> error() ); "get_output", Fun0 (fun() -> VString (ccom()).file ); "set_output", Fun1 (fun s -> match s with | VString s -> (ccom()).file <- s; VNull | _ -> error() ); "get_display_pos", Fun0 (fun() -> let p = !Parser.resume_display in if p = Ast.null_pos then VNull else VObject (obj (hash_field (get_ctx())) ["file",VString p.Ast.pfile;"pos",VInt p.Ast.pmin]) ); "pattern_locals", Fun2 (fun e t -> let loc = (get_ctx()).curapi.get_pattern_locals (decode_expr e) (decode_type t) in let h = Hashtbl.create 0 in PMap.iter (fun n v -> Hashtbl.replace h (VString n) (encode_type v.v_type)) loc; enc_hash h ); "macro_context_reused", Fun1 (fun c -> match c with | VFunction (Fun0 _) -> let ctx = get_ctx() in ctx.on_reused <- (fun() -> catch_errors ctx (fun() -> ctx.do_call VNull c [] null_pos) = Some (VBool true)) :: ctx.on_reused; VNull | _ -> error() ); ] (* ---------------------------------------------------------------------- *) (* EVAL *) let throw ctx p msg = ctx.callstack <- { cpos = p; cthis = ctx.vthis; cstack = DynArray.length ctx.stack; cenv = ctx.venv } :: ctx.callstack; exc (VString msg) let declare ctx var = ctx.locals_map <- PMap.add var ctx.locals_count ctx.locals_map; ctx.locals_count <- ctx.locals_count + 1 let save_locals ctx = let old, oldcount = ctx.locals_map, ctx.locals_count in (fun() -> let n = ctx.locals_count - oldcount in ctx.locals_count <- oldcount; ctx.locals_map <- old; n; ) let get_ident ctx s = try let index = PMap.find s ctx.locals_map in if index >= ctx.locals_barrier then AccLocal (ctx.locals_count - index) else (try AccEnv (DynArray.index_of (fun s2 -> s = s2) ctx.locals_env) with Not_found -> let index = DynArray.length ctx.locals_env in DynArray.add ctx.locals_env s; AccEnv index ) with Not_found -> try AccGlobal (PMap.find s ctx.globals) with Not_found -> let g = ref VNull in ctx.globals <- PMap.add s g ctx.globals; AccGlobal g let no_env = [||] let rec eval ctx (e,p) = match e with | EConst c -> (match c with | True -> (fun() -> VBool true) | False -> (fun() -> VBool false) | Null -> (fun() -> VNull) | This -> (fun() -> ctx.vthis) | Int i -> (fun() -> VInt i) | Int32 i -> (fun() -> VInt32 i) | Float f -> let f = float_of_string f in (fun() -> VFloat f) | String s -> (fun() -> VString s) | Builtin "loader" -> (fun() -> ctx.loader) | Builtin "exports" -> (fun() -> ctx.exports) | Builtin s -> let b = (try Hashtbl.find builtins s with Not_found -> throw ctx p ("Builtin not found '" ^ s ^ "'")) in (fun() -> b) | Ident s -> acc_get ctx p (get_ident ctx s)) | EBlock el -> let old = save_locals ctx in let el = List.map (eval ctx) el in let n = old() in let rec loop = function | [] -> VNull | [e] -> e() | e :: l -> ignore(e()); loop l in (fun() -> let v = loop el in pop ctx n; v) | EParenthesis e -> eval ctx e | EField (e,f) -> let e = eval ctx e in let h = hash_field ctx f in (fun() -> match e() with | VObject o -> get_field o h | _ -> throw ctx p ("Invalid field access : " ^ f) ) | ECall ((EConst (Builtin "mk_pos"),_),[(ECall (_,[EConst (String file),_]),_);(EConst (Int min),_);(EConst (Int max),_)]) -> let pos = VAbstract (APos { Ast.pfile = file; Ast.pmin = min; Ast.pmax = max }) in (fun() -> pos) | ECall ((EConst (Builtin "typewrap"),_),[t]) -> (fun() -> VAbstract (ATDecl (Obj.magic t))) | ECall ((EConst (Builtin "delay_call"),_),[EConst (Int index),_]) -> let f = ctx.curapi.delayed_macro index in let fbuild = ref None in let old = { ctx with gen = ctx.gen } in let compile_delayed_call() = let oldl, oldc, oldb, olde = ctx.locals_map, ctx.locals_count, ctx.locals_barrier, ctx.locals_env in ctx.locals_map <- old.locals_map; ctx.locals_count <- old.locals_count; ctx.locals_barrier <- old.locals_barrier; ctx.locals_env <- DynArray.copy old.locals_env; let save = save_locals ctx in let e = f() in let n = save() in let e = if DynArray.length ctx.locals_env = DynArray.length old.locals_env then e else let n = DynArray.get ctx.locals_env (DynArray.length ctx.locals_env - 1) in (fun() -> exc (VString ("Macro-in-macro call can't access to closure variable '" ^ n ^ "'"))) in ctx.locals_map <- oldl; ctx.locals_count <- oldc; ctx.locals_barrier <- oldb; ctx.locals_env <- olde; (fun() -> let v = e() in pop ctx n; v ) in (fun() -> let e = (match !fbuild with | Some e -> e | None -> let e = compile_delayed_call() in fbuild := Some e; e ) in e()) | ECall (e,el) -> let el = List.map (eval ctx) el in (match fst e with | EField (e,f) -> let e = eval ctx e in let h = hash_field ctx f in (fun() -> let pl = List.map (fun f -> f()) el in let o = e() in let f = (match o with | VObject o -> get_field o h | _ -> throw ctx p ("Invalid field access : " ^ f) ) in call ctx o f pl p ) | _ -> let e = eval ctx e in (fun() -> let pl = List.map (fun f -> f()) el in call ctx ctx.vthis (e()) pl p )) | EArray (e1,e2) -> let e1 = eval ctx e1 in let e2 = eval ctx e2 in let acc = AccArray (e1,e2) in acc_get ctx p acc | EVars vl -> let vl = List.map (fun (v,eo) -> let eo = (match eo with None -> (fun() -> VNull) | Some e -> eval ctx e) in declare ctx v; eo ) vl in (fun() -> List.iter (fun e -> push ctx (e())) vl; VNull ) | EWhile (econd,e,NormalWhile) -> let econd = eval ctx econd in let e = eval ctx e in let rec loop st = match econd() with | VBool true -> let v = (try ignore(e()); None with | Continue -> pop ctx (DynArray.length ctx.stack - st); None | Break v -> pop ctx (DynArray.length ctx.stack - st); Some v ) in (match v with | None -> loop st | Some v -> v) | _ -> VNull in (fun() -> try loop (DynArray.length ctx.stack) with Sys.Break -> throw ctx p "Ctrl+C") | EWhile (econd,e,DoWhile) -> let e = eval ctx e in let econd = eval ctx econd in let rec loop st = let v = (try ignore(e()); None with | Continue -> pop ctx (DynArray.length ctx.stack - st); None | Break v -> pop ctx (DynArray.length ctx.stack - st); Some v ) in match v with | Some v -> v | None -> match econd() with | VBool true -> loop st | _ -> VNull in (fun() -> loop (DynArray.length ctx.stack)) | EIf (econd,eif,eelse) -> let econd = eval ctx econd in let eif = eval ctx eif in let eelse = (match eelse with None -> (fun() -> VNull) | Some e -> eval ctx e) in (fun() -> match econd() with | VBool true -> eif() | _ -> eelse() ) | ETry (e,exc,ecatch) -> let old = save_locals ctx in let e = eval ctx e in let n1 = old() in declare ctx exc; let ecatch = eval ctx ecatch in let n2 = old() in (fun() -> let vthis = ctx.vthis in let venv = ctx.venv in let stack = ctx.callstack in let csize = ctx.callsize in let size = DynArray.length ctx.stack in try pop_ret ctx e n1 with Runtime v -> let rec loop n l = if n = 0 then List.map (fun s -> s.cpos) l else match l with | [] -> [] | _ :: l -> loop (n - 1) l in ctx.exc <- loop (List.length stack) (List.rev ctx.callstack); ctx.callstack <- stack; ctx.callsize <- csize; ctx.vthis <- vthis; ctx.venv <- venv; pop ctx (DynArray.length ctx.stack - size); push ctx v; pop_ret ctx ecatch n2 ) | EFunction (pl,e) -> let old = save_locals ctx in let oldb, oldenv = ctx.locals_barrier, ctx.locals_env in ctx.locals_barrier <- ctx.locals_count; ctx.locals_env <- DynArray.create(); List.iter (declare ctx) pl; let e = eval ctx e in ignore(old()); let env = ctx.locals_env in ctx.locals_barrier <- oldb; ctx.locals_env <- oldenv; let env = DynArray.to_array (DynArray.map (fun s -> acc_get ctx p (get_ident ctx s)) env ) in let init_env = if Array.length env = 0 then (fun() -> no_env) else (fun() -> Array.map (fun e -> e()) env) in (match pl with | [] -> (fun() -> let env = init_env() in VFunction (Fun0 (fun() -> ctx.venv <- env; e()))) | [a] -> (fun() -> let env = init_env() in VFunction (Fun1 (fun v -> ctx.venv <- env; push ctx v; e(); ))) | [a;b] -> (fun() -> let env = init_env() in VFunction (Fun2 (fun va vb -> ctx.venv <- env; push ctx va; push ctx vb; e(); ))) | [a;b;c] -> (fun() -> let env = init_env() in VFunction (Fun3 (fun va vb vc -> ctx.venv <- env; push ctx va; push ctx vb; push ctx vc; e(); ))) | [a;b;c;d] -> (fun() -> let env = init_env() in VFunction (Fun4 (fun va vb vc vd -> ctx.venv <- env; push ctx va; push ctx vb; push ctx vc; push ctx vd; e(); ))) | [a;b;c;d;pe] -> (fun() -> let env = init_env() in VFunction (Fun5 (fun va vb vc vd ve -> ctx.venv <- env; push ctx va; push ctx vb; push ctx vc; push ctx vd; push ctx ve; e(); ))) | _ -> (fun() -> let env = init_env() in VFunction (FunVar (fun vl -> if List.length vl != List.length pl then exc (VString "Invalid call"); ctx.venv <- env; List.iter (push ctx) vl; e(); ))) ) | EBinop (op,e1,e2) -> eval_op ctx op e1 e2 p | EReturn None -> (fun() -> raise (Return VNull)) | EReturn (Some e) -> let e = eval ctx e in (fun() -> raise (Return (e()))) | EBreak None -> (fun() -> raise (Break VNull)) | EBreak (Some e) -> let e = eval ctx e in (fun() -> raise (Break (e()))) | EContinue -> (fun() -> raise Continue) | ENext (e1,e2) -> let e1 = eval ctx e1 in let e2 = eval ctx e2 in (fun() -> ignore(e1()); e2()) | EObject fl -> let fl = List.map (fun (f,e) -> hash_field ctx f, eval ctx e) fl in let fields = Array.of_list (List.map (fun (f,_) -> f,VNull) fl) in Array.sort (fun (f1,_) (f2,_) -> compare f1 f2) fields; (fun() -> let o = { ofields = Array.copy fields; oproto = None; } in List.iter (fun (f,e) -> set_field o f (e())) fl; VObject o ) | ELabel l -> assert false | ESwitch (e1,el,eo) -> let e1 = eval ctx e1 in let el = List.map (fun (cond,e) -> cond, eval ctx cond, eval ctx e) el in let eo = (match eo with None -> (fun() -> VNull) | Some e -> eval ctx e) in let cases = (try let max = ref (-1) in let ints = List.map (fun (cond,_,e) -> match fst cond with | EConst (Int i) -> if i < 0 then raise Exit; if i > !max then max := i; i, e | _ -> raise Exit ) el in let a = Array.create (!max + 1) eo in List.iter (fun (i,e) -> a.(i) <- e) (List.rev ints); Some a; with Exit -> None ) in let def v = let rec loop = function | [] -> eo() | (_,c,e) :: l -> if ctx.do_compare v (c()) = CEq then e() else loop l in loop el in (match cases with | None -> (fun() -> def (e1())) | Some t -> (fun() -> match e1() with | VInt i -> if i >= 0 && i < Array.length t then t.(i)() else eo() | v -> def v )) | ENeko _ -> throw ctx p "Inline neko code unsupported" and eval_oop ctx p o field (params:value list) = match get_field_opt o field with | None -> None | Some f -> Some (call ctx (VObject o) f params p) and eval_access ctx (e,p) = match e with | EField (e,f) -> let v = eval ctx e in AccField (v,f) | EArray (e,eindex) -> let v = eval ctx e in let idx = eval ctx eindex in AccArray (v,idx) | EConst (Ident s) -> get_ident ctx s | EConst This -> AccThis | _ -> throw ctx p "Invalid assign" and eval_access_get_set ctx (e,p) = match e with | EField (e,f) -> let v = eval ctx e in let cache = ref VNull in AccField ((fun() -> cache := v(); !cache),f), AccField((fun() -> !cache), f) | EArray (e,eindex) -> let v = eval ctx e in let idx = eval ctx eindex in let vcache = ref VNull and icache = ref VNull in AccArray ((fun() -> vcache := v(); !vcache),(fun() -> icache := idx(); !icache)), AccArray ((fun() -> !vcache),(fun() -> !icache)) | EConst (Ident s) -> let acc = get_ident ctx s in acc, acc | EConst This -> AccThis, AccThis | _ -> throw ctx p "Invalid assign" and acc_get ctx p = function | AccField (v,f) -> let h = hash_field ctx f in (fun() -> match v() with | VObject o -> get_field o h | _ -> throw ctx p ("Invalid field access : " ^ f)) | AccArray (e,index) -> (fun() -> let e = e() in let index = index() in (match index, e with | VInt i, VArray a -> (try Array.get a i with _ -> VNull) | VInt32 _, VArray _ -> VNull | _, VObject o -> (match eval_oop ctx p o h_get [index] with | None -> throw ctx p "Invalid array access" | Some v -> v) | _ -> throw ctx p "Invalid array access")) | AccLocal i -> (fun() -> DynArray.get ctx.stack (DynArray.length ctx.stack - i)) | AccGlobal g -> (fun() -> !g) | AccThis -> (fun() -> ctx.vthis) | AccEnv i -> (fun() -> ctx.venv.(i)) and acc_set ctx p acc value = match acc with | AccField (v,f) -> let h = hash_field ctx f in (fun() -> let v = v() in let value = value() in match v with | VObject o -> set_field o h value; value | _ -> throw ctx p ("Invalid field access : " ^ f)) | AccArray (e,index) -> (fun() -> let e = e() in let index = index() in let value = value() in (match index, e with | VInt i, VArray a -> (try Array.set a i value; value with _ -> value) | VInt32 _, VArray _ -> value | _, VObject o -> (match eval_oop ctx p o h_set [index;value] with | None -> throw ctx p "Invalid array access" | Some _ -> value); | _ -> throw ctx p "Invalid array access")) | AccLocal i -> (fun() -> let value = value() in DynArray.set ctx.stack (DynArray.length ctx.stack - i) value; value) | AccGlobal g -> (fun() -> let value = value() in g := value; value) | AccThis -> (fun() -> let value = value() in ctx.vthis <- value; value) | AccEnv i -> (fun() -> let value = value() in ctx.venv.(i) <- value; value) and number_op ctx p sop iop fop oop rop v1 v2 = (fun() -> let v1 = v1() in let v2 = v2() in exc_number_op ctx p sop iop fop oop rop v1 v2) and exc_number_op ctx p sop iop fop oop rop v1 v2 = match v1, v2 with | VInt a, VInt b -> best_int (iop (Int32.of_int a) (Int32.of_int b)) | VInt32 a, VInt b -> best_int (iop a (Int32.of_int b)) | VInt a, VInt32 b -> best_int (iop (Int32.of_int a) b) | VFloat a, VInt b -> VFloat (fop a (float_of_int b)) | VFloat a, VInt32 b -> VFloat (fop a (Int32.to_float b)) | VInt a, VFloat b -> VFloat (fop (float_of_int a) b) | VInt32 a, VFloat b -> VFloat (fop (Int32.to_float a) b) | VFloat a, VFloat b -> VFloat (fop a b) | VInt32 a, VInt32 b -> best_int (iop a b) | VObject o, _ -> (match eval_oop ctx p o oop [v2] with | Some v -> v | None -> match v2 with | VObject o -> (match eval_oop ctx p o rop [v1] with | Some v -> v | None -> throw ctx p sop) | _ -> throw ctx p sop) | _ , VObject o -> (match eval_oop ctx p o rop [v1] with | Some v -> v | None -> throw ctx p sop) | _ -> throw ctx p sop and int_op ctx p op iop v1 v2 = (fun() -> let v1 = v1() in let v2 = v2() in match v1, v2 with | VInt a, VInt b -> best_int (iop (Int32.of_int a) (Int32.of_int b)) | VInt32 a, VInt b -> best_int (iop a (Int32.of_int b)) | VInt a, VInt32 b -> best_int (iop (Int32.of_int a) b) | VInt32 a, VInt32 b -> best_int (iop a b) | _ -> throw ctx p op) and base_op ctx op v1 v2 p = match op with | "+" -> (fun() -> let v1 = v1() in let v2 = v2() in match v1, v2 with | (VInt _ | VInt32 _), (VInt _ | VInt32 _) | (VInt _ | VInt32 _), VFloat _ | VFloat _ , (VInt _ | VInt32 _) | VFloat _ , VFloat _ | VObject _ , _ | _ , VObject _ -> exc_number_op ctx p op Int32.add (+.) h_add h_radd v1 v2 | VString a, _ -> VString (a ^ ctx.do_string v2) | _, VString b -> VString (ctx.do_string v1 ^ b) | _ -> throw ctx p op) | "-" -> number_op ctx p op Int32.sub (-.) h_sub h_rsub v1 v2 | "*" -> number_op ctx p op Int32.mul ( *. ) h_mult h_rmult v1 v2 | "/" -> (fun() -> let v1 = v1() in let v2 = v2() in match v1, v2 with | VInt i, VInt j -> VFloat ((float_of_int i) /. (float_of_int j)) | VInt i, VInt32 j -> VFloat ((float_of_int i) /. (Int32.to_float j)) | VInt32 i, VInt j -> VFloat ((Int32.to_float i) /. (float_of_int j)) | VInt32 i, VInt32 j -> VFloat ((Int32.to_float i) /. (Int32.to_float j)) | _ -> exc_number_op ctx p op Int32.div (/.) h_div h_rdiv v1 v2) | "%" -> number_op ctx p op (fun x y -> if y = 0l then throw ctx p op; Int32.rem x y) mod_float h_mod h_rmod v1 v2 | "&" -> int_op ctx p op Int32.logand v1 v2 | "|" -> int_op ctx p op Int32.logor v1 v2 | "^" -> int_op ctx p op Int32.logxor v1 v2 | "<<" -> int_op ctx p op (fun x y -> Int32.shift_left x (Int32.to_int y)) v1 v2 | ">>" -> int_op ctx p op (fun x y -> Int32.shift_right x (Int32.to_int y)) v1 v2 | ">>>" -> int_op ctx p op (fun x y -> Int32.shift_right_logical x (Int32.to_int y)) v1 v2 | _ -> throw ctx p op and eval_op ctx op e1 e2 p = match op with | "=" -> let acc = eval_access ctx e1 in let v = eval ctx e2 in acc_set ctx p acc v | "==" -> let v1 = eval ctx e1 in let v2 = eval ctx e2 in (fun() -> let v1 = v1() in let v2 = v2() in match ctx.do_compare v1 v2 with | CEq -> VBool true | _ -> VBool false) | "!=" -> let v1 = eval ctx e1 in let v2 = eval ctx e2 in (fun() -> let v1 = v1() in let v2 = v2() in match ctx.do_compare v1 v2 with | CEq -> VBool false | _ -> VBool true) | ">" -> let v1 = eval ctx e1 in let v2 = eval ctx e2 in (fun() -> let v1 = v1() in let v2 = v2() in match ctx.do_compare v1 v2 with | CSup -> VBool true | _ -> VBool false) | ">=" -> let v1 = eval ctx e1 in let v2 = eval ctx e2 in (fun() -> let v1 = v1() in let v2 = v2() in match ctx.do_compare v1 v2 with | CSup | CEq -> VBool true | _ -> VBool false) | "<" -> let v1 = eval ctx e1 in let v2 = eval ctx e2 in (fun() -> let v1 = v1() in let v2 = v2() in match ctx.do_compare v1 v2 with | CInf -> VBool true | _ -> VBool false) | "<=" -> let v1 = eval ctx e1 in let v2 = eval ctx e2 in (fun() -> let v1 = v1() in let v2 = v2() in match ctx.do_compare v1 v2 with | CInf | CEq -> VBool true | _ -> VBool false) | "+" | "-" | "*" | "/" | "%" | "|" | "&" | "^" | "<<" | ">>" | ">>>" -> let v1 = eval ctx e1 in let v2 = eval ctx e2 in base_op ctx op v1 v2 p | "+=" | "-=" | "*=" | "/=" | "%=" | "<<=" | ">>=" | ">>>=" | "|=" | "&=" | "^=" -> let aset, aget = eval_access_get_set ctx e1 in let v1 = acc_get ctx p aget in let v2 = eval ctx e2 in let v = base_op ctx (String.sub op 0 (String.length op - 1)) v1 v2 p in acc_set ctx p aset v | "&&" -> let e1 = eval ctx e1 in let e2 = eval ctx e2 in (fun() -> match e1() with | VBool false as v -> v | _ -> e2()) | "||" -> let e1 = eval ctx e1 in let e2 = eval ctx e2 in (fun() -> match e1() with | VBool true as v -> v | _ -> e2()) | "++=" | "--=" -> let aset, aget = eval_access_get_set ctx e1 in let v1 = acc_get ctx p aget in let v2 = eval ctx e2 in let vcache = ref VNull in let v = base_op ctx (String.sub op 0 1) (fun() -> vcache := v1(); !vcache) v2 p in let set = acc_set ctx p aset v in (fun() -> ignore(set()); !vcache) | _ -> throw ctx p ("Unsupported " ^ op) and call ctx vthis vfun pl p = let oldthis = ctx.vthis in let stackpos = DynArray.length ctx.stack in let oldstack = ctx.callstack in let oldsize = ctx.callsize in let oldenv = ctx.venv in ctx.vthis <- vthis; ctx.callstack <- { cpos = p; cthis = oldthis; cstack = stackpos; cenv = oldenv } :: ctx.callstack; ctx.callsize <- oldsize + 1; if oldsize > 200 then exc (VString "Stack overflow"); let ret = (try (match vfun with | VClosure (vl,f) -> f vl pl | VFunction f -> (match pl, f with | [], Fun0 f -> f() | [a], Fun1 f -> f a | [a;b], Fun2 f -> f a b | [a;b;c], Fun3 f -> f a b c | [a;b;c;d], Fun4 f -> f a b c d | [a;b;c;d;e], Fun5 f -> f a b c d e | _, FunVar f -> f pl | _ -> exc (VString (Printf.sprintf "Invalid call (%d args instead of %d)" (List.length pl) (nargs f)))) | VAbstract (ALazyType f) -> encode_type ((!f)()) | _ -> exc (VString "Invalid call")) with Return v -> v | Stack_overflow -> exc (VString "Compiler Stack overflow") | Sys_error msg | Failure msg -> exc (VString msg) | Unix.Unix_error (_,cmd,msg) -> exc (VString ("Error " ^ cmd ^ " " ^ msg)) | Invalid_expr -> exc (VString "Invalid input value") | Builtin_error | Invalid_argument _ -> exc (VString "Invalid call")) in ctx.vthis <- oldthis; ctx.venv <- oldenv; ctx.callstack <- oldstack; ctx.callsize <- oldsize; pop ctx (DynArray.length ctx.stack - stackpos); ret (* ---------------------------------------------------------------------- *) (* OTHERS *) let rec to_string ctx n v = if n > 5 then "<...>" else let n = n + 1 in match v with | VNull -> "null" | VBool true -> "true" | VBool false -> "false" | VInt i -> string_of_int i | VInt32 i -> Int32.to_string i | VFloat f -> let s = string_of_float f in let len = String.length s in if String.unsafe_get s (len - 1) = '.' then String.sub s 0 (len - 1) else s | VString s -> s | VArray vl -> "[" ^ String.concat "," (Array.to_list (Array.map (to_string ctx n) vl)) ^ "]" | VAbstract a -> (match a with | APos p -> "#pos(" ^ Lexer.get_error_pos (Printf.sprintf "%s:%d:") p ^ ")" | _ -> "#abstract") | VFunction f -> "#function:" ^ string_of_int (nargs f) | VClosure _ -> "#function:-1" | VObject o -> match eval_oop ctx null_pos o h_string [] with | Some (VString s) -> s | _ -> let b = Buffer.create 0 in let first = ref true in Buffer.add_char b '{'; Array.iter (fun (f,v) -> if !first then begin Buffer.add_char b ' '; first := false; end else Buffer.add_string b ", "; Buffer.add_string b (field_name ctx f); Buffer.add_string b " => "; Buffer.add_string b (to_string ctx n v); ) o.ofields; Buffer.add_string b (if !first then "}" else " }"); Buffer.contents b let rec compare ctx a b = let fcmp (a:float) b = if a = b then CEq else if a < b then CInf else CSup in let scmp (a:string) b = if a = b then CEq else if a < b then CInf else CSup in let icmp (a:int32) b = let l = Int32.compare a b in if l = 0 then CEq else if l < 0 then CInf else CSup in match a, b with | VNull, VNull -> CEq | VInt a, VInt b -> if a = b then CEq else if a < b then CInf else CSup | VInt32 a, VInt32 b -> icmp a b | VInt a, VInt32 b -> icmp (Int32.of_int a) b | VInt32 a, VInt b -> icmp a (Int32.of_int b) | VFloat a, VFloat b -> fcmp a b | VFloat a, VInt b -> fcmp a (float_of_int b) | VFloat a, VInt32 b -> fcmp a (Int32.to_float b) | VInt a, VFloat b -> fcmp (float_of_int a) b | VInt32 a, VFloat b -> fcmp (Int32.to_float a) b | VBool a, VBool b -> if a = b then CEq else if a then CSup else CInf | VString a, VString b -> scmp a b | VInt _ , VString s | VInt32 _, VString s | VFloat _ , VString s | VBool _ , VString s -> scmp (to_string ctx 0 a) s | VString s, VInt _ | VString s, VInt32 _ | VString s, VFloat _ | VString s, VBool _ -> scmp s (to_string ctx 0 b) | VObject oa, VObject ob -> if oa == ob then CEq else (match eval_oop ctx null_pos oa h_compare [b] with | Some (VInt i) -> if i = 0 then CEq else if i < 0 then CInf else CSup | _ -> CUndef) | VAbstract a, VAbstract b -> if a == b then CEq else CUndef | VArray a, VArray b -> if a == b then CEq else CUndef | VFunction a, VFunction b -> if a == b then CEq else CUndef | VClosure (la,fa), VClosure (lb,fb) -> if la == lb && fa == fb then CEq else CUndef | _ -> CUndef let select ctx = get_ctx_ref := (fun() -> ctx) let load_prim ctx f n = match f, n with | VString f, VInt n -> let lib, fname = (try ExtString.String.split f "@" with _ -> "", f) in (try let f = (match lib with | "std" -> Hashtbl.find std_lib fname | "macro" -> Hashtbl.find macro_lib fname | "regexp" -> Hashtbl.find reg_lib fname | "zlib" -> Hashtbl.find z_lib fname | _ -> failwith ("You cannot use the library '" ^ lib ^ "' inside a macro"); ) in if nargs f <> n then raise Not_found; VFunction f with Not_found -> VFunction (FunVar (fun _ -> exc (VString ("Primitive not found " ^ f ^ ":" ^ string_of_int n))))) | _ -> exc (VString "Invalid call") let create com api = let loader = obj hash [ "args",VArray (Array.of_list (List.map (fun s -> VString s) com.sys_args)); "loadprim",VFunction (Fun2 (fun a b -> (get_ctx()).do_loadprim a b)); "loadmodule",VFunction (Fun2 (fun a b -> assert false)); ] in let ctx = { gen = Genneko.new_context com 2 true; types = Hashtbl.create 0; error = false; error_proto = { ofields = [||]; oproto = None }; prototypes = Hashtbl.create 0; enums = [||]; (* eval *) locals_map = PMap.empty; locals_count = 0; locals_barrier = 0; locals_env = DynArray.create(); globals = PMap.empty; (* runtime *) callstack = []; callsize = 0; stack = DynArray.create(); exc = []; vthis = VNull; venv = [||]; fields_cache = Hashtbl.copy constants; (* api *) do_call = Obj.magic(); do_string = Obj.magic(); do_loadprim = Obj.magic(); do_compare = Obj.magic(); (* context *) curapi = api; loader = VObject loader; on_reused = []; is_reused = true; exports = VObject { ofields = [||]; oproto = None }; } in ctx.do_call <- call ctx; ctx.do_string <- to_string ctx 0; ctx.do_loadprim <- load_prim ctx; ctx.do_compare <- compare ctx; select ctx; List.iter (fun e -> ignore((eval ctx e)())) (Genneko.header()); ctx let do_reuse ctx = ctx.is_reused <- false let can_reuse ctx types = let has_old_version t = let inf = Type.t_infos t in try Hashtbl.find ctx.types inf.mt_path <> inf.mt_module.m_id with Not_found -> false in if List.exists has_old_version types then false else if ctx.is_reused then true else if not (List.for_all (fun f -> f()) ctx.on_reused) then false else begin ctx.is_reused <- true; true; end let add_types ctx types ready = let types = List.filter (fun t -> let path = Type.t_path t in if Hashtbl.mem ctx.types path then false else begin Hashtbl.add ctx.types path (Type.t_infos t).mt_module.m_id; true; end ) types in List.iter ready types; let e = (EBlock (Genneko.build ctx.gen types), null_pos) in ignore(catch_errors ctx (fun() -> ignore((eval ctx e)()))) let eval_expr ctx e = let e = Genneko.gen_expr ctx.gen e in catch_errors ctx (fun() -> (eval ctx e)()) let get_path ctx path p = let rec loop = function | [] -> assert false | [x] -> (EConst (Ident x),p) | x :: l -> (EField (loop l,x),p) in (eval ctx (loop (List.rev path)))() let set_error ctx e = ctx.error <- e let call_path ctx path f vl api = if ctx.error then None else let old = ctx.curapi in ctx.curapi <- api; let p = Genneko.pos ctx.gen api.pos in catch_errors ctx ~final:(fun() -> ctx.curapi <- old) (fun() -> match get_path ctx path p with | VObject o -> let f = get_field o (hash f) in call ctx (VObject o) f vl p | _ -> assert false ) (* ---------------------------------------------------------------------- *) (* EXPR ENCODING *) type enum_index = | IExpr | IBinop | IUnop | IConst | ITParam | ICType | IField | IType | IFieldKind | IMethodKind | IVarAccess | IAccess | IClassKind let enum_name = function | IExpr -> "ExprDef" | IBinop -> "Binop" | IUnop -> "Unop" | IConst -> "Constant" | ITParam -> "TypeParam" | ICType -> "ComplexType" | IField -> "FieldType" | IType -> "Type" | IFieldKind -> "FieldKind" | IMethodKind -> "MethodKind" | IVarAccess -> "VarAccess" | IAccess -> "Access" | IClassKind -> "ClassKind" let init ctx = let enums = [IExpr;IBinop;IUnop;IConst;ITParam;ICType;IField;IType;IFieldKind;IMethodKind;IVarAccess;IAccess;IClassKind] in let get_enum_proto e = match get_path ctx ["haxe";"macro";enum_name e] null_pos with | VObject e -> (match get_field e h_constructs with | VObject cst -> (match get_field cst h_a with | VArray a -> Array.map (fun s -> match s with | VObject s -> (match get_field s h_s with VString s -> get_field e (hash s),s | _ -> assert false) | _ -> assert false ) a | _ -> assert false) | _ -> assert false) | _ -> failwith ("haxe.macro." ^ enum_name e ^ " does not exists") in ctx.enums <- Array.of_list (List.map get_enum_proto enums); ctx.error_proto <- (match get_path ctx ["haxe";"macro";"Error";"prototype"] null_pos with VObject p -> p | _ -> failwith ("haxe.macro.Error does not exists")) open Ast let null f = function | None -> VNull | Some v -> f v let encode_pos p = VAbstract (APos p) let enc_inst path fields = let ctx = get_ctx() in let p = (try Hashtbl.find ctx.prototypes path with Not_found -> try (match get_path ctx (path@["prototype"]) Nast.null_pos with | VObject o -> Hashtbl.add ctx.prototypes path o; o | _ -> raise (Runtime VNull)) with Runtime _ -> failwith ("Prototype not found " ^ String.concat "." path) ) in let o = obj hash fields in o.oproto <- Some p; VObject o let enc_array l = let a = Array.of_list l in enc_inst ["Array"] [ "__a", VArray a; "length", VInt (Array.length a); ] let enc_string s = enc_inst ["String"] [ "__s", VString s; "length", VInt (String.length s) ] let enc_hash h = enc_inst ["haxe";"ds";"StringMap"] [ "h", VAbstract (AHash h); ] let enc_obj l = VObject (obj hash l) let enc_enum (i:enum_index) index pl = let eindex : int = Obj.magic i in let edef = (get_ctx()).enums.(eindex) in if pl = [] then fst edef.(index) else enc_inst ["haxe";"macro";enum_name i] [ "tag", VString (snd edef.(index)); "index", VInt index; "args", VArray (Array.of_list pl); ] let compiler_error msg pos = exc (enc_inst ["haxe";"macro";"Error"] [("message",enc_string msg);("pos",encode_pos pos)]) let encode_const c = let tag, pl = match c with | Int s -> 0, [enc_string s] | Float s -> 1, [enc_string s] | String s -> 2, [enc_string s] | Ident s -> 3, [enc_string s] | Regexp (s,opt) -> 4, [enc_string s;enc_string opt] in enc_enum IConst tag pl let rec encode_binop op = let tag, pl = match op with | OpAdd -> 0, [] | OpMult -> 1, [] | OpDiv -> 2, [] | OpSub -> 3, [] | OpAssign -> 4, [] | OpEq -> 5, [] | OpNotEq -> 6, [] | OpGt -> 7, [] | OpGte -> 8, [] | OpLt -> 9, [] | OpLte -> 10, [] | OpAnd -> 11, [] | OpOr -> 12, [] | OpXor -> 13, [] | OpBoolAnd -> 14, [] | OpBoolOr -> 15, [] | OpShl -> 16, [] | OpShr -> 17, [] | OpUShr -> 18, [] | OpMod -> 19, [] | OpAssignOp op -> 20, [encode_binop op] | OpInterval -> 21, [] | OpArrow -> 22, [] in enc_enum IBinop tag pl let encode_unop op = let tag = match op with | Increment -> 0 | Decrement -> 1 | Not -> 2 | Neg -> 3 | NegBits -> 4 in enc_enum IUnop tag [] let rec encode_path t = let fields = [ "pack", enc_array (List.map enc_string t.tpackage); "name", enc_string t.tname; "params", enc_array (List.map encode_tparam t.tparams); ] in enc_obj (match t.tsub with | None -> fields | Some s -> ("sub", enc_string s) :: fields) and encode_tparam = function | TPType t -> enc_enum ITParam 0 [encode_ctype t] | TPExpr e -> enc_enum ITParam 1 [encode_expr e] and encode_access a = let tag = match a with | APublic -> 0 | APrivate -> 1 | AStatic -> 2 | AOverride -> 3 | ADynamic -> 4 | AInline -> 5 | AMacro -> 6 in enc_enum IAccess tag [] and encode_meta_entry (m,ml,p) = enc_obj [ "name", enc_string (fst (MetaInfo.to_string m)); "params", enc_array (List.map encode_expr ml); "pos", encode_pos p; ] and encode_meta_content m = enc_array (List.map encode_meta_entry m) and encode_field (f:class_field) = let tag, pl = match f.cff_kind with | FVar (t,e) -> 0, [null encode_ctype t; null encode_expr e] | FFun f -> 1, [encode_fun f] | FProp (get,set, t, e) -> 2, [enc_string get; enc_string set; null encode_ctype t; null encode_expr e] in enc_obj [ "name",enc_string f.cff_name; "doc", null enc_string f.cff_doc; "pos", encode_pos f.cff_pos; "kind", enc_enum IField tag pl; "meta", encode_meta_content f.cff_meta; "access", enc_array (List.map encode_access f.cff_access); ] and encode_ctype t = let tag, pl = match t with | CTPath p -> 0, [encode_path p] | CTFunction (pl,r) -> 1, [enc_array (List.map encode_ctype pl);encode_ctype r] | CTAnonymous fl -> 2, [enc_array (List.map encode_field fl)] | CTParent t -> 3, [encode_ctype t] | CTExtend (t,fields) -> 4, [encode_path t; enc_array (List.map encode_field fields)] | CTOptional t -> 5, [encode_ctype t] in enc_enum ICType tag pl and encode_tparam_decl tp = enc_obj [ "name", enc_string tp.tp_name; "params", enc_array (List.map encode_tparam_decl tp.tp_params); "constraints", enc_array (List.map encode_ctype tp.tp_constraints); ] and encode_fun f = enc_obj [ "params", enc_array (List.map encode_tparam_decl f.f_params); "args", enc_array (List.map (fun (n,opt,t,e) -> enc_obj [ "name", enc_string n; "opt", VBool opt; "type", null encode_ctype t; "value", null encode_expr e; ] ) f.f_args); "ret", null encode_ctype f.f_type; "expr", null encode_expr f.f_expr ] and encode_expr e = let rec loop (e,p) = let tag, pl = match e with | EConst c -> 0, [encode_const c] | EArray (e1,e2) -> 1, [loop e1;loop e2] | EBinop (op,e1,e2) -> 2, [encode_binop op;loop e1;loop e2] | EField (e,f) -> 3, [loop e;enc_string f] | EParenthesis e -> 4, [loop e] | EObjectDecl fl -> 5, [enc_array (List.map (fun (f,e) -> enc_obj [ "field",enc_string f; "expr",loop e; ]) fl)] | EArrayDecl el -> 6, [enc_array (List.map loop el)] | ECall (e,el) -> 7, [loop e;enc_array (List.map loop el)] | ENew (p,el) -> 8, [encode_path p; enc_array (List.map loop el)] | EUnop (op,flag,e) -> 9, [encode_unop op; VBool (match flag with Prefix -> false | Postfix -> true); loop e] | EVars vl -> 10, [enc_array (List.map (fun (v,t,eo) -> enc_obj [ "name",enc_string v; "type",null encode_ctype t; "expr",null loop eo; ] ) vl)] | EFunction (name,f) -> 11, [null enc_string name; encode_fun f] | EBlock el -> 12, [enc_array (List.map loop el)] | EFor (e,eloop) -> 13, [loop e;loop eloop] | EIn (e1,e2) -> 14, [loop e1;loop e2] | EIf (econd,e,eelse) -> 15, [loop econd;loop e;null loop eelse] | EWhile (econd,e,flag) -> 16, [loop econd;loop e;VBool (match flag with NormalWhile -> true | DoWhile -> false)] | ESwitch (e,cases,eopt) -> 17, [loop e;enc_array (List.map (fun (ecl,eg,e) -> enc_obj [ "values",enc_array (List.map loop ecl); "guard",null loop eg; "expr",null loop e ] ) cases);null encode_null_expr eopt] | ETry (e,catches) -> 18, [loop e;enc_array (List.map (fun (v,t,e) -> enc_obj [ "name",enc_string v; "type",encode_ctype t; "expr",loop e ] ) catches)] | EReturn eo -> 19, [null loop eo] | EBreak -> 20, [] | EContinue -> 21, [] | EUntyped e -> 22, [loop e] | EThrow e -> 23, [loop e] | ECast (e,t) -> 24, [loop e; null encode_ctype t] | EDisplay (e,flag) -> 25, [loop e; VBool flag] | EDisplayNew t -> 26, [encode_path t] | ETernary (econd,e1,e2) -> 27, [loop econd;loop e1;loop e2] | ECheckType (e,t) -> 28, [loop e; encode_ctype t] | EMeta (m,e) -> 29, [encode_meta_entry m;loop e] in enc_obj [ "pos", encode_pos p; "expr", enc_enum IExpr tag pl; ] in loop e and encode_null_expr e = match e with | None -> enc_obj ["pos", VNull;"expr",VNull] | Some e -> encode_expr e (* ---------------------------------------------------------------------- *) (* EXPR DECODING *) let opt f v = match v with | VNull -> None | _ -> Some (f v) let opt_list f v = match v with | VNull -> [] | _ -> f v let decode_pos = function | VAbstract (APos p) -> p | _ -> raise Invalid_expr let field v f = match v with | VObject o -> get_field o (hash f) | _ -> raise Invalid_expr let decode_enum v = match field v "index", field v "args" with | VInt i, VNull -> i, [] | VInt i, VArray a -> i, Array.to_list a | _ -> raise Invalid_expr let dec_bool = function | VBool b -> b | _ -> raise Invalid_expr let dec_string v = match field v "__s" with | VString s -> s | _ -> raise Invalid_expr let dec_array v = match field v "__a", field v "length" with | VArray a, VInt l -> Array.to_list (if Array.length a = l then a else Array.sub a 0 l) | _ -> raise Invalid_expr let decode_const c = match decode_enum c with | 0, [s] -> Int (dec_string s) | 1, [s] -> Float (dec_string s) | 2, [s] -> String (dec_string s) | 3, [s] -> Ident (dec_string s) | 4, [s;opt] -> Regexp (dec_string s, dec_string opt) | 5, [s] -> Ident (dec_string s) (** deprecated CType, keep until 3.0 release **) | _ -> raise Invalid_expr let rec decode_op op = match decode_enum op with | 0, [] -> OpAdd | 1, [] -> OpMult | 2, [] -> OpDiv | 3, [] -> OpSub | 4, [] -> OpAssign | 5, [] -> OpEq | 6, [] -> OpNotEq | 7, [] -> OpGt | 8, [] -> OpGte | 9, [] -> OpLt | 10, [] -> OpLte | 11, [] -> OpAnd | 12, [] -> OpOr | 13, [] -> OpXor | 14, [] -> OpBoolAnd | 15, [] -> OpBoolOr | 16, [] -> OpShl | 17, [] -> OpShr | 18, [] -> OpUShr | 19, [] -> OpMod | 20, [op] -> OpAssignOp (decode_op op) | 21, [] -> OpInterval | 22,[] -> OpArrow | _ -> raise Invalid_expr let decode_unop op = match decode_enum op with | 0, [] -> Increment | 1, [] -> Decrement | 2, [] -> Not | 3, [] -> Neg | 4, [] -> NegBits | _ -> raise Invalid_expr let rec decode_path t = { tpackage = List.map dec_string (dec_array (field t "pack")); tname = dec_string (field t "name"); tparams = List.map decode_tparam (dec_array (field t "params")); tsub = opt dec_string (field t "sub"); } and decode_tparam v = match decode_enum v with | 0,[t] -> TPType (decode_ctype t) | 1,[e] -> TPExpr (decode_expr e) | _ -> raise Invalid_expr and decode_tparam_decl v = { tp_name = dec_string (field v "name"); tp_constraints = (match field v "constraints" with VNull -> [] | a -> List.map decode_ctype (dec_array a)); tp_params = (match field v "params" with VNull -> [] | a -> List.map decode_tparam_decl (dec_array a)); } and decode_fun v = { f_params = List.map decode_tparam_decl (dec_array (field v "params")); f_args = List.map (fun o -> (dec_string (field o "name"),dec_bool (field o "opt"),opt decode_ctype (field o "type"),opt decode_expr (field o "value")) ) (dec_array (field v "args")); f_type = opt decode_ctype (field v "ret"); f_expr = opt decode_expr (field v "expr"); } and decode_access v = match decode_enum v with | 0, [] -> APublic | 1, [] -> APrivate | 2, [] -> AStatic | 3, [] -> AOverride | 4, [] -> ADynamic | 5, [] -> AInline | 6, [] -> AMacro | _ -> raise Invalid_expr and decode_meta_entry v = MetaInfo.from_string (dec_string (field v "name")), List.map decode_expr (dec_array (field v "params")), decode_pos (field v "pos") and decode_meta_content v = List.map decode_meta_entry (dec_array v) and decode_field v = let fkind = match decode_enum (field v "kind") with | 0, [t;e] -> FVar (opt decode_ctype t, opt decode_expr e) | 1, [f] -> FFun (decode_fun f) | 2, [get;set; t; e] -> FProp (dec_string get, dec_string set, opt decode_ctype t, opt decode_expr e) | _ -> raise Invalid_expr in { cff_name = dec_string (field v "name"); cff_doc = opt dec_string (field v "doc"); cff_pos = decode_pos (field v "pos"); cff_kind = fkind; cff_access = List.map decode_access (opt_list dec_array (field v "access")); cff_meta = opt_list decode_meta_content (field v "meta"); } and decode_ctype t = match decode_enum t with | 0, [p] -> CTPath (decode_path p) | 1, [a;r] -> CTFunction (List.map decode_ctype (dec_array a), decode_ctype r) | 2, [fl] -> CTAnonymous (List.map decode_field (dec_array fl)) | 3, [t] -> CTParent (decode_ctype t) | 4, [t;fl] -> CTExtend (decode_path t, List.map decode_field (dec_array fl)) | 5, [t] -> CTOptional (decode_ctype t) | _ -> raise Invalid_expr let rec decode_expr v = let rec loop v = (decode (field v "expr"), decode_pos (field v "pos")) and decode e = match decode_enum e with | 0, [c] -> EConst (decode_const c) | 1, [e1;e2] -> EArray (loop e1, loop e2) | 2, [op;e1;e2] -> EBinop (decode_op op, loop e1, loop e2) | 3, [e;f] -> EField (loop e, dec_string f) | 4, [e] -> EParenthesis (loop e) | 5, [a] -> EObjectDecl (List.map (fun o -> (dec_string (field o "field"), loop (field o "expr")) ) (dec_array a)) | 6, [a] -> EArrayDecl (List.map loop (dec_array a)) | 7, [e;el] -> ECall (loop e,List.map loop (dec_array el)) | 8, [t;el] -> ENew (decode_path t,List.map loop (dec_array el)) | 9, [op;VBool f;e] -> EUnop (decode_unop op,(if f then Postfix else Prefix),loop e) | 10, [vl] -> EVars (List.map (fun v -> (dec_string (field v "name"),opt decode_ctype (field v "type"),opt loop (field v "expr")) ) (dec_array vl)) | 11, [fname;f] -> EFunction (opt dec_string fname,decode_fun f) | 12, [el] -> EBlock (List.map loop (dec_array el)) | 13, [e1;e2] -> EFor (loop e1, loop e2) | 14, [e1;e2] -> EIn (loop e1, loop e2) | 15, [e1;e2;e3] -> EIf (loop e1, loop e2, opt loop e3) | 16, [e1;e2;VBool flag] -> EWhile (loop e1,loop e2,if flag then NormalWhile else DoWhile) | 17, [e;cases;eo] -> let cases = List.map (fun c -> (List.map loop (dec_array (field c "values")),opt loop (field c "guard"),opt loop (field c "expr")) ) (dec_array cases) in ESwitch (loop e,cases,opt decode_null_expr eo) | 18, [e;catches] -> let catches = List.map (fun c -> (dec_string (field c "name"),decode_ctype (field c "type"),loop (field c "expr")) ) (dec_array catches) in ETry (loop e, catches) | 19, [e] -> EReturn (opt loop e) | 20, [] -> EBreak | 21, [] -> EContinue | 22, [e] -> EUntyped (loop e) | 23, [e] -> EThrow (loop e) | 24, [e;t] -> ECast (loop e,opt decode_ctype t) | 25, [e;f] -> EDisplay (loop e,dec_bool f) | 26, [t] -> EDisplayNew (decode_path t) | 27, [e1;e2;e3] -> ETernary (loop e1,loop e2,loop e3) | 28, [e;t] -> ECheckType (loop e, decode_ctype t) | 29, [m;e] -> EMeta (decode_meta_entry m,loop e) | 30, [e;f] -> EField (loop e, dec_string f) (*** deprecated EType, keep until haxe 3 **) | _ -> raise Invalid_expr in try loop v with Stack_overflow -> raise Invalid_expr and decode_null_expr v = match field v "expr" with | VNull -> None | _ -> Some (decode_expr v) (* ---------------------------------------------------------------------- *) (* TYPE ENCODING *) let encode_ref v convert tostr = enc_obj [ "get", VFunction (Fun0 (fun() -> convert v)); "__string", VFunction (Fun0 (fun() -> VString (tostr()))); "toString", VFunction (Fun0 (fun() -> enc_string (tostr()))); "$", VAbstract (AUnsafe (Obj.repr v)); ] let decode_ref v : 'a = match field v "$" with | VAbstract (AUnsafe t) -> Obj.obj t | _ -> raise Invalid_expr let encode_pmap convert m = let h = Hashtbl.create 0 in PMap.iter (fun k v -> Hashtbl.add h (VString k) (convert v)) m; enc_hash h let encode_pmap_array convert m = let l = ref [] in PMap.iter (fun _ v -> l := !l @ [(convert v)]) m; enc_array !l let encode_array convert l = enc_array (List.map convert l) let encode_meta m set = let meta = ref m in enc_obj [ "get", VFunction (Fun0 (fun() -> encode_meta_content (!meta) )); "add", VFunction (Fun3 (fun k vl p -> (try let el = List.map decode_expr (dec_array vl) in meta := (MetaInfo.from_string (dec_string k), el, decode_pos p) :: !meta; set (!meta) with Invalid_expr -> failwith "Invalid expression"); VNull )); "remove", VFunction (Fun1 (fun k -> let k = MetaInfo.from_string (try dec_string k with Invalid_expr -> raise Builtin_error) in meta := List.filter (fun (m,_,_) -> m <> k) (!meta); set (!meta); VNull )); "has", VFunction (Fun1 (fun k -> let k = MetaInfo.from_string (try dec_string k with Invalid_expr -> raise Builtin_error) in VBool (List.exists (fun (m,_,_) -> m = k) (!meta)); )); ] let rec encode_mtype t fields = let i = t_infos t in enc_obj ([ "__t", VAbstract (ATDecl t); "pack", enc_array (List.map enc_string (fst i.mt_path)); "name", enc_string (snd i.mt_path); "pos", encode_pos i.mt_pos; "module", enc_string (s_type_path i.mt_module.m_path); "isPrivate", VBool i.mt_private; "meta", encode_meta i.mt_meta (fun m -> i.mt_meta <- m); "doc", null enc_string i.mt_doc; "params", encode_type_params i.mt_types; ] @ fields) and encode_type_params tl = enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) tl) and encode_tenum e = encode_mtype (TEnumDecl e) [ "isExtern", VBool e.e_extern; "exclude", VFunction (Fun0 (fun() -> e.e_extern <- true; VNull)); "constructs", encode_pmap encode_efield e.e_constrs; "names", enc_array (List.map enc_string e.e_names); ] and encode_tabstract a = encode_mtype (TAbstractDecl a) [ "type", encode_type a.a_this; "impl", (match a.a_impl with None -> VNull | Some c -> encode_clref c); "binops", enc_array (List.map (fun (op,cf) -> enc_obj [ "op",encode_binop op; "field",encode_cfield cf]) a.a_ops); "unops", enc_array (List.map (fun (op,postfix,cf) -> enc_obj [ "op",encode_unop op; "isPostfix",VBool (match postfix with Postfix -> true | Prefix -> false); "field",encode_cfield cf]) a.a_unops); "from", enc_array (List.map (fun (t,cfo) -> enc_obj [ "t",encode_type t; "field",match cfo with None -> VNull | Some cf -> encode_cfield cf]) a.a_from); "to", enc_array (List.map (fun (t,cfo) -> enc_obj [ "t",encode_type t; "field",match cfo with None -> VNull | Some cf -> encode_cfield cf]) a.a_to); "array", enc_array (List.map encode_cfield a.a_array); ] and encode_efield f = enc_obj [ "name", enc_string f.ef_name; "type", encode_type f.ef_type; "pos", encode_pos f.ef_pos; "index", VInt f.ef_index; "meta", encode_meta f.ef_meta (fun m -> f.ef_meta <- m); "doc", null enc_string f.ef_doc; "params", encode_type_params f.ef_params; ] and encode_cfield f = enc_obj [ "name", enc_string f.cf_name; "type", (match f.cf_kind with Method _ -> encode_lazy_type f.cf_type | _ -> encode_type f.cf_type); "isPublic", VBool f.cf_public; "params", encode_type_params f.cf_params; "meta", encode_meta f.cf_meta (fun m -> f.cf_meta <- m); "expr", (VFunction (Fun0 (fun() -> ignore(follow f.cf_type); (match f.cf_expr with None -> VNull | Some e -> encode_texpr e)))); "kind", encode_field_kind f.cf_kind; "pos", encode_pos f.cf_pos; "doc", null enc_string f.cf_doc; ] and encode_field_kind k = let tag, pl = (match k with | Type.Var v -> 0, [encode_var_access v.v_read; encode_var_access v.v_write] | Method m -> 1, [encode_method_kind m] ) in enc_enum IFieldKind tag pl and encode_var_access a = let tag, pl = (match a with | AccNormal -> 0, [] | AccNo -> 1, [] | AccNever -> 2, [] | AccResolve -> 3, [] | AccCall -> 4, [] | AccInline -> 5, [] | AccRequire (s,msg) -> 6, [enc_string s; null enc_string msg] ) in enc_enum IVarAccess tag pl and encode_method_kind m = let tag, pl = (match m with | MethNormal -> 0, [] | MethInline -> 1, [] | MethDynamic -> 2, [] | MethMacro -> 3, [] ) in enc_enum IMethodKind tag pl and encode_class_kind k = let tag, pl = (match k with | KNormal -> 0, [] | KTypeParameter pl -> 1, [encode_tparams pl] | KExtension (cl, params) -> 2, [encode_clref cl; encode_tparams params] | KExpr e -> 3, [encode_expr e] | KGeneric -> 4, [] | KGenericInstance (cl, params) -> 5, [encode_clref cl; encode_tparams params] | KMacroType -> 6, [] | KAbstractImpl a -> 7, [encode_ref a encode_tabstract (fun() -> s_type_path a.a_path)] ) in enc_enum IClassKind tag pl and encode_tclass c = c.cl_build(); encode_mtype (TClassDecl c) [ "kind", encode_class_kind c.cl_kind; "isExtern", VBool c.cl_extern; "exclude", VFunction (Fun0 (fun() -> c.cl_extern <- true; c.cl_init <- None; VNull)); "isInterface", VBool c.cl_interface; "superClass", (match c.cl_super with | None -> VNull | Some (c,pl) -> enc_obj ["t",encode_clref c;"params",encode_tparams pl] ); "interfaces", enc_array (List.map (fun (c,pl) -> enc_obj ["t",encode_clref c;"params",encode_tparams pl]) c.cl_implements); "fields", encode_ref c.cl_ordered_fields (encode_array encode_cfield) (fun() -> "class fields"); "statics", encode_ref c.cl_ordered_statics (encode_array encode_cfield) (fun() -> "class fields"); "constructor", (match c.cl_constructor with None -> VNull | Some c -> encode_ref c encode_cfield (fun() -> "constructor")); "init", (match c.cl_init with None -> VNull | Some e -> encode_texpr e); ] and encode_ttype t = encode_mtype (TTypeDecl t) [ "isExtern", VBool false; "exclude", VFunction (Fun0 (fun() -> VNull)); "type", encode_type t.t_type; ] and encode_tanon a = enc_obj [ "fields", encode_pmap_array encode_cfield a.a_fields; ] and encode_tparams pl = enc_array (List.map encode_type pl) and encode_clref c = encode_ref c encode_tclass (fun() -> s_type_path c.cl_path) and encode_type t = let rec loop = function | TMono r -> (match !r with | None -> 0, [encode_ref r (fun r -> match !r with None -> VNull | Some t -> encode_type t) (fun() -> "")] | Some t -> loop t) | TEnum (e, pl) -> 1 , [encode_ref e encode_tenum (fun() -> s_type_path e.e_path); encode_tparams pl] | TInst (c, pl) -> 2 , [encode_clref c; encode_tparams pl] | TType (t,pl) -> 3 , [encode_ref t encode_ttype (fun() -> s_type_path t.t_path); encode_tparams pl] | TFun (pl,ret) -> let pl = List.map (fun (n,o,t) -> enc_obj [ "name",enc_string n; "opt",VBool o; "t",encode_type t ] ) pl in 4 , [enc_array pl; encode_type ret] | TAnon a -> 5, [encode_ref a encode_tanon (fun() -> "")] | TDynamic tsub as t -> if t == t_dynamic then 6, [VNull] else 6, [encode_type tsub] | TLazy f -> loop (!f()) | TAbstract (a, pl) -> 8, [encode_ref a encode_tabstract (fun() -> s_type_path a.a_path); encode_tparams pl] in let tag, pl = loop t in enc_enum IType tag pl and encode_lazy_type t = let rec loop = function | TMono r -> (match !r with | Some t -> loop t | _ -> encode_type t) | TLazy f -> enc_enum IType 7 [VAbstract (ALazyType f)] | _ -> encode_type t in loop t and decode_type t = match decode_enum t with | 0, [r] -> TMono (decode_ref r) | 1, [e; pl] -> TEnum (decode_ref e, List.map decode_type (dec_array pl)) | 2, [c; pl] -> TInst (decode_ref c, List.map decode_type (dec_array pl)) | 3, [t; pl] -> TType (decode_ref t, List.map decode_type (dec_array pl)) | 4, [pl; r] -> TFun (List.map (fun p -> dec_string (field p "name"), dec_bool (field p "opt"), decode_type (field p "t")) (dec_array pl), decode_type r) | 5, [a] -> TAnon (decode_ref a) | 6, [VNull] -> t_dynamic | 6, [t] -> TDynamic (decode_type t) | 7, [VAbstract (ALazyType f)] -> TLazy f | 8, [a; pl] -> TAbstract (decode_ref a, List.map decode_type (dec_array pl)) | _ -> raise Invalid_expr and encode_texpr e = VAbstract (ATExpr e) let decode_tdecl v = match v with | VObject o -> (match get_field o (hash "__t") with | VAbstract (ATDecl t) -> t | _ -> raise Invalid_expr) | _ -> raise Invalid_expr (* ---------------------------------------------------------------------- *) (* TYPE DEFINITION *) let decode_type_def v = let pack = List.map dec_string (dec_array (field v "pack")) in let name = dec_string (field v "name") in let meta = decode_meta_content (field v "meta") in let pos = decode_pos (field v "pos") in let isExtern = dec_bool (field v "isExtern") in let fields = List.map decode_field (dec_array (field v "fields")) in let mk fl dl = { d_name = name; d_doc = None; d_params = List.map decode_tparam_decl (dec_array (field v "params")); d_meta = meta; d_flags = fl; d_data = dl; } in let tdef = (match decode_enum (field v "kind") with | 0, [] -> let conv f = let loop (n,opt,t,_) = match t with | None -> raise Invalid_expr | Some t -> n, opt, t in let args, params, t = (match f.cff_kind with | FVar (t,None) -> [], [], t | FFun f -> List.map loop f.f_args, f.f_params, f.f_type | _ -> raise Invalid_expr ) in { ec_name = f.cff_name; ec_doc = f.cff_doc; ec_meta = f.cff_meta; ec_pos = f.cff_pos; ec_args = args; ec_params = params; ec_type = t; } in EEnum (mk (if isExtern then [EExtern] else []) (List.map conv fields)) | 1, [] -> ETypedef (mk (if isExtern then [EExtern] else []) (CTAnonymous fields)) | 2, [ext;impl;interf] -> let flags = if isExtern then [HExtern] else [] in let flags = (match interf with VNull | VBool false -> flags | VBool true -> HInterface :: flags | _ -> raise Invalid_expr) in let flags = (match opt decode_path ext with None -> flags | Some t -> HExtends t :: flags) in let flags = (match opt (fun v -> List.map decode_path (dec_array v)) impl with None -> flags | Some l -> List.map (fun t -> HImplements t) l @ flags) in EClass (mk flags fields) | 3, [t] -> ETypedef (mk (if isExtern then [EExtern] else []) (decode_ctype t)) | 4, [tthis;tfrom;tto] -> let flags = match opt dec_array tfrom with None -> [] | Some ta -> List.map (fun t -> AFromType (decode_ctype t)) ta in let flags = match opt dec_array tto with None -> flags | Some ta -> (List.map (fun t -> AToType (decode_ctype t)) ta) @ flags in let flags = match opt decode_ctype tthis with None -> flags | Some t -> (AIsType t) :: flags in EAbstract(mk flags fields) | _ -> raise Invalid_expr ) in (pack, name), tdef, pos (* ---------------------------------------------------------------------- *) (* VALUE-TO-CONSTANT *) let rec make_const e = match e.eexpr with | TConst c -> (match c with | TInt i -> best_int i | TFloat s -> VFloat (float_of_string s) | TString s -> enc_string s | TBool b -> VBool b | TNull -> VNull | TThis | TSuper -> raise Exit) | TParenthesis e -> make_const e | TObjectDecl el -> VObject (obj (hash_field (get_ctx())) (List.map (fun (f,e) -> f, make_const e) el)) | TArrayDecl al -> enc_array (List.map make_const al) | _ -> raise Exit (* ---------------------------------------------------------------------- *) (* TEXPR-TO-AST-EXPR *) open Ast let tpath p mp pl = if snd mp = snd p then CTPath { tpackage = fst p; tname = snd p; tparams = List.map (fun t -> TPType t) pl; tsub = None; } else CTPath { tpackage = fst mp; tname = snd mp; tparams = List.map (fun t -> TPType t) pl; tsub = Some (snd p); } let rec make_type = function | TMono r -> (match !r with | None -> raise Exit | Some t -> make_type t) | TEnum (e,pl) -> tpath e.e_path e.e_module.m_path (List.map make_type pl) | TInst({cl_kind = KTypeParameter _} as c,pl) -> tpath ([],snd c.cl_path) ([],snd c.cl_path) (List.map make_type pl) | TInst (c,pl) -> tpath c.cl_path c.cl_module.m_path (List.map make_type pl) | TType (t,pl) as tf -> (* recurse on type-type *) if (snd t.t_path).[0] = '#' then make_type (follow tf) else tpath t.t_path t.t_module.m_path (List.map make_type pl) | TAbstract (a,pl) -> tpath a.a_path a.a_module.m_path (List.map make_type pl) | TFun (args,ret) -> CTFunction (List.map (fun (_,_,t) -> make_type t) args, make_type ret) | TAnon a -> begin match !(a.a_status) with | Statics c -> tpath ([],"Class") ([],"Class") [tpath c.cl_path c.cl_path []] | EnumStatics e -> tpath ([],"Enum") ([],"Enum") [tpath e.e_path e.e_path []] | _ -> CTAnonymous (PMap.foldi (fun _ f acc -> { cff_name = f.cf_name; cff_kind = FVar (mk_ot f.cf_type,None); cff_pos = f.cf_pos; cff_doc = f.cf_doc; cff_meta = f.cf_meta; cff_access = []; } :: acc ) a.a_fields []) end | (TDynamic t2) as t -> tpath ([],"Dynamic") ([],"Dynamic") (if t == t_dynamic then [] else [make_type t2]) | TLazy f -> make_type ((!f)()) and mk_ot t = match follow t with | TMono _ -> None | _ -> (try Some (make_type t) with Exit -> None) let rec make_ast e = let full_type_path t = let mp,p = match t with | TClassDecl c -> c.cl_module.m_path,c.cl_path | TEnumDecl en -> en.e_module.m_path,en.e_path | TAbstractDecl a -> a.a_module.m_path,a.a_path | TTypeDecl t -> t.t_module.m_path,t.t_path in if snd mp = snd p then p else (fst mp) @ [snd mp],snd p in let mk_path (pack,name) p = match List.rev pack with | [] -> (EConst (Ident name),p) | pl -> let rec loop = function | [] -> assert false | [n] -> (EConst (Ident n),p) | n :: l -> (EField (loop l, n),p) in (EField (loop pl,name),p) in let mk_const = function | TInt i -> Int (Int32.to_string i) | TFloat s -> Float s | TString s -> String s | TBool b -> Ident (if b then "true" else "false") | TNull -> Ident "null" | TThis -> Ident "this" | TSuper -> Ident "super" in let mk_ident = function | "`trace" -> Ident "trace" | n -> Ident n in let eopt = function None -> None | Some e -> Some (make_ast e) in ((match e.eexpr with | TConst c -> EConst (mk_const c) | TLocal v -> EConst (mk_ident v.v_name) | TArray (e1,e2) -> EArray (make_ast e1,make_ast e2) | TBinop (op,e1,e2) -> EBinop (op, make_ast e1, make_ast e2) | TField (e,f) -> EField (make_ast e, Type.field_name f) | TTypeExpr t -> fst (mk_path (full_type_path t) e.epos) | TParenthesis e -> EParenthesis (make_ast e) | TObjectDecl fl -> EObjectDecl (List.map (fun (f,e) -> f, make_ast e) fl) | TArrayDecl el -> EArrayDecl (List.map make_ast el) | TCall (e,el) -> ECall (make_ast e,List.map make_ast el) | TNew (c,pl,el) -> ENew ((match (try make_type (TInst (c,pl)) with Exit -> make_type (TInst (c,[]))) with CTPath p -> p | _ -> assert false),List.map make_ast el) | TUnop (op,p,e) -> EUnop (op,p,make_ast e) | TFunction f -> let arg (v,c) = v.v_name, false, mk_ot v.v_type, (match c with None -> None | Some c -> Some (EConst (mk_const c),e.epos)) in EFunction (None,{ f_params = []; f_args = List.map arg f.tf_args; f_type = mk_ot f.tf_type; f_expr = Some (make_ast f.tf_expr) }) | TVars vl -> EVars (List.map (fun (v,e) -> v.v_name, mk_ot v.v_type, eopt e) vl) | TBlock el -> EBlock (List.map make_ast el) | TFor (v,it,e) -> let ein = (EIn ((EConst (Ident v.v_name),it.epos),make_ast it),it.epos) in EFor (ein,make_ast e) | TIf (e,e1,e2) -> EIf (make_ast e,make_ast e1,eopt e2) | TWhile (e1,e2,flag) -> EWhile (make_ast e1, make_ast e2, flag) | TSwitch (e,cases,def) -> let cases = List.map (fun (vl,e) -> List.map make_ast vl,None,(match e.eexpr with TBlock [] -> None | _ -> Some (make_ast e)) ) cases in let def = match eopt def with None -> None | Some (EBlock [],_) -> Some None | e -> Some e in ESwitch (make_ast e,cases,def) | TMatch (e,(en,_),cases,def) -> let scases (idx,args,e) = let p = e.epos in let unused = (EConst (Ident "_"),p) in let args = (match args with | None -> None | Some l -> Some (List.map (function None -> unused | Some v -> (EConst (Ident v.v_name),p)) l) ) in let mk_args n = match args with | None -> [unused] | Some args -> args @ Array.to_list (Array.make (n - List.length args) unused) in List.map (fun i -> let c = (try List.nth en.e_names i with _ -> assert false) in let cfield = (try PMap.find c en.e_constrs with Not_found -> assert false) in let c = (EConst (Ident c),p) in (match follow cfield.ef_type with TFun (eargs,_) -> (ECall (c,mk_args (List.length eargs)),p) | _ -> c) ) idx, None, (match e.eexpr with TBlock [] -> None | _ -> Some (make_ast e)) in let def = match eopt def with None -> None | Some (EBlock [],_) -> Some None | e -> Some e in ESwitch (make_ast e,List.map scases cases,def) | TTry (e,catches) -> ETry (make_ast e,List.map (fun (v,e) -> v.v_name, (try make_type v.v_type with Exit -> assert false), make_ast e) catches) | TReturn e -> EReturn (eopt e) | TBreak -> EBreak | TContinue -> EContinue | TThrow e -> EThrow (make_ast e) | TCast (e,t) -> let t = (match t with | None -> None | Some t -> let t = (match t with TClassDecl c -> TInst (c,[]) | TEnumDecl e -> TEnum (e,[]) | TTypeDecl t -> TType (t,[]) | TAbstractDecl a -> TAbstract (a,[])) in Some (try make_type t with Exit -> assert false) ) in ECast (make_ast e,t)) ,e.epos) ;; make_ast_ref := make_ast; make_complex_type_ref := make_type; encode_complex_type_ref := encode_ctype; enc_array_ref := enc_array; encode_type_ref := encode_type; decode_type_ref := decode_type; encode_expr_ref := encode_expr; decode_expr_ref := decode_expr; encode_clref_ref := encode_clref; enc_string_ref := enc_string; enc_hash_ref := enc_hashhaxe-3.0~svn6707/libs/0000755000175000017500000000000012172015451015133 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/swflib/0000755000175000017500000000000012172015640016421 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/swflib/as3code.ml0000644000175000017500000005335112172015137020304 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2004-2006 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open IO open As3 let s = Printf.sprintf let f_int_length : (int -> int) ref = ref (fun _ -> assert false) let f_int_read : (IO.input -> int) ref = ref (fun _ -> assert false) let f_int_write : (unit IO.output -> int -> unit) ref = ref (fun _ _ -> assert false) let int_length i = (!f_int_length) i let read_int ch = (!f_int_read) ch let write_int (ch : 'a IO.output) i = (!f_int_write) (Obj.magic ch) i let int_index (x : 'a index) : int = Obj.magic x let index_int (x : int) : 'a index = Obj.magic x let int_index_nz (x : 'a index_nz) : int = Obj.magic x let index_nz_int (x : int) : 'a index_nz = Obj.magic x let read_index ch = index_int (read_int ch) let write_index ch i = write_int ch (int_index i) let read_index_nz ch = index_nz_int (read_int ch) let write_index_nz ch i = write_int ch (int_index_nz i) let iget (t : 'a array) (i : 'a index) : 'a = t.(Obj.magic i - 1) let write_signed_byte = write_byte let max_i24 = 1 lsl 23 - 1 let read_i24 ch = let a = read_byte ch in let b = read_byte ch in let c = read_byte ch in let n = a lor (b lsl 8) lor (c lsl 16) in if c land 128 <> 0 then n - (1 lsl 24) else n let rec write_i24 ch n = if n < -max_i24 || n > max_i24 then assert false; let n = (if n land (1 lsl 23) <> 0 then n + (1 lsl 24) else n) in write_byte ch n; write_byte ch (n lsr 8); write_byte ch (n lsr 16) let ops , ops_ids = let h = Hashtbl.create 0 in let h2 = Hashtbl.create 0 in List.iter (fun (o,b) -> Hashtbl.add h b o; Hashtbl.add h2 o b) [ A3OAs, 0x87; A3ONeg, 0x90; A3OIncr, 0x91; (* 0x92 : REGINCR *) A3ODecr, 0x93; (* 0x94 : REGDECR *) (* 0x95 : TYPEOF *) A3ONot, 0x96; A3OBitNot, 0x97; A3OAdd, 0xA0; A3OSub, 0xA1; A3OMul, 0xA2; A3ODiv, 0xA3; A3OMod, 0xA4; A3OShl, 0xA5; A3OShr, 0xA6; A3OUShr, 0xA7; A3OAnd, 0xA8; A3OOr, 0xA9; A3OXor, 0xAA; A3OEq, 0xAB; A3OPhysEq, 0xAC; A3OLt, 0xAD; A3OLte, 0xAE; A3OGt, 0xAF; A3OGte, 0xB0; A3OIs, 0xB3; A3OIn, 0xB4; A3OIIncr, 0xC0; A3OIDecr, 0xC1; A3OINeg, 0xC4; A3OIAdd, 0xC5; A3OISub, 0xC6; A3OIMul, 0xC7; A3OMemGet8, 0x35; A3OMemGet16, 0x36; A3OMemGet32, 0x37; A3OMemGetFloat, 0x38; A3OMemGetDouble, 0x39; A3OMemSet8, 0x3A; A3OMemSet16, 0x3B; A3OMemSet32, 0x3C; A3OMemSetFloat, 0x3D; A3OMemSetDouble, 0x3E; A3OSign1, 0x50; A3OSign8, 0x51; A3OSign16, 0x52; ]; h , h2 let length = function | A3SmallInt _ -> 2 | A3Construct n | A3Object n | A3RegKill n | A3Catch n | A3IncrReg n | A3DecrReg n | A3IncrIReg n | A3DecrIReg n | A3Array n | A3Int n | A3CallStack n | A3ConstructSuper n | A3BreakPointLine n | A3ApplyType n | A3DebugLine n -> 1 + int_length n | A3GetSlot s | A3SetSlot s -> 1 + int_length s | A3ClassDef n -> 1 + int_length (int_index_nz n) | A3DxNs f | A3String f | A3DebugFile f -> 1 + int_length (int_index f) | A3IntRef f -> 1 + int_length (int_index f) | A3UIntRef f -> 1 + int_length (int_index f) | A3Float f -> 1 + int_length (int_index f) | A3Function f -> 1 + int_length (int_index_nz f) | A3Namespace f -> 1 + int_length (int_index f) | A3GetProp f | A3InitProp f | A3DeleteProp f | A3FindPropStrict f | A3FindProp f | A3FindDefinition f | A3GetLex f | A3SetProp f | A3Cast f | A3GetSuper f | A3GetDescendants f | A3SetSuper f -> 1 + int_length (int_index f) | A3Op _ | A3Undefined | A3Null | A3True | A3False | A3NaN | A3RetVoid | A3Ret | A3Pop | A3Dup | A3Swap | A3AsAny | A3ToString | A3ToXml | A3ToXmlAttr | A3ToInt | A3ToUInt | A3ToNumber | A3ToBool | A3ToObject | A3AsString | A3AsObject | A3This | A3Throw | A3Nop | A3Typeof | A3InstanceOf | A3Scope | A3ForIn | A3NewBlock | A3ForEach | A3PopScope | A3CheckIsXml | A3Label | A3BreakPoint | A3PushWith | A3HasNext | A3SetThis | A3Timestamp | A3DxNsLate | A3Unk _ -> 1 | A3AsType n | A3IsType n -> 1 + int_length (int_index n) | A3DebugReg (name,reg,line) -> 1 + 1 + int_length (int_index name) + 1 + int_length line | A3GetGlobalScope -> 1 | A3GetScope n -> 1 + int_length n | A3Reg n | A3SetReg n -> if n >= 1 && n <= 3 then 1 else (1 + int_length n) | A3CallSuper (f,n) | A3CallProperty (f,n) | A3ConstructProperty (f,n) | A3CallPropLex (f,n) | A3CallPropVoid (f,n) | A3CallSuperVoid (f,n) -> 1 + int_length n + int_length (int_index f) | A3CallMethod (f,n) -> 1 + int_length n + int_length f | A3CallStatic (f,n) -> 1 + int_length n + int_length (int_index f) | A3Jump _ -> 4 | A3Next (a,b) -> 1 + int_length a + int_length b | A3Switch (_,cases) -> let ncases = List.length cases in 1 + 3 + int_length (ncases - 1) + 3 * ncases let jump ch kind = A3Jump (kind,read_i24 ch) let opcode ch = let op = (try read_byte ch with IO.No_more_input -> raise Exit) in match op with | 0x01 -> A3BreakPoint | 0x02 -> A3Nop | 0x03 -> A3Throw | 0x04 -> A3GetSuper (read_index ch) | 0x05 -> A3SetSuper (read_index ch) | 0x06 -> A3DxNs (read_index ch) | 0x07 -> A3DxNsLate | 0x08 -> A3RegKill (read_int ch) | 0x09 -> A3Label (* 0x0A -> NONE *) (* 0x0B -> NONE *) | 0x0C -> jump ch J3NotLt | 0x0D -> jump ch J3NotLte | 0x0E -> jump ch J3NotGt | 0x0F -> jump ch J3NotGte | 0x10 -> jump ch J3Always | 0x11 -> jump ch J3True | 0x12 -> jump ch J3False | 0x13 -> jump ch J3Eq | 0x14 -> jump ch J3Neq | 0x15 -> jump ch J3Lt | 0x16 -> jump ch J3Lte | 0x17 -> jump ch J3Gt | 0x18 -> jump ch J3Gte | 0x19 -> jump ch J3PhysEq | 0x1A -> jump ch J3PhysNeq | 0x1B -> let def = read_i24 ch in let rec loop n = if n = 0 then [] else let j = read_i24 ch in j :: loop (n - 1) in let cases = loop (read_int ch + 1) in A3Switch (def,cases) | 0x1C -> A3PushWith | 0x1D -> A3PopScope | 0x1E -> A3ForIn | 0x1F -> A3HasNext | 0x20 -> A3Null | 0x21 -> A3Undefined (* 0x22 -> NONE *) | 0x23 -> A3ForEach | 0x24 -> A3SmallInt (read_signed_byte ch) | 0x25 -> A3Int (read_int ch) | 0x26 -> A3True | 0x27 -> A3False | 0x28 -> A3NaN | 0x29 -> A3Pop | 0x2A -> A3Dup | 0x2B -> A3Swap | 0x2C -> A3String (read_index ch) | 0x2D -> A3IntRef (read_index ch) | 0x2E -> A3UIntRef (read_index ch) | 0x2F -> A3Float (read_index ch) | 0x30 -> A3Scope | 0x31 -> A3Namespace (read_index ch) | 0x32 -> let r1 = read_int ch in let r2 = read_int ch in A3Next (r1,r2) (* 0x33 - 0x3F -> NONE *) | 0x40 -> A3Function (read_index_nz ch) | 0x41 -> A3CallStack (read_int ch) | 0x42 -> A3Construct (read_int ch) | 0x43 -> let id = read_int ch in let nargs = read_int ch in A3CallMethod (id,nargs) | 0x44 -> let id = read_index ch in let nargs = read_int ch in A3CallStatic (id,nargs) | 0x45 -> let id = read_index ch in let nargs = read_int ch in A3CallSuper (id,nargs) | 0x46 -> let id = read_index ch in let nargs = read_int ch in A3CallProperty (id,nargs) | 0x47 -> A3RetVoid | 0x48 -> A3Ret | 0x49 -> A3ConstructSuper (read_int ch) | 0x4A -> let id = read_index ch in let nargs = read_int ch in A3ConstructProperty (id,nargs) (* 0x4B -> NONE *) | 0x4C -> let id = read_index ch in let nargs = read_int ch in A3CallPropLex (id,nargs) (* 0x4D -> NONE *) | 0x4E -> let id = read_index ch in let nargs = read_int ch in A3CallSuperVoid (id,nargs) | 0x4F -> let id = read_index ch in let nargs = read_int ch in A3CallPropVoid (id,nargs) (* 0x50 - 0x52 -> NONE *) | 0x53 -> A3ApplyType (read_int ch) (* 0x54 -> NONE *) | 0x55 -> A3Object (read_int ch) | 0x56 -> A3Array (read_int ch) | 0x57 -> A3NewBlock | 0x58 -> A3ClassDef (read_index_nz ch) | 0x59 -> A3GetDescendants (read_index ch) | 0x5A -> A3Catch (read_int ch) (* 0x5B -> NONE *) (* 0x5C -> NONE *) | 0x5D -> A3FindPropStrict (read_index ch) | 0x5E -> A3FindProp (read_index ch) | 0x5F -> A3FindDefinition (read_index ch) | 0x60 -> A3GetLex (read_index ch) | 0x61 -> A3SetProp (read_index ch) | 0x62 -> A3Reg (read_int ch) | 0x63 -> A3SetReg (read_int ch) | 0x64 -> A3GetGlobalScope | 0x65 -> A3GetScope (IO.read_byte ch) | 0x66 -> A3GetProp (read_index ch) (* 0x67 -> NONE *) | 0x68 -> A3InitProp (read_index ch) (* 0x69 -> NONE *) | 0x6A -> A3DeleteProp (read_index ch) (* 0x6B -> NONE *) | 0x6C -> A3GetSlot (read_int ch) | 0x6D -> A3SetSlot (read_int ch) (* 0x6E -> DEPRECATED getglobalslot *) (* 0x6F -> DEPRECATED setglobalslot *) | 0x70 -> A3ToString | 0x71 -> A3ToXml | 0x72 -> A3ToXmlAttr | 0x73 -> A3ToInt | 0x74 -> A3ToUInt | 0x75 -> A3ToNumber | 0x76 -> A3ToBool | 0x77 -> A3ToObject | 0x78 -> A3CheckIsXml (* 0x79 -> NONE *) | 0x80 -> A3Cast (read_index ch) (* 0x81 -> DEPRECATED asbool *) | 0x82 -> A3AsAny (* 0x83 -> DEPRECATED asint *) (* 0x84 -> DEPRECATED asnumber *) | 0x85 -> A3AsString | 0x86 -> A3AsType (read_index ch) (* 0x87 -> OP *) (* 0x88 -> DEPRECATED asuint *) | 0x89 -> A3AsObject (* 0x8A - 0x8F -> NONE *) (* 0x90 - 0x91 -> OP *) | 0x92 -> A3IncrReg (read_int ch) (* 0x93 -> OP *) | 0x94 -> A3DecrReg (read_int ch) | 0x95 -> A3Typeof (* 0x96 -> OP *) (* 0x97 -> OP *) (* 0x98 - 0x9F -> NONE *) (* 0xA0 - 0xB0 -> OP *) | 0xB1 -> A3InstanceOf | 0xB2 -> A3IsType (read_index ch) (* 0xB3 -> OP *) (* 0xB4 -> OP *) (* 0xB5 - 0xBF -> NONE *) (* 0xC0 -> OP *) (* 0xC1 -> OP *) | 0xC2 -> A3IncrIReg (read_int ch) | 0xC3 -> A3DecrIReg (read_int ch) (* 0xC4 - 0xC7 -> OP *) (* 0xC8 - 0xCF -> NONE *) | 0xD0 -> A3This | 0xD1 -> A3Reg 1 | 0xD2 -> A3Reg 2 | 0xD3 -> A3Reg 3 | 0xD4 -> A3SetThis | 0xD5 -> A3SetReg 1 | 0xD6 -> A3SetReg 2 | 0xD7 -> A3SetReg 3 (* 0xD8 - 0xEE -> NONE *) | 0xEF -> if IO.read_byte ch <> 1 then assert false; let name = read_index ch in let reg = read_byte ch + 1 in let line = read_int ch in A3DebugReg (name,reg,line) | 0xF0 -> A3DebugLine (read_int ch) | 0xF1 -> A3DebugFile (read_index ch) | 0xF2 -> A3BreakPointLine (read_int ch) | 0xF3 -> A3Timestamp (* 0xF4 - 0xFF -> NONE *) | _ -> try A3Op (Hashtbl.find ops op) with Not_found -> Printf.printf "Unknown opcode 0x%.2X\n" op; A3Unk (char_of_int op) let parse ch len = let data = nread ch len in let ch = input_string data in let a = MultiArray.create() in let rec loop() = MultiArray.add a (opcode ch); loop(); in (try loop() with Exit -> ()); a let write ch = function | A3BreakPoint -> write_byte ch 0x01 | A3Nop -> write_byte ch 0x02 | A3Throw -> write_byte ch 0x03 | A3GetSuper f -> write_byte ch 0x04; write_index ch f | A3SetSuper f -> write_byte ch 0x05; write_index ch f | A3DxNs i -> write_byte ch 0x06; write_index ch i | A3DxNsLate -> write_byte ch 0x07 | A3RegKill n -> write_byte ch 0x08; write_int ch n | A3Label -> write_byte ch 0x09 | A3Jump (k,n) -> write_byte ch (match k with | J3NotLt -> 0x0C | J3NotLte -> 0x0D | J3NotGt -> 0x0E | J3NotGte -> 0x0F | J3Always -> 0x10 | J3True -> 0x11 | J3False -> 0x12 | J3Eq -> 0x13 | J3Neq -> 0x14 | J3Lt -> 0x15 | J3Lte -> 0x16 | J3Gt -> 0x17 | J3Gte -> 0x18 | J3PhysEq -> 0x19 | J3PhysNeq -> 0x1A ); write_i24 ch n | A3Switch (def,cases) -> write_byte ch 0x1B; write_i24 ch def; write_int ch (List.length cases - 1); List.iter (write_i24 ch) cases | A3PushWith -> write_byte ch 0x1C | A3PopScope -> write_byte ch 0x1D | A3ForIn -> write_byte ch 0x1E | A3HasNext -> write_byte ch 0x1F | A3Null -> write_byte ch 0x20 | A3Undefined -> write_byte ch 0x21 | A3ForEach -> write_byte ch 0x23 | A3SmallInt b -> write_byte ch 0x24; write_signed_byte ch b | A3Int i -> write_byte ch 0x25; write_int ch i | A3True -> write_byte ch 0x26 | A3False -> write_byte ch 0x27 | A3NaN -> write_byte ch 0x28 | A3Pop -> write_byte ch 0x29 | A3Dup -> write_byte ch 0x2A | A3Swap -> write_byte ch 0x2B | A3String s -> write_byte ch 0x2C; write_index ch s | A3IntRef i -> write_byte ch 0x2D; write_index ch i | A3UIntRef i -> write_byte ch 0x2E; write_index ch i | A3Float f -> write_byte ch 0x2F; write_index ch f | A3Scope -> write_byte ch 0x30 | A3Namespace f -> write_byte ch 0x31; write_index ch f | A3Next (r1,r2) -> write_byte ch 0x32; write_int ch r1; write_int ch r2 | A3Function f -> write_byte ch 0x40; write_index_nz ch f | A3CallStack n -> write_byte ch 0x41; write_int ch n | A3Construct n -> write_byte ch 0x42; write_int ch n | A3CallMethod (f,n) -> write_byte ch 0x43; write_int ch f; write_int ch n | A3CallStatic (f,n) -> write_byte ch 0x44; write_index ch f; write_int ch n | A3CallSuper (f,n) -> write_byte ch 0x45; write_index ch f; write_int ch n | A3CallProperty (f,n) -> write_byte ch 0x46; write_index ch f; write_int ch n | A3RetVoid -> write_byte ch 0x47 | A3Ret -> write_byte ch 0x48 | A3ConstructSuper n -> write_byte ch 0x49; write_int ch n | A3ConstructProperty (f,n) -> write_byte ch 0x4A; write_index ch f; write_int ch n | A3CallPropLex (f,n) -> write_byte ch 0x4C; write_index ch f; write_int ch n | A3CallSuperVoid (f,n) -> write_byte ch 0x4E; write_index ch f; write_int ch n | A3CallPropVoid (f,n) -> write_byte ch 0x4F; write_index ch f; write_int ch n | A3ApplyType n -> write_byte ch 0x53; write_int ch n | A3Object n -> write_byte ch 0x55; write_int ch n | A3Array n -> write_byte ch 0x56; write_int ch n | A3NewBlock -> write_byte ch 0x57 | A3ClassDef f -> write_byte ch 0x58; write_index_nz ch f | A3GetDescendants f -> write_byte ch 0x59; write_index ch f | A3Catch n -> write_byte ch 0x5A; write_int ch n | A3FindPropStrict f -> write_byte ch 0x5D; write_index ch f | A3FindProp f -> write_byte ch 0x5E; write_index ch f | A3FindDefinition f -> write_byte ch 0x5F; write_index ch f | A3GetLex f -> write_byte ch 0x60; write_index ch f | A3SetProp f -> write_byte ch 0x61; write_index ch f | A3Reg n -> if n >= 0 && n < 4 then write_byte ch (0xD0 + n) else begin write_byte ch 0x62; write_int ch n end | A3SetReg n -> if n >= 0 && n < 4 then write_byte ch (0xD4 + n) else begin write_byte ch 0x63; write_int ch n end | A3GetGlobalScope -> write_byte ch 0x64 | A3GetScope n -> write_byte ch 0x65; write_byte ch n | A3GetProp f -> write_byte ch 0x66; write_index ch f | A3InitProp f -> write_byte ch 0x68; write_index ch f | A3DeleteProp f -> write_byte ch 0x6A; write_index ch f | A3GetSlot n -> write_byte ch 0x6C; write_int ch n | A3SetSlot n -> write_byte ch 0x6D; write_int ch n | A3ToString -> write_byte ch 0x70 | A3ToXml -> write_byte ch 0x71 | A3ToXmlAttr -> write_byte ch 0x72 | A3ToInt -> write_byte ch 0x73 | A3ToUInt -> write_byte ch 0x74 | A3ToNumber -> write_byte ch 0x75 | A3ToBool -> write_byte ch 0x76 | A3ToObject -> write_byte ch 0x77 | A3CheckIsXml -> write_byte ch 0x78 | A3Cast f -> write_byte ch 0x80; write_index ch f | A3AsAny -> write_byte ch 0x82 | A3AsString -> write_byte ch 0x85 | A3AsType n -> write_byte ch 0x86; write_index ch n | A3AsObject -> write_byte ch 0x89 | A3IncrReg r -> write_byte ch 0x92; write_int ch r | A3DecrReg r -> write_byte ch 0x94; write_int ch r | A3Typeof -> write_byte ch 0x95 | A3InstanceOf -> write_byte ch 0xB1 | A3IsType n -> write_byte ch 0xB2; write_index ch n | A3IncrIReg r -> write_byte ch 0xC2; write_int ch r | A3DecrIReg r -> write_byte ch 0xC3; write_int ch r | A3This -> write_byte ch 0xD0 | A3SetThis -> write_byte ch 0xD4 | A3DebugReg (name,reg,line) -> write_byte ch 0xEF; write_byte ch 0x01; write_index ch name; write_byte ch (reg - 1); write_int ch line; | A3DebugLine f -> write_byte ch 0xF0; write_int ch f; | A3DebugFile f -> write_byte ch 0xF1; write_index ch f; | A3BreakPointLine l -> write_byte ch 0xF2; write_int ch l | A3Timestamp -> write_byte ch 0xF3 | A3Op op -> write_byte ch (try Hashtbl.find ops_ids op with Not_found -> assert false) | A3Unk x -> write ch x let dump_op = function | A3OAs -> "as" | A3ONeg -> "neg" | A3OIncr -> "incr" | A3ODecr -> "decr" | A3ONot -> "not" | A3OBitNot -> "bitnot" | A3OAdd -> "add" | A3OSub -> "sub" | A3OMul -> "mul" | A3ODiv -> "div" | A3OMod -> "mod" | A3OShl -> "shl" | A3OShr -> "shr" | A3OUShr -> "ushr" | A3OAnd -> "and" | A3OOr -> "or" | A3OXor -> "xor" | A3OEq -> "eq" | A3OPhysEq -> "physeq" | A3OLt -> "lt" | A3OLte -> "lte" | A3OGt -> "gt" | A3OGte -> "gte" | A3OIs -> "is" | A3OIn -> "in" | A3OIIncr -> "iincr" | A3OIDecr -> "idecr" | A3OINeg -> "ineg" | A3OIAdd -> "iadd" | A3OISub -> "isub" | A3OIMul -> "imul" | A3OMemSet8 -> "mset8" | A3OMemSet16 -> "set16" | A3OMemSet32 -> "mset32" | A3OMemSetFloat -> "msetfloat" | A3OMemSetDouble -> "msetdouble" | A3OMemGet8 -> "mget8" | A3OMemGet16 -> "mget16" | A3OMemGet32 -> "mget32" | A3OMemGetFloat -> "mgetfloat" | A3OMemGetDouble -> "mgetdouble" | A3OSign1 -> "sign1" | A3OSign8 -> "sign8" | A3OSign16 -> "sign16" let dump_jump = function | J3NotLt -> "-nlt" | J3NotLte -> "-nlte" | J3NotGt -> "-ngt" | J3NotGte -> "-ngte" | J3Always -> "" | J3True -> "-if" | J3False -> "-ifnot" | J3Eq -> "-eq" | J3Neq -> "-neq" | J3Lt -> "-lt" | J3Lte -> "-lte" | J3Gt -> "-gt" | J3Gte -> "-gte" | J3PhysEq -> "-peq" | J3PhysNeq -> "-pneq" let dump ctx op = let ident n = ctx.as3_idents.(int_index n - 1) in let rec field n = let t = ctx.as3_names.(int_index n - 1) in match t with | A3MMultiName (Some ident,_) -> "[" ^ iget ctx.as3_idents ident ^ "]" | A3MName (ident,_) -> iget ctx.as3_idents ident | A3MMultiNameLate idx -> "~array" | A3MParams (t,params) -> field t ^ "<" ^ String.concat "." (List.map field params) ^ ">" | _ -> "???" in match op with | A3BreakPoint -> "bkpt" | A3Nop -> "nop" | A3Throw -> "throw" | A3GetSuper f -> s "getsuper %s" (field f) | A3SetSuper f -> s "setsuper %s" (field f) | A3DxNs i -> s "dxns %s" (ident i) | A3DxNsLate -> "dxnslate" | A3RegKill n -> s "kill %d" n | A3Label -> "label" | A3Jump (k,n) -> s "jump%s %d" (dump_jump k) n | A3Switch (def,cases) -> s "switch %d [%s]" def (String.concat "," (List.map (s "%d") cases)) | A3PushWith -> "pushwith" | A3PopScope -> "popscope" | A3ForIn -> "forin" | A3HasNext -> "hasnext" | A3Null -> "null" | A3Undefined -> "undefined" | A3ForEach -> "foreach" | A3SmallInt b -> s "int %d" b | A3Int n -> s "int %d" n | A3True -> "true" | A3False -> "false" | A3NaN -> "nan" | A3Pop -> "pop" | A3Dup -> "dup" | A3Swap -> "swap" | A3String n -> s "string [%s]" (ident n) | A3IntRef n -> s "int [%ld]" ctx.as3_ints.(int_index n - 1) | A3UIntRef n -> s "uint [%ld]" ctx.as3_uints.(int_index n - 1) | A3Float n -> s "float [%f]" ctx.as3_floats.(int_index n - 1) | A3Scope -> "scope" | A3Namespace f -> s "namespace [%d]" (int_index f) | A3Next (r1,r2) -> s "next %d %d" r1 r2 | A3Function f -> s "function #%d" (int_index_nz f) | A3CallStack n -> s "callstack (%d)" n | A3Construct n -> s "construct (%d)" n | A3CallMethod (f,n) -> s "callmethod %d (%d)" f n | A3CallStatic (f,n) -> s "callstatic %d (%d)" (int_index f) n | A3CallSuper (f,n) -> s "callsuper %s (%d)" (field f) n | A3CallProperty (f,n) -> s "callprop %s (%d)" (field f) n | A3RetVoid -> "retvoid" | A3Ret -> "ret" | A3ConstructSuper n -> s "constructsuper %d" n | A3ConstructProperty (f,n) -> s "constructprop %s (%d)" (field f) n | A3CallPropLex (f,n) -> s "callproplex %s (%d)" (field f) n | A3CallSuperVoid (f,n) -> s "callsupervoid %s (%d)" (field f) n | A3CallPropVoid (f,n) -> s "callpropvoid %s (%d)" (field f) n | A3ApplyType n -> s "applytype %d" n | A3Object n -> s "object %d" n | A3Array n -> s "array %d" n | A3NewBlock -> "newblock" | A3ClassDef n -> s "classdef %d" (int_index_nz n) | A3GetDescendants f -> s "getdescendants %s" (field f) | A3Catch n -> s "catch %d" n | A3FindPropStrict f -> s "findpropstrict %s" (field f) | A3FindProp f -> s "findprop %s" (field f) | A3FindDefinition f -> s "finddefinition %s" (field f) | A3GetLex f -> s "getlex %s" (field f) | A3SetProp f -> s "setprop %s" (field f) | A3Reg n -> s "reg %d" n | A3SetReg n -> s "setreg %d" n | A3GetGlobalScope -> "getglobalscope" | A3GetScope n -> s "getscope %d" n | A3GetProp f -> s "getprop %s" (field f) | A3InitProp f -> s "initprop %s" (field f) | A3DeleteProp f -> s "deleteprop %s" (field f) | A3GetSlot n -> s "getslot %d" n | A3SetSlot n -> s "setslot %d" n | A3ToString -> "tostring" | A3ToXml -> "toxml" | A3ToXmlAttr -> "toxmlattr" | A3ToInt -> "toint" | A3ToUInt -> "touint" | A3ToNumber -> "tonumber" | A3ToBool -> "tobool" | A3ToObject -> "toobject" | A3CheckIsXml -> "checkisxml" | A3Cast f -> s "cast %s" (field f) | A3AsAny -> "asany" | A3AsString -> "asstring" | A3AsType f -> s "astype %s" (field f) | A3AsObject -> "asobject" | A3IncrReg r -> s "incrreg %d" r | A3DecrReg r -> s "decrreg %d" r | A3Typeof -> "typeof" | A3InstanceOf -> "instanceof" | A3IsType f -> s "istype %s" (field f) | A3IncrIReg r -> s "incrireg %d" r | A3DecrIReg r -> s "decrireg %d" r | A3This -> "this" | A3SetThis -> "setthis" | A3DebugReg (name,reg,line) -> s ".reg %d:%s line:%d" reg (ident name) line | A3DebugLine l -> s ".line %d" l | A3DebugFile f -> s ".file %s" (ident f) | A3BreakPointLine l -> s ".bkptline %d" l | A3Timestamp -> ".time" | A3Op o -> dump_op o | A3Unk x -> s "??? 0x%X" (int_of_char x) haxe-3.0~svn6707/libs/swflib/Makefile0000644000175000017500000000175612172015137020073 0ustar bdefreesebdefreese# Makefile generated by OCamake # http://tech.motion-twin.com .SUFFIXES : .ml .mli .cmo .cmi .cmx .mll .mly CFLAGS= -I ../extlib -I ../extc -g LIBS= LFLAGS= -o swflib.cmxa -a MODULES=as3code.cmx png.cmx swf.cmx actionScript.cmx as3parse.cmx swfPic.cmx as3hlparse.cmx swfParser.cmx all: swflib.cmxa swflib.cmxa: $(MODULES) ocamlopt $(LFLAGS) $(LIBS) $(MODULES) actionScript.cmx: swf.cmx as3code.cmx: as3.cmi as3hl.cmi: as3.cmi as3hlparse.cmx: as3parse.cmx as3hl.cmi as3code.cmx as3.cmi as3parse.cmx: as3code.cmx as3.cmi png.cmx: png.cmi swf.cmx: as3.cmi swfParser.cmx: swf.cmx as3parse.cmx actionScript.cmx swfPic.cmx: swf.cmx png.cmi clean: rm -f swflib.cmxa swflib.lib swflib.a as3.cmi as3hl.cmi rm -f $(MODULES) $(MODULES:.cmx=.obj) $(MODULES:.cmx=.cmi) $(MODULES:.cmx=.o) # SUFFIXES .ml.cmo: ocamlc $(CFLAGS) -c $< .ml.cmx: ocamlopt $(CFLAGS) -c $< .mli.cmi: ocamlc $(CFLAGS) $< .mll.ml: ocamllex $< .mly.ml: ocamlyacc $< haxe-3.0~svn6707/libs/swflib/swfParser.ml0000644000175000017500000016225712172015137020745 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2004 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Swf open ActionScript open IO (* ************************************************************************ *) (* TOOLS *) let full_parsing = ref true let force_as3_parsing = ref false let swf_version = ref 0 let id_count = ref 0 let tag_end = { tid = 0; textended = false; tdata = TEnd } let sum f l = List.fold_left (fun acc x -> acc + f x) 0 l let gen_id() = incr id_count; !id_count let const n = fun _ -> n let opt_len f = function | None -> 0 | Some x -> f x let opt_flag flags fid f fparam = if (flags land fid) = 0 then None else Some (f fparam) let opt f = function | None -> () | Some x -> f x let flag = function | None -> false | Some _ -> true let rec make_flags = function | [] -> 0 | true :: l -> 1 lor ((make_flags l) lsl 1) | false :: l -> (make_flags l) lsl 1 let f16_value (a,b) = let k = int_of_char a lor (int_of_char b lsl 8) in float_of_int k /. float_of_int (1 lsl 8) let rec read_count n f arg = if n = 0 then [] else let v = f arg in v :: read_count (n - 1) f arg (* ************************************************************************ *) (* LENGTH *) let _nbits x = if x < 0 then error "Negative nbits"; if x = 0 then 0 else let x = ref x in let nbits = ref 0 in while !x > 0 do x := !x lsr 1; incr nbits; done; !nbits let rect_nbits r = r.rect_nbits let bigrect_nbits r = r.brect_nbits let rgba_nbits c = max (max (_nbits c.r) (_nbits c.g)) (max (_nbits c.b) (_nbits c.a)) let cxa_nbits c = c.cxa_nbits let matrix_part_nbits m = m.m_nbits let rgb_length = 3 let rgba_length = 4 let string_length s = String.length s + 1 let color_length = function | ColorRGB _ -> rgb_length | ColorRGBA _ -> rgba_length let rect_length r = let nbits = rect_nbits r in let nbits = nbits * 4 + 5 in (nbits + 7) / 8 let big_rect_length r = let nbits = bigrect_nbits r in let nbits = nbits * 4 + 5 in (nbits + 7) / 8 let gradient_length = function | GradientRGB (l,_) -> 1 + (1 + rgb_length) * List.length l | GradientRGBA (l,_) -> 1 + (1 + rgba_length) * List.length l let matrix_length m = let matrix_part_len m = 5 + matrix_part_nbits m * 2 in let nbits = 2 + opt_len matrix_part_len m.scale + opt_len matrix_part_len m.rotate + matrix_part_len m.trans in (nbits + 7) / 8 let cxa_length c = let nbits = cxa_nbits c in let nbits = 6 + opt_len (const (nbits * 4)) c.cxa_add + opt_len (const (nbits * 4)) c.cxa_mult in (nbits + 7) / 8 let clip_event_length c = (if !swf_version >= 6 then 4 else 2) + 4 + (opt_len (const 1) c.cle_key) + actions_length c.cle_actions let clip_events_length l = (if !swf_version >= 6 then 10 else 6) + sum clip_event_length l let export_length e = 2 + string_length e.exp_name let import_length i = 2 + string_length i.imp_name let sound_length s = 2 + 1 + 4 + String.length s.so_data let shape_fill_style_length s = 1 + match s with | SFSSolid _ -> rgb_length | SFSSolid3 _ -> rgba_length | SFSLinearGradient (m,g) | SFSRadialGradient (m,g,None) -> matrix_length m + gradient_length g | SFSRadialGradient (m,g,Some _) -> matrix_length m + gradient_length g + 2 | SFSBitmap b -> 2 + matrix_length b.sfb_mpos let shape_line_style_length s = 2 + match s.sls_flags with | None -> color_length s.sls_color | Some _ -> 2 + (match s.sls_fill with None -> color_length s.sls_color | Some f -> shape_fill_style_length f) + opt_len (const 2) s.sls_miter let shape_array_length f s = let n = List.length s in (if n < 0xFF then 1 else 3) + sum f s let shape_new_styles_length s = shape_array_length shape_fill_style_length s.sns_fill_styles + shape_array_length shape_line_style_length s.sns_line_styles + 1 let font_shape_records_length records = let nbits = ref 8 in let nfbits = ref records.srs_nfbits in let nlbits = ref records.srs_nlbits in List.iter (fun r -> nbits := !nbits + 6; match r with | SRStyleChange s -> nbits := !nbits + opt_len (fun (n,_,_) -> 5 + n * 2) s.scsr_move + opt_len (const !nfbits) s.scsr_fs0 + opt_len (const !nfbits) s.scsr_fs1 + opt_len (const !nlbits) s.scsr_ls; | SRCurvedEdge s -> nbits := !nbits + s.scer_nbits * 4 | SRStraightEdge s -> nbits := !nbits + 1 + (match s.sser_line with | None , None -> assert false | Some _ , None | None, Some _ -> 1 + s.sser_nbits | Some _ , Some _ -> 2 * s.sser_nbits) ) records.srs_records; (* nbits := !nbits + 6; *) (!nbits + 7) / 8 let shape_records_length records = let nbits = ref 8 in let nfbits = ref records.srs_nfbits in let nlbits = ref records.srs_nlbits in List.iter (fun r -> nbits := !nbits + 6; match r with | SRStyleChange s -> nbits := !nbits + opt_len (fun (n,_,_) -> 5 + n * 2) s.scsr_move + opt_len (const !nfbits) s.scsr_fs0 + opt_len (const !nfbits) s.scsr_fs1 + opt_len (const !nlbits) s.scsr_ls; (match s.scsr_new_styles with | None -> () | Some s -> nbits := (((!nbits + 7) / 8) + shape_new_styles_length s) * 8; nfbits := s.sns_nfbits; nlbits := s.sns_nlbits) | SRCurvedEdge s -> nbits := !nbits + s.scer_nbits * 4 | SRStraightEdge s -> nbits := !nbits + 1 + (match s.sser_line with | None , None -> assert false | Some _ , None | None, Some _ -> 1 + s.sser_nbits | Some _ , Some _ -> 2 * s.sser_nbits) ) records.srs_records; nbits := !nbits + 6; (!nbits + 7) / 8 let shape_with_style_length s = shape_array_length shape_fill_style_length s.sws_fill_styles + shape_array_length shape_line_style_length s.sws_line_styles + shape_records_length s.sws_records let shape_length s = 2 + rect_length s.sh_bounds + opt_len (fun (r,_) -> rect_length r + 1) s.sh_bounds2 + shape_with_style_length s.sh_style let bitmap_lossless_length b = 2 + 1 + 2 + 2 + String.length b.bll_data let morph_shape_length s = 2 + rect_length s.msh_start_bounds + rect_length s.msh_end_bounds + String.length s.msh_data let text_record_length t r = 1 + opt_len (const 4) r.txr_font + opt_len color_length r.txr_color + opt_len (const 2) r.txr_dx + opt_len (const 2) r.txr_dy + 1 + ((((t.txt_ngbits + t.txt_nabits) * List.length r.txr_glyphs) + 7) / 8) let text_length t = 2 + big_rect_length t.txt_bounds + matrix_length t.txt_matrix + 2 + sum (text_record_length t) t.txt_records + 1 let filters_length l = 1 + sum (fun f -> 1 + match f with | FDropShadow s | FBlur s | FGlow s | FBevel s | FAdjustColor s -> String.length s | FGradientGlow fg | FGradientBevel fg -> 1 + ((rgba_length + 1) * List.length fg.fgr_colors) + String.length fg.fgr_data ) l let button_record_length r = 1 + 2 + 2 + matrix_length r.btr_mpos + (match r.btr_color with None -> 0 | Some c -> cxa_length c) + opt_len filters_length r.btr_filters + (match r.btr_blendmode with None -> 0 | Some c -> 1) let button_action_length r = 2 + 2 + actions_length r.bta_actions let button2_length b = 2 + 1 + 2 + 1 + sum button_record_length b.bt2_records + sum button_action_length b.bt2_actions let cid_data_length c = 2 + String.length c.cd_data let edit_text_layout_length = 9 let header_length h = 3 + 1 + rect_length h.h_size + 2 + 4 let edit_text_length t = 2 + rect_length t.edt_bounds + 2 + opt_len (const 4) t.edt_font + opt_len (const rgba_length) t.edt_color + opt_len (const 2) t.edt_maxlen + opt_len (const edit_text_layout_length) t.edt_layout + string_length t.edt_variable + opt_len string_length t.edt_text let place_object_length p v3 = 3 + (if v3 then 1 else 0) + 0 (* po_move *) + opt_len (const 2) p.po_cid + opt_len matrix_length p.po_matrix + opt_len cxa_length p.po_color + opt_len (const 2) p.po_ratio + opt_len string_length p.po_inst_name + opt_len (const 2) p.po_clip_depth + opt_len clip_events_length p.po_events + (if v3 then opt_len filters_length p.po_filters + opt_len (const 1) p.po_blend + opt_len (const 1) p.po_bcache else 0) let rec tag_data_length = function | TEnd -> 0 | TShowFrame -> 0 | TShape s -> shape_length s | TRemoveObject _ -> 4 | TBitsJPEG b -> 2 + String.length b.jpg_data | TJPEGTables tab -> String.length tab | TSetBgColor _ -> rgb_length | TFont c -> cid_data_length c | TText t -> text_length t | TDoAction acts -> actions_length acts | TFontInfo c -> cid_data_length c | TSound s -> sound_length s | TStartSound s -> 2 + String.length s.sts_data | TBitsLossless b -> bitmap_lossless_length b | TBitsJPEG2 b -> 2 + opt_len String.length b.bd_table + String.length b.bd_data | TShape2 s -> shape_length s | TProtect -> 0 | TPlaceObject2 p -> place_object_length p false | TRemoveObject2 _ -> 2 | TShape3 s -> shape_length s | TText2 t -> text_length t | TButton2 b -> button2_length b | TBitsJPEG3 b -> 2 + 4 + opt_len String.length b.bd_table + String.length b.bd_data + opt_len String.length b.bd_alpha | TBitsLossless2 b -> bitmap_lossless_length b | TEditText t -> edit_text_length t | TClip c -> 4 + sum tag_length (tag_end :: c.c_tags) | TProductInfo s -> String.length s | TFrameLabel (label,id) -> string_length label + (match id with None -> 0 | Some _ -> 1) | TSoundStreamHead2 data -> String.length data | TMorphShape s | TMorphShape2 s -> morph_shape_length s | TFont2 c | TFont3 c | TFontAlignZones c -> cid_data_length c | TExport el -> 2 + sum export_length el | TImport (url,il) -> string_length url + 2 + sum import_length il | TDoInitAction i -> 2 + actions_length i.dia_actions | TVideoStream c -> cid_data_length c | TVideoFrame c -> cid_data_length c | TFontInfo2 c -> cid_data_length c | TDebugID s -> String.length s | TEnableDebugger2 (_,pass) -> 2 + string_length pass | TScriptLimits _ -> 4 | TFilesAttributes _ -> 4 | TPlaceObject3 p -> place_object_length p true | TImport2 (url,il) -> string_length url + 1 + 1 + 2 + sum import_length il | TCSMSettings c -> cid_data_length c | TF9Classes l -> 2 + sum (fun c -> string_length c.f9_classname + 2) l | TMetaData meta -> string_length meta | TScale9 (_,r) -> 2 + rect_length r | TActionScript3 (id,a) -> (match id with None -> 0 | Some (id,f) -> 4 + string_length f) + As3parse.as3_length a | TShape4 s -> shape_length s | TScenes (sl,fl) -> As3parse.int_length (List.length sl) + sum (fun(n,s) -> As3parse.int_length n + string_length s) sl + As3parse.int_length (List.length fl) + sum (fun(n,s) -> As3parse.int_length n + string_length s) fl | TBinaryData (_,data) -> 2 + 4 + String.length data | TBigBinaryData (_,data) -> 2 + 4 + (List.fold_left (fun acc s -> acc + String.length s) 0 data) | TFontName c -> cid_data_length c | TBitsJPEG4 b -> 2 + 2 + 4 + opt_len String.length b.bd_table + String.length b.bd_data + opt_len String.length b.bd_alpha | TFont4 c -> cid_data_length c | TUnknown (_,data) -> String.length data and tag_length t = let dlen = tag_data_length t.tdata in dlen + 2 + (if t.textended || dlen >= 63 then 4 else 0) (* ************************************************************************ *) (* READ PRIMS *) let skip ch n = seek_in ch ((Pervasives.pos_in ch) + n) let read_rgba ch = let r = read_byte ch in let g = read_byte ch in let b = read_byte ch in let a = read_byte ch in { r = r; g = g; b = b; a = a; } let read_rgb ch = let r = read_byte ch in let g = read_byte ch in let b = read_byte ch in { cr = r; cg = g; cb = b; } let read_gradient ch is_rgba = let grad_rgb() = let r = read_byte ch in let c = read_rgb ch in (r, c) in let grad_rgba() = let r = read_byte ch in let c = read_rgba ch in (r, c) in let n = read_byte ch in let n , flags = n land 0xF , n lsr 4 in if is_rgba then GradientRGBA (read_count n grad_rgba (),flags) else GradientRGB (read_count n grad_rgb (),flags) let read_rect ch = let b = input_bits ch in let nbits = read_bits b 5 in let left = read_bits b nbits in let right = read_bits b nbits in let top = read_bits b nbits in let bottom = read_bits b nbits in { rect_nbits = nbits; left = left; right = right; top = top; bottom = bottom; } let rec read_multi_bits b n = if n <= 30 then [read_bits b n] else let d = read_bits b 30 in d :: read_multi_bits b (n - 30) let read_big_rect ch = let b = input_bits ch in let nbits = read_bits b 5 in let left = read_multi_bits b nbits in let right = read_multi_bits b nbits in let top = read_multi_bits b nbits in let bottom = read_multi_bits b nbits in { brect_nbits = nbits; bleft = left; bright = right; btop = top; bbottom = bottom; } let read_matrix ch = let b = input_bits ch in let read_matrix_part() = let nbits = read_bits b 5 in let x = read_bits b nbits in let y = read_bits b nbits in { m_nbits = nbits; mx = x; my = y; } in let has_scale = (read_bits b 1 = 1) in let scale = (if has_scale then Some (read_matrix_part()) else None) in let has_rotate = (read_bits b 1 = 1) in let rotate = (if has_rotate then Some (read_matrix_part()) else None) in let trans = read_matrix_part() in { scale = scale; rotate = rotate; trans = trans; } let read_cxa ch = let b = input_bits ch in let has_add = (read_bits b 1 = 1) in let has_mult = (read_bits b 1 = 1) in let nbits = read_bits b 4 in let read_cxa_color() = let r = read_bits b nbits in let g = read_bits b nbits in let bl = read_bits b nbits in let a = read_bits b nbits in { r = r; g = g; b = bl; a = a; } in let mult = (if has_mult then Some (read_cxa_color()) else None) in let add = (if has_add then Some (read_cxa_color()) else None) in { cxa_nbits = nbits; cxa_add = add; cxa_mult = mult; } let read_event ch = (if !swf_version >= 6 then read_i32 else read_ui16) ch (* ************************************************************************ *) (* WRITE PRIMS *) let write_rgb ch c = write_byte ch c.cr; write_byte ch c.cg; write_byte ch c.cb let write_rgba ch c = write_byte ch c.r; write_byte ch c.g; write_byte ch c.b; write_byte ch c.a let write_color ch = function | ColorRGB c -> write_rgb ch c | ColorRGBA c -> write_rgba ch c let write_gradient ch = function | GradientRGB (l,flags) -> let n = List.length l in write_byte ch (n lor (flags lsl 4)); List.iter (fun (ratio,c) -> write_byte ch ratio; write_rgb ch c) l | GradientRGBA (l,flags) -> let n = List.length l in write_byte ch (n lor (flags lsl 4)); List.iter (fun (ratio,c) -> write_byte ch ratio; write_rgba ch c) l let write_rect ch r = let b = output_bits ch in let nbits = rect_nbits r in write_bits b 5 nbits; write_bits b nbits r.left; write_bits b nbits r.right; write_bits b nbits r.top; write_bits b nbits r.bottom; flush_bits b let rec write_multi_bits b n l = if n <= 30 then match l with | [] -> write_bits b n 0 | [x] -> write_bits b n x | _ -> assert false else match l with | [] -> write_bits b 30 0; write_multi_bits b (n - 30) [] | x :: l -> write_bits b 30 x; write_multi_bits b (n - 30) l let write_big_rect ch r = let b = output_bits ch in let nbits = bigrect_nbits r in write_bits b 5 nbits; write_multi_bits b nbits r.bleft; write_multi_bits b nbits r.bright; write_multi_bits b nbits r.btop; write_multi_bits b nbits r.bbottom; flush_bits b let write_matrix ch m = let b = output_bits ch in let write_matrix_part m = let nbits = matrix_part_nbits m in write_bits b 5 nbits; write_bits b nbits m.mx; write_bits b nbits m.my; in (match m.scale with | None -> write_bits b 1 0 | Some s -> write_bits b 1 1; write_matrix_part s ); (match m.rotate with | None -> write_bits b 1 0 | Some r -> write_bits b 1 1; write_matrix_part r); write_matrix_part m.trans; flush_bits b let write_cxa ch c = let b = output_bits ch in let nbits = cxa_nbits c in (match c.cxa_add , c.cxa_mult with | None , None -> write_bits b 2 0; write_bits b 4 1; (* some strange MM thing... *) | Some c , None -> write_bits b 2 2; write_bits b 4 nbits; List.iter (write_bits b ~nbits) [c.r;c.g;c.b;c.a]; | None , Some c -> write_bits b 2 1; write_bits b 4 nbits; List.iter (write_bits b ~nbits) [c.r;c.g;c.b;c.a]; | Some c1 , Some c2 -> write_bits b 2 3; write_bits b 4 nbits; List.iter (write_bits b ~nbits) [c2.r;c2.g;c2.b;c2.a;c1.r;c1.g;c1.b;c1.a] ); flush_bits b let write_event ch evt = (if !swf_version >= 6 then write_i32 else write_ui16) ch evt (* ************************************************************************ *) (* PARSING *) let parse_clip_events ch = ignore(read_ui16 ch); (* reserved *) ignore(read_event ch); (* all_events *) let rec loop() = let events = read_event ch in if events = 0 then [] else begin ignore(read_i32 ch); (* len *) let key = (if events land (1 lsl 17) <> 0 then Some (read ch) else None) in let e = { cle_events = events; cle_key = key; cle_actions = parse_actions ch } in e :: (loop()) end; in loop() let parse_shape_fill_style ch vshape = let t = read_byte ch in match t with | 0x00 when vshape >= 3 -> SFSSolid3 (read_rgba ch) | 0x00 -> SFSSolid (read_rgb ch) | 0x10 -> let m = read_matrix ch in let g = read_gradient ch (vshape >= 3) in SFSLinearGradient (m,g) | 0x12 -> let m = read_matrix ch in let g = read_gradient ch (vshape >= 3) in SFSRadialGradient (m,g,None) | 0x13 -> let m = read_matrix ch in let g = read_gradient ch (vshape >= 3) in let i = read_i16 ch in SFSRadialGradient (m,g,Some i) | 0x40 | 0x41 | 0x42 | 0x43 -> let id = read_ui16 ch in let m = read_matrix ch in SFSBitmap { sfb_repeat = (t = 0x40 || t = 0x42); sfb_smooth = (t = 0x42 || t = 0x43); sfb_cid = id; sfb_mpos = m; } | _ -> assert false let parse_shape_line_style ch vshape = let width = read_ui16 ch in if vshape >= 4 then begin let flags = read_ui16 ch in let fill = (flags land 8 <> 0) in let miterjoin = (flags land 0x20 <> 0) in let miter = (if miterjoin then Some (IO.read_ui16 ch) else None) in let color = (if fill then { r = 0; g = 0; b = 0; a = 0 } else read_rgba ch) in (* let noVscale = (flags land 0x02 <> 0) in let noHscale = (flags land 0x04 <> 0) in let beveljoin = (flags land 0x10 <> 0) in let nocap = (flags land 0x40 <> 0) in let squarecap = (flags land 0x80 <> 0) in *) { sls_width = width; sls_color = ColorRGBA color; sls_fill = if fill then Some (parse_shape_fill_style ch vshape) else None; sls_flags = Some flags; sls_miter = miter; } end else { sls_width = width; sls_color = if vshape = 3 then ColorRGBA (read_rgba ch) else ColorRGB (read_rgb ch); sls_fill = None; sls_flags = None; sls_miter = None; } let parse_shape_array f ch vshape = let n = (match read_byte ch with 0xFF -> read_ui16 ch | n -> n) in read_count n (f ch) vshape let parse_shape_style_change_record ch b flags nlbits nfbits vshape = let move = (if flags land 1 <> 0 then begin let mbits = read_bits b 5 in let dx = read_bits b mbits in let dy = read_bits b mbits in Some (mbits,dx,dy) end else None) in let fs0 = (if flags land 2 <> 0 then Some (read_bits b !nfbits) else None) in let fs1 = (if flags land 4 <> 0 then Some (read_bits b !nfbits) else None) in let ls = (if flags land 8 <> 0 then Some (read_bits b !nlbits) else None) in let styles = (if flags land 16 <> 0 then begin IO.drop_bits b; let fstyles = parse_shape_array parse_shape_fill_style ch vshape in let lstyles = parse_shape_array parse_shape_line_style ch vshape in let bits = read_byte ch in nlbits := bits land 15; nfbits := bits lsr 4; Some { sns_fill_styles = fstyles; sns_line_styles = lstyles; sns_nlbits = !nlbits; sns_nfbits = !nfbits; } end else None ) in { scsr_move = move; scsr_fs0 = fs0; scsr_fs1 = fs1; scsr_ls = ls; scsr_new_styles = styles; } let parse_shape_curved_edge_record b flags = let nbits = (flags land 15) + 2 in let cx = read_bits b nbits in let cy = read_bits b nbits in let ax = read_bits b nbits in let ay = read_bits b nbits in { scer_nbits = nbits; scer_cx = cx; scer_cy = cy; scer_ax = ax; scer_ay = ay; } let parse_shape_straight_edge_record b flags = let nbits = (flags land 15) + 2 in let is_general = (read_bits b 1 = 1) in let l = (if is_general then let dx = read_bits b nbits in let dy = read_bits b nbits in Some dx, Some dy else let is_vertical = (read_bits b 1 = 1) in let p = read_bits b nbits in if is_vertical then None, Some p else Some p, None) in { sser_nbits = nbits; sser_line = l; } let parse_shape_records ch nlbits nfbits vshape = let b = input_bits ch in let nlbits = ref nlbits in let nfbits = ref nfbits in let rec loop() = let flags = read_bits b 6 in if flags = 0 then [] else let r = (if (flags land 32) = 0 then SRStyleChange (parse_shape_style_change_record ch b flags nlbits nfbits vshape) else if (flags land 48) = 32 then SRCurvedEdge (parse_shape_curved_edge_record b flags) else SRStraightEdge (parse_shape_straight_edge_record b flags)) in r :: loop() in loop() let parse_shape_with_style ch vshape = let fstyles = parse_shape_array parse_shape_fill_style ch vshape in let lstyles = parse_shape_array parse_shape_line_style ch vshape in let bits = read_byte ch in let nlbits = bits land 15 in let nfbits = bits lsr 4 in let records = parse_shape_records ch nlbits nfbits vshape in { sws_fill_styles = fstyles; sws_line_styles = lstyles; sws_records = { srs_nlbits = nlbits; srs_nfbits = nfbits; srs_records = records; } } let parse_shape ch len vshape = let id = read_ui16 ch in let bounds = read_rect ch in let bounds2 = (if vshape = 4 then let r = read_rect ch in let b = read_byte ch in Some (r, b) else None ) in let style = parse_shape_with_style ch vshape in { sh_id = id; sh_bounds = bounds; sh_bounds2 = bounds2; sh_style = style; } let extract_jpg_table data = match data.[0], data.[1] with | '\xFF', '\xD8' -> let ch = IO.input_string data in let b = Buffer.create 0 in let rec loop flag = let c = IO.read ch in Buffer.add_char b c; match int_of_char c with | 0xFF -> loop true | 0xD9 when flag -> () | _ -> loop false in loop false; let t = Buffer.contents b in let l = String.length t in String.sub data l (String.length data - l), Some t | _ -> data, None let parse_bitmap_lossless ch len = let id = read_ui16 ch in let format = read_byte ch in let width = read_ui16 ch in let height = read_ui16 ch in let data = nread ch (len - 7) in { bll_id = id; bll_format = format; bll_width = width; bll_height = height; bll_data = data; } let parse_text ch is_txt2 = let id = read_ui16 ch in let bounds = read_big_rect ch in let matrix = read_matrix ch in let ngbits = read_byte ch in let nabits = read_byte ch in let read_glyph bits = let indx = read_bits bits ngbits in let adv = read_bits bits nabits in { txg_index = indx; txg_advanced = adv; } in let rec loop() = let flags = read_byte ch in if flags = 0 then [] else let font_id = (if flags land 8 <> 0 then read_ui16 ch else 0) in let color = (if flags land 4 <> 0 then Some (if is_txt2 then ColorRGBA (read_rgba ch) else ColorRGB (read_rgb ch)) else None) in let dx = (if flags land 1 <> 0 then Some (read_i16 ch) else None) in let dy = (if flags land 2 <> 0 then Some (read_i16 ch) else None) in let font = (if flags land 8 <> 0 then Some (font_id,read_ui16 ch) else None) in let nglyphs = read_byte ch in let r = { txr_font = font; txr_color = color; txr_dx = dx; txr_dy = dy; txr_glyphs = read_count nglyphs read_glyph (input_bits ch); } in r :: loop() in { txt_id = id; txt_bounds = bounds; txt_matrix = matrix; txt_ngbits = ngbits; txt_nabits = nabits; txt_records = loop(); } let parse_edit_text_layout ch = let align = read_byte ch in let ml = read_ui16 ch in let rl = read_ui16 ch in let ident = read_ui16 ch in let lead = read_ui16 ch in { edtl_align = align; edtl_left_margin = ml; edtl_right_margin = rl; edtl_indent = ident; edtl_leading = lead; } let parse_edit_text ch = let id = read_ui16 ch in let bounds = read_rect ch in let flags = read_ui16 ch in let font = (if flags land 1 <> 0 then let fid = read_ui16 ch in let height = read_ui16 ch in Some (fid, height) else None) in let color = (if flags land 4 <> 0 then Some (read_rgba ch) else None) in let maxlen = (if flags land 2 <> 0 then Some (read_ui16 ch) else None) in let layout = (if flags land (1 lsl 13) <> 0 then Some (parse_edit_text_layout ch) else None) in let variable = read_string ch in let text = (if flags land 128 <> 0 then Some (read_string ch) else None) in { edt_id = id; edt_bounds = bounds; edt_font = font; edt_color = color; edt_maxlen = maxlen; edt_layout = layout; edt_variable = variable; edt_text = text; edt_wordwrap = (flags land 64) <> 0; edt_multiline = (flags land 32) <> 0; edt_password = (flags land 16) <> 0; edt_readonly = (flags land 8) <> 0; edt_autosize = (flags land (1 lsl 14)) <> 0; edt_noselect = (flags land 4096) <> 0; edt_border = (flags land 2048) <> 0; edt_html = (flags land 512) <> 0; edt_outlines = (flags land 256) <> 0; } let parse_cid_data ch len = let id = read_ui16 ch in let data = nread ch (len - 2) in { cd_id = id; cd_data = data; } let parse_morph_shape ch len = let id = read_ui16 ch in let sbounds = read_rect ch in let ebounds = read_rect ch in let data = nread ch (len - 2 - rect_length sbounds - rect_length ebounds) in { msh_id = id; msh_start_bounds = sbounds; msh_end_bounds = ebounds; msh_data = data; } let parse_filter_gradient ch = let ncolors = read_byte ch in let colors = read_count ncolors read_rgba ch in let cvals = read_count ncolors read_byte ch in let data = nread ch 19 in { fgr_colors = List.combine colors cvals; fgr_data = data; } let parse_filter ch = match read_byte ch with | 0 -> FDropShadow (nread ch 23) | 1 -> FBlur (nread ch 9) | 2 -> FGlow (nread ch 15) | 3 -> FBevel (nread ch 27) | 4 -> FGradientGlow (parse_filter_gradient ch) | 6 -> FAdjustColor (nread ch 80) | 7 -> FGradientBevel (parse_filter_gradient ch) | _ -> assert false let parse_filters ch = let nf = read_byte ch in read_count nf parse_filter ch let rec parse_button_records ch color = let flags = read_byte ch in if flags = 0 then [] else let cid = read_ui16 ch in let depth = read_ui16 ch in let mpos = read_matrix ch in let cxa = (if color then Some (read_cxa ch) else None) in let filters = (if flags land 16 = 0 then None else Some (parse_filters ch)) in let blendmode = (if flags land 32 = 0 then None else Some (read_byte ch)) in let r = { btr_flags = flags; btr_cid = cid; btr_depth = depth; btr_mpos = mpos; btr_color = cxa; btr_filters = filters; btr_blendmode = blendmode; } in r :: parse_button_records ch color let rec parse_button_actions ch = let size = read_ui16 ch in let flags = read_ui16 ch in let actions = parse_actions ch in let bta = { bta_flags = flags; bta_actions = actions; } in if size = 0 then [bta] else bta :: parse_button_actions ch let parse_button2 ch len = let id = read_ui16 ch in let flags = read_byte ch in let track = (match flags with 0 -> false | 1 -> true | _ -> assert false) in let offset = read_ui16 ch in let records = parse_button_records ch true in let actions = (if offset = 0 then [] else parse_button_actions ch) in { bt2_id = id; bt2_track_as_menu = track; bt2_records = records; bt2_actions = actions; } let parse_place_object ch v3 = let f = read_byte ch in let fext = (if v3 then read_byte ch else 0) in let depth = read_ui16 ch in let move = (f land 1) <> 0 in let cid = opt_flag f 2 read_ui16 ch in let matrix = opt_flag f 4 read_matrix ch in let color = opt_flag f 8 read_cxa ch in let ratio = opt_flag f 16 read_ui16 ch in let name = opt_flag f 32 read_string ch in let clip_depth = opt_flag f 64 read_ui16 ch in let clip_events = opt_flag f 128 parse_clip_events ch in let filters = opt_flag fext 1 parse_filters ch in let blend = opt_flag fext 2 read_byte ch in let bcache = opt_flag fext 4 read_byte ch in { po_depth = depth; po_move = move; po_cid = cid; po_matrix = matrix; po_color = color; po_ratio = ratio; po_inst_name = name; po_clip_depth = clip_depth; po_events = clip_events; po_filters = filters; po_blend = blend; po_bcache = bcache; } let parse_import ch = let cid = read_ui16 ch in let name = read_string ch in { imp_id = cid; imp_name = name } let rec parse_tag ch h = let id = h lsr 6 in let len = h land 63 in let len , extended = ( if len = 63 then let len = read_i32 ch in len , len < 63 else len , false ) in let t = ( match id with | 0x00 -> TEnd | 0x01 -> TShowFrame | 0x02 when !full_parsing -> TShape (parse_shape ch len 1) (* 0x03 invalid *) (*//0x04 TPlaceObject *) | 0x05 -> let cid = read_ui16 ch in let depth = read_ui16 ch in TRemoveObject { rmo_id = cid; rmo_depth = depth; } | 0x06 -> let id = read_ui16 ch in let data = nread ch (len - 2) in TBitsJPEG { jpg_id = id; jpg_data = data; } (*//0x07 TButton *) | 0x08 -> TJPEGTables (nread ch len) | 0x09 -> TSetBgColor (read_rgb ch) | 0x0A -> TFont (parse_cid_data ch len) | 0x0B when !full_parsing -> TText (parse_text ch false) | 0x0C -> TDoAction (parse_actions ch) | 0x0D -> TFontInfo (parse_cid_data ch len) | 0x0E -> let sid = read_ui16 ch in let flags = read_byte ch in let samples = read_i32 ch in let data = nread ch (len - 7) in TSound { so_id = sid; so_flags = flags; so_samples = samples; so_data = data; } | 0x0F -> let sid = read_ui16 ch in let data = nread ch (len - 2) in TStartSound { sts_id = sid; sts_data = data; } (* 0x10 invalid *) (*//0x11 TButtonSound *) (*//0x12 TSoundStreamHead *) (*//0x13 TSoundStreamBlock *) | 0x14 -> TBitsLossless (parse_bitmap_lossless ch len) | 0x15 -> let id = read_ui16 ch in let data = nread ch (len - 2) in let data, table = extract_jpg_table data in TBitsJPEG2 { bd_id = id; bd_table = table; bd_data = data; bd_alpha = None; bd_deblock = None; } | 0x16 when !full_parsing -> TShape2 (parse_shape ch len 2) (*//0x17 TButtonCXForm *) | 0x18 -> TProtect (* 0x19 invalid *) | 0x1A when !full_parsing -> TPlaceObject2 (parse_place_object ch false) (* 0x1B invalid *) | 0x1C -> let depth = read_ui16 ch in TRemoveObject2 depth (* 0x1D-1F invalid *) | 0x20 when !full_parsing -> TShape3 (parse_shape ch len 3) | 0x21 when !full_parsing -> TText2 (parse_text ch true) | 0x22 when !full_parsing -> TButton2 (parse_button2 ch len) | 0x23 -> let id = read_ui16 ch in let size = read_i32 ch in let data = nread ch size in let data, table = extract_jpg_table data in let alpha = nread ch (len - 6 - size) in TBitsJPEG3 { bd_id = id; bd_table = table; bd_data = data; bd_alpha = Some alpha; bd_deblock = None; } | 0x24 -> TBitsLossless2 (parse_bitmap_lossless ch len) | 0x25 when !full_parsing -> TEditText (parse_edit_text ch) (* 0x26 invalid *) | 0x27 -> let cid = read_ui16 ch in let fcount = read_ui16 ch in let tags = parse_tag_list ch in TClip { c_id = cid; c_frame_count = fcount; c_tags = tags; } (* 0x28 invalid *) | 0x29 -> (* undocumented ? *) TProductInfo (nread ch len) (* 0x2A invalid *) | 0x2B -> let label = read_string ch in let id = (if len = String.length label + 2 then Some (read ch) else None) in TFrameLabel (label,id) (* 0x2C invalid *) | 0x2D -> TSoundStreamHead2 (nread ch len) | 0x2E when !full_parsing -> TMorphShape (parse_morph_shape ch len) (* 0x2F invalid *) | 0x30 when !full_parsing -> TFont2 (parse_cid_data ch len) (* 0x31-37 invalid *) | 0x38 -> let read_export() = let cid = read_ui16 ch in let name = read_string ch in { exp_id = cid; exp_name = name } in TExport (read_count (read_ui16 ch) read_export ()) | 0x39 -> let url = read_string ch in TImport (url, read_count (read_ui16 ch) parse_import ch) (*// 0x3A TEnableDebugger *) | 0x3B -> let cid = read_ui16 ch in let actions = parse_actions ch in TDoInitAction { dia_id = cid; dia_actions = actions; } | 0x3C -> TVideoStream (parse_cid_data ch len) | 0x3D -> TVideoFrame (parse_cid_data ch len) | 0x3E -> TFontInfo2 (parse_cid_data ch len) | 0x3F -> (* undocumented ? *) TDebugID (nread ch len) | 0x40 -> let tag = read_ui16 ch in (* 0 in general, 6517 for some swfs *) let pass_md5 = read_string ch in TEnableDebugger2 (tag,pass_md5) | 0x41 -> let recursion_depth = read_ui16 ch in let script_timeout = read_ui16 ch in TScriptLimits (recursion_depth, script_timeout) (*// 0x42 TSetTabIndex *) (* 0x43-0x44 invalid *) | 0x45 -> let flags = IO.read_i32 ch in let mask = 1 lor 8 lor 16 lor 32 lor 64 in if (flags lor mask) <> mask then failwith ("Invalid file attributes " ^ string_of_int flags); TFilesAttributes { fa_network = (flags land 1) <> 0; (* flags 2,4 : reserved *) fa_as3 = (flags land 8) <> 0; fa_metadata = (flags land 16) <> 0; fa_gpu = (flags land 32) <> 0; fa_direct_blt = (flags land 64) <> 0; } | 0x46 when !full_parsing -> TPlaceObject3 (parse_place_object ch true) | 0x47 -> let url = read_string ch in if IO.read_byte ch <> 1 then assert false; if IO.read_byte ch <> 0 then assert false; TImport2 (url, read_count (read_ui16 ch) parse_import ch) | 0x48 when !full_parsing || !force_as3_parsing -> TActionScript3 (None , As3parse.parse ch len) | 0x49 when !full_parsing -> TFontAlignZones (parse_cid_data ch len) | 0x4A -> TCSMSettings (parse_cid_data ch len) | 0x4B when !full_parsing -> TFont3 (parse_cid_data ch len) | 0x4C -> let i = read_ui16 ch in let rec loop i = if i = 0 then [] else let a = read_ui16 ch in let s = read_string ch in { f9_cid = if a = 0 then None else Some a; f9_classname = s; } :: loop (i - 1) in TF9Classes (loop i) | 0x4D -> TMetaData (read_string ch) | 0x4E -> let cid = read_ui16 ch in let rect = read_rect ch in TScale9 (cid,rect) (* 0x4F-0x51 invalid *) | 0x52 when !full_parsing || !force_as3_parsing -> let id = read_i32 ch in let frame = read_string ch in let len = len - (4 + String.length frame + 1) in TActionScript3 (Some (id,frame), As3parse.parse ch len) | 0x53 when !full_parsing -> TShape4 (parse_shape ch len 4) | 0x54 when !full_parsing -> TMorphShape2 (parse_morph_shape ch len) (* 0x55 invalid *) | 0x56 -> let scenes = read_count (As3parse.read_int ch) (fun() -> let offset = As3parse.read_int ch in let name = read_string ch in (offset, name) ) () in let frames = read_count (As3parse.read_int ch) (fun() -> let f = As3parse.read_int ch in let name = read_string ch in (f, name) ) () in TScenes (scenes,frames) | 0x57 -> let cid = read_ui16 ch in if read_i32 ch <> 0 then assert false; let rec loop len = if len > Sys.max_string_length then let s = nread ch Sys.max_string_length in s :: loop (len - Sys.max_string_length) else [nread ch len] in (match loop (len - 6) with | [data] -> TBinaryData (cid,data) | data -> TBigBinaryData (cid,data)) | 0x58 -> TFontName (parse_cid_data ch len) (* // 0x59 TStartSound2 *) | 0x5A -> let id = read_ui16 ch in let size = read_i32 ch in let deblock = read_ui16 ch in let data = nread ch size in let data, table = extract_jpg_table data in let alpha = nread ch (len - 6 - size) in TBitsJPEG4 { bd_id = id; bd_table = table; bd_data = data; bd_alpha = Some alpha; bd_deblock = Some deblock; } | 0x5B -> TFont4 (parse_cid_data ch len) | _ -> (*if !Swf.warnings then Printf.printf "Unknown tag 0x%.2X\n" id;*) TUnknown (id,nread ch len) ) in (* let len2 = tag_data_length t in if len <> len2 then error (Printf.sprintf "Datalen mismatch for tag 0x%.2X (%d != %d)" id len len2); *) { tid = gen_id(); tdata = t; textended = extended; } and parse_tag_list ch = let rec loop acc = let h = (try read_ui16 ch with IO.No_more_input -> 0) in match parse_tag ch h with | { tdata = TEnd } -> List.rev acc | t -> loop (t :: acc) in loop [] let parse ch = let sign = nread ch 3 in if sign <> "FWS" && sign <> "CWS" then error "Invalid SWF signature"; let ver = read_byte ch in swf_version := ver; ignore(read_i32 ch); (* file length *) let compressed, ch = (if sign = "CWS" then true , inflate ch else false, ch) in let size = read_rect ch in let fps = read_ui16 ch in let frame_count = read_ui16 ch in let h = { h_version = ver; h_size = size; h_fps = fps; h_frame_count = frame_count; h_compressed = compressed; } in let data = h , parse_tag_list ch in if compressed then IO.close_in ch; data (* ************************************************************************ *) (* WRITING *) let rec tag_id = function | TEnd -> 0x00 | TShowFrame -> 0x01 | TShape _ -> 0x02 | TRemoveObject _ -> 0x05 | TBitsJPEG _ -> 0x06 | TJPEGTables _ -> 0x08 | TSetBgColor _ -> 0x09 | TFont _ -> 0x0A | TText _ -> 0x0B | TDoAction _ -> 0x0C | TFontInfo _ -> 0x0D | TSound _ -> 0x0E | TStartSound _ -> 0x0F | TBitsLossless _ -> 0x14 | TBitsJPEG2 _ -> 0x15 | TShape2 _ -> 0x16 | TProtect -> 0x18 | TPlaceObject2 _ -> 0x1A | TRemoveObject2 _ -> 0x1C | TShape3 _ -> 0x20 | TText2 _ -> 0x21 | TButton2 _ -> 0x22 | TBitsJPEG3 _ -> 0x23 | TBitsLossless2 _ -> 0x24 | TEditText _ -> 0x25 | TClip _ -> 0x27 | TProductInfo _ -> 0x29 | TFrameLabel _ -> 0x2B | TSoundStreamHead2 _ -> 0x2D | TMorphShape _ -> 0x2E | TFont2 _ -> 0x30 | TExport _ -> 0x38 | TImport _ -> 0x39 | TDoInitAction _ -> 0x3B | TVideoStream _ -> 0x3C | TVideoFrame _ -> 0x3D | TFontInfo2 _ -> 0x3E | TDebugID _ -> 0x3F | TEnableDebugger2 _ -> 0x40 | TScriptLimits _ -> 0x41 | TFilesAttributes _ -> 0x45 | TPlaceObject3 _ -> 0x46 | TImport2 _ -> 0x47 | TFontAlignZones _ -> 0x49 | TCSMSettings _ -> 0x4A | TFont3 _ -> 0x4B | TF9Classes _ -> 0x4C | TMetaData _ -> 0x4D | TScale9 _ -> 0x4E | TActionScript3 (None,_) -> 0x48 | TActionScript3 _ -> 0x52 | TShape4 _ -> 0x53 | TMorphShape2 _ -> 0x54 | TScenes _ -> 0x56 | TBinaryData _ | TBigBinaryData _ -> 0x57 | TFontName _ -> 0x58 | TBitsJPEG4 _ -> 0x5A | TFont4 _ -> 0x5B | TUnknown (id,_) -> id let write_clip_event ch c = write_event ch c.cle_events; write_i32 ch (actions_length c.cle_actions + opt_len (const 1) c.cle_key); opt (write ch) c.cle_key; write_actions ch c.cle_actions let write_clip_events ch event_list = write_ui16 ch 0; let all_events = List.fold_left (fun acc c -> acc lor c.cle_events) 0 event_list in write_event ch all_events; List.iter (write_clip_event ch) event_list; write_event ch 0 let write_shape_fill_style ch s = match s with | SFSSolid c -> write_byte ch 0x00; write_rgb ch c | SFSSolid3 c -> write_byte ch 0x00; write_rgba ch c | SFSLinearGradient (m,g) -> write_byte ch 0x10; write_matrix ch m; write_gradient ch g | SFSRadialGradient (m,g,None) -> write_byte ch 0x12; write_matrix ch m; write_gradient ch g | SFSRadialGradient (m,g,Some i) -> write_byte ch 0x13; write_matrix ch m; write_gradient ch g; write_i16 ch i; | SFSBitmap b -> write_byte ch (match b.sfb_repeat , b.sfb_smooth with | true, false -> 0x40 | false , false -> 0x41 | true , true -> 0x42 | false, true -> 0x43); write_ui16 ch b.sfb_cid; write_matrix ch b.sfb_mpos let write_shape_line_style ch l = write_ui16 ch l.sls_width; opt (write_ui16 ch) l.sls_flags; opt (write_ui16 ch) l.sls_miter; match l.sls_fill with | None -> write_color ch l.sls_color; | Some fill -> write_shape_fill_style ch fill let write_shape_array ch f sl = let n = List.length sl in if n >= 0xFF then begin write_byte ch 0xFF; write_ui16 ch n; end else write_byte ch n; List.iter (f ch) sl let write_shape_style_change_record ch b nlbits nfbits s = let flags = make_flags [flag s.scsr_move; flag s.scsr_fs0; flag s.scsr_fs1; flag s.scsr_ls; flag s.scsr_new_styles] in write_bits b 6 flags; opt (fun (n,dx,dy) -> write_bits b 5 n; write_bits b n dx; write_bits b n dy; ) s.scsr_move; opt (write_bits b ~nbits:!nfbits) s.scsr_fs0; opt (write_bits b ~nbits:!nfbits) s.scsr_fs1; opt (write_bits b ~nbits:!nlbits) s.scsr_ls; match s.scsr_new_styles with | None -> () | Some s -> flush_bits b; write_shape_array ch write_shape_fill_style s.sns_fill_styles; write_shape_array ch write_shape_line_style s.sns_line_styles; nfbits := s.sns_nfbits; nlbits := s.sns_nlbits; write_bits b 4 !nfbits; write_bits b 4 !nlbits let write_shape_record ch b nlbits nfbits = function | SRStyleChange s -> write_shape_style_change_record ch b nlbits nfbits s | SRCurvedEdge s -> write_bits b 2 2; write_bits b 4 (s.scer_nbits - 2); write_bits b s.scer_nbits s.scer_cx; write_bits b s.scer_nbits s.scer_cy; write_bits b s.scer_nbits s.scer_ax; write_bits b s.scer_nbits s.scer_ay; | SRStraightEdge s -> write_bits b 2 3; write_bits b 4 (s.sser_nbits - 2); match s.sser_line with | None , None -> assert false | None , Some p | Some p , None -> write_bits b 1 0; write_bits b 1 (if (fst s.sser_line) = None then 1 else 0); write_bits b s.sser_nbits p; | Some dx, Some dy -> write_bits b 1 1; write_bits b s.sser_nbits dx; write_bits b s.sser_nbits dy let write_shape_without_style ch s = (* write_shape_array ch write_shape_fill_style s.sws_fill_styles; *) (* write_shape_array ch write_shape_line_style s.sws_line_styles; *) let r = s in (* s.sws_records in *) let b = output_bits ch in write_bits b 4 r.srs_nfbits; write_bits b 4 r.srs_nlbits; let nlbits = ref r.srs_nlbits in let nfbits = ref r.srs_nfbits in List.iter (write_shape_record ch b nlbits nfbits) r.srs_records; (* write_bits b 6 0; *) flush_bits b let write_shape_with_style ch s = write_shape_array ch write_shape_fill_style s.sws_fill_styles; write_shape_array ch write_shape_line_style s.sws_line_styles; let r = s.sws_records in let b = output_bits ch in write_bits b 4 r.srs_nfbits; write_bits b 4 r.srs_nlbits; let nlbits = ref r.srs_nlbits in let nfbits = ref r.srs_nfbits in List.iter (write_shape_record ch b nlbits nfbits) r.srs_records; write_bits b 6 0; flush_bits b let write_shape ch s = write_ui16 ch s.sh_id; write_rect ch s.sh_bounds; (match s.sh_bounds2 with | None -> () | Some (r,b) -> write_rect ch r; write_byte ch b); write_shape_with_style ch s.sh_style let write_bitmap_lossless ch b = write_ui16 ch b.bll_id; write_byte ch b.bll_format; write_ui16 ch b.bll_width; write_ui16 ch b.bll_height; nwrite ch b.bll_data let write_morph_shape ch s = write_ui16 ch s.msh_id; write_rect ch s.msh_start_bounds; write_rect ch s.msh_end_bounds; nwrite ch s.msh_data let write_text_record ch t r = write_byte ch (make_flags [flag r.txr_dx; flag r.txr_dy; flag r.txr_color; flag r.txr_font; false; false; false; true]); opt (fun (id,_) -> write_ui16 ch id) r.txr_font; opt (write_color ch) r.txr_color; opt (write_i16 ch) r.txr_dx; opt (write_i16 ch) r.txr_dy; opt (fun (_,id) -> write_ui16 ch id) r.txr_font; write_byte ch (List.length r.txr_glyphs); let bits = output_bits ch in List.iter (fun g -> write_bits bits t.txt_ngbits g.txg_index; write_bits bits t.txt_nabits g.txg_advanced; ) r.txr_glyphs; flush_bits bits let write_text ch t = write_ui16 ch t.txt_id; write_big_rect ch t.txt_bounds; write_matrix ch t.txt_matrix; write_byte ch t.txt_ngbits; write_byte ch t.txt_nabits; List.iter (write_text_record ch t) t.txt_records; write_byte ch 0 let write_edit_text_layout ch l = write_byte ch l.edtl_align; write_ui16 ch l.edtl_left_margin; write_ui16 ch l.edtl_right_margin; write_ui16 ch l.edtl_indent; write_ui16 ch l.edtl_leading let write_edit_text ch t = write_ui16 ch t.edt_id; write_rect ch t.edt_bounds; write_ui16 ch (make_flags [ flag t.edt_font; flag t.edt_maxlen; flag t.edt_color; t.edt_readonly; t.edt_password; t.edt_multiline; t.edt_wordwrap; flag t.edt_text; t.edt_outlines; t.edt_html; false; t.edt_border; t.edt_noselect; flag t.edt_layout; t.edt_autosize; false ]); opt (fun (id,h) -> write_ui16 ch id; write_ui16 ch h) t.edt_font; opt (write_rgba ch) t.edt_color; opt (write_ui16 ch) t.edt_maxlen; opt (write_edit_text_layout ch) t.edt_layout; write_string ch t.edt_variable; opt (write_string ch) t.edt_text let write_cid_data ch c = write_ui16 ch c.cd_id; nwrite ch c.cd_data let write_filter_gradient ch fg = write_byte ch (List.length fg.fgr_colors); List.iter (fun (c,_) -> write_rgba ch c) fg.fgr_colors; List.iter (fun (_,n) -> write_byte ch n) fg.fgr_colors; nwrite ch fg.fgr_data let write_filter ch = function | FDropShadow s -> write_byte ch 0; nwrite ch s | FBlur s -> write_byte ch 1; nwrite ch s | FGlow s -> write_byte ch 2; nwrite ch s | FBevel s -> write_byte ch 3; nwrite ch s | FGradientGlow fg -> write_byte ch 4; write_filter_gradient ch fg | FAdjustColor s -> write_byte ch 6; nwrite ch s | FGradientBevel fg -> write_byte ch 7; write_filter_gradient ch fg let write_button_record ch r = write_byte ch r.btr_flags; write_ui16 ch r.btr_cid; write_ui16 ch r.btr_depth; write_matrix ch r.btr_mpos; (match r.btr_color with | None -> () | Some c -> write_cxa ch c); opt (fun l -> write_byte ch (List.length l); List.iter (write_filter ch) l ) r.btr_filters; (match r.btr_blendmode with | None -> () | Some c -> write_byte ch c) let rec write_button_actions ch = function | [] -> assert false | [a] -> write_ui16 ch 0; write_ui16 ch a.bta_flags; write_actions ch a.bta_actions | a :: l -> let size = button_action_length a in write_ui16 ch size; write_ui16 ch a.bta_flags; write_actions ch a.bta_actions; write_button_actions ch l let write_button2 ch b = write_ui16 ch b.bt2_id; write_byte ch (if b.bt2_track_as_menu then 1 else 0); if b.bt2_actions <> [] then write_ui16 ch (3 + sum button_record_length b.bt2_records) else write_ui16 ch 0; List.iter (write_button_record ch) b.bt2_records; write_byte ch 0; if b.bt2_actions <> [] then write_button_actions ch b.bt2_actions let write_place_object ch p v3 = write_byte ch (make_flags [ p.po_move; flag p.po_cid; flag p.po_matrix; flag p.po_color; flag p.po_ratio; flag p.po_inst_name; flag p.po_clip_depth; flag p.po_events ]); if v3 then write_byte ch (make_flags [flag p.po_filters; flag p.po_blend; flag p.po_bcache]); write_ui16 ch p.po_depth; opt (write_ui16 ch) p.po_cid; opt (write_matrix ch) p.po_matrix; opt (write_cxa ch) p.po_color; opt (write_ui16 ch) p.po_ratio; opt (write_string ch) p.po_inst_name; opt (write_ui16 ch) p.po_clip_depth; opt (write_clip_events ch) p.po_events; if v3 then begin opt (fun l -> write_byte ch (List.length l); List.iter (write_filter ch) l ) p.po_filters; opt (write_byte ch) p.po_blend; opt (write_byte ch) p.po_bcache; end let rec write_tag_data ch = function | TEnd -> () | TShowFrame -> () | TShape s -> write_shape ch s | TRemoveObject r -> write_ui16 ch r.rmo_id; write_ui16 ch r.rmo_depth; | TBitsJPEG b -> write_ui16 ch b.jpg_id; nwrite ch b.jpg_data | TJPEGTables tab -> nwrite ch tab | TSetBgColor c -> write_rgb ch c | TFont c -> write_cid_data ch c | TText t -> write_text ch t | TDoAction acts -> write_actions ch acts | TFontInfo c -> write_cid_data ch c | TSound s -> write_ui16 ch s.so_id; write_byte ch s.so_flags; write_i32 ch s.so_samples; nwrite ch s.so_data | TStartSound s -> write_ui16 ch s.sts_id; nwrite ch s.sts_data | TBitsLossless b -> write_bitmap_lossless ch b | TBitsJPEG2 b -> write_ui16 ch b.bd_id; opt (nwrite ch) b.bd_table; nwrite ch b.bd_data; | TShape2 s -> write_shape ch s | TProtect -> () | TPlaceObject2 p -> write_place_object ch p false; | TRemoveObject2 depth -> write_ui16 ch depth; | TShape3 s -> write_shape ch s | TText2 t -> write_text ch t | TButton2 b -> write_button2 ch b | TBitsJPEG3 b -> write_ui16 ch b.bd_id; write_i32 ch (String.length b.bd_data + opt_len String.length b.bd_table); opt (nwrite ch) b.bd_table; nwrite ch b.bd_data; opt (nwrite ch) b.bd_alpha; | TBitsLossless2 b -> write_bitmap_lossless ch b | TEditText t -> write_edit_text ch t | TClip c -> write_ui16 ch c.c_id; write_ui16 ch c.c_frame_count; List.iter (write_tag ch) c.c_tags; write_tag ch tag_end; | TProductInfo s -> nwrite ch s | TFrameLabel (label,id) -> write_string ch label; opt (write ch) id; | TSoundStreamHead2 data -> nwrite ch data | TMorphShape s -> write_morph_shape ch s | TFont2 c -> write_cid_data ch c | TExport el -> write_ui16 ch (List.length el); List.iter (fun e -> write_ui16 ch e.exp_id; write_string ch e.exp_name ) el | TImport (url,il) -> write_string ch url; write_ui16 ch (List.length il); List.iter (fun i -> write_ui16 ch i.imp_id; write_string ch i.imp_name ) il | TDoInitAction i -> write_ui16 ch i.dia_id; write_actions ch i.dia_actions; | TVideoStream c -> write_cid_data ch c | TVideoFrame c -> write_cid_data ch c | TFontInfo2 c -> write_cid_data ch c | TDebugID s -> nwrite ch s | TEnableDebugger2 (tag,pass) -> write_ui16 ch tag; write_string ch pass | TScriptLimits (recursion_depth, script_timeout) -> write_ui16 ch recursion_depth; write_ui16 ch script_timeout; | TFilesAttributes f -> let flags = make_flags [f.fa_network;false;false;f.fa_as3;f.fa_metadata;f.fa_gpu;f.fa_direct_blt] in write_i32 ch flags | TPlaceObject3 p -> write_place_object ch p true; | TImport2 (url,il) -> write_string ch url; write_byte ch 1; write_byte ch 0; write_ui16 ch (List.length il); List.iter (fun i -> write_ui16 ch i.imp_id; write_string ch i.imp_name ) il | TFontAlignZones c -> write_cid_data ch c | TCSMSettings c -> write_cid_data ch c | TFont3 c -> write_cid_data ch c | TF9Classes l -> write_ui16 ch (List.length l); List.iter (fun c -> write_ui16 ch (match c.f9_cid with None -> 0 | Some id -> id); write_string ch c.f9_classname ) l | TMetaData meta -> write_string ch meta | TScale9 (cid,r) -> write_ui16 ch cid; write_rect ch r; | TActionScript3 (id,a) -> (match id with | None -> () | Some (id,frame) -> write_i32 ch id; write_string ch frame; ); As3parse.write ch a | TShape4 s -> write_shape ch s | TMorphShape2 m -> write_morph_shape ch m | TScenes (sl,fl) -> As3parse.write_int ch (List.length sl); List.iter (fun (n,s) -> As3parse.write_int ch n; write_string ch s; ) sl; As3parse.write_int ch (List.length fl); List.iter (fun (n,s) -> As3parse.write_int ch n; write_string ch s; ) sl; | TBinaryData (id,data) -> write_ui16 ch id; write_i32 ch 0; nwrite ch data | TBigBinaryData (id,data) -> write_ui16 ch id; write_i32 ch 0; List.iter (nwrite ch) data | TFontName c -> write_cid_data ch c | TBitsJPEG4 b -> write_ui16 ch b.bd_id; write_i32 ch (String.length b.bd_data + opt_len String.length b.bd_table); opt (write_ui16 ch) b.bd_deblock; opt (nwrite ch) b.bd_table; nwrite ch b.bd_data; opt (nwrite ch) b.bd_alpha; | TFont4 c -> write_cid_data ch c | TUnknown (_,data) -> nwrite ch data and write_tag ch t = let id = tag_id t.tdata in let dlen = tag_data_length t.tdata in if t.textended || dlen >= 63 then begin write_ui16 ch ((id lsl 6) lor 63); write_i32 ch dlen; end else begin write_ui16 ch ((id lsl 6) lor dlen); end; write_tag_data ch t.tdata let write ch (h,tags) = swf_version := h.h_version; nwrite ch (if h.h_compressed then "CWS" else "FWS"); write ch (char_of_int h.h_version); let rec calc_len = function | [] -> tag_length tag_end | t :: l -> tag_length t + calc_len l in let len = calc_len tags in let len = len + 4 + 4 + rect_length h.h_size + 2 + 2 in write_i32 ch len; let ch = (if h.h_compressed then deflate ch else ch) in write_rect ch h.h_size; write_ui16 ch h.h_fps; write_ui16 ch h.h_frame_count; List.iter (write_tag ch) tags; write_tag ch tag_end; if h.h_compressed then IO.close_out ch (* ************************************************************************ *) (* EXTRA *) let scan fid f t = match t.tdata with | TEnd | TShowFrame | TJPEGTables _ | TSetBgColor _ | TDoAction _ | TActionScript3 _ | TProtect | TRemoveObject2 _ | TFrameLabel _ | TSoundStreamHead2 _ | TScenes _ | TEnableDebugger2 _ | TMetaData _ | TScriptLimits _ | TDebugID _ | TFilesAttributes _ | TProductInfo _ -> () | TF9Classes l -> List.iter (fun c -> match c.f9_cid with | None -> () | Some id -> c.f9_cid <- Some (f id) ) l | TShape s | TShape2 s | TShape3 s | TShape4 s -> s.sh_id <- fid s.sh_id; let loop fs = List.iter (fun s -> match s with | SFSBitmap b -> if b.sfb_cid <> 0xFFFF then b.sfb_cid <- f b.sfb_cid; | _ -> () ) fs in loop s.sh_style.sws_fill_styles; List.iter (fun s -> match s with | SRStyleChange { scsr_new_styles = Some s } -> loop s.sns_fill_styles | _ -> () ) s.sh_style.sws_records.srs_records; | TRemoveObject r -> r.rmo_id <- f r.rmo_id | TBitsJPEG b -> b.jpg_id <- fid b.jpg_id | TBitsJPEG2 b -> b.bd_id <- fid b.bd_id | TText t | TText2 t -> t.txt_id <- fid t.txt_id; List.iter (fun r -> match r.txr_font with None -> () | Some (id,id2) -> r.txr_font <- Some (f id,id2)) t.txt_records | TEditText t -> t.edt_id <- fid t.edt_id; (match t.edt_font with None -> () | Some (id,h) -> t.edt_font <- Some (f id,h)) | TSound s -> s.so_id <- fid s.so_id | TStartSound s -> s.sts_id <- f s.sts_id | TBitsLossless b | TBitsLossless2 b -> b.bll_id <- fid b.bll_id | TPlaceObject2 p -> p.po_cid <- (match p.po_cid with None -> None | Some id -> Some (f id)) | TButton2 b -> b.bt2_id <- fid b.bt2_id; List.iter (fun r -> r.btr_cid <- f r.btr_cid ) b.bt2_records; | TBitsJPEG3 j -> j.bd_id <- fid j.bd_id | TClip c -> c.c_id <- fid c.c_id | TMorphShape s | TMorphShape2 s -> s.msh_id <- fid s.msh_id | TFont c | TFont2 c | TFont3 c | TFont4 c -> c.cd_id <- fid c.cd_id | TExport el -> List.iter (fun e -> e.exp_id <- f e.exp_id) el | TImport (_,il) | TImport2 (_,il) -> List.iter (fun i -> i.imp_id <- fid i.imp_id) il | TDoInitAction a -> a.dia_id <- f a.dia_id | TVideoStream c -> c.cd_id <- fid c.cd_id | TVideoFrame c -> c.cd_id <- f c.cd_id | TPlaceObject3 p -> p.po_cid <- (match p.po_cid with None -> None | Some id -> Some (f id)) | TCSMSettings c -> c.cd_id <- f c.cd_id | TBinaryData (id,data) -> t.tdata <- TBinaryData (fid id,data) | TBigBinaryData (id,data) -> t.tdata <- TBigBinaryData (fid id,data) | TFontAlignZones c | TFontInfo c | TFontInfo2 c | TFontName c -> c.cd_id <- f c.cd_id | TScale9 (id,r) -> t.tdata <- TScale9 (f id,r) | TBitsJPEG4 j -> j.bd_id <- fid j.bd_id | TUnknown _ -> () let tag_name = function | TEnd -> "End" | TShowFrame -> "ShowFrame" | TShape _ -> "Shape" | TRemoveObject _ -> "RemoveObject" | TBitsJPEG _ -> "BitsJPEG" | TJPEGTables _ -> "JPGETables" | TSetBgColor _ -> "SetBgColor" | TFont _ -> "Font" | TText _ -> "Text" | TDoAction _ -> "DoAction" | TFontInfo _ -> "FontInfo" | TSound _ -> "Sound" | TStartSound _ -> "StartSound" | TBitsLossless _ -> "BitsLossless" | TBitsJPEG2 _ -> "BitsJPEG2" | TShape2 _ -> "Shape2" | TProtect -> "Protect" | TPlaceObject2 _ -> "PlaceObject2" | TRemoveObject2 _ -> "RemoveObject2" | TShape3 _ -> "Shape3" | TText2 _ -> "Text2" | TButton2 _ -> "Button2" | TBitsJPEG3 _ -> "BitsJPEG3" | TBitsLossless2 _ -> "Lossless2" | TEditText _ -> "EditText" | TClip _ -> "Clip" | TProductInfo _ -> "ProductInfo" | TFrameLabel _ -> "FrameLabel" | TSoundStreamHead2 _ -> "SoundStreamHead2" | TMorphShape _ -> "MorphShape" | TFont2 _ -> "Font2" | TExport _ -> "Export" | TImport _ -> "Import" | TDoInitAction _ -> "DoInitAction" | TVideoStream _ -> "VideoStream" | TVideoFrame _ -> "VideoFrame" | TFontInfo2 _ -> "FontInfo2" | TDebugID _ -> "DebugID" | TEnableDebugger2 _ -> "EnableDebugger2" | TScriptLimits _ -> "ScriptLimits" | TFilesAttributes _ -> "FilesAttributes" | TPlaceObject3 _ -> "PlaceObject3" | TImport2 _ -> "Import2" | TFontAlignZones _ -> "FontAlignZones" | TCSMSettings _ -> "TCSMSettings" | TFont3 _ -> "Font3" | TF9Classes _ -> "F9Classes" | TMetaData _ -> "MetaData" | TScale9 _ -> "Scale9" | TActionScript3 _ -> "ActionScript3" | TShape4 _ -> "Shape4" | TMorphShape2 _ -> "MorphShape2" | TScenes _ -> "Scenes" | TBinaryData _ -> "BinaryData" | TBigBinaryData _ -> "BigBinaryData" | TFontName _ -> "FontName" | TBitsJPEG4 _ -> "BitsJPEG4" | TFont4 _ -> "Font4" | TUnknown (n,_) -> Printf.sprintf "Unknown 0x%.2X" n let init inflate deflate = Swf.__parser := parse; Swf.__printer := write; Swf.__inflate := inflate; Swf.__deflate := deflate; ;; Swf.__parser := parse; Swf.__printer := writehaxe-3.0~svn6707/libs/swflib/actionScript.ml0000644000175000017500000004531512172015137021426 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2004 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Swf open IO open Printf let push_item_length = function | PString s -> String.length s + 1 | PFloat _ -> 4 | PNull -> 0 | PUndefined -> 0 | PReg _ -> 1 | PBool _ -> 1 | PDouble _ -> 8 | PInt _ -> 4 | PStack _ -> 1 | PStack2 _ -> 2 let push_item_id = function | PString s -> 0 | PFloat _ -> 1 | PNull -> 2 | PUndefined -> 3 | PReg _ -> 4 | PBool _ -> 5 | PDouble _ -> 6 | PInt _ -> 7 | PStack _ -> 8 | PStack2 _ -> 9 let opcodes = Hashtbl.create 0 let opcodes_rev = Hashtbl.create 0 let opcodes_names = Hashtbl.create 0 let ( => ) code (op,name) = Hashtbl.add opcodes op code; Hashtbl.add opcodes_rev code op; Hashtbl.add opcodes_names op name let short_op_codes = begin 0x00 => (AEnd,"END"); 0x04 => (ANextFrame,"NEXTFRAME"); 0x05 => (APrevFrame,"PREVFRAME"); 0x06 => (APlay,"PLAY"); 0x07 => (AStop,"STOP"); 0x08 => (AToggleHighQuality,"TGLHIGHQULTY"); 0x09 => (AStopSounds,"STOPSOUNDS"); 0x0A => (AAddNum,"ADDNUM"); 0x0B => (ASubtract,"SUB"); 0x0C => (AMultiply,"MULT"); 0x0D => (ADivide,"DIV"); 0x0E => (ACompareNum,"CMP"); 0x0F => (AEqualNum,"EQNUM"); 0x10 => (ALogicalAnd,"LAND"); 0x11 => (ALogicalOr,"LOR"); 0x12 => (ANot,"NOT"); 0x13 => (AStringEqual,"STREQ"); 0x14 => (AStringLength,"STRLEN"); 0x15 => (ASubString,"SUBSTR"); 0x17 => (APop,"POP"); 0x18 => (AToInt,"TOINT"); 0x1C => (AEval,"EVAL"); 0x1D => (ASet,"SET"); 0x20 => (ATellTarget,"TELLTARGET"); 0x21 => (AStringAdd,"STRADD"); 0x22 => (AGetProperty,"GETPROP"); 0x23 => (ASetProperty,"SETPROP"); 0x24 => (ADuplicateMC,"DUPLICATEMC"); 0x25 => (ARemoveMC,"REMOVEMC"); 0x26 => (ATrace,"TRACE"); 0x27 => (AStartDrag,"STARTDRAG"); 0x28 => (AStopDrag,"STOPDRAG"); 0x2A => (AThrow,"THROW"); 0x2B => (ACast,"CAST"); 0x2C => (AImplements,"IMPLEMENTS"); 0x2D => (AFSCommand2,"FSCOMMAND2"); 0x30 => (ARandom,"RANDOM"); 0x31 => (AMBStringLength,"MBSTRLEN"); 0x32 => (AOrd,"ORD"); 0x33 => (AChr,"CHR"); 0x34 => (AGetTimer,"GETTIMER"); 0x35 => (AMBStringSub,"MBSTRSUB"); 0x36 => (AMBOrd,"MBORD"); 0x37 => (AMBChr,"MBCHR"); 0x3A => (ADeleteObj,"DELETEOBJ"); 0x3B => (ADelete,"DELETE"); 0x3C => (ALocalAssign,"VARSET"); 0x3D => (ACall,"CALL"); 0x3E => (AReturn,"RET"); 0x3F => (AMod,"MOD"); 0x40 => (ANew,"NEW"); 0x41 => (ALocalVar,"VAR"); 0x42 => (AInitArray,"ARRAY"); 0x43 => (AObject,"OBJECT"); 0x44 => (ATypeOf,"TYPEOF"); 0x45 => (ATargetPath,"TARGETPATH"); 0x46 => (AEnum,"ENUM"); 0x47 => (AAdd,"ADD"); 0x48 => (ACompare,"CMP"); 0x49 => (AEqual,"EQ"); 0x4A => (AToNumber,"TONUMBER"); 0x4B => (AToString,"TOSTRING"); 0x4C => (ADup,"DUP"); 0x4D => (ASwap,"SWAP"); 0x4E => (AObjGet,"OBJGET"); 0x4F => (AObjSet,"OBJSET"); 0x50 => (AIncrement,"INCR"); 0x51 => (ADecrement,"DECR"); 0x52 => (AObjCall,"OBJCALL"); 0x53 => (ANewMethod,"NEWMETHOD"); 0x54 => (AInstanceOf,"INSTANCEOF"); 0x55 => (AEnum2,"ENUM2"); 0x60 => (AAnd,"AND"); 0x61 => (AOr,"OR"); 0x62 => (AXor,"XOR"); 0x63 => (AShl,"SHL"); 0x64 => (AShr,"SHR"); 0x65 => (AAsr,"ASR"); 0x66 => (APhysEqual,"PHYSEQ"); 0x67 => (AGreater,"GT"); 0x68 => (AStringGreater,"STRGT"); 0x69 => (AExtends,"EXTENDS"); 0x9E => (ACallFrame,"CALLFRAME"); (* special case *) end let action_id = function | AGotoFrame _ -> 0x81 | AGetURL _ -> 0x83 | ASetReg _ -> 0x87 | AStringPool _ -> 0x88 | AWaitForFrame _ -> 0x8A | ASetTarget _ -> 0x8B | AGotoLabel _ -> 0x8C | AWaitForFrame2 _ -> 0x8D | AFunction2 _ -> 0x8E | ATry _ -> 0x8F | AWith _ -> 0x94 | APush _ -> 0x96 | AJump _ -> 0x99 | AGetURL2 _ -> 0x9A | AFunction _ -> 0x9B | ACondJump _ -> 0x9D | AGotoFrame2 _ -> 0x9F | AUnknown (id,_) -> id | op -> try Hashtbl.find opcodes op with Not_found -> error "Unknown opcode id" let action_data_length = function | AGotoFrame _ -> 2 | AGetURL (url,target) -> 2 + String.length url + String.length target | ASetReg _ -> 1 | AStringPool strs -> List.fold_left (fun acc item -> acc + 1 + String.length item) 2 strs | AWaitForFrame _ -> 3 | AFunction2 f -> let base = String.length f.f2_name + 1 + 2 + 1 + 2 + 2 in List.fold_left (fun acc (_,s) -> acc + 2 + String.length s) base f.f2_args | ASetTarget target -> String.length target + 1 | AGotoLabel label -> String.length label + 1 | AWaitForFrame2 _ -> 1 | ATry t -> 1 + 6 + (match t.tr_style with TryVariable n -> String.length n + 1 | TryRegister _ -> 1) | AWith _ -> 2 (* the string does not count in length *) | APush items -> List.fold_left (fun acc item -> acc + 1 + push_item_length item) 0 items | AJump _ -> 2 | AGetURL2 _ -> 1 | AFunction f -> List.fold_left (fun acc s -> acc + 1 + String.length s) 4 (f.f_name :: f.f_args) | ACondJump _ -> 2 | AGotoFrame2 (_,id) -> 1 + (if id = None then 0 else 2) | AUnknown (_,data) -> String.length data | _ -> 0 let action_length a = let len = (if action_id a >= 0x80 then 3 else 1) in len + action_data_length a let actions_length acts = DynArray.fold_left (fun acc a -> acc + action_length a) (action_length AEnd) acts let read_mm_double ch = let i1 = Int64.of_int32 (read_real_i32 ch) in let i2 = Int64.of_int32 (read_real_i32 ch) in let i2 = (if i2 < Int64.zero then Int64.add i2 (Int64.shift_left Int64.one 32) else i2) in Int64.float_of_bits (Int64.logor i2 (Int64.shift_left i1 32)) let write_mm_double ch f = let i64 = Int64.bits_of_float f in write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical i64 32)); write_real_i32 ch (Int64.to_int32 i64) let read_string_max ch len = let b = Buffer.create 0 in let rec loop l = if l = 0 then begin let s = Buffer.contents b in String.sub s 0 (String.length s - 1) end else let c = read ch in if c = '\000' then Buffer.contents b else begin Buffer.add_char b c; loop (l - 1) end; in loop len let parse_push_item ch len = let id = read_byte ch in match id with | 0 -> PString (read_string_max ch len) | 1 -> PFloat (read_real_i32 ch) | 2 -> PNull | 3 -> PUndefined | 4 -> PReg (read_byte ch) | 5 -> PBool (read_byte ch <> 0) | 6 -> PDouble (read_mm_double ch) | 7 -> PInt (read_real_i32 ch) | 8 -> PStack (read_byte ch) | 9 -> PStack2 (read_ui16 ch) | _ -> error (sprintf "Unknown PUSH item id : %d" id) let rec parse_push_items ch len = if len < 0 then error "PUSH parse overflow"; if len = 0 then [] else let item = parse_push_item ch len in item :: parse_push_items ch (len - 1 - push_item_length item) let rec read_strings ch n = if n = 0 then [] else let s = read_string ch in s :: read_strings ch (n-1) let parse_function_decl ch = let name = read_string ch in let nargs = read_ui16 ch in let args = read_strings ch nargs in let clen = read_ui16 ch in { f_name = name; f_args = args; f_codelen = clen; } let parse_f2_flags n = let flags = ref [] in let v = ref 1 in let add_flag f = if n land !v <> 0 then flags := f :: !flags; v := !v lsl 1 in List.iter add_flag [ThisRegister; ThisNoVar; ArgumentsRegister; ArgumentsNoVar; SuperRegister; SuperNoVar; RootRegister; ParentRegister; GlobalRegister]; !flags let parse_function_decl2 ch = let name = read_string ch in let nargs = read_ui16 ch in let nregs = read_byte ch in let flags = parse_f2_flags (read_ui16 ch) in let rec loop n = if n = 0 then [] else let r = read_byte ch in let s = read_string ch in (r,s) :: loop (n-1) in let args = loop nargs in let clen = read_ui16 ch in { f2_name = name; f2_args = args; f2_flags = flags; f2_codelen = clen; f2_nregs = nregs; } let parse_action ch = let id = read_byte ch in let len = (if id >= 0x80 then read_ui16 ch else 0) in let len = (if len = 0xFFFF then 0 else len) in let act = (match id with | 0x81 -> AGotoFrame (read_ui16 ch) | 0x83 -> let url = read_string ch in let target = read_string ch in AGetURL (url,target) | 0x87 -> ASetReg (read_byte ch) | 0x88 -> let nstrs = read_ui16 ch in AStringPool (read_strings ch nstrs) | 0x8A -> let frame = read_ui16 ch in let skip = read_byte ch in AWaitForFrame (frame,skip) | 0x8B -> ASetTarget (read_string ch) | 0x8C -> AGotoLabel (read_string ch) | 0x8D -> AWaitForFrame2 (read_byte ch) | 0x8E -> AFunction2 (parse_function_decl2 ch) | 0x8F -> let flags = read_byte ch in let tsize = read_ui16 ch in let csize = read_ui16 ch in let fsize = read_ui16 ch in let tstyle = (if flags land 4 == 0 then TryVariable (read_string ch) else TryRegister (read_byte ch)) in ATry { tr_style = tstyle; tr_trylen = tsize; tr_catchlen = (if flags land 1 == 0 then None else Some csize); tr_finallylen = (if flags land 2 == 0 then None else Some fsize); } | 0x94 -> let size = read_ui16 ch in AWith size | 0x96 -> APush (parse_push_items ch len) | 0x99 -> AJump (read_i16 ch) | 0x9A -> AGetURL2 (read_byte ch) | 0x9B -> AFunction (parse_function_decl ch) | 0x9D -> ACondJump (read_i16 ch) | 0x9E -> ACallFrame | 0x9F -> let flags = read_byte ch in let play = flags land 1 <> 0 in let delta = (if flags land 2 == 0 then None else Some (read_ui16 ch)) in AGotoFrame2 (play,delta) | _ -> try Hashtbl.find opcodes_rev id with Not_found -> printf "Unknown Action 0x%.2X (%d)\n" id len; AUnknown (id,nread ch len) ) in (* let len2 = action_data_length act in if len <> len2 then error (sprintf "Datalen mismatch for action 0x%.2X (%d != %d)" id len len2); *) act let size_to_jump_index acts curindex size = let delta = ref 0 in let size = ref size in if !size >= 0 then begin while !size > 0 do incr delta; size := !size - action_length (DynArray.get acts (curindex + !delta)); if !size < 0 then error "Unaligned code"; done; end else begin while !size < 0 do size := !size + action_length (DynArray.get acts (curindex + !delta)); if !size > 0 then error "Unaligned code"; decr delta; done; end; !delta let parse_actions ch = let acts = DynArray.create() in let rec loop() = match parse_action ch with | AEnd -> () | AUnknown (0xFF,"") -> DynArray.add acts APlay; DynArray.add acts APlay; DynArray.add acts APlay; loop() | a -> DynArray.add acts a; loop(); in loop(); (* process jump indexes *) let process_jump curindex = function | AJump size -> let index = size_to_jump_index acts curindex size in DynArray.set acts curindex (AJump index) | ACondJump size -> let index = size_to_jump_index acts curindex size in DynArray.set acts curindex (ACondJump index) | AFunction f -> let index = size_to_jump_index acts curindex f.f_codelen in DynArray.set acts curindex (AFunction { f with f_codelen = index }) | AFunction2 f -> let index = size_to_jump_index acts curindex f.f2_codelen in DynArray.set acts curindex (AFunction2 { f with f2_codelen = index }) | AWith size -> let index = size_to_jump_index acts curindex size in DynArray.set acts curindex (AWith index) | ATry t -> let tindex = size_to_jump_index acts curindex t.tr_trylen in let cindex = (match t.tr_catchlen with None -> None | Some size -> Some (size_to_jump_index acts (curindex + tindex) size)) in let findex = (match t.tr_finallylen with None -> None | Some size -> Some (size_to_jump_index acts (curindex + tindex + (match cindex with None -> 0 | Some i -> i)) size)) in DynArray.set acts curindex (ATry { t with tr_trylen = tindex; tr_catchlen = cindex; tr_finallylen = findex }) | _ -> () in DynArray.iteri process_jump acts; acts let jump_index_to_size acts curindex target = let size = ref 0 in if target >= 0 then begin for i = 1 to target do size := !size + action_length (DynArray.get acts (curindex + i)); done; end else begin for i = 0 downto target+1 do size := !size - action_length (DynArray.get acts (curindex + i)); done; end; !size let rec write_strings ch = function | [] -> () | s :: l -> write_string ch s; write_strings ch l let write_push_item_data ch = function | PString s -> write_string ch s | PFloat f -> write_real_i32 ch f | PNull -> () | PUndefined -> () | PReg r -> write_byte ch r | PBool b -> write_byte ch (if b then 1 else 0) | PDouble f -> write_mm_double ch f | PInt n -> write_real_i32 ch n | PStack index -> write_byte ch index | PStack2 index -> write_ui16 ch index let f2_flags_value flags = let fval = function | ThisRegister -> 1 | ThisNoVar -> 2 | ArgumentsRegister -> 4 | ArgumentsNoVar -> 8 | SuperRegister -> 16 | SuperNoVar -> 32 | RootRegister -> 64 | ParentRegister -> 128 | GlobalRegister -> 256 in List.fold_left (fun n f -> n lor (fval f)) 0 flags let write_action_data acts curindex ch = function | AGotoFrame frame -> write_ui16 ch frame | AGetURL (url,target) -> write_string ch url; write_string ch target | ASetReg reg -> write_byte ch reg | AStringPool strs -> write_ui16 ch (List.length strs); write_strings ch strs | AWaitForFrame (frame,skip) -> write_ui16 ch frame; write_byte ch skip | ASetTarget target -> write_string ch target | AGotoLabel label -> write_string ch label | AWaitForFrame2 n -> write_byte ch n | AFunction2 f -> write_string ch f.f2_name; write_ui16 ch (List.length f.f2_args); write_byte ch f.f2_nregs; write_ui16 ch (f2_flags_value f.f2_flags); List.iter (fun (r,s) -> write_byte ch r; write_string ch s; ) f.f2_args; let size = jump_index_to_size acts curindex f.f2_codelen in write_ui16 ch size; | ATry t -> let tsize = jump_index_to_size acts curindex t.tr_trylen in let csize = (match t.tr_catchlen with None -> 0 | Some idx -> jump_index_to_size acts (curindex + t.tr_trylen) idx) in let fsize = (match t.tr_finallylen with None -> 0 | Some idx -> jump_index_to_size acts (curindex + t.tr_trylen + (match t.tr_catchlen with None -> 0 | Some n -> n)) idx) in let flags = (if t.tr_catchlen <> None then 1 else 0) lor (if t.tr_finallylen <> None then 2 else 0) lor (match t.tr_style with TryRegister _ -> 4 | TryVariable _ -> 0) in write_byte ch flags; write_ui16 ch tsize; write_ui16 ch csize; write_ui16 ch fsize; (match t.tr_style with | TryVariable v -> write_string ch v | TryRegister r -> write_byte ch r) | AWith target -> let size = jump_index_to_size acts curindex target in write_ui16 ch size | APush items -> List.iter (fun item -> write_byte ch (push_item_id item); write_push_item_data ch item ) items | AJump target -> let size = jump_index_to_size acts curindex target in write_i16 ch size | AGetURL2 n -> write_byte ch n | AFunction f -> write_string ch f.f_name; write_ui16 ch (List.length f.f_args); write_strings ch f.f_args; let size = jump_index_to_size acts curindex f.f_codelen in write_ui16 ch size; | ACondJump target -> let size = jump_index_to_size acts curindex target in write_i16 ch size; | AGotoFrame2 (play,None) -> write_byte ch (if play then 1 else 0) | AGotoFrame2 (play,Some delta) -> write_byte ch (if play then 3 else 2); write_ui16 ch delta; | ACallFrame -> () | AUnknown (_,data) -> nwrite ch data | _ -> assert false let write_action acts curindex ch a = let id = action_id a in let len = action_data_length a in if id < 0x80 && len > 0 then error "Invalid Action Written"; write_byte ch id; if len > 0 || id >= 0x80 then begin write_ui16 ch len; write_action_data acts curindex ch a; end let write_actions ch acts = DynArray.iteri (fun index act -> write_action acts index ch act) acts; write_action acts (DynArray.length acts) ch AEnd let sprintf = Printf.sprintf let action_string get_ident pos = function | AGotoFrame n -> sprintf "GOTOFRAME %d" n | AGetURL (a,b) -> sprintf "GETURL '%s' '%s'" a b | ASetReg n -> sprintf "SETREG %d" n | AStringPool strlist -> let b = Buffer.create 0 in Buffer.add_string b "STRINGS "; let p = ref 0 in List.iter (fun s -> Buffer.add_string b (string_of_int !p); incr p; Buffer.add_char b ':'; Buffer.add_string b s; Buffer.add_char b ' '; ) strlist; Buffer.contents b | AWaitForFrame (i,j) -> sprintf "WAITFORFRAME %d %d" i j | ASetTarget s -> sprintf "SETTARGET %s" s | AGotoLabel s -> sprintf "GOTOLABEL %s" s | AWaitForFrame2 n -> sprintf "WAITFORFRAME2 %d" n | AFunction2 f -> let b = Buffer.create 0 in Buffer.add_string b "FUNCTION2 "; Buffer.add_string b f.f2_name; Buffer.add_char b '('; Buffer.add_string b (String.concat "," (List.map (fun (n,str) -> sprintf "%d:%s" n str) f.f2_args)); Buffer.add_char b ')'; Buffer.add_string b (sprintf " nregs:%d flags:%d " f.f2_nregs (f2_flags_value f.f2_flags)); Buffer.add_string b (sprintf "0x%.4X" (pos + 1 + f.f2_codelen)); Buffer.contents b | APush pl -> let b = Buffer.create 0 in Buffer.add_string b "PUSH"; List.iter (fun it -> Buffer.add_char b ' '; match it with | PString s -> Buffer.add_char b '"'; Buffer.add_string b s; Buffer.add_char b '"' | PFloat _ -> Buffer.add_string b "" | PNull -> Buffer.add_string b "null" | PUndefined -> Buffer.add_string b "undefined" | PReg n -> Buffer.add_string b (sprintf "reg:%d" n) | PBool fl -> Buffer.add_string b (if fl then "true" else "false") | PDouble _ -> Buffer.add_string b "" | PInt i -> Buffer.add_string b (Int32.to_string i) | PStack n | PStack2 n -> Buffer.add_char b '['; Buffer.add_string b (string_of_int n); Buffer.add_char b ':'; Buffer.add_string b (get_ident n); Buffer.add_char b ']'; ) pl; Buffer.contents b | ATry _ -> sprintf "TRY" | AWith n -> sprintf "WITH %d" n | AJump n -> sprintf "JUMP 0x%.4X" (n + pos + 1) | AGetURL2 n -> sprintf "GETURL2 %d" n | AFunction f -> let b = Buffer.create 0 in Buffer.add_string b "FUNCTION "; Buffer.add_string b f.f_name; Buffer.add_char b '('; Buffer.add_string b (String.concat "," f.f_args); Buffer.add_char b ')'; Buffer.add_string b (sprintf " 0x%.4X" (pos + 1 + f.f_codelen)); Buffer.contents b | ACondJump n -> sprintf "CJMP 0x%.4X" (n + pos + 1) | AGotoFrame2 (b,None) -> sprintf "GOTOFRAME2 %b" b | AGotoFrame2 (b,Some i) -> sprintf "GOTOFRAME2 %b %d" b i | AUnknown (tag,_) -> sprintf "??? 0x%.2X" tag | op -> try Hashtbl.find opcodes_names op with Not_found -> assert false haxe-3.0~svn6707/libs/swflib/as3hlparse.ml0000644000175000017500000007004112172015137021023 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2004-2008 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open As3 open As3hl type parse_ctx = { as3 : as3_tag; mutable namespaces : hl_namespace array; mutable nsets : hl_ns_set array; mutable names : hl_name array; mutable methods : hl_method array; mutable classes : hl_class array; mutable jumps : (int * int) list; mutable pos : int; delta_mt : int; delta_cl : int; } let get = As3parse.iget let no_nz = As3parse.no_nz let idx n = As3parse.index_int n - 1 let ident ctx i = get ctx.as3.as3_idents i let name ctx n = ctx.names.(idx n) let method_type ctx n = ctx.methods.(idx (no_nz n)) let getclass ctx n = ctx.classes.(idx (no_nz n)) let opt f ctx = function | None -> None | Some x -> Some (f ctx x) let stack_delta = function | HBreakPoint -> 0 | HNop -> 0 | HThrow -> -1 | HGetSuper _ -> 0 | HSetSuper _ -> -2 | HDxNs _ -> 0 | HDxNsLate -> -1 | HRegKill _ -> 0 | HLabel -> 0 | HJump (cond,_) -> (match cond with | J3Always -> 0 | J3True | J3False -> -1 | _ -> -2) | HSwitch _ -> -1 | HPushWith -> -1 | HPopScope -> 0 | HForIn -> -1 | HHasNext -> -1 | HNull | HUndefined -> 1 | HForEach -> -1 | HSmallInt _ | HInt _ | HTrue | HFalse | HString _ | HIntRef _ | HUIntRef _ | HFunction _ | HFloat _ | HNaN -> 1 | HPop -> -1 | HDup -> 1 | HSwap -> 0 | HScope -> -1 | HNamespace _ -> 1 | HNext _ -> 1 | HCallStack n -> -(n + 1) | HConstruct n -> -n | HCallMethod (_,n) -> -n | HCallStatic (_,n) -> -n | HCallSuper (_,n) -> -n | HCallProperty (_,n) -> -n | HRetVoid -> 0 | HRet -> -1 | HConstructSuper n -> -(n + 1) | HConstructProperty (_,n) -> -n | HCallPropLex (_,n) -> -n | HCallSuperVoid (_,n) -> -(n + 1) | HCallPropVoid (_,n) -> -(n + 1) | HApplyType n -> -n | HObject n -> -(n * 2) + 1 | HArray n -> -n + 1 | HNewBlock -> 1 | HClassDef _ -> 0 | HGetDescendants _ -> 0 | HCatch _ -> 1 | HFindPropStrict _ -> 1 | HFindProp _ -> 1 | HFindDefinition _ -> 1 | HGetLex _ -> 1 | HSetProp _ -> -2 | HReg _ -> 1 | HSetReg _ | HSetThis -> -1 | HGetGlobalScope | HGetScope _ -> 1 | HGetProp _ -> 0 | HInitProp _ -> -2 | HDeleteProp _ -> -1 (* true/false *) | HGetSlot _ -> 0 | HSetSlot _ -> -2 | HToString | HToXml | HToXmlAttr | HToInt | HToUInt | HToNumber | HToObject | HAsAny | HAsType _ | HIsType _ | HAsObject | HAsString | HToBool -> 0 | HCheckIsXml -> 0 | HCast _ -> 0 | HTypeof -> 0 | HInstanceOf -> -1 | HIncrReg _ | HDecrReg _ | HIncrIReg _ | HDecrIReg _ -> 0 | HThis -> 1 | HDebugReg _ | HDebugLine _ | HBreakPointLine _ | HTimestamp | HDebugFile _ -> 0 | HOp op -> (match op with | A3ONeg | A3OINeg | A3OIncr | A3ODecr | A3ONot | A3OBitNot | A3OIIncr | A3OIDecr -> 0 | A3OMemGet8 | A3OMemGet16 | A3OMemGet32 | A3OMemGetFloat | A3OMemGetDouble | A3OSign1 | A3OSign8 | A3OSign16 -> 0 | A3OMemSet8 | A3OMemSet16 | A3OMemSet32 | A3OMemSetFloat | A3OMemSetDouble -> -2 | _ -> -1) | HUnk _ -> assert false let parse_opcode ctx i = function | A3BreakPoint -> HBreakPoint | A3Nop -> HNop | A3Throw -> HThrow | A3GetSuper n -> HGetSuper (name ctx n) | A3SetSuper n -> HSetSuper (name ctx n) | A3DxNs s -> HDxNs (ident ctx s) | A3DxNsLate -> HDxNsLate | A3RegKill r -> HRegKill r | A3Label -> HLabel | A3Jump (j,n) -> ctx.jumps <- (i,ctx.pos) :: ctx.jumps; HJump (j,n) | A3Switch (n,infos) as op -> ctx.jumps <- (i,ctx.pos - As3code.length op) :: ctx.jumps; HSwitch(n,infos) | A3PushWith -> HPushWith | A3PopScope -> HPopScope | A3ForIn -> HForIn | A3HasNext -> HHasNext | A3Null -> HNull | A3Undefined -> HUndefined | A3ForEach -> HForEach | A3SmallInt n -> HSmallInt n | A3Int n -> HInt n | A3True -> HTrue | A3False -> HFalse | A3NaN -> HNaN | A3Pop -> HPop | A3Dup -> HDup | A3Swap -> HSwap | A3String i -> HString (ident ctx i) | A3IntRef i -> HIntRef (get ctx.as3.as3_ints i) | A3UIntRef i -> HUIntRef (get ctx.as3.as3_uints i) | A3Float f -> HFloat (get ctx.as3.as3_floats f) | A3Scope -> HScope | A3Namespace n -> HNamespace ctx.namespaces.(idx n) | A3Next (r1,r2) -> HNext (r1,r2) | A3Function f -> HFunction (method_type ctx f) | A3CallStack n -> HCallStack n | A3Construct n -> HConstruct n | A3CallMethod (s,n) -> HCallMethod (s,n) | A3CallStatic (m,n) -> HCallStatic (ctx.methods.(idx m),n) | A3CallSuper (p,n) -> HCallSuper (name ctx p,n) | A3CallProperty (p,n) -> HCallProperty (name ctx p,n) | A3RetVoid -> HRetVoid | A3Ret -> HRet | A3ConstructSuper n -> HConstructSuper n | A3ConstructProperty (p,n) -> HConstructProperty (name ctx p,n) | A3CallPropLex (p,n) -> HCallPropLex (name ctx p,n) | A3CallSuperVoid (p,n) -> HCallSuperVoid (name ctx p,n) | A3CallPropVoid (p,n) -> HCallPropVoid (name ctx p,n) | A3ApplyType n -> HApplyType n | A3Object n -> HObject n | A3Array n -> HArray n | A3NewBlock -> HNewBlock | A3ClassDef n -> HClassDef (getclass ctx n) | A3GetDescendants p -> HGetDescendants (name ctx p) | A3Catch n -> HCatch n | A3FindPropStrict p -> HFindPropStrict (name ctx p) | A3FindProp p -> HFindProp (name ctx p) | A3FindDefinition p -> HFindDefinition (name ctx p) | A3GetLex p -> HGetLex (name ctx p) | A3SetProp p -> HSetProp (name ctx p) | A3Reg r -> HReg r | A3SetReg r -> HSetReg r | A3GetGlobalScope -> HGetGlobalScope | A3GetScope n -> HGetScope n | A3GetProp p -> HGetProp (name ctx p) | A3InitProp p -> HInitProp (name ctx p) | A3DeleteProp p -> HDeleteProp (name ctx p) | A3GetSlot n -> HGetSlot n | A3SetSlot n -> HSetSlot n | A3ToString -> HToString | A3ToXml -> HToXml | A3ToXmlAttr -> HToXmlAttr | A3ToInt -> HToInt | A3ToUInt -> HToUInt | A3ToNumber -> HToNumber | A3ToBool -> HToBool | A3ToObject -> HToObject | A3CheckIsXml -> HCheckIsXml | A3Cast p -> HCast (name ctx p) | A3AsAny -> HAsAny | A3AsString -> HAsString | A3AsType p -> HAsType (name ctx p) | A3AsObject -> HAsObject | A3IncrReg r -> HIncrReg r | A3DecrReg r -> HDecrReg r | A3Typeof -> HTypeof | A3InstanceOf -> HInstanceOf | A3IsType p -> HIsType (name ctx p) | A3IncrIReg r -> HIncrIReg r | A3DecrIReg r -> HDecrIReg r | A3This -> HThis | A3SetThis -> HSetThis | A3DebugReg (id,r,n) -> HDebugReg (ident ctx id,r,n) | A3DebugLine n -> HDebugLine n | A3DebugFile p -> HDebugFile (ident ctx p) | A3BreakPointLine n -> HBreakPointLine n | A3Timestamp -> HTimestamp | A3Op op -> HOp op | A3Unk n -> HUnk n let parse_code ctx f trys = let code = f.fun3_code in let old = ctx.pos , ctx.jumps in let indexes = MultiArray.create() in ctx.pos <- 0; ctx.jumps <- []; let codepos pos delta = let id = (try MultiArray.get indexes (pos + delta) with _ -> -1) in if id = -1 then begin (*Printf.eprintf "MISALIGNED JUMP AT %d %c %d IN #%d\n" pos (if delta < 0 then '-' else '+') (if delta < 0 then -delta else delta) (idx (no_nz f.fun3_id));*) MultiArray.get indexes pos; (* jump 0 *) end else id in let hcode = MultiArray.mapi (fun i op -> let len = As3code.length op in MultiArray.add indexes i; for k = 2 to len do MultiArray.add indexes (-1); done; ctx.pos <- ctx.pos + len; parse_opcode ctx i op ) code in (* in case we have a dead-jump at the end of code *) MultiArray.add indexes (MultiArray.length code); (* patch jumps *) List.iter (fun (j,pos) -> MultiArray.set hcode j (match MultiArray.get hcode j with | HJump (jc,n) -> HJump (jc,codepos pos n - j) | HSwitch (n,infos) -> HSwitch (codepos pos n - j, List.map (fun n -> codepos pos n - j) infos) | _ -> assert false) ) ctx.jumps; (* patch try/catches *) Array.iteri (fun i t -> Array.set trys i { hltc_start = codepos 0 t.hltc_start; hltc_end = codepos 0 t.hltc_end; hltc_handle = codepos 0 t.hltc_handle; hltc_type = t.hltc_type; hltc_name = t.hltc_name; } ) trys; ctx.pos <- fst old; ctx.jumps <- snd old; hcode let parse_metadata ctx m = { hlmeta_name = ident ctx m.meta3_name; hlmeta_data = Array.map (fun (i1,i2) -> opt ident ctx i1, ident ctx i2) m.meta3_data; } let parse_method ctx m = { hlm_type = method_type ctx m.m3_type; hlm_final = m.m3_final; hlm_override = m.m3_override; hlm_kind = m.m3_kind; } let parse_value ctx = function | A3VNone -> HVNone | A3VNull -> HVNull | A3VBool b -> HVBool b | A3VString s -> HVString (ident ctx s) | A3VInt i -> HVInt (get ctx.as3.as3_ints i) | A3VUInt i -> HVUInt (get ctx.as3.as3_uints i) | A3VFloat f -> HVFloat (get ctx.as3.as3_floats f) | A3VNamespace (n,ns) -> HVNamespace (n,ctx.namespaces.(idx ns)) let parse_var ctx v = { hlv_type = opt name ctx v.v3_type; hlv_value = parse_value ctx v.v3_value; hlv_const = v.v3_const; } let parse_field_kind ctx = function | A3FMethod m -> HFMethod (parse_method ctx m) | A3FVar v -> HFVar (parse_var ctx v) | A3FFunction f -> HFFunction (method_type ctx f) | A3FClass c -> HFClass (getclass ctx c) let parse_field ctx f = { hlf_name = name ctx f.f3_name; hlf_slot = f.f3_slot; hlf_kind = parse_field_kind ctx f.f3_kind; hlf_metas = match f.f3_metas with | None -> None | Some a -> Some (Array.map (fun i -> parse_metadata ctx (get ctx.as3.as3_metadatas (no_nz i)) ) a); } let parse_static ctx s = { hls_method = method_type ctx s.st3_method; hls_fields = Array.map (parse_field ctx) s.st3_fields; } let parse_namespace ctx = function | A3NPrivate id -> HNPrivate (opt ident ctx id) | A3NPublic id -> HNPublic (opt ident ctx id) | A3NInternal id -> HNInternal (opt ident ctx id) | A3NProtected id -> HNProtected (ident ctx id) | A3NNamespace id -> HNNamespace (ident ctx id) | A3NExplicit id -> HNExplicit (ident ctx id) | A3NStaticProtected id -> HNStaticProtected (opt ident ctx id) let parse_nset ctx l = List.map (fun n -> ctx.namespaces.(idx n)) l let rec parse_name names ctx = function | A3MName (id,ns) -> (match ctx.namespaces.(idx ns) with | HNPublic p -> let pack = (match p with None -> [] | Some i -> ExtString.String.nsplit i ".") in HMPath (pack, ident ctx id) | ns -> HMName (ident ctx id, ns)) | A3MNSAny (id) -> HMNSAny(ident ctx id) | A3MAny -> HMAny | A3MMultiName (id,ns) -> HMMultiName (opt ident ctx id,ctx.nsets.(idx ns)) | A3MRuntimeName id -> HMRuntimeName (ident ctx id) | A3MRuntimeNameLate -> HMRuntimeNameLate | A3MMultiNameLate ns -> HMMultiNameLate ctx.nsets.(idx ns) | A3MAttrib multi -> HMAttrib (parse_name names ctx multi) | A3MParams (id,pl) -> HMParams (parse_name names ctx names.(idx id),List.map (fun id -> parse_name names ctx names.(idx id)) pl) let parse_try_catch ctx t = { hltc_start = t.tc3_start; hltc_end = t.tc3_end; hltc_handle = t.tc3_handle; hltc_type = opt name ctx t.tc3_type; hltc_name = opt name ctx t.tc3_name; } let parse_function ctx f = { hlf_stack_size = f.fun3_stack_size; hlf_nregs = f.fun3_nregs; hlf_init_scope = f.fun3_init_scope; hlf_max_scope = f.fun3_max_scope; hlf_code = MultiArray.create(); (* keep for later *) hlf_trys = Array.map (parse_try_catch ctx) f.fun3_trys; hlf_locals = Array.map (fun f -> if f.f3_metas <> None then assert false; match f.f3_kind with | A3FVar v -> (* v3_value can be <> None if it's a fun parameter with a default value - which looks like a bug of the AS3 compiler *) name ctx f.f3_name , opt name ctx v.v3_type , f.f3_slot, v.v3_const | _ -> assert false ) f.fun3_locals; } let parse_method_type ctx idx f = let m = ctx.as3.as3_method_types.(idx) in { hlmt_index = idx + ctx.delta_mt; hlmt_ret = opt name ctx m.mt3_ret; hlmt_args = List.map (opt name ctx) m.mt3_args; hlmt_native = m.mt3_native; hlmt_var_args = m.mt3_var_args; hlmt_arguments_defined = m.mt3_arguments_defined; hlmt_uses_dxns = m.mt3_uses_dxns; hlmt_new_block = m.mt3_new_block; hlmt_unused_flag = m.mt3_unused_flag; hlmt_debug_name = opt ident ctx m.mt3_debug_name; hlmt_dparams = opt (fun ctx -> List.map (parse_value ctx)) ctx m.mt3_dparams; hlmt_pnames = opt (fun ctx -> List.map (opt ident ctx)) ctx m.mt3_pnames; hlmt_function = opt parse_function ctx f; } let parse_class ctx c s index = { hlc_index = index + ctx.delta_cl; hlc_name = name ctx c.cl3_name; hlc_super = opt name ctx c.cl3_super; hlc_sealed = c.cl3_sealed; hlc_final = c.cl3_final; hlc_interface = c.cl3_interface; hlc_namespace = opt (fun ctx i -> ctx.namespaces.(idx i)) ctx c.cl3_namespace; hlc_implements = Array.map (name ctx) c.cl3_implements; hlc_construct = method_type ctx c.cl3_construct; hlc_fields = Array.map (parse_field ctx) c.cl3_fields; hlc_static_construct = method_type ctx s.st3_method; hlc_static_fields = Array.map (parse_field ctx) s.st3_fields; } let parse_static ctx s = { hls_method = method_type ctx s.st3_method; hls_fields = Array.map (parse_field ctx) s.st3_fields; } let parse ?(delta_mt=0) ?(delta_cl=0) t = let ctx = { as3 = t; namespaces = [||]; nsets = [||]; names = [||]; methods = [||]; classes = [||]; jumps = []; pos = 0; delta_mt = delta_mt; delta_cl = delta_cl; } in ctx.namespaces <- Array.map (parse_namespace ctx) t.as3_namespaces; ctx.nsets <- Array.map (parse_nset ctx) t.as3_nsets; ctx.names <- Array.map (parse_name t.as3_names ctx) t.as3_names; let hfunctions = Hashtbl.create 0 in Array.iter (fun f -> Hashtbl.add hfunctions (idx (no_nz f.fun3_id)) f) t.as3_functions; ctx.methods <- Array.mapi (fun i m -> parse_method_type ctx i (try Some (Hashtbl.find hfunctions i) with Not_found -> None); ) t.as3_method_types; ctx.classes <- Array.mapi (fun i c -> parse_class ctx c t.as3_statics.(i) i ) t.as3_classes; let inits = List.map (parse_static ctx) (Array.to_list t.as3_inits) in Array.iter (fun f -> match (method_type ctx f.fun3_id).hlmt_function with | None -> assert false | Some fl -> fl.hlf_code <- parse_code ctx f fl.hlf_trys ) t.as3_functions; inits (* ************************************************************************ *) (* FLATTEN *) (* ************************************************************************ *) type ('hl,'item) lookup = { h : ('hl,int) Hashtbl.t; a : 'item DynArray.t; f : flatten_ctx -> 'hl -> 'item; } and ('hl,'item) index_lookup = { ordered_list : 'hl list; ordered_array : 'item option DynArray.t; map_f : flatten_ctx -> 'hl -> 'item; } and flatten_ctx = { fints : (hl_int,as3_int) lookup; fuints : (hl_uint,as3_uint) lookup; ffloats : (hl_float,as3_float) lookup; fidents : (hl_ident,as3_ident) lookup; fnamespaces : (hl_namespace,as3_namespace) lookup; fnsets : (hl_ns_set,as3_ns_set) lookup; fnames : (hl_name,as3_multi_name) lookup; fmetas : (hl_metadata,as3_metadata) lookup; fmethods : (hl_method,as3_method_type) index_lookup; fclasses : (hl_class,as3_class * as3_static) index_lookup; mutable ffunctions : as3_function list; mutable fjumps : int list; } let new_lookup f = { h = Hashtbl.create 0; a = DynArray.create(); f = f; } let new_index_lookup l f = { ordered_list = l; ordered_array = DynArray.init (List.length l) (fun _ -> None); map_f = f; } let lookup_array l = DynArray.to_array l.a let lookup_index_array l = Array.map (function None -> assert false | Some x -> x) (DynArray.to_array l.ordered_array) let lookup ctx (l:('a,'b) lookup) item : 'b index = let idx = try Hashtbl.find l.h item with Not_found -> let idx = DynArray.length l.a in (* set dummy value for recursion *) DynArray.add l.a (Obj.magic 0); Hashtbl.add l.h item (idx + 1); DynArray.set l.a idx (l.f ctx item); idx + 1 in As3parse.magic_index idx let lookup_index_nz ctx (l:('a,'b) index_lookup) item : 'c index_nz = let rec loop n = function | [] -> assert false | x :: l -> if x == item then n else loop (n + 1) l in let idx = loop 0 l.ordered_list in if DynArray.get l.ordered_array idx = None then begin (* set dummy value for recursion *) DynArray.set l.ordered_array idx (Some (Obj.magic 0)); DynArray.set l.ordered_array idx (Some (l.map_f ctx item)); end; As3parse.magic_index_nz idx let lookup_nz ctx l item = As3parse.magic_index_nz (As3parse.index_int (lookup ctx l item) - 1) let lookup_ident ctx i = lookup ctx ctx.fidents i let lookup_name ctx n = lookup ctx ctx.fnames n let lookup_method ctx m : as3_method_type index_nz = lookup_index_nz ctx ctx.fmethods m let lookup_class ctx c : as3_class index_nz = lookup_index_nz ctx ctx.fclasses c let flatten_namespace ctx = function | HNPrivate i -> A3NPrivate (opt lookup_ident ctx i) | HNPublic i -> A3NPublic (opt lookup_ident ctx i) | HNInternal i -> A3NInternal (opt lookup_ident ctx i) | HNProtected i -> A3NProtected (lookup_ident ctx i) | HNNamespace i -> A3NNamespace (lookup_ident ctx i) | HNExplicit i -> A3NExplicit (lookup_ident ctx i) | HNStaticProtected i -> A3NStaticProtected (opt lookup_ident ctx i) let flatten_ns_set ctx n = List.map (lookup ctx ctx.fnamespaces) n let rec flatten_name ctx = function | HMPath (pack,i) -> let ns = HNPublic (match pack with [] -> None | l -> Some (String.concat "." l)) in A3MName (lookup_ident ctx i,lookup ctx ctx.fnamespaces ns) | HMName (i,n) -> A3MName (lookup_ident ctx i,lookup ctx ctx.fnamespaces n) | HMNSAny (i) -> A3MNSAny (lookup_ident ctx i) | HMAny -> A3MAny | HMMultiName (i,ns) -> A3MMultiName (opt lookup_ident ctx i,lookup ctx ctx.fnsets ns) | HMRuntimeName i -> A3MRuntimeName (lookup_ident ctx i) | HMRuntimeNameLate -> A3MRuntimeNameLate | HMMultiNameLate ns -> A3MMultiNameLate (lookup ctx ctx.fnsets ns) | HMAttrib n -> A3MAttrib (flatten_name ctx n) | HMParams (i,nl) -> A3MParams (lookup_name ctx i,List.map (lookup_name ctx) nl) let flatten_meta ctx m = { meta3_name = lookup_ident ctx m.hlmeta_name; meta3_data = Array.map (fun (i,i2) -> opt lookup_ident ctx i, lookup_ident ctx i2) m.hlmeta_data; } let flatten_value ctx = function | HVNone -> A3VNone | HVNull -> A3VNull | HVBool b -> A3VBool b | HVString s -> A3VString (lookup_ident ctx s) | HVInt i -> A3VInt (lookup ctx ctx.fints i) | HVUInt i -> A3VUInt (lookup ctx ctx.fuints i) | HVFloat f -> A3VFloat (lookup ctx ctx.ffloats f) | HVNamespace (n,ns) -> A3VNamespace (n,lookup ctx ctx.fnamespaces ns) let flatten_field ctx f = { f3_name = lookup_name ctx f.hlf_name; f3_slot = f.hlf_slot; f3_kind = (match f.hlf_kind with | HFMethod m -> A3FMethod { m3_type = lookup_method ctx m.hlm_type; m3_final = m.hlm_final; m3_override = m.hlm_override; m3_kind = m.hlm_kind; } | HFVar v -> A3FVar { v3_type = opt lookup_name ctx v.hlv_type; v3_value = flatten_value ctx v.hlv_value; v3_const = v.hlv_const; } | HFFunction f -> A3FFunction (lookup_method ctx f) | HFClass c -> A3FClass (lookup_class ctx c) ); f3_metas = opt (fun ctx -> Array.map (fun m -> lookup_nz ctx ctx.fmetas m)) ctx f.hlf_metas; } let flatten_class ctx c = { cl3_name = lookup_name ctx c.hlc_name; cl3_super = opt lookup_name ctx c.hlc_super; cl3_sealed = c.hlc_sealed; cl3_final = c.hlc_final; cl3_interface = c.hlc_interface; cl3_namespace = opt (fun ctx -> lookup ctx ctx.fnamespaces) ctx c.hlc_namespace; cl3_implements = Array.map (lookup_name ctx) c.hlc_implements; cl3_construct = lookup_method ctx c.hlc_construct; cl3_fields = Array.map (flatten_field ctx) c.hlc_fields; }, { st3_method = lookup_method ctx c.hlc_static_construct; st3_fields = Array.map (flatten_field ctx) c.hlc_static_fields; } let flatten_opcode ctx i = function | HBreakPoint -> A3BreakPoint | HNop -> A3Nop | HThrow -> A3Throw | HGetSuper n -> A3GetSuper (lookup_name ctx n) | HSetSuper n -> A3SetSuper (lookup_name ctx n) | HDxNs s -> A3DxNs (lookup_ident ctx s) | HDxNsLate -> A3DxNsLate | HRegKill r -> A3RegKill r | HLabel -> A3Label | HJump (j,n) -> ctx.fjumps <- i :: ctx.fjumps; A3Jump (j,n) | HSwitch (n,l) -> ctx.fjumps <- i :: ctx.fjumps; A3Switch (n,l) | HPushWith -> A3PushWith | HPopScope -> A3PopScope | HForIn -> A3ForIn | HHasNext -> A3HasNext | HNull -> A3Null | HUndefined -> A3Undefined | HForEach -> A3ForEach | HSmallInt n -> A3SmallInt n | HInt n -> A3Int n | HTrue -> A3True | HFalse -> A3False | HNaN -> A3NaN | HPop -> A3Pop | HDup -> A3Dup | HSwap -> A3Swap | HString s -> A3String (lookup_ident ctx s) | HIntRef i -> A3IntRef (lookup ctx ctx.fints i) | HUIntRef i -> A3UIntRef (lookup ctx ctx.fuints i) | HFloat f -> A3Float (lookup ctx ctx.ffloats f) | HScope -> A3Scope | HNamespace n -> A3Namespace (lookup ctx ctx.fnamespaces n) | HNext (r1,r2) -> A3Next (r1,r2) | HFunction m -> A3Function (lookup_method ctx m) | HCallStack n -> A3CallStack n | HConstruct n -> A3Construct n | HCallMethod (s,n) -> A3CallMethod (s,n) | HCallStatic (m,n) -> A3CallStatic (no_nz (lookup_method ctx m),n) | HCallSuper (i,n) -> A3CallSuper (lookup_name ctx i,n) | HCallProperty (i,n) -> A3CallProperty (lookup_name ctx i,n) | HRetVoid -> A3RetVoid | HRet -> A3Ret | HConstructSuper n -> A3ConstructSuper n | HConstructProperty (i,n) -> A3ConstructProperty (lookup_name ctx i,n) | HCallPropLex (i,n) -> A3CallPropLex (lookup_name ctx i,n) | HCallSuperVoid (i,n) -> A3CallSuperVoid (lookup_name ctx i,n) | HCallPropVoid (i,n)-> A3CallPropVoid (lookup_name ctx i,n) | HApplyType n -> A3ApplyType n | HObject n -> A3Object n | HArray n -> A3Array n | HNewBlock -> A3NewBlock | HClassDef c -> A3ClassDef (As3parse.magic_index_nz (As3parse.index_nz_int (lookup_class ctx c))) | HGetDescendants i -> A3GetDescendants (lookup_name ctx i) | HCatch n -> A3Catch n | HFindPropStrict i -> A3FindPropStrict (lookup_name ctx i) | HFindProp i -> A3FindProp (lookup_name ctx i) | HFindDefinition i -> A3FindDefinition (lookup_name ctx i) | HGetLex i -> A3GetLex (lookup_name ctx i) | HSetProp i -> A3SetProp (lookup_name ctx i) | HReg r -> A3Reg r | HSetReg r -> A3SetReg r | HGetGlobalScope -> A3GetGlobalScope | HGetScope n -> A3GetScope n | HGetProp n -> A3GetProp (lookup_name ctx n) | HInitProp n -> A3InitProp (lookup_name ctx n) | HDeleteProp n -> A3DeleteProp (lookup_name ctx n) | HGetSlot s -> A3GetSlot s | HSetSlot s -> A3SetSlot s | HToString -> A3ToString | HToXml -> A3ToXml | HToXmlAttr -> A3ToXmlAttr | HToInt -> A3ToInt | HToUInt -> A3ToUInt | HToNumber -> A3ToNumber | HToBool -> A3ToBool | HToObject -> A3ToObject | HCheckIsXml -> A3CheckIsXml | HCast n -> A3Cast (lookup_name ctx n) | HAsAny -> A3AsAny | HAsString -> A3AsString | HAsType n -> A3AsType (lookup_name ctx n) | HAsObject -> A3AsObject | HIncrReg r -> A3IncrReg r | HDecrReg r -> A3DecrReg r | HTypeof -> A3Typeof | HInstanceOf -> A3InstanceOf | HIsType t -> A3IsType (lookup_name ctx t) | HIncrIReg r -> A3IncrIReg r | HDecrIReg r -> A3DecrIReg r | HThis -> A3This | HSetThis -> A3SetThis | HDebugReg (i,r,l) -> A3DebugReg (lookup_ident ctx i,r,l) | HDebugLine l -> A3DebugLine l | HDebugFile f -> A3DebugFile (lookup_ident ctx f) | HBreakPointLine n -> A3BreakPointLine n | HTimestamp -> A3Timestamp | HOp op -> A3Op op | HUnk c -> A3Unk c let flatten_code ctx hcode trys = let positions = MultiArray.make (MultiArray.length hcode + 1) 0 in let pos = ref 0 in let old = ctx.fjumps in ctx.fjumps <- []; let code = MultiArray.mapi (fun i op -> let op = flatten_opcode ctx i op in pos := !pos + As3code.length op; MultiArray.set positions (i + 1) !pos; op ) hcode in (* patch jumps *) List.iter (fun j -> MultiArray.set code j (match MultiArray.get code j with | A3Jump (jc,n) -> A3Jump (jc,MultiArray.get positions (j+n) - MultiArray.get positions (j+1)) | A3Switch (n,infos) -> A3Switch (MultiArray.get positions (j+n) - MultiArray.get positions (j),List.map (fun n -> MultiArray.get positions (j+n) - MultiArray.get positions (j)) infos) | _ -> assert false); ) ctx.fjumps; (* patch trys *) let trys = Array.mapi (fun i t -> { tc3_start = MultiArray.get positions t.hltc_start; tc3_end = MultiArray.get positions t.hltc_end; tc3_handle = MultiArray.get positions t.hltc_handle; tc3_type = opt lookup_name ctx t.hltc_type; tc3_name = opt lookup_name ctx t.hltc_name; } ) trys in ctx.fjumps <- old; code, trys let flatten_function ctx f mid = let code, trys = flatten_code ctx f.hlf_code f.hlf_trys in { fun3_id = mid; fun3_stack_size = f.hlf_stack_size; fun3_nregs = f.hlf_nregs; fun3_init_scope = f.hlf_init_scope; fun3_max_scope = f.hlf_max_scope; fun3_code = code; fun3_trys = trys; fun3_locals = Array.map (fun (n,t,s,c) -> { f3_name = lookup_name ctx n; f3_slot = s; f3_kind = A3FVar { v3_type = opt lookup_name ctx t; v3_value = A3VNone; v3_const = c }; f3_metas = None; } ) f.hlf_locals; } let flatten_method ctx m = let mid = lookup_method ctx m in (match m.hlmt_function with | None -> () | Some f -> ctx.ffunctions <- flatten_function ctx f mid :: ctx.ffunctions); { mt3_ret = opt lookup_name ctx m.hlmt_ret; mt3_args = List.map (opt lookup_name ctx) m.hlmt_args; mt3_native = m.hlmt_native; mt3_var_args = m.hlmt_var_args; mt3_arguments_defined = m.hlmt_arguments_defined; mt3_uses_dxns = m.hlmt_uses_dxns; mt3_new_block = m.hlmt_new_block; mt3_unused_flag = m.hlmt_unused_flag; mt3_debug_name = opt lookup_ident ctx m.hlmt_debug_name; mt3_dparams = opt (fun ctx -> List.map (flatten_value ctx)) ctx m.hlmt_dparams; mt3_pnames = opt (fun ctx -> List.map (opt lookup_ident ctx)) ctx m.hlmt_pnames; } let flatten_static ctx s = { st3_method = lookup_method ctx s.hls_method; st3_fields = Array.map (flatten_field ctx) s.hls_fields; } let rec browse_method ctx m = let ml, _ = ctx in if not (List.memq m !ml) then begin ml := m :: !ml; match m.hlmt_function with | None -> () | Some f -> MultiArray.iter (function | HFunction f | HCallStatic (f,_) -> browse_method ctx f | HClassDef _ -> () (* ignore, should be in fields list anyway *) | _ -> () ) f.hlf_code end and browse_class ctx c = let _, cl = ctx in if not (List.memq c !cl) then begin cl := c :: !cl; browse_method ctx c.hlc_construct; browse_method ctx c.hlc_static_construct; Array.iter (browse_field ctx) c.hlc_fields; Array.iter (browse_field ctx) c.hlc_static_fields; end and browse_field ctx f = match f.hlf_kind with | HFMethod m -> browse_method ctx m.hlm_type | HFVar _ -> () | HFFunction m -> browse_method ctx m | HFClass c -> browse_class ctx c let flatten t = let id _ x = x in (* collect methods and classes, sort by index and force evaluation in order to keep order *) let methods = ref [] in let classes = ref [] in let ctx = (methods,classes) in List.iter (fun s -> Array.iter (browse_field ctx) s.hls_fields; browse_method ctx s.hls_method; ) t; let methods = List.sort (fun m1 m2 -> m1.hlmt_index - m2.hlmt_index) (List.rev !methods) in (* done *) let rec ctx = { fints = new_lookup id; fuints = new_lookup id; ffloats = new_lookup id; fidents = new_lookup id; fnamespaces = new_lookup flatten_namespace; fnsets = new_lookup flatten_ns_set; fnames = new_lookup flatten_name; fmetas = new_lookup flatten_meta; fmethods = new_index_lookup methods flatten_method; fclasses = new_index_lookup (List.rev !classes) flatten_class; fjumps = []; ffunctions = []; } in ignore(lookup_ident ctx ""); let inits = List.map (flatten_static ctx) t in let classes = lookup_index_array ctx.fclasses in { as3_ints = lookup_array ctx.fints; as3_uints = lookup_array ctx.fuints; as3_floats = lookup_array ctx.ffloats; as3_idents = lookup_array ctx.fidents; as3_namespaces = lookup_array ctx.fnamespaces; as3_nsets = lookup_array ctx.fnsets; as3_names = lookup_array ctx.fnames; as3_metadatas = lookup_array ctx.fmetas; as3_method_types = lookup_index_array ctx.fmethods; as3_classes = Array.map fst classes; as3_statics = Array.map snd classes; as3_functions = Array.of_list (List.rev ctx.ffunctions); as3_inits = Array.of_list inits; as3_unknown = ""; } haxe-3.0~svn6707/libs/swflib/swfPic.ml0000644000175000017500000001333612172015137020215 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2005 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Png open Swf open ExtList type error_msg = | PngError of Png.error_msg | Interlaced | UnsupportedColorModel | UnsupportedExtension | UnzipFailed exception Error of error_msg exception File_not_found of string type picture = { pwidth : int; pheight : int; pid : int; pdata : tag_data; pframe : string option; } let error_msg = function | PngError m -> Png.error_msg m | Interlaced -> "Interlaced mode is not supported" | UnsupportedColorModel -> "Unsupported color model" | UnsupportedExtension -> "Unsupported file extension" | UnzipFailed -> "Decompression failed" let error msg = raise (Error msg) let unsigned v n = if v < 0 then (- ( v + 1 )) lxor (1 lsl n - 1) else v let load_picture file id = let ch = IO.input_channel (try open_in_bin file with _ -> raise (File_not_found file)) in let len = String.length file in let p = (try String.rindex file '.' with Not_found -> len) in let ext = String.sub file (p + 1) (len - (p + 1)) in match String.uppercase ext with | "PNG" -> let png , header, data = (try let p = Png.parse ch in p , Png.header p, Png.data p with Png.Error msg -> IO.close_in ch; error (PngError msg) ) in IO.close_in ch; if header.png_interlace then error Interlaced; let data = (try Extc.unzip data with _ -> error UnzipFailed) in let w = header.png_width in let h = header.png_height in let data = (try Png.filter png data with Png.Error msg -> error (PngError msg)) in { pwidth = w; pheight = h; pid = id; pframe = None; pdata = (match header.png_color with | ClTrueColor (TBits8,NoAlpha) -> (* set alpha to 0 *) for p = 0 to w * h - 1 do String.unsafe_set data (p * 4) '\000'; done; TBitsLossless { bll_id = id; bll_format = 5; bll_width = w; bll_height = h; bll_data = Extc.zip data; } | ClTrueColor (TBits8,HaveAlpha) -> (* premultiply rgb by alpha *) for p = 0 to w * h - 1 do let k = p * 4 in let a = int_of_char (String.unsafe_get data k) in String.unsafe_set data (k + 1) (Char.unsafe_chr ((int_of_char (String.unsafe_get data (k + 1)) * a) / 0xFF)); String.unsafe_set data (k + 2) (Char.unsafe_chr ((int_of_char (String.unsafe_get data (k + 2)) * a) / 0xFF)); String.unsafe_set data (k + 3) (Char.unsafe_chr ((int_of_char (String.unsafe_get data (k + 3)) * a) / 0xFF)); done; TBitsLossless2 { bll_id = id; bll_format = 5; bll_width = w; bll_height = h; bll_data = Extc.zip data; } | _ -> error UnsupportedColorModel); } | _ -> IO.close_in ch; error UnsupportedExtension let make_clip name pics baseid = let npics = List.length pics in let ids = Array.of_list (List.map (fun p -> p.pid) pics) in let rec loop i p = let w = p.pwidth in let h = p.pheight in let rb = if 20 * max w h >= 1 lsl 14 then 15 else 14 in let nbits = rb in TShape { sh_id = baseid + i; sh_bounds = { rect_nbits = rb; left = 0; top = 0; right = w * 20; bottom = h * 20; }; sh_bounds2 = None; sh_style = { sws_fill_styles = [ SFSBitmap { sfb_repeat = true; sfb_smooth = true; sfb_cid = ids.(i); sfb_mpos = { scale = Some { m_nbits = 22; mx = 20 lsl 16; my = 20 lsl 16; }; rotate = None; trans = { m_nbits = 0; mx = 0; my = 0; }; }; }; ]; sws_line_styles = []; sws_records = { srs_nlbits = 0; srs_nfbits = 1; srs_records = [ SRStyleChange { scsr_move = None; scsr_fs0 = None; scsr_fs1 = Some 1; scsr_ls = None; scsr_new_styles = None; }; SRStraightEdge { sser_nbits = nbits; sser_line = Some (w * 20) , None; }; SRStraightEdge { sser_nbits = nbits; sser_line = None , Some (h * 20); }; SRStraightEdge { sser_nbits = nbits; sser_line = Some (unsigned (-w * 20) nbits), None; }; SRStraightEdge { sser_nbits = nbits; sser_line = None , Some (unsigned (-h * 20) nbits); }; ]; }; }; } in let shapes = List.mapi loop pics in let rec loop i = if i = npics then [] else TPlaceObject2 { po_depth = 0; po_move = (i > 0); po_cid = Some (baseid+i); po_color = None; po_matrix = None; po_ratio = None; po_inst_name = None; po_clip_depth = None; po_events = None; po_filters = None; po_blend = None; po_bcache = None; } :: TShowFrame :: loop (i+1) in let tid = ref 0 in let make_tag t = incr tid; { tid = - !tid; textended = false; tdata = t; } in let pics = List.map (fun p -> make_tag p.pdata) pics in let shapes = List.map make_tag shapes in pics @ shapes @ List.map make_tag [ TClip { c_id = baseid + npics; c_frame_count = npics; c_tags = List.map make_tag (loop 0); }; TExport [{ exp_id = baseid + npics; exp_name = name; }]; ] haxe-3.0~svn6707/libs/swflib/LICENSE0000644000175000017500000004313112172015137017431 0ustar bdefreesebdefreese GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. haxe-3.0~svn6707/libs/swflib/as3parse.ml0000644000175000017500000010244212172015137020500 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2004-2006 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open As3 let parse_idents = true let parse_namespaces = true && parse_idents let parse_ns_sets = true && parse_namespaces let parse_names = true && parse_ns_sets let parse_mtypes = true && parse_names let parse_metadata = true && parse_mtypes let parse_classes = true && parse_metadata let parse_statics = true && parse_classes let parse_inits = true && parse_statics let parse_functions = true && parse_inits let parse_bytecode = true && parse_functions let magic_index (i : int) : 'a index = Obj.magic i let magic_index_nz (i : int) : 'a index_nz = Obj.magic i let index (t : 'a array) (i : int) : 'a index = if i <= 0 || i - 1 >= Array.length t then assert false; magic_index i let index_opt t i = if i = 0 then None else Some (index t i) let index_nz (t : 'a array) (i : int) : 'a index_nz = if i < 0 || i >= Array.length t then assert false; Obj.magic i let index_int (i : 'a index) = (Obj.magic i : int) let index_nz_int (i : 'a index_nz) = (Obj.magic i : int) let iget (t : 'a array) (i : 'a index) : 'a = t.(index_int i - 1) let no_nz (i : 'a index_nz) : 'a index = Obj.magic ((Obj.magic i) + 1) (* ************************************************************************ *) (* LENGTH *) let as3_empty_index ctx = let empty_index = ref 0 in try Array.iteri (fun i x -> if x = "" then begin empty_index := (i + 1); raise Exit; end) ctx.as3_idents; if parse_idents then assert false; magic_index 0 with Exit -> index ctx.as3_idents (!empty_index) let as3_int_length i = if Int32.compare (Int32.shift_right_logical i 28) 0l > 0 then 5 else if Int32.compare (Int32.shift_right i 21) 0l > 0 then 4 else if Int32.compare (Int32.shift_right i 14) 0l > 0 then 3 else if Int32.compare (Int32.shift_right i 7) 0l > 0 then 2 else 1 let as3_uint_length i = as3_int_length i let sum f l = List.fold_left (fun acc n -> acc + f n) 0 l let int_length i = as3_int_length (Int32.of_int i) let idx_length i = int_length (index_int i) let idx_length_nz i = int_length (index_nz_int i) let idx_opt_length = function | None -> int_length 0 | Some i -> idx_length i let as3_ident_length s = let n = String.length s in n + int_length n let as3_namespace_length ei = function | A3NStaticProtected o | A3NPrivate o -> 1 + (match o with None -> int_length 0 | Some n -> idx_length n) | A3NPublic o | A3NInternal o -> 1 + idx_length (match o with None -> ei | Some n -> n) | A3NExplicit n | A3NNamespace n | A3NProtected n -> 1 + idx_length n let as3_ns_set_length l = int_length (List.length l) + sum idx_length l let rec as3_name_length t = 1 + match t with | A3MMultiName (id,r) -> idx_opt_length id + idx_length r | A3MName (id,r) -> idx_length r + idx_length id | A3MNSAny (id) -> int_length 0 + idx_length id | A3MAny -> int_length 0 + int_length 0 | A3MRuntimeName i -> idx_length i | A3MRuntimeNameLate -> 0 | A3MMultiNameLate idx -> idx_length idx | A3MAttrib n -> as3_name_length n - 1 | A3MParams (id,pl) -> idx_length id + 1 + (sum idx_length pl) let as3_value_length extra = function | A3VNone -> if extra then 2 else 1 | A3VNull | A3VBool _ -> 2 | A3VString s -> 1 + idx_length s | A3VInt s -> 1 + idx_length s | A3VUInt s -> 1 + idx_length s | A3VFloat s -> 1 + idx_length s | A3VNamespace (_,s) -> 1 + idx_length s let as3_method_type_length m = 1 + idx_opt_length m.mt3_ret + sum idx_opt_length m.mt3_args + idx_opt_length m.mt3_debug_name + 1 + (match m.mt3_dparams with None -> 0 | Some l -> 1 + sum (as3_value_length true) l) + (match m.mt3_pnames with None -> 0 | Some l -> sum idx_opt_length l) let list_length f l = match Array.length l with | 0 -> int_length 0 | n -> Array.fold_left (fun acc x -> acc + f x) (int_length (n + 1)) l let list2_length f l = Array.fold_left (fun acc x -> acc + f x) (int_length (Array.length l)) l let as3_field_length f = idx_length f.f3_name + 1 + int_length f.f3_slot + (match f.f3_kind with | A3FMethod m -> idx_length_nz m.m3_type | A3FClass c -> idx_length_nz c | A3FFunction id -> idx_length_nz id | A3FVar v -> idx_opt_length v.v3_type + as3_value_length false v.v3_value) + match f.f3_metas with | None -> 0 | Some l -> list2_length idx_length_nz l let as3_class_length c = idx_length c.cl3_name + idx_opt_length c.cl3_super + 1 + (match c.cl3_namespace with None -> 0 | Some r -> idx_length r) + list2_length idx_length c.cl3_implements + idx_length_nz c.cl3_construct + list2_length as3_field_length c.cl3_fields let as3_static_length s = idx_length_nz s.st3_method + list2_length as3_field_length s.st3_fields let as3_metadata_length m = idx_length m.meta3_name + list2_length (fun (i1,i2) -> idx_opt_length i1 + idx_length i2) m.meta3_data let as3_try_catch_length t = int_length t.tc3_start + int_length t.tc3_end + int_length t.tc3_handle + idx_opt_length t.tc3_type + idx_opt_length t.tc3_name let as3_function_length f = let clen = MultiArray.fold_left (fun acc op -> acc + As3code.length op) 0 f.fun3_code in idx_length_nz f.fun3_id + int_length f.fun3_stack_size + int_length f.fun3_nregs + int_length f.fun3_init_scope + int_length f.fun3_max_scope + int_length clen + clen + list2_length as3_try_catch_length f.fun3_trys + list2_length as3_field_length f.fun3_locals let as3_length ctx = let ei = as3_empty_index ctx in String.length ctx.as3_unknown + 4 + list_length as3_int_length ctx.as3_ints + list_length as3_uint_length ctx.as3_uints + list_length (fun _ -> 8) ctx.as3_floats + if parse_idents then list_length as3_ident_length ctx.as3_idents + if parse_namespaces then list_length (as3_namespace_length ei) ctx.as3_namespaces + if parse_ns_sets then list_length as3_ns_set_length ctx.as3_nsets + if parse_names then list_length as3_name_length ctx.as3_names + if parse_mtypes then list2_length as3_method_type_length ctx.as3_method_types + if parse_metadata then list2_length as3_metadata_length ctx.as3_metadatas + if parse_classes then list2_length as3_class_length ctx.as3_classes + if parse_statics then Array.fold_left (fun acc x -> acc + as3_static_length x) 0 ctx.as3_statics + if parse_inits then list2_length as3_static_length ctx.as3_inits + if parse_functions then list2_length as3_function_length ctx.as3_functions else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0 (* ************************************************************************ *) (* PARSING *) let read_as3_int ch = let a = IO.read_byte ch in if a < 128 then Int32.of_int a else let a = a land 127 in let b = IO.read_byte ch in if b < 128 then Int32.of_int ((b lsl 7) lor a) else let b = b land 127 in let c = IO.read_byte ch in if c < 128 then Int32.of_int ((c lsl 14) lor (b lsl 7) lor a) else let c = c land 127 in let d = IO.read_byte ch in if d < 128 then Int32.of_int ((d lsl 21) lor (c lsl 14) lor (b lsl 7) lor a) else let d = d land 127 in let e = IO.read_byte ch in if e > 15 then assert false; let small = Int32.of_int ((d lsl 21) lor (c lsl 14) lor (b lsl 7) lor a) in let big = Int32.shift_left (Int32.of_int e) 28 in Int32.logor big small let read_as3_uint ch = read_as3_int ch let read_int ch = Int32.to_int (read_as3_int ch) let read_ident ch = IO.nread ch (read_int ch) let read_namespace idents ch = let k = IO.read_byte ch in let p = index_opt idents (read_int ch) in match k with | 0x05 -> A3NPrivate p | 0x08 -> (match p with | None -> assert false | Some idx -> A3NNamespace idx) | 0x16 -> (match p with | None -> assert false | Some p when iget idents p = "" -> A3NPublic None | _ -> A3NPublic p) | 0x17 -> (match p with | None -> assert false | Some p when iget idents p = "" -> A3NInternal None | _ -> A3NInternal p) | 0x18 -> (match p with | None -> assert false | Some idx -> A3NProtected idx) | 0x19 -> (match p with | None -> assert false | Some idx -> A3NExplicit idx) | 0x1A -> A3NStaticProtected p | _ -> assert false let read_ns_set namespaces ch = let rec loop n = if n = 0 then [] else let r = index namespaces (read_int ch) in r :: loop (n - 1) in loop (IO.read_byte ch) let rec read_name ctx ?k ch = let k = (match k with None -> IO.read_byte ch | Some k -> k) in match k with | 0x07 -> let i = read_int ch in let j = read_int ch in if i = 0 && j = 0 then A3MAny else if i = 0 && j <> 0 then let id = index ctx.as3_idents j in A3MNSAny(id) else let ns = index ctx.as3_namespaces i in let id = index ctx.as3_idents j in (* both ns and id can be 0 <=> '*' *) A3MName (id,ns) | 0x09 -> let id = index_opt ctx.as3_idents (read_int ch) in let ns = index ctx.as3_nsets (read_int ch) in A3MMultiName (id,ns) | 0x0D -> A3MAttrib (read_name ctx ~k:0x07 ch) | 0x0E -> A3MAttrib (read_name ctx ~k:0x09 ch) | 0x0F -> let id = index ctx.as3_idents (read_int ch) in A3MRuntimeName id | 0x10 -> A3MAttrib (read_name ctx ~k:0x0F ch) | 0x11 -> A3MRuntimeNameLate | 0x12 -> A3MAttrib (read_name ctx ~k:0x11 ch) | 0x1B -> let ns = index ctx.as3_nsets (read_int ch) in A3MMultiNameLate ns | 0x1C -> A3MAttrib (read_name ctx ~k:0x1B ch) | 0x1D -> let rec loop n = if n = 0 then [] else let name = magic_index (read_int ch) in name :: loop (n - 1) in let id = magic_index (read_int ch) in A3MParams (id,loop (IO.read_byte ch)) | n -> prerr_endline (string_of_int n); assert false let read_value ctx ch extra = let idx = read_int ch in if idx = 0 then begin if extra && IO.read_byte ch <> 0 then assert false; A3VNone end else match IO.read_byte ch with | 0x01 -> A3VString (index ctx.as3_idents idx) | 0x03 -> A3VInt (index ctx.as3_ints idx) | 0x04 -> A3VUInt (index ctx.as3_uints idx) | 0x06 -> A3VFloat (index ctx.as3_floats idx) | 0x08 | 0x16 | 0x17 | 0x18 | 0x19 | 0x1A | 0x05 as n-> A3VNamespace (n,index ctx.as3_namespaces idx) | 0x0A -> if idx <> 0x0A then assert false; A3VBool false | 0x0B -> if idx <> 0x0B then assert false; A3VBool true | 0x0C -> if idx <> 0x0C then assert false; A3VNull | _ -> assert false let read_method_type ctx ch = let nargs = IO.read_byte ch in let tret = index_opt ctx.as3_names (read_int ch) in let targs = Array.to_list (Array.init nargs (fun _ -> index_opt ctx.as3_names (read_int ch))) in let dname = index_opt ctx.as3_idents (read_int ch) in let flags = IO.read_byte ch in let dparams = (if flags land 0x08 <> 0 then Some (Array.to_list (Array.init (IO.read_byte ch) (fun _ -> read_value ctx ch true))) else None ) in let pnames = (if flags land 0x80 <> 0 then Some (Array.to_list (Array.init nargs (fun _ -> index_opt ctx.as3_idents (read_int ch)))) else None ) in { mt3_ret = tret; mt3_args = targs; mt3_var_args = flags land 0x04 <> 0; mt3_native = flags land 0x20 <> 0; mt3_new_block = flags land 0x02 <> 0; mt3_debug_name = dname; mt3_dparams = dparams; mt3_pnames = pnames; mt3_arguments_defined = flags land 0x01 <> 0; mt3_uses_dxns = flags land 0x40 <> 0; mt3_unused_flag = flags land 0x10 <> 0; } let read_list ch f = match read_int ch with | 0 -> [||] | n -> Array.init (n - 1) (fun _ -> f ch) let read_list2 ch f = Array.init (read_int ch) (fun _ -> f ch) let read_field ctx ch = let name = index ctx.as3_names (read_int ch) in let kind = IO.read_byte ch in let has_meta = kind land 0x40 <> 0 in let slot = read_int ch in let kind = (match kind land 0xF with | 0x00 | 0x06 -> let t = index_opt ctx.as3_names (read_int ch) in let value = read_value ctx ch false in A3FVar { v3_type = t; v3_value = value; v3_const = kind = 0x06; } | 0x02 | 0x03 | 0x01 -> let meth = index_nz ctx.as3_method_types (read_int ch) in let final = kind land 0x10 <> 0 in let override = kind land 0x20 <> 0 in A3FMethod { m3_type = meth; m3_final = final; m3_override = override; m3_kind = (match kind land 0xF with 0x01 -> MK3Normal | 0x02 -> MK3Getter | 0x03 -> MK3Setter | _ -> assert false); } | 0x04 -> let c = index_nz ctx.as3_classes (read_int ch) in A3FClass c | 0x05 -> let f = index_nz ctx.as3_method_types (read_int ch) in A3FFunction f | _ -> assert false ) in let metas = (if has_meta then Some (read_list2 ch (fun _ -> index_nz ctx.as3_metadatas (read_int ch))) else None ) in { f3_name = name; f3_slot = slot; f3_kind = kind; f3_metas = metas; } let read_class ctx ch = let name = index ctx.as3_names (read_int ch) in let csuper = index_opt ctx.as3_names (read_int ch) in let flags = IO.read_byte ch in let namespace = if flags land 8 <> 0 then let r = index ctx.as3_namespaces (read_int ch) in Some r else None in let impls = read_list2 ch (fun _ -> index ctx.as3_names (read_int ch)) in let construct = index_nz ctx.as3_method_types (read_int ch) in let fields = read_list2 ch (read_field ctx) in { cl3_name = name; cl3_super = csuper; cl3_sealed = (flags land 1) <> 0; cl3_final = (flags land 2) <> 0; cl3_interface = (flags land 4) <> 0; cl3_namespace = namespace; cl3_implements = impls; cl3_construct = construct; cl3_fields = fields; } let read_static ctx ch = let meth = index_nz ctx.as3_method_types (read_int ch) in let fields = read_list2 ch (read_field ctx) in { st3_method = meth; st3_fields = fields; } let read_metadata ctx ch = let name = index ctx.as3_idents (read_int ch) in let data = read_list2 ch (fun _ -> index_opt ctx.as3_idents (read_int ch)) in let data = Array.map (fun i1 -> i1 , index ctx.as3_idents (read_int ch)) data in { meta3_name = name; meta3_data = data; } let read_try_catch ctx ch = let start = read_int ch in let pend = read_int ch in let handle = read_int ch in let t = index_opt ctx.as3_names (read_int ch) in let name = index_opt ctx.as3_names (read_int ch) in { tc3_start = start; tc3_end = pend; tc3_handle = handle; tc3_type = t; tc3_name = name; } let read_function ctx ch = let id = index_nz ctx.as3_method_types (read_int ch) in let ss = read_int ch in let nregs = read_int ch in let init_scope = read_int ch in let max_scope = read_int ch in let size = read_int ch in let code = if parse_bytecode then As3code.parse ch size else MultiArray.init size (fun _ -> A3Unk (IO.read ch)) in let trys = read_list2 ch (read_try_catch ctx) in let local_funs = read_list2 ch (read_field ctx) in { fun3_id = id; fun3_stack_size = ss; fun3_nregs = nregs; fun3_init_scope = init_scope; fun3_max_scope = max_scope; fun3_code = code; fun3_trys = trys; fun3_locals = local_funs; } let header_magic = 0x002E0010 let parse ch len = let ch, get_pos = IO.pos_in ch in if IO.read_i32 ch <> header_magic then assert false; let ints = read_list ch read_as3_int in let uints = read_list ch read_as3_uint in let floats = read_list ch IO.read_double in let idents = (if parse_idents then read_list ch read_ident else [||]) in let idents = (if parse_idents then begin if ExtArray.Array.exists (fun i -> i="") idents then idents else Array.append idents [|""|] end else [||]) in let namespaces = (if parse_namespaces then read_list ch (read_namespace idents) else [||]) in let nsets = (if parse_ns_sets then read_list ch (read_ns_set namespaces) else [||]) in let ctx = { as3_ints = ints; as3_uints = uints; as3_floats = floats; as3_idents = idents; as3_namespaces = namespaces; as3_nsets = nsets; as3_names = [||]; as3_method_types = [||]; as3_metadatas = [||]; as3_classes = [||]; as3_statics = [||]; as3_inits = [||]; as3_functions = [||]; as3_unknown = ""; } in if parse_names then ctx.as3_names <- read_list ch (read_name ctx); if parse_mtypes then ctx.as3_method_types <- read_list2 ch (read_method_type ctx); if parse_metadata then ctx.as3_metadatas <- read_list2 ch (read_metadata ctx); if parse_classes then ctx.as3_classes <- read_list2 ch (read_class ctx); if parse_statics then ctx.as3_statics <- Array.map (fun _ -> read_static ctx ch) ctx.as3_classes; if parse_inits then ctx.as3_inits <- read_list2 ch (read_static ctx); if parse_functions then ctx.as3_functions <- read_list2 ch (read_function ctx); ctx.as3_unknown <- IO.really_nread ch (len - (get_pos())); if parse_functions && String.length ctx.as3_unknown <> 0 then assert false; (* let len2 = as3_length ctx in if len2 <> len then begin Printf.printf "%d != %d" len len2; assert false; end; *) ctx (* ************************************************************************ *) (* WRITING *) let write_as3_int ch i = let e = Int32.to_int (Int32.shift_right_logical i 28) in let d = Int32.to_int (Int32.shift_right i 21) land 0x7F in let c = Int32.to_int (Int32.shift_right i 14) land 0x7F in let b = Int32.to_int (Int32.shift_right i 7) land 0x7F in let a = Int32.to_int (Int32.logand i 0x7Fl) in if b <> 0 || c <> 0 || d <> 0 || e <> 0 then begin IO.write_byte ch (a lor 0x80); if c <> 0 || d <> 0 || e <> 0 then begin IO.write_byte ch (b lor 0x80); if d <> 0 || e <> 0 then begin IO.write_byte ch (c lor 0x80); if e <> 0 then begin IO.write_byte ch (d lor 0x80); IO.write_byte ch e; end else IO.write_byte ch d; end else IO.write_byte ch c; end else IO.write_byte ch b; end else IO.write_byte ch a let write_as3_uint = write_as3_int let write_int ch i = write_as3_int ch (Int32.of_int i) let write_index ch n = write_int ch (index_int n) let write_index_nz ch n = write_int ch (index_nz_int n) let write_index_opt ch = function | None -> write_int ch 0 | Some n -> write_index ch n let write_as3_ident ch id = write_int ch (String.length id); IO.nwrite ch id let write_namespace empty_index ch = function | A3NPrivate n -> IO.write_byte ch 0x05; (match n with | None -> write_int ch 0 | Some n -> write_index ch n); | A3NPublic n -> IO.write_byte ch 0x16; (match n with | None -> write_index ch empty_index | Some n -> write_index ch n); | A3NInternal n -> IO.write_byte ch 0x17; (match n with | None -> write_index ch empty_index | Some n -> write_index ch n); | A3NProtected n -> IO.write_byte ch 0x18; write_index ch n | A3NNamespace n -> IO.write_byte ch 0x08; write_index ch n | A3NExplicit n -> IO.write_byte ch 0x19; write_index ch n | A3NStaticProtected n -> IO.write_byte ch 0x1A; (match n with | None -> write_int ch 0 | Some n -> write_index ch n) let write_rights ch l = IO.write_byte ch (List.length l); List.iter (write_index ch) l let rec write_name ch ?k x = let b n = match k with None -> n | Some v -> v in match x with | A3MMultiName (id,r) -> IO.write_byte ch (b 0x09); write_index_opt ch id; write_index ch r; | A3MName (id,r) -> IO.write_byte ch (b 0x07); write_index ch r; write_index ch id | A3MNSAny(id) -> IO.write_byte ch (b 0x07); write_int ch 0; write_index ch id; | A3MAny -> IO.write_byte ch (b 0x07); write_int ch 0; write_int ch 0; | A3MRuntimeName i -> IO.write_byte ch (b 0x0F); write_index ch i | A3MRuntimeNameLate -> IO.write_byte ch (b 0x11); | A3MMultiNameLate id -> IO.write_byte ch (b 0x1B); write_index ch id | A3MAttrib n -> write_name ch ~k:(match n with | A3MName _ | A3MNSAny _ | A3MAny -> 0x0D | A3MMultiName _ -> 0x0E | A3MRuntimeName _ -> 0x10 | A3MRuntimeNameLate -> 0x12 | A3MMultiNameLate _ -> 0x1C | A3MAttrib _ | A3MParams _ -> assert false ) n | A3MParams (id,pl) -> IO.write_byte ch (b 0x1D); write_index ch id; IO.write_byte ch (List.length pl); List.iter (write_index ch) pl let write_value ch extra v = match v with | A3VNone -> IO.write_byte ch 0x00; if extra then IO.write_byte ch 0x00; | A3VNull -> IO.write_byte ch 0x0C; IO.write_byte ch 0x0C; | A3VBool b -> IO.write_byte ch (if b then 0x0B else 0x0A); IO.write_byte ch (if b then 0x0B else 0x0A); | A3VString s -> write_index ch s; IO.write_byte ch 0x01; | A3VInt s -> write_index ch s; IO.write_byte ch 0x03; | A3VUInt s -> write_index ch s; IO.write_byte ch 0x04; | A3VFloat s -> write_index ch s; IO.write_byte ch 0x06 | A3VNamespace (n,s) -> write_index ch s; IO.write_byte ch n let write_method_type ch m = let nargs = List.length m.mt3_args in IO.write_byte ch nargs; write_index_opt ch m.mt3_ret; List.iter (write_index_opt ch) m.mt3_args; write_index_opt ch m.mt3_debug_name; let flags = (if m.mt3_arguments_defined then 0x01 else 0) lor (if m.mt3_new_block then 0x02 else 0) lor (if m.mt3_var_args then 0x04 else 0) lor (if m.mt3_dparams <> None then 0x08 else 0) lor (if m.mt3_unused_flag then 0x10 else 0) lor (if m.mt3_native then 0x20 else 0) lor (if m.mt3_uses_dxns then 0x40 else 0) lor (if m.mt3_pnames <> None then 0x80 else 0) in IO.write_byte ch flags; (match m.mt3_dparams with | None -> () | Some l -> IO.write_byte ch (List.length l); List.iter (write_value ch true) l); match m.mt3_pnames with | None -> () | Some l -> if List.length l <> nargs then assert false; List.iter (write_index_opt ch) l let write_list ch f l = match Array.length l with | 0 -> IO.write_byte ch 0 | n -> write_int ch (n + 1); Array.iter (f ch) l let write_list2 ch f l = write_int ch (Array.length l); Array.iter (f ch) l let write_field ch f = write_index ch f.f3_name; let flags = (if f.f3_metas <> None then 0x40 else 0) in (match f.f3_kind with | A3FMethod m -> let base = (match m.m3_kind with MK3Normal -> 0x01 | MK3Getter -> 0x02 | MK3Setter -> 0x03) in let flags = flags lor (if m.m3_final then 0x10 else 0) lor (if m.m3_override then 0x20 else 0) in IO.write_byte ch (base lor flags); write_int ch f.f3_slot; write_index_nz ch m.m3_type; | A3FClass c -> IO.write_byte ch (0x04 lor flags); write_int ch f.f3_slot; write_index_nz ch c | A3FFunction i -> IO.write_byte ch (0x05 lor flags); write_int ch f.f3_slot; write_index_nz ch i | A3FVar v -> IO.write_byte ch (flags lor (if v.v3_const then 0x06 else 0x00)); write_int ch f.f3_slot; write_index_opt ch v.v3_type; write_value ch false v.v3_value); match f.f3_metas with | None -> () | Some l -> write_list2 ch write_index_nz l let write_class ch c = write_index ch c.cl3_name; write_index_opt ch c.cl3_super; let flags = (if c.cl3_sealed then 1 else 0) lor (if c.cl3_final then 2 else 0) lor (if c.cl3_interface then 4 else 0) lor (if c.cl3_namespace <> None then 8 else 0) in IO.write_byte ch flags; (match c.cl3_namespace with | None -> () | Some r -> write_index ch r); write_list2 ch write_index c.cl3_implements; write_index_nz ch c.cl3_construct; write_list2 ch write_field c.cl3_fields let write_static ch s = write_index_nz ch s.st3_method; write_list2 ch write_field s.st3_fields let write_metadata ch m = write_index ch m.meta3_name; write_list2 ch (fun _ (i1,_) -> write_index_opt ch i1) m.meta3_data; Array.iter (fun (_,i2) -> write_index ch i2) m.meta3_data let write_try_catch ch t = write_int ch t.tc3_start; write_int ch t.tc3_end; write_int ch t.tc3_handle; write_index_opt ch t.tc3_type; write_index_opt ch t.tc3_name let write_function ch f = write_index_nz ch f.fun3_id; write_int ch f.fun3_stack_size; write_int ch f.fun3_nregs; write_int ch f.fun3_init_scope; write_int ch f.fun3_max_scope; let clen = MultiArray.fold_left (fun acc op -> acc + As3code.length op) 0 f.fun3_code in write_int ch clen; MultiArray.iter (As3code.write ch) f.fun3_code; write_list2 ch write_try_catch f.fun3_trys; write_list2 ch write_field f.fun3_locals let write ch1 ctx = let ch = IO.output_strings() in let empty_index = as3_empty_index ctx in IO.write_i32 ch header_magic; write_list ch write_as3_int ctx.as3_ints; write_list ch write_as3_uint ctx.as3_uints; write_list ch IO.write_double ctx.as3_floats; if parse_idents then write_list ch write_as3_ident ctx.as3_idents; if parse_namespaces then write_list ch (write_namespace empty_index) ctx.as3_namespaces; if parse_ns_sets then write_list ch write_rights ctx.as3_nsets; if parse_names then write_list ch (write_name ?k:None) ctx.as3_names; if parse_mtypes then write_list2 ch write_method_type ctx.as3_method_types; if parse_metadata then write_list2 ch write_metadata ctx.as3_metadatas; if parse_classes then write_list2 ch write_class ctx.as3_classes; if parse_statics then Array.iter (write_static ch) ctx.as3_statics; if parse_inits then write_list2 ch write_static ctx.as3_inits; if parse_functions then write_list2 ch write_function ctx.as3_functions; IO.nwrite ch ctx.as3_unknown; let str = IO.close_out ch in List.iter (IO.nwrite ch1) str (* ************************************************************************ *) (* DUMP *) let dump_code_size = ref true let ident_str ctx i = iget ctx.as3_idents i let namespace_str ctx i = match iget ctx.as3_namespaces i with | A3NPrivate None -> "private" | A3NPrivate (Some n) -> "private:" ^ ident_str ctx n | A3NPublic None -> "public" | A3NPublic (Some n) -> "public:" ^ ident_str ctx n | A3NInternal None -> "internal" | A3NInternal (Some n) -> "internal:" ^ ident_str ctx n | A3NProtected n -> "protected:" ^ ident_str ctx n | A3NExplicit n -> "explicit:" ^ ident_str ctx n | A3NStaticProtected None -> "static_protected" | A3NStaticProtected (Some n) -> "static_protectec:" ^ ident_str ctx n | A3NNamespace n -> "namespace:" ^ ident_str ctx n let ns_set_str ctx i = let l = iget ctx.as3_nsets i in String.concat " " (List.map (fun r -> namespace_str ctx r) l) let rec name_str ctx kind t = let rec loop = function | A3MName (id,r) -> Printf.sprintf "%s %s%s" (namespace_str ctx r) kind (ident_str ctx id) | A3MNSAny (id) -> Printf.sprintf "%s %s%s" "ANY" kind (ident_str ctx id) | A3MAny -> "ANY" | A3MMultiName (id,r) -> Printf.sprintf "[%s %s%s]" (ns_set_str ctx r) kind (match id with None -> "NO" | Some i -> ident_str ctx i) | A3MRuntimeName id -> Printf.sprintf "'%s'" (ident_str ctx id) | A3MRuntimeNameLate -> "RTLATE" | A3MMultiNameLate id -> Printf.sprintf "late:(%s)" (ns_set_str ctx id) | A3MAttrib n -> "attrib " ^ loop n | A3MParams (id,pl) -> Printf.sprintf "%s<%s>" (name_str ctx kind id) (String.concat "," (List.map (name_str ctx kind) pl)) in loop (iget ctx.as3_names t) let value_str ctx v = match v with | A3VNone -> "" | A3VNull -> "null" | A3VString s -> "\"" ^ ident_str ctx s ^ "\"" | A3VBool b -> if b then "true" else "false" | A3VInt s -> Printf.sprintf "%ld" (iget ctx.as3_ints s) | A3VUInt s -> Printf.sprintf "%ld" (iget ctx.as3_uints s) | A3VFloat s -> Printf.sprintf "%f" (iget ctx.as3_floats s) | A3VNamespace (_,s) -> "ns::" ^ namespace_str ctx s let metadata_str ctx i = let m = iget ctx.as3_metadatas i in let data = List.map (fun (i1,i2) -> Printf.sprintf "%s=\"%s\"" (match i1 with None -> "NO" | Some i -> ident_str ctx i) (ident_str ctx i2)) (Array.to_list m.meta3_data) in Printf.sprintf "%s(%s)" (ident_str ctx m.meta3_name) (String.concat ", " data) let method_str ?(infos=false) ctx m = let m = iget ctx.as3_method_types m in let pcount = ref 0 in Printf.sprintf "%s(%s%s)%s" (if m.mt3_native then " native " else "") (String.concat ", " (List.map (fun a -> let id = (match m.mt3_pnames with | None -> "p" ^ string_of_int !pcount | Some l -> match List.nth l !pcount with | None -> "p" ^ string_of_int !pcount | Some i -> ident_str ctx i ) in let p = (match a with None -> id | Some t -> name_str ctx (id ^ " : ") t) in let p = (match m.mt3_dparams with | None -> p | Some l -> let vargs = List.length m.mt3_args - List.length l in if !pcount >= vargs then let v = List.nth l (!pcount - vargs) in p ^ " = " ^ value_str ctx v else p ) in incr pcount; p ) m.mt3_args)) (if m.mt3_var_args then " ..." else "") (match m.mt3_ret with None -> "" | Some t -> " : " ^ name_str ctx "" t) ^ (if infos then begin let name = (match m.mt3_debug_name with None -> "" | Some idx -> Printf.sprintf " '%s'" (ident_str ctx idx)) in Printf.sprintf "%s blk:%b args:%b dxns:%b%s" name m.mt3_new_block m.mt3_arguments_defined m.mt3_uses_dxns (if m.mt3_unused_flag then " SPECIAL-FLAG" else "") end else "") let dump_field ctx ch stat f = (* (match f.f3_metas with | None -> () | Some l -> Array.iter (fun i -> IO.printf ch " [%s]\n" (metadata_str ctx (no_nz i))) l); *) IO.printf ch " "; if stat then IO.printf ch "static "; (match f.f3_kind with | A3FVar v -> IO.printf ch "%s" (name_str ctx (if v.v3_const then "const " else "var ") f.f3_name); (match v.v3_type with | None -> () | Some id -> IO.printf ch " : %s" (name_str ctx "" id)); if v.v3_value <> A3VNone then IO.printf ch " = %s" (value_str ctx v.v3_value); | A3FClass c -> let c = iget ctx.as3_classes (no_nz c) in IO.printf ch "%s = %s" (name_str ctx "CLASS " c.cl3_name) (name_str ctx "class " f.f3_name); | A3FFunction id -> IO.printf ch "%s = %s" (method_str ~infos:false ctx (no_nz id)) (name_str ctx "method " f.f3_name); | A3FMethod m -> if m.m3_final then IO.printf ch "final "; if m.m3_override then IO.printf ch "override "; let k = "function " ^ (match m.m3_kind with | MK3Normal -> "" | MK3Getter -> "get " | MK3Setter -> "set " ) in IO.printf ch "%s%s #%d" (name_str ctx k f.f3_name) (method_str ctx (no_nz m.m3_type)) (index_nz_int m.m3_type); ); if f.f3_slot <> 0 then IO.printf ch " = [SLOT:%d]" f.f3_slot; IO.printf ch ";\n" let dump_class ctx ch idx c = let st = if parse_statics then ctx.as3_statics.(idx) else { st3_method = magic_index_nz (-1); st3_fields = [||] } in if not c.cl3_sealed then IO.printf ch "dynamic "; if c.cl3_final then IO.printf ch "final "; (match c.cl3_namespace with | None -> () | Some r -> IO.printf ch "%s " (namespace_str ctx r)); let kind = (if c.cl3_interface then "interface " else "class ") in IO.printf ch "%s " (name_str ctx kind c.cl3_name); (match c.cl3_super with | None -> () | Some s -> IO.printf ch "extends %s " (name_str ctx "" s)); (match Array.to_list c.cl3_implements with | [] -> () | l -> IO.printf ch "implements %s " (String.concat ", " (List.map (fun i -> name_str ctx "" i) l))); IO.printf ch "{\n"; Array.iter (dump_field ctx ch false) c.cl3_fields; Array.iter (dump_field ctx ch true) st.st3_fields; IO.printf ch "} constructor#%d statics#%d\n\n" (index_nz_int c.cl3_construct) (index_nz_int st.st3_method) let dump_init ctx ch idx s = IO.printf ch "init #%d {\n" (index_nz_int s.st3_method); Array.iter (dump_field ctx ch false) s.st3_fields; IO.printf ch "}\n\n" let dump_try_catch ctx ch t = IO.printf ch " try %d %d %d (%s) (%s)\n" t.tc3_start t.tc3_end t.tc3_handle (match t.tc3_type with None -> "*" | Some idx -> name_str ctx "" idx) (match t.tc3_name with None -> "NO" | Some idx -> name_str ctx "" idx) let dump_function ctx ch idx f = IO.printf ch "function #%d %s\n" (index_nz_int f.fun3_id) (method_str ~infos:true ctx (no_nz f.fun3_id)); IO.printf ch " stack:%d nregs:%d scope:%d-%d\n" f.fun3_stack_size f.fun3_nregs f.fun3_init_scope f.fun3_max_scope; Array.iter (dump_field ctx ch false) f.fun3_locals; Array.iter (dump_try_catch ctx ch) f.fun3_trys; let pos = ref 0 in MultiArray.iter (fun op -> IO.printf ch "%4d %s\n" !pos (As3code.dump ctx op); if !dump_code_size then pos := !pos + As3code.length op else incr pos; ) f.fun3_code; IO.printf ch "\n" let dump_ident ctx ch idx _ = IO.printf ch "I%d = %s\n" (idx + 1) (ident_str ctx (index ctx.as3_idents (idx + 1))) let dump_namespace ctx ch idx _ = IO.printf ch "N%d = %s\n" (idx + 1) (namespace_str ctx (index ctx.as3_namespaces (idx + 1))) let dump_ns_set ctx ch idx _ = IO.printf ch "S%d = %s\n" (idx + 1) (ns_set_str ctx (index ctx.as3_nsets (idx + 1))) let dump_name ctx ch idx _ = IO.printf ch "T%d = %s\n" (idx + 1) (name_str ctx "" (index ctx.as3_names (idx + 1))) let dump_method_type ctx ch idx _ = IO.printf ch "M%d = %s\n" (idx + 1) (method_str ~infos:true ctx (index ctx.as3_method_types (idx + 1))) let dump_metadata ctx ch idx _ = IO.printf ch "D%d = %s\n" (idx + 1) (metadata_str ctx (index ctx.as3_metadatas (idx + 1))) let dump_int ctx ch idx i = IO.printf ch "INT %d = 0x%lX\n" (idx + 1) i let dump_float ctx ch idx f = IO.printf ch "FLOAT %d = %f\n" (idx + 1) f let dump ch ctx id = (match id with | None -> IO.printf ch "\n---------------- AS3 -------------------------\n\n"; | Some (id,f) -> IO.printf ch "\n---------------- AS3 %s [%d] -----------------\n\n" f id); (* Array.iteri (dump_int ctx ch) ctx.as3_ints; Array.iteri (dump_float ctx ch) ctx.as3_floats; Array.iteri (dump_ident ctx ch) ctx.as3_idents; IO.printf ch "\n"; Array.iteri (dump_namespace ctx ch) ctx.as3_namespaces; IO.printf ch "\n"; Array.iteri (dump_ns_set ctx ch) ctx.as3_nsets; IO.printf ch "\n"; Array.iteri (dump_name ctx ch) ctx.as3_names; IO.printf ch "\n"; *) (* Array.iteri (dump_metadata ctx ch) ctx.as3_metadatas; *) Array.iteri (dump_class ctx ch) ctx.as3_classes; Array.iteri (dump_init ctx ch) ctx.as3_inits; Array.iteri (dump_function ctx ch) ctx.as3_functions; IO.printf ch "\n" ;; As3code.f_int_length := int_length; As3code.f_int_read := read_int; As3code.f_int_write := write_int; haxe-3.0~svn6707/libs/swflib/png.ml0000644000175000017500000002422312172015137017543 0ustar bdefreesebdefreese(* * PNG File Format Library * Copyright (c)2005 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type grey_bits = | GBits1 | GBits2 | GBits4 | GBits8 | GBits16 type grey_alpha_bits = | GABits8 | GABits16 type true_bits = | TBits8 | TBits16 type index_bits = | IBits1 | IBits2 | IBits4 | IBits8 type alpha = | NoAlpha | HaveAlpha type color = | ClGreyScale of grey_bits | ClGreyAlpha of grey_alpha_bits | ClTrueColor of true_bits * alpha | ClIndexed of index_bits type header = { png_width : int; png_height : int; png_color : color; png_interlace : bool; } type chunk_id = string type chunk = | CEnd | CHeader of header | CData of string | CPalette of string | CUnknown of chunk_id * string type png = chunk list type error_msg = | Invalid_header | Invalid_file | Truncated_file | Invalid_CRC | Invalid_colors | Unsupported_colors | Invalid_datasize | Invalid_filter of int | Invalid_array exception Error of error_msg let error_msg = function | Invalid_header -> "Invalid header" | Invalid_file -> "Invalid file" | Truncated_file -> "Truncated file" | Invalid_CRC -> "Invalid CRC" | Invalid_colors -> "Invalid color model" | Unsupported_colors -> "Unsupported color model" | Invalid_datasize -> "Invalid data size" | Invalid_filter f -> "Invalid filter " ^ string_of_int f | Invalid_array -> "Invalid array" let error msg = raise (Error msg) let is_upper c = ((int_of_char c) land 32) <> 0 let is_critical id = is_upper id.[0] let is_public id = is_upper id.[1] let is_reseverd id = is_upper id.[2] let is_safe_to_copy id = is_upper id.[3] let is_id_char c = (c >= '\065' && c <= '\090') || (c >= '\097' && c <= '\122') let rec header = function | [] -> error Invalid_file | CHeader h :: _ -> h | _ :: l -> header l let data f = let rec loop acc = function | [] -> (match List.rev acc with | [] -> error Invalid_file | l -> String.concat "" l) | CData s :: l -> loop (s :: acc) l | _ :: l -> loop acc l in loop [] f let color_bits = function | ClGreyScale g -> (match g with | GBits1 -> 1 | GBits2 -> 2 | GBits4 -> 4 | GBits8 -> 8 | GBits16 -> 16) | ClGreyAlpha g -> (match g with | GABits8 -> 8 | GABits16 -> 16) | ClTrueColor (t,_) -> (match t with | TBits8 -> 8 | TBits16 -> 16) | ClIndexed i -> (match i with | IBits1 -> 1 | IBits2 -> 2 | IBits4 -> 4 | IBits8 -> 8) let crc_table = Array.init 256 (fun n -> let c = ref (Int32.of_int n) in for k = 0 to 7 do if Int32.logand !c 1l <> 0l then c := Int32.logxor 0xEDB88320l (Int32.shift_right_logical !c 1) else c := (Int32.shift_right_logical !c 1); done; !c) let input_crc ch = let crc = ref 0xFFFFFFFFl in let update c = let c = Int32.of_int (int_of_char c) in let k = Array.unsafe_get crc_table (Int32.to_int (Int32.logand (Int32.logxor !crc c) 0xFFl)) in crc := Int32.logxor k (Int32.shift_right_logical !crc 8) in let ch2 = IO.create_in ~read:(fun () -> let c = IO.read ch in update c; c ) ~input:(fun s p l -> let l = IO.input ch s p l in for i = 0 to l - 1 do update s.[p+i] done; l ) ~close:(fun () -> IO.close_in ch ) in ch2 , (fun () -> Int32.logxor !crc 0xFFFFFFFFl) let output_crc ch = let crc = ref 0xFFFFFFFFl in let update c = let c = Int32.of_int (int_of_char c) in let k = Array.unsafe_get crc_table (Int32.to_int (Int32.logand (Int32.logxor !crc c) 0xFFl)) in crc := Int32.logxor k (Int32.shift_right_logical !crc 8) in let ch2 = IO.create_out ~write:(fun c -> IO.write ch c; update c; ) ~output:(fun s p l -> let l = IO.output ch s p l in for i = 0 to l - 1 do update s.[p+i] done; l ) ~flush:(fun () -> IO.flush ch ) ~close:(fun () -> IO.close_out ch ) in ch2 , (fun () -> Int32.logxor !crc 0xFFFFFFFFl) let parse_header ch = let width = IO.BigEndian.read_i32 ch in let height = IO.BigEndian.read_i32 ch in if width < 0 || height < 0 then error Invalid_header; let bits = IO.read_byte ch in let color = IO.read_byte ch in let color = (match color with | 0 -> ClGreyScale (match bits with 1 -> GBits1 | 2 -> GBits2 | 4 -> GBits4 | 8 -> GBits8 | 16 -> GBits16 | _ -> error Invalid_colors) | 2 -> ClTrueColor ((match bits with 8 -> TBits8 | 16 -> TBits16 | _ -> error Invalid_colors) , NoAlpha) | 3 -> ClIndexed (match bits with 1 -> IBits1 | 2 -> IBits2 | 4 -> IBits4 | 8 -> IBits8 | _ -> error Invalid_colors) | 4 -> ClGreyAlpha (match bits with 8 -> GABits8 | 16 -> GABits16 | _ -> error Invalid_colors) | 6 -> ClTrueColor ((match bits with 8 -> TBits8 | 16 -> TBits16 | _ -> error Invalid_colors) , HaveAlpha) | _ -> error Invalid_colors) in let compress = IO.read_byte ch in let filter = IO.read_byte ch in if compress <> 0 || filter <> 0 then error Invalid_header; let interlace = IO.read_byte ch in let interlace = (match interlace with 0 -> false | 1 -> true | _ -> error Invalid_header) in { png_width = width; png_height = height; png_color = color; png_interlace = interlace; } let parse_chunk ch = let len = IO.BigEndian.read_i32 ch in let ch2 , crc = input_crc ch in let id = IO.nread ch2 4 in if len < 0 || not (is_id_char id.[0]) || not (is_id_char id.[1]) || not (is_id_char id.[2]) || not (is_id_char id.[3]) then error Invalid_file; let data = IO.nread ch2 len in let crc_val = IO.BigEndian.read_real_i32 ch in if crc_val <> crc() then error Invalid_CRC; match id with | "IEND" -> CEnd | "IHDR" -> CHeader (parse_header (IO.input_string data)) | "IDAT" -> CData data | "PLTE" -> CPalette data | _ -> CUnknown (id,data) let png_sign = "\137\080\078\071\013\010\026\010" let parse ch = let sign = (try IO.nread ch (String.length png_sign) with IO.No_more_input -> error Invalid_header) in if sign <> png_sign then error Invalid_header; let rec loop acc = match parse_chunk ch with | CEnd -> List.rev acc | c -> loop (c :: acc) in try loop [] with | IO.No_more_input -> error Truncated_file | IO.Overflow _ -> error Invalid_file let write_chunk ch cid cdata = IO.BigEndian.write_i32 ch (String.length cdata); let ch2 , crc = output_crc ch in IO.nwrite ch2 cid; IO.nwrite ch2 cdata; IO.BigEndian.write_real_i32 ch (crc()) let write_header real_ch h = let ch = IO.output_string() in IO.BigEndian.write_i32 ch h.png_width; IO.BigEndian.write_i32 ch h.png_height; IO.write_byte ch (color_bits h.png_color); IO.write_byte ch (match h.png_color with | ClGreyScale _ -> 0 | ClTrueColor (_,NoAlpha) -> 2 | ClIndexed _ -> 3 | ClGreyAlpha _ -> 4 | ClTrueColor (_,HaveAlpha) -> 6); IO.write_byte ch 0; IO.write_byte ch 0; IO.write_byte ch (if h.png_interlace then 1 else 0); let data = IO.close_out ch in write_chunk real_ch "IHDR" data let write ch png = IO.nwrite ch png_sign; List.iter (function | CEnd -> write_chunk ch "IEND" "" | CHeader h -> write_header ch h | CData s -> write_chunk ch "IDAT" s | CPalette s -> write_chunk ch "PLTE" s | CUnknown (id,data) -> write_chunk ch id data ) png let filter png data = let head = header png in let w = head.png_width in let h = head.png_height in match head.png_color with | ClGreyScale _ | ClGreyAlpha _ | ClIndexed _ | ClTrueColor (TBits16,_) -> error Unsupported_colors | ClTrueColor (TBits8,alpha) -> let alpha = (match alpha with NoAlpha -> false | HaveAlpha -> true) in let buf = String.create (w * h * 4) in let nbytes = if alpha then 4 else 3 in let stride = nbytes * w + 1 in if String.length data < h * stride then error Invalid_datasize; let bp = ref 0 in let get p = int_of_char (String.unsafe_get data p) in let bget p = int_of_char (String.unsafe_get buf p) in let set v = String.unsafe_set buf !bp (Char.unsafe_chr v); incr bp in let filters = [| (fun x y v -> v ); (fun x y v -> let v2 = if x = 0 then 0 else bget (!bp - 4) in v + v2 ); (fun x y v -> let v2 = if y = 0 then 0 else bget (!bp - 4*w) in v + v2 ); (fun x y v -> let v2 = if x = 0 then 0 else bget (!bp - 4) in let v3 = if y = 0 then 0 else bget (!bp - 4*w) in v + (v2 + v3) / 2 ); (fun x y v -> let a = if x = 0 then 0 else bget (!bp - 4) in let b = if y = 0 then 0 else bget (!bp - 4*w) in let c = if x = 0 || y = 0 then 0 else bget (!bp - 4 - 4*w) in let p = a + b - c in let pa = abs (p - a) in let pb = abs (p - b) in let pc = abs (p - c) in let d = (if pa <= pb && pa <= pc then a else if pb <= pc then b else c) in v + d ); |] in for y = 0 to h - 1 do let f = get (y * stride) in let f = (if f < 5 then filters.(f) else error (Invalid_filter f)) in for x = 0 to w - 1 do let p = x * nbytes + y * stride in if not alpha then begin set 255; for c = 1 to 3 do let v = get (p + c) in set (f x y v) done; end else begin let v = get (p + 4) in let a = f x y v in set a; for c = 1 to 3 do let v = get (p + c) in set (f x y v) done; end; done; done; buf let make ~width ~height ~pixel ~compress = let data = String.create (width * height * 4 + height) in let p = ref 0 in let set v = String.unsafe_set data !p (Char.unsafe_chr v); incr p in for y = 0 to height - 1 do set 0; for x = 0 to width - 1 do let c = pixel x y in let ic = Int32.to_int c in (* RGBA *) set (ic lsr 16); set (ic lsr 8); set ic; set (Int32.to_int (Int32.shift_right_logical c 24)); done; done; let data = compress data in let header = { png_width = width; png_height = height; png_color = ClTrueColor (TBits8,HaveAlpha); png_interlace = false; } in [CHeader header; CData data; CEnd] haxe-3.0~svn6707/libs/swflib/as3hl.mli0000644000175000017500000001307312172015137020143 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2004-2008 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open As3 type hl_ident = string type hl_int = int32 type hl_uint = int32 type hl_float = float type hl_slot = int type hl_jump = as3_jump type hl_op = as3_op type hl_opcode = | HBreakPoint | HNop | HThrow | HGetSuper of hl_name | HSetSuper of hl_name | HDxNs of hl_ident | HDxNsLate | HRegKill of reg | HLabel | HJump of hl_jump * int | HSwitch of int * int list | HPushWith | HPopScope | HForIn | HHasNext | HNull | HUndefined | HForEach | HSmallInt of int | HInt of int | HTrue | HFalse | HNaN | HPop | HDup | HSwap | HString of hl_ident | HIntRef of hl_int | HUIntRef of hl_uint | HFloat of hl_float | HScope | HNamespace of hl_namespace | HNext of reg * reg | HFunction of hl_method | HCallStack of nargs | HConstruct of nargs | HCallMethod of hl_slot * nargs | HCallStatic of hl_method * nargs | HCallSuper of hl_name * nargs | HCallProperty of hl_name * nargs | HRetVoid | HRet | HConstructSuper of nargs | HConstructProperty of hl_name * nargs | HCallPropLex of hl_name * nargs | HCallSuperVoid of hl_name * nargs | HCallPropVoid of hl_name * nargs | HApplyType of nargs | HObject of nargs | HArray of nargs | HNewBlock | HClassDef of hl_class | HGetDescendants of hl_name | HCatch of int | HFindPropStrict of hl_name | HFindProp of hl_name | HFindDefinition of hl_name | HGetLex of hl_name | HSetProp of hl_name | HReg of reg | HSetReg of reg | HGetGlobalScope | HGetScope of int | HGetProp of hl_name | HInitProp of hl_name | HDeleteProp of hl_name | HGetSlot of hl_slot | HSetSlot of hl_slot | HToString | HToXml | HToXmlAttr | HToInt | HToUInt | HToNumber | HToBool | HToObject | HCheckIsXml | HCast of hl_name | HAsAny | HAsString | HAsType of hl_name | HAsObject | HIncrReg of reg | HDecrReg of reg | HTypeof | HInstanceOf | HIsType of hl_name | HIncrIReg of reg | HDecrIReg of reg | HThis | HSetThis | HDebugReg of hl_ident * reg * int | HDebugLine of int | HDebugFile of hl_ident | HBreakPointLine of int | HTimestamp | HOp of hl_op | HUnk of char and hl_namespace = | HNPrivate of hl_ident option | HNPublic of hl_ident option | HNInternal of hl_ident option | HNProtected of hl_ident | HNNamespace of hl_ident | HNExplicit of hl_ident | HNStaticProtected of hl_ident option and hl_ns_set = hl_namespace list and hl_name = | HMPath of hl_ident list * hl_ident | HMName of hl_ident * hl_namespace | HMMultiName of hl_ident option * hl_ns_set | HMRuntimeName of hl_ident | HMRuntimeNameLate | HMMultiNameLate of hl_ns_set | HMAttrib of hl_name | HMParams of hl_name * hl_name list | HMNSAny of hl_ident | HMAny and hl_value = | HVNone | HVNull | HVBool of bool | HVString of hl_ident | HVInt of hl_int | HVUInt of hl_uint | HVFloat of hl_float | HVNamespace of int * hl_namespace and hl_method = { hlmt_index : int; (* used to sort methods (preserve order) *) hlmt_ret : hl_name option; hlmt_args : hl_name option list; hlmt_native : bool; hlmt_var_args : bool; hlmt_arguments_defined : bool; hlmt_uses_dxns : bool; hlmt_new_block : bool; hlmt_unused_flag : bool; hlmt_debug_name : hl_ident option; hlmt_dparams : hl_value list option; hlmt_pnames : hl_ident option list option; mutable hlmt_function : hl_function option; (* None for interfaces constructors only *) } and hl_try_catch = { hltc_start : int; hltc_end : int; hltc_handle : int; hltc_type : hl_name option; hltc_name : hl_name option; } and hl_function = { hlf_stack_size : int; hlf_nregs : int; hlf_init_scope : int; hlf_max_scope : int; mutable hlf_code : hl_opcode MultiArray.t; mutable hlf_trys : hl_try_catch array; hlf_locals : (hl_name * hl_name option * hl_slot * bool) array; (* bool = const - mostly false *) } and hl_method_kind = as3_method_kind and hl_method_field = { hlm_type : hl_method; hlm_final : bool; hlm_override : bool; hlm_kind : hl_method_kind; } and hl_var_field = { hlv_type : hl_name option; hlv_value : hl_value; hlv_const : bool; } and hl_metadata = { hlmeta_name : hl_ident; hlmeta_data : (hl_ident option * hl_ident) array; } and hl_field_kind = | HFMethod of hl_method_field | HFVar of hl_var_field | HFFunction of hl_method | HFClass of hl_class (* only for hl_static fields *) and hl_field = { hlf_name : hl_name; hlf_slot : hl_slot; hlf_kind : hl_field_kind; hlf_metas : hl_metadata array option; } and hl_class = { hlc_index : int; hlc_name : hl_name; hlc_super : hl_name option; hlc_sealed : bool; hlc_final : bool; hlc_interface : bool; hlc_namespace : hl_namespace option; hlc_implements : hl_name array; mutable hlc_construct : hl_method; mutable hlc_fields : hl_field array; mutable hlc_static_construct : hl_method; mutable hlc_static_fields : hl_field array; } and hl_static = { hls_method : hl_method; hls_fields : hl_field array; } and hl_tag = hl_static list haxe-3.0~svn6707/libs/swflib/png.mli0000644000175000017500000000414212172015137017712 0ustar bdefreesebdefreese(* * PNG File Format Library * Copyright (c)2005 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type grey_bits = | GBits1 | GBits2 | GBits4 | GBits8 | GBits16 type grey_alpha_bits = | GABits8 | GABits16 type true_bits = | TBits8 | TBits16 type index_bits = | IBits1 | IBits2 | IBits4 | IBits8 type alpha = | NoAlpha | HaveAlpha type color = | ClGreyScale of grey_bits | ClGreyAlpha of grey_alpha_bits | ClTrueColor of true_bits * alpha | ClIndexed of index_bits type header = { png_width : int; png_height : int; png_color : color; png_interlace : bool; } type chunk_id = string type chunk = | CEnd | CHeader of header | CData of string | CPalette of string | CUnknown of chunk_id * string type png = chunk list type error_msg = | Invalid_header | Invalid_file | Truncated_file | Invalid_CRC | Invalid_colors | Unsupported_colors | Invalid_datasize | Invalid_filter of int | Invalid_array exception Error of error_msg val error_msg : error_msg -> string val is_critical : chunk_id -> bool val is_public : chunk_id -> bool val is_reseverd : chunk_id -> bool val is_safe_to_copy : chunk_id -> bool val header : png -> header val data : png -> string val color_bits : color -> int val parse : IO.input -> png val write : 'a IO.output -> png -> unit val filter : png -> string -> string val make : width:int -> height:int -> pixel:(int -> int -> int32) -> compress:(string -> string) -> png haxe-3.0~svn6707/libs/swflib/as3.mli0000644000175000017500000001604112172015137017615 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2004-2006 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a index type 'a index_nz type as3_ident = string type as3_int = int32 type as3_uint = int32 type as3_float = float type as3_slot = int type reg = int type nargs = int type as3_jump = | J3NotLt | J3NotLte | J3NotGt | J3NotGte | J3Always | J3True | J3False | J3Eq | J3Neq | J3Lt | J3Lte | J3Gt | J3Gte | J3PhysEq | J3PhysNeq type as3_op = | A3OAs | A3ONeg | A3OIncr | A3ODecr | A3ONot | A3OBitNot | A3OAdd | A3OSub | A3OMul | A3ODiv | A3OMod | A3OShl | A3OShr | A3OUShr | A3OAnd | A3OOr | A3OXor | A3OEq | A3OPhysEq | A3OLt | A3OLte | A3OGt | A3OGte | A3OIs | A3OIn | A3OIIncr | A3OIDecr | A3OINeg | A3OIAdd | A3OISub | A3OIMul | A3OMemSet8 | A3OMemSet16 | A3OMemSet32 | A3OMemSetFloat | A3OMemSetDouble | A3OMemGet8 | A3OMemGet16 | A3OMemGet32 | A3OMemGetFloat | A3OMemGetDouble | A3OSign1 | A3OSign8 | A3OSign16 type as3_name = as3_multi_name index and as3_opcode = | A3BreakPoint | A3Nop | A3Throw | A3GetSuper of as3_name | A3SetSuper of as3_name | A3DxNs of as3_ident index | A3DxNsLate | A3RegKill of reg | A3Label | A3Jump of as3_jump * int | A3Switch of int * int list | A3PushWith | A3PopScope | A3ForIn | A3HasNext | A3Null | A3Undefined | A3ForEach | A3SmallInt of int | A3Int of int | A3True | A3False | A3NaN | A3Pop | A3Dup | A3Swap | A3String of as3_ident index | A3IntRef of as3_int index | A3UIntRef of as3_uint index | A3Float of as3_float index | A3Scope | A3Namespace of as3_namespace index | A3Next of reg * reg | A3Function of as3_method_type index_nz | A3CallStack of nargs | A3Construct of nargs | A3CallMethod of as3_slot * nargs | A3CallStatic of as3_method_type index * nargs | A3CallSuper of as3_name * nargs | A3CallProperty of as3_name * nargs | A3RetVoid | A3Ret | A3ConstructSuper of nargs | A3ConstructProperty of as3_name * nargs | A3CallPropLex of as3_name * nargs | A3CallSuperVoid of as3_name * nargs | A3CallPropVoid of as3_name * nargs | A3ApplyType of nargs | A3Object of nargs | A3Array of nargs | A3NewBlock | A3ClassDef of unit index_nz | A3GetDescendants of as3_name | A3Catch of int | A3FindPropStrict of as3_name | A3FindProp of as3_name | A3FindDefinition of as3_name | A3GetLex of as3_name | A3SetProp of as3_name | A3Reg of reg | A3SetReg of reg | A3GetGlobalScope | A3GetScope of int | A3GetProp of as3_name | A3InitProp of as3_name | A3DeleteProp of as3_name | A3GetSlot of as3_slot | A3SetSlot of as3_slot | A3ToString | A3ToXml | A3ToXmlAttr | A3ToInt | A3ToUInt | A3ToNumber | A3ToBool | A3ToObject | A3CheckIsXml | A3Cast of as3_name | A3AsAny | A3AsString | A3AsType of as3_name | A3AsObject | A3IncrReg of reg | A3DecrReg of reg | A3Typeof | A3InstanceOf | A3IsType of as3_name | A3IncrIReg of reg | A3DecrIReg of reg | A3This | A3SetThis | A3DebugReg of as3_ident index * reg * int | A3DebugLine of int | A3DebugFile of as3_ident index | A3BreakPointLine of int | A3Timestamp | A3Op of as3_op | A3Unk of char and as3_namespace = | A3NPrivate of as3_ident index option | A3NPublic of as3_ident index option | A3NInternal of as3_ident index option | A3NProtected of as3_ident index | A3NNamespace of as3_ident index | A3NExplicit of as3_ident index | A3NStaticProtected of as3_ident index option and as3_ns_set = as3_namespace index list and as3_multi_name = | A3MName of as3_ident index * as3_namespace index | A3MMultiName of as3_ident index option * as3_ns_set index | A3MRuntimeName of as3_ident index | A3MRuntimeNameLate | A3MMultiNameLate of as3_ns_set index | A3MAttrib of as3_multi_name | A3MParams of as3_multi_name index * as3_multi_name index list | A3MNSAny of as3_ident index | A3MAny and as3_value = | A3VNone | A3VNull | A3VBool of bool | A3VString of as3_ident index | A3VInt of as3_int index | A3VUInt of as3_uint index | A3VFloat of as3_float index | A3VNamespace of int * as3_namespace index (* int : kind of namespace *) and as3_method_type = { mt3_ret : as3_name option; mt3_args : as3_name option list; mt3_native : bool; mt3_var_args : bool; mt3_arguments_defined : bool; mt3_uses_dxns : bool; mt3_new_block : bool; mt3_unused_flag : bool; mt3_debug_name : as3_ident index option; mt3_dparams : as3_value list option; mt3_pnames : as3_ident index option list option; } type as3_method_kind = | MK3Normal | MK3Getter | MK3Setter type as3_method = { m3_type : as3_method_type index_nz; m3_final : bool; m3_override : bool; m3_kind : as3_method_kind; } type as3_var = { v3_type : as3_name option; v3_value : as3_value; v3_const : bool; } type as3_metadata = { meta3_name : as3_ident index; meta3_data : (as3_ident index option * as3_ident index) array; } type as3_field_kind = | A3FMethod of as3_method | A3FVar of as3_var | A3FClass of as3_class index_nz | A3FFunction of as3_method_type index_nz and as3_field = { f3_name : as3_name; f3_slot : as3_slot; f3_kind : as3_field_kind; f3_metas : as3_metadata index_nz array option; } and as3_class = { cl3_name : as3_name; cl3_super : as3_name option; cl3_sealed : bool; cl3_final : bool; cl3_interface : bool; cl3_namespace : as3_namespace index option; cl3_implements : as3_name array; cl3_construct : as3_method_type index_nz; cl3_fields : as3_field array; } type as3_static = { st3_method : as3_method_type index_nz; st3_fields : as3_field array; } type as3_try_catch = { tc3_start : int; tc3_end : int; tc3_handle : int; tc3_type : as3_name option; tc3_name : as3_name option; } type as3_function = { fun3_id : as3_method_type index_nz; fun3_stack_size : int; fun3_nregs : int; fun3_init_scope : int; fun3_max_scope : int; fun3_code : as3_opcode MultiArray.t; fun3_trys : as3_try_catch array; fun3_locals : as3_field array; } type as3_tag = { as3_ints : as3_int array; as3_uints : as3_uint array; as3_floats : as3_float array; as3_idents : as3_ident array; as3_namespaces : as3_namespace array; as3_nsets : as3_ns_set array; mutable as3_names : as3_multi_name array; mutable as3_method_types : as3_method_type array; mutable as3_metadatas : as3_metadata array; mutable as3_classes : as3_class array; mutable as3_statics : as3_static array; mutable as3_inits : as3_static array; mutable as3_functions : as3_function array; mutable as3_unknown : string; (* only for partial parsing *) } haxe-3.0~svn6707/libs/swflib/swf.ml0000644000175000017500000003107012172015137017554 0ustar bdefreesebdefreese(* * This file is part of SwfLib * Copyright (c)2004 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type float16 = int type unknown = string type binary = string type action_count = int type rgb = { cr : int; cg : int; cb : int; } type rgba = { r : int; g : int; b : int; a : int; } type color = | ColorRGB of rgb | ColorRGBA of rgba type gradient = | GradientRGB of ((int * rgb) list * int) | GradientRGBA of ((int * rgba) list * int) type rect = { rect_nbits : int; left : int; right : int; top : int; bottom : int; } type big_rect = { brect_nbits : int; bleft : int list; bright : int list; btop : int list; bbottom : int list; } type matrix_part = { m_nbits : int; mx : int; my : int; } type matrix = { scale : matrix_part option; rotate : matrix_part option; trans : matrix_part; } type color_transform_alpha = { cxa_nbits : int; cxa_add : rgba option; cxa_mult : rgba option; } type function_decl = { f_name : string; f_args : string list; mutable f_codelen : action_count; } type func2_flags = | ThisRegister | ThisNoVar | ArgumentsRegister | ArgumentsNoVar | SuperRegister | SuperNoVar | RootRegister | ParentRegister | GlobalRegister type function_decl2 = { f2_name : string; f2_flags : func2_flags list; f2_args : (int * string) list; mutable f2_nregs : int; mutable f2_codelen : action_count; } type try_style = | TryRegister of int | TryVariable of string type try_block = { tr_style : try_style; mutable tr_trylen : action_count; mutable tr_catchlen : action_count option; mutable tr_finallylen : action_count option } type push_item = | PString of string | PFloat of int32 | PNull | PUndefined | PReg of int | PBool of bool | PDouble of float | PInt of int32 | PStack of int | PStack2 of int type property = | PX | PY | PXScale | PYScale | PCurrentFrame | PTotalFrames | PAlpha | PVisible | PWidth | PHeight | PRotation | PTarget | PFramesLoaded | PName | PDropTarget | PUrl | PHighQuality | PFocusRect | PSoundBufTime | PQuality | PXMouse | PYMouse type action = | AEnd | ANextFrame | APrevFrame | APlay | AStop | AToggleHighQuality | AStopSounds | AAddNum | ASubtract | AMultiply | ADivide | ACompareNum | AEqualNum | ALogicalAnd | ALogicalOr | ANot | AStringEqual | AStringLength | ASubString | APop | AToInt | AEval | ASet | ATellTarget | AStringAdd | AGetProperty | ASetProperty | ADuplicateMC | ARemoveMC | ATrace | AStartDrag | AStopDrag | AThrow | ACast | AImplements | AFSCommand2 | ARandom | AMBStringLength | AOrd | AChr | AGetTimer | AMBStringSub | AMBOrd | AMBChr | ADeleteObj | ADelete | ALocalAssign | ACall | AReturn | AMod | ANew | ALocalVar | AInitArray | AObject | ATypeOf | ATargetPath | AEnum | AAdd | ACompare | AEqual | AToNumber | AToString | ADup | ASwap | AObjGet | AObjSet | AIncrement | ADecrement | AObjCall | ANewMethod | AInstanceOf | AEnum2 | AAnd | AOr | AXor | AShl | AShr | AAsr | APhysEqual | AGreater | AStringGreater | AExtends | AGotoFrame of int | AGetURL of string * string | ASetReg of int | AStringPool of string list | AWaitForFrame of int * int | ASetTarget of string | AGotoLabel of string | AWaitForFrame2 of int | AFunction2 of function_decl2 | ATry of try_block | AWith of int | APush of push_item list | AJump of action_count | AGetURL2 of int | AFunction of function_decl | ACondJump of action_count | ACallFrame (* no data *) | AGotoFrame2 of bool * int option | AUnknown of int * unknown type actions = action DynArray.t type header = { mutable h_version : int; mutable h_size : rect; mutable h_fps : float16; mutable h_frame_count : int; mutable h_compressed : bool; } type export = { mutable exp_id : int; exp_name : string; } type import = { mutable imp_id : int; imp_name : string; } type do_init_action = { mutable dia_id : int; dia_actions : actions; } type sound = { mutable so_id : int; so_flags : int; so_samples : int; so_data : unknown; } type start_sound = { mutable sts_id : int; sts_data : unknown; } type sfs_bitmap = { sfb_repeat : bool; sfb_smooth : bool; mutable sfb_cid : int; sfb_mpos : matrix; } type shape_fill_style = | SFSSolid of rgb | SFSSolid3 of rgba | SFSLinearGradient of matrix * gradient | SFSRadialGradient of matrix * gradient * int option | SFSBitmap of sfs_bitmap type shape_line_style = { sls_width : int; sls_color : color; sls_flags : int option; sls_fill : shape_fill_style option; sls_miter : int option; } type shape_new_styles = { sns_fill_styles : shape_fill_style list; sns_line_styles : shape_line_style list; sns_nlbits : int; sns_nfbits : int; } type shape_change_style_record = { scsr_move : (int * int * int) option; scsr_fs0 : int option; scsr_fs1 : int option; scsr_ls : int option; scsr_new_styles : shape_new_styles option; } type shape_curved_edge_record = { scer_nbits : int; scer_cx : int; scer_cy : int; scer_ax : int; scer_ay : int; } type shape_straight_edge_record = { sser_nbits : int; sser_line : int option * int option; } type shape_record = | SRStyleChange of shape_change_style_record | SRCurvedEdge of shape_curved_edge_record | SRStraightEdge of shape_straight_edge_record type shape_records = { srs_nlbits : int; srs_nfbits : int; srs_records : shape_record list; } type shape_with_style = { sws_fill_styles : shape_fill_style list; sws_line_styles : shape_line_style list; sws_records : shape_records; } type shape = { mutable sh_id : int; sh_bounds : rect; sh_bounds2 : (rect * int) option; sh_style : shape_with_style; } type filter_gradient = { fgr_colors : (rgba * int) list; fgr_data : unknown; } type filter = | FDropShadow of unknown | FBlur of unknown | FGlow of unknown | FBevel of unknown | FGradientGlow of filter_gradient | FAdjustColor of unknown | FGradientBevel of filter_gradient type bitmap_jpg = { mutable jpg_id : int; jpg_data : binary; } type bitmap_data = { mutable bd_id : int; bd_table : binary option; bd_data : binary; bd_alpha : binary option; bd_deblock : int option; } type bitmap_lossless = { mutable bll_id : int; bll_format : int; bll_width : int; bll_height : int; bll_data : unknown; } type morph_shape = { mutable msh_id : int; msh_start_bounds : rect; msh_end_bounds : rect; msh_data : unknown; } type cid_data = { mutable cd_id : int; cd_data : binary; } type text_glyph = { txg_index : int; txg_advanced : int; } type text_record = { mutable txr_font : (int * int) option; txr_color : color option; txr_dx : int option; txr_dy : int option; txr_glyphs : text_glyph list; } type text = { mutable txt_id : int; txt_bounds : big_rect; txt_matrix : matrix; txt_ngbits : int; txt_nabits : int; txt_records : text_record list; } type button_record = { btr_flags : int; mutable btr_cid : int; btr_depth : int; btr_mpos : matrix; btr_color : color_transform_alpha option; btr_filters : filter list option; btr_blendmode : int option; } type button_action = { bta_flags : int; bta_actions : actions; } type button2 = { mutable bt2_id : int; bt2_track_as_menu : bool; bt2_records : button_record list; bt2_actions : button_action list; } type remove_object = { mutable rmo_id : int; rmo_depth : int; } type edit_text_layout = { edtl_align : int; edtl_left_margin : int; edtl_right_margin : int; edtl_indent : int; edtl_leading : int; } type edit_text = { mutable edt_id : int; edt_bounds : rect; mutable edt_font : (int * int) option; edt_color : rgba option; edt_maxlen : int option; edt_layout : edit_text_layout option; edt_variable : string; edt_text : string option; edt_wordwrap : bool; edt_multiline : bool; edt_password : bool; edt_readonly : bool; edt_autosize : bool; edt_noselect : bool; edt_border : bool; edt_html : bool; edt_outlines : bool; } type f9class = { mutable f9_cid : int option; f9_classname : string; } type files_attrib = { fa_network : bool; fa_as3 : bool; fa_metadata : bool; fa_gpu : bool; fa_direct_blt : bool; } type tag_data = | TEnd | TShowFrame | TShape of shape | TRemoveObject of remove_object | TBitsJPEG of bitmap_jpg | TJPEGTables of binary | TSetBgColor of rgb | TFont of cid_data | TText of text | TDoAction of actions | TFontInfo of cid_data | TSound of sound | TStartSound of start_sound | TBitsLossless of bitmap_lossless | TBitsJPEG2 of bitmap_data | TShape2 of shape | TProtect | TPlaceObject2 of place_object | TRemoveObject2 of int | TShape3 of shape | TText2 of text | TButton2 of button2 | TBitsJPEG3 of bitmap_data | TBitsLossless2 of bitmap_lossless | TEditText of edit_text | TClip of clip | TProductInfo of unknown | TFrameLabel of string * char option | TSoundStreamHead2 of unknown | TMorphShape of morph_shape | TFont2 of cid_data | TExport of export list | TImport of string * import list | TDoInitAction of do_init_action | TVideoStream of cid_data | TVideoFrame of cid_data | TFontInfo2 of cid_data | TDebugID of unknown | TEnableDebugger2 of int * string | TScriptLimits of int * int | TFilesAttributes of files_attrib | TPlaceObject3 of place_object | TImport2 of string * import list | TFontAlignZones of cid_data | TCSMSettings of cid_data | TFont3 of cid_data | TF9Classes of f9class list | TMetaData of string | TScale9 of int * rect | TActionScript3 of (int * string) option * As3.as3_tag | TShape4 of shape | TMorphShape2 of morph_shape | TScenes of (int * string) list * (int * string) list | TBinaryData of int * binary | TBigBinaryData of int * binary list | TFontName of cid_data | TBitsJPEG4 of bitmap_data | TFont4 of cid_data | TUnknown of int * unknown and tag = { mutable tid : int; mutable textended : bool; mutable tdata : tag_data; } and clip_event = { cle_events : int; cle_key : char option; cle_actions : actions; } and place_object = { po_depth : int; po_move : bool; mutable po_cid : int option; po_matrix : matrix option; po_color : color_transform_alpha option; po_ratio : float16 option; po_inst_name : string option; po_clip_depth : int option; po_events : clip_event list option; po_filters : filter list option; po_blend : int option; po_bcache : int option; } and clip = { mutable c_id : int; c_frame_count : int; c_tags : tag list; } type font_language_code = | LCNone (*0*) | LCLatin (*1*) | LCJapanese (*2*) | LCKorean (*3*) | LCSimplifiedChinese (*4*) | LCTraditionalChinese (*5*) type font_glyph_data = { font_char_code: int; font_shape: shape_records; } type font_layout_glyph_data = { font_advance: int; font_bounds: rect; } type font_kerning_data = { font_char_code1: int; font_char_code2: int; font_adjust: int; } type font_layout_data = { font_ascent: int; font_descent: int; font_leading: int; font_glyphs_layout: font_layout_glyph_data array; font_kerning: font_kerning_data list; } type font2_data = { font_shift_jis: bool; font_is_small: bool; font_is_ansi: bool; font_wide_codes: bool; font_wide_offsets: bool; font_is_italic: bool; font_is_bold: bool; font_language: font_language_code; font_name: string; font_glyphs: font_glyph_data array; font_layout: font_layout_data; } type swf = header * tag list let __deflate = ref (fun (_:unit IO.output) -> assert false) let __inflate = ref (fun _ -> assert false) let __parser = ref (fun _ -> assert false) let __printer = ref (fun (_:unit IO.output) _ -> ()) exception Error of string let error msg = raise (Error msg) let warnings = ref true let to_float16 f = let sign , f = (if f < 0. then true , 0. -. f else false , f) in let high = int_of_float f in let low = int_of_float ((f -. (float high)) *. 256.) in if high > 127 then failwith "to_float16"; (high lsl 8) lor (if sign then low lor (1 lsl 15) else low) let parse (ch : IO.input) = (!__parser ch : swf) let write (ch : 'a IO.output) (data : swf) = !__printer (Obj.magic ch) data let deflate (ch : 'a IO.output) = (Obj.magic (!__deflate (Obj.magic ch) : unit IO.output) : 'a IO.output) let inflate (ch : IO.input) = (!__inflate ch : IO.input) haxe-3.0~svn6707/libs/ttflib/0000755000175000017500000000000012172015137016420 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/ttflib/tTFCanvasWriter.ml0000644000175000017500000000231712172015137022003 0ustar bdefreesebdefreeseopen TTFData open TTFTools let rec write_glyph ttf key glyf = key,TTFTools.build_glyph_paths ttf false glyf let write_font ch ttf glyphs = let scale = 1024. /. (float_of_int ttf.ttf_head.hd_units_per_em) in List.iter (fun (key,paths) -> IO.nwrite ch (Printf.sprintf "\tfunction key%i(ctx) {\n" key); IO.nwrite ch "\t\tctx.beginPath();\n"; List.iter (fun path -> IO.nwrite ch (match path.gp_type with | 0 -> Printf.sprintf "\t\tctx.moveTo(%.2f,%.2f);\n" (path.gp_x *. scale) (path.gp_y *. scale *. (-1.)) | 1 -> Printf.sprintf "\t\tctx.lineTo(%.2f,%.2f);\n" (path.gp_x *. scale) (path.gp_y *. scale *. (-1.)) | 2 -> Printf.sprintf "\t\tctx.quadraticCurveTo(%.2f,%.2f,%.2f,%.2f);\n" (path.gp_cx *. scale) (path.gp_cy *. scale *. (-1.)) (path.gp_x *. scale) (path.gp_y *. scale *. (-1.)) | _ -> assert false) ) paths; IO.nwrite ch "\t\tctx.fill();\n"; IO.nwrite ch "\t}\n"; ) glyphs; () let to_canvas ttf range_str = let lut = TTFTools.build_lut ttf range_str in let glyfs = Hashtbl.fold (fun k v acc -> (k,ttf.ttf_glyfs.(v)) :: acc) lut [] in let glyfs = List.stable_sort (fun a b -> compare (fst a) (fst b)) glyfs in List.map (fun (k,g) -> write_glyph ttf k g) glyfshaxe-3.0~svn6707/libs/ttflib/tTFJsonWriter.ml0000644000175000017500000000215712172015137021503 0ustar bdefreesebdefreeseopen TTFData open TTFTools let rec write_glyph ttf key glyf = key,TTFTools.build_glyph_paths ttf false glyf let write_font ch ttf glyphs = let scale = 1024. /. (float_of_int ttf.ttf_head.hd_units_per_em) in IO.nwrite ch "{\n\t"; IO.nwrite ch (String.concat ",\n\t" (List.map (fun (key,paths) -> (Printf.sprintf "\"g%i\":[" key) ^ (String.concat "," (List.map (fun path -> match path.gp_type with | 0 -> Printf.sprintf "[0,%.2f,%.2f]" (path.gp_x *. scale) (path.gp_y *. scale *. (-1.)) | 1 -> Printf.sprintf "[1,%.2f,%.2f]" (path.gp_x *. scale) (path.gp_y *. scale *. (-1.)) | 2 -> Printf.sprintf "[2,%.2f,%.2f,%.2f,%.2f]" (path.gp_cx *. scale) (path.gp_cy *. scale *. (-1.)) (path.gp_x *. scale) (path.gp_y *. scale *. (-1.)) | _ -> assert false ) paths)) ^ "]"; ) glyphs)); IO.nwrite ch "\n}" let to_json ttf range_str = let lut = TTFTools.build_lut ttf range_str in let glyfs = Hashtbl.fold (fun k v acc -> (k,ttf.ttf_glyfs.(v)) :: acc) lut [] in let glyfs = List.stable_sort (fun a b -> compare (fst a) (fst b)) glyfs in List.map (fun (k,g) -> write_glyph ttf k g) glyfshaxe-3.0~svn6707/libs/ttflib/Makefile0000644000175000017500000000060412172015137020060 0ustar bdefreesebdefreeseFLAGS=-I ../extlib -I ../swflib FILES=tTFData tTFParser tTFTools tTFSwfWriter tTFCanvasWriter tTFJsonWriter LIBS=extLib swflib unix OUTPUT=ttf all: ocamlopt $(FLAGS) $(FILES:=.ml) -g -a -o ttf.cmxa exec: ocamlopt $(FLAGS) $(LIBS:=.cmxa) $(FILES:=.ml) main.ml -g -o $(OUTPUT) clean: rm -rf ttf.cmxa ttf.lib ttf.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi)haxe-3.0~svn6707/libs/ttflib/tTFSwfWriter.ml0000644000175000017500000001340712172015137021331 0ustar bdefreesebdefreeseopen TTFData open Swf let num_bits x = if x = 0 then 0 else let rec loop n v = if v = 0 then n else loop (n + 1) (v lsr 1) in loop 1 (abs x) let round x = int_of_float (floor (x +. 0.5)) let to_twips v = round (v *. 20.) type ctx = { ttf : ttf; } let begin_fill = SRStyleChange { scsr_move = None; scsr_fs0 = Some(1); scsr_fs1 = None; scsr_ls = None; scsr_new_styles = None; } let end_fill = SRStyleChange { scsr_move = None; scsr_fs0 = None; scsr_fs1 = None; scsr_ls = None; scsr_new_styles = None; } let align_bits x nbits = x land ((1 lsl nbits ) - 1) let move_to ctx x y = let x = to_twips x in let y = to_twips y in let nbits = max (num_bits x) (num_bits y) in SRStyleChange { scsr_move = Some (nbits, align_bits x nbits, align_bits y nbits); scsr_fs0 = Some(1); scsr_fs1 = None; scsr_ls = None; scsr_new_styles = None; } let line_to ctx x y = let x = to_twips x in let y = to_twips y in if x = 0 && y = 0 then raise Exit; let nbits = max (num_bits x) (num_bits y) in SRStraightEdge { sser_nbits = nbits; sser_line = (if x = 0 then None else Some(align_bits x nbits)), (if y = 0 then None else Some(align_bits y nbits)); } let curve_to ctx cx cy ax ay = let cx = to_twips cx in let cy = to_twips cy in let ax = to_twips ax in let ay = to_twips ay in let nbits = max (max (num_bits cx) (num_bits cy)) (max (num_bits ax) (num_bits ay)) in SRCurvedEdge { scer_nbits = nbits; scer_cx = align_bits cx nbits; scer_cy = align_bits cy nbits; scer_ax = align_bits ax nbits; scer_ay = align_bits ay nbits; } open TTFTools let write_paths ctx paths = let scale = 1024. /. (float_of_int ctx.ttf.ttf_head.hd_units_per_em) in let srl = DynArray.create () in List.iter (fun path -> try DynArray.add srl (match path.gp_type with | 0 -> move_to ctx (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale); | 1 -> line_to ctx (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale); | 2 -> curve_to ctx (path.gp_cx *. scale) ((-1.) *. path.gp_cy *. scale) (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale); | _ -> assert false) with Exit -> () ) paths; DynArray.add srl (end_fill); { srs_nfbits = 1; srs_nlbits = 0; srs_records = DynArray.to_list srl; } let rec write_glyph ctx key glyf = { font_char_code = key; font_shape = write_paths ctx (TTFTools.build_glyph_paths ctx.ttf true glyf); } let write_font_layout ctx lut = let scale = 1024. /. (float_of_int ctx.ttf.ttf_head.hd_units_per_em) in let hmtx = Hashtbl.fold (fun k v acc -> (k,ctx.ttf.ttf_hmtx.(v)) :: acc) lut [] in let hmtx = List.stable_sort (fun a b -> compare (fst a) (fst b)) hmtx in let hmtx = List.map (fun (k,g) -> g) hmtx in { font_ascent = round((float_of_int ctx.ttf.ttf_os2.os2_us_win_ascent) *. scale *. 20.); font_descent = round((float_of_int ctx.ttf.ttf_os2.os2_us_win_descent) *. scale *. 20.); font_leading = round(((float_of_int(ctx.ttf.ttf_os2.os2_us_win_ascent + ctx.ttf.ttf_os2.os2_us_win_descent - ctx.ttf.ttf_head.hd_units_per_em)) *. scale) *. 20.); font_glyphs_layout = Array.of_list( ExtList.List.mapi (fun i h -> { font_advance = round((float_of_int h.advance_width) *. scale *. 20.); font_bounds = {rect_nbits=0; left=0; right=0; top=0; bottom=0}; }) hmtx ); font_kerning = []; } let bi v = if v then 1 else 0 let int_from_langcode lc = match lc with | LCNone -> 0 | LCLatin -> 1 | LCJapanese -> 2 | LCKorean -> 3 | LCSimplifiedChinese -> 4 | LCTraditionalChinese -> 5 let write_font2 ch b f2 = IO.write_bits b 1 (bi true); IO.write_bits b 1 (bi f2.font_shift_jis); IO.write_bits b 1 (bi f2.font_is_small); IO.write_bits b 1 (bi f2.font_is_ansi); IO.write_bits b 1 (bi f2.font_wide_offsets); IO.write_bits b 1 (bi f2.font_wide_codes); IO.write_bits b 1 (bi f2.font_is_italic); IO.write_bits b 1 (bi f2.font_is_bold); IO.write_byte ch (int_from_langcode f2.font_language); IO.write_byte ch (String.length f2.font_name); IO.nwrite ch f2.font_name; IO.write_ui16 ch (Array.length f2.font_glyphs); let glyph_offset = ref (((Array.length f2.font_glyphs) * 4)+4) in Array.iter (fun g -> IO.write_i32 ch !glyph_offset; glyph_offset := !glyph_offset + SwfParser.font_shape_records_length g.font_shape; )f2.font_glyphs; IO.write_i32 ch !glyph_offset; Array.iter (fun g -> SwfParser.write_shape_without_style ch g.font_shape;) f2.font_glyphs; Array.iter (fun g -> IO.write_ui16 ch g.font_char_code; )f2.font_glyphs; IO.write_i16 ch f2.font_layout.font_ascent; IO.write_i16 ch f2.font_layout.font_descent; IO.write_i16 ch f2.font_layout.font_leading; Array.iter (fun g -> let fa = ref g.font_advance in if (!fa) < -32767 then fa := -32768;(* fix or check *) if (!fa) > 32766 then fa := 32767; IO.write_i16 ch !fa;) f2.font_layout.font_glyphs_layout; Array.iter (fun g -> SwfParser.write_rect ch g.font_bounds;) f2.font_layout.font_glyphs_layout; IO.write_ui16 ch 0 (* TODO: optional FontKerningTable *) let to_swf ttf range_str = let ctx = { ttf = ttf; } in let lut = TTFTools.build_lut ttf range_str in let glyfs = Hashtbl.fold (fun k v acc -> (k,ctx.ttf.ttf_glyfs.(v)) :: acc) lut [] in let glyfs = List.stable_sort (fun a b -> compare (fst a) (fst b)) glyfs in let glyfs = List.map (fun (k,g) -> write_glyph ctx k g) glyfs in let glyfs_font_layout = write_font_layout ctx lut in let glyfs = Array.of_list glyfs in { font_shift_jis = false; font_is_small = false; font_is_ansi = false; font_wide_offsets = true; font_wide_codes = true; font_is_italic = false; font_is_bold = false; font_language = LCNone; font_name = ttf.ttf_font_name; font_glyphs = glyfs; font_layout = glyfs_font_layout; } ;;haxe-3.0~svn6707/libs/ttflib/main.ml0000644000175000017500000001005212172015137017674 0ustar bdefreesebdefreeseopen TTFData exception Abort let gen_hxswfml_debug fontname = let xml = " " in Std.output_file (fontname ^ ".fxml") xml; if Sys.command "haxe -main Main -swf main.swf" <> 0 then failwith "Error while executing haxe"; if Sys.command ("hxswfml xml2swf \"" ^ fontname ^ ".fxml\" \"" ^ fontname ^ ".swf\" -no-strict") <> 0 then failwith "Error while executing hxswfml"; Unix.unlink (fontname ^ ".fxml"); Unix.unlink "main.swf" let normalize_path p = let l = String.length p in if l = 0 then "./" else begin let p = String.concat "/" (ExtString.String.nsplit p "\\") in match p.[l-1] with | '/' -> p | _ -> p ^ "/" end let mk_dir_rec dir = let dir = normalize_path dir in let parts = ExtString.String.nsplit dir "/" in let rec create acc = function | [] -> () | "" :: [] -> () | d :: l -> let dir = String.concat "/" (List.rev (d :: acc)) in if not (Sys.file_exists dir) then Unix.mkdir dir 0o755; create (d :: acc) l in create [] parts let exit msg = prerr_endline msg; raise Abort let process args = let fonts = ref [] in let range_str = ref "" in let targets = ref [] in let debug_hxswfml = ref false in let args_callback s = fonts := s :: !fonts in let usage = Printf.sprintf "Ttf (-swf|-canvas)" in let basic_args = [ ("-range",Arg.String (fun str -> range_str := str; )," : specifies the character range"); ("-swf",Arg.String (fun dir -> mk_dir_rec dir; let f ttf range_str = let f2 = TTFSwfWriter.to_swf ttf range_str in let ch = IO.output_channel (open_out_bin (dir ^ "/" ^ ttf.ttf_font_name ^ ".dat")) in let b = IO.output_bits ch in IO.write_i16 ch 1; TTFSwfWriter.write_font2 ch b f2; IO.close_out ch; if !debug_hxswfml then begin if not (Sys.file_exists "Main.hx") then failwith "Could not find Main.hx required for -hxswfml-debug"; let main = Std.input_file "Main.hx" in let old = Sys.getcwd () in Sys.chdir dir; Std.output_file ~filename:"Main.hx" ~text:main; gen_hxswfml_debug ttf.ttf_font_name; Unix.unlink "Main.hx"; Sys.chdir old; end in targets := f :: !targets; )," : generate swf tag data to "); ("-canvas", Arg.String (fun dir -> mk_dir_rec dir; let f ttf range_str = let glyphs = TTFCanvasWriter.to_canvas ttf range_str in let ch = IO.output_channel (open_out_bin (dir ^ "/" ^ ttf.ttf_font_name ^ ".js")) in TTFCanvasWriter.write_font ch ttf glyphs; IO.close_out ch; in targets := f :: !targets; )," : generate canvas draw commands to "); ("-json", Arg.String (fun dir -> mk_dir_rec dir; let f ttf range_str = let glyphs = TTFJsonWriter.to_json ttf range_str in let ch = IO.output_channel (open_out_bin (dir ^ "/" ^ ttf.ttf_font_name ^ ".js")) in TTFJsonWriter.write_font ch ttf glyphs; IO.close_out ch; in targets := f :: !targets; )," : generate json-encoded glyph information to "); ("-hxswfml-debug", Arg.Unit (fun () -> debug_hxswfml := true; ),": generate debug swf with hxswfml") ] in if Array.length Sys.argv = 1 then Arg.usage basic_args usage else begin Arg.parse basic_args args_callback usage; match !fonts,!targets with | [],_ -> prerr_endline "Missing font argument"; Arg.usage basic_args usage | _,[] -> prerr_endline "No targets specified (-swf|-canvas|-json)"; Arg.usage basic_args usage | fonts,targets -> List.iter (fun font -> let ch = try open_in_bin font with _ -> exit ("No such file: " ^ font) in let ttf = TTFParser.parse ch in List.iter (fun target -> target ttf !range_str ) targets; close_in ch; ) fonts; end ;; try process Sys.argv; with Abort -> ()haxe-3.0~svn6707/libs/ttflib/tTFTools.ml0000644000175000017500000001551512172015137020477 0ustar bdefreesebdefreeseopen TTFData type glyf_transformation_matrix = { mutable a : float; mutable b : float; mutable c : float; mutable d : float; mutable tx : float; mutable ty : float; } type glyf_path = { gp_type : int; gp_x : float; gp_y : float; gp_cx : float; gp_cy : float; } type simple_point = { x : float; y : float; } let mk_path t x y cx cy = { gp_type = t; gp_x = x; gp_y = y; gp_cx = cx; gp_cy = cy; } let identity () = { a = 1.0; b = 0.0; c = 0.0; d = 1.0; tx = 0.0; ty = 0.0; } let multiply m x y = x *. m.a +. y *. m.b +. m.tx, x *. m.c +. y *. m.d +. m.ty (* TODO: check if this can be done in the parser directly *) let matrix_from_composite gc = let a,b,c,d = match gc.gc_transformation with | NoScale -> 1.0,0.0,0.0,1.0 | Scale f -> f,0.0,0.0,f | ScaleXY(fx,fy) -> fx,0.0,0.0,fy | ScaleMatrix (a,b,c,d) -> a,b,c,d in let arg1 = float_of_int gc.gc_arg1 in let arg2 = float_of_int gc.gc_arg2 in { a = a; b = b; c = c; d = d; (* TODO: point offsets *) tx = arg1 *. a +. arg2 *. b; ty = arg1 *. c +. arg2 *. d; } let relative_matrix m = {m with tx = 0.0; ty = 0.0} let make_coords relative mo g = match mo with | None -> Array.init (Array.length g.gs_x_coordinates) (fun i -> float_of_int g.gs_x_coordinates.(i),float_of_int g.gs_y_coordinates.(i)) | Some m -> let m = if relative then relative_matrix m else m in Array.init (Array.length g.gs_x_coordinates) (fun i -> let x,y = float_of_int g.gs_x_coordinates.(i),float_of_int g.gs_y_coordinates.(i) in multiply m x y ) let build_paths relative mo g = let len = Array.length g.gs_x_coordinates in let current_end = ref 0 in let end_pts = Array.init len (fun i -> if g.gs_end_pts_of_contours.(!current_end) = i then begin incr current_end; true end else false ) in let is_on i = g.gs_flags.(i) land 0x01 <> 0 in let is_end i = end_pts.(i) in let arr = DynArray.create () in let tx,ty = match mo with None -> 0.0,0.0 | Some m -> m.tx,m.ty in let last_added = ref { x = 0.0; y = 0.0; } in let add_rel t x y cx cy = let p = match t with | 0 -> mk_path t (x +. tx) (y +. ty) cx cy | 1 -> mk_path t (x -. !last_added.x) (y -. !last_added.y) cx cy | 2 -> mk_path t (x -. cx) (y -. cy) (cx -. !last_added.x) (cy -. !last_added.y) | _ -> assert false in last_added := { x = x; y = y; }; DynArray.add arr p in let add_abs t x y cx cy = DynArray.add arr (mk_path t x y cx cy) in let add = if relative then add_rel else add_abs in let coords = make_coords relative mo g in let left = ref [] in let right = ref [] in let new_contour = ref true in let p = ref { x = 0.0; y = 0.0 } in for i = 0 to len - 1 do p := { x = !p.x +. fst coords.(i); y = !p.y +. snd coords.(i); }; let p = !p in let is_on = is_on i in let is_end = is_end i in let rec flush pl = match pl with | c :: a :: [] -> add 2 a.x a.y c.x c.y | a :: [] -> add 1 a.x a.y 0.0 0.0 | c1 :: c2 :: pl -> add 2 (c1.x +. (c2.x -. c1.x) /. 2.0) (c1.y +. (c2.y -. c1.y) /. 2.0) c1.x c1.y; flush (c2 :: pl) | _ -> Printf.printf "Fail, len: %i\n" (List.length pl); in if !new_contour then begin if is_on then begin new_contour := false; add 0 p.x p.y 0.0 0.0; end; left := p :: !left end else if is_on || is_end then begin right := p :: !right; if is_on then begin flush (List.rev !right); right := [] end; if is_end then begin new_contour := true; flush ((List.rev !right) @ (List.rev !left)); left := []; right := []; end end else right := p :: !right done; DynArray.to_list arr let rec build_glyph_paths ttf relative ?(transformation=None) glyf = match glyf with | TGlyfSimple (h,g) -> build_paths relative transformation g | TGlyfComposite (h,gl) -> List.concat (List.map (fun g -> let t = Some (matrix_from_composite g) in build_glyph_paths ttf relative ~transformation:t (ttf.ttf_glyfs.(g.gc_glyf_index)) ) gl) | TGlyfNull -> [] let map_char_code cc c4 = let index = ref 0 in let seg_count = c4.c4_seg_count_x2 / 2 in if cc >= 0xFFFF then 0 else begin for i = 0 to seg_count - 1 do if c4.c4_end_code.(i) >= cc && c4.c4_start_code.(i) <= cc then begin if c4.c4_id_range_offset.(i) > 0 then let v = c4.c4_id_range_offset.(i)/2 + cc - c4.c4_start_code.(i) - seg_count + i in index := c4.c4_glyph_index_array.(v) else index := (c4.c4_id_delta.(i) + cc) mod 65536 end done; !index end let parse_range_str str = let len = String.length str in let last = ref str.[0] in let offset = ref 1 in let lut = Hashtbl.create 0 in if len = 1 then Hashtbl.add lut (Char.code !last) true else while !offset < len do let cur = str.[!offset] in begin match cur with | '-' when !last = '\\' -> Hashtbl.replace lut (Char.code '-') true; incr offset; | c when !offset = len - 1 -> Hashtbl.replace lut (Char.code !last) true; Hashtbl.replace lut (Char.code cur) true; incr offset | '-' -> let first, last = match Char.code !last, Char.code str.[!offset + 1] with | first,last when first > last -> last,first | first,last -> first,last in for i = first to last do Hashtbl.add lut i true done; offset := !offset + 2; | c -> Hashtbl.replace lut (Char.code !last) true; incr offset; end; last := cur; done; lut let build_lut ttf range_str = let lut = Hashtbl.create 0 in Hashtbl.add lut 0 0; Hashtbl.add lut 1 1; Hashtbl.add lut 2 2; let add_character = if range_str = "" then fun k v -> Hashtbl.replace lut k v else begin let range = parse_range_str range_str in fun k v -> if Hashtbl.mem range k then Hashtbl.replace lut k v end in let make_cmap4_map c4 = let seg_count = c4.c4_seg_count_x2 / 2 in for i = 0 to seg_count - 1 do for j = c4.c4_start_code.(i) to c4.c4_end_code.(i) do let index = map_char_code j c4 in add_character j index; done; done in (* let make_cmap12_map c12 = List.iter (fun group -> let rec loop cc gi = add_character cc gi; if cc < (Int32.to_int group.c12g_end_char_code) then loop (cc + 1) (gi + 1) in loop (Int32.to_int group.c12g_start_char_code) (Int32.to_int group.c12g_start_glyph_code) ) c12.c12_groups in *) List.iter (fun st -> match st.cs_def with | Cmap0 c0 -> Array.iteri (fun i c -> add_character i (int_of_char c)) c0.c0_glyph_index_array; | Cmap4 c4 -> make_cmap4_map c4; | Cmap12 c12 -> (* TODO: this causes an exception with some fonts: Fatal error: exception IO.Overflow("write_ui16") *) (* make_cmap12_map ctx lut c12; *) () | _ -> (* TODO *) () ) ttf.ttf_cmap.cmap_subtables; luthaxe-3.0~svn6707/libs/ttflib/tTFData.ml0000644000175000017500000001506312172015137020246 0ustar bdefreesebdefreesetype header = { hd_major_version : int; hd_minor_version : int; hd_num_tables : int; hd_search_range : int; hd_entry_selector : int; hd_range_shift : int; } type entry = { entry_table_name : string; entry_checksum : int32; entry_offset : int32; entry_length: int32; } (* GLYF *) type glyf_header = { gh_num_contours : int; gh_xmin : int; gh_ymin : int; gh_xmax : int; gh_ymax : int; } type glyf_simple = { gs_end_pts_of_contours : int array; gs_instruction_length : int; gs_instructions : char array; gs_flags : int array; gs_x_coordinates : int array; gs_y_coordinates : int array; } type transformation_option = | NoScale | Scale of float | ScaleXY of float * float | ScaleMatrix of float * float * float * float type glyf_component = { gc_flags : int; gc_glyf_index : int; gc_arg1 : int; gc_arg2 : int; gc_transformation : transformation_option; } type glyf = | TGlyfSimple of glyf_header * glyf_simple | TGlyfComposite of glyf_header * glyf_component list | TGlyfNull (* HMTX *) type hmtx = { advance_width : int; left_side_bearing : int; } (* CMAP *) type cmap_subtable_header = { csh_platform_id : int; csh_platform_specific_id : int; csh_offset : int32; } type cmap_format_0 = { c0_format : int; c0_length : int; c0_language : int; c0_glyph_index_array : char array; } type cmap_format_4 = { c4_format : int; c4_length : int; c4_language : int; c4_seg_count_x2 : int; c4_search_range : int; c4_entry_selector : int; c4_range_shift : int; c4_end_code : int array; c4_reserved_pad : int; c4_start_code : int array; c4_id_delta : int array; c4_id_range_offset : int array; c4_glyph_index_array : int array; } type cmap_format_6 = { c6_format : int; c6_length : int; c6_language : int; c6_first_code : int; c6_entry_count : int; c6_glyph_index_array : int array; } type cmap_format_12_group = { c12g_start_char_code : int32; c12g_end_char_code : int32; c12g_start_glyph_code : int32; } type cmap_format_12 = { c12_format : int32; c12_length : int32; c12_language : int32; c12_num_groups : int32; c12_groups : cmap_format_12_group list; } type cmap_subtable_def = | Cmap0 of cmap_format_0 | Cmap4 of cmap_format_4 | Cmap6 of cmap_format_6 | Cmap12 of cmap_format_12 | CmapUnk of string type cmap_subtable = { cs_header : cmap_subtable_header; cs_def : cmap_subtable_def; } type cmap = { cmap_version : int; cmap_num_subtables : int; cmap_subtables : cmap_subtable list; } (* KERN *) type kern_subtable_header = { ksh_length : int32; ksh_coverage : int; ksh_tuple_index : int; } type kern_pair = { kern_left : int; kern_right : int; kern_value : int; } type kern_format_0 = { k0_num_pairs : int; k0_search_range : int; k0_entry_selector : int; k0_range_shift : int; k0_pairs : kern_pair list; } type kern_format_2 = { k2_row_width : int; k2_left_offset_table : int; k2_right_offset_table : int; k2_array : int; k2_first_glyph : int; k2_num_glyphs : int; k2_offsets : int list; } type kern_subtable_def = | Kern0 of kern_format_0 | Kern2 of kern_format_2 type kern_subtable = { ks_header : kern_subtable_header; ks_def : kern_subtable_def; } type kern = { kern_version : int32; kern_num_tables : int32; kern_subtables : kern_subtable list; } (* NAME *) type name_record = { nr_platform_id : int; nr_platform_specific_id : int; nr_language_id : int; nr_name_id : int; nr_length : int; nr_offset : int; mutable nr_value : string; } type name = { name_format : int; name_num_records : int; name_offset : int; name_records : name_record array; } (* HEAD *) type head = { hd_version : int32; hd_font_revision : int32; hd_checksum_adjustment : int32; hd_magic_number : int32; hd_flags : int; hd_units_per_em : int; hd_created : float; hd_modified : float; hd_xmin : int; hd_ymin : int; hd_xmax : int; hd_ymax : int; hd_mac_style : int; hd_lowest_rec_ppem : int; hd_font_direction_hint : int; hd_index_to_loc_format : int; hd_glyph_data_format : int; } (* HHEA *) type hhea = { hhea_version : int32; hhea_ascent : int; hhea_descent : int; hhea_line_gap : int; hhea_advance_width_max : int; hhea_min_left_side_bearing : int; hhea_min_right_side_bearing : int; hhea_x_max_extent : int; hhea_caret_slope_rise : int; hhea_caret_slope_run : int; hhea_caret_offset : int; hhea_reserved : string; hhea_metric_data_format : int; hhea_number_of_hmetrics :int; } (* LOCA *) type loca = int32 array (* MAXP *) type maxp = { maxp_version_number : int32; maxp_num_glyphs : int; maxp_max_points : int; maxp_max_contours : int; maxp_max_component_points : int; maxp_max_component_contours : int; maxp_max_zones : int; maxp_max_twilight_points : int; maxp_max_storage : int; maxp_max_function_defs : int; maxp_max_instruction_defs :int; maxp_max_stack_elements : int; maxp_max_size_of_instructions :int; maxp_max_component_elements :int; maxp_max_component_depth :int; } (* OS2 *) type os2 = { os2_version : int; os2_x_avg_char_width : int; os2_us_weight_class : int; os2_us_width_class : int; os2_fs_type : int; os2_y_subscript_x_size : int; os2_y_subscript_y_size : int; os2_y_subscript_x_offset : int; os2_y_subscript_y_offset : int; os2_y_superscript_x_size : int; os2_y_superscript_y_size : int; os2_y_superscript_x_offset : int; os2_y_superscript_y_offset : int; os2_y_strikeout_size : int; os2_y_strikeout_position : int; os2_s_family_class : int; os2_b_family_type : int; os2_b_serif_style : int; os2_b_weight : int; os2_b_proportion : int; os2_b_contrast : int; os2_b_stroke_variation : int; os2_b_arm_style : int; os2_b_letterform : int; os2_b_midline : int; os2_b_x_height : int; os2_ul_unicode_range_1 : int32; os2_ul_unicode_range_2 : int32; os2_ul_unicode_range_3 : int32; os2_ul_unicode_range_4 : int32; os2_ach_vendor_id : int32; os2_fs_selection : int; os2_us_first_char_index : int; os2_us_last_char_index : int; os2_s_typo_ascender : int; os2_s_typo_descender : int; os2_s_typo_line_gap : int; os2_us_win_ascent : int; os2_us_win_descent : int; } type ttf = { ttf_header : header; ttf_font_name : string; ttf_directory: (string,entry) Hashtbl.t; ttf_glyfs : glyf array; ttf_hmtx : hmtx array; ttf_cmap : cmap; ttf_head : head; ttf_loca : loca; ttf_hhea : hhea; ttf_maxp : maxp; ttf_name : name; ttf_os2 : os2; ttf_kern : kern option; }haxe-3.0~svn6707/libs/ttflib/tTFParser.ml0000644000175000017500000005011712172015137020630 0ustar bdefreesebdefreeseopen TTFData open IO type ctx = { file : Pervasives.in_channel; ch : input; mutable entry : entry; } let rd16 = BigEndian.read_i16 let rdu16 = BigEndian.read_ui16 let rd32 = BigEndian.read_i32 let rd32r = BigEndian.read_real_i32 let parse_header ctx = let ch = ctx.ch in let major_version = rdu16 ch in let minor_version = rdu16 ch in let num_tables = rdu16 ch in let search_range = rdu16 ch in let entry_selector = rdu16 ch in let range_shift = rdu16 ch in { hd_major_version = major_version; hd_minor_version = minor_version; hd_num_tables = num_tables; hd_search_range = search_range; hd_entry_selector = entry_selector; hd_range_shift = range_shift; } let parse_directory ctx header = let ch = ctx.ch in let directory = Hashtbl.create 0 in for i = 0 to header.hd_num_tables - 1 do let name = nread ch 4 in let cs = rd32r ch in let off = rd32r ch in let length = rd32r ch in Hashtbl.add directory name { entry_table_name = name; entry_checksum = cs; entry_offset = off; entry_length = length; } done; directory let parse_head_table ctx = let ch = ctx.ch in let version = rd32r ch in let font_revision = rd32r ch in let checksum_adjustment = rd32r ch in let magic_number = rd32r ch in let flags = rdu16 ch in let units_per_em = rdu16 ch in let created = BigEndian.read_double ch in let modified = BigEndian.read_double ch in let xmin = rd16 ch in let ymin = rd16 ch in let xmax = rd16 ch in let ymax = rd16 ch in let mac_style = rdu16 ch in let lowest_rec_ppem = rdu16 ch in let font_direction_hint = rd16 ch in let index_to_loc_format = rd16 ch in let glyph_data_format = rd16 ch in { hd_version = version; hd_font_revision = font_revision; hd_checksum_adjustment = checksum_adjustment; hd_magic_number = magic_number; hd_flags = flags; hd_units_per_em = units_per_em; hd_created = created; hd_modified = modified; hd_xmin = xmin; hd_ymin = ymin; hd_xmax = xmax; hd_ymax = ymax; hd_mac_style = mac_style; hd_lowest_rec_ppem = lowest_rec_ppem; hd_font_direction_hint = font_direction_hint; hd_index_to_loc_format = index_to_loc_format; hd_glyph_data_format = glyph_data_format; } let parse_hhea_table ctx = let ch = ctx.ch in let version = rd32r ch in let ascender = rd16 ch in let descender = rd16 ch in let line_gap = rd16 ch in let advance_width_max = rdu16 ch in let min_left_side_bearing = rd16 ch in let min_right_side_bearing = rd16 ch in let x_max_extent = rd16 ch in let caret_slope_rise = rd16 ch in let caret_slope_run = rd16 ch in let caret_offset = rd16 ch in let reserved = nread ch 8 in let metric_data_format = rd16 ch in let number_of_hmetrics = rdu16 ch in { hhea_version = version; hhea_ascent = ascender; hhea_descent = descender; hhea_line_gap = line_gap; hhea_advance_width_max = advance_width_max; hhea_min_left_side_bearing = min_left_side_bearing; hhea_min_right_side_bearing = min_right_side_bearing; hhea_x_max_extent = x_max_extent; hhea_caret_slope_rise = caret_slope_rise; hhea_caret_slope_run = caret_slope_run; hhea_caret_offset = caret_offset; hhea_reserved = reserved; hhea_metric_data_format = metric_data_format; hhea_number_of_hmetrics = number_of_hmetrics; } let parse_maxp_table ctx = let ch = ctx.ch in let version_number = rd32r ch in let num_glyphs = rdu16 ch in let max_points = rdu16 ch in let max_contours = rdu16 ch in let max_component_points = rdu16 ch in let max_component_contours = rdu16 ch in let max_zones = rdu16 ch in let max_twilight_points = rdu16 ch in let max_storage = rdu16 ch in let max_function_defs = rdu16 ch in let max_instruction_defs = rdu16 ch in let max_stack_elements = rdu16 ch in let max_size_of_instructions = rdu16 ch in let max_component_elements = rdu16 ch in let max_component_depth = rdu16 ch in { maxp_version_number = version_number; maxp_num_glyphs = num_glyphs; maxp_max_points = max_points; maxp_max_contours = max_contours; maxp_max_component_points = max_component_points; maxp_max_component_contours = max_component_contours; maxp_max_zones = max_zones; maxp_max_twilight_points = max_twilight_points; maxp_max_storage = max_storage; maxp_max_function_defs = max_function_defs; maxp_max_instruction_defs = max_instruction_defs; maxp_max_stack_elements = max_stack_elements; maxp_max_size_of_instructions = max_size_of_instructions; maxp_max_component_elements = max_component_elements; maxp_max_component_depth = max_component_depth; } let parse_loca_table head maxp ctx = let ch = ctx.ch in if head.hd_index_to_loc_format = 0 then Array.init (maxp.maxp_num_glyphs + 1) (fun _ -> Int32.of_int ((rdu16 ch) * 2)) else Array.init (maxp.maxp_num_glyphs + 1) (fun _ -> rd32r ch) let parse_hmtx_table maxp hhea ctx = let ch = ctx.ch in let last_advance_width = ref 0 in (* check me 1/2*) Array.init maxp.maxp_num_glyphs (fun i -> let advance_width = if i > hhea.hhea_number_of_hmetrics-1 then (* check me 2/2*) !last_advance_width else rdu16 ch in last_advance_width := advance_width; let left_side_bearing = rd16 ch in { advance_width = advance_width; left_side_bearing = left_side_bearing; } ) let parse_cmap_table ctx = let ch = ctx.ch in let version = rdu16 ch in let num_subtables = rdu16 ch in let dir = ExtList.List.init num_subtables (fun _ -> let platform_id = rdu16 ch in let platform_specific_id = rdu16 ch in let offset = rd32r ch in { csh_platform_id = platform_id; csh_platform_specific_id = platform_specific_id; csh_offset = offset; } ) in let dir = List.stable_sort (fun csh1 csh2 -> if csh1.csh_platform_id < csh2.csh_platform_id then -1 else if csh1.csh_platform_id > csh2.csh_platform_id then 1 else compare csh1.csh_platform_specific_id csh2.csh_platform_specific_id ) dir in let parse_sub entry = seek_in ctx.file ((Int32.to_int ctx.entry.entry_offset) + (Int32.to_int entry.csh_offset)); let format = rdu16 ch in let def = match format with | 0 -> let length = rdu16 ch in let language = rdu16 ch in let glyph_index = Array.init 256 (fun _ -> read ch) in Cmap0 { c0_format = 0; c0_length = length; c0_language = language; c0_glyph_index_array = glyph_index; } | 4 -> let length = rdu16 ch in let language = rdu16 ch in let seg_count_x2 = rdu16 ch in let seg_count = seg_count_x2 / 2 in let search_range = rdu16 ch in let entry_selector = rdu16 ch in let range_shift = rdu16 ch in let end_code = Array.init seg_count (fun _ -> rdu16 ch) in let reserved = rdu16 ch in assert (reserved = 0); let start_code = Array.init seg_count (fun _ -> rdu16 ch) in let id_delta = Array.init seg_count (fun _ -> rdu16 ch) in let id_range_offset = Array.init seg_count (fun _ -> rdu16 ch) in let count = length - (8 * seg_count + 16) / 2 in let glyph_index = Array.init count (fun _ -> rdu16 ch) in Cmap4 { c4_format = format; c4_length = length; c4_language = language; c4_seg_count_x2 = seg_count_x2; c4_search_range = search_range; c4_entry_selector = entry_selector; c4_range_shift = range_shift; c4_end_code = end_code; c4_reserved_pad = reserved; c4_start_code = start_code; c4_id_delta = id_delta; c4_id_range_offset = id_range_offset; c4_glyph_index_array = glyph_index; } | 6 -> let length = rdu16 ch in let language = rdu16 ch in let first_code = rdu16 ch in let entry_count = rdu16 ch in let glyph_index = Array.init entry_count (fun _ -> rdu16 ch) in Cmap6 { c6_format = format; c6_length = length; c6_language = language; c6_first_code = first_code; c6_entry_count = entry_count; c6_glyph_index_array = glyph_index; } | 12 -> ignore (rd16 ch); let length = rd32r ch in let language = rd32r ch in let num_groups = rd32r ch in let groups = ExtList.List.init (Int32.to_int num_groups) (fun _ -> let start = rd32r ch in let stop = rd32r ch in let start_glyph = rd32r ch in { c12g_start_char_code = start; c12g_end_char_code = stop; c12g_start_glyph_code = start_glyph; } ) in Cmap12 { c12_format = Int32.of_int 12; c12_length = length; c12_language = language; c12_num_groups = num_groups; c12_groups = groups; } | x -> failwith ("Not implemented format: " ^ (string_of_int x)); in { cs_def = def; cs_header = entry; } in { cmap_version = version; cmap_num_subtables = num_subtables; cmap_subtables = List.map parse_sub dir; } let parse_glyf_table maxp loca cmap hmtx ctx = let ch = ctx.ch in let parse_glyf i = seek_in ctx.file ((Int32.to_int ctx.entry.entry_offset) + (Int32.to_int loca.(i))); let num_contours = rd16 ch in let xmin = rd16 ch in let ymin = rd16 ch in let xmax = rd16 ch in let ymax = rd16 ch in let header = { gh_num_contours = num_contours; gh_xmin = xmin; gh_ymin = ymin; gh_xmax = xmax; gh_ymax = ymax; } in if num_contours >= 0 then begin let num_points = ref 0 in let end_pts_of_contours = Array.init num_contours (fun i -> let v = rdu16 ch in if i = num_contours - 1 then num_points := v + 1; v ) in let instruction_length = rdu16 ch in let instructions = Array.init instruction_length (fun _ -> read ch ) in let flags = DynArray.create () in let rec loop index = if index >= !num_points then () else begin let v = read_byte ch in let incr = if (v land 8) == 0 then begin DynArray.add flags v; 1 end else begin let r = (int_of_char (read ch)) in for i = 0 to r do DynArray.add flags v done; r + 1 end in loop (index + incr) end in loop 0; assert (DynArray.length flags = !num_points); let x_coordinates = Array.init !num_points (fun i -> let flag = DynArray.get flags i in if flag land 0x10 <> 0 then begin if flag land 0x02 <> 0 then read_byte ch else 0 end else begin if flag land 0x02 <> 0 then -read_byte ch else rd16 ch end ) in let y_coordinates = Array.init !num_points (fun i -> let flag = DynArray.get flags i in if flag land 0x20 <> 0 then begin if flag land 0x04 <> 0 then read_byte ch else 0 end else begin if flag land 0x04 <> 0 then -read_byte ch else rd16 ch end; ) in TGlyfSimple (header, { gs_end_pts_of_contours = end_pts_of_contours; gs_instruction_length = instruction_length; gs_instructions = instructions; gs_flags = DynArray.to_array flags; gs_x_coordinates = x_coordinates; gs_y_coordinates = y_coordinates; }) end else if num_contours = -1 then begin let acc = DynArray.create () in let rec loop () = let flags = rdu16 ch in let glyph_index = rdu16 ch in let arg1,arg2 = if flags land 1 <> 0 then begin let arg1 = rd16 ch in let arg2 = rd16 ch in arg1,arg2 end else begin let arg1 = read_byte ch in let arg2 = read_byte ch in arg1,arg2 end in let fmt214 i = (float_of_int i) /. (float_of_int 0x4000) in let fmode = if flags land 8 <> 0 then Scale (fmt214 (rd16 ch)) else if flags land 64 <> 0 then begin let s1 = fmt214 (rd16 ch) in let s2 = fmt214 (rd16 ch) in ScaleXY (s1,s2) end else if flags land 128 <> 0 then begin let a = fmt214 (rd16 ch) in let b = fmt214 (rd16 ch) in let c = fmt214 (rd16 ch) in let d = fmt214 (rd16 ch) in ScaleMatrix (a,b,c,d) end else NoScale in DynArray.add acc { gc_flags = flags; gc_glyf_index = glyph_index; gc_arg1 = if flags land 2 <> 0 then arg1 else 0; gc_arg2 = if flags land 2 <> 0 then arg2 else 0; gc_transformation = fmode; }; if flags land 0x20 <> 0 then loop (); in loop (); TGlyfComposite (header,(DynArray.to_list acc)) end else failwith "Unknown Glyf" in Array.init maxp.maxp_num_glyphs (fun i -> let len = (Int32.to_int loca.(i + 1)) - (Int32.to_int loca.(i)) in if len > 0 then parse_glyf i else TGlyfNull ) let parse_kern_table ctx = let ch = ctx.ch in let version = Int32.of_int (rd16 ch) in let num_tables = Int32.of_int (rd16 ch) in let tables = ExtList.List.init (Int32.to_int num_tables) (fun _ -> let length = Int32.of_int (rdu16 ch) in let tuple_index = rdu16 ch in let coverage = rdu16 ch in let def = match coverage lsr 8 with | 0 -> let num_pairs = rdu16 ch in let search_range = rdu16 ch in let entry_selector = rdu16 ch in let range_shift = rdu16 ch in let kerning_pairs = ExtList.List.init num_pairs (fun _ -> let left = rdu16 ch in let right = rdu16 ch in let value = rd16 ch in { kern_left = left; kern_right = right; kern_value = value; } ) in Kern0 { k0_num_pairs = num_pairs; k0_search_range = search_range; k0_entry_selector = entry_selector; k0_range_shift = range_shift; k0_pairs = kerning_pairs; } | 2 -> let row_width = rdu16 ch in let left_offset_table = rdu16 ch in let right_offset_table = rdu16 ch in let array_offset = rdu16 ch in let first_glyph = rdu16 ch in let num_glyphs = rdu16 ch in let offsets = ExtList.List.init num_glyphs (fun _ -> rdu16 ch ) in Kern2 { k2_row_width = row_width; k2_left_offset_table = left_offset_table; k2_right_offset_table = right_offset_table; k2_array = array_offset; k2_first_glyph = first_glyph; k2_num_glyphs = num_glyphs; k2_offsets = offsets; } | i -> failwith ("Unknown kerning: " ^ (string_of_int i)); in { ks_def = def; ks_header = { ksh_length = length; ksh_coverage = coverage; ksh_tuple_index = tuple_index; } } ) in { kern_version = version; kern_num_tables = num_tables; kern_subtables = tables; } let parse_name_table ctx = let ch = ctx.ch in let format = rdu16 ch in let num_records = rdu16 ch in let offset = rdu16 ch in let records = Array.init num_records (fun _ -> let platform_id = rdu16 ch in let platform_specific_id = rdu16 ch in let language_id = rdu16 ch in let name_id = rdu16 ch in let length = rdu16 ch in let offset = rdu16 ch in { nr_platform_id = platform_id; nr_platform_specific_id = platform_specific_id; nr_language_id = language_id; nr_name_id = name_id; nr_length = length; nr_offset = offset; nr_value = ""; } ) in let ttf_name = ref "" in (* TODO: use real utf16 conversion *) let set_name n = let l = ExtList.List.init (String.length n / 2) (fun i -> String.make 1 n.[i * 2 + 1]) in ttf_name := String.concat "" l in let records = Array.map (fun r -> seek_in ctx.file ((Int32.to_int ctx.entry.entry_offset) + offset + r.nr_offset); r.nr_value <- nread ch r.nr_length; if r.nr_name_id = 4 && r.nr_platform_id = 3 || r.nr_platform_id = 0 then set_name r.nr_value; r ) records in { name_format = format; name_num_records = num_records; name_offset = offset; name_records = records; },!ttf_name let parse_os2_table ctx = let ch = ctx.ch in let version = rdu16 ch in let x_avg_char_width = rd16 ch in let us_weight_class = rdu16 ch in let us_width_class = rdu16 ch in let fs_type = rd16 ch in let y_subscript_x_size = rd16 ch in let y_subscript_y_size = rd16 ch in let y_subscript_x_offset = rd16 ch in let y_subscript_y_offset = rd16 ch in let y_superscript_x_size = rd16 ch in let y_superscript_y_size = rd16 ch in let y_superscript_x_offset = rd16 ch in let y_superscript_y_offset = rd16 ch in let y_strikeout_size = rd16 ch in let y_strikeout_position = rd16 ch in let s_family_class = rd16 ch in let b_family_type = read_byte ch in let b_serif_style = read_byte ch in let b_weight = read_byte ch in let b_proportion = read_byte ch in let b_contrast = read_byte ch in let b_stroke_variation = read_byte ch in let b_arm_style = read_byte ch in let b_letterform = read_byte ch in let b_midline = read_byte ch in let b_x_height = read_byte ch in let ul_unicode_range_1 = rd32r ch in let ul_unicode_range_2 = rd32r ch in let ul_unicode_range_3 = rd32r ch in let ul_unicode_range_4 = rd32r ch in let ach_vendor_id = rd32r ch in let fs_selection = rd16 ch in let us_first_char_index = rdu16 ch in let us_last_char_index = rdu16 ch in let s_typo_ascender = rd16 ch in let s_typo_descender = rd16 ch in let s_typo_line_gap = rd16 ch in let us_win_ascent = rdu16 ch in let us_win_descent = rdu16 ch in { os2_version = version; os2_x_avg_char_width = x_avg_char_width; os2_us_weight_class = us_weight_class; os2_us_width_class = us_width_class; os2_fs_type = fs_type; os2_y_subscript_x_size = y_subscript_x_size; os2_y_subscript_y_size = y_subscript_y_size; os2_y_subscript_x_offset = y_subscript_x_offset; os2_y_subscript_y_offset = y_subscript_y_offset; os2_y_superscript_x_size = y_superscript_x_size; os2_y_superscript_y_size = y_superscript_y_size; os2_y_superscript_x_offset = y_superscript_x_offset; os2_y_superscript_y_offset = y_superscript_y_offset; os2_y_strikeout_size = y_strikeout_size; os2_y_strikeout_position = y_strikeout_position; os2_s_family_class = s_family_class; os2_b_family_type = b_family_type; os2_b_serif_style = b_serif_style; os2_b_weight = b_weight; os2_b_proportion = b_proportion; os2_b_contrast = b_contrast; os2_b_stroke_variation = b_stroke_variation; os2_b_arm_style = b_arm_style; os2_b_letterform = b_letterform; os2_b_midline = b_midline; os2_b_x_height = b_x_height; os2_ul_unicode_range_1 = ul_unicode_range_1; os2_ul_unicode_range_2 = ul_unicode_range_2; os2_ul_unicode_range_3 = ul_unicode_range_3; os2_ul_unicode_range_4 = ul_unicode_range_4; os2_ach_vendor_id = ach_vendor_id; os2_fs_selection = fs_selection; os2_us_first_char_index = us_first_char_index; os2_us_last_char_index = us_last_char_index; os2_s_typo_ascender = s_typo_ascender; os2_s_typo_descender = s_typo_descender; os2_s_typo_line_gap = s_typo_line_gap; os2_us_win_ascent = us_win_ascent; os2_us_win_descent = us_win_descent; } let parse file : ttf = let ctx = { file = file; ch = input_channel file; entry = { entry_table_name = ""; entry_offset = Int32.of_int 0; entry_length = Int32.of_int 0; entry_checksum = Int32.of_int 0; } } in let header = parse_header ctx in let directory = parse_directory ctx header in let parse_table entry f = seek_in file (Int32.to_int entry.entry_offset); ctx.entry <- entry; f ctx in let parse_req_table name f = try let entry = Hashtbl.find directory name in parse_table entry f with Not_found -> failwith (Printf.sprintf "Required table %s could not be found" name) in let parse_opt_table name f = try let entry = Hashtbl.find directory name in Some (parse_table entry f) with Not_found -> None in let head = parse_req_table "head" parse_head_table in let hhea = parse_req_table "hhea" parse_hhea_table in let maxp = parse_req_table "maxp" parse_maxp_table in let loca = parse_req_table "loca" (parse_loca_table head maxp) in let hmtx = parse_req_table "hmtx" (parse_hmtx_table maxp hhea) in let cmap = parse_req_table "cmap" (parse_cmap_table) in let glyfs = parse_req_table "glyf" (parse_glyf_table maxp loca cmap hmtx) in let kern = parse_opt_table "kern" (parse_kern_table) in let name,ttf_name = parse_req_table "name" (parse_name_table) in let os2 = parse_req_table "OS/2" (parse_os2_table) in { ttf_header = header; ttf_font_name = ttf_name; ttf_directory = directory; ttf_head = head; ttf_hhea = hhea; ttf_maxp = maxp; ttf_loca = loca; ttf_hmtx = hmtx; ttf_cmap = cmap; ttf_glyfs = glyfs; ttf_name = name; ttf_os2 = os2; ttf_kern = kern; }haxe-3.0~svn6707/libs/javalib/0000755000175000017500000000000012172015140016536 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/javalib/Makefile0000644000175000017500000000026412172015140020200 0ustar bdefreesebdefreeseall: ocamlopt -g -I ../extlib -a -o java.cmxa jData.ml jReader.ml clean: rm -rf java.cmxa java.lib java.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi) haxe-3.0~svn6707/libs/javalib/jReader.ml0000644000175000017500000004475012172015140020456 0ustar bdefreesebdefreese(* * This file is part of JavaLib * Copyright (c)2004-2012 Nicolas Cannasse and Caue Waneck * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open JData;; open IO.BigEndian;; open ExtString;; open ExtList;; exception Error_message of string let error msg = raise (Error_message msg) let get_reference_type i constid = match i with | 1 -> RGetField | 2 -> RGetStatic | 3 -> RPutField | 4 -> RPutStatic | 5 -> RInvokeVirtual | 6 -> RInvokeStatic | 7 -> RInvokeSpecial | 8 -> RNewInvokeSpecial | 9 -> RInvokeInterface | _ -> error (string_of_int constid ^ ": Invalid reference type " ^ string_of_int i) let parse_constant max idx ch = let cid = IO.read_byte ch in let error() = error (string_of_int idx ^ ": Invalid constant " ^ string_of_int cid) in let index() = let n = read_ui16 ch in if n = 0 || n >= max then error(); n in match cid with | 7 -> KClass (index()) | 9 -> let n1 = index() in let n2 = index() in KFieldRef (n1,n2) | 10 -> let n1 = index() in let n2 = index() in KMethodRef (n1,n2) | 11 -> let n1 = index() in let n2 = index() in KInterfaceMethodRef (n1,n2) | 8 -> KString (index()) | 3 -> KInt (read_real_i32 ch) | 4 -> let f = Int32.float_of_bits (read_real_i32 ch) in KFloat f | 5 -> KLong (read_i64 ch) | 6 -> KDouble (read_double ch) | 12 -> let n1 = index() in let n2 = index() in KNameAndType (n1, n2) | 1 -> let len = read_ui16 ch in let str = IO.nread ch len in (* TODO: correctly decode modified UTF8 *) KUtf8String str | 15 -> let reft = get_reference_type (read_ui16 ch) idx in let dynref = index() in KMethodHandle (reft, dynref) | 16 -> KMethodType (index()) | 18 -> let bootstrapref = read_ui16 ch in (* not index *) let nametyperef = index() in KInvokeDynamic (bootstrapref, nametyperef) | n -> error() let expand_path s = let rec loop remaining acc = match remaining with | name :: [] -> List.rev acc, name | v :: tl -> loop tl (v :: acc) | _ -> assert false in loop (String.nsplit s "/") [] let rec parse_type_parameter_part s = match s.[0] with | '*' -> TAny, 1 | c -> let wildcard, i = match c with | '+' -> WExtends, 1 | '-' -> WSuper, 1 | _ -> WNone, 0 in let jsig, l = parse_signature_part (String.sub s i (String.length s - 1)) in (TType (wildcard, jsig), l + i) and parse_signature_part s = let len = String.length s in if len = 0 then raise Exit; match s.[0] with | 'B' -> TByte, 1 | 'C' -> TChar, 1 | 'D' -> TDouble, 1 | 'F' -> TFloat, 1 | 'I' -> TInt, 1 | 'J' -> TLong, 1 | 'S' -> TShort, 1 | 'Z' -> TBool, 1 | 'L' -> (try let orig_s = s in let rec loop start i acc = match s.[i] with | '/' -> loop (i + 1) (i + 1) (String.sub s start (i - start) :: acc) | ';' | '.' -> List.rev acc, (String.sub s start (i - start)), [], (i) | '<' -> let name = String.sub s start (i - start) in let rec loop_params i acc = let s = String.sub s i (len - i) in match s.[0] with | '>' -> List.rev acc, i + 1 | _ -> let tp, l = parse_type_parameter_part s in loop_params (l + i) (tp :: acc) in let params, _end = loop_params (i + 1) [] in List.rev acc, name, params, (_end) | _ -> loop start (i+1) acc in let pack, name, params, _end = loop 1 1 [] in let rec loop_inner i acc = match s.[i] with | '.' -> let pack, name, params, _end = loop (i+1) (i+1) [] in if pack <> [] then error ("Inner types must not define packages. For '" ^ orig_s ^ "'."); loop_inner _end ( (name,params) :: acc ) | ';' -> List.rev acc, i + 1 | c -> error ("End of complex type signature expected after type parameter. Got '" ^ Char.escaped c ^ "' for '" ^ orig_s ^ "'." ); in let inners, _end = loop_inner _end [] in match inners with | [] -> TObject((pack,name), params), _end | _ -> TObjectInner( pack, (name,params) :: inners ), _end with Invalid_string -> raise Exit) | '[' -> let p = ref 1 in while !p < String.length s && s.[!p] >= '0' && s.[!p] <= '9' do incr p; done; let size = (if !p > 1 then Some (int_of_string (String.sub s 1 (!p - 1))) else None) in let s , l = parse_signature_part (String.sub s !p (String.length s - !p)) in TArray (s,size) , l + !p | '(' -> let p = ref 1 in let args = ref [] in while !p < String.length s && s.[!p] <> ')' do let a , l = parse_signature_part (String.sub s !p (String.length s - !p)) in args := a :: !args; p := !p + l; done; incr p; if !p >= String.length s then raise Exit; let ret , l = (match s.[!p] with 'V' -> None , 1 | _ -> let s, l = parse_signature_part (String.sub s !p (String.length s - !p)) in Some s, l ) in TMethod (List.rev !args,ret) , !p + l | 'T' -> (try let s1 , _ = String.split s ";" in let len = String.length s1 in TTypeParameter (String.sub s1 1 (len - 1)) , len + 1 with Invalid_string -> raise Exit) | _ -> raise Exit let parse_signature s = try let sign , l = parse_signature_part s in if String.length s <> l then raise Exit; sign with Exit -> error ("Invalid signature '" ^ s ^ "'") let parse_method_signature s = match parse_signature s with | (TMethod m) -> m | _ -> error ("Unexpected signature '" ^ s ^ "'. Expecting method") let parse_formal_type_params s = match s.[0] with | '<' -> let rec read_id i = match s.[i] with | ':' | '>' -> i | _ -> read_id (i + 1) in let len = String.length s in let rec parse_params idx acc = let idi = read_id (idx + 1) in let id = String.sub s (idx + 1) (idi - idx - 1) in (* next must be a : *) (match s.[idi] with | ':' -> () | _ -> error ("Invalid formal type signature character: " ^ Char.escaped s.[idi] ^ " ; from " ^ s)); let ext, l = match s.[idi + 1] with | ':' | '>' -> None, idi + 1 | _ -> let sgn, l = parse_signature_part (String.sub s (idi + 1) (len - idi - 1)) in Some sgn, l + idi + 1 in let rec loop idx acc = match s.[idx] with | ':' -> let ifacesig, ifacei = parse_signature_part (String.sub s (idx + 1) (len - idx - 1)) in loop (idx + ifacei + 1) (ifacesig :: acc) | _ -> acc, idx in let ifaces, idx = loop l [] in let acc = (id, ext, ifaces) :: acc in if s.[idx] = '>' then List.rev acc, idx + 1 else parse_params (idx - 1) acc in parse_params 0 [] | _ -> [], 0 let parse_throws s = let len = String.length s in let rec loop idx acc = if idx > len then raise Exit else if idx = len then acc, idx else match s.[idx] with | '^' -> let tsig, l = parse_signature_part (String.sub s (idx+1) (len - idx - 1)) in loop (idx + l + 1) (tsig :: acc) | _ -> acc, idx in loop 0 [] let parse_complete_method_signature s = try let len = String.length s in let tparams, i = parse_formal_type_params s in let sign, l = parse_signature_part (String.sub s i (len - i)) in let throws, l2 = parse_throws (String.sub s (i+l) (len - i - l)) in if (i + l + l2) <> len then raise Exit; match sign with | TMethod msig -> tparams, msig, throws | _ -> raise Exit with Exit -> error ("Invalid method extended signature '" ^ s ^ "'") let rec expand_constant consts i = let unexpected i = error (string_of_int i ^ ": Unexpected constant type") in let expand_path n = match Array.get consts n with | KUtf8String s -> expand_path s | _ -> unexpected n in let expand_cls n = match expand_constant consts n with | ConstClass p -> p | _ -> unexpected n in let expand_nametype n = match expand_constant consts n with | ConstNameAndType (s,jsig) -> s, jsig | _ -> unexpected n in let expand_string n = match Array.get consts n with | KUtf8String s -> s | _ -> unexpected n in let expand_nametype_m n = match expand_nametype n with | (n, TMethod m) -> n, m | _ -> unexpected n in let expand ncls nt = match expand_cls ncls, expand_nametype nt with | path, (n, m) -> path, n, m in let expand_m ncls nt = match expand_cls ncls, expand_nametype_m nt with | path, (n, m) -> path, n, m in match Array.get consts i with | KClass utf8ref -> ConstClass (expand_path utf8ref) | KFieldRef (classref, nametyperef) -> ConstField (expand classref nametyperef) | KMethodRef (classref, nametyperef) -> ConstMethod (expand_m classref nametyperef) | KInterfaceMethodRef (classref, nametyperef) -> ConstInterfaceMethod (expand_m classref nametyperef) | KString utf8ref -> ConstString (expand_string utf8ref) | KInt i32 -> ConstInt i32 | KFloat f -> ConstFloat f | KLong i64 -> ConstLong i64 | KDouble d -> ConstDouble d | KNameAndType (n, t) -> ConstNameAndType(expand_string n, parse_signature (expand_string t)) | KUtf8String s -> ConstUtf8 s (* TODO: expand UTF8 characters *) | KMethodHandle (reference_type, dynref) -> ConstMethodHandle (reference_type, expand_constant consts dynref) | KMethodType utf8ref -> ConstMethodType (parse_method_signature (expand_string utf8ref)) | KInvokeDynamic (bootstrapref, nametyperef) -> let n, t = expand_nametype nametyperef in ConstInvokeDynamic(bootstrapref, n, t) | KUnusable -> ConstUnusable let parse_access_flags ch all_flags = let fl = read_ui16 ch in let flags = ref [] in let fbit = ref 0 in List.iter (fun f -> if fl land (1 lsl !fbit) <> 0 then begin flags := f :: !flags; if f = JUnusable then error ("Unusable flag: " ^ string_of_int fl) end; incr fbit ) all_flags; (*if fl land (0x4000 - (1 lsl !fbit)) <> 0 then error ("Invalid access flags " ^ string_of_int fl);*) !flags let get_constant c n = if n < 1 || n >= Array.length c then error ("Invalid constant index " ^ string_of_int n); match c.(n) with | ConstUnusable -> error "Unusable constant index"; | x -> x let get_class consts ch = match get_constant consts (read_ui16 ch) with | ConstClass n -> n | _ -> error "Invalid class index" let get_string consts ch = let i = read_ui16 ch in match get_constant consts i with | ConstUtf8 s -> s | _ -> error ("Invalid string index " ^ string_of_int i) let rec parse_element_value consts ch = let tag = IO.read_byte ch in match Char.chr tag with | 'B' | 'C' | 'D' | 'E' | 'F' | 'I' | 'J' | 'S' | 'Z' | 's' -> ValConst (get_constant consts (read_ui16 ch)) | 'e' -> let path = parse_signature (get_string consts ch) in let name = get_string consts ch in ValEnum (path, name) | 'c' -> let name = get_string consts ch in let jsig = if name = "V" then TObject(([], "Void"), []) else parse_signature name in ValClass jsig | '@' -> ValAnnotation (parse_annotation consts ch) | '[' -> let num_vals = read_ui16 ch in ValArray (List.init (num_vals) (fun _ -> parse_element_value consts ch)) | tag -> error ("Invalid element value: '" ^ Char.escaped tag ^ "'") and parse_ann_element consts ch = let name = get_string consts ch in let element_value = parse_element_value consts ch in name, element_value and parse_annotation consts ch = let anntype = parse_signature (get_string consts ch) in let count = read_ui16 ch in { ann_type = anntype; ann_elements = List.init count (fun _ -> parse_ann_element consts ch) } let parse_attribute on_special consts ch = let aname = get_string consts ch in let error() = error ("Malformed attribute " ^ aname) in let alen = read_i32 ch in match aname with | "Deprecated" -> if alen <> 0 then error(); Some (AttrDeprecated) | "RuntimeVisibleAnnotations" -> let anncount = read_ui16 ch in Some (AttrVisibleAnnotations (List.init anncount (fun _ -> parse_annotation consts ch))) | "RuntimeInvisibleAnnotations" -> let anncount = read_ui16 ch in Some (AttrInvisibleAnnotations (List.init anncount (fun _ -> parse_annotation consts ch))) | _ -> let do_default () = Some (AttrUnknown (aname,IO.nread ch alen)) in match on_special with | None -> do_default() | Some fn -> fn consts ch aname alen do_default let parse_attributes ?on_special consts ch count = let rec loop i acc = if i >= count then List.rev acc else match parse_attribute on_special consts ch with | None -> loop (i + 1) acc | Some attrib -> loop (i + 1) (attrib :: acc) in loop 0 [] let parse_field kind consts ch = let all_flags = match kind with | JKField -> [JPublic; JPrivate; JProtected; JStatic; JFinal; JUnusable; JVolatile; JTransient; JSynthetic; JEnum] | JKMethod -> [JPublic; JPrivate; JProtected; JStatic; JFinal; JSynchronized; JBridge; JVarArgs; JNative; JUnusable; JAbstract; JStrict; JSynthetic] in let acc = ref (parse_access_flags ch all_flags) in let name = get_string consts ch in let sign = parse_signature (get_string consts ch) in let jsig = ref sign in let throws = ref [] in let types = ref [] in let constant = ref None in let code = ref None in let attrib_count = read_ui16 ch in let attribs = parse_attributes ~on_special:(fun _ _ aname alen do_default -> match kind, aname with | JKField, "ConstantValue" -> constant := Some (get_constant consts (read_ui16 ch)); None | JKField, "Synthetic" -> if not (List.mem JSynthetic !acc) then acc := !acc @ [JSynthetic]; None | JKField, "Signature" -> let s = get_string consts ch in jsig := parse_signature s; None | JKMethod, "Code" -> (* TODO *) do_default() | JKMethod, "Exceptions" -> let num = read_ui16 ch in throws := List.init num (fun _ -> TObject(get_class consts ch,[])); None | JKMethod, "Signature" -> let s = get_string consts ch in let tp, sgn, thr = parse_complete_method_signature s in if thr <> [] then throws := thr; types := tp; jsig := TMethod(sgn); None | _ -> do_default() ) consts ch attrib_count in { jf_name = name; jf_kind = kind; (* signature, as used by the vm *) jf_vmsignature = sign; (* actual signature, as used in java code *) jf_signature = !jsig; jf_throws = !throws; jf_types = !types; jf_flags = !acc; jf_attributes = attribs; jf_constant = !constant; jf_code = !code; } let parse_class ch = if read_real_i32 ch <> 0xCAFEBABEl then error "Invalid header"; let minorv = read_ui16 ch in let majorv = read_ui16 ch in let constant_count = read_ui16 ch in let const_big = ref true in let consts = Array.init constant_count (fun idx -> if !const_big then begin const_big := false; KUnusable end else let c = parse_constant constant_count idx ch in (match c with KLong _ | KDouble _ -> const_big := true | _ -> ()); c ) in let consts = Array.mapi (fun i _ -> expand_constant consts i) consts in let flags = parse_access_flags ch [JPublic; JUnusable; JUnusable; JUnusable; JFinal; JSuper; JUnusable; JUnusable; JUnusable; JInterface; JAbstract; JUnusable; JSynthetic; JAnnotation; JEnum] in let this = get_class consts ch in let super_idx = read_ui16 ch in let super = match super_idx with | 0 -> TObject((["java";"lang"], "Object"), []); | idx -> match get_constant consts idx with | ConstClass path -> TObject(path,[]) | _ -> error "Invalid super index" in let interfaces = List.init (read_ui16 ch) (fun _ -> TObject (get_class consts ch, [])) in let fields = List.init (read_ui16 ch) (fun _ -> parse_field JKField consts ch) in let methods = List.init (read_ui16 ch) (fun _ -> parse_field JKMethod consts ch) in let inner = ref [] in let types = ref [] in let super = ref super in let interfaces = ref interfaces in let attribs = read_ui16 ch in let attribs = parse_attributes ~on_special:(fun _ _ aname alen do_default -> match aname with | "InnerClasses" -> let count = read_ui16 ch in let classes = List.init count (fun _ -> let inner_ci = get_class consts ch in let outeri = read_ui16 ch in let outer_ci = match outeri with | 0 -> None | _ -> match get_constant consts outeri with | ConstClass n -> Some n | _ -> error "Invalid class index" in let inner_namei = read_ui16 ch in let inner_name = match inner_namei with | 0 -> None | _ -> match get_constant consts inner_namei with | ConstUtf8 s -> Some s | _ -> error ("Invalid string index " ^ string_of_int inner_namei) in let flags = parse_access_flags ch [JPublic; JPrivate; JProtected; JStatic; JFinal; JUnusable; JUnusable; JUnusable; JUnusable; JInterface; JAbstract; JSynthetic; JAnnotation; JEnum] in inner_ci, outer_ci, inner_name, flags ) in inner := classes; None | "Signature" -> let s = get_string consts ch in let formal, idx = parse_formal_type_params s in types := formal; let s = String.sub s idx (String.length s - idx) in let len = String.length s in let sup, idx = parse_signature_part s in let rec loop idx acc = if idx = len then acc else begin let s = String.sub s idx (len - idx) in let iface, i2 = parse_signature_part s in loop (idx + i2) (iface :: acc) end in interfaces := loop idx []; super := sup; None | _ -> do_default() ) consts ch attribs in { cversion = majorv, minorv; cpath = this; csuper = !super; cflags = flags; cinterfaces = !interfaces; cfields = fields; cmethods = methods; cattributes = attribs; cinner_types = !inner; ctypes = !types; } haxe-3.0~svn6707/libs/javalib/jData.ml0000644000175000017500000001776012172015140020126 0ustar bdefreesebdefreese(* * This file is part of JavaLib * Copyright (c)2004-2012 Nicolas Cannasse and Caue Waneck * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type jpath = (string list) * string type jversion = int * int (* minor + major *) (** unqualified names cannot have the characters '.', ';', '[' or '/' *) type unqualified_name = string type jwildcard = | WExtends (* + *) | WSuper (* - *) | WNone type jtype_argument = | TType of jwildcard * jsignature | TAny (* * *) and jsignature = | TByte (* B *) | TChar (* C *) | TDouble (* D *) | TFloat (* F *) | TInt (* I *) | TLong (* J *) | TShort (* S *) | TBool (* Z *) | TObject of jpath * jtype_argument list (* L Classname *) | TObjectInner of (string list) * (string * jtype_argument list) list (* L Classname ClassTypeSignatureSuffix *) | TArray of jsignature * int option (* [ *) | TMethod of jmethod_signature (* ( *) | TTypeParameter of string (* T *) (* ( jsignature list ) ReturnDescriptor (| V | jsignature) *) and jmethod_signature = jsignature list * jsignature option (* InvokeDynamic-specific: Method handle *) type reference_type = | RGetField (* constant must be ConstField *) | RGetStatic (* constant must be ConstField *) | RPutField (* constant must be ConstField *) | RPutStatic (* constant must be ConstField *) | RInvokeVirtual (* constant must be Method *) | RInvokeStatic (* constant must be Method *) | RInvokeSpecial (* constant must be Method *) | RNewInvokeSpecial (* constant must be Method with name *) | RInvokeInterface (* constant must be InterfaceMethod *) (* TODO *) type bootstrap_method = int type jconstant = (** references a class or an interface - jpath must be encoded as StringUtf8 *) | ConstClass of jpath (* tag = 7 *) (** field reference *) | ConstField of (jpath * unqualified_name * jsignature) (* tag = 9 *) (** method reference; string can be special "" and "" values *) | ConstMethod of (jpath * unqualified_name * jmethod_signature) (* tag = 10 *) (** interface method reference *) | ConstInterfaceMethod of (jpath * unqualified_name * jmethod_signature) (* tag = 11 *) (** constant values *) | ConstString of string (* tag = 8 *) | ConstInt of int32 (* tag = 3 *) | ConstFloat of float (* tag = 4 *) | ConstLong of int64 (* tag = 5 *) | ConstDouble of float (* tag = 6 *) (** name and type: used to represent a field or method, without indicating which class it belongs to *) | ConstNameAndType of unqualified_name * jsignature (** UTF8 encoded strings. Note that when reading/writing, take into account Utf8 modifications of java *) (* (http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.4.7) *) | ConstUtf8 of string (** invokeDynamic-specific *) | ConstMethodHandle of (reference_type * jconstant) (* tag = 15 *) | ConstMethodType of jmethod_signature (* tag = 16 *) | ConstInvokeDynamic of (bootstrap_method * unqualified_name * jsignature) (* tag = 18 *) | ConstUnusable type jcode = unit (* TODO *) type jaccess_flag = | JPublic (* 0x0001 *) | JPrivate (* 0x0002 *) | JProtected (* 0x0004 *) | JStatic (* 0x0008 *) | JFinal (* 0x0010 *) | JSynchronized (* 0x0020 *) | JVolatile (* 0x0040 *) | JTransient (* 0x0080 *) (** added if created by the compiler *) | JSynthetic (* 0x1000 *) | JEnum (* 0x4000 *) | JUnusable (* should not be present *) (** class flags *) | JSuper (* 0x0020 *) | JInterface (* 0x0200 *) | JAbstract (* 0x0400 *) | JAnnotation (* 0x2000 *) (** method flags *) | JBridge (* 0x0040 *) | JVarArgs (* 0x0080 *) | JNative (* 0x0100 *) | JStrict (* 0x0800 *) type jaccess = jaccess_flag list (* type parameter name, extends signature, implements signatures *) type jtypes = (string * jsignature option * jsignature list) list type jannotation = { ann_type : jsignature; ann_elements : (string * jannotation_value) list; } and jannotation_value = | ValConst of jconstant (* B, C, D, E, F, I, J, S, Z, s *) | ValEnum of jsignature * string (* e *) | ValClass of jsignature (* c *) (* V -> Void *) | ValAnnotation of jannotation (* @ *) | ValArray of jannotation_value list (* [ *) type jattribute = | AttrDeprecated | AttrVisibleAnnotations of jannotation list | AttrInvisibleAnnotations of jannotation list | AttrUnknown of string * string type jfield_kind = | JKField | JKMethod type jfield = { jf_name : string; jf_kind : jfield_kind; (* signature, as used by the vm *) jf_vmsignature : jsignature; (* actual signature, as used in java code *) jf_signature : jsignature; jf_throws : jsignature list; jf_types : jtypes; jf_flags : jaccess; jf_attributes : jattribute list; jf_constant : jconstant option; jf_code : jcode option; } type jclass = { cversion : jversion; cpath : jpath; csuper : jsignature; cflags : jaccess; cinterfaces : jsignature list; cfields : jfield list; cmethods : jfield list; cattributes : jattribute list; cinner_types : (jpath * jpath option * string option * jaccess) list; ctypes : jtypes; } (* reading/writing *) type utf8ref = int type classref = int type nametyperef = int type dynref = int type bootstrapref = int type jconstant_raw = | KClass of utf8ref (* 7 *) | KFieldRef of (classref * nametyperef) (* 9 *) | KMethodRef of (classref * nametyperef) (* 10 *) | KInterfaceMethodRef of (classref * nametyperef) (* 11 *) | KString of utf8ref (* 8 *) | KInt of int32 (* 3 *) | KFloat of float (* 4 *) | KLong of int64 (* 5 *) | KDouble of float (* 6 *) | KNameAndType of (utf8ref * utf8ref) (* 12 *) | KUtf8String of string (* 1 *) | KMethodHandle of (reference_type * dynref) (* 15 *) | KMethodType of utf8ref (* 16 *) | KInvokeDynamic of (bootstrapref * nametyperef) (* 18 *) | KUnusable (* jData debugging *) let is_override_attrib = (function (* TODO: pass anotations as @:meta *) | AttrVisibleAnnotations ann -> List.exists (function | { ann_type = TObject( (["java";"lang"], "Override"), [] ) } -> true | _ -> false ) ann | _ -> false ) let is_override field = List.exists is_override_attrib field.jf_attributes let path_s = function | (pack,name) -> String.concat "." (pack @ [name]) let rec s_sig = function | TByte (* B *) -> "byte" | TChar (* C *) -> "char" | TDouble (* D *) -> "double" | TFloat (* F *) -> "float" | TInt (* I *) -> "int" | TLong (* J *) -> "long" | TShort (* S *) -> "short" | TBool (* Z *) -> "bool" | TObject(path,args) -> path_s path ^ s_args args | TObjectInner (sl, sjargl) -> String.concat "." sl ^ "." ^ (String.concat "." (List.map (fun (s,arg) -> s ^ s_args arg) sjargl)) | TArray (s,i) -> s_sig s ^ "[" ^ (match i with | None -> "" | Some i -> string_of_int i) ^ "]" | TMethod (sigs, sopt) -> (match sopt with | None -> "" | Some s -> s_sig s ^ " ") ^ "(" ^ String.concat ", " (List.map s_sig sigs) ^ ")" | TTypeParameter s -> s and s_args = function | [] -> "" | args -> "<" ^ String.concat ", " (List.map (fun t -> match t with | TAny -> "*" | TType (wc, s) -> (match wc with | WNone -> "" | WExtends -> "+" | WSuper -> "-") ^ (s_sig s)) args) ^ ">" let s_field f = (if is_override f then "override " else "") ^ s_sig f.jf_signature ^ " " ^ f.jf_name let s_fields fs = "{ \n\t" ^ String.concat "\n\t" (List.map s_field fs) ^ "\n}" haxe-3.0~svn6707/libs/javalib/jWriter.ml0000644000175000017500000001227012172015140020520 0ustar bdefreesebdefreese(* * This file is part of JavaLib * Copyright (c)2004-2012 Nicolas Cannasse and Caue Waneck * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open JData;; open IO.BigEndian;; open ExtString;; open ExtList;; exception Writer_error_message of string type context = { cpool : unit output; mutable ccount : int; ch : string output; mutable constants : (jconstant,int) PMap.t; } let error msg = raise (Writer_error_message msg) let get_reference_type i = match i with | RGetField -> 1 | RGetStatic -> 2 | RPutField -> 3 | RPutStatic -> 4 | RInvokeVirtual -> 5 | RInvokeStatic -> 6 | RInvokeSpecial -> 7 | RNewInvokeSpecial -> 8 | RInvokeInterface -> 9 let encode_path ctx (pack,name) = String.concat "/" (pack @ [name]) let encode_sig ctx jsig = "" let encode_utf8 ctx s = s (* TODO *) let rec const ctx c = try PMap.find c ctx.constants with | Not_found -> (match c with (** references a class or an interface - jpath must be encoded as StringUtf8 *) | ConstClass path -> (* tag = 7 *) write_byte ctx.cpool 7; write_ui16 ctx.cpool (const ctx (ConstUtf8 (encode_path ctx path))) (** field reference *) | ConstField (jpath, unqualified_name, jsignature) (* tag = 9 *) -> write_byte ctx.cpool 9; write_ui16 ctx.cpool (const ctx (ConstClass jpath)); write_ui16 ctx.cpool (const ctx (ConstNameAndType (unqualified_name, jsignature))) (** method reference; string can be special "" and "" values *) | ConstMethod (jpath, unqualified_name, jmethod_signature) (* tag = 10 *) -> write_byte ctx.cpool 10; write_ui16 ctx.cpool (const ctx (ConstClass jpath)); write_ui16 ctx.cpool (const ctx (ConstNameAndType (unqualified_name, TMethod jmethod_signature))) (** interface method reference *) | ConstInterfaceMethod of (jpath, unqualified_name, jmethod_signature) (* tag = 11 *) -> write_byte ctx.cpool 11; write_ui16 ctx.cpool (const ctx (ConstClass jpath)); write_ui16 ctx.cpool (const ctx (ConstNameAndType (unqualified_name, TMethod jmethod_signature))) (** constant values *) | ConstString s (* tag = 8 *) -> write_byte ctx.cpool 8; write_ui16 ctx.cpool (const ctx (ConstUtf8 s)) | ConstInt i (* tag = 3 *) -> write_byte ctx.cpool 3; write_real_i32 ctx.cpool i | ConstFloat f (* tag = 4 *) -> write_byte ctx.cpool 4; (match classify_float f with | FP_normal | FP_subnormal | FP_zero -> write_real_i32 ctx.cpool (Int32.bits_of_float f) | FP_infinity when f > 0 -> write_real_i32 ctx.cpool 0x7f800000l | FP_infinity when f < 0 -> write_real_i32 ctx.cpool 0xff800000l | FP_nan -> write_real_i32 ctx.cpool 0x7f800001l) | ConstLong i (* tag = 5 *) -> write_byte ctx.cpool 5; write_i64 ctx.cpool i; ctx.ccount <- ctx.ccount + 1 | ConstDouble d (* tag = 6 *) -> write_byte ctx.cpool 6; write_double ctx.cpool d; ctx.ccount <- ctx.ccount + 1 (** name and type: used to represent a field or method, without indicating which class it belongs to *) | ConstNameAndType (unqualified_name, jsignature) -> write_byte ctx.cpool 12; write_ui16 ctx.cpool (const ctx (ConstUtf8 (unqualified_name))); write_ui16 ctx.cpool (const ctx (ConstUtf8 (encode_sig ctx jsignature))) (** UTF8 encoded strings. Note that when reading/writing, take into account Utf8 modifications of java *) (* (http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.4.7) *) | ConstUtf8 s -> write_byte ctx.cpool 1; write_ui16 ctx.cpool (String.length s); write_string ctx.cpool (encode_utf8 s) (** invokeDynamic-specific *) | ConstMethodHandle (reference_type, jconstant) (* tag = 15 *) -> write_byte ctx.cpool 15; write_byte ctx.cpool (get_reference_type reference_type); write_ui16 ctx.cpool (const ctx jconstant) | ConstMethodType jmethod_signature (* tag = 16 *) -> write_byte ctx.cpool 16; write_ui16 ctx.cpool (const ctx (ConstUtf8 (encode_sig ctx (TMethod jmethod_signature)))) | ConstInvokeDynamic (bootstrap_method, unqualified_name, jsignature) (* tag = 18 *) -> write_byte ctx.cpool 18; write_ui16 ctx.cpool bootstrap_method; write_ui16 ctx.cpool (const ctx (ConstNameAndType(unqualified_name, jsignature))) | ConstUnusable -> assert false); let ret = ctx.ccount in ctx.ccount <- ret + 1; ret haxe-3.0~svn6707/libs/extlib/0000755000175000017500000000000012172015140016415 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/extlib/extArray.mli0000755000175000017500000001176312172015140020732 0ustar bdefreesebdefreese(* * ExtArray - additional and modified functions for arrays. * Copyright (C) 2005 Richard W.M. Jones (rich @ annexia.org) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Additional and modified functions for arrays. The OCaml standard library provides a module of array functions. This ExtArray module can be used to override the Array module or as a standalone module. It provides some additional functions. *) module Array : sig (** {6 New functions} *) val rev : 'a array -> 'a array (** Array reversal. *) val rev_in_place : 'a array -> unit (** In-place array reversal. The array argument is updated. *) val for_all : ('a -> bool) -> 'a array -> bool (** [for_all p [a1; ...; an]] checks if all elements of the array satisfy the predicate [p]. That is, it returns [ (p a1) && (p a2) && ... && (p an)]. *) val exists : ('a -> bool) -> 'a array -> bool (** [exists p [a1; ...; an]] checks if at least one element of the array satisfies the predicate [p]. That is, it returns [ (p a1) || (p a2) || ... || (p an)]. *) val mem : 'a -> 'a array -> bool (** [mem m a] is true if and only if [m] is equal to an element of [a]. *) val memq : 'a -> 'a array -> bool (** Same as {!Array.mem} but uses physical equality instead of structural equality to compare array elements. *) val find : ('a -> bool) -> 'a array -> 'a (** [find p a] returns the first element of array [a] that satisfies the predicate [p]. Raise [Not_found] if there is no value that satisfies [p] in the array [a]. *) val findi : ('a -> bool) -> 'a array -> int (** [findi p a] returns the index of the first element of array [a] that satisfies the predicate [p]. Raise [Not_found] if there is no value that satisfies [p] in the array [a]. *) val filter : ('a -> bool) -> 'a array -> 'a array (** [filter p a] returns all the elements of the array [a] that satisfy the predicate [p]. The order of the elements in the input array is preserved. *) val find_all : ('a -> bool) -> 'a array -> 'a array (** [find_all] is another name for {!Array.filter}. *) val partition : ('a -> bool) -> 'a array -> 'a array * 'a array (** [partition p a] returns a pair of arrays [(a1, a2)], where [a1] is the array of all the elements of [a] that satisfy the predicate [p], and [a2] is the array of all the elements of [a] that do not satisfy [p]. The order of the elements in the input array is preserved. *) (** {6 Enumerations} *) val enum : 'a array -> 'a Enum.t (** Returns an enumeration of the elements of an array. *) val of_enum : 'a Enum.t -> 'a array (** Build an array from an enumeration. *) (** {6 Old functions} *) (** These functions are already part of the Ocaml standard library and have not been modified. Please refer to the Ocaml Manual for documentation. *) external length : 'a array -> int = "%array_length" external get : 'a array -> int -> 'a = "%array_safe_get" external set : 'a array -> int -> 'a -> unit = "%array_safe_set" external make : int -> 'a -> 'a array = "caml_make_vect" external create : int -> 'a -> 'a array = "caml_make_vect" val init : int -> (int -> 'a) -> 'a array val make_matrix : int -> int -> 'a -> 'a array array val create_matrix : int -> int -> 'a -> 'a array array val append : 'a array -> 'a array -> 'a array val concat : 'a array list -> 'a array val sub : 'a array -> int -> int -> 'a array val copy : 'a array -> 'a array val fill : 'a array -> int -> int -> 'a -> unit val blit : 'a array -> int -> 'a array -> int -> int -> unit val to_list : 'a array -> 'a list val of_list : 'a list -> 'a array val iter : ('a -> unit) -> 'a array -> unit val map : ('a -> 'b) -> 'a array -> 'b array val iteri : (int -> 'a -> unit) -> 'a array -> unit val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a val sort : ('a -> 'a -> int) -> 'a array -> unit val stable_sort : ('a -> 'a -> int) -> 'a array -> unit val fast_sort : ('a -> 'a -> int) -> 'a array -> unit external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" end haxe-3.0~svn6707/libs/extlib/global.ml0000644000175000017500000000231412172015140020207 0ustar bdefreesebdefreese(* * Global - Mutable global variable * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) exception Global_not_initialized of string type 'a t = ('a option ref * string) let empty name = ref None,name let name = snd let set (r,_) v = r := Some v let get (r,name) = match !r with | None -> raise (Global_not_initialized name) | Some v -> v let undef (r,_) = r := None let isdef (r,_) = !r <> None let opt (r,_) = !r haxe-3.0~svn6707/libs/extlib/option.mli0000644000175000017500000000404712172015140020435 0ustar bdefreesebdefreese(* * Options - functions for the option type * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Functions for the option type. Options are an Ocaml standard type that can be either [None] (undefined) or [Some x] where x can be any value. Options are widely used in Ocaml to represent undefined values (a little like NULL in C, but in a type and memory safe way). This module adds some functions for working with options. *) val may : ('a -> unit) -> 'a option -> unit (** [may f (Some x)] calls [f x] and [may f None] does nothing. *) val map : ('a -> 'b) -> 'a option -> 'b option (** [map f (Some x)] returns [Some (f x)] and [map None] returns [None]. *) val default : 'a -> 'a option -> 'a (** [default x (Some v)] returns [v] and [default x None] returns [x]. *) val map_default : ('a -> 'b) -> 'b -> 'a option -> 'b (** [map_default f x (Some v)] returns [f v] and [map_default f x None] returns [x]. *) val is_none : 'a option -> bool (** [is_none None] returns [true] otherwise it returns [false]. *) val is_some : 'a option -> bool (** [is_some (Some x)] returns [true] otherwise it returns [false]. *) val get : 'a option -> 'a (** [get (Some x)] returns [x] and [get None] raises [No_value]. *) exception No_value (** Raised when calling [get None]. *) haxe-3.0~svn6707/libs/extlib/README.txt0000644000175000017500000000333112172015140020113 0ustar bdefreesebdefreeseOCaml Extended standard Library - ExtLib. ========================================= * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version,, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA What is ExtLib ? ---------------- ExtLib is a set of additional useful functions and modules for OCaml. You can watch the SourceForge project page here : http://sourceforge.net/projects/ocaml-lib/ The web site is here : http://ocaml-lib.sourceforge.net/ and you can join the mailing list here : http://lists.sourceforge.net/lists/listinfo/ocaml-lib-devel People are encouraged to contribute and to report any bug or problem they might have with ExtLib by using the mailing list. Installation : -------------- Unzip or untar in any directory, then simply run > ocaml install.ml and follow the instructions. Usage : ------- Generate and watch the documentation. Contributors : -------------- Nicolas Cannasse (ncannasse@motion-twin.com) Brian Hurt (brian.hurt@qlogic.com) Yamagata Yoriyuki (yori@users.sourceforge.net) License : --------- See LICENSEhaxe-3.0~svn6707/libs/extlib/extArray.ml0000644000175000017500000000761212172015140020554 0ustar bdefreesebdefreese(* * ExtList - additional and modified functions for lists. * Copyright (C) 2005 Richard W.M. Jones (rich @ annexia.org) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module Array = struct include Array let rev_in_place xs = let n = length xs in let j = ref (n-1) in for i = 0 to n/2-1 do let c = xs.(i) in xs.(i) <- xs.(!j); xs.(!j) <- c; decr j done let rev xs = let ys = Array.copy xs in rev_in_place ys; ys let for_all p xs = let n = length xs in let rec loop i = if i = n then true else if p xs.(i) then loop (succ i) else false in loop 0 let exists p xs = let n = length xs in let rec loop i = if i = n then false else if p xs.(i) then true else loop (succ i) in loop 0 let mem a xs = let n = length xs in let rec loop i = if i = n then false else if a = xs.(i) then true else loop (succ i) in loop 0 let memq a xs = let n = length xs in let rec loop i = if i = n then false else if a == xs.(i) then true else loop (succ i) in loop 0 let findi p xs = let n = length xs in let rec loop i = if i = n then raise Not_found else if p xs.(i) then i else loop (succ i) in loop 0 let find p xs = xs.(findi p xs) (* Use of BitSet suggested by Brian Hurt. *) let filter p xs = let n = length xs in (* Use a bitset to store which elements will be in the final array. *) let bs = BitSet.create n in for i = 0 to n-1 do if p xs.(i) then BitSet.set bs i done; (* Allocate the final array and copy elements into it. *) let n' = BitSet.count bs in let j = ref 0 in let xs' = init n' (fun _ -> (* Find the next set bit in the BitSet. *) while not (BitSet.is_set bs !j) do incr j done; let r = xs.(!j) in incr j; r) in xs' let find_all = filter let partition p xs = let n = length xs in (* Use a bitset to store which elements will be in which final array. *) let bs = BitSet.create n in for i = 0 to n-1 do if p xs.(i) then BitSet.set bs i done; (* Allocate the final arrays and copy elements into them. *) let n1 = BitSet.count bs in let n2 = n - n1 in let j = ref 0 in let xs1 = init n1 (fun _ -> (* Find the next set bit in the BitSet. *) while not (BitSet.is_set bs !j) do incr j done; let r = xs.(!j) in incr j; r) in let j = ref 0 in let xs2 = init n2 (fun _ -> (* Find the next clear bit in the BitSet. *) while BitSet.is_set bs !j do incr j done; let r = xs.(!j) in incr j; r) in xs1, xs2 let enum xs = let rec make start xs = let n = length xs in Enum.make ~next:(fun () -> if !start < n then ( let r = xs.(!start) in incr start; r ) else raise Enum.No_more_elements) ~count:(fun () -> n - !start) ~clone:(fun () -> let xs' = Array.sub xs !start (n - !start) in make (ref 0) xs') in make (ref 0) xs let of_enum e = let n = Enum.count e in (* This assumes, reasonably, that init traverses the array in order. *) Array.init n (fun i -> match Enum.get e with | Some x -> x | None -> assert false) end haxe-3.0~svn6707/libs/extlib/base64.mli0000644000175000017500000000415012172015140020204 0ustar bdefreesebdefreese(* * Base64 - Base64 codec * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Base64 codec. 8-bit characters are encoded into 6-bit ones using ASCII lookup tables. Default tables maps 0..63 values on characters A-Z, a-z, 0-9, '+' and '/' (in that order). *) (** This exception is raised when reading an invalid character from a base64 input. *) exception Invalid_char (** This exception is raised if the encoding or decoding table size is not correct. *) exception Invalid_table (** An encoding table maps integers 0..63 to the corresponding char. *) type encoding_table = char array (** A decoding table mais chars 0..255 to the corresponding 0..63 value or -1 if the char is not accepted. *) type decoding_table = int array (** Encode a string into Base64. *) val str_encode : ?tbl:encoding_table -> string -> string (** Decode a string encoded into Base64, raise [Invalid_char] if a character in the input string is not a valid one. *) val str_decode : ?tbl:decoding_table -> string -> string (** Generic base64 encoding over an output. *) val encode : ?tbl:encoding_table -> 'a IO.output -> 'a IO.output (** Generic base64 decoding over an input. *) val decode : ?tbl:decoding_table -> IO.input -> IO.input (** Create a valid decoding table from an encoding one. *) val make_decoding_table : encoding_table -> decoding_table haxe-3.0~svn6707/libs/extlib/Makefile0000644000175000017500000000161112172015140020054 0ustar bdefreesebdefreese# Makefile contributed by Alain Frisch MODULES = \ enum bitSet dynArray extArray extHashtbl extList extString global IO option \ pMap std uChar uTF8 base64 unzip refList optParse dllist multiArray # the list is topologically sorted MLI = $(MODULES:=.mli) SRC = $(MLI) $(MODULES:=.ml) extLib.ml all: ocamlc -a -o extLib.cma $(SRC) opt: ocamlopt -g -a -o extLib.cmxa $(SRC) doc: ocamlc -c $(MODULES:=.mli) mkdir -p doc/ ocamldoc -sort -html -d doc/ $(MODULES:=.mli) cp odoc_style.css doc/style.css copy: mv *.cmi *.cmx *.cma *.cmxa extLib.lib c:/ocaml/lib/ install: cp META.txt META ocamlfind install extlib META *.cmi *.cma $(MLI) $(wildcard *.cmxa) $(wildcard *.a) uninstall: ocamlfind remove extlib clean: rm -f $(wildcard *.cmo) $(wildcard *.cmx) $(wildcard *.o) $(wildcard *.cmi) $(wildcard *.cma) $(wildcard *.cmxa) $(wildcard *.a) $(wildcard *.lib) $(wildcard *.obj) rm -Rf doc haxe-3.0~svn6707/libs/extlib/std.ml0000644000175000017500000001207412172015140017545 0ustar bdefreesebdefreese(* * Std - Additional functions * Copyright (C) 2003 Nicolas Cannasse and Markus Mottl * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) let input_lines ch = Enum.from (fun () -> try input_line ch with End_of_file -> raise Enum.No_more_elements) let input_chars ch = Enum.from (fun () -> try input_char ch with End_of_file -> raise Enum.No_more_elements) type 'a _mut_list = { hd : 'a; mutable tl : 'a _mut_list; } let input_list ch = let _empty = Obj.magic [] in let rec loop dst = let r = { hd = input_line ch; tl = _empty } in dst.tl <- r; loop r in let r = { hd = Obj.magic(); tl = _empty } in try loop r with End_of_file -> Obj.magic r.tl let buf_len = 8192 let input_all ic = let rec loop acc total buf ofs = let n = input ic buf ofs (buf_len - ofs) in if n = 0 then let res = String.create total in let pos = total - ofs in let _ = String.blit buf 0 res pos ofs in let coll pos buf = let new_pos = pos - buf_len in String.blit buf 0 res new_pos buf_len; new_pos in let _ = List.fold_left coll pos acc in res else let new_ofs = ofs + n in let new_total = total + n in if new_ofs = buf_len then loop (buf :: acc) new_total (String.create buf_len) 0 else loop acc new_total buf new_ofs in loop [] 0 (String.create buf_len) 0 let input_file ?(bin=false) fname = let ch = (if bin then open_in_bin else open_in) fname in let str = input_all ch in close_in ch; str let output_file ~filename ~text = let ch = open_out filename in output_string ch text; close_out ch let print_bool = function | true -> print_string "true" | false -> print_string "false" let prerr_bool = function | true -> prerr_string "true" | false -> prerr_string "false" let string_of_char c = String.make 1 c external identity : 'a -> 'a = "%identity" let rec dump r = if Obj.is_int r then string_of_int (Obj.magic r : int) else (* Block. *) let rec get_fields acc = function | 0 -> acc | n -> let n = n-1 in get_fields (Obj.field r n :: acc) n in let rec is_list r = if Obj.is_int r then r = Obj.repr 0 (* [] *) else let s = Obj.size r and t = Obj.tag r in t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) in let rec get_list r = if Obj.is_int r then [] else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in h :: t in let opaque name = (* XXX In future, print the address of value 'r'. Not possible in * pure OCaml at the moment. *) "<" ^ name ^ ">" in let s = Obj.size r and t = Obj.tag r in (* From the tag, determine the type of block. *) match t with | _ when is_list r -> let fields = get_list r in "[" ^ String.concat "; " (List.map dump fields) ^ "]" | 0 -> let fields = get_fields [] s in "(" ^ String.concat ", " (List.map dump fields) ^ ")" | x when x = Obj.lazy_tag -> (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not * clear if very large constructed values could have the same * tag. XXX *) opaque "lazy" | x when x = Obj.closure_tag -> opaque "closure" | x when x = Obj.object_tag -> let fields = get_fields [] s in let clasz, id, slots = match fields with | h::h'::t -> h, h', t | _ -> assert false in (* No information on decoding the class (first field). So just print * out the ID and the slots. *) "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")" | x when x = Obj.infix_tag -> opaque "infix" | x when x = Obj.forward_tag -> opaque "forward" | x when x < Obj.no_scan_tag -> let fields = get_fields [] s in "Tag" ^ string_of_int t ^ " (" ^ String.concat ", " (List.map dump fields) ^ ")" | x when x = Obj.string_tag -> "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" | x when x = Obj.double_tag -> string_of_float (Obj.magic r : float) | x when x = Obj.abstract_tag -> opaque "abstract" | x when x = Obj.custom_tag -> opaque "custom" | x when x = Obj.final_tag -> opaque "final" | _ -> failwith ("Std.dump: impossible tag (" ^ string_of_int t ^ ")") let dump v = dump (Obj.repr v) let print v = print_endline (dump v) let finally handler f x = let r = ( try f x with e -> handler(); raise e ) in handler(); r let __unique_counter = ref 0 let unique() = incr __unique_counter; !__unique_counterhaxe-3.0~svn6707/libs/extlib/optParse.ml0000644000175000017500000005516012172015140020553 0ustar bdefreesebdefreese(* * optParse - Functions for parsing command line arguments. * Copyright (C) 2004 Bardur Arantsson * * Heavily influenced by the optparse.py module from the Python * standard library, but with lots of adaptation to the 'Ocaml Way' * * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Printf open ExtString open ExtList let terminal_width = try int_of_string (Sys.getenv "COLUMNS") (* Might as well use it if it's there... *) with Failure _ -> 80 | Not_found -> 80 module GetOpt = struct type action = string -> string list -> unit type long_opt = string * int * action type short_opt = char * int * action exception Error of (string * string) let split1 haystack needle = try let (h, x) = String.split haystack needle in h, [x] with Invalid_string -> haystack, [] let find_opt format_name options s = let rec loop l = match l with (x, y, z) :: t -> if x = s then x, y, z else loop t | [] -> raise (Error (format_name s, "no such option")) in loop options let find_short_opt options = find_opt (fun c -> sprintf "-%c" c) options let find_long_opt options = find_opt (fun s -> "--" ^ s) options let parse other find_short_opt find_long_opt args = let rec loop args = let rec gather_args name n args = try List.split_nth n args with List.Invalid_index _ -> raise (Error (name, "missing required arguments")) in let gather_long_opt s args = let (h, t) = split1 s "=" in let (_, nargs, action) = find_long_opt (String.slice ~first:2 h) in let (accum, args') = gather_args h (nargs - List.length t) args in action h (t @ accum); args' in let rec gather_short_opt_concat seen_args s k args = if k < String.length s then let ostr = sprintf "-%c" s.[k] and (_, nargs, action) = find_short_opt s.[k] in if nargs = 0 then begin action ostr []; gather_short_opt_concat seen_args s (k + 1) args end else if not seen_args then let (accum, args') = gather_args ostr nargs args in action ostr accum; gather_short_opt_concat true s (k + 1) args' else raise (Error (sprintf "-%c" s.[k], sprintf "option list '%s' already contains an option requiring an argument" s)) else args in let gather_short_opt s k args = let ostr = sprintf "-%c" s.[k] in let (_, nargs, action) = find_short_opt s.[k] in if nargs = 0 then gather_short_opt_concat false s k args else let (accum, args') = let h = String.slice ~first:(k+1) s in if String.length h = 0 then gather_args ostr nargs args else let (t, args'') = gather_args ostr (nargs - 1) args in h :: t, args'' in action ostr accum; args' in match args with [] -> [] | arg :: args' -> if arg = "--" then args' else if String.starts_with arg "--" then loop (gather_long_opt arg args') else if arg = "-" then begin other arg; loop args' end else if String.starts_with arg "-" then loop (gather_short_opt arg 1 args') else begin other arg; loop args' end in let args' = loop args in List.iter other args' end module Opt = struct exception No_value exception Option_error of string * string exception Option_help type 'a t = { option_set : string -> string list -> unit; option_set_value : 'a -> unit; option_get : unit -> 'a option; option_metavars : string list; option_defhelp : string option } let get opt = match opt.option_get () with Some x -> x | None -> raise No_value let set opt v = opt.option_set_value v let is_set opt = Option.is_some (opt.option_get ()) let opt opt = opt.option_get () let value_option metavar default coerce errfmt = let data = ref default in { option_metavars = [metavar]; option_defhelp = None; option_get = (fun _ -> !data); option_set_value = (fun x -> data := Some x); option_set = (fun option args -> let arg = List.hd args in try data := Some (coerce arg) with exn -> raise (Option_error (option, errfmt exn arg))) } let callback_option metavar coerce errfmt f = { option_metavars = [metavar]; option_defhelp = None; option_get = (fun _ -> Some ()); option_set_value = (fun () -> ()); option_set = (fun option args -> let arg = List.hd args in let datum = ref None in begin try datum := Some (coerce arg) with exn -> raise (Option_error (option, errfmt exn arg)) end; Option.may f !datum) } end module StdOpt = struct open Opt let store_const ?default const = let data = ref default in { option_metavars = []; option_defhelp = None; option_get = (fun _ -> !data); option_set_value = (fun x -> data := Some x); option_set = fun _ _ -> data := Some const } let store_true () = store_const ~default:false true let store_false () = store_const ~default:true false let int_option ?default ?(metavar = "INT") () = value_option metavar default int_of_string (fun _ s -> sprintf "invalid integer value '%s'" s) let int_callback ?(metavar = "INT") = callback_option metavar int_of_string (fun _ s -> sprintf "invalid integer value '%s'" s) let float_option ?default ?(metavar = "FLOAT") () = value_option metavar default float_of_string (fun _ s -> sprintf "invalid floating point value '%s'" s) let float_callback ?(metavar = "FLOAT") = callback_option metavar float_of_string (fun _ s -> sprintf "invalid floating point value '%s'" s) let str_option ?default ?(metavar = "STR") () = value_option metavar default (fun s -> s) (fun _ _ -> "cannot happen") let str_callback ?(metavar = "STR") = callback_option metavar (fun s -> s) (fun _ _ -> "cannot happen") let count_option ?(dest = ref 0) ?(increment = 1) () = { option_metavars = []; option_defhelp = None; option_get = (fun _ -> Some !dest); option_set_value = (fun x -> dest := x); option_set = fun _ _ -> dest := !dest + increment } let incr_option ?(dest = ref 0) = count_option ~dest ~increment:1 let decr_option ?(dest = ref 0) = count_option ~dest ~increment:(-1) let help_option () = { option_metavars = []; option_defhelp = Some "show this help message and exit"; option_get = (fun _ -> raise No_value); option_set_value = (fun _ -> ()); option_set = fun _ _ -> raise Option_help } let version_option vfunc = { option_metavars = []; option_defhelp = Some "show program's version and exit"; option_get = (fun _ -> raise No_value); option_set_value = (fun _ -> ()); option_set = fun _ _ -> print_endline (vfunc ()); exit 0 } end module Formatter = struct (* Note that the whitespace regexps must NOT treat the non-breaking space character as whitespace. *) let whitespace = "\t\n\013\014\r " let split_into_chunks s = let buf = Buffer.create (String.length s) in let flush () = let s = Buffer.contents buf in Buffer.clear buf; s in let rec loop state accum i = if (i 0 then loop (not state) (flush () :: accum) i else loop (not state) accum i else begin Buffer.add_char buf s.[i]; loop state accum (i+1) end else if Buffer.length buf > 0 then flush () :: accum else accum in List.rev (loop false [] 0) let is_whitespace s = let rec loop i = if i let n = tab_size - col mod tab_size in Buffer.add_string b (spaces n); expand (i + 1) (col + n) | '\n' -> Buffer.add_string b "\n"; expand (i + 1) 0 | c -> Buffer.add_char b c; expand (i + 1) (col + 1) in expand 0 0; Buffer.contents b let wrap ?(initial_indent = 0) ?(subsequent_indent = 0) text _width = let wrap_chunks_line width acc = let rec wrap (chunks, cur_line, cur_len) = match chunks with [] -> [], cur_line, cur_len | hd :: tl -> let l = String.length hd in if cur_len + l <= width then wrap (tl, hd :: cur_line, cur_len + l) else chunks, cur_line, cur_len in wrap acc in let wrap_long_last_word width (chunks, cur_line, cur_len) = match chunks with [] -> [], cur_line, cur_len | hd :: tl -> let l = String.length hd in if l > width then match cur_line with [] -> tl, [hd], cur_len + l | _ -> chunks, cur_line, cur_len else chunks, cur_line, cur_len in let wrap_remove_last_ws (chunks, cur_line, cur_len) = match cur_line with [] -> chunks, cur_line, cur_len | hd :: tl -> if is_whitespace hd then chunks, tl, cur_len - String.length hd else chunks, cur_line, cur_len in let rec wrap_chunks_lines chunks lines = let indent = match lines with [] -> initial_indent | _ -> subsequent_indent in let width = _width - indent in match chunks with hd :: tl -> if is_whitespace hd && lines <> [] then wrap_chunks_lines tl lines else (* skip *) let (chunks', cur_line, _) = wrap_remove_last_ws (wrap_long_last_word width (wrap_chunks_line width (chunks, [], 0))) in wrap_chunks_lines chunks' ((String.make indent ' ' ^ String.concat "" (List.rev cur_line)) :: lines) | [] -> List.rev lines in let chunks = split_into_chunks (expand_tabs text) in wrap_chunks_lines chunks [] let fill ?(initial_indent = 0) ?(subsequent_indent = 0) text width = String.concat "\n" (wrap ~initial_indent ~subsequent_indent text width) type t = { indent : unit -> unit; dedent : unit -> unit; format_usage : string -> string; format_heading : string -> string; format_description : string -> string; format_option : char list * string list -> string list -> string option -> string } let format_option_strings short_first (snames, lnames) metavars = let metavar = String.concat " " metavars in let lopts = List.map (match metavar with "" -> (fun z -> sprintf "--%s" z) | _ -> fun z -> sprintf "--%s=%s" z metavar) lnames and sopts = List.map (fun x -> sprintf "-%c%s" x metavar) snames in match short_first with true -> String.concat ", " (sopts @ lopts) | false -> String.concat ", " (lopts @ sopts) let indented_formatter ?level:(extlevel = ref 0) ?indent:(extindent = ref 0) ?(indent_increment = 2) ?(max_help_position = 24) ?(width = terminal_width - 1) ?(short_first = true) () = let indent = ref 0 and level = ref 0 in let help_position = ref max_help_position and help_width = ref (width - max_help_position) in { indent = (fun () -> indent := !indent + indent_increment; level := !level + 1; extindent := !indent; extlevel := !level); dedent = (fun () -> indent := !indent - indent_increment; level := !level - 1; assert (!level >= 0); extindent := !indent; extlevel := !level); format_usage = (fun usage -> sprintf "usage: %s\n" usage); format_heading = (fun heading -> sprintf "%*s%s:\n\n" !indent "" heading); format_description = (fun description -> let x = fill ~initial_indent:(!indent) ~subsequent_indent:(!indent) description (width - !indent) in if not (String.ends_with x "\n") then x ^ "\n\n" else x ^ "\n"); format_option = fun names metavars help -> let opt_width = !help_position - !indent - 2 in let opt_strings = format_option_strings short_first names metavars in let buf = Buffer.create 256 in let indent_first = if String.length opt_strings > opt_width then begin bprintf buf "%*s%s\n" !indent "" opt_strings; !help_position end else begin bprintf buf "%*s%-*s " !indent "" opt_width opt_strings; 0 end in Option.may (fun option_help -> let lines = wrap option_help !help_width in match lines with h :: t -> bprintf buf "%*s%s\n" indent_first "" h; List.iter (fun x -> bprintf buf "%*s%s\n" !help_position "" x) t | [] -> ()) help; let contents = Buffer.contents buf in if String.length contents > 0 && not (String.ends_with contents "\n") then contents ^ "\n" else contents } let titled_formatter ?(level = ref 0) ?(indent = ref 0) ?(indent_increment = 0) ?(max_help_position = 24) ?(width = terminal_width - 1) ?(short_first = true) () = let formatter = indented_formatter ~level ~indent ~indent_increment ~max_help_position ~width ~short_first () in let format_heading h = let c = match !level with 0 -> '=' | 1 -> '-' | _ -> failwith "titled_formatter: Too much indentation" in sprintf "%*s%s\n%*s%s\n\n" !indent "" (String.capitalize h) !indent "" (String.make (String.length h) c) in let format_usage usage = sprintf "%s %s\n" (format_heading "Usage") usage in { formatter with format_usage = format_usage; format_heading = format_heading } end open Opt open Formatter module OptParser = struct exception Option_conflict of string type group = { og_heading : string; og_description : string option; og_options : ((char list * string list) * string list * string option) RefList.t; og_children : group RefList.t } type t = { op_usage : string; op_suppress_usage : bool; op_prog : string; op_formatter : Formatter.t; op_long_options : GetOpt.long_opt RefList.t; op_short_options : GetOpt.short_opt RefList.t; op_groups : group } let unprogify optparser s = (snd (String.replace ~str:s ~sub:"%prog" ~by:optparser.op_prog)) let add optparser ?(group = optparser.op_groups) ?help ?(hide = false) ?short_name ?(short_names = []) ?long_name ?(long_names = []) opt = let lnames = match long_name with None -> long_names | Some x -> x :: long_names and snames = match short_name with None -> short_names | Some x -> x :: short_names in if lnames = [] && snames = [] then failwith "Options must have at least one name" else (* Checking for duplicates: *) let snames' = List.fold_left (fun r (x, _, _) -> x :: r) [] (RefList.to_list optparser.op_short_options) and lnames' = List.fold_left (fun r (x, _, _) -> x :: r) [] (RefList.to_list optparser.op_long_options) in let sconf = List.filter (fun e -> List.exists (( = ) e) snames') snames and lconf = List.filter (fun e -> List.exists (( = ) e) lnames') lnames in if List.length sconf > 0 then raise (Option_conflict (sprintf "-%c" (List.hd sconf))) else if List.length lconf > 0 then raise (Option_conflict (sprintf "--%s" (List.hd lconf))); (* Add to display list. *) if not hide then RefList.add group.og_options ((snames, lnames), opt.option_metavars, (match help with None -> opt.option_defhelp | Some _ -> help)); (* Getopt: *) let nargs = List.length opt.option_metavars in List.iter (fun short -> RefList.add optparser.op_short_options (short, nargs, opt.option_set)) snames; List.iter (fun long -> RefList.add optparser.op_long_options (long, nargs, opt.option_set)) lnames let add_group optparser ?(parent = optparser.op_groups) ?description heading = let g = { og_heading = heading; og_description = description; og_options = RefList.empty (); og_children = RefList.empty () } in RefList.add parent.og_children g; g let make ?(usage = "%prog [options]") ?description ?version ?(suppress_usage = false) ?(suppress_help = false) ?prog ?(formatter = Formatter.indented_formatter ()) () = let optparser = { op_usage = usage; op_suppress_usage = suppress_usage; op_prog = Option.default (Filename.basename Sys.argv.(0)) prog; op_formatter = formatter; op_short_options = RefList.empty (); op_long_options = RefList.empty (); op_groups = { og_heading = "options"; og_options = RefList.empty (); og_children = RefList.empty (); og_description = description } } in Option.may (* Add version option? *) (fun version -> add optparser ~long_name:"version" (StdOpt.version_option (fun () -> unprogify optparser version))) version; if not suppress_help then (* Add help option? *) add optparser ~short_name:'h' ~long_name:"help" (StdOpt.help_option ()); optparser let format_usage optparser eol = match optparser.op_suppress_usage with true -> "" | false -> unprogify optparser (optparser.op_formatter.format_usage optparser.op_usage) ^ eol let error optparser ?(chn = stderr) ?(status = 1) message = fprintf chn "%s%s: %s\n" (format_usage optparser "\n") optparser.op_prog message; flush chn; exit status let usage optparser ?(chn = stdout) () = let rec loop g = (* Heading: *) output_string chn (optparser.op_formatter.format_heading g.og_heading); optparser.op_formatter.indent (); (* Description: *) Option.may (fun x -> output_string chn (optparser.op_formatter.format_description x)) g.og_description; (* Options: *) RefList.iter (fun (names, metavars, help) -> output_string chn (optparser.op_formatter.format_option names metavars help)) g.og_options; (* Child groups: *) output_string chn "\n"; RefList.iter loop g.og_children; optparser.op_formatter.dedent () in output_string chn (format_usage optparser "\n"); loop optparser.op_groups; flush chn let parse optparser ?(first = 0) ?last argv = let args = RefList.empty () and n = match last with None -> Array.length argv - first | Some m -> m - first + 1 in begin try GetOpt.parse (RefList.push args) (GetOpt.find_short_opt (RefList.to_list optparser.op_short_options)) (GetOpt.find_long_opt (RefList.to_list optparser.op_long_options)) (Array.to_list (Array.sub argv first n)) with GetOpt.Error (opt, errmsg) -> error optparser (sprintf "option '%s': %s" opt errmsg) | Option_error (opt, errmsg) -> error optparser (sprintf "option '%s': %s" opt errmsg) | Option_help -> usage optparser (); exit 0 end; List.rev (RefList.to_list args) let parse_argv optparser = parse optparser ~first:1 Sys.argv end haxe-3.0~svn6707/libs/extlib/extHashtbl.mli0000644000175000017500000000575612172015140021243 0ustar bdefreesebdefreese(* * ExtHashtbl - extra functions over hashtables. * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Extra functions over hashtables. *) module Hashtbl : (** The wrapper module *) sig type ('a,'b) t = ('a,'b) Hashtbl.t (** The type of a hashtable. *) (** {6 New Functions} *) val exists : ('a,'b) t -> 'a -> bool (** [exists h k] returns true is at least one item with key [k] is found in the hashtable. *) val keys : ('a,'b) t -> 'a Enum.t (** Return an enumeration of all the keys of a hashtable. If the key is in the Hashtable multiple times, all occurrences will be returned. *) val values : ('a,'b) t -> 'b Enum.t (** Return an enumeration of all the values of a hashtable. *) val enum : ('a, 'b) t -> ('a * 'b) Enum.t (** Return an enumeration of (key,value) pairs of a hashtable. *) val of_enum : ('a * 'b) Enum.t -> ('a, 'b) t (** Create a hashtable from a (key,value) enumeration. *) val find_default : ('a,'b) t -> 'a -> 'b -> 'b (** Find a binding for the key, and return a default value if not found *) val find_option : ('a,'b) Hashtbl.t -> 'a -> 'b option (** Find a binding for the key, or return [None] if no value is found *) val remove_all : ('a,'b) t -> 'a -> unit (** Remove all bindings for the given key *) val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t (** [map f x] creates a new hashtable with the same keys as [x], but with the function [f] applied to all the values *) val length : ('a,'b) t -> int (** Return the number of elements inserted into the Hashtbl (including duplicates) *) (** {6 Older Functions} *) (** Please refer to the Ocaml Manual for documentation of these functions. (note : functor support removed to avoid code duplication). *) val create : int -> ('a, 'b) t val clear : ('a, 'b) t -> unit val add : ('a, 'b) t -> 'a -> 'b -> unit val copy : ('a, 'b) t -> ('a, 'b) t val find : ('a, 'b) t -> 'a -> 'b val find_all : ('a, 'b) t -> 'a -> 'b list val mem : ('a, 'b) t -> 'a -> bool val remove : ('a, 'b) t -> 'a -> unit val replace : ('a, 'b) t -> 'a -> 'b -> unit val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c val hash : 'a -> int end haxe-3.0~svn6707/libs/extlib/dllist.mli0000644000175000017500000001362512172015140020422 0ustar bdefreesebdefreese(* * Dllist- a mutable, circular, doubly linked list library * Copyright (C) 2004 Brian Hurt, Jesse Guardiani * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** A mutable, imperative, circular, doubly linked list library This module implements a doubly linked list in a mutable or imperitive style (changes to the list are visible to all copies of the list). *) type 'a node_t (* abstract *) exception Empty (** {6 node functions } *) (** Creates a node. This is an O(1) operation. *) val create : 'a -> 'a node_t (** Copy the list attached to the given node and return the copy of the given node. This is an O(N) operation. *) val copy : 'a node_t -> 'a node_t (** Returns the length of the list. This is an O(N) operation. *) val length : 'a node_t -> int (** List reversal. This is an O(N) operation. *) val rev : 'a node_t -> unit (** [add n a] Creates a new node containing data [a] and inserts it into the list after node [n]. This is an O(1) operation. *) val add : 'a node_t -> 'a -> unit (** [append n a] Creates a new node containing data [a] and inserts it into the list after node [n]. Returns new node. This is an O(1) operation. *) val append : 'a node_t -> 'a -> 'a node_t (** [prepend n a] Creates a new node containing data [a] and inserts it into the list before node [n]. Returns new node. This is an O(1) operation. *) val prepend : 'a node_t -> 'a -> 'a node_t (** [promote n] Swaps [n] with [next n]. This is an O(1) operation. *) val promote : 'a node_t -> unit (** [demote n] Swaps [n] with [prev n]. This is an O(1) operation. *) val demote : 'a node_t -> unit (** Remove node from the list no matter where it is. This is an O(1) operation. *) val remove : 'a node_t -> unit (** Remove node from the list no matter where it is. Return next node. This is an O(1) operation. *) val drop : 'a node_t -> 'a node_t (** Remove node from the list no matter where it is. Return previous node. This is an O(1) operation. *) val rev_drop : 'a node_t -> 'a node_t (** [splice n1 n2] Connects [n1] and [n2] so that [next n1 == n2 && prev n2 == n1]. This can be used to connect two discrete lists, or, if used on two nodes within the same list, it can be used to separate the nodes between [n1] and [n2] from the rest of the list. In this case, those nodes become a discrete list by themselves. This is an O(1) operation. *) val splice : 'a node_t -> 'a node_t -> unit (** Given a node, get the data associated with that node. This is an O(1) operation. *) val get : 'a node_t -> 'a (** Given a node, set the data associated with that node. This is an O(1) operation. *) val set : 'a node_t -> 'a -> unit (** Given a node, get the next element in the list after the node. The list is circular, so the last node of the list returns the first node of the list as it's next node. This is an O(1) operation. *) val next : 'a node_t -> 'a node_t (** Given a node, get the previous element in the list before the node. The list is circular, so the first node of the list returns the last element of the list as it's previous node. This is an O(1) operation. *) val prev : 'a node_t -> 'a node_t (** [skip n i] Return the node that is [i] nodes after node [n] in the list. If [i] is negative then return the node that is [i] nodes before node [n] in the list. This is an O(N) operation. *) val skip : 'a node_t -> int -> 'a node_t (** [iter f n] Apply [f] to every element in the list, starting at [n]. This is an O(N) operation. *) val iter : ('a -> unit) -> 'a node_t -> unit (** Accumulate a value over the entire list. This works like List.fold_left. This is an O(N) operation. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b node_t -> 'a (** Accumulate a value over the entire list. This works like List.fold_right, but since the list is bidirectional, it doesn't suffer the performance problems of List.fold_right. This is an O(N) operation. *) val fold_right : ('a -> 'b -> 'b) -> 'a node_t -> 'b -> 'b (** Allocate a new list, with entirely new nodes, whose values are the transforms of the values of the original list. Note that this does not modify the given list. This is an O(N) operation. *) val map : ('a -> 'b) -> 'a node_t -> 'b node_t (** {6 list conversion } *) (** Converts a dllist to a normal list. This is an O(N) operation. *) val to_list : 'a node_t -> 'a list (** Converts from a normal list to a Dllist and returns the first node. Raises [Empty] if given list is empty. This is an O(N) operation. *) val of_list : 'a list -> 'a node_t (** {6 enums } *) (** Create an enum of the list. Note that modifying the list while the enum exists will have undefined effects. This is an O(1) operation. *) val enum : 'a node_t -> 'a Enum.t (** Create a reverse enum of the list. Note that modifying the list while the enum exists will have undefined effects. This is an O(1) operation. *) val rev_enum : 'a node_t -> 'a Enum.t (** Create a dllist from an enum. This consumes the enum, and allocates a whole new dllist. Raises [Empty] if given enum is empty. This is an O(N) operation. *) val of_enum : 'a Enum.t -> 'a node_t haxe-3.0~svn6707/libs/extlib/extList.mli0000755000175000017500000002200312172015140020554 0ustar bdefreesebdefreese(* * ExtList - additional and modified functions for lists. * Copyright (C) 2003 Brian Hurt * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Additional and modified functions for lists. The OCaml standard library provides a module for list functions. This ExtList module can be used to override the List module or as a standalone module. It provides new functions and modify the behavior of some other ones (in particular all functions are now {b tail-recursive}). *) module List : sig (** {6 New functions} *) val init : int -> (int -> 'a) -> 'a list (** Similar to [Array.init], [init n f] returns the list containing the results of (f 0),(f 1).... (f (n-1)). Raise [Invalid_arg "ExtList.init"] if n < 0.*) val make : int -> 'a -> 'a list (** Similar to [String.make], [make n x] returns a * list containing [n] elements [x]. *) val first : 'a list -> 'a (** Returns the first element of the list, or raise [Empty_list] if the list is empty (similar to [hd]). *) val last : 'a list -> 'a (** Returns the last element of the list, or raise [Empty_list] if the list is empty. This function takes linear time. *) val iteri : (int -> 'a -> 'b) -> 'a list -> unit (** [iteri f l] will call [(f 0 a0);(f 1 a1) ... (f n an)] where [a0..an] are the elements of the list [l]. *) val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list (** [mapi f l] will build the list containing [(f 0 a0);(f 1 a1) ... (f n an)] where [a0..an] are the elements of the list [l]. *) val rfind : ('a -> bool) -> 'a list -> 'a (** [rfind p l] returns the last element [x] of [l] such as [p x] returns [true] or raises [Not_found] if such element as not been found. *) val find_exc : ('a -> bool) -> exn -> 'a list -> 'a (** [find_exc p e l] returns the first element of [l] such as [p x] returns [true] or raises [e] if such element as not been found. *) val findi : (int -> 'a -> bool) -> 'a list -> (int * 'a) (** [findi p e l] returns the first element [ai] of [l] along with its index [i] such that [p i ai] is true, or raises [Not_found] if no such element has been found. *) val unique : ?cmp:('a -> 'a -> bool) -> 'a list -> 'a list (** [unique cmp l] returns the list [l] without any duplicate element. Default comparator ( = ) is used if no comparison function specified. *) val filter_map : ('a -> 'b option) -> 'a list -> 'b list (** [filter_map f l] call [(f a0) (f a1).... (f an)] where [a0..an] are the elements of [l]. It returns the list of elements [bi] such as [f ai = Some bi] (when [f] returns [None], the corresponding element of [l] is discarded). *) val split_nth : int -> 'a list -> 'a list * 'a list (** [split_nth n l] returns two lists [l1] and [l2], [l1] containing the first [n] elements of [l] and [l2] the others. Raise [Invalid_index] if [n] is outside of [l] size bounds. *) val remove : 'a list -> 'a -> 'a list (** [remove l x] returns the list [l] without the first element [x] found or returns [l] if no element is equal to [x]. Elements are compared using ( = ). *) val remove_if : ('a -> bool) -> 'a list -> 'a list (** [remove_if cmp l] is similar to [remove], but with [cmp] used instead of ( = ). *) val remove_all : 'a list -> 'a -> 'a list (** [remove_all l x] is similar to [remove] but removes all elements that are equal to [x] and not only the first one. *) val take : int -> 'a list -> 'a list (** [take n l] returns up to the [n] first elements from list [l], if available. *) val drop : int -> 'a list -> 'a list (** [drop n l] returns [l] without the first [n] elements, or the empty list if [l] have less than [n] elements. *) val takewhile : ('a -> bool) -> 'a list -> 'a list (** [takewhile f xs] returns the first elements of list [xs] which satisfy the predicate [f]. *) val dropwhile : ('a -> bool) -> 'a list -> 'a list (** [dropwhile f xs] returns the list [xs] with the first elements satisfying the predicate [f] dropped. *) (** {6 Enum functions} *) (** Enumerations are important in ExtLib, they are a good way to work with abstract enumeration of elements, regardless if they are located in a list, an array, or a file. *) val enum : 'a list -> 'a Enum.t (** Returns an enumeration of the elements of a list. *) val of_enum : 'a Enum.t -> 'a list (** Build a list from an enumeration. *) (** {6 Modified functions} *) (** Some minor modifications have been made to the specification of some functions, especially concerning exceptions raised. *) val hd : 'a list -> 'a (** Returns the first element of the list or raise [Empty_list] if the list is empty. *) val tl : 'a list -> 'a list (** Returns the list without its first elements or raise [Empty_list] if the list is empty. *) val nth : 'a list -> int -> 'a (** [nth l n] returns the n-th element of the list [l] or raise [Invalid_index] is the index is outside of [l] bounds. *) val sort : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list (** Sort the list using optional comparator (by default [compare]). *) (** The following functions have been improved so all of them are tail-recursive. They have also been modified so they no longer raise [Invalid_arg] but [Different_list_size] when used on two lists having a different number of elements. *) val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val combine : 'a list -> 'b list -> ('a * 'b) list (** {6 Improved functions} *) (** The following functions have the same behavior as the [List] module ones but are tail-recursive. That means they will not cause a [Stack_overflow] when used on very long list. The implementation might be a little more slow in bytecode, but compiling in native code will not affect performances. *) val map : ('a -> 'b) -> 'a list -> 'b list val append : 'a list -> 'a list -> 'a list val flatten : 'a list list -> 'a list val concat : 'a list list -> 'a list val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list val split : ('a * 'b) list -> 'a list * 'b list (** The following functions were already tail-recursive in the [List] module but were using [List.rev] calls. The new implementations have better performances. *) val filter : ('a -> bool) -> 'a list -> 'a list val find_all : ('a -> bool) -> 'a list -> 'a list val partition : ('a -> bool) -> 'a list -> 'a list * 'a list (** {6 Older functions} *) (** These functions are already part of the Ocaml standard library and have not been modified. Please refer to the Ocaml Manual for documentation. *) val length : 'a list -> int val rev_append : 'a list -> 'a list -> 'a list val rev : 'a list -> 'a list val rev_map : ('a -> 'b) -> 'a list -> 'b list val iter : ('a -> unit) -> 'a list -> unit val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a list -> 'b val for_all : ('a -> bool) -> 'a list -> bool val exists : ('a -> bool) -> 'a list -> bool val find : ('a -> bool) -> 'a list -> 'a val mem : 'a -> 'a list -> bool val memq : 'a -> 'a list -> bool val assoc : 'a -> ('a * 'b) list -> 'b val assq : 'a -> ('a * 'b) list -> 'b val mem_assoc : 'a -> ('a * 'b) list -> bool val mem_assq : 'a -> ('a * 'b) list -> bool val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** {6 Exceptions} *) exception Empty_list (** [Empty_list] is raised when an operation applied on an empty list is invalid : [hd] for example. *) exception Invalid_index of int (** [Invalid_index] is raised when an indexed access on a list is out of list bounds. *) exception Different_list_size of string (** [Different_list_size] is raised when applying functions such as [iter2] on two lists having different size. *) end val ( @ ) : 'a list -> 'a list -> 'a list (** the new implementation for ( @ ) operator, see [List.append]. *) haxe-3.0~svn6707/libs/extlib/global.mli0000644000175000017500000000411412172015140020360 0ustar bdefreesebdefreese(* * Global - Mutable global variable * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Mutable global variable. Often in OCaml you want to have a global variable, which is mutable and uninitialized when declared. You can use a ['a option ref] but this is not very convenient. The Global module provides functions to easily create and manipulate such variables. *) type 'a t (** Abstract type of a global *) exception Global_not_initialized of string (** Raised when a global variable is accessed without first having been assigned a value. The parameter contains the name of the global. *) val empty : string -> 'a t (** Returns an new named empty global. The name of the global can be any string. It identifies the global and makes debugging easier. *) val name : 'a t -> string (** Retrieve the name of a global. *) val set : 'a t -> 'a -> unit (** Set the global value contents. *) val get : 'a t -> 'a (** Get the global value contents - raise Global_not_initialized if not defined. *) val undef : 'a t -> unit (** Reset the global value contents to undefined. *) val isdef : 'a t -> bool (** Return [true] if the global value has been set. *) val opt : 'a t -> 'a option (** Return [None] if the global is undefined, else [Some v] where v is the current global value contents. *) haxe-3.0~svn6707/libs/extlib/multiArray.mli0000644000175000017500000001064412172015140021256 0ustar bdefreesebdefreese(* * MultiArray - Resizeable Ocaml big arrays * Copyright (C) 201 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Dynamic Big arrays. A dynamic array is equivalent to a OCaml array that will resize itself when elements are added or removed. MultiArray is different from DynArray since it allows more than 4 Millions elements on 32 bits systems. A MultiArray of size <= Sys.max_array_length will use a single indirection internal representation. If the size exceeds Sys.max_array_length, e.g. by adding an additional element, the internal representation is promoted to use double indirection. This allows for bigger arrays, but it also slower. *) type 'a t exception Invalid_arg of int * string * string (** When an operation on an array fails, [Invalid_arg] is raised. The integer is the value that made the operation fail, the first string contains the function name that has been called and the second string contains the parameter name that made the operation fail. *) (** {6 MultiArray creation} *) val create : unit -> 'a t (** [create()] returns a new empty dynamic array. *) val make : int -> 'a -> 'a t (** [make count value] returns an array with some memory already allocated and [count] elements initialized to [value]. *) val init : int -> (int -> 'a) -> 'a t (** [init n f] returns an array of [n] elements filled with values returned by [f 0 , f 1, ... f (n-1)]. *) (** {6 MultiArray manipulation functions} *) val empty : 'a t -> bool (** Return true if the number of elements in the array is 0. *) val length : 'a t -> int (** Return the number of elements in the array. *) val get : 'a t -> int -> 'a (** [get darr idx] gets the element in [darr] at index [idx]. If [darr] has [len] elements in it, then the valid indexes range from [0] to [len-1]. *) val set : 'a t -> int -> 'a -> unit (** [set darr idx v] sets the element of [darr] at index [idx] to value [v]. The previous value is overwritten. *) val add : 'a t -> 'a -> unit (** [add darr v] appends [v] onto [darr]. [v] becomes the new last element of [darr]. If required, the size of the internal representation is doubled. If this would exceed Sys.max_array_length, the internal representation is automatically changed to double indirection and the current contents are copied over. *) val clear : 'a t -> unit (** remove all elements from the array and resize it to 0. *) (** {6 MultiArray copy and conversion} *) val of_array : 'a array -> 'a t (** [of_array arr] returns an array with the elements of [arr] in it in order. *) val of_list : 'a list -> 'a t (** [of_list lst] returns a dynamic array with the elements of [lst] in it in order. *) (** {6 MultiArray functional support} *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f darr] calls the function [f] on every element of [darr]. It is equivalent to [for i = 0 to length darr - 1 do f (get darr i) done;] *) val iteri : (int -> 'a -> unit) -> 'a t -> unit (** [iter f darr] calls the function [f] on every element of [darr]. It is equivalent to [for i = 0 to length darr - 1 do f i (get darr i) done;] *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f darr] applies the function [f] to every element of [darr] and creates a dynamic array from the results - similar to [List.map] or [Array.map]. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** [mapi f darr] applies the function [f] to every element of [darr] and creates a dynamic array from the results - similar to [List.mapi] or [Array.mapi]. *) val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** [fold_left f x darr] computes [f ( ... ( f ( f (get darr 0) x) (get darr 1) ) ... ) (get darr n-1)], similar to [Array.fold_left] or [List.fold_left]. *)haxe-3.0~svn6707/libs/extlib/dynArray.ml0000644000175000017500000002454212172015140020547 0ustar bdefreesebdefreese(* * DynArray - Resizeable Ocaml arrays * Copyright (C) 2003 Brian Hurt * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type resizer_t = currslots:int -> oldlength:int -> newlength:int -> int type 'a intern external ilen : 'a intern -> int = "%obj_size" let idup (x : 'a intern) = if ilen x = 0 then x else (Obj.magic (Obj.dup (Obj.repr x)) : 'a intern) let imake tag len = (Obj.magic (Obj.new_block tag len) : 'a intern) external iget : 'a intern -> int -> 'a = "%obj_field" external iset : 'a intern -> int -> 'a -> unit = "%obj_set_field" type 'a t = { mutable arr : 'a intern; mutable len : int; mutable resize: resizer_t; } exception Invalid_arg of int * string * string let invalid_arg n f p = raise (Invalid_arg (n,f,p)) let length d = d.len let exponential_resizer ~currslots ~oldlength ~newlength = let rec doubler x = if x >= newlength then x else doubler (x * 2) in let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in if newlength = 1 then 1 else if currslots = 0 then doubler 1 else if currslots < newlength then doubler currslots else halfer currslots let step_resizer step = if step <= 0 then invalid_arg step "step_resizer" "step"; (fun ~currslots ~oldlength ~newlength -> if currslots < newlength || newlength < (currslots - step) then (newlength + step - (newlength mod step)) else currslots) let conservative_exponential_resizer ~currslots ~oldlength ~newlength = let rec doubler x = if x >= newlength then x else doubler (x * 2) in let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in if currslots < newlength then begin if newlength = 1 then 1 else if currslots = 0 then doubler 1 else doubler currslots end else if oldlength < newlength then halfer currslots else currslots let default_resizer = conservative_exponential_resizer let changelen (d : 'a t) newlen = let oldsize = ilen d.arr in let r = d.resize ~currslots:oldsize ~oldlength:d.len ~newlength:newlen in (* We require the size to be at least large enough to hold the number * of elements we know we need! *) let newsize = if r < newlen then newlen else r in if newsize <> oldsize then begin let newarr = imake 0 newsize in let cpylen = (if newlen < d.len then newlen else d.len) in for i = 0 to cpylen - 1 do iset newarr i (iget d.arr i); done; d.arr <- newarr; end; d.len <- newlen let compact d = if d.len <> ilen d.arr then begin let newarr = imake 0 d.len in for i = 0 to d.len - 1 do iset newarr i (iget d.arr i) done; d.arr <- newarr; end let create() = { resize = default_resizer; len = 0; arr = imake 0 0; } let make initsize = if initsize < 0 then invalid_arg initsize "make" "size"; { resize = default_resizer; len = 0; arr = imake 0 initsize; } let init initlen f = if initlen < 0 then invalid_arg initlen "init" "len"; let arr = imake 0 initlen in for i = 0 to initlen-1 do iset arr i (f i) done; { resize = default_resizer; len = initlen; arr = arr; } let set_resizer d resizer = d.resize <- resizer let get_resizer d = d.resize let empty d = d.len = 0 let get d idx = if idx < 0 || idx >= d.len then invalid_arg idx "get" "index"; iget d.arr idx let last d = if d.len = 0 then invalid_arg 0 "last" ""; iget d.arr (d.len - 1) let set d idx v = if idx < 0 || idx >= d.len then invalid_arg idx "set" "index"; iset d.arr idx v let insert d idx v = if idx < 0 || idx > d.len then invalid_arg idx "insert" "index"; if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1; if idx < d.len - 1 then begin for i = d.len - 2 downto idx do iset d.arr (i+1) (iget d.arr i) done; end; iset d.arr idx v let add d v = if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1; iset d.arr (d.len - 1) v let delete d idx = if idx < 0 || idx >= d.len then invalid_arg idx "delete" "index"; let oldsize = ilen d.arr in (* we don't call changelen because we want to blit *) let r = d.resize ~currslots:oldsize ~oldlength:d.len ~newlength:(d.len - 1) in let newsize = (if r < d.len - 1 then d.len - 1 else r) in if oldsize <> newsize then begin let newarr = imake 0 newsize in for i = 0 to idx - 1 do iset newarr i (iget d.arr i); done; for i = idx to d.len - 2 do iset newarr i (iget d.arr (i+1)); done; d.arr <- newarr; end else begin for i = idx to d.len - 2 do iset d.arr i (iget d.arr (i+1)); done; iset d.arr (d.len - 1) (Obj.magic 0) end; d.len <- d.len - 1 let delete_range d idx len = if len < 0 then invalid_arg len "delete_range" "length"; if idx < 0 || idx + len > d.len then invalid_arg idx "delete_range" "index"; let oldsize = ilen d.arr in (* we don't call changelen because we want to blit *) let r = d.resize ~currslots:oldsize ~oldlength:d.len ~newlength:(d.len - len) in let newsize = (if r < d.len - len then d.len - len else r) in if oldsize <> newsize then begin let newarr = imake 0 newsize in for i = 0 to idx - 1 do iset newarr i (iget d.arr i); done; for i = idx to d.len - len - 1 do iset newarr i (iget d.arr (i+len)); done; d.arr <- newarr; end else begin for i = idx to d.len - len - 1 do iset d.arr i (iget d.arr (i+len)); done; for i = d.len - len to d.len - 1 do iset d.arr i (Obj.magic 0) done; end; d.len <- d.len - len let clear d = d.len <- 0; d.arr <- imake 0 0 let delete_last d = if d.len <= 0 then invalid_arg 0 "delete_last" ""; (* erase for GC, in case changelen don't resize our array *) iset d.arr (d.len - 1) (Obj.magic 0); changelen d (d.len - 1) let rec blit src srcidx dst dstidx len = if len < 0 then invalid_arg len "blit" "len"; if srcidx < 0 || srcidx + len > src.len then invalid_arg srcidx "blit" "source index"; if dstidx < 0 || dstidx > dst.len then invalid_arg dstidx "blit" "dest index"; let newlen = dstidx + len in if newlen > ilen dst.arr then begin (* this case could be inlined so we don't blit on just-copied elements *) changelen dst newlen end else begin if newlen > dst.len then dst.len <- newlen; end; (* same array ! we need to copy in reverse order *) if src.arr == dst.arr && dstidx > srcidx then for i = len - 1 downto 0 do iset dst.arr (dstidx+i) (iget src.arr (srcidx+i)); done else for i = 0 to len - 1 do iset dst.arr (dstidx+i) (iget src.arr (srcidx+i)); done let append src dst = blit src 0 dst dst.len src.len let to_list d = let rec loop idx accum = if idx < 0 then accum else loop (idx - 1) (iget d.arr idx :: accum) in loop (d.len - 1) [] let to_array d = if d.len = 0 then begin (* since the empty array is an atom, we don't care if float or not *) [||] end else begin let arr = Array.make d.len (iget d.arr 0) in for i = 1 to d.len - 1 do Array.unsafe_set arr i (iget d.arr i) done; arr; end let of_list lst = let size = List.length lst in let arr = imake 0 size in let rec loop idx = function | h :: t -> iset arr idx h; loop (idx + 1) t | [] -> () in loop 0 lst; { resize = default_resizer; len = size; arr = arr; } let of_array src = let size = Array.length src in let is_float = Obj.tag (Obj.repr src) = Obj.double_array_tag in let arr = (if is_float then begin let arr = imake 0 size in for i = 0 to size - 1 do iset arr i (Array.unsafe_get src i); done; arr end else (* copy the fields *) idup (Obj.magic src : 'a intern)) in { resize = default_resizer; len = size; arr = arr; } let copy src = { resize = src.resize; len = src.len; arr = idup src.arr; } let sub src start len = if len < 0 then invalid_arg len "sub" "len"; if start < 0 || start + len > src.len then invalid_arg start "sub" "start"; let arr = imake 0 len in for i = 0 to len - 1 do iset arr i (iget src.arr (i+start)); done; { resize = src.resize; len = len; arr = arr; } let iter f d = for i = 0 to d.len - 1 do f (iget d.arr i) done let iteri f d = for i = 0 to d.len - 1 do f i (iget d.arr i) done let filter f d = let l = d.len in let a = imake 0 l in let a2 = d.arr in let p = ref 0 in for i = 0 to l - 1 do let x = iget a2 i in if f x then begin iset a !p x; incr p; end; done; d.len <- !p; d.arr <- a let index_of f d = let rec loop i = if i >= d.len then raise Not_found else if f (iget d.arr i) then i else loop (i+1) in loop 0 let map f src = let arr = imake 0 src.len in for i = 0 to src.len - 1 do iset arr i (f (iget src.arr i)) done; { resize = src.resize; len = src.len; arr = arr; } let mapi f src = let arr = imake 0 src.len in for i = 0 to src.len - 1 do iset arr i (f i (iget src.arr i)) done; { resize = src.resize; len = src.len; arr = arr; } let fold_left f x a = let rec loop idx x = if idx >= a.len then x else loop (idx + 1) (f x (iget a.arr idx)) in loop 0 x let fold_right f a x = let rec loop idx x = if idx < 0 then x else loop (idx - 1) (f (iget a.arr idx) x) in loop (a.len - 1) x let enum d = let rec make start = let idxref = ref 0 in let next () = if !idxref >= d.len then raise Enum.No_more_elements else let retval = iget d.arr !idxref in incr idxref; retval and count () = if !idxref >= d.len then 0 else d.len - !idxref and clone () = make !idxref in Enum.make ~next:next ~count:count ~clone:clone in make 0 let of_enum e = if Enum.fast_count e then begin let c = Enum.count e in let arr = imake 0 c in Enum.iteri (fun i x -> iset arr i x) e; { resize = default_resizer; len = c; arr = arr; } end else let d = make 0 in Enum.iter (add d) e; d let unsafe_get a n = iget a.arr n let unsafe_set a n x = iset a.arr n x haxe-3.0~svn6707/libs/extlib/pMap.ml0000644000175000017500000001241712172015140017651 0ustar bdefreesebdefreese(* * PMap - Polymorphic maps * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type ('k, 'v) map = | Empty | Node of ('k, 'v) map * 'k * 'v * ('k, 'v) map * int type ('k, 'v) t = { cmp : 'k -> 'k -> int; map : ('k, 'v) map; } let height = function | Node (_, _, _, _, h) -> h | Empty -> 0 let make l k v r = Node (l, k, v, r, max (height l) (height r) + 1) let bal l k v r = let hl = height l in let hr = height r in if hl > hr + 2 then match l with | Node (ll, lk, lv, lr, _) -> if height ll >= height lr then make ll lk lv (make lr k v r) else (match lr with | Node (lrl, lrk, lrv, lrr, _) -> make (make ll lk lv lrl) lrk lrv (make lrr k v r) | Empty -> assert false) | Empty -> assert false else if hr > hl + 2 then match r with | Node (rl, rk, rv, rr, _) -> if height rr >= height rl then make (make l k v rl) rk rv rr else (match rl with | Node (rll, rlk, rlv, rlr, _) -> make (make l k v rll) rlk rlv (make rlr rk rv rr) | Empty -> assert false) | Empty -> assert false else Node (l, k, v, r, max hl hr + 1) let rec min_binding = function | Node (Empty, k, v, _, _) -> k, v | Node (l, _, _, _, _) -> min_binding l | Empty -> raise Not_found let rec remove_min_binding = function | Node (Empty, _, _, r, _) -> r | Node (l, k, v, r, _) -> bal (remove_min_binding l) k v r | Empty -> invalid_arg "PMap.remove_min_binding" let merge t1 t2 = match t1, t2 with | Empty, _ -> t2 | _, Empty -> t1 | _ -> let k, v = min_binding t2 in bal t1 k v (remove_min_binding t2) let create cmp = { cmp = cmp; map = Empty } let empty = { cmp = compare; map = Empty } let is_empty x = x.map = Empty let add x d { cmp = cmp; map = map } = let rec loop = function | Node (l, k, v, r, h) -> let c = cmp x k in if c = 0 then Node (l, x, d, r, h) else if c < 0 then let nl = loop l in bal nl k v r else let nr = loop r in bal l k v nr | Empty -> Node (Empty, x, d, Empty, 1) in { cmp = cmp; map = loop map } let find x { cmp = cmp; map = map } = let rec loop = function | Node (l, k, v, r, _) -> let c = cmp x k in if c < 0 then loop l else if c > 0 then loop r else v | Empty -> raise Not_found in loop map let remove x { cmp = cmp; map = map } = let rec loop = function | Node (l, k, v, r, _) -> let c = cmp x k in if c = 0 then merge l r else if c < 0 then bal (loop l) k v r else bal l k v (loop r) | Empty -> Empty in { cmp = cmp; map = loop map } let mem x { cmp = cmp; map = map } = let rec loop = function | Node (l, k, v, r, _) -> let c = cmp x k in c = 0 || loop (if c < 0 then l else r) | Empty -> false in loop map let exists = mem let iter f { map = map } = let rec loop = function | Empty -> () | Node (l, k, v, r, _) -> loop l; f k v; loop r in loop map let map f { cmp = cmp; map = map } = let rec loop = function | Empty -> Empty | Node (l, k, v, r, h) -> let l = loop l in let r = loop r in Node (l, k, f v, r, h) in { cmp = cmp; map = loop map } let mapi f { cmp = cmp; map = map } = let rec loop = function | Empty -> Empty | Node (l, k, v, r, h) -> let l = loop l in let r = loop r in Node (l, k, f k v, r, h) in { cmp = cmp; map = loop map } let fold f { cmp = cmp; map = map } acc = let rec loop acc = function | Empty -> acc | Node (l, k, v, r, _) -> loop (f v (loop acc l)) r in loop acc map let foldi f { cmp = cmp; map = map } acc = let rec loop acc = function | Empty -> acc | Node (l, k, v, r, _) -> loop (f k v (loop acc l)) r in loop acc map let rec enum m = let rec make l = let l = ref l in let rec next() = match !l with | [] -> raise Enum.No_more_elements | Empty :: tl -> l := tl; next() | Node (m1, key, data, m2, h) :: tl -> l := m1 :: m2 :: tl; (key, data) in let count() = let n = ref 0 in let r = !l in try while true do ignore (next()); incr n done; assert false with Enum.No_more_elements -> l := r; !n in let clone() = make !l in Enum.make ~next ~count ~clone in make [m.map] let uncurry_add (k, v) m = add k v m let of_enum ?(cmp = compare) e = Enum.fold uncurry_add (create cmp) e haxe-3.0~svn6707/libs/extlib/uTF8.ml0000644000175000017500000001701212172015140017536 0ustar bdefreesebdefreese(* * UTF-8 - UTF-8 encoded Unicode string * Copyright 2002, 2003 (C) Yamagata Yoriyuki. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open UChar type t = string type index = int let look s i = let n' = let n = Char.code s.[i] in if n < 0x80 then n else if n <= 0xdf then (n - 0xc0) lsl 6 lor (0x7f land (Char.code s.[i + 1])) else if n <= 0xef then let n' = n - 0xe0 in let m0 = Char.code s.[i + 2] in let m = Char.code (String.unsafe_get s (i + 1)) in let n' = n' lsl 6 lor (0x7f land m) in n' lsl 6 lor (0x7f land m0) else if n <= 0xf7 then let n' = n - 0xf0 in let m0 = Char.code s.[i + 3] in let m = Char.code (String.unsafe_get s (i + 1)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 2)) in let n' = n' lsl 6 lor (0x7f land m) in n' lsl 6 lor (0x7f land m0) else if n <= 0xfb then let n' = n - 0xf8 in let m0 = Char.code s.[i + 4] in let m = Char.code (String.unsafe_get s (i + 1)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 2)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 3)) in let n' = n' lsl 6 lor (0x7f land m) in n' lsl 6 lor (0x7f land m0) else if n <= 0xfd then let n' = n - 0xfc in let m0 = Char.code s.[i + 5] in let m = Char.code (String.unsafe_get s (i + 1)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 2)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 3)) in let n' = n' lsl 6 lor (0x7f land m) in let m = Char.code (String.unsafe_get s (i + 4)) in let n' = n' lsl 6 lor (0x7f land m) in n' lsl 6 lor (0x7f land m0) else invalid_arg "UTF8.look" in Obj.magic n' let rec search_head s i = if i >= String.length s then i else let n = Char.code (String.unsafe_get s i) in if n < 0x80 || n >= 0xc2 then i else search_head s (i + 1) let next s i = let n = Char.code s.[i] in if n < 0x80 then i + 1 else if n < 0xc0 then search_head s (i + 1) else if n <= 0xdf then i + 2 else if n <= 0xef then i + 3 else if n <= 0xf7 then i + 4 else if n <= 0xfb then i + 5 else if n <= 0xfd then i + 6 else invalid_arg "UTF8.next" let rec search_head_backward s i = if i < 0 then -1 else let n = Char.code s.[i] in if n < 0x80 || n >= 0xc2 then i else search_head_backward s (i - 1) let prev s i = search_head_backward s (i - 1) let move s i n = if n >= 0 then let rec loop i n = if n <= 0 then i else loop (next s i) (n - 1) in loop i n else let rec loop i n = if n >= 0 then i else loop (prev s i) (n + 1) in loop i n let rec nth_aux s i n = if n = 0 then i else nth_aux s (next s i) (n - 1) let nth s n = nth_aux s 0 n let last s = search_head_backward s (String.length s - 1) let out_of_range s i = i < 0 || i >= String.length s let compare_index _ i j = i - j let get s n = look s (nth s n) let add_uchar buf u = let masq = 0b111111 in let k = int_of_uchar u in if k < 0 || k >= 0x4000000 then begin Buffer.add_char buf (Char.chr (0xfc + (k lsr 30))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 24) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); end else if k <= 0x7f then Buffer.add_char buf (Char.unsafe_chr k) else if k <= 0x7ff then begin Buffer.add_char buf (Char.unsafe_chr (0xc0 lor (k lsr 6))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))) end else if k <= 0xffff then begin Buffer.add_char buf (Char.unsafe_chr (0xe0 lor (k lsr 12))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); end else if k <= 0x1fffff then begin Buffer.add_char buf (Char.unsafe_chr (0xf0 + (k lsr 18))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); end else begin Buffer.add_char buf (Char.unsafe_chr (0xf8 + (k lsr 24))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); end let init len f = let buf = Buffer.create len in for c = 0 to len - 1 do add_uchar buf (f c) done; Buffer.contents buf let rec length_aux s c i = if i >= String.length s then c else let n = Char.code (String.unsafe_get s i) in let k = if n < 0x80 then 1 else if n < 0xc0 then invalid_arg "UTF8.length" else if n < 0xe0 then 2 else if n < 0xf0 then 3 else if n < 0xf8 then 4 else if n < 0xfc then 5 else if n < 0xfe then 6 else invalid_arg "UTF8.length" in length_aux s (c + 1) (i + k) let length s = length_aux s 0 0 let rec iter_aux proc s i = if i >= String.length s then () else let u = look s i in proc u; iter_aux proc s (next s i) let iter proc s = iter_aux proc s 0 let compare s1 s2 = Pervasives.compare s1 s2 exception Malformed_code let validate s = let rec trail c i a = if c = 0 then a else if i >= String.length s then raise Malformed_code else let n = Char.code (String.unsafe_get s i) in if n < 0x80 || n >= 0xc0 then raise Malformed_code else trail (c - 1) (i + 1) (a lsl 6 lor (n - 0x80)) in let rec main i = if i >= String.length s then () else let n = Char.code (String.unsafe_get s i) in if n < 0x80 then main (i + 1) else if n < 0xc2 then raise Malformed_code else if n <= 0xdf then if trail 1 (i + 1) (n - 0xc0) < 0x80 then raise Malformed_code else main (i + 2) else if n <= 0xef then if trail 2 (i + 1) (n - 0xe0) < 0x800 then raise Malformed_code else main (i + 3) else if n <= 0xf7 then if trail 3 (i + 1) (n - 0xf0) < 0x10000 then raise Malformed_code else main (i + 4) else if n <= 0xfb then if trail 4 (i + 1) (n - 0xf8) < 0x200000 then raise Malformed_code else main (i + 5) else if n <= 0xfd then let n = trail 5 (i + 1) (n - 0xfc) in if n lsr 16 < 0x400 then raise Malformed_code else main (i + 6) else raise Malformed_code in main 0 module Buf = struct include Buffer type buf = t let add_char = add_uchar end haxe-3.0~svn6707/libs/extlib/extHashtbl.ml0000644000175000017500000000670412172015140021064 0ustar bdefreesebdefreese(* * ExtHashtbl, extra functions over hashtables. * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module Hashtbl = struct type ('a, 'b) h_bucketlist = | Empty | Cons of 'a * 'b * ('a, 'b) h_bucketlist type ('a, 'b) h_t = { mutable size: int; mutable data: ('a, 'b) h_bucketlist array } include Hashtbl external h_conv : ('a, 'b) t -> ('a, 'b) h_t = "%identity" external h_make : ('a, 'b) h_t -> ('a, 'b) t = "%identity" let create (size:int) = create size let exists = mem let enum h = let rec make ipos ibuck idata icount = let pos = ref ipos in let buck = ref ibuck in let hdata = ref idata in let hcount = ref icount in let force() = (** this is a hack in order to keep an O(1) enum constructor **) if !hcount = -1 then begin hcount := (h_conv h).size; hdata := Array.copy (h_conv h).data; end; in let rec next() = force(); match !buck with | Empty -> if !hcount = 0 then raise Enum.No_more_elements; incr pos; buck := Array.unsafe_get !hdata !pos; next() | Cons (k,i,next_buck) -> buck := next_buck; decr hcount; (k,i) in let count() = if !hcount = -1 then (h_conv h).size else !hcount in let clone() = force(); make !pos !buck !hdata !hcount in Enum.make ~next ~count ~clone in make (-1) Empty (Obj.magic()) (-1) let keys h = Enum.map (fun (k,_) -> k) (enum h) let values h = Enum.map (fun (_,v) -> v) (enum h) let map f h = let rec loop = function | Empty -> Empty | Cons (k,v,next) -> Cons (k,f v,loop next) in h_make { size = (h_conv h).size; data = Array.map loop (h_conv h).data; } let remove_all h key = let hc = h_conv h in let rec loop = function | Empty -> Empty | Cons(k,v,next) -> if k = key then begin hc.size <- pred hc.size; loop next end else Cons(k,v,loop next) in let pos = (hash key) mod (Array.length hc.data) in Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos)) let find_default h key defval = let rec loop = function | Empty -> defval | Cons (k,v,next) -> if k = key then v else loop next in let pos = (hash key) mod (Array.length (h_conv h).data) in loop (Array.unsafe_get (h_conv h).data pos) let find_option h key = let rec loop = function | Empty -> None | Cons (k,v,next) -> if k = key then Some v else loop next in let pos = (hash key) mod (Array.length (h_conv h).data) in loop (Array.unsafe_get (h_conv h).data pos) let of_enum e = let h = create (if Enum.fast_count e then Enum.count e else 0) in Enum.iter (fun (k,v) -> add h k v) e; h let length h = (h_conv h).size end haxe-3.0~svn6707/libs/extlib/dynArray.mli0000644000175000017500000002634112172015140020717 0ustar bdefreesebdefreese(* * DynArray - Resizeable Ocaml arrays * Copyright (C) 2003 Brian Hurt * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Dynamic arrays. A dynamic array is equivalent to a OCaml array that will resize itself when elements are added or removed, except that floats are boxed and that no initialization element is required. *) type 'a t exception Invalid_arg of int * string * string (** When an operation on an array fails, [Invalid_arg] is raised. The integer is the value that made the operation fail, the first string contains the function name that has been called and the second string contains the parameter name that made the operation fail. *) (** {6 Array creation} *) val create : unit -> 'a t (** [create()] returns a new empty dynamic array. *) val make : int -> 'a t (** [make count] returns an array with some memory already allocated so up to [count] elements can be stored into it without resizing. *) val init : int -> (int -> 'a) -> 'a t (** [init n f] returns an array of [n] elements filled with values returned by [f 0 , f 1, ... f (n-1)]. *) (** {6 Array manipulation functions} *) val empty : 'a t -> bool (** Return true if the number of elements in the array is 0. *) val length : 'a t -> int (** Return the number of elements in the array. *) val get : 'a t -> int -> 'a (** [get darr idx] gets the element in [darr] at index [idx]. If [darr] has [len] elements in it, then the valid indexes range from [0] to [len-1]. *) val last : 'a t -> 'a (** [last darr] returns the last element of [darr]. *) val set : 'a t -> int -> 'a -> unit (** [set darr idx v] sets the element of [darr] at index [idx] to value [v]. The previous value is overwritten. *) val insert : 'a t -> int -> 'a -> unit (** [insert darr idx v] inserts [v] into [darr] at index [idx]. All elements of [darr] with an index greater than or equal to [idx] have their index incremented (are moved up one place) to make room for the new element. *) val add : 'a t -> 'a -> unit (** [add darr v] appends [v] onto [darr]. [v] becomes the new last element of [darr]. *) val append : 'a t -> 'a t -> unit (** [append src dst] adds all elements of [src] to the end of [dst]. *) val delete : 'a t -> int -> unit (** [delete darr idx] deletes the element of [darr] at [idx]. All elements with an index greater than [idx] have their index decremented (are moved down one place) to fill in the hole. *) val delete_last : 'a t -> unit (** [delete_last darr] deletes the last element of [darr]. This is equivalent of doing [delete darr ((length darr) - 1)]. *) val delete_range : 'a t -> int -> int -> unit (** [delete_range darr p len] deletes [len] elements starting at index [p]. All elements with an index greater than [p+len] are moved to fill in the hole. *) val clear : 'a t -> unit (** remove all elements from the array and resize it to 0. *) val blit : 'a t -> int -> 'a t -> int -> int -> unit (** [blit src srcidx dst dstidx len] copies [len] elements from [src] starting with index [srcidx] to [dst] starting at [dstidx]. *) val compact : 'a t -> unit (** [compact darr] ensures that the space allocated by the array is minimal.*) (** {6 Array copy and conversion} *) val to_list : 'a t -> 'a list (** [to_list darr] returns the elements of [darr] in order as a list. *) val to_array : 'a t -> 'a array (** [to_array darr] returns the elements of [darr] in order as an array. *) val enum : 'a t -> 'a Enum.t (** [enum darr] returns the enumeration of [darr] elements. *) val of_list : 'a list -> 'a t (** [of_list lst] returns a dynamic array with the elements of [lst] in it in order. *) val of_array : 'a array -> 'a t (** [of_array arr] returns an array with the elements of [arr] in it in order. *) val of_enum : 'a Enum.t -> 'a t (** [of_enum e] returns an array that holds, in order, the elements of [e]. *) val copy : 'a t -> 'a t (** [copy src] returns a fresh copy of [src], such that no modification of [src] affects the copy, or vice versa (all new memory is allocated for the copy). *) val sub : 'a t -> int -> int -> 'a t (** [sub darr start len] returns an array holding the subset of [len] elements from [darr] starting with the element at index [idx]. *) (** {6 Array functional support} *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f darr] calls the function [f] on every element of [darr]. It is equivalent to [for i = 0 to length darr - 1 do f (get darr i) done;] *) val iteri : (int -> 'a -> unit) -> 'a t -> unit (** [iter f darr] calls the function [f] on every element of [darr]. It is equivalent to [for i = 0 to length darr - 1 do f i (get darr i) done;] *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f darr] applies the function [f] to every element of [darr] and creates a dynamic array from the results - similar to [List.map] or [Array.map]. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** [mapi f darr] applies the function [f] to every element of [darr] and creates a dynamic array from the results - similar to [List.mapi] or [Array.mapi]. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [fold_left f x darr] computes [f ( ... ( f ( f (get darr 0) x) (get darr 1) ) ... ) (get darr n-1)], similar to [Array.fold_left] or [List.fold_left]. *) val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold_right f darr x] computes [ f (get darr 0) (f (get darr 1) ( ... ( f (get darr n-1) x ) ... ) ) ] similar to [Array.fold_right] or [List.fold_right]. *) val index_of : ('a -> bool) -> 'a t -> int (** [index_of f darr] returns the index of the first element [x] in darr such as [f x] returns [true] or raise [Not_found] if not found. *) val filter : ('a -> bool) -> 'a t -> unit (** {6 Array resizers} *) type resizer_t = currslots:int -> oldlength:int -> newlength:int -> int (** The type of a resizer function. Resizer functions are called whenever elements are added to or removed from the dynamic array to determine what the current number of storage spaces in the array should be. The three named arguments passed to a resizer are the current number of storage spaces in the array, the length of the array before the elements are added or removed, and the length the array will be after the elements are added or removed. If elements are being added, newlength will be larger than oldlength, if elements are being removed, newlength will be smaller than oldlength. If the resizer function returns exactly oldlength, the size of the array is only changed when adding an element while there is not enough space for it. By default, all dynamic arrays are created with the [default_resizer]. When a dynamic array is created from another dynamic array (using [copy], [map] , etc. ) the resizer of the copy will be the same as the original dynamic array resizer. To change the resizer, use the [set_resizer] function. *) val set_resizer : 'a t -> resizer_t -> unit (** Change the resizer for this array. *) val get_resizer : 'a t -> resizer_t (** Get the current resizer function for a given array *) val default_resizer : resizer_t (** The default resizer function the library is using - in this version of DynArray, this is the [exponential_resizer] but should change in next versions. *) val exponential_resizer : resizer_t (** The exponential resizer- The default resizer except when the resizer is being copied from some other darray. [exponential_resizer] works by doubling or halving the number of slots until they "fit". If the number of slots is less than the new length, the number of slots is doubled until it is greater than the new length (or Sys.max_array_size is reached). If the number of slots is more than four times the new length, the number of slots is halved until it is less than four times the new length. Allowing darrays to fall below 25% utilization before shrinking them prevents "thrashing". Consider the case where the caller is constantly adding a few elements, and then removing a few elements, causing the length to constantly cross above and below a power of two. Shrinking the array when it falls below 50% would causing the underlying array to be constantly allocated and deallocated. A few elements would be added, causing the array to be reallocated and have a usage of just above 50%. Then a few elements would be remove, and the array would fall below 50% utilization and be reallocated yet again. The bulk of the array, untouched, would be copied and copied again. By setting the threshold at 25% instead, such "thrashing" only occurs with wild swings- adding and removing huge numbers of elements (more than half of the elements in the array). [exponential_resizer] is a good performing resizer for most applications. A list allocates 2 words for every element, while an array (with large numbers of elements) allocates only 1 word per element (ignoring unboxed floats). On insert, [exponential_resizer] keeps the amount of wasted "extra" array elements below 50%, meaning that less than 2 words per element are used. Even on removals where the amount of wasted space is allowed to rise to 75%, that only means that darray is using 4 words per element. This is generally not a significant overhead. Furthermore, [exponential_resizer] minimizes the number of copies needed- appending n elements into an empty darray with initial size 0 requires between n and 2n elements of the array be copied- O(n) work, or O(1) work per element (on average). A similar argument can be made that deletes from the end of the array are O(1) as well (obviously deletes from anywhere else are O(n) work- you have to move the n or so elements above the deleted element down). *) val step_resizer : int -> resizer_t (** The stepwise resizer- another example of a resizer function, this time of a parameterized resizer. The resizer returned by [step_resizer step] returns the smallest multiple of [step] larger than [newlength] if [currslots] is less then [newlength]-[step] or greater than [newlength]. For example, to make an darray with a step of 10, a length of len, and a null of null, you would do: [make] ~resizer:([step_resizer] 10) len null *) val conservative_exponential_resizer : resizer_t (** [conservative_exponential_resizer] is an example resizer function which uses the oldlength parameter. It only shrinks the array on inserts- no deletes shrink the array, only inserts. It does this by comparing the oldlength and newlength parameters. Other than that, it acts like [exponential_resizer]. *) (** {6 Unsafe operations} **) val unsafe_get : 'a t -> int -> 'a val unsafe_set : 'a t -> int -> 'a -> unit haxe-3.0~svn6707/libs/extlib/extLib.ml0000755000175000017500000000277712172015140020216 0ustar bdefreesebdefreese(* * ExtLib - use extensions as separate modules * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (* Note: Since ExtLib is provided for namespace convenience for users who wants to keep the usage of the original Ocaml Standard Library, no MLI CMI nor documentation will be provided for this module. Users can simply do an "open ExtLib" to import all Ext* namespaces instead of doing "open ExtList" for example. The trade-off is that they'll have to link all the modules included below so the resulting binary is bigger. *) module List = ExtList.List module String = ExtString.String module Hashtbl = ExtHashtbl.Hashtbl module Array = ExtArray.Array exception Invalid_string = ExtString.Invalid_string include Std haxe-3.0~svn6707/libs/extlib/enum.ml0000644000175000017500000001555212172015140017723 0ustar bdefreesebdefreese(* * Enum - Enumeration over abstract collection of elements. * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a t = { mutable count : unit -> int; mutable next : unit -> 'a; mutable clone : unit -> 'a t; mutable fast : bool; } (* raised by 'next' functions, should NOT go outside the API *) exception No_more_elements let _dummy () = assert false let make ~next ~count ~clone = { count = count; next = next; clone = clone; fast = true; } let rec init n f = if n < 0 then invalid_arg "Enum.init"; let count = ref n in { count = (fun () -> !count); next = (fun () -> match !count with | 0 -> raise No_more_elements | _ -> decr count; f (n - 1 - !count)); clone = (fun () -> init !count f); fast = true; } let rec empty () = { count = (fun () -> 0); next = (fun () -> raise No_more_elements); clone = (fun () -> empty()); fast = true; } type 'a _mut_list = { hd : 'a; mutable tl : 'a _mut_list; } let force t = let rec clone enum count = let enum = ref !enum and count = ref !count in { count = (fun () -> !count); next = (fun () -> match !enum with | [] -> raise No_more_elements | h :: t -> decr count; enum := t; h); clone = (fun () -> let enum = ref !enum and count = ref !count in clone enum count); fast = true; } in let count = ref 0 in let _empty = Obj.magic [] in let rec loop dst = let x = { hd = t.next(); tl = _empty } in incr count; dst.tl <- x; loop x in let enum = ref _empty in (try enum := { hd = t.next(); tl = _empty }; incr count; loop !enum; with No_more_elements -> ()); let tc = clone (Obj.magic enum) count in t.clone <- tc.clone; t.next <- tc.next; t.count <- tc.count; t.fast <- true let from f = let e = { next = f; count = _dummy; clone = _dummy; fast = false; } in e.count <- (fun () -> force e; e.count()); e.clone <- (fun () -> force e; e.clone()); e let from2 next clone = let e = { next = next; count = _dummy; clone = clone; fast = false; } in e.count <- (fun () -> force e; e.count()); e let get t = try Some (t.next()) with No_more_elements -> None let push t e = let rec make t = let fnext = t.next in let fcount = t.count in let fclone = t.clone in let next_called = ref false in t.next <- (fun () -> next_called := true; t.next <- fnext; t.count <- fcount; t.clone <- fclone; e); t.count <- (fun () -> let n = fcount() in if !next_called then n else n+1); t.clone <- (fun () -> let tc = fclone() in if not !next_called then make tc; tc); in make t let peek t = match get t with | None -> None | Some x -> push t x; Some x let junk t = try ignore(t.next()) with No_more_elements -> () let is_empty t = if t.fast then t.count() = 0 else peek t = None let count t = t.count() let fast_count t = t.fast let clone t = t.clone() let iter f t = let rec loop () = f (t.next()); loop(); in try loop(); with No_more_elements -> () let iteri f t = let rec loop idx = f idx (t.next()); loop (idx+1); in try loop 0; with No_more_elements -> () let iter2 f t u = let push_t = ref None in let rec loop () = push_t := None; let e = t.next() in push_t := Some e; f e (u.next()); loop () in try loop () with No_more_elements -> match !push_t with | None -> () | Some e -> push t e let iter2i f t u = let push_t = ref None in let rec loop idx = push_t := None; let e = t.next() in push_t := Some e; f idx e (u.next()); loop (idx + 1) in try loop 0 with No_more_elements -> match !push_t with | None -> () | Some e -> push t e let fold f init t = let acc = ref init in let rec loop() = acc := f (t.next()) !acc; loop() in try loop() with No_more_elements -> !acc let foldi f init t = let acc = ref init in let rec loop idx = acc := f idx (t.next()) !acc; loop (idx + 1) in try loop 0 with No_more_elements -> !acc let fold2 f init t u = let acc = ref init in let push_t = ref None in let rec loop() = push_t := None; let e = t.next() in push_t := Some e; acc := f e (u.next()) !acc; loop() in try loop() with No_more_elements -> match !push_t with | None -> !acc | Some e -> push t e; !acc let fold2i f init t u = let acc = ref init in let push_t = ref None in let rec loop idx = push_t := None; let e = t.next() in push_t := Some e; acc := f idx e (u.next()) !acc; loop (idx + 1) in try loop 0 with No_more_elements -> match !push_t with | None -> !acc | Some e -> push t e; !acc let find f t = let rec loop () = let x = t.next() in if f x then x else loop() in try loop() with No_more_elements -> raise Not_found let rec map f t = { count = t.count; next = (fun () -> f (t.next())); clone = (fun () -> map f (t.clone())); fast = t.fast; } let rec mapi f t = let idx = ref (-1) in { count = t.count; next = (fun () -> incr idx; f !idx (t.next())); clone = (fun () -> mapi f (t.clone())); fast = t.fast; } let rec filter f t = let rec next() = let x = t.next() in if f x then x else next() in from2 next (fun () -> filter f (t.clone())) let rec filter_map f t = let rec next () = match f (t.next()) with | None -> next() | Some x -> x in from2 next (fun () -> filter_map f (t.clone())) let rec append ta tb = let t = { count = (fun () -> ta.count() + tb.count()); next = _dummy; clone = (fun () -> append (ta.clone()) (tb.clone())); fast = ta.fast && tb.fast; } in t.next <- (fun () -> try ta.next() with No_more_elements -> (* add one indirection because tb can mute *) t.next <- (fun () -> tb.next()); t.count <- (fun () -> tb.count()); t.clone <- (fun () -> tb.clone()); t.fast <- tb.fast; t.next() ); t let rec concat t = let concat_ref = ref _dummy in let rec concat_next() = let tn = t.next() in concat_ref := (fun () -> try tn.next() with No_more_elements -> concat_next()); !concat_ref () in concat_ref := concat_next; from2 (fun () -> !concat_ref ()) (fun () -> concat (t.clone())) haxe-3.0~svn6707/libs/extlib/IO.mli0000644000175000017500000002534512172015140017440 0ustar bdefreesebdefreese(* * IO - Abstract input/output * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** High-order abstract I/O. IO module simply deals with abstract inputs/outputs. It provides a set of methods for working with these IO as well as several constructors that enable to write to an underlying channel, buffer, or enum. *) type input (** The abstract input type. *) type 'a output (** The abstract output type, ['a] is the accumulator data, it is returned when the [close_out] function is called. *) exception No_more_input (** This exception is raised when reading on an input with the [read] or [nread] functions while there is no available token to read. *) exception Input_closed (** This exception is raised when reading on a closed input. *) exception Output_closed (** This exception is raised when reading on a closed output. *) (** {6 Standard API} *) val read : input -> char (** Read a single char from an input or raise [No_more_input] if no input available. *) val nread : input -> int -> string (** [nread i n] reads a string of size up to [n] from an input. The function will raise [No_more_input] if no input is available. It will raise [Invalid_argument] if [n] < 0. *) val really_nread : input -> int -> string (** [really_nread i n] reads a string of exactly [n] characters from the input. Raises [No_more_input] if at least [n] characters are not available. Raises [Invalid_argument] if [n] < 0. *) val input : input -> string -> int -> int -> int (** [input i s p l] reads up to [l] characters from the given input, storing them in string [s], starting at character number [p]. It returns the actual number of characters read or raise [No_more_input] if no character can be read. It will raise [Invalid_argument] if [p] and [l] do not designate a valid substring of [s]. *) val really_input : input -> string -> int -> int -> int (** [really_input i s p l] reads exactly [l] characters from the given input, storing them in the string [s], starting at position [p]. For consistency with {!IO.input} it returns [l]. Raises [No_more_input] if at [l] characters are not available. Raises [Invalid_argument] if [p] and [l] do not designate a valid substring of [s]. *) val close_in : input -> unit (** Close the input. It can no longer be read from. *) val write : 'a output -> char -> unit (** Write a single char to an output. *) val nwrite : 'a output -> string -> unit (** Write a string to an output. *) val output : 'a output -> string -> int -> int -> int (** [output o s p l] writes up to [l] characters from string [s], starting at offset [p]. It returns the number of characters written. It will raise [Invalid_argument] if [p] and [l] do not designate a valid substring of [s]. *) val really_output : 'a output -> string -> int -> int -> int (** [really_output o s p l] writes exactly [l] characters from string [s] onto the the output, starting with the character at offset [p]. For consistency with {!IO.output} it returns [l]. Raises [Invalid_argument] if [p] and [l] do not designate a valid substring of [s]. *) val flush : 'a output -> unit (** Flush an output. *) val close_out : 'a output -> 'a (** Close the output and return its accumulator data. It can no longer be written. *) (** {6 Creation of IO Inputs/Outputs} *) val input_string : string -> input (** Create an input that will read from a string. *) val output_string : unit -> string output (** Create an output that will write into a string in an efficient way. When closed, the output returns all the data written into it. *) val output_strings : unit -> string list output (** Create an output that will write into a string in an efficient way. When closed, the output returns all the data written into it. Several strings are used in case the output size excess max_string_length *) val input_channel : in_channel -> input (** Create an input that will read from a channel. *) val output_channel : out_channel -> unit output (** Create an output that will write into a channel. *) val input_enum : char Enum.t -> input (** Create an input that will read from an [enum]. *) val output_enum : unit -> char Enum.t output (** Create an output that will write into an [enum]. The final enum is returned when the output is closed. *) val create_in : read:(unit -> char) -> input:(string -> int -> int -> int) -> close:(unit -> unit) -> input (** Fully create an input by giving all the needed functions. *) val create_out : write:(char -> unit) -> output:(string -> int -> int -> int) -> flush:(unit -> unit) -> close:(unit -> 'a) -> 'a output (** Fully create an output by giving all the needed functions. *) (** {6 Utilities} *) val printf : 'a output -> ('b, unit, string, unit) format4 -> 'b (** The printf function works for any output. *) val read_all : input -> string (** read all the contents of the input until [No_more_input] is raised. *) val pipe : unit -> input * unit output (** Create a pipe between an input and an ouput. Data written from the output can be read from the input. *) val pos_in : input -> input * (unit -> int) (** Create an input that provide a count function of the number of bytes read from it. *) val pos_out : 'a output -> 'a output * (unit -> int) (** Create an output that provide a count function of the number of bytes written through it. *) external cast_output : 'a output -> unit output = "%identity" (** You can safely transform any output to an unit output in a safe way by using this function. *) (** {6 Binary files API} Here is some API useful for working with binary files, in particular binary files generated by C applications. By default, encoding of multibyte integers is low-endian. The BigEndian module provide multibyte operations with other encoding. *) exception Overflow of string (** Exception raised when a read or write operation cannot be completed. *) val read_byte : input -> int (** Read an unsigned 8-bit integer. *) val read_signed_byte : input -> int (** Read an signed 8-bit integer. *) val read_ui16 : input -> int (** Read an unsigned 16-bit word. *) val read_i16 : input -> int (** Read a signed 16-bit word. *) val read_i32 : input -> int (** Read a signed 32-bit integer. Raise [Overflow] if the read integer cannot be represented as a Caml 31-bit integer. *) val read_real_i32 : input -> int32 (** Read a signed 32-bit integer as an OCaml int32. *) val read_i64 : input -> int64 (** Read a signed 64-bit integer as an OCaml int64. *) val read_double : input -> float (** Read an IEEE double precision floating point value. *) val read_string : input -> string (** Read a null-terminated string. *) val read_line : input -> string (** Read a LF or CRLF terminated string. *) val write_byte : 'a output -> int -> unit (** Write an unsigned 8-bit byte. *) val write_ui16 : 'a output -> int -> unit (** Write an unsigned 16-bit word. *) val write_i16 : 'a output -> int -> unit (** Write a signed 16-bit word. *) val write_i32 : 'a output -> int -> unit (** Write a signed 32-bit integer. *) val write_real_i32 : 'a output -> int32 -> unit (** Write an OCaml int32. *) val write_i64 : 'a output -> int64 -> unit (** Write an OCaml int64. *) val write_double : 'a output -> float -> unit (** Write an IEEE double precision floating point value. *) val write_string : 'a output -> string -> unit (** Write a string and append an null character. *) val write_line : 'a output -> string -> unit (** Write a line and append a LF (it might be converted to CRLF on some systems depending on the underlying IO). *) (** Same as operations above, but use big-endian encoding *) module BigEndian : sig val read_ui16 : input -> int val read_i16 : input -> int val read_i32 : input -> int val read_real_i32 : input -> int32 val read_i64 : input -> int64 val read_double : input -> float val write_ui16 : 'a output -> int -> unit val write_i16 : 'a output -> int -> unit val write_i32 : 'a output -> int -> unit val write_real_i32 : 'a output -> int32 -> unit val write_i64 : 'a output -> int64 -> unit val write_double : 'a output -> float -> unit end (** {6 Bits API} This enable you to read and write from an IO bit-by-bit or several bits at the same time. *) type in_bits type out_bits exception Bits_error val input_bits : input -> in_bits (** Read bits from an input *) val output_bits : 'a output -> out_bits (** Write bits to an output *) val read_bits : in_bits -> int -> int (** Read up to 31 bits, raise Bits_error if n < 0 or n > 31 *) val write_bits : out_bits -> nbits:int -> int -> unit (** Write up to 31 bits represented as a value, raise Bits_error if nbits < 0 or nbits > 31 or the value representation excess nbits. *) val flush_bits : out_bits -> unit (** Flush remaining unwritten bits, adding up to 7 bits which values 0. *) val drop_bits : in_bits -> unit (** Drop up to 7 buffered bits and restart to next input character. *) (** {6 Generic IO Object Wrappers} Theses OO Wrappers have been written to provide easy support of ExtLib IO by external librairies. If you want your library to support ExtLib IO without actually requiring ExtLib to compile, you can should implement the classes [in_channel], [out_channel], [poly_in_channel] and/or [poly_out_channel] which are the common IO specifications established for ExtLib, OCamlNet and Camomile. (see http://www.ocaml-programming.de/tmp/IO-Classes.html for more details). *) class in_channel : input -> object method input : string -> int -> int -> int method close_in : unit -> unit end class out_channel : 'a output -> object method output : string -> int -> int -> int method flush : unit -> unit method close_out : unit -> unit end class in_chars : input -> object method get : unit -> char method close_in : unit -> unit end class out_chars : 'a output -> object method put : char -> unit method flush : unit -> unit method close_out : unit -> unit end val from_in_channel : #in_channel -> input val from_out_channel : #out_channel -> unit output val from_in_chars : #in_chars -> input val from_out_chars : #out_chars -> unit output haxe-3.0~svn6707/libs/extlib/META.txt0000644000175000017500000000010712172015140017702 0ustar bdefreesebdefreeseversion="1.3" archive(byte)="extLib.cma" archive(native)="extLib.cmxa" haxe-3.0~svn6707/libs/extlib/std.mli0000644000175000017500000000464612172015140017724 0ustar bdefreesebdefreese(* * Std - Additional functions * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Additional functions. *) val input_lines : in_channel -> string Enum.t (** Returns an enumeration over lines of an input channel, as read by the [input_line] function. *) val input_chars : in_channel -> char Enum.t (** Returns an enumeration over characters of an input channel. *) val input_list : in_channel -> string list (** Returns the list of lines read from an input channel. *) val input_all : in_channel -> string (** Return the whole contents of an input channel as a single string. *) val print_bool : bool -> unit (** Print a boolean to stdout. *) val prerr_bool : bool -> unit (** Print a boolean to stderr. *) val input_file : ?bin:bool -> string -> string (** returns the data of a given filename. *) val output_file : filename:string -> text:string -> unit (** creates a filename, write text into it and close it. *) val string_of_char : char -> string (** creates a string from a char. *) external identity : 'a -> 'a = "%identity" (** the identity function. *) val unique : unit -> int (** returns an unique identifier every time it is called. *) val dump : 'a -> string (** represent a runtime value as a string. Since types are lost at compile time, the representation might not match your type. For example, None will be printed 0 since they share the same runtime representation. *) val print : 'a -> unit (** print the representation of a runtime value on stdout. See remarks for [dump]. *) val finally : (unit -> unit) -> ('a -> 'b) -> 'a -> 'b (** finally [fend f x] calls [f x] and then [fend()] even if [f x] raised an exception. *) haxe-3.0~svn6707/libs/extlib/pMap.mli0000644000175000017500000000723712172015140020026 0ustar bdefreesebdefreese(* * PMap - Polymorphic maps * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Polymorphic Map. This is a polymorphic map, similar to standard library [Map] module but in a defunctorized style. *) type ('a, 'b) t val empty : ('a, 'b) t (** The empty map, using [compare] as key comparison function. *) val is_empty : ('a, 'b) t -> bool (** returns true if the map is empty. *) val create : ('a -> 'a -> int) -> ('a, 'b) t (** creates a new empty map, using the provided function for key comparison.*) val add : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) val find : 'a -> ('a, 'b) t -> 'b (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val remove : 'a -> ('a, 'b) t -> ('a, 'b) t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) val mem : 'a -> ('a, 'b) t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val exists : 'a -> ('a, 'b) t -> bool (** same as [mem]. *) val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The order in which the bindings are passed to [f] is unspecified. Only current bindings are presented to [f]: bindings hidden by more recent bindings are not passed to [f]. *) val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The order in which the associated values are passed to [f] is unspecified. *) val mapi : ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) val fold : ('b -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m], and [d1 ... dN] are the associated data. The order in which the bindings are presented to [f] is unspecified. *) val foldi : ('a -> 'b -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c (** Same as [fold], but the function receives as arguments both the key and the associated value for each binding of the map. *) val enum : ('a, 'b) t -> ('a * 'b) Enum.t (** creates an enumeration for this map. *) val of_enum : ?cmp:('a -> 'a -> int) -> ('a * 'b) Enum.t -> ('a, 'b) t (** creates a map from an enumeration, using the specified function for key comparison or [compare] by default. *) haxe-3.0~svn6707/libs/extlib/optParse.mli0000644000175000017500000004026512172015140020724 0ustar bdefreesebdefreese(* * optParse - Functions for parsing command line arguments. * Copyright (C) 2004 Bardur Arantsson * * Heavily influenced by the optparse.py module from the Python * standard library, but with lots of adaptation to the 'Ocaml Way' * * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Modules for GNU [getopt(3)]-style command line parsing. *) (** This module contains the basic functions and types for defining new option types and accessing the values of options. *) module Opt : sig (** {6 Exceptions} *) exception No_value (** [No_value] gets raised by {!OptParse.Opt.get} when an option value is not available. *) exception Option_error of string * string (** This exception signals that an option value is invalid. The first string contains the option string ('-x' or '--long-name') and the second string contains an error message. This exception is only used when implementing custom option types and can never "escape" the scope of a {!OptParse.OptParser.parse}. The user should therefore not attempt to catch it. *) exception Option_help (** When an option wants to display a usage message, this exception may be raised. It can never "escape" the scope of a {!OptParse.OptParser.parse} call and the user should therefore not attempt to catch it. *) (** {6 Types} *) type 'a t = { option_set : string -> string list -> unit; option_set_value : 'a -> unit; option_get : unit -> 'a option; option_metavars : string list; option_defhelp : string option } (** Option type. [option_set] is a closure which converts and records the value of an option so that it can be retrieved with a later call to the [option_get] closure. It is called with the option name which was given on the command line and a list of strings, each representing one of the argument values given on the command line. It may raise [Option_error] if the value is invalid (for whatever reason). [option_set_value] is a closure which sets the value of an option to a particular value. [option_get] is a closure which retrieves the recorded value of the option. If the option value has not been set from the command line, the default value is used. If there is no default value, then [None] should be returned. [option_metavars] is a list of "meta-variables" (arguments) which this option accepts. This is mainly for display purposes, but the length of this list determines how many arguments the option parser accepts for this option (currently only lists of length 0 or 1 are supported). [option_defhelp] is the default help string (if any). It is used for displaying help messages whenever the user does {b not} specify a help string manually when adding this option. Using a non-None value here only makes sense for completely generic options like {!OptParse.StdOpt.help_option}. *) (** {6 Option value retrieval} *) val get : 'a t -> 'a (** Get the value of an option. @return the value of the option. If the option has not been encountered while parsing the command line, the default value is returned. @raise No_value if no default values has been given and the option value has not been set from the command line. *) val set : 'a t -> 'a -> unit (** Set the value of an option. *) val opt : 'a t -> 'a option (** Get the value of an option as an optional value. @return [Some x] if the option has value [x] (either by default or from the command line). If the option doesn't have a value [None] is returned. *) val is_set : 'a t -> bool (** Find out if the option has a value (either by default or from the command line). @return [True] iff the option has a value. *) (** {6 Option creation} *) val value_option : string -> 'a option -> (string -> 'a) -> (exn -> string -> string) -> 'a t (** Make an option which takes a single argument. [value_option metavar default coerce errfmt] returns an option which takes a single argument from the command line and calls [coerce] to coerce it to the proper type. If [coerce] raises an exception, [exn], then [errfmt exn argval] is called to generate an error message for display. [metavar] is the name of the metavariable of the option. [default] is the default value of the option. If [None], the the option has no default value. @return the newly created option. *) val callback_option : string -> (string -> 'a) -> (exn -> string -> string) -> ('a -> unit) -> unit t (** Make a callback option which takes a single argument. [callback_option metavar coerce errfmt f] returns an option which takes a single argument from the command line and calls [coerce] to coerce it to the proper type. If [coerce] raises an exception [errfmt exn argval] is called to format an error message for display. If [coerce] succeeds, the callback function [f] is called with the coerced value. Finally, [metavar] is the name of the metavariable of the option. @return the newly created option. *) end (** This module contains various standard options. *) module StdOpt : sig (** {6 Flag options} *) val store_const : ?default: 'a -> 'a -> 'a Opt.t (** [store_const ?default const] returns a flag option which stores the constant value [const] when the option is encountered on the command line. *) val store_true : unit -> bool Opt.t (** [store_true ()] returns an option which is set to true when it is encountered on the command line. The default value is false. *) val store_false : unit -> bool Opt.t (** [store_false ()] returns an option which is set to false when it is encountered on the command line. The default value is true. *) val count_option : ?dest: int ref -> ?increment: int -> unit -> int Opt.t (** Create a counting option which increments its value each time the option is encountered on the command line. @param increment Increment to add to the option value each time the option is encountered. @param dest Reference to the option value. Useful for making options like '--quiet' and '--verbose' sharing a single value. @return the newly created option. *) val incr_option : ?dest: int ref -> unit -> int Opt.t (** Exactly identical to [count_option ~dest:dest ~increment:1 ()]. *) val decr_option : ?dest: int ref -> unit -> int Opt.t (** Exactly identical to [count_option ~dest:dest ~increment:(-1) ()]. *) (** {6 Value options} *) val int_option : ?default: int -> ?metavar: string -> unit -> int Opt.t (** [int_option ?default ?metavar ()] returns an option which takes a single integer argument. If [~default] is given it is the default value returned when the option has not been encountered on the command line. *) val float_option : ?default: float -> ?metavar: string -> unit -> float Opt.t (** See {!OptParse.StdOpt.int_option}. *) val str_option : ?default: string -> ?metavar: string -> unit -> string Opt.t (** See {!OptParse.StdOpt.int_option}. *) (** {6 Callback options} *) val int_callback : ?metavar: string -> (int -> unit) -> unit Opt.t (** [int_callback ?metavar f] returns an option which takes a single integer argument and calls [f] with that argument when encountered on the command line. *) val float_callback : ?metavar: string -> (float -> unit) -> unit Opt.t (** See {!OptParse.StdOpt.int_callback}. *) val str_callback : ?metavar: string -> (string -> unit) -> unit Opt.t (** See {!OptParse.StdOpt.int_callback}. *) (** {6 Special options} *) val help_option : unit -> 'a Opt.t (** [help_option ()] returns the standard help option which displays a usage message and exits the program when encountered on the command line. *) val version_option : (unit -> string) -> 'a Opt.t (** [version_option f] returns the standard version option which displays the string returned by [f ()] (and nothing else) on standard output and exits. *) end (** This module contains the types and functions for implementing custom usage message formatters. *) module Formatter : sig type t = { indent : unit -> unit; (** Increase the indentation level. *) dedent : unit -> unit; (** Decrease the indentation level. *) format_usage : string -> string; (** Format usage string into style of this formatter. *) format_heading : string -> string; (** Format heading into style of this formatter. *) format_description : string -> string; (** Format description into style of this formatter. *) format_option : char list * string list -> string list -> string option -> string (** Format option into style of this formatter (see explanation below). *) } (** This is the type of a formatter. The [format_option] has signature [format_option (snames,lnames) metavars help], where [snames] is a list of the short option names, [lnames] is a list of the long option names, [metavars] is a list of the metavars the option takes as arguments, and [help] is the help string supplied by the user. *) (** {6 Standard formatters} *) val indented_formatter : ?level: int ref -> ?indent: int ref -> ?indent_increment: int -> ?max_help_position: int -> ?width: int -> ?short_first: bool -> unit -> t (** Create an "indented" formatter with the given options. @param width Total with of the usage messages printed. @param max_help_position Maximum starting column for the help messages relating to each option. @param short_first List all the short option names first? @param indent_increment Number of columns to indent by when more indentation is required. @param indent Reference to the current indentation amount. Its value reflects changes in indentation level. @param level Reference to the current indentation level. Its value reflects changes in indentation level. *) val titled_formatter : ?level: int ref -> ?indent: int ref -> ?indent_increment: int -> ?max_help_position: int -> ?width: int -> ?short_first: bool -> unit -> t (** Creates a titled formatter which is quite similar to the indented formatter. See {!OptParse.Formatter.indented_formatter} for a description of the options. *) (** {6 Low-level formatting} *) val wrap : ?initial_indent: int -> ?subsequent_indent: int -> string -> int -> string list (** [wrap text width] reflows the given text paragraph into lines of width at most [width] (lines may exceed this if the are single words that exceed this limit). @param initial_indent Indentation of the first line. @param subsequent_indent Indentation of the following lines. @return a list of lines making up the reformatted paragraph. *) val fill : ?initial_indent: int -> ?subsequent_indent: int -> string -> int -> string (** See {!OptParse.Formatter.wrap}. @return a string containing the reformatted paragraph. *) end (** This module contains the option parser itself. It provides functions to create, populate and use option parsers to parse command line arguments. *) module OptParser : sig (** {6 Exceptions} *) exception Option_conflict of string (** [Option_conflic name] is raised by {!OptParse.OptParser.add} when two different options are added with identical names. Usually this doesn't need to be caught since this error is usually easily fixed permanently by removing/renaming the conflicting option names. *) (** {6 Types} *) type t (** The type of an option parser. *) type group (** The type of an option group. *) (** {6 Option parser creation} *) val make : ?usage: string -> ?description: string -> ?version: string -> ?suppress_usage: bool -> ?suppress_help: bool -> ?prog: string -> ?formatter: Formatter.t -> unit -> t (** Creates a new option parser with the given options. @param usage Usage message. The default is a reasonable usage message for most programs. Any occurrence of the substring ["%prog"] in [usage] is replaced with the name of the program (see [prog]). @param prog Program name. The default is the base name of the executable. @param suppress_usage Suppress the usage message if set. @param suppress_help Suppress the 'help' option which is otherwise added by default. @param version Version string. If set, a '--version' option is automatically added. When encountered on the command line it causes [version] to be printed to the standard output and the program to exit. @param description: description of the main purpose of the program. @return the new option parser. *) val add : t -> ?group: group -> ?help: string -> ?hide: bool -> ?short_name: char -> ?short_names: char list -> ?long_name: string -> ?long_names: string list -> 'a Opt.t -> unit (** Add an option to the option parser. @raise Option_conflict if the short name(s) or long name(s) have alread been used for some other option. @param help Short help message describing the option (for the usage message). @param hide If true, hide the option from the usage message. This can be used to implement "secret" options which are not shown, but work just the same as regular options in all other respects. @param short_name is the name for the short form of the option (e.g. ['x'] means that the option is invoked with [-x] on the command line). @param short_names is a list of names for the short form of the option (see [short_name]). @param long_name is the name for the long form of the option (e.g. ["xyzzy"] means that the option is invoked with [--xyzzy] on the command line). @param long_names is a list of names for the long form of the option (see [long_name]). *) val add_group : t -> ?parent: group -> ?description: string -> string -> group (** Add a group to the option parser. @param parent is the parent group (if any). @param description is a description of the group. @return the new group. *) (** {6 Output and error handling} *) val error : t -> ?chn: out_channel -> ?status: int -> string -> unit (** Display an error message and exit the program. The error message is printed to the channel [chn] (default is [Pervasives.stderr]) and the program exits with exit status [status] (default is 1). *) val usage : t -> ?chn: out_channel -> unit -> unit (** Display the usage message to the channel [chn] (default is [Pervasives.stdout]) and return. *) (** {6 Option parsing} *) val parse : t -> ?first: int -> ?last: int -> string array -> string list (** Parse arguments as if the arguments [args.(first)], [args.(first+1)], ..., [args.(last)] had been given on the command line. By default [first] is 0 and [last] is the index of the last element of the array. *) val parse_argv : t -> string list (** Parse all the arguments in [Sys.argv]. *) end haxe-3.0~svn6707/libs/extlib/uTF8.mli0000644000175000017500000001162112172015140017707 0ustar bdefreesebdefreese(* * UTF-8 - UTF-8 encoded Unicode string * Copyright 2002, 2003 (C) Yamagata Yoriyuki. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** UTF-8 encoded Unicode strings. The Module for UTF-8 encoded Unicode strings. *) open UChar (** UTF-8 encoded Unicode strings. the type is normal string. *) type t = string exception Malformed_code (** [validate s] Succeeds if s is valid UTF-8, otherwise raises Malformed_code. Other functions assume strings are valid UTF-8, so it is prudent to test their validity for strings from untrusted origins. *) val validate : t -> unit (* All functions below assume string are valid UTF-8. If not, * the result is unspecified. *) (** [get s n] returns [n]-th Unicode character of [s]. The call requires O(n)-time. *) val get : t -> int -> uchar (** [init len f] returns a new string which contains [len] Unicode characters. The i-th Unicode character is initialized by [f i] *) val init : int -> (int -> uchar) -> t (** [length s] returns the number of Unicode characters contained in s *) val length : t -> int (** Positions in the string represented by the number of bytes from the head. The location of the first character is [0] *) type index = int (** [nth s n] returns the position of the [n]-th Unicode character. The call requires O(n)-time *) val nth : t -> int -> index (** The position of the head of the last Unicode character. *) val last : t -> index (** [look s i] returns the Unicode character of the location [i] in the string [s]. *) val look : t -> index -> uchar (** [out_of_range s i] tests whether [i] is a position inside of [s]. *) val out_of_range : t -> index -> bool (** [compare_index s i1 i2] returns a value < 0 if [i1] is the position located before [i2], 0 if [i1] and [i2] points the same location, a value > 0 if [i1] is the position located after [i2]. *) val compare_index : t -> index -> index -> int (** [next s i] returns the position of the head of the Unicode character located immediately after [i]. If [i] is inside of [s], the function always successes. If [i] is inside of [s] and there is no Unicode character after [i], the position outside [s] is returned. If [i] is not inside of [s], the behaviour is unspecified. *) val next : t -> index -> index (** [prev s i] returns the position of the head of the Unicode character located immediately before [i]. If [i] is inside of [s], the function always successes. If [i] is inside of [s] and there is no Unicode character before [i], the position outside [s] is returned. If [i] is not inside of [s], the behaviour is unspecified. *) val prev : t -> index -> index (** [move s i n] returns [n]-th Unicode character after [i] if n >= 0, [n]-th Unicode character before [i] if n < 0. If there is no such character, the result is unspecified. *) val move : t -> index -> int -> index (** [iter f s] applies [f] to all Unicode characters in [s]. The order of application is same to the order of the Unicode characters in [s]. *) val iter : (uchar -> unit) -> t -> unit (** Code point comparison by the lexicographic order. [compare s1 s2] returns a positive integer if [s1] > [s2], 0 if [s1] = [s2], a negative integer if [s1] < [s2]. *) val compare : t -> t -> int (** Buffer module for UTF-8 strings *) module Buf : sig (** Buffers for UTF-8 strings. *) type buf (** [create n] creates a buffer with the initial size [n]-bytes. *) val create : int -> buf (* The rest of functions is similar to the ones of Buffer in stdlib. *) (** [contents buf] returns the contents of the buffer. *) val contents : buf -> t (** Empty the buffer, but retains the internal storage which was holding the contents *) val clear : buf -> unit (** Empty the buffer and de-allocate the internal storage. *) val reset : buf -> unit (** Add one Unicode character to the buffer. *) val add_char : buf -> uchar -> unit (** Add the UTF-8 string to the buffer. *) val add_string : buf -> t -> unit (** [add_buffer b1 b2] adds the contents of [b2] to [b1]. The contents of [b2] is not changed. *) val add_buffer : buf -> buf -> unit end haxe-3.0~svn6707/libs/extlib/install.ml0000644000175000017500000001475112172015140020425 0ustar bdefreesebdefreese(* * Install - ExtLib installation * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Printf type path = | PathUnix | PathDos let modules = [ "enum"; "bitSet"; "dynArray"; "extArray"; "extHashtbl"; "extList"; "extString"; "global"; "IO"; "option"; "pMap"; "std"; "uChar"; "uTF8"; "base64"; "unzip"; "refList"; "optParse"; "dllist"; "multiArray"; ] let m_list suffix = String.concat " " (List.map (fun m -> m ^ suffix) modules) let obj_ext , lib_ext , cp_cmd , path_type = match Sys.os_type with | "Unix" | "Cygwin" | "MacOS" -> ".o" , ".a" , "cp", PathUnix | "Win32" -> ".obj" , ".lib" , "copy", PathDos | _ -> failwith "Unknown OS" let run cmd = print_endline cmd; let ecode = Sys.command cmd in if ecode <> 0 then failwith (sprintf "Exit Code %d - Stopped" ecode) let copy file dest = if dest <> "" && dest <> "." then begin print_endline ("Installing " ^ file); let path = dest ^ file in (try Sys.remove path with _ -> ()); try Sys.rename file path; with _ -> failwith "Aborted" end let complete_path p = if p = "" then p else let c = p.[String.length p - 1] in if c = '/' || c = '\\' then p else p ^ (match path_type with PathUnix -> "/" | PathDos -> "\\") let remove file = try Sys.remove file with _ -> prerr_endline ("Warning : failed to delete " ^ file) let is_findlib() = let findlib = Sys.command (if Sys.os_type = "Win32" then "ocamlfind printconf 2>NUL" else "ocamlfind printconf") = 0 in if findlib then print_endline "Using Findlib"; findlib type install_dir = Findlib | Dir of string let install() = let autodir = ref None in let docflag = ref None in let autodoc = ref false in let autobyte = ref false in let autonative = ref false in let usage = "ExtLib installation program v1.3\n(c)2003,2004 Nicolas Cannasse" in Arg.parse [ ("-d", Arg.String (fun s -> autodir := Some s) , " : install in target directory"); ("-b", Arg.Unit (fun () -> autobyte := true) , ": byte code installation"); ("-n", Arg.Unit (fun () -> autonative := true) , ": native code installation"); ("-doc", Arg.Unit (fun () -> docflag := Some true) , ": documentation installation"); ("-nodoc", Arg.Unit (fun () -> docflag := Some false) , ": documentation installation"); ] (fun s -> raise (Arg.Bad s)) usage; let findlib = is_findlib () in let install_dir = ( match !autodir with | Some dir -> if not !autobyte && not !autonative && not !autodoc then failwith "Nothing to do."; Dir (complete_path dir) | None -> let byte, native = if !autobyte || !autonative then (!autobyte, !autonative) else begin printf "Choose one of the following :\n1- Bytecode installation only\n2- Native installation only\n3- Both Native and Bytecode installation\n> "; (match read_line() with | "1" -> true, false | "2" -> false, true | "3" -> true, true | _ -> failwith "Invalid choice, exit.") end in let dest = if not findlib then begin printf "Choose installation directory :\n> "; let dest = complete_path (read_line()) in (try close_out (open_out (dest ^ "test.file")); Sys.remove (dest ^ "test.file"); with _ -> failwith ("Directory " ^ dest ^ " does not exists or cannot be written.")); Dir dest; end else Findlib in autobyte := byte; autonative := native; dest ) in let doc = match !docflag with Some doc -> doc | None -> printf "Do you want to generate ocamldoc documentation (Y/N) ?\n> "; (match read_line() with | "y" | "Y" -> true | "n" | "N" -> false | _ -> failwith "Invalid choice, exit.") in autodoc := doc; let doc_dir = match install_dir with Findlib -> "extlib-doc" | Dir install_dir -> sprintf "%sextlib-doc" install_dir in if !autodoc && not (Sys.file_exists doc_dir) then run (sprintf "mkdir %s" doc_dir); run (sprintf "ocamlc -c %s" (m_list ".mli")); if !autobyte then begin List.iter (fun m -> run (sprintf "ocamlc -c %s.ml" m)) modules; run (sprintf "ocamlc -a -o extLib.cma %s extLib.ml" (m_list ".cmo")); List.iter (fun m -> remove (m ^ ".cmo")) modules; remove "extLib.cmo"; end; if !autonative then begin List.iter (fun m -> run (sprintf "ocamlopt -c %s.ml" m)) modules; run (sprintf "ocamlopt -a -o extLib.cmxa %s extLib.ml" (m_list ".cmx")); List.iter (fun m -> remove (m ^ obj_ext)) modules; remove ("extLib" ^ obj_ext); end; if !autodoc then begin run (sprintf "ocamldoc -sort -html -d %s %s" doc_dir (m_list ".mli")); run ((match path_type with | PathDos -> sprintf "%s odoc_style.css %s\\style.css"; | PathUnix -> sprintf "%s odoc_style.css %s/style.css") cp_cmd doc_dir); end; match install_dir with Findlib -> let files = Buffer.create 0 in List.iter (fun m -> Buffer.add_string files (m ^ ".cmi"); Buffer.add_char files ' '; Buffer.add_string files (m ^ ".mli"); Buffer.add_char files ' ') modules; Buffer.add_string files "extLib.cmi "; if !autobyte then Buffer.add_string files "extLib.cma "; if !autonative then begin Buffer.add_string files "extLib.cmxa "; Buffer.add_string files ("extLib" ^ lib_ext^ " "); end; run (sprintf "%s META.txt META" cp_cmd); let files = Buffer.contents files in run (sprintf "ocamlfind install extlib %s META" files); | Dir install_dir -> List.iter (fun m -> copy (m ^ ".cmi") install_dir; if !autonative then copy (m ^ ".cmx") install_dir ) ("extLib" :: modules); if !autobyte then copy "extLib.cma" install_dir; if !autonative then begin copy "extLib.cmxa" install_dir; copy ("extLib" ^ lib_ext) install_dir; end; ;; try install(); printf "Done."; with Failure msg -> prerr_endline msg; exit 1 haxe-3.0~svn6707/libs/extlib/bitSet.mli0000644000175000017500000000640612172015140020360 0ustar bdefreesebdefreese(* * Bitset - Efficient bit sets * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Efficient bit sets. A bitset is an array of boolean values that can be accessed with indexes like an array but provides a better memory usage (divided by 8) for a very small speed trade-off. *) type t exception Negative_index of string (** When a negative bit value is used for one of the BitSet functions, this exception is raised with the name of the function. *) val empty : unit -> t (** Create an empty bitset of size 0, the bitset will automatically expand when needed. *) val create : int -> t (** Create an empty bitset with an initial size (in number of bits). *) val copy : t -> t (** Copy a bitset : further modifications of first one will not affect the copy. *) val clone : t -> t (** Same as [copy] *) val set : t -> int -> unit (** [set s n] sets the nth-bit in the bitset [s] to true. *) val unset : t -> int -> unit (** [unset s n] sets the nth-bit in the bitset [s] to false. *) val put : t -> bool -> int -> unit (** [put s v n] sets the nth-bit in the bitset [s] to [v]. *) val toggle : t -> int -> unit (** [toggle s n] changes the nth-bit value in the bitset [s]. *) val is_set : t -> int -> bool (** [is_set s n] returns true if nth-bit in the bitset [s] is set, or false otherwise. *) val compare : t -> t -> int (** [compare s1 s2] compares two bitsets. Highest bit indexes are compared first. *) val equals : t -> t -> bool (** [equals s1 s2] returns true if, and only if, all bits values in s1 are the same as in s2. *) val count : t -> int (** [count s] returns the number of bits set in the bitset [s]. *) val enum : t -> int Enum.t (** [enum s] returns an enumeration of bits which are set in the bitset [s]. *) val intersect : t -> t -> unit (** [intersect s t] sets [s] to the intersection of the sets [s] and [t]. *) val unite : t -> t -> unit (** [unite s t] sets [s] to the union of the sets [s] and [t]. *) val differentiate : t -> t -> unit (** [differentiate s t] removes the elements of [t] from [s]. *) val differentiate_sym : t -> t -> unit (** [differentiate_sym s t] sets [s] to the symmetrical difference of the sets [s] and [t]. *) val inter : t -> t -> t (** [inter s t] returns the intersection of sets [s] and [t]. *) val union : t -> t -> t (** [union s t] return the union of sets [s] and [t]. *) val diff : t -> t -> t (** [diff s t] returns [s]-[t]. *) val sym_diff : t -> t -> t (** [sym_diff s t] returns the symmetrical difference of [s] and [t]. *) haxe-3.0~svn6707/libs/extlib/enum.mli0000644000175000017500000001743112172015140020072 0ustar bdefreesebdefreese(* * Enum - enumeration over abstract collection of elements. * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Enumeration over abstract collection of elements. Enumerations are entirely functional and most of the operations do not actually require the allocation of data structures. Using enumerations to manipulate data is therefore efficient and simple. All data structures in ExtLib such as lists, arrays, etc. have support to convert from and to enumerations. *) type 'a t (** {6 Final functions} These functions consume the enumeration until it ends or an exception is raised by the first argument function. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f e] calls the function [f] with each elements of [e] in turn. *) val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** [iter2 f e1 e2] calls the function [f] with the next elements of [e] and [e2] repeatedly until one of the two enumerations ends. *) val fold : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b (** [fold f v e] returns v if e is empty, otherwise [f (... (f (f v a1) a2) ...) aN] where a1..N are the elements of [e]. *) val fold2 : ('a -> 'b -> 'c -> 'c) -> 'c -> 'a t -> 'b t -> 'c (** [fold2] is similar to [fold] but will fold over two enumerations at the same time until one of the two enumerations ends. *) (** Indexed functions : these functions are similar to previous ones except that they call the function with one additional argument which is an index starting at 0 and incremented after each call to the function. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit val iter2i : ( int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val foldi : (int -> 'a -> 'b -> 'b) -> 'b -> 'a t -> 'b val fold2i : (int -> 'a -> 'b -> 'c -> 'c) -> 'c -> 'a t -> 'b t -> 'c (** {6 Useful functions} *) val find : ('a -> bool) -> 'a t -> 'a (** [find f e] returns the first element [x] of [e] such that [f x] returns [true], consuming the enumeration up to and including the found element, or, raises [Not_found] if no such element exists in the enumeration, consuming the whole enumeration in the search. Since [find] consumes a prefix of the enumeration, it can be used several times on the same enumeration to find the next element. *) val is_empty : 'a t -> bool (** [is_empty e] returns true if [e] does not contains any element. *) val peek : 'a t -> 'a option (** [peek e] returns [None] if [e] is empty or [Some x] where [x] is the next element of [e]. The element is not removed from the enumeration. *) val get : 'a t -> 'a option (** [get e] returns [None] if [e] is empty or [Some x] where [x] is the next element of [e], in which case the element is removed from the enumeration. *) val push : 'a t -> 'a -> unit (** [push e x] will add [x] at the beginning of [e]. *) val junk : 'a t -> unit (** [junk e] removes the first element from the enumeration, if any. *) val clone : 'a t -> 'a t (** [clone e] creates a new enumeration that is copy of [e]. If [e] is consumed by later operations, the clone will not get affected. *) val force : 'a t -> unit (** [force e] forces the application of all lazy functions and the enumeration of all elements, exhausting the enumeration. An efficient intermediate data structure of enumerated elements is constructed and [e] will now enumerate over that data structure. *) (** {6 Lazy constructors} These functions are lazy which means that they will create a new modified enumeration without actually enumerating any element until they are asked to do so by the programmer (using one of the functions above). When the resulting enumerations of these functions are consumed, the underlying enumerations they were created from are also consumed. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f e] returns an enumeration over [(f a1, f a2, ... , f aN)] where a1...N are the elements of [e]. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** [mapi] is similar to [map] except that [f] is passed one extra argument which is the index of the element in the enumeration, starting from 0. *) val filter : ('a -> bool) -> 'a t -> 'a t (** [filter f e] returns an enumeration over all elements [x] of [e] such as [f x] returns [true]. *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** [filter_map f e] returns an enumeration over all elements [x] such as [f y] returns [Some x] , where [y] is an element of [e]. *) val append : 'a t -> 'a t -> 'a t (** [append e1 e2] returns an enumeration that will enumerate over all elements of [e1] followed by all elements of [e2]. *) val concat : 'a t t -> 'a t (** [concat e] returns an enumeration over all elements of all enumerations of [e]. *) (** {6 Constructors} In this section the word {i shall} denotes a semantic requirement. The correct operation of the functions in this interface are conditional on the client meeting these requirements. *) exception No_more_elements (** This exception {i shall} be raised by the [next] function of [make] or [from] when no more elements can be enumerated, it {i shall not} be raised by any function which is an argument to any other function specified in the interface. *) val empty : unit -> 'a t (** The empty enumeration : contains no element *) val make : next:(unit -> 'a) -> count:(unit -> int) -> clone:(unit -> 'a t) -> 'a t (** This function creates a fully defined enumeration. {ul {li the [next] function {i shall} return the next element of the enumeration or raise [No_more_elements] if the underlying data structure does not have any more elements to enumerate.} {li the [count] function {i shall} return the actual number of remaining elements in the enumeration.} {li the [clone] function {i shall} create a clone of the enumeration such as operations on the original enumeration will not affect the clone. }} For some samples on how to correctly use [make], you can have a look at implementation of [ExtList.enum]. *) val from : (unit -> 'a) -> 'a t (** [from next] creates an enumeration from the [next] function. [next] {i shall} return the next element of the enumeration or raise [No_more_elements] when no more elements can be enumerated. Since the enumeration definition is incomplete, a call to [clone] or [count] will result in a call to [force] that will enumerate all elements in order to return a correct value. *) val init : int -> (int -> 'a) -> 'a t (** [init n f] creates a new enumeration over elements [f 0, f 1, ..., f (n-1)] *) (** {6 Counting} *) val count : 'a t -> int (** [count e] returns the number of remaining elements in [e] without consuming the enumeration. Depending of the underlying data structure that is implementing the enumeration functions, the count operation can be costly, and even sometimes can cause a call to [force]. *) val fast_count : 'a t -> bool (** For users worried about the speed of [count] you can call the [fast_count] function that will give an hint about [count] implementation. Basically, if the enumeration has been created with [make] or [init] or if [force] has been called on it, then [fast_count] will return true. *) haxe-3.0~svn6707/libs/extlib/uChar.mli0000644000175000017500000000544612172015140020173 0ustar bdefreesebdefreese(* * UChar - Unicode (ISO-UCS) characters * Copyright (C) 2002, 2003 Yamagata Yoriyuki * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Unicode (ISO-UCS) characters. This module implements Unicode (actually ISO-UCS) characters. All 31-bit code points are allowed. *) (** Unicode characters. All 31-bit code points are allowed.*) type t exception Out_of_range (** [char_of u] returns the Latin-1 representation of [u]. If [u] can not be represented by Latin-1, raises Out_of_range *) val char_of : t -> char (** [of_char c] returns the Unicode character of the Latin-1 character [c] *) val of_char : char -> t (** [code u] returns the Unicode code number of [u]. If the value can not be represented by a positive integer, raise Out_of_range *) val code : t -> int (** [code n] returns the Unicode character with the code number [n]. If n >= 2^32 or n < 0, raises [invalid_arg] *) val chr : int -> t (** [uint_code u] returns the Unicode code number of [u]. The returned int is unsigned, that is, on 32-bit platforms, the sign bit is used for storing the 31-th bit of the code number. *) external uint_code : t -> int = "%identity" (** [chr_of_uint n] returns the Unicode character of the code number [n]. [n] is interpreted as unsigned, that is, on 32-bit platforms, the sign bit is treated as the 31-th bit of the code number. If n exceeds 31-bit values, then raise [Invalid_arg]. *) val chr_of_uint : int -> t (** Unsafe version of {!UChar.chr_of_uint}. No check of its argument is performed. *) external unsafe_chr_of_uint : int -> t = "%identity" (** Equality by code point comparison *) val eq : t -> t -> bool (** [compare u1 u2] returns, a value > 0 if [u1] has a larger Unicode code number than [u2], 0 if [u1] and [u2] are the same Unicode character, a value < 0 if [u1] has a smaller Unicode code number than [u2]. *) val compare : t -> t -> int (** Aliases of [type t] *) type uchar = t (** Alias of [uint_code] *) val int_of_uchar : uchar -> int (** Alias of [chr_of_uint] *) val uchar_of_int : int -> uchar haxe-3.0~svn6707/libs/extlib/dllist.ml0000644000175000017500000001341412172015140020245 0ustar bdefreesebdefreese(* * Dllist- a mutable, circular, doubly linked list library * Copyright (C) 2004 Brian Hurt, Jesse Guardiani * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a node_t = { mutable data : 'a; mutable next : 'a node_t; mutable prev : 'a node_t } type 'a enum_t = { mutable curr : 'a node_t; mutable valid : bool } exception Empty let create x = let rec nn = { data = x; next = nn; prev = nn} in nn let length node = let rec loop cnt n = if n == node then cnt else loop (cnt + 1) n.next in loop 1 node.next let add node elem = let nn = { data = elem; next = node.next; prev = node } in node.next.prev <- nn; node.next <- nn let append node elem = let nn = { data = elem; next = node.next; prev = node } in node.next.prev <- nn; node.next <- nn; nn let prepend node elem = let nn = { data = elem; next = node; prev = node.prev } in node.prev.next <- nn; node.prev <- nn; nn let promote node = let next = node.next in let prev = node.prev in if next != prev then begin next.next.prev <- node; node.next <- next.next; node.prev <- next; next.next <- node; next.prev <- prev; prev.next <- next end let demote node = let next = node.next in let prev = node.prev in if next != prev then begin prev.prev.next <- node; node.prev <- prev.prev; node.next <- prev; prev.prev <- node; prev.next <- next; next.prev <- prev end let remove node = let next = node.next in let prev = node.prev in prev.next <- next; next.prev <- prev; node.next <- node; node.prev <- node let drop node = let next = node.next in let prev = node.prev in prev.next <- next; next.prev <- prev; node.next <- node; node.prev <- node; next let rev_drop node = let next = node.next in let prev = node.prev in prev.next <- next; next.prev <- prev; node.next <- node; node.prev <- node; prev let splice node1 node2 = let next = node1.next in let prev = node2.prev in node1.next <- node2; node2.prev <- node1; next.prev <- prev; prev.next <- next let set node data = node.data <- data let get node = node.data let next node = node.next let prev node = node.prev let skip node idx = let m = if idx > 0 then -1 else 1 in let rec loop idx n = if idx == 0 then n else loop (idx + m) n.next in loop idx node let rev node = let rec loop next n = begin let prev = n.prev in n.next <- prev; n.prev <- next; if n != node then loop n prev end in loop node node.prev let iter f node = let () = f node.data in let rec loop n = if n != node then let () = f n.data in loop n.next in loop node.next let fold_left f init node = let rec loop accu n = if n == node then accu else loop (f accu n.data) n.next in loop (f init node.data) node.next let fold_right f node init = let rec loop accu n = if n == node then f n.data accu else loop (f n.data accu) n.prev in loop init node.prev let map f node = let first = create (f node.data) in let rec loop last n = if n == node then begin first.prev <- last; first end else begin let nn = { data = f n.data; next = first; prev = last } in last.next <- nn; loop nn n.next end in loop first node.next let copy node = map (fun x -> x) node let to_list node = fold_right (fun d l -> d::l) node [] let of_list lst = match lst with | [] -> raise Empty | h :: t -> let first = create h in let rec loop last = function | [] -> last.next <- first; first.prev <- last; first | h :: t -> let nn = { data = h; next = first; prev = last } in last.next <- nn; loop nn t in loop first t let enum node = let next e () = if e.valid == false then raise Enum.No_more_elements else begin let rval = e.curr.data in e.curr <- e.curr.next; if (e.curr == node) then e.valid <- false; rval end and count e () = if e.valid == false then 0 else let rec loop cnt n = if n == node then cnt else loop (cnt + 1) (n.next) in loop 1 (e.curr.next) in let rec clone e () = let e' = { curr = e.curr; valid = e.valid } in Enum.make ~next:(next e') ~count:(count e') ~clone:(clone e') in let e = { curr = node; valid = true } in Enum.make ~next:(next e) ~count:(count e) ~clone:(clone e) let rev_enum node = let prev e () = if e.valid == false then raise Enum.No_more_elements else begin let rval = e.curr.data in e.curr <- e.curr.prev; if (e.curr == node) then e.valid <- false; rval end and count e () = if e.valid == false then 0 else let rec loop cnt n = if n == node then cnt else loop (cnt + 1) (n.prev) in loop 1 (e.curr.prev) in let rec clone e () = let e' = { curr = e.curr; valid = e.valid } in Enum.make ~next:(prev e') ~count:(count e') ~clone:(clone e') in let e = { curr = node; valid = true } in Enum.make ~next:(prev e) ~count:(count e) ~clone:(clone e) let of_enum enm = match Enum.get enm with | None -> raise Empty | Some(d) -> let first = create d in let f d n = append n d in ignore(Enum.fold f first enm); first haxe-3.0~svn6707/libs/extlib/extString.mli0000644000175000017500000001540212172015140021111 0ustar bdefreesebdefreese(* * ExtString - Additional functions for string manipulations. * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Additional functions for string manipulations. *) exception Invalid_string module String : sig (** {6 New Functions} *) val init : int -> (int -> char) -> string (** [init l f] returns the string of length [l] with the chars f 0 , f 1 , f 2 ... f (l-1). *) val find : string -> string -> int (** [find s x] returns the starting index of the string [x] within the string [s] or raises [Invalid_string] if [x] is not a substring of [s]. *) val split : string -> string -> string * string (** [split s sep] splits the string [s] between the first occurrence of [sep]. raises [Invalid_string] if the separator is not found. *) val nsplit : string -> string -> string list (** [nsplit s sep] splits the string [s] into a list of strings which are separated by [sep]. *) val join : string -> string list -> string (** Same as [concat] *) val slice : ?first:int -> ?last:int -> string -> string (** [slice ?first ?last s] returns a "slice" of the string which corresponds to the characters [s.[first]], [s.[first+1]], ..., [s[last-1]]. Note that the character at index [last] is {b not} included! If [first] is omitted it defaults to the start of the string, i.e. index 0, and if [last] is omitted is defaults to point just past the end of [s], i.e. [length s]. Thus, [slice s] is equivalent to [copy s]. Negative indexes are interpreted as counting from the end of the string. For example, [slice ~last:-2 s] will return the string [s], but without the last two characters. This function {b never} raises any exceptions. If the indexes are out of bounds they are automatically clipped. *) val lchop : string -> string (** Returns the same string but without the first character. does nothing if the string is empty. *) val rchop : string -> string (** Returns the same string but without the last character. does nothing if the string is empty. *) val of_int : int -> string (** Returns the string representation of an int. *) val of_float : float -> string (** Returns the string representation of an float. *) val of_char : char -> string (** Returns a string containing one given character. *) val to_int : string -> int (** Returns the integer represented by the given string or raises [Invalid_string] if the string does not represent an integer.*) val to_float : string -> float (** Returns the float represented by the given string or raises Invalid_string if the string does not represent a float. *) val ends_with : string -> string -> bool (** [ends_with s x] returns true if the string [s] is ending with [x]. *) val starts_with : string -> string -> bool (** [starts_with s x] return true if [s] is starting with [x]. *) val enum : string -> char Enum.t (** Returns an enumeration of the characters of a string.*) val of_enum : char Enum.t -> string (** Creates a string from a character enumeration. *) val map : (char -> char) -> string -> string (** [map f s] returns a string where all characters [c] in [s] have been replaced by [f c]. **) val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a (** [fold_left f a s] is [f (... (f (f a s.[0]) s.[1]) ...) s.[n-1]] *) val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a (** [fold_right f s b] is [f s.[0] (f s.[1] (... (f s.[n-1] b) ...))] *) val explode : string -> char list (** [explode s] returns the list of characters in the string [s]. *) val implode : char list -> string (** [implode cs] returns a string resulting from concatenating the characters in the list [cs]. *) val strip : ?chars:string -> string -> string (** Returns the string without the chars if they are at the beginning or at the end of the string. By default chars are " \t\r\n". *) val exists : string -> string -> bool (** [exists str sub] returns true if [sub] is a substring of [str] or false otherwise. *) val replace_chars : (char -> string) -> string -> string (** [replace_chars f s] returns a string where all chars [c] of [s] have been replaced by the string returned by [f c]. *) val replace : str:string -> sub:string -> by:string -> bool * string (** [replace ~str ~sub ~by] returns a tuple constisting of a boolean and a string where the first occurrence of the string [sub] within [str] has been replaced by the string [by]. The boolean is true if a subtitution has taken place. *) (** {6 Older Functions} *) (** Please refer to the Ocaml Manual for documentation of these functions. *) val length : string -> int val get : string -> int -> char val set : string -> int -> char -> unit val create : int -> string val make : int -> char -> string val copy : string -> string val sub : string -> int -> int -> string val fill : string -> int -> int -> char -> unit val blit : string -> int -> string -> int -> int -> unit val concat : string -> string list -> string val iter : (char -> unit) -> string -> unit val escaped : string -> string val index : string -> char -> int val rindex : string -> char -> int val index_from : string -> int -> char -> int val rindex_from : string -> int -> char -> int val contains : string -> char -> bool val contains_from : string -> int -> char -> bool val rcontains_from : string -> int -> char -> bool val uppercase : string -> string val lowercase : string -> string val capitalize : string -> string val uncapitalize : string -> string type t = string val compare : t -> t -> int (**/**) external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" external unsafe_fill : string -> int -> int -> char -> unit = "caml_fill_string" "noalloc" end haxe-3.0~svn6707/libs/extlib/extList.ml0000755000175000017500000002373412172015140020417 0ustar bdefreesebdefreese(* * ExtList - additional and modified functions for lists. * Copyright (C) 2003 Brian Hurt * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) module List = struct exception Empty_list exception Invalid_index of int exception Different_list_size of string include List (* Thanks to Jacques Garrigue for suggesting the following structure *) type 'a mut_list = { hd: 'a; mutable tl: 'a list } external inj : 'a mut_list -> 'a list = "%identity" let dummy_node () = { hd = Obj.magic (); tl = [] } let hd = function | [] -> raise Empty_list | h :: t -> h let tl = function | [] -> raise Empty_list | h :: t -> t let nth l index = if index < 0 then raise (Invalid_index index); let rec loop n = function | [] -> raise (Invalid_index index); | h :: t -> if n = 0 then h else loop (n - 1) t in loop index l let append l1 l2 = match l1 with | [] -> l2 | h :: t -> let rec loop dst = function | [] -> dst.tl <- l2 | h :: t -> let cell = { hd = h; tl = [] } in dst.tl <- inj cell; loop cell t in let r = { hd = h; tl = [] } in loop r t; inj r let rec flatten l = let rec inner dst = function | [] -> dst | h :: t -> let r = { hd = h; tl = [] } in dst.tl <- inj r; inner r t in let rec outer dst = function | [] -> () | h :: t -> outer (inner dst h) t in let r = dummy_node () in outer r l; r.tl let concat = flatten let map f = function | [] -> [] | h :: t -> let rec loop dst = function | [] -> () | h :: t -> let r = { hd = f h; tl = [] } in dst.tl <- inj r; loop r t in let r = { hd = f h; tl = [] } in loop r t; inj r let rec drop n = function | _ :: l when n > 0 -> drop (n-1) l | l -> l let take n l = let rec loop n dst = function | h :: t when n > 0 -> let r = { hd = h; tl = [] } in dst.tl <- inj r; loop (n-1) r t | _ -> () in let dummy = dummy_node() in loop n dummy l; dummy.tl (* takewhile and dropwhile by Richard W.M. Jones. *) let rec takewhile f = function | [] -> [] | x :: xs when f x -> x :: takewhile f xs | _ -> [] let rec dropwhile f = function | [] -> [] | x :: xs when f x -> dropwhile f xs | xs -> xs let rec unique ?(cmp = ( = )) l = let rec loop dst = function | [] -> () | h :: t -> match exists (cmp h) t with | true -> loop dst t | false -> let r = { hd = h; tl = [] } in dst.tl <- inj r; loop r t in let dummy = dummy_node() in loop dummy l; dummy.tl let filter_map f l = let rec loop dst = function | [] -> () | h :: t -> match f h with | None -> loop dst t | Some x -> let r = { hd = x; tl = [] } in dst.tl <- inj r; loop r t in let dummy = dummy_node() in loop dummy l; dummy.tl let fold_right_max = 1000 let fold_right f l init = let rec tail_loop acc = function | [] -> acc | h :: t -> tail_loop (f h acc) t in let rec loop n = function | [] -> init | h :: t -> if n < fold_right_max then f h (loop (n+1) t) else f h (tail_loop init (rev t)) in loop 0 l let map2 f l1 l2 = let rec loop dst src1 src2 = match src1, src2 with | [], [] -> () | h1 :: t1, h2 :: t2 -> let r = { hd = f h1 h2; tl = [] } in dst.tl <- inj r; loop r t1 t2 | _ -> raise (Different_list_size "map2") in let dummy = dummy_node () in loop dummy l1 l2; dummy.tl let rec iter2 f l1 l2 = match l1, l2 with | [], [] -> () | h1 :: t1, h2 :: t2 -> f h1 h2; iter2 f t1 t2 | _ -> raise (Different_list_size "iter2") let rec fold_left2 f accum l1 l2 = match l1, l2 with | [], [] -> accum | h1 :: t1, h2 :: t2 -> fold_left2 f (f accum h1 h2) t1 t2 | _ -> raise (Different_list_size "fold_left2") let fold_right2 f l1 l2 init = let rec tail_loop acc l1 l2 = match l1, l2 with | [] , [] -> acc | h1 :: t1 , h2 :: t2 -> tail_loop (f h1 h2 acc) t1 t2 | _ -> raise (Different_list_size "fold_right2") in let rec loop n l1 l2 = match l1, l2 with | [], [] -> init | h1 :: t1, h2 :: t2 -> if n < fold_right_max then f h1 h2 (loop (n+1) t1 t2) else f h1 h2 (tail_loop init (rev t1) (rev t2)) | _ -> raise (Different_list_size "fold_right2") in loop 0 l1 l2 let for_all2 p l1 l2 = let rec loop l1 l2 = match l1, l2 with | [], [] -> true | h1 :: t1, h2 :: t2 -> if p h1 h2 then loop t1 t2 else false | _ -> raise (Different_list_size "for_all2") in loop l1 l2 let exists2 p l1 l2 = let rec loop l1 l2 = match l1, l2 with | [], [] -> false | h1 :: t1, h2 :: t2 -> if p h1 h2 then true else loop t1 t2 | _ -> raise (Different_list_size "exists2") in loop l1 l2 let remove_assoc x lst = let rec loop dst = function | [] -> () | (a, _ as pair) :: t -> if a = x then dst.tl <- t else let r = { hd = pair; tl = [] } in dst.tl <- inj r; loop r t in let dummy = dummy_node () in loop dummy lst; dummy.tl let remove_assq x lst = let rec loop dst = function | [] -> () | (a, _ as pair) :: t -> if a == x then dst.tl <- t else let r = { hd = pair; tl = [] } in dst.tl <- inj r; loop r t in let dummy = dummy_node() in loop dummy lst; dummy.tl let rfind p l = find p (rev l) let find_all p l = let rec findnext dst = function | [] -> () | h :: t -> if p h then let r = { hd = h; tl = [] } in dst.tl <- inj r; findnext r t else findnext dst t in let dummy = dummy_node () in findnext dummy l; dummy.tl let rec findi p l = let rec loop n = function | [] -> raise Not_found | h :: t -> if p n h then (n,h) else loop (n+1) t in loop 0 l let filter = find_all let partition p lst = let rec loop yesdst nodst = function | [] -> () | h :: t -> let r = { hd = h; tl = [] } in if p h then begin yesdst.tl <- inj r; loop r nodst t end else begin nodst.tl <- inj r; loop yesdst r t end in let yesdummy = dummy_node() and nodummy = dummy_node() in loop yesdummy nodummy lst; yesdummy.tl, nodummy.tl let split lst = let rec loop adst bdst = function | [] -> () | (a, b) :: t -> let x = { hd = a; tl = [] } and y = { hd = b; tl = [] } in adst.tl <- inj x; bdst.tl <- inj y; loop x y t in let adummy = dummy_node () and bdummy = dummy_node () in loop adummy bdummy lst; adummy.tl, bdummy.tl let combine l1 l2 = let rec loop dst l1 l2 = match l1, l2 with | [], [] -> () | h1 :: t1, h2 :: t2 -> let r = { hd = h1, h2; tl = [] } in dst.tl <- inj r; loop r t1 t2 | _, _ -> raise (Different_list_size "combine") in let dummy = dummy_node () in loop dummy l1 l2; dummy.tl let sort ?(cmp=compare) = List.sort cmp let rec init size f = if size = 0 then [] else if size < 0 then invalid_arg "ExtList.init" else let rec loop dst n = if n < size then let r = { hd = f n; tl = [] } in dst.tl <- inj r; loop r (n+1) in let r = { hd = f 0; tl = [] } in loop r 1; inj r (* make by Richard W.M. Jones. *) let make i x = if i < 0 then invalid_arg "ExtList.List.make"; let rec make' x = function | 0 -> [] | i -> x :: make' x (i-1) in make' x i let mapi f = function | [] -> [] | h :: t -> let rec loop dst n = function | [] -> () | h :: t -> let r = { hd = f n h; tl = [] } in dst.tl <- inj r; loop r (n+1) t in let r = { hd = f 0 h; tl = [] } in loop r 1 t; inj r let iteri f l = let rec loop n = function | [] -> () | h :: t -> f n h; loop (n+1) t in loop 0 l let first = hd let rec last = function | [] -> raise Empty_list | h :: [] -> h | _ :: t -> last t let split_nth index = function | [] -> if index = 0 then [],[] else raise (Invalid_index index) | (h :: t as l) -> if index = 0 then [],l else if index < 0 then raise (Invalid_index index) else let rec loop n dst l = if n = 0 then l else match l with | [] -> raise (Invalid_index index) | h :: t -> let r = { hd = h; tl = [] } in dst.tl <- inj r; loop (n-1) r t in let r = { hd = h; tl = [] } in inj r, loop (index-1) r t let find_exc f e l = try find f l with Not_found -> raise e let remove l x = let rec loop dst = function | [] -> raise Not_found | h :: t -> if x = h then dst.tl <- t else let r = { hd = h; tl = [] } in dst.tl <- inj r; loop r t in let dummy = dummy_node () in loop dummy l; dummy.tl let rec remove_if f lst = let rec loop dst = function | [] -> () | x :: l -> if f x then dst.tl <- l else let r = { hd = x; tl = [] } in dst.tl <- inj r; loop r l in let dummy = dummy_node () in loop dummy lst; dummy.tl let rec remove_all l x = let rec loop dst = function | [] -> () | h :: t -> if x = h then loop dst t else let r = { hd = h; tl = [] } in dst.tl <- inj r; loop r t in let dummy = dummy_node () in loop dummy l; dummy.tl let enum l = let rec make lr count = Enum.make ~next:(fun () -> match !lr with | [] -> raise Enum.No_more_elements | h :: t -> decr count; lr := t; h ) ~count:(fun () -> if !count < 0 then count := length !lr; !count ) ~clone:(fun () -> make (ref !lr) (ref !count) ) in make (ref l) (ref (-1)) let of_enum e = let h = dummy_node() in let _ = Enum.fold (fun x acc -> let r = { hd = x; tl = [] } in acc.tl <- inj r; r) h e in h.tl end let ( @ ) = List.append haxe-3.0~svn6707/libs/extlib/IO.ml0000644000175000017500000004124712172015140017266 0ustar bdefreesebdefreese(* * IO - Abstract input/output * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type input = { mutable in_read : unit -> char; mutable in_input : string -> int -> int -> int; mutable in_close : unit -> unit; } type 'a output = { mutable out_write : char -> unit; mutable out_output : string -> int -> int -> int; mutable out_close : unit -> 'a; mutable out_flush : unit -> unit; } exception No_more_input exception Input_closed exception Output_closed (* -------------------------------------------------------------- *) (* API *) let default_close = (fun () -> ()) let create_in ~read ~input ~close = { in_read = read; in_input = input; in_close = close; } let create_out ~write ~output ~flush ~close = { out_write = write; out_output = output; out_close = close; out_flush = flush; } let read i = i.in_read() let nread i n = if n < 0 then invalid_arg "IO.nread"; if n = 0 then "" else let s = String.create n in let l = ref n in let p = ref 0 in try while !l > 0 do let r = i.in_input s !p !l in if r = 0 then raise No_more_input; p := !p + r; l := !l - r; done; s with No_more_input as e -> if !p = 0 then raise e; String.sub s 0 !p let really_output o s p l' = let sl = String.length s in if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_output"; let l = ref l' in let p = ref p in while !l > 0 do let w = o.out_output s !p !l in if w = 0 then raise Sys_blocked_io; p := !p + w; l := !l - w; done; l' let input i s p l = let sl = String.length s in if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.input"; if l = 0 then 0 else i.in_input s p l let really_input i s p l' = let sl = String.length s in if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_input"; let l = ref l' in let p = ref p in while !l > 0 do let r = i.in_input s !p !l in if r = 0 then raise Sys_blocked_io; p := !p + r; l := !l - r; done; l' let really_nread i n = if n < 0 then invalid_arg "IO.really_nread"; if n = 0 then "" else let s = String.create n in ignore(really_input i s 0 n); s let close_in i = let f _ = raise Input_closed in i.in_close(); i.in_read <- f; i.in_input <- f; i.in_close <- f let write o x = o.out_write x let nwrite o s = let p = ref 0 in let l = ref (String.length s) in while !l > 0 do let w = o.out_output s !p !l in if w = 0 then raise Sys_blocked_io; p := !p + w; l := !l - w; done let output o s p l = let sl = String.length s in if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.output"; o.out_output s p l let printf o fmt = Printf.kprintf (fun s -> nwrite o s) fmt let flush o = o.out_flush() let close_out o = let f _ = raise Output_closed in let r = o.out_close() in o.out_write <- f; o.out_output <- f; o.out_close <- f; o.out_flush <- f; r let read_all i = let maxlen = 1024 in let str = ref [] in let pos = ref 0 in let rec loop() = let s = nread i maxlen in str := (s,!pos) :: !str; pos := !pos + String.length s; loop() in try loop() with No_more_input -> let buf = String.create !pos in List.iter (fun (s,p) -> String.unsafe_blit s 0 buf p (String.length s) ) !str; buf let pos_in i = let p = ref 0 in { in_read = (fun () -> let c = i.in_read() in incr p; c ); in_input = (fun s sp l -> let n = i.in_input s sp l in p := !p + n; n ); in_close = i.in_close } , (fun () -> !p) let pos_out o = let p = ref 0 in { out_write = (fun c -> o.out_write c; incr p ); out_output = (fun s sp l -> let n = o.out_output s sp l in p := !p + n; n ); out_close = o.out_close; out_flush = o.out_flush; } , (fun () -> !p) (* -------------------------------------------------------------- *) (* Standard IO *) let input_string s = let pos = ref 0 in let len = String.length s in { in_read = (fun () -> if !pos >= len then raise No_more_input; let c = String.unsafe_get s !pos in incr pos; c ); in_input = (fun sout p l -> if !pos >= len then raise No_more_input; let n = (if !pos + l > len then len - !pos else l) in String.unsafe_blit s !pos sout p n; pos := !pos + n; n ); in_close = (fun () -> ()); } let output_string() = let b = Buffer.create 0 in { out_write = (fun c -> Buffer.add_char b c ); out_output = (fun s p l -> Buffer.add_substring b s p l; l ); out_close = (fun () -> Buffer.contents b); out_flush = (fun () -> ()); } let output_strings() = let sl = ref [] in let size = ref 0 in let b = Buffer.create 0 in { out_write = (fun c -> if !size = Sys.max_string_length then begin sl := Buffer.contents b :: !sl; Buffer.clear b; size := 0; end else incr size; Buffer.add_char b c ); out_output = (fun s p l -> if !size + l > Sys.max_string_length then begin sl := Buffer.contents b :: !sl; Buffer.clear b; size := 0; end else size := !size + l; Buffer.add_substring b s p l; l ); out_close = (fun () -> sl := Buffer.contents b :: !sl; List.rev (!sl)); out_flush = (fun () -> ()); } let input_channel ch = { in_read = (fun () -> try input_char ch with End_of_file -> raise No_more_input ); in_input = (fun s p l -> let n = Pervasives.input ch s p l in if n = 0 then raise No_more_input; n ); in_close = (fun () -> Pervasives.close_in ch); } let output_channel ch = { out_write = (fun c -> output_char ch c); out_output = (fun s p l -> Pervasives.output ch s p l; l); out_close = (fun () -> Pervasives.close_out ch); out_flush = (fun () -> Pervasives.flush ch); } let input_enum e = let pos = ref 0 in { in_read = (fun () -> match Enum.get e with | None -> raise No_more_input | Some c -> incr pos; c ); in_input = (fun s p l -> let rec loop p l = if l = 0 then 0 else match Enum.get e with | None -> l | Some c -> String.unsafe_set s p c; loop (p + 1) (l - 1) in let k = loop p l in if k = l then raise No_more_input; l - k ); in_close = (fun () -> ()); } let output_enum() = let b = Buffer.create 0 in { out_write = (fun x -> Buffer.add_char b x ); out_output = (fun s p l -> Buffer.add_substring b s p l; l ); out_close = (fun () -> let s = Buffer.contents b in ExtString.String.enum s ); out_flush = (fun () -> ()); } let pipe() = let input = ref "" in let inpos = ref 0 in let output = Buffer.create 0 in let flush() = input := Buffer.contents output; inpos := 0; Buffer.reset output; if String.length !input = 0 then raise No_more_input in let read() = if !inpos = String.length !input then flush(); let c = String.unsafe_get !input !inpos in incr inpos; c in let input s p l = if !inpos = String.length !input then flush(); let r = (if !inpos + l > String.length !input then String.length !input - !inpos else l) in String.unsafe_blit !input !inpos s p r; inpos := !inpos + r; r in let write c = Buffer.add_char output c in let output s p l = Buffer.add_substring output s p l; l in let input = { in_read = read; in_input = input; in_close = (fun () -> ()); } in let output = { out_write = write; out_output = output; out_close = (fun () -> ()); out_flush = (fun () -> ()); } in input , output external cast_output : 'a output -> unit output = "%identity" (* -------------------------------------------------------------- *) (* BINARY APIs *) exception Overflow of string let read_byte i = int_of_char (i.in_read()) let read_signed_byte i = let c = int_of_char (i.in_read()) in if c land 128 <> 0 then c - 256 else c let read_string i = let b = Buffer.create 8 in let rec loop() = let c = i.in_read() in if c <> '\000' then begin Buffer.add_char b c; loop(); end; in loop(); Buffer.contents b let read_line i = let b = Buffer.create 8 in let cr = ref false in let rec loop() = let c = i.in_read() in match c with | '\n' -> () | '\r' -> cr := true; loop() | _ when !cr -> cr := false; Buffer.add_char b '\r'; Buffer.add_char b c; loop(); | _ -> Buffer.add_char b c; loop(); in try loop(); Buffer.contents b with No_more_input -> if !cr then Buffer.add_char b '\r'; if Buffer.length b > 0 then Buffer.contents b else raise No_more_input let read_ui16 i = let ch1 = read_byte i in let ch2 = read_byte i in ch1 lor (ch2 lsl 8) let read_i16 i = let ch1 = read_byte i in let ch2 = read_byte i in let n = ch1 lor (ch2 lsl 8) in if ch2 land 128 <> 0 then n - 65536 else n let read_i32 ch = let ch1 = read_byte ch in let ch2 = read_byte ch in let ch3 = read_byte ch in let ch4 = read_byte ch in if ch4 land 128 <> 0 then begin if ch4 land 64 = 0 then raise (Overflow "read_i32"); ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24) end else begin if ch4 land 64 <> 0 then raise (Overflow "read_i32"); ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24) end let read_real_i32 ch = let ch1 = read_byte ch in let ch2 = read_byte ch in let ch3 = read_byte ch in let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in Int32.logor base big let read_i64 ch = let ch1 = read_byte ch in let ch2 = read_byte ch in let ch3 = read_byte ch in let ch4 = read_byte ch in let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in let big = Int64.of_int32 (read_real_i32 ch) in Int64.logor (Int64.shift_left big 32) small let read_double ch = Int64.float_of_bits (read_i64 ch) let write_byte o n = (* doesn't test bounds of n in order to keep semantics of Pervasives.output_byte *) write o (Char.unsafe_chr (n land 0xFF)) let write_string o s = nwrite o s; write o '\000' let write_line o s = nwrite o s; write o '\n' let write_ui16 ch n = if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16"); write_byte ch n; write_byte ch (n lsr 8) let write_i16 ch n = if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16"); if n < 0 then write_ui16 ch (65536 + n) else write_ui16 ch n let write_i32 ch n = write_byte ch n; write_byte ch (n lsr 8); write_byte ch (n lsr 16); write_byte ch (n asr 24) let write_real_i32 ch n = let base = Int32.to_int n in let big = Int32.to_int (Int32.shift_right_logical n 24) in write_byte ch base; write_byte ch (base lsr 8); write_byte ch (base lsr 16); write_byte ch big let write_i64 ch n = write_real_i32 ch (Int64.to_int32 n); write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32)) let write_double ch f = write_i64 ch (Int64.bits_of_float f) (* -------------------------------------------------------------- *) (* Big Endians *) module BigEndian = struct let read_ui16 i = let ch2 = read_byte i in let ch1 = read_byte i in ch1 lor (ch2 lsl 8) let read_i16 i = let ch2 = read_byte i in let ch1 = read_byte i in let n = ch1 lor (ch2 lsl 8) in if ch2 land 128 <> 0 then n - 65536 else n let read_i32 ch = let ch4 = read_byte ch in let ch3 = read_byte ch in let ch2 = read_byte ch in let ch1 = read_byte ch in if ch4 land 128 <> 0 then begin if ch4 land 64 = 0 then raise (Overflow "read_i32"); ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24) end else begin if ch4 land 64 <> 0 then raise (Overflow "read_i32"); ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24) end let read_real_i32 ch = let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in let ch3 = read_byte ch in let ch2 = read_byte ch in let ch1 = read_byte ch in let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in Int32.logor base big let read_i64 ch = let big = Int64.of_int32 (read_real_i32 ch) in let ch4 = read_byte ch in let ch3 = read_byte ch in let ch2 = read_byte ch in let ch1 = read_byte ch in let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in Int64.logor (Int64.shift_left big 32) small let read_double ch = Int64.float_of_bits (read_i64 ch) let write_ui16 ch n = if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16"); write_byte ch (n lsr 8); write_byte ch n let write_i16 ch n = if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16"); if n < 0 then write_ui16 ch (65536 + n) else write_ui16 ch n let write_i32 ch n = write_byte ch (n asr 24); write_byte ch (n lsr 16); write_byte ch (n lsr 8); write_byte ch n let write_real_i32 ch n = let base = Int32.to_int n in let big = Int32.to_int (Int32.shift_right_logical n 24) in write_byte ch big; write_byte ch (base lsr 16); write_byte ch (base lsr 8); write_byte ch base let write_i64 ch n = write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32)); write_real_i32 ch (Int64.to_int32 n) let write_double ch f = write_i64 ch (Int64.bits_of_float f) end (* -------------------------------------------------------------- *) (* Bits API *) type 'a bc = { ch : 'a; mutable nbits : int; mutable bits : int; } type in_bits = input bc type out_bits = unit output bc exception Bits_error let input_bits ch = { ch = ch; nbits = 0; bits = 0; } let output_bits ch = { ch = cast_output ch; nbits = 0; bits = 0; } let rec read_bits b n = if b.nbits >= n then begin let c = b.nbits - n in let k = (b.bits asr c) land ((1 lsl n) - 1) in b.nbits <- c; k end else begin let k = read_byte b.ch in if b.nbits >= 24 then begin if n >= 31 then raise Bits_error; let c = 8 + b.nbits - n in let d = b.bits land ((1 lsl b.nbits) - 1) in let d = (d lsl (8 - c)) lor (k lsr c) in b.bits <- k; b.nbits <- c; d end else begin b.bits <- (b.bits lsl 8) lor k; b.nbits <- b.nbits + 8; read_bits b n; end end let drop_bits b = b.nbits <- 0 let rec write_bits b ~nbits x = let n = nbits in if n + b.nbits >= 32 then begin if n > 31 then raise Bits_error; let n2 = 32 - b.nbits - 1 in let n3 = n - n2 in write_bits b ~nbits:n2 (x asr n3); write_bits b ~nbits:n3 (x land ((1 lsl n3) - 1)); end else begin if n < 0 then raise Bits_error; if (x < 0 || x > (1 lsl n - 1)) && n <> 31 then raise Bits_error; b.bits <- (b.bits lsl n) lor x; b.nbits <- b.nbits + n; while b.nbits >= 8 do b.nbits <- b.nbits - 8; write_byte b.ch (b.bits asr b.nbits) done end let flush_bits b = if b.nbits > 0 then write_bits b (8 - b.nbits) 0 (* -------------------------------------------------------------- *) (* Generic IO *) class in_channel ch = object method input s pos len = input ch s pos len method close_in() = close_in ch end class out_channel ch = object method output s pos len = output ch s pos len method flush() = flush ch method close_out() = ignore(close_out ch) end class in_chars ch = object method get() = try read ch with No_more_input -> raise End_of_file method close_in() = close_in ch end class out_chars ch = object method put t = write ch t method flush() = flush ch method close_out() = ignore(close_out ch) end let from_in_channel ch = let cbuf = String.create 1 in let read() = try if ch#input cbuf 0 1 = 0 then raise Sys_blocked_io; String.unsafe_get cbuf 0 with End_of_file -> raise No_more_input in let input s p l = ch#input s p l in create_in ~read ~input ~close:ch#close_in let from_out_channel ch = let cbuf = String.create 1 in let write c = String.unsafe_set cbuf 0 c; if ch#output cbuf 0 1 = 0 then raise Sys_blocked_io; in let output s p l = ch#output s p l in create_out ~write ~output ~flush:ch#flush ~close:ch#close_out let from_in_chars ch = let input s p l = let i = ref 0 in try while !i < l do String.unsafe_set s (p + !i) (ch#get()); incr i done; l with End_of_file when !i > 0 -> !i in create_in ~read:ch#get ~input ~close:ch#close_in let from_out_chars ch = let output s p l = for i = p to p + l - 1 do ch#put (String.unsafe_get s i) done; l in create_out ~write:ch#put ~output ~flush:ch#flush ~close:ch#close_out haxe-3.0~svn6707/libs/extlib/multiArray.ml0000644000175000017500000001505512172015140021106 0ustar bdefreesebdefreese(* * MultiArray - Resizeable Big Ocaml arrays * Copyright (C) 2012 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type 'a intern external ilen : 'a intern -> int = "%obj_size" let idup (x : 'a intern) = if ilen x = 0 then x else (Obj.magic (Obj.dup (Obj.repr x)) : 'a intern) let imake tag len = (Obj.magic (Obj.new_block tag len) : 'a intern) external iget : 'a intern -> int -> 'a = "%obj_field" external iset : 'a intern -> int -> 'a -> unit = "%obj_set_field" type 'a t = { mutable arr : 'a intern intern; mutable len : int; mutable darr : 'a intern option; } exception Invalid_arg of int * string * string let invalid_arg n f p = raise (Invalid_arg (n,f,p)) let length d = d.len (* create 1K chunks, which allows up to 4GB elements *) let nbits = 10 let size = 1 lsl nbits let mask = size - 1 let create() = { len = 0; arr = imake 0 0; darr = Some (imake 0 0); } let init len f = if len > Sys.max_array_length then begin let count = (len + size - 1) lsr nbits in let d = { len = len; arr = imake 0 count; darr = None; } in let max = count - 1 in for i = 0 to max do let arr = imake 0 size in iset d.arr i arr; for j = 0 to (if i = max then len land mask else size) - 1 do iset arr j (f ((i lsl nbits) + j)) done; done; d end else begin let arr = imake 0 len in for i = 0 to len - 1 do iset arr i (f i) done; { len = len; arr = imake 0 0; darr = Some arr; } end let make len e = if len > Sys.max_array_length then begin let count = (len + size - 1) lsr nbits in let d = { len = len; arr = imake 0 count; darr = None; } in let max = count - 1 in for i = 0 to max do let arr = imake 0 size in iset d.arr i arr; for j = 0 to (if i = max then len land mask else size) - 1 do iset arr j e done; done; d end else begin let arr = imake 0 len in for i = 0 to len - 1 do iset arr i e done; { len = len; arr = imake 0 0; darr = Some arr; } end let empty d = d.len = 0 let get d idx = if idx < 0 || idx >= d.len then invalid_arg idx "get" "index"; match d.darr with | None -> iget (iget d.arr (idx lsr nbits)) (idx land mask) | Some arr -> iget arr idx let set d idx v = if idx < 0 || idx >= d.len then invalid_arg idx "set" "index"; match d.darr with | None -> iset (iget d.arr (idx lsr nbits)) (idx land mask) v | Some arr -> iset arr idx v let rec add d v = (match d.darr with | None -> let asize = ilen d.arr in if d.len >= asize lsl nbits then begin let narr = imake 0 (asize + 1) in for i = 0 to asize-1 do iset narr i (iget d.arr i); done; iset narr asize (imake 0 size); d.arr <- narr; end; iset (iget d.arr (d.len lsr nbits)) (d.len land mask) v; | Some arr -> if d.len < ilen arr then begin (* set *) iset arr d.len v; end else if d.len lsl 1 >= Sys.max_array_length then begin (* promote *) let count = (d.len + size) lsr nbits in d.darr <- None; d.arr <- imake 0 count; let max = count - 1 in for i = 0 to max do let arr2 = imake 0 size in iset d.arr i arr2; for j = 0 to (if i = max then d.len land mask else size) - 1 do iset arr2 j (iget arr ((i lsl nbits) + j)) done; done; iset (iget d.arr (d.len lsr nbits)) (d.len land mask) v; end else begin (* resize *) let arr2 = imake 0 (if d.len = 0 then 1 else d.len lsl 1) in for i = 0 to d.len - 1 do iset arr2 i (iget arr i) done; iset arr2 d.len v; d.darr <- Some arr2; end); d.len <- d.len + 1 let clear d = d.len <- 0; d.arr <- imake 0 0; d.darr <- Some (imake 0 0) let of_array src = let c = create() in Array.iteri (fun i v -> add c v) src; c let of_list src = let c = create() in List.iter (add c) src; c let iter f d = match d.darr with | None -> let max = ilen d.arr - 1 in for i = 0 to max do let arr = iget d.arr i in for j = 0 to (if i = max then (d.len land mask) else size) - 1 do f (iget arr j) done; done | Some arr -> for i = 0 to d.len - 1 do f (iget arr i) done let iteri f d = match d.darr with | None -> let max = ilen d.arr - 1 in for i = 0 to max do let arr = iget d.arr i in for j = 0 to (if i = max then (d.len land mask) else size) - 1 do f ((i lsl nbits) + j) (iget arr j) done; done | Some arr -> for i = 0 to d.len - 1 do f i (iget arr i) done let map f d = match d.darr with | None -> let max = ilen d.arr - 1 in let d2 = { len = d.len; arr = imake 0 (max + 1); darr = None; } in for i = 0 to max do let arr = iget d.arr i in let narr = imake 0 size in iset d2.arr i narr; for j = 0 to (if i = max then (d.len land mask) else size) - 1 do iset narr j (f (iget arr j)) done; done; d2 | Some arr -> let arr2 = imake 0 d.len in for i = 0 to d.len - 1 do iset arr2 i (f (iget arr i)) done; { len = d.len; arr = imake 0 0; darr = Some (arr2); } let mapi f d = match d.darr with | None -> let max = ilen d.arr - 1 in let d2 = { len = d.len; arr = imake 0 (max + 1); darr = None; } in for i = 0 to max do let arr = iget d.arr i in let narr = imake 0 size in iset d2.arr i narr; for j = 0 to (if i = max then (d.len land mask) else size) - 1 do iset narr j (f ((i lsl nbits) + j) (iget arr j)) done; done; d2 | Some arr -> let arr2 = imake 0 d.len in for i = 0 to d.len - 1 do iset arr2 i (f i (iget arr i)) done; { len = d.len; arr = imake 0 0; darr = Some (arr2); } let fold_left f acc d = match d.darr with | None -> let acc = ref acc in let max = ilen d.arr - 1 in for i = 0 to max do let arr = iget d.arr i in for j = 0 to (if i = max then (d.len land mask) else size) - 1 do acc := f !acc (iget arr j) done; done; !acc | Some arr -> let acc = ref acc in for i = 0 to d.len - 1 do acc := f !acc (iget arr i) done; !acchaxe-3.0~svn6707/libs/extlib/LICENSE0000644000175000017500000006441412172015140017433 0ustar bdefreesebdefreeseThe Library is distributed under the terms of the GNU Library General Public License version 2 (included below). As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. ------------ GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. one line to give the library's name and an idea of what it does. Copyright (C) year name of author This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library 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 Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. signature of Ty Coon, 1 April 1990 Ty Coon, President of Vice That's all there is to it! haxe-3.0~svn6707/libs/extlib/uChar.ml0000644000175000017500000000310312172015140020006 0ustar bdefreesebdefreese(* * UChar - Unicode (ISO-UCS) characters * Copyright (C) 2002, 2003 Yamagata Yoriyuki * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type t = int exception Out_of_range external unsafe_chr_of_uint : int -> t = "%identity" external uint_code : t -> int = "%identity" let char_of c = if c >= 0 && c < 0x100 then Char.chr c else raise Out_of_range let of_char = Char.code let code c = if c >= 0 then c else raise Out_of_range let chr n = if n >= 0 && n lsr 31 = 0 then n else invalid_arg "UChar.chr" let chr_of_uint n = if n lsr 31 = 0 then n else invalid_arg "UChar.uint_chr" let eq (u1 : t) (u2 : t) = u1 = u2 let compare u1 u2 = let sgn = (u1 lsr 16) - (u2 lsr 16) in if sgn = 0 then (u1 land 0xFFFF) - (u2 land 0xFFFF) else sgn type uchar = t let int_of_uchar u = uint_code u let uchar_of_int n = chr_of_uint n haxe-3.0~svn6707/libs/extlib/unzip.ml0000644000175000017500000002750612172015140020126 0ustar bdefreesebdefreese(* * Unzip - inflate format decompression algorithm * Copyright (C) 2004 Nicolas Cannasse * Compliant with RFC 1950 and 1951 * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type huffman = | Found of int | NeedBit of huffman * huffman | NeedBits of int * huffman array type adler32 = { mutable a1 : int; mutable a2 : int; } type window = { mutable wbuffer : string; mutable wpos : int; wcrc : adler32; } type state = | Head | Block | CData | Flat | Crc | Dist | DistOne | Done type t = { mutable znbits : int; mutable zbits : int; mutable zstate : state; mutable zfinal : bool; mutable zhuffman : huffman; mutable zhuffdist : huffman option; mutable zlen : int; mutable zdist : int; mutable zneeded : int; mutable zoutput : string; mutable zoutpos : int; zinput : IO.input; zlengths : int array; zwindow : window; } type error_msg = | Invalid_huffman | Invalid_data | Invalid_crc | Truncated_data | Unsupported_dictionary exception Error of error_msg let error msg = raise (Error msg) (* ************************************************************************ *) (* HUFFMAN TREES *) let rec tree_depth = function | Found _ -> 0 | NeedBits _ -> assert false | NeedBit (a,b) -> 1 + min (tree_depth a) (tree_depth b) let rec tree_compress t = match tree_depth t with | 0 -> t | 1 -> (match t with | NeedBit (a,b) -> NeedBit (tree_compress a,tree_compress b) | _ -> assert false) | d -> let size = 1 lsl d in let tbl = Array.make size (Found (-1)) in tree_walk tbl 0 0 d t; NeedBits (d,tbl) and tree_walk tbl p cd d = function | NeedBit (a,b) when d > 0 -> tree_walk tbl p (cd + 1) (d-1) a; tree_walk tbl (p lor (1 lsl cd)) (cd + 1) (d-1) b; | t -> Array.set tbl p (tree_compress t) let make_huffman lengths pos nlengths maxbits = let counts = Array.make maxbits 0 in for i = 0 to nlengths - 1 do let p = Array.unsafe_get lengths (i + pos) in if p >= maxbits then error Invalid_huffman; Array.unsafe_set counts p (Array.unsafe_get counts p + 1); done; let code = ref 0 in let tmp = Array.make maxbits 0 in for i = 1 to maxbits - 2 do code := (!code + Array.unsafe_get counts i) lsl 1; Array.unsafe_set tmp i !code; done; let bits = Hashtbl.create 0 in for i = 0 to nlengths - 1 do let l = Array.unsafe_get lengths (i + pos) in if l <> 0 then begin let n = Array.unsafe_get tmp (l - 1) in Array.unsafe_set tmp (l - 1) (n + 1); Hashtbl.add bits (n,l) i; end; done; let rec tree_make v l = if l > maxbits then error Invalid_huffman; try Found (Hashtbl.find bits (v,l)) with Not_found -> NeedBit (tree_make (v lsl 1) (l + 1) , tree_make (v lsl 1 lor 1) (l + 1)) in tree_compress (NeedBit (tree_make 0 1 , tree_make 1 1)) (* ************************************************************************ *) (* ADLER32 (CRC) *) let adler32_create() = { a1 = 1; a2 = 0; } let adler32_update a s p l = let p = ref p in for i = 0 to l - 1 do let c = int_of_char (String.unsafe_get s !p) in a.a1 <- (a.a1 + c) mod 65521; a.a2 <- (a.a2 + a.a1) mod 65521; incr p; done let adler32_read ch = let a2a = IO.read_byte ch in let a2b = IO.read_byte ch in let a1a = IO.read_byte ch in let a1b = IO.read_byte ch in { a1 = (a1a lsl 8) lor a1b; a2 = (a2a lsl 8) lor a2b; } (* ************************************************************************ *) (* WINDOW *) let window_size = 1 lsl 15 let buffer_size = 1 lsl 16 let window_create size = { wbuffer = String.create buffer_size; wpos = 0; wcrc = adler32_create() } let window_slide w = adler32_update w.wcrc w.wbuffer 0 window_size; let b = String.create buffer_size in w.wpos <- w.wpos - window_size; String.unsafe_blit w.wbuffer window_size b 0 w.wpos; w.wbuffer <- b let window_add_string w s p len = if w.wpos + len > buffer_size then window_slide w; String.unsafe_blit s p w.wbuffer w.wpos len; w.wpos <- w.wpos + len let window_add_char w c = if w.wpos = buffer_size then window_slide w; String.unsafe_set w.wbuffer w.wpos c; w.wpos <- w.wpos + 1 let window_get_last_char w = String.unsafe_get w.wbuffer (w.wpos - 1) let window_available w = w.wpos let window_checksum w = adler32_update w.wcrc w.wbuffer 0 w.wpos; w.wcrc (* ************************************************************************ *) let len_extra_bits_tbl = [|0;0;0;0;0;0;0;0;1;1;1;1;2;2;2;2;3;3;3;3;4;4;4;4;5;5;5;5;0;-1;-1|] let len_base_val_tbl = [|3;4;5;6;7;8;9;10;11;13;15;17;19;23;27;31;35;43;51;59;67;83;99;115;131;163;195;227;258|] let dist_extra_bits_tbl = [|0;0;0;0;1;1;2;2;3;3;4;4;5;5;6;6;7;7;8;8;9;9;10;10;11;11;12;12;13;13;-1;-1|] let dist_base_val_tbl = [|1;2;3;4;5;7;9;13;17;25;33;49;65;97;129;193;257;385;513;769;1025;1537;2049;3073;4097;6145;8193;12289;16385;24577|] let code_lengths_pos = [|16;17;18;0;8;7;9;6;10;5;11;4;12;3;13;2;14;1;15|] let fixed_huffman = make_huffman (Array.init 288 (fun n -> if n <= 143 then 8 else if n <= 255 then 9 else if n <= 279 then 7 else 8 )) 0 288 10 let get_bits z n = while z.znbits < n do z.zbits <- z.zbits lor ((IO.read_byte z.zinput) lsl z.znbits); z.znbits <- z.znbits + 8; done; let b = z.zbits land (1 lsl n - 1) in z.znbits <- z.znbits - n; z.zbits <- z.zbits lsr n; b let get_bit z = if z.znbits = 0 then begin z.znbits <- 8; z.zbits <- IO.read_byte z.zinput; end; let b = z.zbits land 1 = 1 in z.znbits <- z.znbits - 1; z.zbits <- z.zbits lsr 1; b let rec get_rev_bits z n = if n = 0 then 0 else if get_bit z then (1 lsl (n - 1)) lor (get_rev_bits z (n-1)) else get_rev_bits z (n-1) let reset_bits z = z.zbits <- 0; z.znbits <- 0 let add_string z s p l = window_add_string z.zwindow s p l; String.unsafe_blit s p z.zoutput z.zoutpos l; z.zneeded <- z.zneeded - l; z.zoutpos <- z.zoutpos + l let add_char z c = window_add_char z.zwindow c; String.unsafe_set z.zoutput z.zoutpos c; z.zneeded <- z.zneeded - 1; z.zoutpos <- z.zoutpos + 1 let add_dist_one z n = let c = window_get_last_char z.zwindow in let s = String.make n c in add_string z s 0 n let add_dist z d l = add_string z z.zwindow.wbuffer (z.zwindow.wpos - d) l let rec apply_huffman z = function | Found n -> n | NeedBit (a,b) -> apply_huffman z (if get_bit z then b else a) | NeedBits (n,t) -> apply_huffman z (Array.unsafe_get t (get_bits z n)) let inflate_lengths z a max = let i = ref 0 in let prev = ref 0 in while !i < max do match apply_huffman z z.zhuffman with | n when n <= 15 -> prev := n; Array.unsafe_set a !i n; incr i | 16 -> let n = 3 + get_bits z 2 in if !i + n > max then error Invalid_data; for k = 0 to n - 1 do Array.unsafe_set a !i !prev; incr i; done; | 17 -> let n = 3 + get_bits z 3 in i := !i + n; if !i > max then error Invalid_data; | 18 -> let n = 11 + get_bits z 7 in i := !i + n; if !i > max then error Invalid_data; | _ -> error Invalid_data done let rec inflate_loop z = match z.zstate with | Head -> let cmf = IO.read_byte z.zinput in let cm = cmf land 15 in let cinfo = cmf lsr 4 in if cm <> 8 || cinfo <> 7 then error Invalid_data; let flg = IO.read_byte z.zinput in (*let fcheck = flg land 31 in*) let fdict = flg land 32 <> 0 in (*let flevel = flg lsr 6 in*) if (cmf lsl 8 + flg) mod 31 <> 0 then error Invalid_data; if fdict then error Unsupported_dictionary; z.zstate <- Block; inflate_loop z | Crc -> let calc = window_checksum z.zwindow in let crc = adler32_read z.zinput in if calc <> crc then error Invalid_crc; z.zstate <- Done; inflate_loop z | Done -> () | Block -> z.zfinal <- get_bit z; let btype = get_bits z 2 in (match btype with | 0 -> (* no compression *) z.zlen <- IO.read_ui16 z.zinput; let nlen = IO.read_ui16 z.zinput in if nlen <> 0xFFFF - z.zlen then error Invalid_data; z.zstate <- Flat; inflate_loop z; reset_bits z | 1 -> (* fixed Huffman *) z.zhuffman <- fixed_huffman; z.zhuffdist <- None; z.zstate <- CData; inflate_loop z | 2 -> (* dynamic Huffman *) let hlit = get_bits z 5 + 257 in let hdist = get_bits z 5 + 1 in let hclen = get_bits z 4 + 4 in for i = 0 to hclen - 1 do Array.unsafe_set z.zlengths (Array.unsafe_get code_lengths_pos i) (get_bits z 3); done; for i = hclen to 18 do Array.unsafe_set z.zlengths (Array.unsafe_get code_lengths_pos i) 0; done; z.zhuffman <- make_huffman z.zlengths 0 19 8; let lengths = Array.make (hlit + hdist) 0 in inflate_lengths z lengths (hlit + hdist); z.zhuffdist <- Some (make_huffman lengths hlit hdist 16); z.zhuffman <- make_huffman lengths 0 hlit 16; z.zstate <- CData; inflate_loop z | _ -> error Invalid_data) | Flat -> let rlen = min z.zlen z.zneeded in let str = IO.nread z.zinput rlen in let len = String.length str in z.zlen <- z.zlen - len; add_string z str 0 len; if z.zlen = 0 then z.zstate <- (if z.zfinal then Crc else Block); if z.zneeded > 0 then inflate_loop z | DistOne -> let len = min z.zlen z.zneeded in add_dist_one z len; z.zlen <- z.zlen - len; if z.zlen = 0 then z.zstate <- CData; if z.zneeded > 0 then inflate_loop z | Dist -> while z.zlen > 0 && z.zneeded > 0 do let len = min z.zneeded (min z.zlen z.zdist) in add_dist z z.zdist len; z.zlen <- z.zlen - len; done; if z.zlen = 0 then z.zstate <- CData; if z.zneeded > 0 then inflate_loop z | CData -> match apply_huffman z z.zhuffman with | n when n < 256 -> add_char z (Char.unsafe_chr n); if z.zneeded > 0 then inflate_loop z | 256 -> z.zstate <- if z.zfinal then Crc else Block; inflate_loop z | n -> let n = n - 257 in let extra_bits = Array.unsafe_get len_extra_bits_tbl n in if extra_bits = -1 then error Invalid_data; z.zlen <- (Array.unsafe_get len_base_val_tbl n) + (get_bits z extra_bits); let dist_code = (match z.zhuffdist with None -> get_rev_bits z 5 | Some h -> apply_huffman z h) in let extra_bits = Array.unsafe_get dist_extra_bits_tbl dist_code in if extra_bits = -1 then error Invalid_data; z.zdist <- (Array.unsafe_get dist_base_val_tbl dist_code) + (get_bits z extra_bits); if z.zdist > window_available z.zwindow then error Invalid_data; z.zstate <- (if z.zdist = 1 then DistOne else Dist); inflate_loop z let inflate_data z s pos len = if pos < 0 || len < 0 || pos + len > String.length s then invalid_arg "inflate_data"; z.zneeded <- len; z.zoutpos <- pos; z.zoutput <- s; try if len > 0 then inflate_loop z; len - z.zneeded with IO.No_more_input -> error Truncated_data let inflate_init ?(header=true) ch = { zfinal = false; zhuffman = fixed_huffman; zhuffdist = None; zlen = 0; zdist = 0; zstate = (if header then Head else Block); zinput = ch; zbits = 0; znbits = 0; zneeded = 0; zoutput = ""; zoutpos = 0; zlengths = Array.make 19 (-1); zwindow = window_create (1 lsl 15) } let inflate ?(header=true) ch = let z = inflate_init ~header ch in let s = String.create 1 in IO.create_in ~read:(fun() -> let l = inflate_data z s 0 1 in if l = 1 then String.unsafe_get s 0 else raise IO.No_more_input ) ~input:(fun s p l -> let n = inflate_data z s p l in if n = 0 then raise IO.No_more_input; n ) ~close:(fun () -> IO.close_in ch ) haxe-3.0~svn6707/libs/extlib/bitSet.ml0000644000175000017500000001731012172015140020203 0ustar bdefreesebdefreese(* * Bitset - Efficient bit sets * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type intern let bcreate : int -> intern = Obj.magic String.create external fast_get : intern -> int -> int = "%string_unsafe_get" external fast_set : intern -> int -> int -> unit = "%string_unsafe_set" external fast_bool : int -> bool = "%identity" let fast_blit : intern -> int -> intern -> int -> int -> unit = Obj.magic String.blit let fast_fill : intern -> int -> int -> int -> unit = Obj.magic String.fill let fast_length : intern -> int= Obj.magic String.length let bget s ndx = assert (ndx >= 0 && ndx < fast_length s); fast_get s ndx let bset s ndx v = assert (ndx >= 0 && ndx < fast_length s); fast_set s ndx v let bblit src srcoff dst dstoff len = assert (srcoff >= 0 && dstoff >= 0 && len >= 0); fast_blit src srcoff dst dstoff len let bfill dst start len c = assert (start >= 0 && len >= 0); fast_fill dst start len c exception Negative_index of string type t = { mutable data : intern; mutable len : int; } let error fname = raise (Negative_index fname) let empty() = { data = bcreate 0; len = 0; } let int_size = 7 (* value used to round up index *) let log_int_size = 3 (* number of shifts *) let create n = if n < 0 then error "create"; let size = (n+int_size) lsr log_int_size in let b = bcreate size in bfill b 0 size 0; { data = b; len = size; } let copy t = let b = bcreate t.len in bblit t.data 0 b 0 t.len; { data = b; len = t.len } let clone = copy let set t x = if x < 0 then error "set"; let pos = x lsr log_int_size and delta = x land int_size in let size = t.len in if pos >= size then begin let b = bcreate (pos+1) in bblit t.data 0 b 0 size; bfill b size (pos - size + 1) 0; t.len <- pos + 1; t.data <- b; end; bset t.data pos ((bget t.data pos) lor (1 lsl delta)) let unset t x = if x < 0 then error "unset"; let pos = x lsr log_int_size and delta = x land int_size in if pos < t.len then bset t.data pos ((bget t.data pos) land (0xFF lxor (1 lsl delta))) let toggle t x = if x < 0 then error "toggle"; let pos = x lsr log_int_size and delta = x land int_size in let size = t.len in if pos >= size then begin let b = bcreate (pos+1) in bblit t.data 0 b 0 size; bfill b size (pos - size + 1) 0; t.len <- pos + 1; t.data <- b; end; bset t.data pos ((bget t.data pos) lxor (1 lsl delta)) let put t = function | true -> set t | false -> unset t let is_set t x = if x < 0 then error "is_set"; let pos = x lsr log_int_size and delta = x land int_size in let size = t.len in if pos < size then fast_bool (((bget t.data pos) lsr delta) land 1) else false exception Break_int of int (* Find highest set element or raise Not_found *) let find_msb t = (* Find highest set bit in a byte. Does not work with zero. *) let byte_msb b = assert (b <> 0); let rec loop n = if b land (1 lsl n) = 0 then loop (n-1) else n in loop 7 in let n = t.len - 1 and buf = t.data in try for i = n downto 0 do let byte = bget buf i in if byte <> 0 then raise (Break_int ((i lsl log_int_size)+(byte_msb byte))) done; raise Not_found with Break_int n -> n | _ -> raise Not_found let compare t1 t2 = let some_msb b = try Some (find_msb b) with Not_found -> None in match (some_msb t1, some_msb t2) with (None, Some _) -> -1 (* 0-y -> -1 *) | (Some _, None) -> 1 (* x-0 -> 1 *) | (None, None) -> 0 (* 0-0 -> 0 *) | (Some a, Some b) -> (* x-y *) if a < b then -1 else if a > b then 1 else begin (* MSBs differ, we need to scan arrays until we find a difference *) let ndx = a lsr log_int_size in assert (ndx < t1.len && ndx < t2.len); try for i = ndx downto 0 do let b1 = bget t1.data i and b2 = bget t2.data i in if b1 <> b2 then raise (Break_int (compare b1 b2)) done; 0 with Break_int res -> res end let equals t1 t2 = compare t1 t2 = 0 let partial_count t x = let rec nbits x = if x = 0 then 0 else if fast_bool (x land 1) then 1 + (nbits (x lsr 1)) else nbits (x lsr 1) in let size = t.len in let pos = x lsr log_int_size and delta = x land int_size in let rec loop n acc = if n = size then acc else let x = bget t.data n in loop (n+1) (acc + nbits x) in if pos >= size then 0 else loop (pos+1) (nbits ((bget t.data pos) lsr delta)) let count t = partial_count t 0 let enum t = let rec make n = let cur = ref n in let rec next() = let pos = !cur lsr log_int_size and delta = !cur land int_size in if pos >= t.len then raise Enum.No_more_elements; let x = bget t.data pos in let rec loop i = if i = 8 then next() else if x land (1 lsl i) = 0 then begin incr cur; loop (i+1) end else !cur in let b = loop delta in incr cur; b in Enum.make ~next ~count:(fun () -> partial_count t !cur) ~clone:(fun () -> make !cur) in make 0 let raw_create size = let b = bcreate size in bfill b 0 size 0; { data = b; len = size } let inter a b = let max_size = max a.len b.len in let d = raw_create max_size in let sl = min a.len b.len in let abuf = a.data and bbuf = b.data in (* Note: rest of the array is set to zero automatically *) for i = 0 to sl-1 do bset d.data i ((bget abuf i) land (bget bbuf i)) done; d (* Note: rest of the array is handled automatically correct, since we took a copy of the bigger set. *) let union a b = let d = if a.len > b.len then copy a else copy b in let sl = min a.len b.len in let abuf = a.data and bbuf = b.data in for i = 0 to sl-1 do bset d.data i ((bget abuf i) lor (bget bbuf i)) done; d let diff a b = let maxlen = max a.len b.len in let buf = bcreate maxlen in bblit a.data 0 buf 0 a.len; let sl = min a.len b.len in let abuf = a.data and bbuf = b.data in for i = 0 to sl-1 do bset buf i ((bget abuf i) land (lnot (bget bbuf i))) done; { data = buf; len = maxlen } let sym_diff a b = let maxlen = max a.len b.len in let buf = bcreate maxlen in (* Copy larger (assumes missing bits are zero) *) bblit (if a.len > b.len then a.data else b.data) 0 buf 0 maxlen; let sl = min a.len b.len in let abuf = a.data and bbuf = b.data in for i = 0 to sl-1 do bset buf i ((bget abuf i) lxor (bget bbuf i)) done; { data = buf; len = maxlen } (* TODO the following set operations can be made faster if you do the set operation in-place instead of taking a copy. But be careful when the sizes of the bitvector strings differ. *) let intersect t t' = let d = inter t t' in t.data <- d.data; t.len <- d.len let differentiate t t' = let d = diff t t' in t.data <- d.data; t.len <- d.len let unite t t' = let d = union t t' in t.data <- d.data; t.len <- d.len let differentiate_sym t t' = let d = sym_diff t t' in t.data <- d.data; t.len <- d.len haxe-3.0~svn6707/libs/extlib/option.ml0000644000175000017500000000244712172015140020266 0ustar bdefreesebdefreese(* * Option - functions for the option type * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) exception No_value let may f = function | None -> () | Some v -> f v let map f = function | None -> None | Some v -> Some (f v) let default v = function | None -> v | Some v -> v let is_some = function | None -> false | _ -> true let is_none = function | None -> true | _ -> false let get = function | None -> raise No_value | Some v -> v let map_default f v = function | None -> v | Some v2 -> f v2 haxe-3.0~svn6707/libs/extlib/base64.ml0000644000175000017500000000633612172015140020043 0ustar bdefreesebdefreese(* * Base64 - Base64 codec * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) exception Invalid_char exception Invalid_table external unsafe_char_of_int : int -> char = "%identity" type encoding_table = char array type decoding_table = int array let chars = [| 'A';'B';'C';'D';'E';'F';'G';'H';'I';'J';'K';'L';'M';'N';'O';'P'; 'Q';'R';'S';'T';'U';'V';'W';'X';'Y';'Z';'a';'b';'c';'d';'e';'f'; 'g';'h';'i';'j';'k';'l';'m';'n';'o';'p';'q';'r';'s';'t';'u';'v'; 'w';'x';'y';'z';'0';'1';'2';'3';'4';'5';'6';'7';'8';'9';'+';'/' |] let make_decoding_table tbl = if Array.length tbl <> 64 then raise Invalid_table; let d = Array.make 256 (-1) in for i = 0 to 63 do Array.unsafe_set d (int_of_char (Array.unsafe_get tbl i)) i; done; d let inv_chars = make_decoding_table chars let encode ?(tbl=chars) ch = if Array.length tbl <> 64 then raise Invalid_table; let data = ref 0 in let count = ref 0 in let flush() = if !count > 0 then begin let d = (!data lsl (6 - !count)) land 63 in IO.write ch (Array.unsafe_get tbl d); end; in let write c = let c = int_of_char c in data := (!data lsl 8) lor c; count := !count + 8; while !count >= 6 do count := !count - 6; let d = (!data asr !count) land 63 in IO.write ch (Array.unsafe_get tbl d) done; in let output s p l = for i = p to p + l - 1 do write (String.unsafe_get s i) done; l in IO.create_out ~write ~output ~flush:(fun () -> flush(); IO.flush ch) ~close:(fun() -> flush(); IO.close_out ch) let decode ?(tbl=inv_chars) ch = if Array.length tbl <> 256 then raise Invalid_table; let data = ref 0 in let count = ref 0 in let rec fetch() = if !count >= 8 then begin count := !count - 8; let d = (!data asr !count) land 0xFF in unsafe_char_of_int d end else let c = int_of_char (IO.read ch) in let c = Array.unsafe_get tbl c in if c = -1 then raise Invalid_char; data := (!data lsl 6) lor c; count := !count + 6; fetch() in let read = fetch in let input s p l = let i = ref 0 in try while !i < l do String.unsafe_set s (p + !i) (fetch()); incr i; done; l with IO.No_more_input when !i > 0 -> !i in let close() = count := 0; IO.close_in ch in IO.create_in ~read ~input ~close let str_encode ?(tbl=chars) s = let ch = encode ~tbl (IO.output_string()) in IO.nwrite ch s; IO.close_out ch let str_decode ?(tbl=inv_chars) s = let ch = decode ~tbl (IO.input_string s) in IO.nread ch ((String.length s * 6) / 8) haxe-3.0~svn6707/libs/extlib/unzip.mli0000644000175000017500000000314612172015140020271 0ustar bdefreesebdefreese(* * Unzip - inflate format decompression algorithm * Copyright (C) 2004 Nicolas Cannasse * Compliant with RFC 1950 and 1951 * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Decompression algorithm. Unzip decompression algorithm is compliant with RFC 1950 and 1951 which are describing the "inflate" algorithm used in most popular file formats. This format is also the one used by the popular ZLib library. *) type error_msg = | Invalid_huffman | Invalid_data | Invalid_crc | Truncated_data | Unsupported_dictionary exception Error of error_msg val inflate : ?header:bool -> IO.input -> IO.input (** wrap an input using "inflate" decompression algorithm. raises [Error] if an error occurs (this can only be caused by malformed input data). *) type t val inflate_init : ?header:bool -> IO.input -> t val inflate_data : t -> string -> int -> int -> int haxe-3.0~svn6707/libs/extlib/refList.mli0000644000175000017500000001413012172015140020527 0ustar bdefreesebdefreese(* * RefList - List reference * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Reference on lists. RefList is a extended set of functions that manipulate list references. *) exception Empty_list exception Invalid_index of int type 'a t val empty : unit -> 'a t (** Returns a new empty ref list *) val is_empty : 'a t -> bool (** Return [true] if a ref list is empty *) val clear : 'a t -> unit (** Removes all elements *) val length : 'a t -> int (** Returns the number of elements - O(n) *) val copy : dst:'a t -> src:'a t -> unit (** Makes a copy of a ref list - O(1) *) val copy_list : dst:'a t -> src:'a list -> unit (** Makes a copy of a list - O(1) *) val copy_enum : dst:'a t -> src:'a Enum.t -> unit (** Makes a copy of a enum *) val of_list : 'a list -> 'a t (** Creates a ref list from a list - O(1) *) val to_list : 'a t -> 'a list (** Returns the current elements as a list - O(1) *) val of_enum : 'a Enum.t -> 'a t (** Creates a ref list from an enumeration *) val enum : 'a t -> 'a Enum.t (** Returns an enumeration of current elements in the ref list *) val add : 'a t -> 'a -> unit (** Adds an element at the end - O(n) *) val push : 'a t -> 'a -> unit (** Adds an element at the head - O(1) *) val add_sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a -> unit (** Adds an element in a sorted list, using optional comparator or 'compare' as default. *) val first : 'a t -> 'a (** Returns the first element or raises [Empty_list] if the ref list is empty *) val last : 'a t -> 'a (** Returns the last element - O(n) or raises Empty_list if the ref list is empty *) val pop : 'a t -> 'a (** Removes and returns the first element or raises [Empty_list] if the ref list is empty *) val npop : 'a t -> int -> 'a list (** Removes and returns the n first elements or raises [Empty_list] if the ref list does not contain enough elements *) val hd : 'a t -> 'a (** same as [first] *) val tl : 'a t -> 'a t (** Returns a ref list containing the same elements but without the first one or raises [Empty_list] if the ref list is empty *) val rev : 'a t -> unit (** Reverses the ref list - O(n) *) (** {6 Functional Operations} *) val iter : ('a -> unit) -> 'a t -> unit (** Apply the given function to all elements of the ref list, in respect with the order of the list *) val find : ('a -> bool) -> 'a t -> 'a (** Find the first element matching the specified predicate raise [Not_found] if no element is found *) val rfind : ('a -> bool) -> 'a t -> 'a (** Find the first element in the reversed ref list matching the specified predicate raise [Not_found] if no element is found *) val find_exc : ('a -> bool) -> exn -> 'a t -> 'a (** Same as find but takes an exception to be raised when no element is found as additional parameter *) val exists : ('a -> bool) -> 'a t -> bool (** Return [true] if an element matches the specified predicate *) val for_all : ('a -> bool) -> 'a t -> bool (** Return [true] if all elements match the specified predicate *) val map : ('a -> 'b) -> 'a t -> 'b t (** Apply a function to all elements and return the ref list constructed with the function returned values *) val transform : ('a -> 'a) -> 'a t -> unit (** transform all elements in the ref list using a function. *) val map_list : ('a -> 'b) -> 'a t -> 'b list (** Apply a function to all elements and return the list constructed with the function returned values *) val sort : ?cmp:('a -> 'a -> int) -> 'a t -> unit (** Sort elements using the specified comparator or compare as default comparator *) val filter : ('a -> bool) -> 'a t -> unit (** Remove all elements that do not match the specified predicate *) val remove : 'a t -> 'a -> unit (** Remove an element from the ref list raise [Not_found] if the element is not found *) val remove_if : ('a -> bool) -> 'a t -> unit (** Remove the first element matching the specified predicate raise [Not_found] if no element has been removed *) val remove_all : 'a t -> 'a -> unit (** Remove all elements equal to the specified element from the ref list *) (** Functions that operate on the [i]th element of a list. While it is sometimes necessary to perform these operations on lists (hence their inclusion here), the functions were moved to an inner module to prevent their overuse: all functions work in O(n) time. You might prefer to use [Array] or [DynArray] for constant time indexed element access. *) module Index : sig val index_of : 'a t -> 'a -> int (** Return the index (position : 0 starting) of an element in a ref list, using ( = ) for testing element equality raise [Not_found] if no element was found *) val index : ('a -> bool) -> 'a t -> int (** Return the index (position : 0 starting) of an element in a ref list, using the specified comparator raise [Not_found] if no element was found *) val at_index : 'a t -> int -> 'a (** Return the element of ref list at the specified index raise [Invalid_index] if the index is outside [0 ; length-1] *) val set : 'a t -> int -> 'a -> unit (** Change the element at the specified index raise [Invalid_index] if the index is outside [0 ; length-1] *) val remove_at : 'a t -> int -> unit (** Remove the element at the specified index raise [Invalid_index] if the index is outside [0 ; length-1] *) end haxe-3.0~svn6707/libs/extlib/refList.ml0000644000175000017500000000675112172015140020370 0ustar bdefreesebdefreese(* * RefList - List reference * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open ExtList exception Empty_list exception Invalid_index of int type 'a t = 'a list ref let empty () = ref [] let is_empty x = match !x with | [] -> true | _ -> false let of_list l = ref l let to_list rl = !rl let copy ~dst ~src = dst := !src let copy_list ~dst ~src = dst := src let add rl item = rl := List.append !rl [item] let push rl item = rl := item::!rl let clear rl = rl := [] let length rl = List.length !rl let hd rl = try List.hd !rl with _ -> raise Empty_list let tl rl = try ref (List.tl !rl) with _ -> raise Empty_list let iter f rl = List.iter f !rl let for_all f rl = List.for_all f !rl let map f rl = ref (List.map f !rl) let transform f rl = rl := List.map f !rl let map_list f rl = List.map f !rl let find f rl = List.find f !rl let rev rl = rl := List.rev !rl let find_exc f exn rl = try List.find f !rl with _ -> raise exn let exists f rl = List.exists f !rl let sort ?(cmp=compare) rl = rl := List.sort ~cmp !rl let rfind f rl = List.rfind f !rl let first = hd let last rl = let rec loop = function | x :: [] -> x | x :: l -> loop l | [] -> assert false in match !rl with | [] -> raise Empty_list | l -> loop l let remove rl item = rl := List.remove !rl item let remove_if pred rl = rl := List.remove_if pred !rl let remove_all rl item = rl := List.remove_all !rl item let filter pred rl = rl := List.filter pred !rl let add_sort ?(cmp=compare) rl item = let rec add_aux = function | x::lnext as l -> let r = cmp x item in if r < 0 then item::l else x::(add_aux lnext) | [] -> [item] in rl := add_aux !rl let pop rl = match !rl with | [] -> raise Empty_list | e::l -> rl := l; e let npop rl n = let rec pop_aux l n = if n = 0 then begin rl := l; [] end else match l with | [] -> raise Empty_list | x::l -> x::(pop_aux l (n-1)) in pop_aux !rl n let copy_enum ~dst ~src = dst := List.of_enum src let enum rl = List.enum !rl let of_enum e = ref (List.of_enum e) module Index = struct let remove_at rl pos = let p = ref (-1) in let rec del_aux = function | x::l -> incr p; if !p = pos then l else x::(del_aux l) | [] -> raise (Invalid_index pos) in rl := del_aux !rl let index pred rl = let index = ref (-1) in List.find (fun it -> incr index; pred it; ) !rl; !index let index_of rl item = let index = ref (-1) in List.find (fun it -> incr index; it = item; ) !rl; !index let at_index rl pos = try List.nth !rl pos with _ -> raise (Invalid_index pos) let set rl pos newitem = let p = ref (-1) in rl := List.map (fun item -> incr p; if !p = pos then newitem else item) !rl; if !p < pos || pos < 0 then raise (Invalid_index pos) end haxe-3.0~svn6707/libs/extlib/extString.ml0000644000175000017500000001164012172015140020740 0ustar bdefreesebdefreese(* * ExtString - Additional functions for string manipulations. * Copyright (C) 2003 Nicolas Cannasse * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version, * with the special exception on linking described in file LICENSE. * * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) exception Invalid_string module String = struct include String let init len f = let s = create len in for i = 0 to len - 1 do unsafe_set s i (f i) done; s let starts_with str p = let len = length p in if length str < len then false else sub str 0 len = p let ends_with s e = let el = length e in let sl = length s in if sl < el then false else sub s (sl-el) el = e let find str sub = let sublen = length sub in if sublen = 0 then 0 else let found = ref 0 in let len = length str in try for i = 0 to len - sublen do let j = ref 0 in while unsafe_get str (i + !j) = unsafe_get sub !j do incr j; if !j = sublen then begin found := i; raise Exit; end; done; done; raise Invalid_string with Exit -> !found let exists str sub = try ignore(find str sub); true with Invalid_string -> false let strip ?(chars=" \t\r\n") s = let p = ref 0 in let l = length s in while !p < l && contains chars (unsafe_get s !p) do incr p; done; let p = !p in let l = ref (l - 1) in while !l >= p && contains chars (unsafe_get s !l) do decr l; done; sub s p (!l - p + 1) let split str sep = let p = find str sep in let len = length sep in let slen = length str in sub str 0 p, sub str (p + len) (slen - p - len) let rec nsplit str sep = try let s1 , s2 = split str sep in s1 :: nsplit s2 sep with Invalid_string -> [str] let join = concat let slice ?(first=0) ?(last=Sys.max_string_length) s = let clip _min _max x = max _min (min _max x) in let i = clip 0 (length s) (if (first<0) then (length s) + first else first) and j = clip 0 (length s) (if (last<0) then (length s) + last else last) in if i>=j || i=length s then create 0 else sub s i (j-i) let lchop s = if s = "" then "" else sub s 1 (length s - 1) let rchop s = if s = "" then "" else sub s 0 (length s - 1) let of_int = string_of_int let of_float = string_of_float let of_char = make 1 let to_int s = try int_of_string s with _ -> raise Invalid_string let to_float s = try float_of_string s with _ -> raise Invalid_string let enum s = let l = length s in let rec make i = Enum.make ~next:(fun () -> if !i = l then raise Enum.No_more_elements else let p = !i in incr i; unsafe_get s p ) ~count:(fun () -> l - !i) ~clone:(fun () -> make (ref !i)) in make (ref 0) let of_enum e = let l = Enum.count e in let s = create l in let i = ref 0 in Enum.iter (fun c -> unsafe_set s !i c; incr i) e; s let map f s = let len = length s in let sc = create len in for i = 0 to len - 1 do unsafe_set sc i (f (unsafe_get s i)) done; sc (* fold_left and fold_right by Eric C. Cooper *) let fold_left f init str = let n = String.length str in let rec loop i result = if i = n then result else loop (i + 1) (f result str.[i]) in loop 0 init let fold_right f str init = let n = String.length str in let rec loop i result = if i = 0 then result else let i' = i - 1 in loop i' (f str.[i'] result) in loop n init (* explode and implode from the OCaml Expert FAQ. *) let explode s = let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in exp (String.length s - 1) [] let implode l = let res = String.create (List.length l) in let rec imp i = function | [] -> res | c :: l -> res.[i] <- c; imp (i + 1) l in imp 0 l let replace_chars f s = let len = String.length s in let tlen = ref 0 in let rec loop i acc = if i = len then acc else let s = f (unsafe_get s i) in tlen := !tlen + length s; loop (i+1) (s :: acc) in let strs = loop 0 [] in let sbuf = create !tlen in let pos = ref !tlen in let rec loop2 = function | [] -> () | s :: acc -> let len = length s in pos := !pos - len; blit s 0 sbuf !pos len; loop2 acc in loop2 strs; sbuf let replace ~str ~sub ~by = try let i = find str sub in (true, (slice ~last:i str) ^ by ^ (slice ~first:(i+(String.length sub)) str)) with Invalid_string -> (false, String.copy str) end haxe-3.0~svn6707/libs/extlib/odoc_style.css0000644000175000017500000000227012172015140021274 0ustar bdefreesebdefreesebody { padding: 0px 20px 0px 26px; background: #ffffff; color: #000000; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 90%; } h1 { padding : 5px 0px 5px 0px; font-size : 16pt; font-weight : normal; background-color : #E0E0FF } h6 { padding : 5px 0px 5px 20px; font-size : 16pt; font-weight : normal; background-color : #E0E0FF } a:link, a:visited, a:active { text-decoration: none; } a:link { color: #000077; } a:visited { color: #000077; } a:hover { color: #cc9900; } .keyword { font-weight : bold ; color : Blue } .keywordsign { color : #606060 } .superscript { font-size : 4 } .subscript { font-size : 4 } .comment { color : #606060 } .constructor { color : #808080; } .type { color : #606060 } .string { color : Red } .warning { color : Red ; font-weight : bold } .info { margin-left : 3em; margin-right : 3em } .code { color : #606060 ; } .title1 { font-size : 16pt ; background-color : #E0E0E0 } .title2 { font-size : 16pt ; background-color : #E0E0E0 } .title3 { font-size : 16pt ; background-color : #E0E0E0 } .title4 { font-size : 16pt ; background-color : #E0E0E0 } .title5 { font-size : 16pt ; background-color : #E0E0E0 } .title6 { font-size : 16pt ; background-color : #E0E0E0; }haxe-3.0~svn6707/libs/ziplib/0000755000175000017500000000000012172015140016417 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/ziplib/zip.mli0000644000175000017500000002254312172015140017732 0ustar bdefreesebdefreese(***********************************************************************) (* *) (* The CamlZip library *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* adapted to Extc lib by Caue Waneck *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License, with *) (* the special exception on linking described in file LICENSE. *) (* *) (***********************************************************************) (* $Id: zip.mli,v 1.7 2008/12/07 09:23:08 xleroy Exp $ *) (** Reading and writing ZIP archives This module provides functions for reading and writing ZIP archive files. ZIP archives package one or more compressed files into a single ``ZIP file'' along with information about the files, including file name, date and time of last modification, user-provided comments, and a checksum to verify the integrity of each entry. The entries of a ZIP file are not necessarily actual files, and can actually consist of arbitrary data. The ZIP file format used in this module is identical to that implemented by the popular [pkzip] archiver under Windows, and by the Info-ZIP [zip] and [unzip] commands under Unix and Windows. This format is also identical to the JAR file format used by Java. *) (** {6 Information on ZIP entries} *) type compression_method = Stored (** data is stored without compression *) | Deflated (** data is compressed with the ``deflate'' algorithm *) (** Indicate whether the data in the entry is compressed or not. *) type entry = { filename: string; (** file name for entry *) extra: string; (** extra information attached to entry *) comment: string; (** comment attached to entry *) methd: compression_method; (** compression method *) mtime: float; (** last modification time (seconds since epoch) *) crc: int32; (** cyclic redundancy check for data *) uncompressed_size: int; (** size of original data in bytes *) compressed_size: int; (** size of compressed data *) is_directory: bool; (** whether this entry represents a directory *) file_offset: int64 (** for internal use *) } (** Description of an entry in a ZIP file. *) (** {6 Reading from ZIP files} *) type in_file (** Abstract type representing a handle opened for reading from a ZIP file. *) val open_in: string -> in_file (** Open the ZIP file with the given filename. Return a handle opened for reading from this file. *) val entries: in_file -> entry list (** Return a list of all entries in the given ZIP file. *) val comment: in_file -> string (** Return the comment attached to the given ZIP file, or the empty string if none. *) val find_entry: in_file -> string -> entry (** [Zip.find_entry zf filename] returns the description of the entry having name [filename] in the ZIP file [zf]. Raises [Not_found] if no such entry exists. The file name must match exactly; in particular, case is significant. File names must use [/] (slash) as the directory separator. The name of a directory must end with a trailing [/] (slash). *) val read_entry: in_file -> entry -> string (** [Zip.read_entry zf e] reads and uncompresses the data (file contents) associated with entry [e] of ZIP file [zf]. The data is returned as a character string. *) val copy_entry_to_channel: in_file -> entry -> out_channel -> unit (** [Zip.copy_entry_to_channel zf e oc] reads and uncompresses the data associated with entry [e] of ZIP file [zf]. It then writes this data to the output channel [oc]. *) val copy_entry_to_file: in_file -> entry -> string -> unit (** [Zip.copy_entry_to_file zf e destfile] reads and uncompresses the data associated with entry [e] of ZIP file [zf]. It then writes this data to the file named [destfile]. The file [destfile] is created if it does not exist, and overwritten otherwise. The last modification date of the file is set to that indicated in the ZIP entry [e], if possible. *) val close_in: in_file -> unit (** Close the given ZIP file handle. If the ZIP file handle was created by [open_in_channel], the underlying input channel is closed. *) (** {6 Writing to ZIP files} *) type out_file (** Abstract type representing a handle opened for writing to a ZIP file. *) val open_out: ?comment: string -> string -> out_file (** Create (or truncate to zero length) the ZIP file with the given filename. Return a handle opened for writing to this file. The optional argument [comment] is a comment string that is attached to the ZIP file as a whole (as opposed to the comments that can be attached to individual ZIP entries). *) val add_entry: string -> out_file -> ?extra: string -> ?comment: string -> ?level: int -> ?mtime: float -> string -> unit (** [Zip.add_entry data zf name] adds a new entry to the ZIP file [zf]. The data (file contents) associated with the entry is taken from the string [data]. It is compressed and written to the ZIP file [zf]. [name] is the file name stored along with this entry. Several optional arguments can be provided to control the format and attached information of the entry: @param extra extra data attached to the entry (a string). Default: empty. @param comment attached to the entry (a string). Default: empty. @param level compression level for the entry. This is an integer between 0 and 9, with 0 meaning no compression (store as is), 1 lowest compression, 9 highest compression. Higher levels result in smaller compressed data, but longer compression times. Default: 6 (moderate compression). @param mtime last modification time (in seconds since the epoch). Default: the current time. *) val copy_channel_to_entry: in_channel -> out_file -> ?extra: string -> ?comment: string -> ?level: int -> ?mtime: float -> string -> unit (** Same as [Zip.add_entry], but the data associated with the entry is read from the input channel given as first argument. The channel is read up to end of file. *) val copy_file_to_entry: string -> out_file -> ?extra: string -> ?comment: string -> ?level: int -> ?mtime: float -> string -> unit (** Same as [Zip.add_entry], but the data associated with the entry is read from the file whose name is given as first argument. Also, the default value for the [mtime] optional parameter is the time of last modification of the file. *) val add_entry_generator: out_file -> ?extra: string -> ?comment: string -> ?level: int -> ?mtime: float -> string -> (string -> int -> int -> unit) * (unit -> unit) (** [Zip.add_entry_generator zf name] returns a pair of functions [(add, finish)]. It adds a new entry to the ZIP file [zf]. The file name stored along with this entry is [name]. Initially, no data is stored in this entry. To store data in this entry, the program must repeatedly call the [add] function returned by [Zip.add_entry_generator]. An invocation [add s ofs len] stores [len] characters of string [s] starting at offset [ofs] in the ZIP entry. When all the data forming the entry has been sent, the program must call the [finish] function returned by [Zip.add_entry_generator]. [finish] must be called exactly once. The optional arguments to [Zip.add_entry_generator] are as described in {!Zip.add_entry}. *) val close_out: out_file -> unit (** Finish writing the ZIP archive by adding the table of contents, and close it. *) (** {6 Error reporting} *) exception Error of string * string * string (** Exception raised when an ill-formed ZIP archive is encountered, or illegal parameters are given to the functions in this module. The exception is of the form [Error(ZIP_name, entry_name, message)] where [ZIP_name] is the name of the ZIP file, [entry_name] the name of the offending entry, and [message] an explanation of the error. *) haxe-3.0~svn6707/libs/ziplib/Makefile0000644000175000017500000000030612172015140020056 0ustar bdefreesebdefreeseall: ocamlopt -g -I ../extlib -I ../extc -a -o zip.cmxa zlib.mli zlib.ml zip.mli zip.ml clean: rm -rf zip.cmxa zip.lib zip.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi)haxe-3.0~svn6707/libs/ziplib/zlib.ml0000644000175000017500000001147512172015140017721 0ustar bdefreesebdefreese(***********************************************************************) (* *) (* The CamlZip library *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* adapted to Extc lib by Caue Waneck *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License, with *) (* the special exception on linking described in file LICENSE. *) (* *) (***********************************************************************) (* $Id: zlib.ml,v 1.4 2008/12/07 09:23:08 xleroy Exp $ *) open Extc;; let buffer_size = 1024 let polynom = 0xedb88320l let crc_table = Array.init 256 (fun n -> let crc = ref (Int32.of_int n) in for j = 0 to 7 do crc := if Int32.to_int (Int32.logand (!crc) 1l) <> 0 then Int32.logxor (Int32.shift_right_logical (!crc) 1) polynom else Int32.shift_right_logical (!crc) 1; done; !crc) let max_wbits = 15 let compress ?(level = 6) ?(header = true) refill flush = let inbuf = String.create buffer_size and outbuf = String.create buffer_size in let zs = Extc.zlib_deflate_init2 level (if header then max_wbits else -max_wbits) in let rec compr inpos inavail = if inavail = 0 then begin let incount = refill inbuf in if incount = 0 then compr_finish() else compr 0 incount end else begin let res = Extc.zlib_deflate zs ~src:inbuf ~spos:inpos ~slen:inavail ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_NO_FLUSH in let used_in, used_out = res.z_read, res.z_wrote in flush outbuf used_out; compr (inpos + used_in) (inavail - used_in) end and compr_finish () = let ret = Extc.zlib_deflate zs ~src:inbuf ~spos:0 ~slen:0 ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_FINISH in let (finished, _, used_out) = ret.z_finish, ret.z_read, ret.z_wrote in flush outbuf used_out; if not finished then compr_finish() in compr 0 0; Extc.zlib_deflate_end zs let compress_direct ?(level = 6) ?(header = true) flush = let outbuf = String.create buffer_size in let zs = Extc.zlib_deflate_init2 level (if header then max_wbits else -max_wbits) in let rec compr inbuf inpos inavail = if inavail = 0 then () else begin let res = Extc.zlib_deflate zs ~src:inbuf ~spos:inpos ~slen:inavail ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_NO_FLUSH in let used_in, used_out = res.z_read, res.z_wrote in flush outbuf used_out; compr inbuf (inpos + used_in) (inavail - used_in) end and compr_finish () = let ret = Extc.zlib_deflate zs ~src:"" ~spos:0 ~slen:0 ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_FINISH in let (finished, _, used_out) = ret.z_finish, (), ret.z_wrote in flush outbuf used_out; if not finished then compr_finish() in compr, compr_finish let uncompress ?(header = true) refill flush = let inbuf = String.create buffer_size and outbuf = String.create buffer_size in let zs = Extc.zlib_inflate_init2 (if header then max_wbits else -max_wbits) in let rec uncompr inpos inavail = if inavail = 0 then begin let incount = refill inbuf in if incount = 0 then uncompr_finish true else uncompr 0 incount end else begin let ret = Extc.zlib_inflate zs ~src:inbuf ~spos: inpos ~slen:inavail ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_SYNC_FLUSH in let (finished, used_in, used_out) = ret.z_finish, ret.z_read, ret.z_wrote in flush outbuf used_out; if not finished then uncompr (inpos + used_in) (inavail - used_in) end and uncompr_finish first_finish = (* Gotcha: if there is no header, inflate requires an extra "dummy" byte after the compressed stream in order to complete decompression and return finished = true. *) let dummy_byte = if first_finish && not header then 1 else 0 in let ret = Extc.zlib_inflate zs ~src:inbuf ~spos:0 ~slen:dummy_byte ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_SYNC_FLUSH in let (finished, _, used_out) = ret.z_finish, ret.z_read, ret.z_wrote in flush outbuf used_out; if not finished then uncompr_finish false in uncompr 0 0; Extc.zlib_inflate_end zs let update_crc crc buf pos len = let c = ref (Int32.lognot crc) in for i = pos to (len + pos - 1) do let b = Int32.of_int (int_of_char (String.get buf i)) in c := Int32.logxor (Array.get crc_table (Int32.to_int (Int32.logand (Int32.logxor !c b) 0xFFl))) (Int32.shift_right_logical !c 8); done; let ret = Int32.lognot !c in rethaxe-3.0~svn6707/libs/ziplib/zip.ml0000644000175000017500000005404412172015140017562 0ustar bdefreesebdefreese(***********************************************************************) (* *) (* The CamlZip library *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* adapted to Extc lib by Caue Waneck *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License, with *) (* the special exception on linking described in file LICENSE. *) (* *) (***********************************************************************) (* $Id: zip.ml,v 1.5 2008/12/07 09:23:08 xleroy Exp $ *) (* Module [Zip]: reading and writing ZIP archives *) exception Error of string * string * string let read1 = input_byte let read2 ic = let lb = read1 ic in let hb = read1 ic in lb lor (hb lsl 8) let read4 ic = let lw = read2 ic in let hw = read2 ic in Int32.logor (Int32.of_int lw) (Int32.shift_left (Int32.of_int hw) 16) let read4_int ic = let lw = read2 ic in let hw = read2 ic in if hw > max_int lsr 16 then raise (Error("", "", "32-bit data too large")); lw lor (hw lsl 16) let readstring ic n = let s = String.create n in really_input ic s 0 n; s let write1 = output_byte let write2 oc n = write1 oc n; write1 oc (n lsr 8) let write4 oc n = write2 oc (Int32.to_int n); write2 oc (Int32.to_int (Int32.shift_right_logical n 16)) let write4_int oc n = write2 oc n; write2 oc (n lsr 16) let writestring oc s = output oc s 0 (String.length s) type compression_method = Stored | Deflated type entry = { filename: string; extra: string; comment: string; methd: compression_method; mtime: float; crc: int32; uncompressed_size: int; compressed_size: int; is_directory: bool; file_offset: int64 } type in_file = { if_filename: string; if_channel: Pervasives.in_channel; if_entries: entry list; if_directory: (string, entry) Hashtbl.t; if_comment: string } let entries ifile = ifile.if_entries let comment ifile = ifile.if_comment type out_file = { of_filename: string; of_channel: Pervasives.out_channel; mutable of_entries: entry list; of_comment: string } exception Error of string * string * string (* Return the position of the last occurrence of s1 in s2, or -1 if not found. *) let strrstr pattern buf ofs len = let rec search i j = if i < ofs then -1 else if j >= String.length pattern then i else if pattern.[j] = buf.[i + j] then search i (j+1) else search (i-1) 0 in search (ofs + len - String.length pattern) 0 (* Determine if a file name is a directory (ends with /) *) let filename_is_directory name = String.length name > 0 && name.[String.length name - 1] = '/' (* Convert between Unix dates and DOS dates *) let unixtime_of_dostime time date = fst(Unix.mktime { Unix.tm_sec = (time lsl 1) land 0x3e; Unix.tm_min = (time lsr 5) land 0x3f; Unix.tm_hour = (time lsr 11) land 0x1f; Unix.tm_mday = date land 0x1f; Unix.tm_mon = ((date lsr 5) land 0xf) - 1; Unix.tm_year = ((date lsr 9) land 0x7f) + 80; Unix.tm_wday = 0; Unix.tm_yday = 0; Unix.tm_isdst = false }) let dostime_of_unixtime t = let tm = Unix.localtime t in (tm.Unix.tm_sec lsr 1 + (tm.Unix.tm_min lsl 5) + (tm.Unix.tm_hour lsl 11), tm.Unix.tm_mday + (tm.Unix.tm_mon + 1) lsl 5 + (tm.Unix.tm_year - 80) lsl 9) (* Read end of central directory record *) let read_ecd filename ic = let buf = String.create 256 in let filelen = in_channel_length ic in let rec find_ecd pos len = (* On input, bytes 0 ... len - 1 of buf reflect what is at pos in ic *) if pos <= 0 || filelen - pos >= 0x10000 then raise (Error(filename, "", "end of central directory not found, not a ZIP file")); let toread = min pos 128 in (* Make room for "toread" extra bytes, and read them *) String.blit buf 0 buf toread (256 - toread); let newpos = pos - toread in seek_in ic newpos; really_input ic buf 0 toread; let newlen = min (toread + len) 256 in (* Search for magic number *) let ofs = strrstr "PK\005\006" buf 0 newlen in if ofs < 0 || newlen < 22 || (let comment_len = Char.code buf.[ofs + 20] lor (Char.code buf.[ofs + 21] lsl 8) in newpos + ofs + 22 + comment_len <> filelen) then find_ecd newpos newlen else newpos + ofs in seek_in ic (find_ecd filelen 0); let magic = read4 ic in let disk_no = read2 ic in let cd_disk_no = read2 ic in let _disk_entries = read2 ic in let cd_entries = read2 ic in let cd_size = read4 ic in let cd_offset = read4 ic in let comment_len = read2 ic in let comment = readstring ic comment_len in assert (magic = Int32.of_int 0x06054b50); if disk_no <> 0 || cd_disk_no <> 0 then raise (Error(filename, "", "multi-disk ZIP files not supported")); (cd_entries, cd_size, cd_offset, comment) (* Read central directory *) let read_cd filename ic cd_entries cd_offset cd_bound = let cd_bound = Int64.of_int32 cd_bound in try LargeFile.seek_in ic (Int64.of_int32 cd_offset); let e = ref [] in let entrycnt = ref 0 in while (LargeFile.pos_in ic < cd_bound) do incr entrycnt; let magic = read4 ic in let _version_made_by = read2 ic in let _version_needed = read2 ic in let flags = read2 ic in let methd = read2 ic in let lastmod_time = read2 ic in let lastmod_date = read2 ic in let crc = read4 ic in let compr_size = read4_int ic in let uncompr_size = read4_int ic in let name_len = read2 ic in let extra_len = read2 ic in let comment_len = read2 ic in let _disk_number = read2 ic in let _internal_attr = read2 ic in let _external_attr = read4 ic in let header_offset = Int64.of_int32(read4 ic) in let name = readstring ic name_len in let extra = readstring ic extra_len in let comment = readstring ic comment_len in if magic <> Int32.of_int 0x02014b50 then raise (Error(filename, name, "wrong file header in central directory")); if flags land 1 <> 0 then raise (Error(filename, name, "encrypted entries not supported")); e := { filename = name; extra = extra; comment = comment; methd = (match methd with 0 -> Stored | 8 -> Deflated | _ -> raise (Error(filename, name, "unknown compression method"))); mtime = unixtime_of_dostime lastmod_time lastmod_date; crc = crc; uncompressed_size = uncompr_size; compressed_size = compr_size; is_directory = filename_is_directory name; file_offset = header_offset } :: !e done; assert((cd_bound = (LargeFile.pos_in ic)) && (cd_entries = 65535 || !entrycnt = cd_entries)); List.rev !e with End_of_file -> raise (Error(filename, "", "end-of-file while reading central directory")) (* Open a ZIP file for reading *) let open_in filename = let ic = Pervasives.open_in_bin filename in let (cd_entries, cd_size, cd_offset, cd_comment) = read_ecd filename ic in let entries = read_cd filename ic cd_entries cd_offset (Int32.add cd_offset cd_size) in let dir = Hashtbl.create (cd_entries / 3) in List.iter (fun e -> Hashtbl.add dir e.filename e) entries; { if_filename = filename; if_channel = ic; if_entries = entries; if_directory = dir; if_comment = cd_comment } (* Close a ZIP file opened for reading *) let close_in ifile = Pervasives.close_in ifile.if_channel (* Return the info associated with an entry *) let find_entry ifile name = Hashtbl.find ifile.if_directory name (* Position on an entry *) let goto_entry ifile e = try let ic = ifile.if_channel in LargeFile.seek_in ic e.file_offset; let magic = read4 ic in let _version_needed = read2 ic in let _flags = read2 ic in let _methd = read2 ic in let _lastmod_time = read2 ic in let _lastmod_date = read2 ic in let _crc = read4 ic in let _compr_size = read4_int ic in let _uncompr_size = read4_int ic in let filename_len = read2 ic in let extra_len = read2 ic in if magic <> Int32.of_int 0x04034b50 then raise (Error(ifile.if_filename, e.filename, "wrong local file header")); (* Could validate information read against directory entry, but what the heck *) LargeFile.seek_in ifile.if_channel (Int64.add e.file_offset (Int64.of_int (30 + filename_len + extra_len))) with End_of_file -> raise (Error(ifile.if_filename, e.filename, "truncated local file header")) (* Read the contents of an entry as a string *) let read_entry ifile e = try goto_entry ifile e; let res = String.create e.uncompressed_size in match e.methd with Stored -> if e.compressed_size <> e.uncompressed_size then raise (Error(ifile.if_filename, e.filename, "wrong size for stored entry")); really_input ifile.if_channel res 0 e.uncompressed_size; res | Deflated -> let in_avail = ref e.compressed_size in let out_pos = ref 0 in begin try Zlib.uncompress ~header:false (fun buf -> let read = input ifile.if_channel buf 0 (min !in_avail (String.length buf)) in in_avail := !in_avail - read; read) (fun buf len -> if !out_pos + len > String.length res then raise (Error(ifile.if_filename, e.filename, "wrong size for deflated entry (too much data)")); String.blit buf 0 res !out_pos len; out_pos := !out_pos + len) with Failure(_) -> raise (Error(ifile.if_filename, e.filename, "decompression error")) end; if !out_pos <> String.length res then raise (Error(ifile.if_filename, e.filename, "wrong size for deflated entry (not enough data)")); let crc = Zlib.update_crc Int32.zero res 0 (String.length res) in if crc <> e.crc then raise (Error(ifile.if_filename, e.filename, "CRC mismatch")); res with End_of_file -> raise (Error(ifile.if_filename, e.filename, "truncated data")) (* Write the contents of an entry into an out channel *) let copy_entry_to_channel ifile e oc = try goto_entry ifile e; match e.methd with Stored -> if e.compressed_size <> e.uncompressed_size then raise (Error(ifile.if_filename, e.filename, "wrong size for stored entry")); let buf = String.create 4096 in let rec copy n = if n > 0 then begin let r = input ifile.if_channel buf 0 (min n (String.length buf)) in output oc buf 0 r; copy (n - r) end in copy e.uncompressed_size | Deflated -> let in_avail = ref e.compressed_size in let crc = ref Int32.zero in begin try Zlib.uncompress ~header:false (fun buf -> let read = input ifile.if_channel buf 0 (min !in_avail (String.length buf)) in in_avail := !in_avail - read; read) (fun buf len -> output oc buf 0 len; crc := Zlib.update_crc !crc buf 0 len) with Failure _ -> raise (Error(ifile.if_filename, e.filename, "decompression error")) end; if !crc <> e.crc then raise (Error(ifile.if_filename, e.filename, "CRC mismatch")) with End_of_file -> raise (Error(ifile.if_filename, e.filename, "truncated data")) (* Write the contents of an entry to a file *) let copy_entry_to_file ifile e outfilename = let oc = open_out_bin outfilename in try copy_entry_to_channel ifile e oc; close_out oc; begin try Unix.utimes outfilename e.mtime e.mtime with Unix.Unix_error(_, _, _) | Invalid_argument _ -> () end with x -> close_out oc; Sys.remove outfilename; raise x (* Open a ZIP file for writing *) let open_out ?(comment = "") filename = if String.length comment >= 0x10000 then raise(Error(filename, "", "comment too long")); { of_filename = filename; of_channel = Pervasives.open_out_bin filename; of_entries = []; of_comment = comment } (* Close a ZIP file for writing. Add central directory. *) let write_directory_entry oc e = write4 oc (Int32.of_int 0x02014b50); (* signature *) let version = match e.methd with Stored -> 10 | Deflated -> 20 in write2 oc version; (* version made by *) write2 oc version; (* version needed to extract *) write2 oc 8; (* flags *) write2 oc (match e.methd with Stored -> 0 | Deflated -> 8); (* method *) let (time, date) = dostime_of_unixtime e.mtime in write2 oc time; (* last mod time *) write2 oc date; (* last mod date *) write4 oc e.crc; (* CRC32 *) write4_int oc e.compressed_size; (* compressed size *) write4_int oc e.uncompressed_size; (* uncompressed size *) write2 oc (String.length e.filename); (* filename length *) write2 oc (String.length e.extra); (* extra length *) write2 oc (String.length e.comment); (* comment length *) write2 oc 0; (* disk number start *) write2 oc 0; (* internal attributes *) write4_int oc 0; (* external attributes *) write4 oc (Int64.to_int32 e.file_offset); (* offset of local header *) writestring oc e.filename; (* filename *) writestring oc e.extra; (* extra info *) writestring oc e.comment (* file comment *) let close_out ofile = let oc = ofile.of_channel in let start_cd = pos_out oc in List.iter (write_directory_entry oc) (List.rev ofile.of_entries); let cd_size = pos_out oc - start_cd in let num_entries = List.length ofile.of_entries in if num_entries >= 0x10000 then raise(Error(ofile.of_filename, "", "too many entries")); write4 oc (Int32.of_int 0x06054b50); (* signature *) write2 oc 0; (* disk number *) write2 oc 0; (* number of disk with central dir *) write2 oc num_entries; (* # entries in this disk *) write2 oc num_entries; (* # entries in central dir *) write4_int oc cd_size; (* size of central dir *) write4_int oc start_cd; (* offset of central dir *) write2 oc (String.length ofile.of_comment); (* length of comment *) writestring oc ofile.of_comment; (* comment *) Pervasives.close_out oc (* Write a local file header and return the corresponding entry *) let add_entry_header ofile extra comment level mtime filename = if level < 0 || level > 9 then raise(Error(ofile.of_filename, filename, "wrong compression level")); if String.length filename >= 0x10000 then raise(Error(ofile.of_filename, filename, "filename too long")); if String.length extra >= 0x10000 then raise(Error(ofile.of_filename, filename, "extra data too long")); if String.length comment >= 0x10000 then raise(Error(ofile.of_filename, filename, "comment too long")); let oc = ofile.of_channel in let pos = LargeFile.pos_out oc in write4 oc (Int32.of_int 0x04034b50); (* signature *) let version = if level = 0 then 10 else 20 in write2 oc version; (* version needed to extract *) write2 oc 8; (* flags *) write2 oc (if level = 0 then 0 else 8); (* method *) let (time, date) = dostime_of_unixtime mtime in write2 oc time; (* last mod time *) write2 oc date; (* last mod date *) write4 oc Int32.zero; (* CRC32 - to be filled later *) write4_int oc 0; (* compressed size - later *) write4_int oc 0; (* uncompressed size - later *) write2 oc (String.length filename); (* filename length *) write2 oc (String.length extra); (* extra length *) writestring oc filename; (* filename *) writestring oc extra; (* extra info *) { filename = filename; extra = extra; comment = comment; methd = (if level = 0 then Stored else Deflated); mtime = mtime; crc = Int32.zero; uncompressed_size = 0; compressed_size = 0; is_directory = filename_is_directory filename; file_offset = pos } (* Write a data descriptor and update the entry *) let add_data_descriptor ofile crc compr_size uncompr_size entry = let oc = ofile.of_channel in write4 oc (Int32.of_int 0x08074b50); (* signature *) write4 oc crc; (* CRC *) write4_int oc compr_size; (* compressed size *) write4_int oc uncompr_size; (* uncompressed size *) { entry with crc = crc; uncompressed_size = uncompr_size; compressed_size = compr_size } (* Add an entry with the contents of a string *) let add_entry data ofile ?(extra = "") ?(comment = "") ?(level = 6) ?(mtime = Unix.time()) name = let e = add_entry_header ofile extra comment level mtime name in let crc = Zlib.update_crc Int32.zero data 0 (String.length data) in let compr_size = match level with 0 -> output ofile.of_channel data 0 (String.length data); String.length data | _ -> let in_pos = ref 0 in let out_pos = ref 0 in try Zlib.compress ~level ~header:false (fun buf -> let n = min (String.length data - !in_pos) (String.length buf) in String.blit data !in_pos buf 0 n; in_pos := !in_pos + n; n) (fun buf n -> output ofile.of_channel buf 0 n; out_pos := !out_pos + n); !out_pos with Failure _ -> raise (Error(ofile.of_filename, name, "compression error")) in let e' = add_data_descriptor ofile crc compr_size (String.length data) e in ofile.of_entries <- e' :: ofile.of_entries (* Add an entry with the contents of an in channel *) let copy_channel_to_entry ic ofile ?(extra = "") ?(comment = "") ?(level = 6) ?(mtime = Unix.time()) name = let e = add_entry_header ofile extra comment level mtime name in let crc = ref Int32.zero in let (compr_size, uncompr_size) = match level with 0 -> let buf = String.create 4096 in let rec copy sz = let r = input ic buf 0 (String.length buf) in if r = 0 then sz else begin crc := Zlib.update_crc !crc buf 0 r; output ofile.of_channel buf 0 r; copy (sz + r) end in let size = copy 0 in (size, size) | _ -> let in_pos = ref 0 in let out_pos = ref 0 in try Zlib.compress ~level ~header:false (fun buf -> let r = input ic buf 0 (String.length buf) in crc := Zlib.update_crc !crc buf 0 r; in_pos := !in_pos + r; r) (fun buf n -> output ofile.of_channel buf 0 n; out_pos := !out_pos + n); (!out_pos, !in_pos) with Failure( _) -> raise (Error(ofile.of_filename, name, "compression error")) in let e' = add_data_descriptor ofile !crc compr_size uncompr_size e in ofile.of_entries <- e' :: ofile.of_entries (* Add an entry with the contents of a file *) let copy_file_to_entry infilename ofile ?(extra = "") ?(comment = "") ?(level = 6) ?mtime name = let ic = open_in_bin infilename in let mtime' = match mtime with Some t -> mtime | None -> try Some((Unix.stat infilename).Unix.st_mtime) with Unix.Unix_error(_,_,_) -> None in try copy_channel_to_entry ic ofile ~extra ~comment ~level ?mtime:mtime' name; Pervasives.close_in ic with x -> Pervasives.close_in ic; raise x (* Add an entry whose content will be produced by the caller *) let add_entry_generator ofile ?(extra = "") ?(comment = "") ?(level = 6) ?(mtime = Unix.time()) name = let e = add_entry_header ofile extra comment level mtime name in let crc = ref Int32.zero in let compr_size = ref 0 in let uncompr_size = ref 0 in let finished = ref false in let check () = if !finished then raise (Error(ofile.of_filename, name, "entry already finished")) in let finish () = finished := true; let e' = add_data_descriptor ofile !crc !compr_size !uncompr_size e in ofile.of_entries <- e' :: ofile.of_entries in match level with | 0 -> (fun buf pos len -> check (); output ofile.of_channel buf pos len; compr_size := !compr_size + len; uncompr_size := !uncompr_size + len ), (fun () -> check (); finish () ) | _ -> let (send, flush) = Zlib.compress_direct ~level ~header:false (fun buf n -> output ofile.of_channel buf 0 n; compr_size := !compr_size + n) in (fun buf pos len -> check (); try send buf pos len; uncompr_size := !uncompr_size + len; crc := Zlib.update_crc !crc buf pos len with Failure(_) -> raise (Error(ofile.of_filename, name, "compression error")) ), (fun () -> check (); try flush (); finish () with Failure(_) -> raise (Error(ofile.of_filename, name, "compression error")) ) haxe-3.0~svn6707/libs/ziplib/test/0000755000175000017500000000000012172015140017376 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/ziplib/test/Makefile0000644000175000017500000000036412172015140021041 0ustar bdefreesebdefreeseall: ../zip.cmxa minizip.ml ocamlopt -g -g -I .. -I ../../extc -o minizip -cclib ../../extc/extc_stubs.o -cclib -lz unix.cmxa ../zip.cmxa minizip.ml clean: rm -rf minizip $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi) haxe-3.0~svn6707/libs/ziplib/test/minizip.ml0000644000175000017500000000637712172015140021424 0ustar bdefreesebdefreese(***********************************************************************) (* *) (* The CamlZip library *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file LICENSE. *) (* *) (***********************************************************************) (* $Id: minizip.ml,v 1.2 2006/04/04 08:29:07 xleroy Exp $ *) open Printf let list_entry e = let t = Unix.localtime e.Zip.mtime in printf "%6d %6d %c %04d-%02d-%02d %02d:%02d %c %s\n" e.Zip.uncompressed_size e.Zip.compressed_size (match e.Zip.methd with Zip.Stored -> 's' | Zip.Deflated -> 'd') (t.Unix.tm_year + 1900) (t.Unix.tm_mon + 1) t.Unix.tm_mday t.Unix.tm_hour t.Unix.tm_min (if e.Zip.is_directory then 'd' else ' ') e.Zip.filename; if e.Zip.comment <> "" then printf " %s\n" e.Zip.comment let list zipfile = let ic = Zip.open_in zipfile in if Zip.comment ic <> "" then printf "%s\n" (Zip.comment ic); List.iter list_entry (Zip.entries ic); Zip.close_in ic let extract_entry ifile e = print_string e.Zip.filename; print_newline(); if e.Zip.is_directory then begin try Unix.mkdir e.Zip.filename 0o777 with Unix.Unix_error(Unix.EEXIST, _, _) -> () end else begin Zip.copy_entry_to_file ifile e e.Zip.filename end let extract zipfile = let ic = Zip.open_in zipfile in List.iter (extract_entry ic) (Zip.entries ic); Zip.close_in ic let rec add_entry oc file = let s = Unix.stat file in match s.Unix.st_kind with Unix.S_REG -> printf "Adding file %s\n" file; flush stdout; Zip.copy_file_to_entry file oc ~mtime:s.Unix.st_mtime file | Unix.S_DIR -> printf "Adding directory %s\n" file; flush stdout; Zip.add_entry "" oc ~mtime:s.Unix.st_mtime (if Filename.check_suffix file "/" then file else file ^ "/"); let d = Unix.opendir file in begin try while true do let e = Unix.readdir d in if e <> "." && e <> ".." then add_entry oc (Filename.concat file e) done with End_of_file -> () end; Unix.closedir d | _ -> () let create zipfile files = let oc = Zip.open_out zipfile in Array.iter (add_entry oc) files; Zip.close_out oc let usage() = prerr_string "Usage: minizip t show contents of minizip x extract files from minizip c .. create a with the given files"; exit 2 let _ = if Array.length Sys.argv < 3 then usage(); match Sys.argv.(1) with "t" -> list Sys.argv.(2) | "x" -> extract Sys.argv.(2) | "c" -> create Sys.argv.(2) (Array.sub Sys.argv 3 (Array.length Sys.argv - 3)) | _ -> usage() haxe-3.0~svn6707/libs/ziplib/zlib.mli0000644000175000017500000000257312172015140020071 0ustar bdefreesebdefreese(***********************************************************************) (* *) (* The CamlZip library *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* adapted to Extc lib by Caue Waneck *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License, with *) (* the special exception on linking described in file LICENSE. *) (* *) (***********************************************************************) (* $Id: zlib.mli,v 1.2 2008/12/07 09:23:08 xleroy Exp $ *) val compress: ?level: int -> ?header: bool -> (string -> int) -> (string -> int -> unit) -> unit val compress_direct: ?level: int -> ?header: bool -> (string -> int -> unit) -> (string -> int -> int -> unit) * (unit -> unit) val uncompress: ?header: bool -> (string -> int) -> (string -> int -> unit) -> unit val update_crc: int32 -> string -> int -> int -> int32haxe-3.0~svn6707/libs/extc/0000755000175000017500000000000012172015137016077 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/extc/Makefile0000644000175000017500000000062112172015137017536 0ustar bdefreesebdefreeseCFLAGS = -I zlib LIBS = -I ../extlib all: bytecode native bytecode: extc_stubs.obj ocamlc -a -o extc.cma $(LIBS) extc.ml native: extc_stubs.obj ocamlopt -a -o extc.cmxa $(LIBS) extc.ml extc_stubs.obj: extc_stubs.c ocamlc $(CFLAGS) extc_stubs.c clean: rm -f extc.cma extc.cmi extc.cmx extc.cmxa extc.o extc.obj extc.lib extc_stubs.obj extc_stubs.o rm -f extc.a libextc.a libextc.lib extc.cmo haxe-3.0~svn6707/libs/extc/test.ml0000644000175000017500000000173312172015137017414 0ustar bdefreesebdefreese(* * Extc : C common OCaml bindings * Copyright (c)2004 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) prerr_endline (Extc.executable_path()); let contents = Std.input_file "test.ml" in let s = Extc.unzip (Extc.zip contents) in if s <> contents then failwith "zip + unzip failed"; haxe-3.0~svn6707/libs/extc/extc.ml0000644000175000017500000001475412172015137017407 0ustar bdefreesebdefreese(* * Extc : C common OCaml bindings * Copyright (c)2004 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type zstream type zflush = | Z_NO_FLUSH | Z_PARTIAL_FLUSH | Z_SYNC_FLUSH | Z_FULL_FLUSH | Z_FINISH type zresult = { z_finish : bool; z_read : int; z_wrote : int; } external zlib_deflate_init2 : int -> int -> zstream = "zlib_deflate_init2" external zlib_deflate : zstream -> src:string -> spos:int -> slen:int -> dst:string -> dpos:int -> dlen:int -> zflush -> zresult = "zlib_deflate_bytecode" "zlib_deflate" external zlib_deflate_end : zstream -> unit = "zlib_deflate_end" external zlib_inflate_init2 : int -> zstream = "zlib_inflate_init" external zlib_inflate : zstream -> src:string -> spos:int -> slen:int -> dst:string -> dpos:int -> dlen:int -> zflush -> zresult = "zlib_inflate_bytecode" "zlib_inflate" external zlib_inflate_end : zstream -> unit = "zlib_inflate_end" external _executable_path : string -> string = "executable_path" external get_full_path : string -> string = "get_full_path" external get_real_path : string -> string = "get_real_path" external zlib_deflate_bound : zstream -> int -> int = "zlib_deflate_bound" external time : unit -> float = "sys_time" type library type sym type value external dlopen : string -> library = "sys_dlopen" external dlsym : library -> string -> sym = "sys_dlsym" external dlcall0 : sym -> value = "sys_dlcall0" external dlcall1 : sym -> value -> value = "sys_dlcall1" external dlcall2 : sym -> value -> value -> value = "sys_dlcall2" external dlcall3 : sym -> value -> value -> value -> value = "sys_dlcall3" external dlcall4 : sym -> value -> value -> value -> value -> value = "sys_dlcall4" external dlcall5 : sym -> value -> value -> value -> value -> value -> value = "sys_dlcall5_bc" "sys_dlcall5" external dlint : int -> value = "sys_dlint" external dltoint : value -> int = "sys_dltoint" external dlstring : string -> value = "%identity" external dladdr : value -> int -> value = "sys_dladdr" external dlptr : value -> value = "sys_dlptr" external dlsetptr : value -> value -> unit = "sys_dlsetptr" external dlalloc_string : value -> string = "sys_dlalloc_string" external dlmemcpy : value -> value -> int -> unit = "sys_dlmemcpy" external dlcallback : int -> value = "sys_dlcallback" external dlcaml_callback : int -> value = "sys_dlcaml_callback" external dlint32 : int32 -> value = "sys_dlint32" external getch : bool -> int = "sys_getch" (* support for backward compatibility *) let zlib_deflate_init lvl = zlib_deflate_init2 lvl 15 let zlib_inflate_init() = zlib_inflate_init2 15 let executable_path() = let p = _executable_path Sys.argv.(0) in let p1 = (try String.rindex p '/' with Not_found -> String.length p + 1) in let p2 = (try String.rindex p '\\' with Not_found -> String.length p + 1) in match min p1 p2 with | x when x = String.length p + 1 -> "" | pos -> String.sub p 0 pos ^ "/" let zlib_op op z str = let bufsize = 1 lsl 14 in let tmp = String.create bufsize in let total = ref 0 in let rec loop pos len acc = let r = op z ~src:str ~spos:pos ~slen:len ~dst:tmp ~dpos:0 ~dlen:bufsize (if len = 0 then Z_FINISH else Z_SYNC_FLUSH) in total := !total + r.z_wrote; let acc = String.sub tmp 0 r.z_wrote :: acc in if r.z_finish then acc else loop (pos + r.z_read) (len - r.z_read) acc in let strings = loop 0 (String.length str) [] in let big = String.create !total in ignore(List.fold_left (fun p s -> let l = String.length s in let p = p - l in String.unsafe_blit s 0 big p l; p ) !total strings); big let zip str = let z = zlib_deflate_init 9 in let s = zlib_op zlib_deflate z str in zlib_deflate_end z; s let unzip str = let z = zlib_inflate_init() in let s = zlib_op zlib_inflate z str in zlib_inflate_end z; s let input_zip ?(bufsize=65536) ch = let tmp_out = String.create bufsize in let tmp_in = String.create bufsize in let tmp_buf = Buffer.create bufsize in let buf = ref "" in let p = ref 0 in let z = zlib_inflate_init() in let rec fill_buffer() = let rec loop pos len = if len > 0 || pos = 0 then begin let r = zlib_inflate z tmp_in pos len tmp_out 0 bufsize (if pos = 0 && len = 0 then Z_FINISH else Z_SYNC_FLUSH) in Buffer.add_substring tmp_buf tmp_out 0 r.z_wrote; loop (pos + r.z_read) (len - r.z_read); end in loop 0 (IO.input ch tmp_in 0 bufsize); p := 0; buf := Buffer.contents tmp_buf; Buffer.clear tmp_buf; in let read() = if !p = String.length !buf then fill_buffer(); let c = String.unsafe_get !buf !p in incr p; c in let rec input str pos len = let b = String.length !buf - !p in if b >= len then begin String.blit !buf !p str pos len; p := !p + len; len; end else begin String.blit !buf !p str pos b; fill_buffer(); if !p = String.length !buf then b else b + input str (pos + b) (len - b) end; in let close() = zlib_inflate_end z in IO.create_in ~read ~input ~close let output_zip ?(bufsize=65536) ?(level=9) ch = let z = zlib_deflate_init level in let out = String.create bufsize in let tmp_out = String.create bufsize in let p = ref 0 in let rec flush finish = let r = zlib_deflate z out 0 !p tmp_out 0 bufsize (if finish then Z_FINISH else Z_SYNC_FLUSH) in ignore(IO.really_output ch tmp_out 0 r.z_wrote); let remain = !p - r.z_read in String.blit out r.z_read out 0 remain; p := remain; if finish && not r.z_finish then flush true in let write c = if !p = bufsize then flush false; String.unsafe_set out !p c; incr p in let rec output str pos len = let b = bufsize - !p in if len <= b then begin String.blit str pos out !p len; p := !p + len; len end else begin String.blit str pos out !p b; p := !p + b; flush false; b + output str (pos + b) (len - b); end; in let close() = flush true; zlib_deflate_end z in IO.create_out ~write ~output ~flush:(fun() -> flush false; IO.flush ch) ~close haxe-3.0~svn6707/libs/extc/zlib/0000755000175000017500000000000012172015137017037 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/extc/zlib/README.txt0000644000175000017500000000002312172015137020530 0ustar bdefreesebdefreese1.2.3 static LIBCMThaxe-3.0~svn6707/libs/extc/zlib/zconf.h0000644000175000017500000002257212172015137020337 0ustar bdefreesebdefreese/* zconf.h -- configuration of the zlib compression library * Copyright (C) 1995-2005 Jean-loup Gailly. * For conditions of distribution and use, see copyright notice in zlib.h */ /* @(#) $Id: zconf.h,v 1.1 2007-02-15 14:41:38 ncannasse Exp $ */ #ifndef ZCONF_H #define ZCONF_H /* * If you *really* need a unique prefix for all types and library functions, * compile with -DZ_PREFIX. The "standard" zlib should be compiled without it. */ #ifdef Z_PREFIX # define deflateInit_ z_deflateInit_ # define deflate z_deflate # define deflateEnd z_deflateEnd # define inflateInit_ z_inflateInit_ # define inflate z_inflate # define inflateEnd z_inflateEnd # define deflateInit2_ z_deflateInit2_ # define deflateSetDictionary z_deflateSetDictionary # define deflateCopy z_deflateCopy # define deflateReset z_deflateReset # define deflateParams z_deflateParams # define deflateBound z_deflateBound # define deflatePrime z_deflatePrime # define inflateInit2_ z_inflateInit2_ # define inflateSetDictionary z_inflateSetDictionary # define inflateSync z_inflateSync # define inflateSyncPoint z_inflateSyncPoint # define inflateCopy z_inflateCopy # define inflateReset z_inflateReset # define inflateBack z_inflateBack # define inflateBackEnd z_inflateBackEnd # define compress z_compress # define compress2 z_compress2 # define compressBound z_compressBound # define uncompress z_uncompress # define adler32 z_adler32 # define crc32 z_crc32 # define get_crc_table z_get_crc_table # define zError z_zError # define alloc_func z_alloc_func # define free_func z_free_func # define in_func z_in_func # define out_func z_out_func # define Byte z_Byte # define uInt z_uInt # define uLong z_uLong # define Bytef z_Bytef # define charf z_charf # define intf z_intf # define uIntf z_uIntf # define uLongf z_uLongf # define voidpf z_voidpf # define voidp z_voidp #endif #if defined(__MSDOS__) && !defined(MSDOS) # define MSDOS #endif #if (defined(OS_2) || defined(__OS2__)) && !defined(OS2) # define OS2 #endif #if defined(_WINDOWS) && !defined(WINDOWS) # define WINDOWS #endif #if defined(_WIN32) || defined(_WIN32_WCE) || defined(__WIN32__) # ifndef WIN32 # define WIN32 # endif #endif #if (defined(MSDOS) || defined(OS2) || defined(WINDOWS)) && !defined(WIN32) # if !defined(__GNUC__) && !defined(__FLAT__) && !defined(__386__) # ifndef SYS16BIT # define SYS16BIT # endif # endif #endif /* * Compile with -DMAXSEG_64K if the alloc function cannot allocate more * than 64k bytes at a time (needed on systems with 16-bit int). */ #ifdef SYS16BIT # define MAXSEG_64K #endif #ifdef MSDOS # define UNALIGNED_OK #endif #ifdef __STDC_VERSION__ # ifndef STDC # define STDC # endif # if __STDC_VERSION__ >= 199901L # ifndef STDC99 # define STDC99 # endif # endif #endif #if !defined(STDC) && (defined(__STDC__) || defined(__cplusplus)) # define STDC #endif #if !defined(STDC) && (defined(__GNUC__) || defined(__BORLANDC__)) # define STDC #endif #if !defined(STDC) && (defined(MSDOS) || defined(WINDOWS) || defined(WIN32)) # define STDC #endif #if !defined(STDC) && (defined(OS2) || defined(__HOS_AIX__)) # define STDC #endif #if defined(__OS400__) && !defined(STDC) /* iSeries (formerly AS/400). */ # define STDC #endif #ifndef STDC # ifndef const /* cannot use !defined(STDC) && !defined(const) on Mac */ # define const /* note: need a more gentle solution here */ # endif #endif /* Some Mac compilers merge all .h files incorrectly: */ #if defined(__MWERKS__)||defined(applec)||defined(THINK_C)||defined(__SC__) # define NO_DUMMY_DECL #endif /* Maximum value for memLevel in deflateInit2 */ #ifndef MAX_MEM_LEVEL # ifdef MAXSEG_64K # define MAX_MEM_LEVEL 8 # else # define MAX_MEM_LEVEL 9 # endif #endif /* Maximum value for windowBits in deflateInit2 and inflateInit2. * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files * created by gzip. (Files created by minigzip can still be extracted by * gzip.) */ #ifndef MAX_WBITS # define MAX_WBITS 15 /* 32K LZ77 window */ #endif /* The memory requirements for deflate are (in bytes): (1 << (windowBits+2)) + (1 << (memLevel+9)) that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) plus a few kilobytes for small objects. For example, if you want to reduce the default memory requirements from 256K to 128K, compile with make CFLAGS="-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7" Of course this will generally degrade compression (there's no free lunch). The memory requirements for inflate are (in bytes) 1 << windowBits that is, 32K for windowBits=15 (default value) plus a few kilobytes for small objects. */ /* Type declarations */ #ifndef OF /* function prototypes */ # ifdef STDC # define OF(args) args # else # define OF(args) () # endif #endif /* The following definitions for FAR are needed only for MSDOS mixed * model programming (small or medium model with some far allocations). * This was tested only with MSC; for other MSDOS compilers you may have * to define NO_MEMCPY in zutil.h. If you don't need the mixed model, * just define FAR to be empty. */ #ifdef SYS16BIT # if defined(M_I86SM) || defined(M_I86MM) /* MSC small or medium model */ # define SMALL_MEDIUM # ifdef _MSC_VER # define FAR _far # else # define FAR far # endif # endif # if (defined(__SMALL__) || defined(__MEDIUM__)) /* Turbo C small or medium model */ # define SMALL_MEDIUM # ifdef __BORLANDC__ # define FAR _far # else # define FAR far # endif # endif #endif #if defined(WINDOWS) || defined(WIN32) /* If building or using zlib as a DLL, define ZLIB_DLL. * This is not mandatory, but it offers a little performance increase. */ # ifdef ZLIB_DLL # if defined(WIN32) && (!defined(__BORLANDC__) || (__BORLANDC__ >= 0x500)) # ifdef ZLIB_INTERNAL # define ZEXTERN extern __declspec(dllexport) # else # define ZEXTERN extern __declspec(dllimport) # endif # endif # endif /* ZLIB_DLL */ /* If building or using zlib with the WINAPI/WINAPIV calling convention, * define ZLIB_WINAPI. * Caution: the standard ZLIB1.DLL is NOT compiled using ZLIB_WINAPI. */ # ifdef ZLIB_WINAPI # ifdef FAR # undef FAR # endif # include /* No need for _export, use ZLIB.DEF instead. */ /* For complete Windows compatibility, use WINAPI, not __stdcall. */ # define ZEXPORT WINAPI # ifdef WIN32 # define ZEXPORTVA WINAPIV # else # define ZEXPORTVA FAR CDECL # endif # endif #endif #if defined (__BEOS__) # ifdef ZLIB_DLL # ifdef ZLIB_INTERNAL # define ZEXPORT __declspec(dllexport) # define ZEXPORTVA __declspec(dllexport) # else # define ZEXPORT __declspec(dllimport) # define ZEXPORTVA __declspec(dllimport) # endif # endif #endif #ifndef ZEXTERN # define ZEXTERN extern #endif #ifndef ZEXPORT # define ZEXPORT #endif #ifndef ZEXPORTVA # define ZEXPORTVA #endif #ifndef FAR # define FAR #endif #if !defined(__MACTYPES__) typedef unsigned char Byte; /* 8 bits */ #endif typedef unsigned int uInt; /* 16 bits or more */ typedef unsigned long uLong; /* 32 bits or more */ #ifdef SMALL_MEDIUM /* Borland C/C++ and some old MSC versions ignore FAR inside typedef */ # define Bytef Byte FAR #else typedef Byte FAR Bytef; #endif typedef char FAR charf; typedef int FAR intf; typedef uInt FAR uIntf; typedef uLong FAR uLongf; #ifdef STDC typedef void const *voidpc; typedef void FAR *voidpf; typedef void *voidp; #else typedef Byte const *voidpc; typedef Byte FAR *voidpf; typedef Byte *voidp; #endif #if 0 /* HAVE_UNISTD_H -- this line is updated by ./configure */ # include /* for off_t */ # include /* for SEEK_* and off_t */ # ifdef VMS # include /* for off_t */ # endif # define z_off_t off_t #endif #ifndef SEEK_SET # define SEEK_SET 0 /* Seek from beginning of file. */ # define SEEK_CUR 1 /* Seek from current position. */ # define SEEK_END 2 /* Set file pointer to EOF plus "offset" */ #endif #ifndef z_off_t # define z_off_t long #endif #if defined(__OS400__) # define NO_vsnprintf #endif #if defined(__MVS__) # define NO_vsnprintf # ifdef FAR # undef FAR # endif #endif /* MVS linker does not support external names larger than 8 bytes */ #if defined(__MVS__) # pragma map(deflateInit_,"DEIN") # pragma map(deflateInit2_,"DEIN2") # pragma map(deflateEnd,"DEEND") # pragma map(deflateBound,"DEBND") # pragma map(inflateInit_,"ININ") # pragma map(inflateInit2_,"ININ2") # pragma map(inflateEnd,"INEND") # pragma map(inflateSync,"INSY") # pragma map(inflateSetDictionary,"INSEDI") # pragma map(compressBound,"CMBND") # pragma map(inflate_table,"INTABL") # pragma map(inflate_fast,"INFA") # pragma map(inflate_copyright,"INCOPY") #endif #endif /* ZCONF_H */ haxe-3.0~svn6707/libs/extc/zlib/zlib.h0000644000175000017500000020121412172015137020150 0ustar bdefreesebdefreese/* zlib.h -- interface of the 'zlib' general purpose compression library version 1.2.3, July 18th, 2005 Copyright (C) 1995-2005 Jean-loup Gailly and Mark Adler This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. Jean-loup Gailly Mark Adler jloup@gzip.org madler@alumni.caltech.edu The data format used by the zlib library is described by RFCs (Request for Comments) 1950 to 1952 in the files http://www.ietf.org/rfc/rfc1950.txt (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). */ #ifndef ZLIB_H #define ZLIB_H #include "zconf.h" #ifdef __cplusplus extern "C" { #endif #define ZLIB_VERSION "1.2.3" #define ZLIB_VERNUM 0x1230 /* The 'zlib' compression library provides in-memory compression and decompression functions, including integrity checks of the uncompressed data. This version of the library supports only one compression method (deflation) but other algorithms will be added later and will have the same stream interface. Compression can be done in a single step if the buffers are large enough (for example if an input file is mmap'ed), or can be done by repeated calls of the compression function. In the latter case, the application must provide more input and/or consume the output (providing more output space) before each call. The compressed data format used by default by the in-memory functions is the zlib format, which is a zlib wrapper documented in RFC 1950, wrapped around a deflate stream, which is itself documented in RFC 1951. The library also supports reading and writing files in gzip (.gz) format with an interface similar to that of stdio using the functions that start with "gz". The gzip format is different from the zlib format. gzip is a gzip wrapper, documented in RFC 1952, wrapped around a deflate stream. This library can optionally read and write gzip streams in memory as well. The zlib format was designed to be compact and fast for use in memory and on communications channels. The gzip format was designed for single- file compression on file systems, has a larger header than zlib to maintain directory information, and uses a different, slower check method than zlib. The library does not install any signal handler. The decoder checks the consistency of the compressed data, so the library should never crash even in case of corrupted input. */ typedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size)); typedef void (*free_func) OF((voidpf opaque, voidpf address)); struct internal_state; typedef struct z_stream_s { Bytef *next_in; /* next input byte */ uInt avail_in; /* number of bytes available at next_in */ uLong total_in; /* total nb of input bytes read so far */ Bytef *next_out; /* next output byte should be put there */ uInt avail_out; /* remaining free space at next_out */ uLong total_out; /* total nb of bytes output so far */ char *msg; /* last error message, NULL if no error */ struct internal_state FAR *state; /* not visible by applications */ alloc_func zalloc; /* used to allocate the internal state */ free_func zfree; /* used to free the internal state */ voidpf opaque; /* private data object passed to zalloc and zfree */ int data_type; /* best guess about the data type: binary or text */ uLong adler; /* adler32 value of the uncompressed data */ uLong reserved; /* reserved for future use */ } z_stream; typedef z_stream FAR *z_streamp; /* gzip header information passed to and from zlib routines. See RFC 1952 for more details on the meanings of these fields. */ typedef struct gz_header_s { int text; /* true if compressed data believed to be text */ uLong time; /* modification time */ int xflags; /* extra flags (not used when writing a gzip file) */ int os; /* operating system */ Bytef *extra; /* pointer to extra field or Z_NULL if none */ uInt extra_len; /* extra field length (valid if extra != Z_NULL) */ uInt extra_max; /* space at extra (only when reading header) */ Bytef *name; /* pointer to zero-terminated file name or Z_NULL */ uInt name_max; /* space at name (only when reading header) */ Bytef *comment; /* pointer to zero-terminated comment or Z_NULL */ uInt comm_max; /* space at comment (only when reading header) */ int hcrc; /* true if there was or will be a header crc */ int done; /* true when done reading gzip header (not used when writing a gzip file) */ } gz_header; typedef gz_header FAR *gz_headerp; /* The application must update next_in and avail_in when avail_in has dropped to zero. It must update next_out and avail_out when avail_out has dropped to zero. The application must initialize zalloc, zfree and opaque before calling the init function. All other fields are set by the compression library and must not be updated by the application. The opaque value provided by the application will be passed as the first parameter for calls of zalloc and zfree. This can be useful for custom memory management. The compression library attaches no meaning to the opaque value. zalloc must return Z_NULL if there is not enough memory for the object. If zlib is used in a multi-threaded application, zalloc and zfree must be thread safe. On 16-bit systems, the functions zalloc and zfree must be able to allocate exactly 65536 bytes, but will not be required to allocate more than this if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, pointers returned by zalloc for objects of exactly 65536 bytes *must* have their offset normalized to zero. The default allocation function provided by this library ensures this (see zutil.c). To reduce memory requirements and avoid any allocation of 64K objects, at the expense of compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h). The fields total_in and total_out can be used for statistics or progress reports. After compression, total_in holds the total size of the uncompressed data and may be saved for use in the decompressor (particularly if the decompressor wants to decompress everything in a single step). */ /* constants */ #define Z_NO_FLUSH 0 #define Z_PARTIAL_FLUSH 1 /* will be removed, use Z_SYNC_FLUSH instead */ #define Z_SYNC_FLUSH 2 #define Z_FULL_FLUSH 3 #define Z_FINISH 4 #define Z_BLOCK 5 /* Allowed flush values; see deflate() and inflate() below for details */ #define Z_OK 0 #define Z_STREAM_END 1 #define Z_NEED_DICT 2 #define Z_ERRNO (-1) #define Z_STREAM_ERROR (-2) #define Z_DATA_ERROR (-3) #define Z_MEM_ERROR (-4) #define Z_BUF_ERROR (-5) #define Z_VERSION_ERROR (-6) /* Return codes for the compression/decompression functions. Negative * values are errors, positive values are used for special but normal events. */ #define Z_NO_COMPRESSION 0 #define Z_BEST_SPEED 1 #define Z_BEST_COMPRESSION 9 #define Z_DEFAULT_COMPRESSION (-1) /* compression levels */ #define Z_FILTERED 1 #define Z_HUFFMAN_ONLY 2 #define Z_RLE 3 #define Z_FIXED 4 #define Z_DEFAULT_STRATEGY 0 /* compression strategy; see deflateInit2() below for details */ #define Z_BINARY 0 #define Z_TEXT 1 #define Z_ASCII Z_TEXT /* for compatibility with 1.2.2 and earlier */ #define Z_UNKNOWN 2 /* Possible values of the data_type field (though see inflate()) */ #define Z_DEFLATED 8 /* The deflate compression method (the only one supported in this version) */ #define Z_NULL 0 /* for initializing zalloc, zfree, opaque */ #define zlib_version zlibVersion() /* for compatibility with versions < 1.0.2 */ /* basic functions */ ZEXTERN const char * ZEXPORT zlibVersion OF((void)); /* The application can compare zlibVersion and ZLIB_VERSION for consistency. If the first character differs, the library code actually used is not compatible with the zlib.h header file used by the application. This check is automatically made by deflateInit and inflateInit. */ /* ZEXTERN int ZEXPORT deflateInit OF((z_streamp strm, int level)); Initializes the internal stream state for compression. The fields zalloc, zfree and opaque must be initialized before by the caller. If zalloc and zfree are set to Z_NULL, deflateInit updates them to use default allocation functions. The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9: 1 gives best speed, 9 gives best compression, 0 gives no compression at all (the input data is simply copied a block at a time). Z_DEFAULT_COMPRESSION requests a default compromise between speed and compression (currently equivalent to level 6). deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_STREAM_ERROR if level is not a valid compression level, Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible with the version assumed by the caller (ZLIB_VERSION). msg is set to null if there is no error message. deflateInit does not perform any compression: this will be done by deflate(). */ ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush)); /* deflate compresses as much data as possible, and stops when the input buffer becomes empty or the output buffer becomes full. It may introduce some output latency (reading input without producing any output) except when forced to flush. The detailed semantics are as follows. deflate performs one or both of the following actions: - Compress more input starting at next_in and update next_in and avail_in accordingly. If not all input can be processed (because there is not enough room in the output buffer), next_in and avail_in are updated and processing will resume at this point for the next call of deflate(). - Provide more output starting at next_out and update next_out and avail_out accordingly. This action is forced if the parameter flush is non zero. Forcing flush frequently degrades the compression ratio, so this parameter should be set only when necessary (in interactive applications). Some output may be provided even if flush is not set. Before the call of deflate(), the application should ensure that at least one of the actions is possible, by providing more input and/or consuming more output, and updating avail_in or avail_out accordingly; avail_out should never be zero before the call. The application can consume the compressed output when it wants, for example when the output buffer is full (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK and with zero avail_out, it must be called again after making room in the output buffer because there might be more output pending. Normally the parameter flush is set to Z_NO_FLUSH, which allows deflate to decide how much data to accumualte before producing output, in order to maximize compression. If the parameter flush is set to Z_SYNC_FLUSH, all pending output is flushed to the output buffer and the output is aligned on a byte boundary, so that the decompressor can get all input data available so far. (In particular avail_in is zero after the call if enough output space has been provided before the call.) Flushing may degrade compression for some compression algorithms and so it should be used only when necessary. If flush is set to Z_FULL_FLUSH, all output is flushed as with Z_SYNC_FLUSH, and the compression state is reset so that decompression can restart from this point if previous compressed data has been damaged or if random access is desired. Using Z_FULL_FLUSH too often can seriously degrade compression. If deflate returns with avail_out == 0, this function must be called again with the same value of the flush parameter and more output space (updated avail_out), until the flush is complete (deflate returns with non-zero avail_out). In the case of a Z_FULL_FLUSH or Z_SYNC_FLUSH, make sure that avail_out is greater than six to avoid repeated flush markers due to avail_out == 0 on return. If the parameter flush is set to Z_FINISH, pending input is processed, pending output is flushed and deflate returns with Z_STREAM_END if there was enough output space; if deflate returns with Z_OK, this function must be called again with Z_FINISH and more output space (updated avail_out) but no more input data, until it returns with Z_STREAM_END or an error. After deflate has returned Z_STREAM_END, the only possible operations on the stream are deflateReset or deflateEnd. Z_FINISH can be used immediately after deflateInit if all the compression is to be done in a single step. In this case, avail_out must be at least the value returned by deflateBound (see below). If deflate does not return Z_STREAM_END, then it must be called again as described above. deflate() sets strm->adler to the adler32 checksum of all input read so far (that is, total_in bytes). deflate() may update strm->data_type if it can make a good guess about the input data type (Z_BINARY or Z_TEXT). In doubt, the data is considered binary. This field is only for information purposes and does not affect the compression algorithm in any manner. deflate() returns Z_OK if some progress has been made (more input processed or more output produced), Z_STREAM_END if all input has been consumed and all output has been produced (only when flush is set to Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible (for example avail_in or avail_out was zero). Note that Z_BUF_ERROR is not fatal, and deflate() can be called again with more input and more output space to continue compressing. */ ZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm)); /* All dynamically allocated data structures for this stream are freed. This function discards any unprocessed input and does not flush any pending output. deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state was inconsistent, Z_DATA_ERROR if the stream was freed prematurely (some input or output was discarded). In the error case, msg may be set but then points to a static string (which must not be deallocated). */ /* ZEXTERN int ZEXPORT inflateInit OF((z_streamp strm)); Initializes the internal stream state for decompression. The fields next_in, avail_in, zalloc, zfree and opaque must be initialized before by the caller. If next_in is not Z_NULL and avail_in is large enough (the exact value depends on the compression method), inflateInit determines the compression method from the zlib header and allocates all data structures accordingly; otherwise the allocation will be deferred to the first call of inflate. If zalloc and zfree are set to Z_NULL, inflateInit updates them to use default allocation functions. inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_VERSION_ERROR if the zlib library version is incompatible with the version assumed by the caller. msg is set to null if there is no error message. inflateInit does not perform any decompression apart from reading the zlib header if present: this will be done by inflate(). (So next_in and avail_in may be modified, but next_out and avail_out are unchanged.) */ ZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush)); /* inflate decompresses as much data as possible, and stops when the input buffer becomes empty or the output buffer becomes full. It may introduce some output latency (reading input without producing any output) except when forced to flush. The detailed semantics are as follows. inflate performs one or both of the following actions: - Decompress more input starting at next_in and update next_in and avail_in accordingly. If not all input can be processed (because there is not enough room in the output buffer), next_in is updated and processing will resume at this point for the next call of inflate(). - Provide more output starting at next_out and update next_out and avail_out accordingly. inflate() provides as much output as possible, until there is no more input data or no more space in the output buffer (see below about the flush parameter). Before the call of inflate(), the application should ensure that at least one of the actions is possible, by providing more input and/or consuming more output, and updating the next_* and avail_* values accordingly. The application can consume the uncompressed output when it wants, for example when the output buffer is full (avail_out == 0), or after each call of inflate(). If inflate returns Z_OK and with zero avail_out, it must be called again after making room in the output buffer because there might be more output pending. The flush parameter of inflate() can be Z_NO_FLUSH, Z_SYNC_FLUSH, Z_FINISH, or Z_BLOCK. Z_SYNC_FLUSH requests that inflate() flush as much output as possible to the output buffer. Z_BLOCK requests that inflate() stop if and when it gets to the next deflate block boundary. When decoding the zlib or gzip format, this will cause inflate() to return immediately after the header and before the first block. When doing a raw inflate, inflate() will go ahead and process the first block, and will return when it gets to the end of that block, or when it runs out of data. The Z_BLOCK option assists in appending to or combining deflate streams. Also to assist in this, on return inflate() will set strm->data_type to the number of unused bits in the last byte taken from strm->next_in, plus 64 if inflate() is currently decoding the last block in the deflate stream, plus 128 if inflate() returned immediately after decoding an end-of-block code or decoding the complete header up to just before the first byte of the deflate stream. The end-of-block will not be indicated until all of the uncompressed data from that block has been written to strm->next_out. The number of unused bits may in general be greater than seven, except when bit 7 of data_type is set, in which case the number of unused bits will be less than eight. inflate() should normally be called until it returns Z_STREAM_END or an error. However if all decompression is to be performed in a single step (a single call of inflate), the parameter flush should be set to Z_FINISH. In this case all pending input is processed and all pending output is flushed; avail_out must be large enough to hold all the uncompressed data. (The size of the uncompressed data may have been saved by the compressor for this purpose.) The next operation on this stream must be inflateEnd to deallocate the decompression state. The use of Z_FINISH is never required, but can be used to inform inflate that a faster approach may be used for the single inflate() call. In this implementation, inflate() always flushes as much output as possible to the output buffer, and always uses the faster approach on the first call. So the only effect of the flush parameter in this implementation is on the return value of inflate(), as noted below, or when it returns early because Z_BLOCK is used. If a preset dictionary is needed after this call (see inflateSetDictionary below), inflate sets strm->adler to the adler32 checksum of the dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise it sets strm->adler to the adler32 checksum of all output produced so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or an error code as described below. At the end of the stream, inflate() checks that its computed adler32 checksum is equal to that saved by the compressor and returns Z_STREAM_END only if the checksum is correct. inflate() will decompress and check either zlib-wrapped or gzip-wrapped deflate data. The header type is detected automatically. Any information contained in the gzip header is not retained, so applications that need that information should instead use raw inflate, see inflateInit2() below, or inflateBack() and perform their own processing of the gzip header and trailer. inflate() returns Z_OK if some progress has been made (more input processed or more output produced), Z_STREAM_END if the end of the compressed data has been reached and all uncompressed output has been produced, Z_NEED_DICT if a preset dictionary is needed at this point, Z_DATA_ERROR if the input data was corrupted (input stream not conforming to the zlib format or incorrect check value), Z_STREAM_ERROR if the stream structure was inconsistent (for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not enough memory, Z_BUF_ERROR if no progress is possible or if there was not enough room in the output buffer when Z_FINISH is used. Note that Z_BUF_ERROR is not fatal, and inflate() can be called again with more input and more output space to continue decompressing. If Z_DATA_ERROR is returned, the application may then call inflateSync() to look for a good compression block if a partial recovery of the data is desired. */ ZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm)); /* All dynamically allocated data structures for this stream are freed. This function discards any unprocessed input and does not flush any pending output. inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state was inconsistent. In the error case, msg may be set but then points to a static string (which must not be deallocated). */ /* Advanced functions */ /* The following functions are needed only in some special applications. */ /* ZEXTERN int ZEXPORT deflateInit2 OF((z_streamp strm, int level, int method, int windowBits, int memLevel, int strategy)); This is another version of deflateInit with more compression options. The fields next_in, zalloc, zfree and opaque must be initialized before by the caller. The method parameter is the compression method. It must be Z_DEFLATED in this version of the library. The windowBits parameter is the base two logarithm of the window size (the size of the history buffer). It should be in the range 8..15 for this version of the library. Larger values of this parameter result in better compression at the expense of memory usage. The default value is 15 if deflateInit is used instead. windowBits can also be -8..-15 for raw deflate. In this case, -windowBits determines the window size. deflate() will then generate raw deflate data with no zlib header or trailer, and will not compute an adler32 check value. windowBits can also be greater than 15 for optional gzip encoding. Add 16 to windowBits to write a simple gzip header and trailer around the compressed data instead of a zlib wrapper. The gzip header will have no file name, no extra data, no comment, no modification time (set to zero), no header crc, and the operating system will be set to 255 (unknown). If a gzip stream is being written, strm->adler is a crc32 instead of an adler32. The memLevel parameter specifies how much memory should be allocated for the internal compression state. memLevel=1 uses minimum memory but is slow and reduces compression ratio; memLevel=9 uses maximum memory for optimal speed. The default value is 8. See zconf.h for total memory usage as a function of windowBits and memLevel. The strategy parameter is used to tune the compression algorithm. Use the value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a filter (or predictor), Z_HUFFMAN_ONLY to force Huffman encoding only (no string match), or Z_RLE to limit match distances to one (run-length encoding). Filtered data consists mostly of small values with a somewhat random distribution. In this case, the compression algorithm is tuned to compress them better. The effect of Z_FILTERED is to force more Huffman coding and less string matching; it is somewhat intermediate between Z_DEFAULT and Z_HUFFMAN_ONLY. Z_RLE is designed to be almost as fast as Z_HUFFMAN_ONLY, but give better compression for PNG image data. The strategy parameter only affects the compression ratio but not the correctness of the compressed output even if it is not set appropriately. Z_FIXED prevents the use of dynamic Huffman codes, allowing for a simpler decoder for special applications. deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_STREAM_ERROR if a parameter is invalid (such as an invalid method). msg is set to null if there is no error message. deflateInit2 does not perform any compression: this will be done by deflate(). */ ZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm, const Bytef *dictionary, uInt dictLength)); /* Initializes the compression dictionary from the given byte sequence without producing any compressed output. This function must be called immediately after deflateInit, deflateInit2 or deflateReset, before any call of deflate. The compressor and decompressor must use exactly the same dictionary (see inflateSetDictionary). The dictionary should consist of strings (byte sequences) that are likely to be encountered later in the data to be compressed, with the most commonly used strings preferably put towards the end of the dictionary. Using a dictionary is most useful when the data to be compressed is short and can be predicted with good accuracy; the data can then be compressed better than with the default empty dictionary. Depending on the size of the compression data structures selected by deflateInit or deflateInit2, a part of the dictionary may in effect be discarded, for example if the dictionary is larger than the window size in deflate or deflate2. Thus the strings most likely to be useful should be put at the end of the dictionary, not at the front. In addition, the current implementation of deflate will use at most the window size minus 262 bytes of the provided dictionary. Upon return of this function, strm->adler is set to the adler32 value of the dictionary; the decompressor may later use this value to determine which dictionary has been used by the compressor. (The adler32 value applies to the whole dictionary even if only a subset of the dictionary is actually used by the compressor.) If a raw deflate was requested, then the adler32 value is not computed and strm->adler is not set. deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a parameter is invalid (such as NULL dictionary) or the stream state is inconsistent (for example if deflate has already been called for this stream or if the compression method is bsort). deflateSetDictionary does not perform any compression: this will be done by deflate(). */ ZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest, z_streamp source)); /* Sets the destination stream as a complete copy of the source stream. This function can be useful when several compression strategies will be tried, for example when there are several ways of pre-processing the input data with a filter. The streams that will be discarded should then be freed by calling deflateEnd. Note that deflateCopy duplicates the internal compression state which can be quite large, so this strategy is slow and can consume lots of memory. deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_STREAM_ERROR if the source stream state was inconsistent (such as zalloc being NULL). msg is left unchanged in both source and destination. */ ZEXTERN int ZEXPORT deflateReset OF((z_streamp strm)); /* This function is equivalent to deflateEnd followed by deflateInit, but does not free and reallocate all the internal compression state. The stream will keep the same compression level and any other attributes that may have been set by deflateInit2. deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source stream state was inconsistent (such as zalloc or state being NULL). */ ZEXTERN int ZEXPORT deflateParams OF((z_streamp strm, int level, int strategy)); /* Dynamically update the compression level and compression strategy. The interpretation of level and strategy is as in deflateInit2. This can be used to switch between compression and straight copy of the input data, or to switch to a different kind of input data requiring a different strategy. If the compression level is changed, the input available so far is compressed with the old level (and may be flushed); the new level will take effect only at the next call of deflate(). Before the call of deflateParams, the stream state must be set as for a call of deflate(), since the currently available input may have to be compressed and flushed. In particular, strm->avail_out must be non-zero. deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR if strm->avail_out was zero. */ ZEXTERN int ZEXPORT deflateTune OF((z_streamp strm, int good_length, int max_lazy, int nice_length, int max_chain)); /* Fine tune deflate's internal compression parameters. This should only be used by someone who understands the algorithm used by zlib's deflate for searching for the best matching string, and even then only by the most fanatic optimizer trying to squeeze out the last compressed bit for their specific input data. Read the deflate.c source code for the meaning of the max_lazy, good_length, nice_length, and max_chain parameters. deflateTune() can be called after deflateInit() or deflateInit2(), and returns Z_OK on success, or Z_STREAM_ERROR for an invalid deflate stream. */ ZEXTERN uLong ZEXPORT deflateBound OF((z_streamp strm, uLong sourceLen)); /* deflateBound() returns an upper bound on the compressed size after deflation of sourceLen bytes. It must be called after deflateInit() or deflateInit2(). This would be used to allocate an output buffer for deflation in a single pass, and so would be called before deflate(). */ ZEXTERN int ZEXPORT deflatePrime OF((z_streamp strm, int bits, int value)); /* deflatePrime() inserts bits in the deflate output stream. The intent is that this function is used to start off the deflate output with the bits leftover from a previous deflate stream when appending to it. As such, this function can only be used for raw deflate, and must be used before the first deflate() call after a deflateInit2() or deflateReset(). bits must be less than or equal to 16, and that many of the least significant bits of value will be inserted in the output. deflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source stream state was inconsistent. */ ZEXTERN int ZEXPORT deflateSetHeader OF((z_streamp strm, gz_headerp head)); /* deflateSetHeader() provides gzip header information for when a gzip stream is requested by deflateInit2(). deflateSetHeader() may be called after deflateInit2() or deflateReset() and before the first call of deflate(). The text, time, os, extra field, name, and comment information in the provided gz_header structure are written to the gzip header (xflag is ignored -- the extra flags are set according to the compression level). The caller must assure that, if not Z_NULL, name and comment are terminated with a zero byte, and that if extra is not Z_NULL, that extra_len bytes are available there. If hcrc is true, a gzip header crc is included. Note that the current versions of the command-line version of gzip (up through version 1.3.x) do not support header crc's, and will report that it is a "multi-part gzip file" and give up. If deflateSetHeader is not used, the default gzip header has text false, the time set to zero, and os set to 255, with no extra, name, or comment fields. The gzip header is returned to the default state by deflateReset(). deflateSetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source stream state was inconsistent. */ /* ZEXTERN int ZEXPORT inflateInit2 OF((z_streamp strm, int windowBits)); This is another version of inflateInit with an extra parameter. The fields next_in, avail_in, zalloc, zfree and opaque must be initialized before by the caller. The windowBits parameter is the base two logarithm of the maximum window size (the size of the history buffer). It should be in the range 8..15 for this version of the library. The default value is 15 if inflateInit is used instead. windowBits must be greater than or equal to the windowBits value provided to deflateInit2() while compressing, or it must be equal to 15 if deflateInit2() was not used. If a compressed stream with a larger window size is given as input, inflate() will return with the error code Z_DATA_ERROR instead of trying to allocate a larger window. windowBits can also be -8..-15 for raw inflate. In this case, -windowBits determines the window size. inflate() will then process raw deflate data, not looking for a zlib or gzip header, not generating a check value, and not looking for any check values for comparison at the end of the stream. This is for use with other formats that use the deflate compressed data format such as zip. Those formats provide their own check values. If a custom format is developed using the raw deflate format for compressed data, it is recommended that a check value such as an adler32 or a crc32 be applied to the uncompressed data as is done in the zlib, gzip, and zip formats. For most applications, the zlib format should be used as is. Note that comments above on the use in deflateInit2() applies to the magnitude of windowBits. windowBits can also be greater than 15 for optional gzip decoding. Add 32 to windowBits to enable zlib and gzip decoding with automatic header detection, or add 16 to decode only the gzip format (the zlib format will return a Z_DATA_ERROR). If a gzip stream is being decoded, strm->adler is a crc32 instead of an adler32. inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_STREAM_ERROR if a parameter is invalid (such as a null strm). msg is set to null if there is no error message. inflateInit2 does not perform any decompression apart from reading the zlib header if present: this will be done by inflate(). (So next_in and avail_in may be modified, but next_out and avail_out are unchanged.) */ ZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm, const Bytef *dictionary, uInt dictLength)); /* Initializes the decompression dictionary from the given uncompressed byte sequence. This function must be called immediately after a call of inflate, if that call returned Z_NEED_DICT. The dictionary chosen by the compressor can be determined from the adler32 value returned by that call of inflate. The compressor and decompressor must use exactly the same dictionary (see deflateSetDictionary). For raw inflate, this function can be called immediately after inflateInit2() or inflateReset() and before any call of inflate() to set the dictionary. The application must insure that the dictionary that was used for compression is provided. inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a parameter is invalid (such as NULL dictionary) or the stream state is inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the expected one (incorrect adler32 value). inflateSetDictionary does not perform any decompression: this will be done by subsequent calls of inflate(). */ ZEXTERN int ZEXPORT inflateSync OF((z_streamp strm)); /* Skips invalid compressed data until a full flush point (see above the description of deflate with Z_FULL_FLUSH) can be found, or until all available input is skipped. No output is provided. inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR if no more input was provided, Z_DATA_ERROR if no flush point has been found, or Z_STREAM_ERROR if the stream structure was inconsistent. In the success case, the application may save the current current value of total_in which indicates where valid compressed data was found. In the error case, the application may repeatedly call inflateSync, providing more input each time, until success or end of the input data. */ ZEXTERN int ZEXPORT inflateCopy OF((z_streamp dest, z_streamp source)); /* Sets the destination stream as a complete copy of the source stream. This function can be useful when randomly accessing a large stream. The first pass through the stream can periodically record the inflate state, allowing restarting inflate at those points when randomly accessing the stream. inflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_STREAM_ERROR if the source stream state was inconsistent (such as zalloc being NULL). msg is left unchanged in both source and destination. */ ZEXTERN int ZEXPORT inflateReset OF((z_streamp strm)); /* This function is equivalent to inflateEnd followed by inflateInit, but does not free and reallocate all the internal decompression state. The stream will keep attributes that may have been set by inflateInit2. inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source stream state was inconsistent (such as zalloc or state being NULL). */ ZEXTERN int ZEXPORT inflatePrime OF((z_streamp strm, int bits, int value)); /* This function inserts bits in the inflate input stream. The intent is that this function is used to start inflating at a bit position in the middle of a byte. The provided bits will be used before any bytes are used from next_in. This function should only be used with raw inflate, and should be used before the first inflate() call after inflateInit2() or inflateReset(). bits must be less than or equal to 16, and that many of the least significant bits of value will be inserted in the input. inflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source stream state was inconsistent. */ ZEXTERN int ZEXPORT inflateGetHeader OF((z_streamp strm, gz_headerp head)); /* inflateGetHeader() requests that gzip header information be stored in the provided gz_header structure. inflateGetHeader() may be called after inflateInit2() or inflateReset(), and before the first call of inflate(). As inflate() processes the gzip stream, head->done is zero until the header is completed, at which time head->done is set to one. If a zlib stream is being decoded, then head->done is set to -1 to indicate that there will be no gzip header information forthcoming. Note that Z_BLOCK can be used to force inflate() to return immediately after header processing is complete and before any actual data is decompressed. The text, time, xflags, and os fields are filled in with the gzip header contents. hcrc is set to true if there is a header CRC. (The header CRC was valid if done is set to one.) If extra is not Z_NULL, then extra_max contains the maximum number of bytes to write to extra. Once done is true, extra_len contains the actual extra field length, and extra contains the extra field, or that field truncated if extra_max is less than extra_len. If name is not Z_NULL, then up to name_max characters are written there, terminated with a zero unless the length is greater than name_max. If comment is not Z_NULL, then up to comm_max characters are written there, terminated with a zero unless the length is greater than comm_max. When any of extra, name, or comment are not Z_NULL and the respective field is not present in the header, then that field is set to Z_NULL to signal its absence. This allows the use of deflateSetHeader() with the returned structure to duplicate the header. However if those fields are set to allocated memory, then the application will need to save those pointers elsewhere so that they can be eventually freed. If inflateGetHeader is not used, then the header information is simply discarded. The header is always checked for validity, including the header CRC if present. inflateReset() will reset the process to discard the header information. The application would need to call inflateGetHeader() again to retrieve the header from the next gzip stream. inflateGetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source stream state was inconsistent. */ /* ZEXTERN int ZEXPORT inflateBackInit OF((z_streamp strm, int windowBits, unsigned char FAR *window)); Initialize the internal stream state for decompression using inflateBack() calls. The fields zalloc, zfree and opaque in strm must be initialized before the call. If zalloc and zfree are Z_NULL, then the default library- derived memory allocation routines are used. windowBits is the base two logarithm of the window size, in the range 8..15. window is a caller supplied buffer of that size. Except for special applications where it is assured that deflate was used with small window sizes, windowBits must be 15 and a 32K byte window must be supplied to be able to decompress general deflate streams. See inflateBack() for the usage of these routines. inflateBackInit will return Z_OK on success, Z_STREAM_ERROR if any of the paramaters are invalid, Z_MEM_ERROR if the internal state could not be allocated, or Z_VERSION_ERROR if the version of the library does not match the version of the header file. */ typedef unsigned (*in_func) OF((void FAR *, unsigned char FAR * FAR *)); typedef int (*out_func) OF((void FAR *, unsigned char FAR *, unsigned)); ZEXTERN int ZEXPORT inflateBack OF((z_streamp strm, in_func in, void FAR *in_desc, out_func out, void FAR *out_desc)); /* inflateBack() does a raw inflate with a single call using a call-back interface for input and output. This is more efficient than inflate() for file i/o applications in that it avoids copying between the output and the sliding window by simply making the window itself the output buffer. This function trusts the application to not change the output buffer passed by the output function, at least until inflateBack() returns. inflateBackInit() must be called first to allocate the internal state and to initialize the state with the user-provided window buffer. inflateBack() may then be used multiple times to inflate a complete, raw deflate stream with each call. inflateBackEnd() is then called to free the allocated state. A raw deflate stream is one with no zlib or gzip header or trailer. This routine would normally be used in a utility that reads zip or gzip files and writes out uncompressed files. The utility would decode the header and process the trailer on its own, hence this routine expects only the raw deflate stream to decompress. This is different from the normal behavior of inflate(), which expects either a zlib or gzip header and trailer around the deflate stream. inflateBack() uses two subroutines supplied by the caller that are then called by inflateBack() for input and output. inflateBack() calls those routines until it reads a complete deflate stream and writes out all of the uncompressed data, or until it encounters an error. The function's parameters and return types are defined above in the in_func and out_func typedefs. inflateBack() will call in(in_desc, &buf) which should return the number of bytes of provided input, and a pointer to that input in buf. If there is no input available, in() must return zero--buf is ignored in that case--and inflateBack() will return a buffer error. inflateBack() will call out(out_desc, buf, len) to write the uncompressed data buf[0..len-1]. out() should return zero on success, or non-zero on failure. If out() returns non-zero, inflateBack() will return with an error. Neither in() nor out() are permitted to change the contents of the window provided to inflateBackInit(), which is also the buffer that out() uses to write from. The length written by out() will be at most the window size. Any non-zero amount of input may be provided by in(). For convenience, inflateBack() can be provided input on the first call by setting strm->next_in and strm->avail_in. If that input is exhausted, then in() will be called. Therefore strm->next_in must be initialized before calling inflateBack(). If strm->next_in is Z_NULL, then in() will be called immediately for input. If strm->next_in is not Z_NULL, then strm->avail_in must also be initialized, and then if strm->avail_in is not zero, input will initially be taken from strm->next_in[0 .. strm->avail_in - 1]. The in_desc and out_desc parameters of inflateBack() is passed as the first parameter of in() and out() respectively when they are called. These descriptors can be optionally used to pass any information that the caller- supplied in() and out() functions need to do their job. On return, inflateBack() will set strm->next_in and strm->avail_in to pass back any unused input that was provided by the last in() call. The return values of inflateBack() can be Z_STREAM_END on success, Z_BUF_ERROR if in() or out() returned an error, Z_DATA_ERROR if there was a format error in the deflate stream (in which case strm->msg is set to indicate the nature of the error), or Z_STREAM_ERROR if the stream was not properly initialized. In the case of Z_BUF_ERROR, an input or output error can be distinguished using strm->next_in which will be Z_NULL only if in() returned an error. If strm->next is not Z_NULL, then the Z_BUF_ERROR was due to out() returning non-zero. (in() will always be called before out(), so strm->next_in is assured to be defined if out() returns non-zero.) Note that inflateBack() cannot return Z_OK. */ ZEXTERN int ZEXPORT inflateBackEnd OF((z_streamp strm)); /* All memory allocated by inflateBackInit() is freed. inflateBackEnd() returns Z_OK on success, or Z_STREAM_ERROR if the stream state was inconsistent. */ ZEXTERN uLong ZEXPORT zlibCompileFlags OF((void)); /* Return flags indicating compile-time options. Type sizes, two bits each, 00 = 16 bits, 01 = 32, 10 = 64, 11 = other: 1.0: size of uInt 3.2: size of uLong 5.4: size of voidpf (pointer) 7.6: size of z_off_t Compiler, assembler, and debug options: 8: DEBUG 9: ASMV or ASMINF -- use ASM code 10: ZLIB_WINAPI -- exported functions use the WINAPI calling convention 11: 0 (reserved) One-time table building (smaller code, but not thread-safe if true): 12: BUILDFIXED -- build static block decoding tables when needed 13: DYNAMIC_CRC_TABLE -- build CRC calculation tables when needed 14,15: 0 (reserved) Library content (indicates missing functionality): 16: NO_GZCOMPRESS -- gz* functions cannot compress (to avoid linking deflate code when not needed) 17: NO_GZIP -- deflate can't write gzip streams, and inflate can't detect and decode gzip streams (to avoid linking crc code) 18-19: 0 (reserved) Operation variations (changes in library functionality): 20: PKZIP_BUG_WORKAROUND -- slightly more permissive inflate 21: FASTEST -- deflate algorithm with only one, lowest compression level 22,23: 0 (reserved) The sprintf variant used by gzprintf (zero is best): 24: 0 = vs*, 1 = s* -- 1 means limited to 20 arguments after the format 25: 0 = *nprintf, 1 = *printf -- 1 means gzprintf() not secure! 26: 0 = returns value, 1 = void -- 1 means inferred string length returned Remainder: 27-31: 0 (reserved) */ /* utility functions */ /* The following utility functions are implemented on top of the basic stream-oriented functions. To simplify the interface, some default options are assumed (compression level and memory usage, standard memory allocation functions). The source code of these utility functions can easily be modified if you need special options. */ ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen, const Bytef *source, uLong sourceLen)); /* Compresses the source buffer into the destination buffer. sourceLen is the byte length of the source buffer. Upon entry, destLen is the total size of the destination buffer, which must be at least the value returned by compressBound(sourceLen). Upon exit, destLen is the actual size of the compressed buffer. This function can be used to compress a whole file at once if the input file is mmap'ed. compress returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_BUF_ERROR if there was not enough room in the output buffer. */ ZEXTERN int ZEXPORT compress2 OF((Bytef *dest, uLongf *destLen, const Bytef *source, uLong sourceLen, int level)); /* Compresses the source buffer into the destination buffer. The level parameter has the same meaning as in deflateInit. sourceLen is the byte length of the source buffer. Upon entry, destLen is the total size of the destination buffer, which must be at least the value returned by compressBound(sourceLen). Upon exit, destLen is the actual size of the compressed buffer. compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_BUF_ERROR if there was not enough room in the output buffer, Z_STREAM_ERROR if the level parameter is invalid. */ ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen)); /* compressBound() returns an upper bound on the compressed size after compress() or compress2() on sourceLen bytes. It would be used before a compress() or compress2() call to allocate the destination buffer. */ ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen, const Bytef *source, uLong sourceLen)); /* Decompresses the source buffer into the destination buffer. sourceLen is the byte length of the source buffer. Upon entry, destLen is the total size of the destination buffer, which must be large enough to hold the entire uncompressed data. (The size of the uncompressed data must have been saved previously by the compressor and transmitted to the decompressor by some mechanism outside the scope of this compression library.) Upon exit, destLen is the actual size of the compressed buffer. This function can be used to decompress a whole file at once if the input file is mmap'ed. uncompress returns Z_OK if success, Z_MEM_ERROR if there was not enough memory, Z_BUF_ERROR if there was not enough room in the output buffer, or Z_DATA_ERROR if the input data was corrupted or incomplete. */ typedef voidp gzFile; ZEXTERN gzFile ZEXPORT gzopen OF((const char *path, const char *mode)); /* Opens a gzip (.gz) file for reading or writing. The mode parameter is as in fopen ("rb" or "wb") but can also include a compression level ("wb9") or a strategy: 'f' for filtered data as in "wb6f", 'h' for Huffman only compression as in "wb1h", or 'R' for run-length encoding as in "wb1R". (See the description of deflateInit2 for more information about the strategy parameter.) gzopen can be used to read a file which is not in gzip format; in this case gzread will directly read from the file without decompression. gzopen returns NULL if the file could not be opened or if there was insufficient memory to allocate the (de)compression state; errno can be checked to distinguish the two cases (if errno is zero, the zlib error is Z_MEM_ERROR). */ ZEXTERN gzFile ZEXPORT gzdopen OF((int fd, const char *mode)); /* gzdopen() associates a gzFile with the file descriptor fd. File descriptors are obtained from calls like open, dup, creat, pipe or fileno (in the file has been previously opened with fopen). The mode parameter is as in gzopen. The next call of gzclose on the returned gzFile will also close the file descriptor fd, just like fclose(fdopen(fd), mode) closes the file descriptor fd. If you want to keep fd open, use gzdopen(dup(fd), mode). gzdopen returns NULL if there was insufficient memory to allocate the (de)compression state. */ ZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy)); /* Dynamically update the compression level or strategy. See the description of deflateInit2 for the meaning of these parameters. gzsetparams returns Z_OK if success, or Z_STREAM_ERROR if the file was not opened for writing. */ ZEXTERN int ZEXPORT gzread OF((gzFile file, voidp buf, unsigned len)); /* Reads the given number of uncompressed bytes from the compressed file. If the input file was not in gzip format, gzread copies the given number of bytes into the buffer. gzread returns the number of uncompressed bytes actually read (0 for end of file, -1 for error). */ ZEXTERN int ZEXPORT gzwrite OF((gzFile file, voidpc buf, unsigned len)); /* Writes the given number of uncompressed bytes into the compressed file. gzwrite returns the number of uncompressed bytes actually written (0 in case of error). */ ZEXTERN int ZEXPORTVA gzprintf OF((gzFile file, const char *format, ...)); /* Converts, formats, and writes the args to the compressed file under control of the format string, as in fprintf. gzprintf returns the number of uncompressed bytes actually written (0 in case of error). The number of uncompressed bytes written is limited to 4095. The caller should assure that this limit is not exceeded. If it is exceeded, then gzprintf() will return return an error (0) with nothing written. In this case, there may also be a buffer overflow with unpredictable consequences, which is possible only if zlib was compiled with the insecure functions sprintf() or vsprintf() because the secure snprintf() or vsnprintf() functions were not available. */ ZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s)); /* Writes the given null-terminated string to the compressed file, excluding the terminating null character. gzputs returns the number of characters written, or -1 in case of error. */ ZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len)); /* Reads bytes from the compressed file until len-1 characters are read, or a newline character is read and transferred to buf, or an end-of-file condition is encountered. The string is then terminated with a null character. gzgets returns buf, or Z_NULL in case of error. */ ZEXTERN int ZEXPORT gzputc OF((gzFile file, int c)); /* Writes c, converted to an unsigned char, into the compressed file. gzputc returns the value that was written, or -1 in case of error. */ ZEXTERN int ZEXPORT gzgetc OF((gzFile file)); /* Reads one byte from the compressed file. gzgetc returns this byte or -1 in case of end of file or error. */ ZEXTERN int ZEXPORT gzungetc OF((int c, gzFile file)); /* Push one character back onto the stream to be read again later. Only one character of push-back is allowed. gzungetc() returns the character pushed, or -1 on failure. gzungetc() will fail if a character has been pushed but not read yet, or if c is -1. The pushed character will be discarded if the stream is repositioned with gzseek() or gzrewind(). */ ZEXTERN int ZEXPORT gzflush OF((gzFile file, int flush)); /* Flushes all pending output into the compressed file. The parameter flush is as in the deflate() function. The return value is the zlib error number (see function gzerror below). gzflush returns Z_OK if the flush parameter is Z_FINISH and all output could be flushed. gzflush should be called only when strictly necessary because it can degrade compression. */ ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile file, z_off_t offset, int whence)); /* Sets the starting position for the next gzread or gzwrite on the given compressed file. The offset represents a number of bytes in the uncompressed data stream. The whence parameter is defined as in lseek(2); the value SEEK_END is not supported. If the file is opened for reading, this function is emulated but can be extremely slow. If the file is opened for writing, only forward seeks are supported; gzseek then compresses a sequence of zeroes up to the new starting position. gzseek returns the resulting offset location as measured in bytes from the beginning of the uncompressed stream, or -1 in case of error, in particular if the file is opened for writing and the new starting position would be before the current position. */ ZEXTERN int ZEXPORT gzrewind OF((gzFile file)); /* Rewinds the given file. This function is supported only for reading. gzrewind(file) is equivalent to (int)gzseek(file, 0L, SEEK_SET) */ ZEXTERN z_off_t ZEXPORT gztell OF((gzFile file)); /* Returns the starting position for the next gzread or gzwrite on the given compressed file. This position represents a number of bytes in the uncompressed data stream. gztell(file) is equivalent to gzseek(file, 0L, SEEK_CUR) */ ZEXTERN int ZEXPORT gzeof OF((gzFile file)); /* Returns 1 when EOF has previously been detected reading the given input stream, otherwise zero. */ ZEXTERN int ZEXPORT gzdirect OF((gzFile file)); /* Returns 1 if file is being read directly without decompression, otherwise zero. */ ZEXTERN int ZEXPORT gzclose OF((gzFile file)); /* Flushes all pending output if necessary, closes the compressed file and deallocates all the (de)compression state. The return value is the zlib error number (see function gzerror below). */ ZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum)); /* Returns the error message for the last error which occurred on the given compressed file. errnum is set to zlib error number. If an error occurred in the file system and not in the compression library, errnum is set to Z_ERRNO and the application may consult errno to get the exact error code. */ ZEXTERN void ZEXPORT gzclearerr OF((gzFile file)); /* Clears the error and end-of-file flags for file. This is analogous to the clearerr() function in stdio. This is useful for continuing to read a gzip file that is being written concurrently. */ /* checksum functions */ /* These functions are not related to compression but are exported anyway because they might be useful in applications using the compression library. */ ZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len)); /* Update a running Adler-32 checksum with the bytes buf[0..len-1] and return the updated checksum. If buf is NULL, this function returns the required initial value for the checksum. An Adler-32 checksum is almost as reliable as a CRC32 but can be computed much faster. Usage example: uLong adler = adler32(0L, Z_NULL, 0); while (read_buffer(buffer, length) != EOF) { adler = adler32(adler, buffer, length); } if (adler != original_adler) error(); */ ZEXTERN uLong ZEXPORT adler32_combine OF((uLong adler1, uLong adler2, z_off_t len2)); /* Combine two Adler-32 checksums into one. For two sequences of bytes, seq1 and seq2 with lengths len1 and len2, Adler-32 checksums were calculated for each, adler1 and adler2. adler32_combine() returns the Adler-32 checksum of seq1 and seq2 concatenated, requiring only adler1, adler2, and len2. */ ZEXTERN uLong ZEXPORT crc32 OF((uLong crc, const Bytef *buf, uInt len)); /* Update a running CRC-32 with the bytes buf[0..len-1] and return the updated CRC-32. If buf is NULL, this function returns the required initial value for the for the crc. Pre- and post-conditioning (one's complement) is performed within this function so it shouldn't be done by the application. Usage example: uLong crc = crc32(0L, Z_NULL, 0); while (read_buffer(buffer, length) != EOF) { crc = crc32(crc, buffer, length); } if (crc != original_crc) error(); */ ZEXTERN uLong ZEXPORT crc32_combine OF((uLong crc1, uLong crc2, z_off_t len2)); /* Combine two CRC-32 check values into one. For two sequences of bytes, seq1 and seq2 with lengths len1 and len2, CRC-32 check values were calculated for each, crc1 and crc2. crc32_combine() returns the CRC-32 check value of seq1 and seq2 concatenated, requiring only crc1, crc2, and len2. */ /* various hacks, don't look :) */ /* deflateInit and inflateInit are macros to allow checking the zlib version * and the compiler's view of z_stream: */ ZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level, const char *version, int stream_size)); ZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm, const char *version, int stream_size)); ZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int level, int method, int windowBits, int memLevel, int strategy, const char *version, int stream_size)); ZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int windowBits, const char *version, int stream_size)); ZEXTERN int ZEXPORT inflateBackInit_ OF((z_streamp strm, int windowBits, unsigned char FAR *window, const char *version, int stream_size)); #define deflateInit(strm, level) \ deflateInit_((strm), (level), ZLIB_VERSION, sizeof(z_stream)) #define inflateInit(strm) \ inflateInit_((strm), ZLIB_VERSION, sizeof(z_stream)) #define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \ deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\ (strategy), ZLIB_VERSION, sizeof(z_stream)) #define inflateInit2(strm, windowBits) \ inflateInit2_((strm), (windowBits), ZLIB_VERSION, sizeof(z_stream)) #define inflateBackInit(strm, windowBits, window) \ inflateBackInit_((strm), (windowBits), (window), \ ZLIB_VERSION, sizeof(z_stream)) #if !defined(ZUTIL_H) && !defined(NO_DUMMY_DECL) struct internal_state {int dummy;}; /* hack for buggy compilers */ #endif ZEXTERN const char * ZEXPORT zError OF((int)); ZEXTERN int ZEXPORT inflateSyncPoint OF((z_streamp z)); ZEXTERN const uLongf * ZEXPORT get_crc_table OF((void)); #ifdef __cplusplus } #endif #endif /* ZLIB_H */ haxe-3.0~svn6707/libs/extc/zlib/zlib.lib0000644000175000017500000032571012172015137020477 0ustar bdefreesebdefreese! / 1171549761 0 2786 ` k(#À#À)))8l8l8l8l8l8l8l8l8l8l8l8l8l8l8l8lEÂJªJªJªJªJªJªJª‡,‡,‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘Ô‘ÔÚRÚRÚRÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚÚ3<3<3<3<3<3<3<3<3<3<3<3<3<k k k ž>ž>ž>¤þ¤þ_inflate_fast_longest_match_match_init_cpudetect32_longest_match_686_longest_match_7fff??_C@_00CNPNBAHC@?$AA@??_C@_05GDHACFMB@1?42?43?$AA@??_C@_0BA@MOKMMFOD@need?5dictionary?$AA@??_C@_0BE@OGGJBMCE@insufficient?5memory?$AA@??_C@_0BF@CJFPCCEG@incompatible?5version?$AA@??_C@_0L@FNAOCBOG@stream?5end?$AA@??_C@_0L@HAHMBNLP@data?5error?$AA@??_C@_0L@KIJFAKBJ@file?5error?$AA@??_C@_0N@DFPGLBGC@buffer?5error?$AA@??_C@_0N@MKKNPMJD@stream?5error?$AA@_zError_z_errmsg_zcalloc_zcfree_zlibCompileFlags_zlibVersion_uncompress__dist_code__length_code__tr_align__tr_flush_block__tr_init__tr_stored_block__tr_tally_inflate_copyright_inflate_table??_C@_0BD@PJCBIDD@invalid?5block?5type?$AA@??_C@_0BE@EMOGCLGO@invalid?5window?5size?$AA@??_C@_0BE@GONKLEPM@header?5crc?5mismatch?$AA@??_C@_0BF@MEIGEHBE@incorrect?5data?5check?$AA@??_C@_0BG@GMDFCBGP@invalid?5distances?5set?$AA@??_C@_0BG@LBKINIKP@invalid?5distance?5code?$AA@??_C@_0BH@FGKKJGOC@incorrect?5length?5check?$AA@??_C@_0BH@LIBMMIGA@incorrect?5header?5check?$AA@??_C@_0BJ@BLBBCOMO@unknown?5header?5flags?5set?$AA@??_C@_0BJ@HDEPPGOH@invalid?5code?5lengths?5set?$AA@??_C@_0BK@BMMPFBBH@invalid?5bit?5length?5repeat?$AA@??_C@_0BL@IHKGDAEE@unknown?5compression?5method?$AA@??_C@_0BM@FFFLPBBC@invalid?5literal?1length?5code?$AA@??_C@_0BM@IIMGAINC@invalid?5literal?1lengths?5set?$AA@??_C@_0BN@LGAADGOK@invalid?5stored?5block?5lengths?$AA@??_C@_0BO@ECPMAOGG@invalid?5distance?5too?5far?5back?$AA@??_C@_0CE@GMIGFPBB@too?5many?5length?5or?5distance?5symb@_inflate_inflateCopy_inflateEnd_inflateGetHeader_inflateInit2__inflateInit__inflatePrime_inflateReset_inflateSetDictionary_inflateSync_inflateSyncPoint_inflateBack_inflateBackEnd_inflateBackInit_??_C@_02LMMGGCAJ@?3?5?$AA@??_C@_07EBNKNFJN@?$DMfd?3?$CFd?$DO?$AA@??_C@_0BF@FJABJDFD@?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$AA@_gzclearerr_gzclose_gzdirect_gzdopen_gzeof_gzerror_gzflush_gzgetc_gzgets_gzopen_gzprintf_gzputc_gzputs_gzread_gzrewind_gzseek_gzsetparams_gztell_gzungetc_gzwrite_deflate_deflateBound_deflateCopy_deflateEnd_deflateInit2__deflateInit__deflateParams_deflatePrime_deflateReset_deflateSetDictionary_deflateSetHeader_deflateTune_deflate_copyright_crc32_crc32_combine_get_crc_table_compress_compress2_compressBound_adler32_adler32_combine/ 1171549761 0 2640 ` (À#)ü2l8ÂEªJ,‡Ô‘î×RÚÚ<3 k>žþ¤k      ??_C@_00CNPNBAHC@?$AA@??_C@_02LMMGGCAJ@?3?5?$AA@??_C@_05GDHACFMB@1?42?43?$AA@??_C@_07EBNKNFJN@?$DMfd?3?$CFd?$DO?$AA@??_C@_0BA@MOKMMFOD@need?5dictionary?$AA@??_C@_0BD@PJCBIDD@invalid?5block?5type?$AA@??_C@_0BE@EMOGCLGO@invalid?5window?5size?$AA@??_C@_0BE@GONKLEPM@header?5crc?5mismatch?$AA@??_C@_0BE@OGGJBMCE@insufficient?5memory?$AA@??_C@_0BF@CJFPCCEG@incompatible?5version?$AA@??_C@_0BF@FJABJDFD@?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$AA@??_C@_0BF@MEIGEHBE@incorrect?5data?5check?$AA@??_C@_0BG@GMDFCBGP@invalid?5distances?5set?$AA@??_C@_0BG@LBKINIKP@invalid?5distance?5code?$AA@??_C@_0BH@FGKKJGOC@incorrect?5length?5check?$AA@??_C@_0BH@LIBMMIGA@incorrect?5header?5check?$AA@??_C@_0BJ@BLBBCOMO@unknown?5header?5flags?5set?$AA@??_C@_0BJ@HDEPPGOH@invalid?5code?5lengths?5set?$AA@??_C@_0BK@BMMPFBBH@invalid?5bit?5length?5repeat?$AA@??_C@_0BL@IHKGDAEE@unknown?5compression?5method?$AA@??_C@_0BM@FFFLPBBC@invalid?5literal?1length?5code?$AA@??_C@_0BM@IIMGAINC@invalid?5literal?1lengths?5set?$AA@??_C@_0BN@LGAADGOK@invalid?5stored?5block?5lengths?$AA@??_C@_0BO@ECPMAOGG@invalid?5distance?5too?5far?5back?$AA@??_C@_0CE@GMIGFPBB@too?5many?5length?5or?5distance?5symb@??_C@_0L@FNAOCBOG@stream?5end?$AA@??_C@_0L@HAHMBNLP@data?5error?$AA@??_C@_0L@KIJFAKBJ@file?5error?$AA@??_C@_0N@DFPGLBGC@buffer?5error?$AA@??_C@_0N@MKKNPMJD@stream?5error?$AA@__dist_code__length_code__tr_align__tr_flush_block__tr_init__tr_stored_block__tr_tally_adler32_adler32_combine_compress_compress2_compressBound_cpudetect32_crc32_crc32_combine_deflate_deflateBound_deflateCopy_deflateEnd_deflateInit2__deflateInit__deflateParams_deflatePrime_deflateReset_deflateSetDictionary_deflateSetHeader_deflateTune_deflate_copyright_get_crc_table_gzclearerr_gzclose_gzdirect_gzdopen_gzeof_gzerror_gzflush_gzgetc_gzgets_gzopen_gzprintf_gzputc_gzputs_gzread_gzrewind_gzseek_gzsetparams_gztell_gzungetc_gzwrite_inflate_inflateBack_inflateBackEnd_inflateBackInit__inflateCopy_inflateEnd_inflateGetHeader_inflateInit2__inflateInit__inflatePrime_inflateReset_inflateSetDictionary_inflateSync_inflateSyncPoint_inflate_copyright_inflate_fast_inflate_table_longest_match_longest_match_686_longest_match_7fff_match_init_uncompress_zError_z_errmsg_zcalloc_zcfree_zlibCompileFlags_zlibVersion// 1171549761 0 569 ` .\win32_lib_asm_release\inffas32.obj.\win32_lib_asm_release\gvmat32c.obj.\win32_lib_asm_release\gvmat32.obj.\win32_lib_asm_release\zlib1.res.\win32_lib_asm_release\zutil.obj.\win32_lib_asm_release\uncompr.obj.\win32_lib_asm_release\trees.obj.\win32_lib_asm_release\inftrees.obj.\win32_lib_asm_release\inflate.obj.\win32_lib_asm_release\inffast.obj.\win32_lib_asm_release\infback.obj.\win32_lib_asm_release\gzio.obj.\win32_lib_asm_release\deflate.obj.\win32_lib_asm_release\crc32.obj.\win32_lib_asm_release\compress.obj.\win32_lib_asm_release\adler32.obj /0 1171549697 100666 2908 ` LnÔEd .text›Œ( P`.data› @PÀ.debug$SŸÀ¤@BéIFast decoding Code from Chris Andersoninvalid literal/length codeinvalid distance code‹ÿinvalid distance too far back‹ÿ?ÿÿÿÿÿÿÿ?ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ?ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ?ÿÿÿÿÿÿÿWVUSœƒì@ü‹t$X‹~‹V‹Ðƒê ‰D$,‰T$‹l$\‹N‹^ +é÷Ýëéˉ\$<‰l$(‰L$‹GL‹OP‰D$‰L$ ¸‹OTÓàH‰$¸‹OXÓàH‰D$‹G(‹O0‹W4‰D$4‰L$0‰T$8‹o8‹_<‹t$,‹L$;Îw"ƒÁ +θ +Á|$ó¤‹È3Àóªt$‰t$ë÷Æt3ÀŠF‹ËƒÃÓà èëè‹|$<ƒ=„‰wkPSQRœ‹$4$ œZ3ÐtD3À¢ûGenuu8ùntelu0úineIu(¸¢Áèƒàƒøu÷€uë Çë ÇZY[X뇀ûw 3Àf­ŠË€ÃÓà è‹$‹L$#Õ‹‘ŠÌ*ÜÓí„ÀuÁèª9|$†b9t$wÄéW‹ÐÁêŠÈ¨„ô€át%8ËsŠé3Àf­ŠË€ÃÓà èŠÍ¸ÓàH*Ù#ÅÓíЉT$€ûw 3Àf­ŠË€ÃÓà è‹T$‹L$ #Õ‹‘‹ÐÁêŠÌ*ÜÓíŠÈ¨„²€áte8ËsŠé3Àf­ŠË€ÃÓà èŠÍ¸ÓàH*Ù#ÅÓíÐë‰t$,‹Ç+D$(;‚”‹L$‹÷+òƒéŠˆŠFŠVƒÆˆGˆWƒÇó¤‹t$,éÿÿÿƒúu½9|$(t·O‹L$ŠƒéˆGˆGˆGƒÇóªéèþÿÿ¨@…¸ÓàH#Å‹T$‹‚éºþÿÿ¨@…â¸ÓàH#Å‹T$ ‹‚éÿÿÿ‹È‹D$4÷Ù‹t$8;‚Þʃ|$0u$+Áð‹D$;Áv`+Áó¤‹÷+òëV;ÁvR+Áó¤‹÷+òëH‹D$0;Èv,t$4ð+ñ+È‹D$;Áv.+Áó¤‹t$8‹L$0;Áv+Áó¤‹÷+òëð+ñ‹D$;Áv+Áó¤‹÷+ò‹Èó¤‹t$,éþÿÿ‹ÿwnÅ‹ën$$ãnl$êïÉ‹\$ëÓÁƒý wnõn>ƒÆóþƒÅ ëÇÛà~àÜ‹ƒ¶ÌnÉ+é„ÀuÁèª9|$†9t$wºé‹ÐÁꨄàƒàtÓÁnÈ~Á+è# …ÑÓÁƒý wnõn>ƒÆóþƒÅ ëÇ‹\$ Ûè~èÕ‹ƒ¶Ì‹ØÁë+énɨ„¬ƒàtWÓÁnÈ~Á+è# …Ù‰t$,‹Ç+D$(;©‹Ê‹÷+óƒéŠˆŠFŠVƒÆˆGˆWƒÇó¤‹t$,‹\$é-ÿÿÿIƒûu¸9|$(t²O‹ÊŠƒéˆGˆGˆGƒÇóª‹\$éÿÿÿ‹ÿ¨@…ÞƒàÓÁ~Á# …Ê‹‹éÌþÿÿ‹ÿ¨@…®ƒàÓÁ~Á# …‹D$ Ë‹ˆéÿÿÿ‹ÿ‹È‹D$4÷Ù‹t$8;¢˃|$0u +Áð;ÑvX+Ñó¤‹÷+óëN;ÑvJ+Ñó¤‹÷+óë@‹D$0;Èv(t$4ð+ñ+È;Ñv*+Ñó¤‹t$8‹L$0;Ñv+Ñó¤‹÷+óëð+ñ;Ñv+Ñó¤‹÷+ó‹Êó¤‹t$,‹\$é$þÿÿ¹ºë,¨ t ¹º 빺ë‹t$,¹ºë‹D$X…Ét‰H‹@‰ëƒ=u‹Ý‹D$X‹Ë‹PÁé+ñÁá+Ù‰x ‰Z<‹Ë\$9\$u+ó‹‰\$ó‹Xƒë \$‰0»ÓãKƒ=uÓÁ~Åw#ë‰j8‹\$;Þv +ރà ‰Xë +ó÷ÞƒÆ ‰p‹\$;ßv +ßÉXë +û÷ßljxƒÄ@[]^_Ãà=IÿWà§ÃÓò@ñ|c:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\inffas32.obj4 ŽMicrosoft (R) Macro Assembler.fileþÿgc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\contrib\masmx86\inffas32.asm@comp.idŽÿÿ.text› .data.debug$SÀL,„>0^sdinvalid_distance_code_msg_inflate_fastinflate_fast_maskinvalid_literal_length_code_msginflate_fast_use_mmxinvalid_distance_too_far_msg/37 1171549760 100666 1289 ` L@nÔE¾.drectve,, .debug$S¼X@B.data@0À.text0 P`.debug$FDT@B.text(^† P`.debug$F¤´@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" | uc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\gvmat32c.obj8 Ž Ž!Microsoft (R) Optimizing Compilerè%=À@£Ã¡…Àu‹D$x4ÿt ‰D$é‰D$é$(.fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\contrib\masmx86\gvmat32c.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S¼.data‹È ª_iIsPPro.textÇŠþç  .debug$F.text(¶Ê¢ , @ .debug$FS_match_init_cpudetect32_longest_match_longest_match_7fff_longest_match_686 /74 1171549697 100666 2490 ` LnÔEP.textŒ 0`.data@0À.debug$S¿@B‹T$UWVSƒì4‹ê‹U|‹]x9ŒwÁêB‹½‰T$0‹Et;Çs‹ø‰\$(‹u8‹Ml‰t$$‰|$ñ‰t$ f‹f‹\3ÿÆf‰T$‰4$‹u,î+Îw3ɉL$,‹U@‰T$ ‹Upf‹l$‹D$L‰T$‹T$$‹ú|$(‹t$ O‰|$ëNƒD$0„Ñf98t%ÿf‹F;ȃºÿL$0uãé¯f;,uÞéã‹|$%ÿf‹F;ȃƒl$0v¬f98„¬%ÿf‹F;ȃmf98„€%ÿf‹F;ȃRf98„T%ÿf‹F;ȃ7f98„(%ÿf‹F;ȃf98„ü%ÿf‹F;ȃf98„Ð%ÿf‹F;ȃæf98„¤%ÿf‹F;ȃËf98„u%ÿf‹F;ȃ°f98„F%ÿf‹F;ȃ•f98„%ÿf‹F;ȃzf98„è%ÿf‹F;ȃ_f98t}%ÿf‹F;ȃHf98tz%ÿf‹F;ȃ1f98ts%ÿf‹F;ȃf98tl%ÿf‹F;ȃf98te%ÿf‹F;ȃìƒl$0‡Yþÿÿéþÿÿf;,…yÿÿÿƒD$0éf;,u€ƒD$0éf;,u‡ƒD$0éõf;,uŽƒD$0éåf;,u•ƒD$0éÕf;,…ÿÿÿƒD$0éÁf;,…ßþÿÿƒD$0é­f;,…°þÿÿƒD$0é™f;,…þÿÿƒD$0 é…f;,…RþÿÿƒD$0 ëtf;,…&þÿÿƒD$0 ëcf;,…úýÿÿƒD$0 ëRf;,…ÎýÿÿƒD$0 ëAf;,…¢ýÿÿƒD$0ë0f;,…výÿÿƒD$0ëf;,…JýÿÿƒD$0ë‹|$$f;,8…ýÿÿ‹ú‹t$ ø‹V3Wt- Òt¾ëQf Òt¾ëEâÿÿÿt¾ë6¾ë/ƒÇƒÆ¹?ó§tƒî‹Wü3 ÒuFf Òu FâÿÿÿuF+t$ ;t$(w‹t$ ‹L$,‹T$$éŒüÿÿ‰t$(‰D$;t$s"‹L$ ‹T$$ÎòN‰t$f‹Yÿ‹t$ ‹L$,é\üÿÿ‹\$‹l$H‹L$(‰]p‹Et;Èw‹ÁƒÄ4[^_]à GVMat32 optimised assembly code written 1996-98 by Gilles Vollant SœX‹È5PœX3ÁtQœœY‹Á5 PœX3Át¸¢[øë÷¸ëðUWVSƒì$‹T$8‹L$<‹Bx‹šŒ;ËB4‹Z||ÁëKÁã ؉$‹‚‹Zt;Ø|‹Ø‰\$‹r8‰t$‹jl|5‰|$ ‹Ç÷؃à‰D$‹B,-+è3í‹Bx‰D$ð‰t$·‰\$·\8ÿ‰\$ ‹z@‹$ë#Ê· O;͆àêˆÔ·D1ÿ;ÃuÝ‹D$·;D$uω$‹t$‹|$ ñ‹D$ºøþÿÿ¼8´0‹23:u‹D23D:uƒÂuéëqƒÂ©ÿÿuƒÂÁè,ƒÒ:‹|$ +Ç=}L‹T$8‹\$;Ët$‹z@‹\$ ‹$éNÿÿÿ‹\$‰D$‰Jp;Ã}-‹t$ð‰t$·\8ÿ‹z@‰\$ ‹$é!ÿÿÿ‹T$8ÇD$‰Jp‹T$8‹\$‹Bt;؋ÃÄ$[^_]à asm686 with masm, optimised assembly code from Brian Raiter, written 1998 ñ{c:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\gvmat32.obj4 ŽMicrosoft (R) Macro Assembler.fileþÿgc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\contrib\masmx86\gvmat32.asm@comp.idŽÿÿ.text.data.debug$S¿ á % 8_longest_match_7fff_cpudetect32_longest_match_686/110 1171549761 100666 1332 ` LAnÔEŽ .debug$ShŒ@B.rsrc$01XôL@@.rsrc$028V@@4 -C:\DOCUME~1\NCANNA~1\LOCALS~1\Temp\lnk133.tmp, ì Microsoft (R) CVTRES€0€ H8H84VS_VERSION_INFO½ïþ?–StringFileInfor040904E4dFileDescriptionzlib data compression library,FileVersion1.2.34 InternalNamezlib1.dll|,LegalCopyright(C) 1995-2004 Jean-loup Gailly & Mark Adler< OriginalFilenamezlib1.dll*ProductNamezlib0ProductVersion1.2.3‚5CommentsDLL support by Alessandro Iacopetti & Gilles VollantDVarFileInfo$Translation ä@comp.idì ^ÿÿ@feat.00ÿÿ.debug$Sh.rsrc$01X.rsrc$028$R000000/144 1171549761 100666 3353 ` LAnÔE‚G.drectve,¬ .debug$S¹Ø@B.rdata(‘¹ @0@.rdata@0@.rdata 2@0@.rdata?@0@.rdata S@0@.rdata ^@0@.rdata k@0@.rdatav@@.rdata w@0@.rdata‚@0@.text’˜ P`.rdata¢@0@.debug$F¨¸@B.text P`.debug$FÈØ@B.textâ÷ P`.debug$F@B.text. P`.debug$F8H@B.text R^ P`.debug$Fhx@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" y rc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\zutil.obj8 Ž Ž!Microsoft (R) Optimizing Compiler(%"  $"incompatible versionbuffer errorinsufficient memorydata errorstream errorfile errorstream endneed dictionary¸Ã.1.2.3+¸UÃ3‹D$ …º+Ñ‹à 8‹D$¯D$ PèƒÄà >=‹D$PèYÃD C.fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\zutil.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S¹.rdata( .rdata2¤—.rdata }Å<.rdataVxCa.rdata ¬SäŽ.rdata îE&:±.rdata  Dí<Ö .rdata ù .rdata  õovÉ .rdata IqèÝ3 .text ôô\ .rdata{M-i.debug$F .text"Š®‡ .debug$F.textcxÐv_zError .debug$F.text°Óظ_zcalloc _malloc .debug$F.text Î׆_zcfree _free .debug$F™_z_errmsg??_C@_0BF@CJFPCCEG@incompatible?5version?$AA@??_C@_0N@DFPGLBGC@buffer?5error?$AA@??_C@_0BE@OGGJBMCE@insufficient?5memory?$AA@??_C@_0L@HAHMBNLP@data?5error?$AA@??_C@_0N@MKKNPMJD@stream?5error?$AA@??_C@_0L@KIJFAKBJ@file?5error?$AA@??_C@_00CNPNBAHC@?$AA@??_C@_0L@FNAOCBOG@stream?5end?$AA@??_C@_0BA@MOKMMFOD@need?5dictionary?$AA@_zlibVersion??_C@_05GDHACFMB@1?42?43?$AA@_zlibCompileFlags /178 1171549761 100666 1195 ` LAnÔEÅ.drectve,Ü .debug$S»@B.text°Ãs P`.rdata¥@0@.debug$F«»@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" { tc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\uncompr.obj8 Ž Ž!Microsoft (R) Optimizing Compilerƒì8‹L$H‹D$D‹T$¾~þAÁ!¡aá‘QÑ1±qñ ‰IÉ)©ié™YÙ9¹yù…EÅ%¥eå•UÕ5µuõ MÍ-­mí]Ý=½}ý  “ “ S S Ó Ó 3 3 ³ ³ s s ó ó  ‹ ‹ K K Ë Ë + + « « k k ë ë   › › [ [ Û Û ; ; » » { { û û   ‡ ‡ G G Ç Ç ' ' § § g g ç ç   — — W W × × 7 7 · · w w ÷ ÷    O O Ï Ï / / ¯ ¯ o o ï ï   Ÿ Ÿ _ _ ß ß ? ? ¿ ¿   ÿ ÿ @ `P0pH(hX8xD$dT4tƒCÃ#£cã         (08@P`p€ Àà  0@`€À€  0@`ÃV‚”¹3ö‹ÿf‰0ƒÀIu÷‚ˆ ¹f‰0ƒÀIu÷‚| ¹f‰0ƒÀIu÷‰²¬‰²¨‰²°‰² fÇ‚”^Ãd#Q‹PUV‹t$‹¬°\ 6;ʉl$–S}2‹´ˆ` ‹¬ˆ\ f‹·f‹¯f;ÓruŠ”X:”(XwA‹l$ ‹´ˆ\ f‹¯f‹·f;Ór-uŠ”(X:”Xv+‹T$‰´\ ‹P‰L$Ñá;Ê~‹‹L$[^‰¬ˆ\ ]YËT$[^‰¬\ ]Yɬ°\ ^]YÃÄ (ƒì ‹Q‰T$S‹‹I‹Q‰T$ ‹Q‰T$3ÒU‹)V‹q‰< ‰@ ‰D ‰H ‰L ‰P ‰T ‰X ‹T‹”\ 3ÉWf‰L“‹¸TGÿ=‰t$‰L$¤Œ¸\ ‰L$¹=+Ïù‰L$ ‰|$ë ‹t$¤$‹T$‹·L“·L‹A;Î~‹ÎÿD$;T$$f‰L“L‹|$(fÿ„H< 3ö;×| ‹ò+÷‹|$,‹4··<“ίψ¨…ít·T•‹ˆ¬Ö¯×ʉˆ¬‹|$‹T$‹L$ ƒÂI‰T$‰L$ …iÿÿÿ‹l$…í„ã‹L$Qÿ‰T$,´H< ›‹L$,fƒ¼H< ”H< u ƒêIfƒ:töfÿŒH< fƒ„H> fÿƒí…íÅ‹T$…Ò„„‰t$ ëI·6…ö‰t$t`¬¸\ ‹|$‹MüOƒí‰|$;L$$‰l$,8·|‹;út‹t · ‹‹ê+ï¯é‹ˆ¨Í‹l$,‰ˆ¨f‰‹L$I‰L$‹ñ…öu«‹|$‹t$ Jƒî…Ò‰t$ u…_^][ƒÄ Ã3g-QSUVW·xƒÍÿ3ö…ÿ‹Ù¹ºu ¹Šº…ÛfÇD˜ÿÿŒ›ƒÀ‰D$C‹Ç‹|$·?F;ñ};Çtn;ò‹L$} f´| ë.…Àt;Åtfÿ„| fÿ¼ ëƒþ  fÿÀ ëfÿÄ 3ö…ÿ‹èu ¹Šºë;Çu ¹ºë ¹º‹D$ƒÀK‰D$…nÿÿÿ_^][YÃØ2ƒì SU‹l$VW‹ù·O‰L$3öƒËÿ9t$¹ºu ¹Šº…íŒÆƒÇE‰|$‰l$뛋|$·?‹l$F;ñ‰|$‰t$ };ï„x;ò§ë›·¼¨~ ‹ˆ¼º+×;Ê~\·´¨| ‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîL:ðf‰°¸‹t$ ëf‹”¨| fÓâf ¸ÏN‰ˆ¼‰t$ …fÿÿÿé—…í„™;ë„”·¼¨~ ‹ˆ¼º+×;Ê~\·´¨| ‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîL:ðf‰°¸‹t$ ëf‹”¨| fÓâf ¸ÏN‰ˆ¼‰t$ ·¸¾ ‹ˆ¼º+×;Ê~[·°¼ ‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîL:ðf‰°¸‹t$ ëf‹¼ fÓâf ¸σÆýƒù‰ˆ¼~X‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîƒÂò‰¼f‰°¸éÓæf °¸ƒÁéðƒþ ‹ˆ¼ºò·¸Â +×;Ê~[·°À ‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîL:ðf‰°¸‹t$ ëf‹À fÓâf ¸σÆýƒù ‰ˆ¼~X‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîƒÂó‰¼f‰°¸éÓæf °¸ƒÁéê·¸Æ +×;Ê~[·°Ä ‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîL:ðf‰°¸‹t$ ëf‹Ä fÓâf ¸σÆõƒù ‰ˆ¼~U‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîƒÂ÷‰¼f‰°¸ëÓæf °¸ƒÁ‰ˆ¼‹L$3ö…É‹Ýu ¹Šºë;éu ¹ºë ¹º‹l$‹|$ƒÅO‰l$‰|$…Nûÿÿ_^][ƒÄ à  7‹ˆ¼ƒù S‹\$ U‹l$VW~g‹t$Æÿþÿÿ‹ÖÓâ‹H‰\$f ¸Š˜¸‹Pˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼‹\$A‰H±*ÊfÓîƒÂõ‰¼f‰°¸ë‹T$ÂÿþÿÿÓâf ¸ƒÁ‰ˆ¼‹ˆ¼ƒù ~`sÿ‹ÖÓâ‹H‰\$f ¸Š˜¸‹Pˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼‹\$A‰H±*ÊfÓîƒÂõ‰¼f‰°¸ëSÿÓâf ¸ƒÁ‰ˆ¼‹ˆ¼ƒù ~`uü‹ÖÓâ‹H‰\$f ¸Š˜¸‹Pˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼‹\$A‰H±*ÊfÓîƒÂô‰¼f‰°¸ëUüÓâf ¸ƒÁ‰ˆ¼3ÿ…íŽ£ë ¤$I‹ˆ¼ƒù ¶—~]·´~ ‹ÖÓâ‹Hf ¸Š˜¸‹Pˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓîƒÂó‰¼f‰°¸ëf‹”~ fÓâf ¸ƒÁ‰ˆ¼G;ýŒmÿÿÿ‹\$‹L$IQˆ”èKSˆˆ èƒÄ_^][üT7a7m<‹D$‹ ‹L$V‹°¤f‰ V‹°˜‹T$W‹¸ ˆ>‹¸ G…ɉ¸ u fÿ„”ë@ÿ€°¶’Ifÿ„˜ù”˜s ¶‰ë Á鶉fÿ„ˆˆ ‹ˆœ‹° 3ÒI;ñ”Â_^‹ÂÃQp|¡$A‹ ƒì S‹\$UV3É…ÒW„FëI‹¤·,J‹˜¶4A…í‰L$‹ˆ¼…„·|³º+×;Ê~_·4³‹ÖÓâ‹H‰\$f ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼‹\$A‰H±*ÊfÓîL:ðf‰°¸é•f‹³fÓâf ¸Ï逶–·¼“»+ß;ˉ|$‹|$ ‰T$~f·¼—‹×Óâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼A‰H±*ÊfÓï‹L$T ð‰¼‹T$f‰¸¸ëf‹¼—fÓçf ¸¸‹|$ωˆ¼‹<•…ÿ‹\$ „}+4•‹ˆ¼º+×;Ê~T‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼‹\$ A‰H±*ÊfÓîL:ðf‰°¸ë Óæf °¸ωˆ¼Mýs ¶½ë ‹ÕÁ궺‹L$$·T¹‹ˆ¼¾+ò;ΉT$~f‹T$$·4º‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼‹\$ A‰H±*ÊfÓî‹L$T ð‰¼f‰°¸ë‹t$$f‹4¾fÓæf °¸ʉˆ¼‹4½…ö„+,½‹ˆ¼º+Ö;Ê~X‹ÕÓâ‹H‰\$f ¸‹PŠ˜¸ˆ‹PŠ˜¹B‰P‹Ê‹Pˆ‹H‹¼‹\$A‰H±*ÊfÓíL2ðf‰¨¸ë Óåf ¨¸Ήˆ¼‹L$;ˆ ‚¿üÿÿ·»‹ˆ¼º+×;Ê~x·³‹ÖÓâ‹H‰\$ f ¸‹PŠ˜¸ˆ‹P‹H‹\$ B‰P‹êŠ¹ˆ)‹H‹¼A‰H±*ÊfÓîL:ð_‰ˆ¼f‰°¸·“^]‰´[ƒÄ Ãf‹“fÓâf ¸Ï_‰ˆ¼·‹^]‰ˆ´[ƒÄ ÃÎx‹ÄÓF3ÀŠ”fƒ9u @ƒÁƒø |ñƒø …›¸ŠÐëIfƒyü…€fƒ9u5fƒyu=fƒyuGfƒy uQfƒyu[ƒÀƒÁƒø |È‹3Ƀø ”Á‰J,Ë3É@ƒø ”Á‰J,Ë3ɃÀƒø ”Á‰J,Ë3ɃÀƒø ”Á‰J,Ë3ɃÀƒø ”Á‰J,ÃÀ‹3Ƀø ”Á‰J,ÃÉK3ÀV‹ñƒæ ÆÑéÑàJ…ÒðÑè^ÃP‹ˆ¼ƒùSu8‹PŠ˜¸‹Hˆ‹PŠ˜¹B‰P‹Ê‹Pˆÿ@3Éf‰ˆ¸‰ˆ¼[Ãù|4‹H‹PŠ˜¸ˆf¶ˆ¹‹Pf‰ˆ¸‹ˆ¼BƒÁø‰P‰ˆ¼[à U‹¼ƒúS~8‹PŠ˜¸‹Hˆ‹PŠ˜¹B‰P‹Ê‹Pˆÿ@3Éf‰ˆ¸‰ˆ¼[Ã3É;Ñ~‹PŠ˜¸V‹pˆ2ÿ@^f‰ˆ¸‰ˆ¼[Ãm ZSVW‹Ù‹úè‹L$…ÉÇ€´t;‹H‹Pˆ‹H‹PA‰Hˆ<‹p‹PF‰pŠËöш ‹p‹PF‹Ë÷щpˆ,ÿ@…Ût!I‹H‹P‰\$Šˆ‹p‹\$FGK‰puâ_^[ÃZ‚_‹T$‚”‰‚ ‚| ‰‚0 3ÀŠˆ Ç‚ ‰Š$ Ç‚, Ç‚8 f‰‚¸‰‚¼Ç‚´é*:D `#ddƒì Vt$3ɸ+Ö4B·t4fñÑæ‹Îf‰LD@ƒø~æ3ö…Û|;U·T·…Òt+3Àf‹DT·È@f‰DT3ÀI‹éƒå ÅÑéÑàJ…ÒðÑèf‰·F;ó~Ç]^ƒÄ Ãqiƒì‹D$ SUW‹8‹@‹H ‹3ÒƒÍÿ3À;ʉL$‰l$ ‰–PdžT=~7f9‡t#‹ŽPA‰ŽP‰„Ž\ ‰D$ ˆ”0X‹èëf‰T‡‹L$@;Á|Ƀ¾P}Vƒý}E‹Åë3À‹ŽPA‰ŽP‰„Ž\ fLJˆ”X‹Ž¨I;Ú‰Ž¨t ·Dƒ)†¬ƒ¾P|®‰l$ ‹L$‰i‹†P™+‹ØÑûƒû|S‹ÆèƒÄKƒû}ï‹l$ëI‹†P‹”†\ ‹ž` H‰†Pj‹Æ‰–` è‹–T‹†` ƒÄJ‰–T‹Ê‰œŽ\ ‹ŽTI‰ŽT‰„Ž\ f‹ ‡f Ÿf‰ ¯ŠŒXŠ”X:Ñr¶Êë¶ÉþÁˆŒ.Xf‰l‡f‰lŸ‰®` j‹ÆE苆PƒÄƒøIÿÿÿ‹†T‹–` ‹L$H‰†T‰”†\ ‹Æè‹\$ –< è_][ƒÄÃê(%(¡(Ø-çiò nV‹ð‹Ž †”Vè‹Ž( †ˆ Vè†0 PèƒÄ ¸ëI¶ˆfƒ¼Ž~ uHƒø}è‹Ž¨T@ʉŽ¨^Ã2#2/nCls‹D$‹ˆ¼ƒù ~jSV‹t$‹ÖÓâ‹Hf ¸‹PŠ˜¸ˆ‹HŠ˜¹‹PA‰Hˆ‹¼‹X±*ÊfÓî‹L$CƒÂóf‰°¸^‰X‰¼‹T$ [jèYËT$ÓâƒÁ‰ˆ¼‹L$ f ¸‹T$jèYÃs_š_ x‹D$‹ˆ¼ºÓâSVf ¸ƒù ~M‹PŠ˜¸‹Hˆ‹HŠ˜¹‹PA‰Hˆ‹¼‹X±*ʾfÓîCƒÂó‰Xf‰°¸‰¼ë ƒÁ‰ˆ¼‹ˆ¼3ÒÓâf ¸ƒù ~J‹PŠ˜¸‹Hˆ‹HŠ˜¹‹PA‰Hˆ‹¼‹X±*Ê3öfÓîCƒÂ÷‰Xf‰°¸‰¼ë ƒÁ‰ˆ¼苈¼‹´+у ƒú çºÓâf ¸ƒù ~M‹PŠ˜¸‹Hˆ‹HŠ˜¹‹PA‰Hˆ‹¼‹X±*ʾfÓîCƒÂó‰Xf‰°¸‰¼ë ƒÁ‰ˆ¼‹ˆ¼3ÒÓâf ¸ƒù ~Z‹PŠ˜¸‹Hˆ‹HŠ˜¹‹PA‰Hˆ‹¼‹X±*Ê3öfÓîCƒÂ÷‰Xf‰°¸‰¼è^Ç€´[ÃÁ‰ˆ¼è^Ç€´[ÃßUÅUàUñ}SU‹l$V‹t$‹Ž„3À…ÉW~S…ív‹ƒx,u‹ÖèŽ Qè–$ RèƒÄ‹Æè‹–¨‹Ž¬ƒÂ ƒÁ ÁêÁé;ÊwëM‹Ñ};úw‹\$…Ût‹|$ WUSVèƒÄéWƒ¾ˆ„½;Ê„µ‹Ž¼ƒù ‹|$ W~[‹ÚÓã‹N‰D$ f ž¸‹^Š†¸ˆ‹NŠ†¹‹^A‰Nˆ‹ž¼‹F±*ËfÓê@ƒÃó‰F‹D$ f‰–¸‰ž¼ëÓâf –¸ƒÁ‰Ž¼‹Ž @P‹†( @PAQ‹Æè–ˆ R†”P‹ÆèƒÄé‹Ž¼ƒù ‹|$ G~U‹ÐÓâ‹Nf –¸‹VŠž¸ˆ‹VŠž¹B‰V‹Ê‹Vˆ‹N‹–¼A‰N±*ÊfÓèƒÂó‰–¼f‰†¸ëÓàf †¸ƒÁ‰Ž¼hh‹ÆèƒÄ‹Öè…ÿ_t ‹Æ^][é^][Ã'K3n?nIsˆx=<RFØÝäFî#ýZ‚.fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\trees.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S¹.data<a‘ß(#.rdata8 Se-«2À =H JHXHdÐrP€<Šð˜x¥.text “m² .debug$F.textd7$÷ .debug$F.text ÄuŸ“ËÎ .debug$F  .text 3U ¾Ú .debug$F  .text Ø?¾yæ .debug$F .text Ôpñ .debug$F.textm݆¡îü .debug$F.text¡4®vš  .debug$F.textÂÈŽø .debug$F.textÉ`E f' .debug$F.text1V=,6 .debug$F.textó(™xB .debug$F.textmo`ë©L .debug$F.text‚ïm W .debug$F .text!dqk.c! .debug$F"!.text#qU§2m# .debug$F$#.text%ò½Ù™éx% .debug$F&%.text'l 7…¸„' .debug$F('.text) ý‚&“) .debug$F*).text+ñ\¥†n¥+ .debug$F,+.text- |çh°- .debug$F.-Á_static_bl_desc_static_d_desc_static_l_desc_base_dist_base_length__length_code__dist_code_static_dtree_static_ltree_bl_order_extra_blbits_extra_dbits_extra_lbits_tr_static_init_init_block_pqdownheap_gen_bitlen_scan_tree_send_tree_send_all_trees__tr_tally_compress_block_set_data_type_bi_reverse_bi_flush_bi_windup_copy_block__tr_init_gen_codes_build_tree_build_bl_tree__tr_stored_block__tr_align__tr_flush_block/248 1171549761 100666 2668 ` LAnÔE .drectve,Ü .debug$S¼@B.rdata0Ä@@@.textêôÞ P`.debug$F@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" | uc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\inftrees.obj8 Ž Ž!Microsoft (R) Optimizing Compiler inflate 1.2.3 Copyright 1995-2005 Mark Adler  #+3;CScsƒ£ÃãÉÄ !1AaÁ  0@`@@ƒì|‹”$ˆ3À…Ò‰D$<‰D$@‰D$D‰D$H‰D$LS‰D$TU‹¬$Œ‰D$\V‰D$dv›·LEfÿDLHLLH@;Ârí‹´$œ‹»‰D$‰\$¤$fƒ|\HuKƒûsò;É\$v‰\$…Ûu9‹„$˜‹f‰\$ÆD$ @ÆD$ ‹L$ ‰ ‹ƒÂ‰‰ ƒÇ^]3À[ƒÄ|þd$fƒ|tHu:fƒ|tJu"fƒ|tLufƒ|tNufƒ|tPuƒÆƒþvÐëFë ƒÆëƒÆëƒÆ9t$s‰t$º‹Â·LDHÒ+Ñx&@ƒøvï…ÒW‹¼$~…ÿtƒût_^]ƒÈÿ[ƒÄ|Ã^]ƒÈÿ[ƒÄ|ÃfÇD$n¸›f‹TlfTLf‹LNfÊf‰Tnf‰LpƒÀƒørÜ‹œ$˜3À…Ûv0fƒ|Et#·TE·LTl‹”$¤f‰J·TEfÿDTlTTl@;ÃrЋǃèºÿÿÿÿt;HtÇD$4ÇD$0‰T$,ë9¸-‰D$4¸-ÇD$,ë‹„$¤‰D$4ÇD$,‰D$0‹„$œ‹‰L$ ‹L$¸Óà‰T$83í3ÛƒÿPÿ‰t$‰D$<‰D$(‰T$@u =°ƒk‹„$¤‰D$$IŠL$‹t$$f‹‹T$,*ˈL$·È;Ê} ÆD$f‰D$ë-~·‹T$0ÑàŠ ‹T$4f‹ˆL$f‰D$ë ÆD$`fÇD$‹L$‹D$<+˺Óâ‹Ë‹ýÓï‹L$ ‰D$D4•ø ¹‹|$+Â+Î…À‰9uö‹T$Jÿ¸Óà…ÅtÑè…Åuú…Àt Hÿ#ÍÈ‹éë3í‹t$$ƒÆfÿLTLfƒ|TL‰t$$u;T$„à‹Œ$”‹Ö··A‰T$;T$† ÿÿÿ‹t$@‹D$8#õ;ð‰t$H„óþÿÿ…Ûu‹\$‹D$ ‹L$D‹|$ˆ‹L$+ˉT$ ¸ Óà;×s tTL·>+Ç…À~‹|$ABƒÆÑà;×rè‹t$H‹T$(¸ÓàЉD$<ƒ¼$‰T$(u ‹Â=°ƒÕ‹Ö‹´$œ‹ˆ ‹ŠD$ˆD‘‹‹L$ +ÈÁù‰T$8f‰LéGþÿÿ‹¼$œŠÂ*Ã…íÆD$@ˆD$fÇD$t]‹t$ d$…Ût ‹L$@‹D$8#Í;Èt‹D$‹73Û‰D$ˆD$‹Ð‹Ë‹ÅÓè‹L$‰ †Jÿ¸Óà…ÅtÑè…Åuú…Àt Hÿ#ÍÈ‹éu«‹T$(‹•‹T$ȉ‹Œ$ _^]‰3À[ƒÄ|Ã_^]¸[ƒÄ|Ãäì÷ê4.fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\inftrees.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S¼.rdata0S ‘Nð!°?p\0z.textê—+›’ .debug$Fœ?dext@?1??inflate_table@@9@9?dbase@?1??inflate_table@@9@9?lext@?1??inflate_table@@9@9?lbase@?1??inflate_table@@9@9_inflate_copyright_inflate_table/285 1171549761 100666 17885 ` L0AnÔE®4³.drectve,” .debug$S»À@B.rdata¦{@@@.text]! P`.debug$F~Ž@B.textT˜ P`.debug$Fìü@B.textÇÍ P`.debug$Fëû@B.text P`.debug$F)9@B.textC` P`.debug$Ft„@B.textŽ P`.debug$F£³@B.text(½å*O P`.rdataû-@0@.rdata.@0@.rdata'.@0@.rdataE.@0@.rdata[.@0@.rdataw.@0@.rdata.@0@.rdata§.@0@.rdata$Ã.@0@.rdataç.@0@.rdata/@0@.rdata/@0@.rdata0/@0@.rdataD/@0@.rdata]/@0@.rdatat/@0@.rdataˆ/@0@.debug$F£/³/@B.textH½/ P`.debug$F00@B.textä01 P`.debug$F!111@B.text,;1 P`.debug$Fg1w1@B.textR1 P`.debug$FÓ1ã1@B.textöí1ã2 P`.debug$F33@B.text*3 P`.debug$FE3U3@B.text5_3 P`.debug$F”4¤4@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" { tc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\inflate.obj8 Ž Ž!Microsoft (R) Optimizing Compiler`Psp0 À `  €@ àX ;x8 Ðh( °ˆH ðTã+t4 È d$ ¨„D è\ ˜S|< Øl, ¸ ŒL øR£#r2 Ä b" ¤‚B äZ ”Cz: Ôj* ´ ŠJ ôV@3v6 Ìf& ¬†F ì ^ œc~> Ün. ¼ŽN ü`Qƒq1  a! ¢A âY ’;y9 Òi) ² ‰I òU+u5 Ê e% ª…E ê] šS}= Úm- º M úSÃ#s3 Æ c# ¦ƒC æ[ –C{; Ök+ ¶ ‹K öW@3w7 Îg' ®‡G î _ žc? Þo/ ¾O þ`Psp0 Á ` ¡€@ áX ‘;x8 Ñh( ±ˆH ñTã+t4 É d$ ©„D é\ ™S|< Ùl, ¹ ŒL ùR£#r2 Å b" ¥‚B åZ •Cz: Õj* µ ŠJ õV@3v6 Íf& ­†F í ^ c~> Ýn. ½ŽN ý`Qƒq1 à a! £A ãY “;y9 Ói) ³ ‰I óU+u5 Ë e% «…E ë] ›S}= Ûm- » M ûSÃ#s3 Ç c# §ƒC ç[ —C{; ×k+ · ‹K ÷W@3w7 Ïg' ¯‡G ï _ Ÿc? ßo/ ¿O ÿA@!  @a`10  Á@     ‹T$3É;ÑtM‹B;ÁtF‰H‰J‰J‰JÇB0‰‰H‰H ‰H ‰H(‰H,‰H0‰H8‰H<ˆ0Ç@€‰Hl‰HP‰HL3ÀøþÿÿÿÃ]‹D$…ÀtF‹@…Àt?‹L$ƒùV.‹P<4 ƒþ w#W¿Óç‹L$‰p3íUUUè‰CjD$4ÆD$4ÆD$5‹‹KPQè‰CƒÄ‰l$Ç‹Åéü‹C …ÀÇCtÇ@0ÿÿÿÿöC„¬‹L$‹Á%ÿÁàÁéÁ3Ò¹÷ñ…Ò…ˆ‹L$‹Ñ€â€út‹D$LÇ@‹Áé“‹C$Áé‰L$ƒáƒÁƒí;Èv‹L$L‹D$ÇAéh3íºÓâUUU‰Sè‹T$‹L$XÁê÷ÒƒâƒÄ ‰C‰A0ƒÊ ‰‰l$‹Åé1‹D$LÇ@‹D$éƒýs'…ÿ„n¶‹ÍÓâOƒÅ‰|$ÂFƒý‰D$‰t$rÙ<‰Ct‹L$LÇAéÔöÄàt‹T$LÇBé¿‹K …ÉtÁèƒà‰‹CöÄt%‹D$ˆD$$ÁèˆD$%‹KjD$(PQèƒÄ ‰C3À3íÇëƒý s…ÿ„ζ‹ÍÓâOƒÅÂFƒý ‰D$rá‹K …Ét‰A‹CöÄt7‹D$ˆD$$‹È‹ÐÁèÁéˆD$'ÁêjD$(ˆL$)ˆT$*‹KPQèƒÄ ‰C3À3íÇëƒýs(…ÿ„T¶‹ÍÓâOƒÅ‰|$ÂFƒý‰D$‰t$rÙ‹K …Ét‹Ðâÿ‰Q‹K Áè‰A ‹CöÄt%‹D$ˆD$$ÁèjT$(ˆD$)‹CRPèƒÄ ‰C3À‰D$3íÇ‹KöÅtvƒýs-›…ÿ„Ķ‹ÍÓâOƒÅ‰|$ÂFƒý‰D$‰t$rÙ‹K …ɉC@t‰A‹CöÄt%‹D$ˆD$$ÁèˆD$%‹KjD$(PQèƒÄ ‰C3À‰D$3íë‹K …ÉtÇAÇ‹KöÅ„¬‹K@;ωL$v‹Ï‰L$…É„ˆ‹S …ÒtH‹R…Ò‰T$8t=‹S ‹z‹s@‹R+þ49;òv+׋ʋT$8‹t$ú‹ÑÁéó¥‹Êƒáó¤‹L$‹|$‹t$‹SöÆt‹D$‹KPVQè‹L$(‰C‹D$ƒÄ ‹S@+ùñ+щ|$‰t$‰S@‹K@…É…•ÇC@Ç‹KöÅ„ …ÿ„t3É›¶1A‰L$‹K …ɉT$,t-‹Q…Ò‰T$8t"‹S@;Q s‹L$8‹|$‰D$8ŠD$,ˆÿC@‹D$8‹L$,…Ét‹L$;Ïr¯‹KöÅt‹T$‹CRVPè‰C‹D$ƒÄ ‹L$+ùñ‹L$,…ɉ|$‰t$…Þë‹K …ÉtÇAÇC@Ç‹KöÅ„š…ÿ„­3ɶ1A‰L$‹K …ɉT$,t-‹Q$…Ò‰T$8t"‹S@;Q(s‹L$8‹|$‰D$8ŠD$,ˆÿC@‹D$8‹L$,…Ét‹L$;Ïr¯‹KöÅt‹T$‹CRVPè‰C‹D$ƒÄ ‹L$+ùñ‹L$,…ɉ|$‰t$…ë‹K …ÉtÇA$Ç‹KöÅtOƒýs'…ÿ„ò ¶‹ÍÓâOƒÅ‰|$ÂFƒý‰D$‰t$rÙ‹Káÿÿ;Át‹T$LÇBéR 3í‰l$‹C …Àt‹KÁù ƒá‰H,‹S ÇB0jjjè‹L$X‰C‰A0‹D$ƒÄ Ç é ƒý s'…ÿ„_ ¶‹ÍÓâOƒÅ‰|$ÂFƒý ‰D$‰t$rÙ‹È‹ÐáÿÁâÊ3ÒŠt$ÁáÁèÊÁ‹L$L‰C‰A03À‰D$3íÇ ‹K …É„¸ jjjè‹T$X‰C‰B0‹D$ƒÄ Ç ƒ|$P„Ñ ‹K…Ét‹ÍƒáÓè+éljD$éT ƒýs$…ÿ„¤ ¶‹ÍÓâOƒÅ‰|$ÂFƒý‰t$r݋ȃáÑè‰K‹ÈƒáMƒùwsÿ$ÁèÇ ‰D$ƒíéú ÁèÇCLÇCT ÇCPÇCXljD$ƒíéÉ ÁèljD$ƒíé´ ‹T$LÇBÇÁè‰D$ƒíé” ‹ÍƒáÓè+éƒý ‰D$s+d$…ÿ„Ô ¶‹ÍÓâOƒÅ‰|$ÂFƒý ‰D$‰t$rًЋÈ÷ÒáÿÿÁê;Êt‹L$LÇAé. 3À‰K@‰D$3íÇ‹K@…ɉL$„¢;Ïv‹Ï‰L$‹T$ ;Êv‹Ê‰L$…É„R ‹t$‹|$(‹ÑÁéó¥‹Ê‹T$ƒáó¤‹L$‹t$‹|$ +ñ‰t$‹t$(щT$‹S@+ùñ+щ|$ ‹|$‰t$(‹t$‰S@é ƒýs#…ÿ„î ¶‹ÍÓâOƒÅ‰|$ÂFƒý‰t$r݋ȃáÁÁè‹Ð‰K`Áè‹ÈƒáƒÁƒâ‰K\‹K`BÁèƒíù‰Sd‰D$‡ý‹Êƒù‡òÇChÇ‹Kh;K\s[›ƒýs#…ÿ„_ ¶‹ÍÓâOƒÅ‰|$ÂFƒý‰t$rÝ‹Sh·U3ÉŠÈÁèƒí‰D$ƒáf‰LSp‹KhA‰Kh;K\r«‹Kh¸;Ès*3Éë ¤$d$‹Sh·Uf‰LSp‹ShB;ЉShråƒ0Kl‰‰CL“ðRCTPQÇjCpPjèƒÄ‰D$4…À‹D$t ‹L$LÇAé1 ‹T$LÇBé! ÇChÇ‹K`‹SdÑ9Shƒ‹KTºÓâ‹KLJ#Ћ ‘¶Õ;Õ‰L$@v<…ÿ„A ¶‹ÍÓâ‹KTOƒÅºÓâ‹KLF‰|$J#Ћ ‘¶Õ;Õ‰t$‰L$@wÄ‹T$@ÁêfƒúsR¶Í;é‰L$s&…ÿ„í¶‹ÍÓâ‹L$OƒÅÂF;é‰|$‰t$rÚf‹T$BÓè+é‹Khf‰TKp‹KhA‰D$‰KhéHuh¶ÍQ;ê‰L$s+‹ÿ…ÿ„”¶‹ÍÓâ‹L$OƒÅÂFQ;ê‰|$‰t$r×Óè+é‹Kh…ɉD$„b·LKn‰L$,‹ÈƒáƒÁÁèƒíé§fƒú¶Õ‰T$uJJ;és-d$…ÿ„$¶‹ÍÓâOƒÅ‰|$‹T$FJ;é‰t$r׋ÊÓè¿ýÿÿÿ‹ÈƒáƒÁÁèëDJ;és)…ÿ„Þ¶‹ÍÓâOƒÅ‰|$‹T$FJ;é‰t$r׋ÊÓè¿ùÿÿÿ‹ÈƒáƒÁ Áè+úÇD$,ï‹{d‹Sh{`Ñ;׉D$‡˜…Ét‹T$,‹ÿ‹{hf‰T{p‹{hGI‰{huî‹|$‹S`‹KdÊ9Kh‚îýÿÿƒ;„îƒ0Kl‰‰CL“ðR‹S`CTPQÇ RCpPjèƒÄ…À‰D$4t8‹L$L‹D$ÇAéš‹T$LÇB銋L$L‹|$ÇAév‹SlKl‰SP“ðRCXPQ‹K`Ç‹CdPTKpRjèƒÄ…À‰D$4t‹D$LÇ@‹D$é)‹D$ǃÿrg|$ r]‹D$L‹T$ ‹L$(‰P‹T$0‰H ‹L$R‰0‰xP‰K8‰k<è‹D$T‹H ‹P‹0‹x‹C8‹k<ƒÄ‰L$(‰T$ ‰t$‰|$‰D$鹋KTºÓâ‹KLJ#Ћ‘¶Î;͉T$@v<…ÿ„ñ¶‹ÍÓâ‹KTOƒÅºÓâ‹KLF‰|$J#Ћ‘¶Î;͉t$‰T$@wÄ„Ò„¹öÂð…°¶Î‰L$3ɊʉT$,L$ºÓâ‹L$J#ÐÓê‹L$@ÁéÑ‹KL‹‘‹L$,Áé‰T$@¶É¶ÖÑ;Õ‰L$v[I…ÿ„T¶‹ÍÓâ3ÉŠL$,O‹T$FƒÅ‰|$ʺÓâ‹L$‰t$J#ÐÓê·L$.Ñ‹KL‹ ‘¶Õ‰L$@‹L$Ñ;Õw¨‹T$@Óè+é¶ÎÓè¶Î+é‹L$@Áé„Ò‰D$‰K@u Çéwö t Ç égöÂ@t‹T$LÇBéLƒâ‰SHÇ‹KH…ÉtE;és%…ÿ„‘¶‹ÍÓâ‹KHOƒÅÂF;é‰|$‰t$rÛ‹KHºÓâ‹K@J#ÐʉK@‹KHÓè+éÇ‹KXºÓâ‹KPJ#Ћ‘¶Î;͉T$@v<…ÿ„,¶‹ÍÓâ‹KXOƒÅºÓâ‹KPF‰|$J#Ћ‘¶Î;͉t$‰T$@wÄöÂð…³¶Î‰L$3ɊʉT$,L$ºÓâ‹L$J#ÐÓê‹L$@ÁéÑ‹KP‹‘‹L$,Áé‰T$@¶É¶ÖÑ;Õ‰L$v^›…ÿ„”¶‹ÍÓâ3ÉŠL$,O‹T$FƒÅ‰|$ʺÓâ‹L$‰t$J#ÐÓê·L$.Ñ‹KP‹ ‘¶Õ‰L$@‹L$Ñ;Õw¨‹T$@Óè+é¶ÎÓè¶Î+éöÂ@‰D$t‹L$LÇA鵋L$@Áéƒâ‰KD‰SHÇ‹KH…ÉtI;és%…ÿ„ð¶‹ÍÓâ‹KHOƒÅÂF;é‰|$‰t$rÛ‹KHºÓâ‹KDJ#ÐʉKD‹KHÓè+é‰D$‹T$ ‹K,+ÊL$09KDv‹T$LÇBé-Ç‹L$ …É„‹T$0+Ñ‹KD;Êv<+Ê‹S0;ʉL$v+Ê‹S4S(‰L$+Ñë ‹S4+ÑS0‹L$‰T$,‹S@;ʉT$8v‹Êë‹T$(+Ñ‹K@‰T$,‰L$8‰L$‹T$ ;Êv‹Ê‰L$+щT$ ‹T$8+щS@뛋L$,Š‹L$(ˆ‹T$,A‰L$(‹L$BI‰T$,‰L$uÛ‹K@…É…nÇéc…Ò„¹‹L$(ŠS@ˆA‰L$(ÿL$ Çé>‹K…É„Õƒý s'…ÿ„„¶‹ÍÓâOƒÅ‰|$ÂFƒý ‰D$‰t$rÙ‹L$0+L$ ‹T$LJ‹SхɉL$0‰St8‹C‹S‹L$(…À‹D$0Pt +ÈQRèë +ÈQRè‹L$X‰C‰A0‹D$ƒÄ ‹K‹T$ …ɉT$0‹Èu'áÿ‹ÐÁâÊ3ÒŠt$Áá‰L$8Ê‹ÐÁêʉL$8;Kt ‹L$LÇAë`3À‰D$3íÇ‹K…É„“‹K…É„ˆƒý s'…ÿ„“¶‹ÍÓâOƒÅ‰|$ÂFƒý ‰D$‰t$rÙ;CtS‹L$LÇAÇ‹ ƒù†dìÿÿ_^]¸þÿÿÿ[ƒÄ8ËL$L‹T$(‰Q ‹T$ ‰y_‰1‰Q^‰k<‰C8]¸[ƒÄ8Ã3À3íÇÇD$4ëÇD$4ýÿÿÿ‹L$L‹T$(‰Q ‹T$ ‰Q‰1‰y‰C8‹C(…À‰k: 654ml k$jincorrect length checkincorrect data checkinvalid distance too far backinvalid distance codeinvalid literal/length codeinvalid distances setinvalid bit length repeatinvalid literal/lengths settoo many length or distance symbolsinvalid code lengths setinvalid stored block lengthsinvalid block typeheader crc mismatchunknown header flags setincorrect header checkinvalid window sizeunknown compression method( 3V‹t$…öt8‹F…Àt1‹N$…Ét*‹@4…Àt P‹F(PÿуÄ‹N‹V(QRÿV$ƒÄÇF3À^øþÿÿÿ^ÃH’SW‹|$ …ÿ„΋_…Û„ËCU‹l$V‹t$…À‹tƒø t^]_¸þÿÿÿ[Ãø u'jjjèUVPè‹KƒÄ;Át ^]_¸ýÿÿÿ[ËGWèƒÄ…Àt^]_Ǹüÿÿÿ[ËC(;è‹{4v&+ðõ‹ÈÁéó¥‹Èƒáó¤‹K(^]_‰K,ÇC 3À[Ã+ý‹Í‹ÑÁéøó¥‹Êƒáó¤^‰k,]_ÇC 3À[Ã_¸þÿÿÿ[ÃG„O„l.ä—‹D$…Àt‹@…Àtö@t‹L$‰H ÇA03ÀøþÿÿÿÃ,œ‹T$‹3À…ÒvCSU‹ÿƒùs8Š0ƒùÛãÿÿÿ¶êÃÿ;ëuAë„Òt3Éë º+Ñ‹Ê‹T$ @;ÂrÃ][‰ÃR¡SU‹l$ …í„à‹]…Û„Õ‹E…ÀW¿u9{ Ün. ¼ŽN ü`Qƒq1  a! ¢A âY ’;y9 Òi) ² ‰I òU+u5 Ê e% ª…E ê] šS}= Úm- º M úSÃ#s3 Æ c# ¦ƒC æ[ –C{; Ök+ ¶ ‹K öW@3w7 Îg' ®‡G î _ žc? Þo/ ¾O þ`Psp0 Á ` ¡€@ áX ‘;x8 Ñh( ±ˆH ñTã+t4 É d$ ©„D é\ ™S|< Ùl, ¹ ŒL ùR£#r2 Å b" ¥‚B åZ •Cz: Õj* µ ŠJ õV@3v6 Íf& ­†F í ^ c~> Ýn. ½ŽN ý`Qƒq1 à a! £A ãY “;y9 Ói) ³ ‰I óU+u5 Ë e% «…E ë] ›S}= Ûm- » M ûSÃ#s3 Ç c# §ƒC ç[ —C{; ×k+ · ‹K ÷W@3w7 Ïg' ¯‡G ï _ Ÿc? ßo/ ¿O ÿA@!  @a`10  Á@     ‹D$S3Û;Ä¥€81…œƒ|$8…‘UV‹t$;óWt|‹l$;ëtt‹|$ƒÿ|kƒÿf9^ ‰^u ÇF ‰^(9^$uÇF$‹F(h0%jPÿV ƒÄ ;Ãu _^]¸üÿÿÿ[ÉF‹Ï‰x$º_Óâ^‰h4‰X0‰X,]Ç@€‰P(3À[Ã_^]¸þÿÿÿ[øúÿÿÿ[ÃO^»Ç@LÇ@T Ç@PÇ@XËD$ƒì SU3í;Å„W‹X;Ý„L‰hÇ ‰k‰k,‹;ÍVW‰L$t‹pë3ö‹C4‹K(‰D$ ‹ƒè ƒø‰t$‰l$‰L$‡¤ ë ¤$I¶ÿ$•‹C…Àt‹T$‹ýƒç‹ÏÓê+ïljT$éW ƒýsF…öu‹L$3¥/Ý.É +½ (k %xK|B€>„0ˆ"Œ! ¨I¬H°G´Finvalid distance too far backinvalid distance codeinvalid literal/length codetoo many length or distance symbolsinvalid distances setinvalid bit length repeatinvalid literal/lengths setinvalid code lengths setinvalid stored block lengthsinvalid block type¸ V‹t$…öt#‹N…Ét‹F$…ÀtQ‹N(QÿЃÄÇF3À^øþÿÿÿ^Ã3R.fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\infback.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S».rdata¦Ìô0I€ >.text»—Bzì[ _zcfree _zcalloc .debug$F.text»ž×m .debug$F.text¸!”Y¨¸z $L2190$L2189c$L21863.rdata ,Ͻ‡ .rdata °–~æÁ .rdata yÔ*ñ .rdata $;Ïù( b $L2020S.rdata poã;p .rdataÚÜL .rdataÄ€I÷Õ.rdata—e @ $L1815ô.rdata3 «BO$L1773‰.rdata£.e*‡$L1765i$L1764T$L1763#$L1762$L2346¨$L1730~$L2345x$L2313”.debug$F.text37cüÛ³ .debug$FÃ?order@?1??inflateBack@@9@9?distfix@?1??fixedtables@@9@9?lenfix@?1??fixedtables@@9@9_inflateBackInit__fixedtables_inflateBack??_C@_0BO@ECPMAOGG@invalid?5distance?5too?5far?5back?$AA@??_C@_0BG@LBKINIKP@invalid?5distance?5code?$AA@??_C@_0BM@FFFLPBBC@invalid?5literal?1length?5code?$AA@??_C@_0CE@GMIGFPBB@too?5many?5length?5or?5distance?5symb@_inflate_fast??_C@_0BG@GMDFCBGP@invalid?5distances?5set?$AA@??_C@_0BK@BMMPFBBH@invalid?5bit?5length?5repeat?$AA@??_C@_0BM@IIMGAINC@invalid?5literal?1lengths?5set?$AA@??_C@_0BJ@HDEPPGOH@invalid?5code?5lengths?5set?$AA@_inflate_table??_C@_0BN@LGAADGOK@invalid?5stored?5block?5lengths?$AA@??_C@_0BD@PJCBIDD@invalid?5block?5type?$AA@_inflateBackEnd/393 1171549760 100666 12326 ` L>@nÔEõ À.drectve,Ä .debug$S¸ð @B.rdata¨ @0@.texta°   P`.debug$F% 5 @B.textg? ¦  P`.debug$Fº Ê @B.textVÔ * P`.debug$F˜ ¨ @B.textª² \ P`.debug$F¶Æ@B.textNÐ P`.debug$F.@B.textÌ8 P`.debug$F"2@B.textp<¬ P`.debug$FÊÚ@B.text+ä P`.debug$F)@B.text*3] P`.debug$Fgw@B.textÐQ P`.debug$Feu@B.text2± P`.debug$FÅÕ@B.texteßD P`.debug$Fbr@B.text,| P`.debug$F¨¸@B.text P`.debug$F×ç@B.text*ñ P`.debug$F%5@B.text8?w P`.debug$FŸ¯@B.textE¹þ P`.debug$F&6@B.text@^ P`.rdataÂ@0@.rdataÅ@@.debug$FÆÖ@B.text#à P`.debug$F @B.textE'l P`.rdata@0@.rdata+@0@.debug$F1A@B.textK_ P`.debug$Fiy@B.text:ƒ½ P`.rdataÛ@0@.debug$Fãó@B.textŸýœ P`.debug$F @B.text&$J P`.debug$FTd@B.textUnà P`.debug$FÍÝ@B.text‚çi  P`.debug$F¥ µ @B.text¿ Ñ  P`.debug$FÛ ë @B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" x qc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\gzio.obj8 Ž Ž!Microsoft (R) Optimizing Compiler‹V‹t$…ötQ€~\wuK‹F…Àu/‹N@‹FHQh@jP‰F èƒÄ=@tÇF8ÿÿÿÿÇF@‹T$‹D$ RPVèƒÄ ^øþÿÿÿ^Ã)Qa‹F<…ÀtƒÈÿËF…ÀuGèÇ‹F@‹NDPh@jQèƒÄ…À‰Fu‹V@ÇF<ŠJ ƒÈÿöÁ t‰F8ËFD‰ÿN‹Š@‰¶ÁÃ-gV‹ðW‹~ƒÿsd…ÿt ‹‹NDŠˆèÇ‹F@‹ÏP‹FDº@ÓúÇRjPèƒÄ…Àu‹N@öA tÇF8ÿÿÿÿ‹VЋƒø‰V‹VD‰s_‰FX^Ë€8…Ñ€x‹…Ç‹NƒÁþƒÀS‰N‰è‹øèƒÿ‹Ø…–öÃà…¿¤$èOuøöÃt$è‹øèÁàø‹ÿ‹ÇO…Àt èƒøÿuïöÃtè…ÀtƒøÿuòöÃt¤$è…ÀtƒøÿuòöÃt ¿èOuø‹N<÷ÙÉ[ƒáý_‰N8^Ã[_ÇF8ýÿÿÿ^Ã_ÇFX^Ã;•œÁÎÕè÷)VW3ÿ…öu¸þÿÿÿ_ËFP…Àt PèƒÄ‹F…ÀtŠF\VUUeT‹D$…Àt!€x\ru‹H<…Ét¸ËP83Ƀú”Á‹ÁÃ3ÀÃ,[‹D$…Àt €x\ru‹@XÃ3ÀÃ`VW‹ð¿¤$‹Æ%ÿSPèƒÄÁîOué_^Ãf*eVW‹ðè‹øèÁàøèÁàøèƒøÿuÇF8ýÿÿÿÁàÇ_^à  8kV‹t$…öu¸þÿÿÿ^À~\wu(j‹ÆèƒÄ…Àu‹FLS‹^@è‹Fd‹^@è[è^ÃI.e9e?#EpS‹\$…Ûu‹D$ Çþÿÿÿ¡[ËC8…À‹L$ ‰u¸[ÃøÿUuè‹RèƒÄ‹èë‹k…ít€}u‹C8Áà¹+È‹)‹CP…Àt PèƒÄ‹CTP›Š@„Éuù+‹ЋÅVpŠ@„Éuù+ÆTRèƒÄ…À‰CPu ¡^][ËST›Š Bˆ@„ÉuöW‹{POŠGG„Àuøf¡f‰Š ‹ÅˆO‹È‹ÿŠ@„Òuù‹{P+Á‹ñOŠOG„Éuø‹ÈÁéó¥‹Èƒáó¤‹CP_^][Ã~(}5=z\~m' y¯~Úxãx: u‹D$3É;Átƒx8t‰H8‰H<‹@@‰D$éÄ#ƒƒìXSL$ U3Û‰L$ ‹L$dƒÍÿ;ËW‰\$ ‹ø„;ÄVjtè‹ðƒÄ;ó„4SSS‰^ ‰^$‰^(‰^D‰‰^H‰^ ‰^‰^‰^@‰^8‰^<‰^d‰^h‰nlè‰FL‹D$xƒÄ ‰^P‰^XP¤$Š@:Ëuù+Â@PèƒÄ;ÉFT„ËL$l‹ÐŠAˆB:Ãuöˆ^\±r8uˆN\Š: Ÿ‹D$U‹l$…íV‹ð„ƒ€}\r…y‹M8ƒùý„gƒÊÿ;Ê„\ƒùu^3À]ÃSW‹|$…ÿ‹Ø‰E ‰}t:‹Ml;Êt3ˆ‹u‹MhX‹E @N‰E ‹EpA…À‰u‰Ul‰Mh‹ót _[¸^‰E8]ËE…À„Àë¤$‹EX…À…‹E…ÀuJ‹E<…ÀuCèÇ‹U@‹EDRh@jPèƒÄ…À‰Eu‹M@ÇE<öA …Y‹UD‰U‹Md‹E‹UhȉMd‹MÑjU‰Uhè‹U‹Md+Ê‹Uh‰Md‹M+уăø‰E8‰UhuU‹U ‹EL+ÖRVPè‹u ‰ELƒÄ ‹Åè;ELuV‹Åè‹Åè‹E8…À…ÝUèjjjèƒÄ‰EL‹E8…À…»‹E<…À…°‹E…À…ïþÿÿé ÇE8ýÿÿÿ锋E‹M;Áv‹Á…Àv7‹u‹} ‹È‹ÑÁéó¥‹Êƒáó¤‹u‹U‹M‹|$Øð+Ð+ȉ] ‰u‰U‰M‹E…Àv‹M@QPjSè‹MƒÄ+ȉM‹u‹Ud‹Mh+þ×Ï…ÿ‰Ud‰MhuÇE<‹Ç_[^]ÃÇE8ÿÿÿÿ‹U ‹EL+ÖRVPè‹MƒÄ ;ù‰ELu‹m8ƒýýtƒýÿu_[^ƒÈÿ]ËÇ_[^+Á]Ã^ƒÈÿ]Ã^¸þÿÿÿ]úÔ©G2Wkckj{V†2b2Ÿ ¨Q‹L$jD$PQèƒÄ ƒøu¶D$YÃÈÿYè&®UV‹t$…öW‹îtB‹|$…ÿ~:S‹\$›O…ÿ~jVSèƒÄ ƒøuŠF< uã;îÆ[u…ÿ_^‹Å]Ã_^3À]Ã*¨U ³V‹t$…ö„p‹L$ƒù„c‹F8ƒøÿ„Wƒøý„N€~\wWuk…ÉS‹\$u+^d…Û}[_ƒÈÿ^ËFD…Àuh@è‹øƒÄ…ÿ‰~Dtܹ3Àó«…Û~#¸@;Ø}‹ÃP‹FDPVèƒÄ …Àt²+Ø…ÛÝ‹Fd[_^Ãù‹|$u~h…ÿ}_ƒÈÿ^ËFX…Àt1‹V@‹NDjWRÇFlÿÿÿÿÇF‰èƒÄ …À|͉~h‰~d‹Ç_^ËFh;ø|+øë VèƒÄ…À|ª…ÿtl‹FH…Àuh@èƒÄ…À‰FHt‹ƒ~lÿt‹Vh‹FpBO…ÀÇFlÿÿÿÿ‰VhtÇF8…ÿ~*I¸@;ø}‹ÇP‹FHPVèƒÄ …ÀŽ@ÿÿÿ+ø…ÿÙ‹Fh_^ÃÈÿ^ÃZy‰1ÙUüTyb¨‚¸‹D$jjPèƒÄ à ¸½.fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\gzio.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S¸.rdata½ß.texta‹V¸·  _fwrite .debug$F.textgx2.z* _fread __errno .debug$F.textV Ö?š€4 .debug$F .text ª ݇aC_destroy _fclose B N _free .debug$F  .text N§T3Z .debug$F  .textÌèn¤M_gzwrite _crc32 _deflate .debug$F.textp–c¼ d n __chkstk .debug$F.text+} Ú_gzputc .debug$F.text*‘GÆ8_gzputs .debug$F.textÐðÚ@Àz .debug$F.text2…T´‚_gzflush _fflush .debug$F.texte˜Ì„ _fseek Ž .debug$F.text,ÁrP¿_gzeof .debug$F.text‡†š‹œ .debug$F.text *­ìì_putLong _fputc .debug$F! .text"8ˆÇ¸ñ_getLong" .debug$F#".text$Eló+ _gzclose$ .debug$F%$.text& sxòo_gzerror& .rdata'äDx¼¦'_malloc Á .rdata(Ë(â.debug$F)&.text*#ù·Û¬ì* ø .debug$F+*.text,EÄÝ°z_gz_open, _ftell _fprintf .rdata-'©úç-__fdopen _fopen M \ .rdata.{M-k..debug$F/,.text0å’i_gzopen0 .debug$F10.text2:«ôÜG_gzdopen2 _sprintf .rdata3 õÛ‰3.debug$F42.text5Ÿ ï .d_gzread5 _inflate .debug$F65.text7&DƒÿR_gzgetc7 .debug$F87.text9U3MM_gzgets9 .debug$F:9.text;‚à0ý+_gzseek; .debug$F<;.text=çÓñŠ_gztell= .debug$F>=±_gz_magic_gzsetparams_deflateParams_get_byte_check_header_inflateEnd_deflateEnd_gzungetc_gzprintf__vsnprintf_do_flush_gzrewind_inflateReset_gzdirect??_C@_02LMMGGCAJ@?3?5?$AA@_strerror??_C@_00CNPNBAHC@?$AA@_z_errmsg_gzclearerr_clearerr??_C@_0BF@FJABJDFD@?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$CFc?$AA@_inflateInit2__deflateInit2_??_C@_05GDHACFMB@1?42?43?$AA@??_C@_07EBNKNFJN@?$DMfd?3?$CFd?$DO?$AA@/426 1171549760 100666 14227 ` L-@nÔE,ˆ.drectve, .debug$S»H@B.rdata¶¹ @@@.text $  P`.debug$F. > @B.text%H P`.debug$Fm } @B.text<‡ P`.debug$FÃ Ó @B.text=Ý P`.debug$F * @B.text;4 o  P`.debug$Fy ‰ @B.text'“ P`.debug$Fº Ê @B.textdÔ P`.debug$F8 H @B.textcR µ P`.debug$F×ç@B.textÆñ P`.debug$F·Ç@B.text§Ñx P`.debug$F‚’@B.textwœ P`.debug$F'7@B.text‘AÒ P`.debug$F@B.textÀ P`.debug$FÞî@B.text ø P`.debug$F@B.text): P`.debug$Fl|@B.textš† " P`.debug$Fz"Š"@B.text”"¬& P`.debug$F$'4'@B.text‘>'Ï' P`.debug$F÷'(@B.textÙ(ê( P`.debug$F0)@)@B.text8J)‚+ P`.debug$F´+Ä+@B.text%Î+ó+ P`.debug$Fý+ ,@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" { tc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\deflate.obj8 Ž Ž!Microsoft (R) Optimizing Compiler deflate 1.2.3 Copyright 1995-2005 Jean-loup Gailly   €€ € € 1.2.3@`LfXfdfpn|nˆn”n n¬n‹D$…ÀSUVW‹|$‹ï„ç‹X…Û„Ü‹t$…ö„ЋKƒù„ăùu ƒ{*…µ‹K…Ét‹@0WVPè‹L$ ƒÄ ‰A0ƒÿ‚‰‹C,úþÿÿ;øv‹è+ý÷‹{8‹Í‹ÑÁéó¥‹Êƒáó¤‹S8‹KX‰kl‰k\¶‰CHÓà¶J3Á#CT‰CH3Òuý‹{H‹KX‹C8¶D‹k4Óç‹KT3Ç#Á‹KD‰CHf‹A‹ú#ý‹k@f‰D}‹KH‹CDf‰HB;ÖvÁ_^]3À[Ã_^]¸þÿÿÿ[ÃV ‹D$…Àt‹@…Àtƒxu ‹L$‰H3ÀøþÿÿÿÃ%‹D$…Àt.‹H…Ét'‹Ñ‹L$‰Š¼‹@ºÓâ‹L$ J#Ñf‰¸3ÀøþÿÿÿÃ<‹D$…Àt/‹@…Àt(‹L$‹T$ ‰ˆŒ‹L$‰€‹T$‰ˆ‰P|3ÀøþÿÿÿÃ=#‹T$B?ÁèJÁéÂD ‹L$…Ét‹I…Étƒy0uƒyPu RèƒÄÃ3);(V‹p‹ÑW‹xÁêˆ>‹P‹pB‰Pˆ 2‹HA_‰H^Ã'.‹HV‹p‹V;Ñv‹Ñ…ÒtN‹vSW‹x ‹Ê‹ÙÁéó¥‹Ëƒáó¤‹x ‹Hú‰x Q‹X‹x‹HÚ‰X+ú‰x)Q‹@‹H…É_[u‹H‰H^Ãd3U‹l$…íV„M‹u…ö„B‹L$ƒù5…ÉŒ-‹E …À„ƒ}u ‹E…À… ‹F=šu ƒù…ö‹U…Òu¡‰E^¸ûÿÿÿ]Ãø*‹V(SW‰.‰T$‰N(»…Ô9^…/jjjè‰E0‹N‹FÆ‹F‹VƒÄ @‰FÆ‹‹~‹NG‰~‹ÇÆ‹V‹FB…À‰V‹ú…–‹Vˆ‹~‹NG‰~‹ÇÆ‹VB‰V‹Â‹VÆ‹NA‰N‹Á‹NÆ‹F‹V@‰FÆ‹~‹†„Gƒø ‰~‹Ïu‹Ãë9žˆ};Ã|3À븋Vˆ‹NA‰N‹Á‹NÆ ÿFÇFqéè‹P$‹H,…Ò”Âþʃâ…É”ÁþÉ#ËÑ‹H…É”ÁþɃáÑ‹H…É”ÁþɃáу8‹N•ÀЈ‹~‹V‹NG‰~ŠR‹Çˆ‹V‹NB‰VŠI‹Â‹Vˆ ‹N‹VA‰NŠR‹Á‹Nˆ‹F‹N‹V@‰FŠIˆ ‹~‹†„Gƒø ‰~‹Ïu‹Ãë9žˆ};Ã|3À븋Vˆ‹^‹N‹VC‰^ŠI ‹Ãˆ ‹~‹FG‰~‹P…Ò‹Ït'Š@‹Vˆ‹N‹VA‰N‹Á‹NŠIˆ ‹F@‰F‹È‹V‹B,…Àt‹FQ‹M0PQèƒÄ ‰E0ÇF ÇFE霋N0‹†ˆƒéÁá Á;Ã}$‹†„;Ã|ƒø}¸ë3Òƒø•ÂÓ‹Âë3ÀÁà È‹Fl…ÀtƒÉ ‹Á3Ò¿÷÷‹ÆÇFq+ÊÏè‹Fl…Àt·M2‹Æè‹M0áÿÿèjjjèƒÄ ‰E0ƒ~E…Õ‹F‹H…É„À‹@‹V ‹N%ÿÿ;Ðss‹ÿ‹F;F u7‹V‹z,…ÿt;Áv+ÁP‹FÁ‹M0PQèƒÄ ‰E0‹Åè‹F;F ‹Èt2‹V‹R‹~ Š:‹^ˆ‹F‹^ @C‰F‰^ ‹F‹Pâÿÿ‹Ã;Âr‹F‹P,…Òt‹F;Áv‹V+ÁP‹E0ÑRPèƒÄ ‰E0‹N‹V ;QuÇF ÇFIƒ~I…²‹F‹H…É„‹~‹ÿ‹F;F u7‹N‹Q,…Òt;Çv‹V+ÇP‹E0×RPèƒÄ ‰E0‹Åè‹F;F ‹øt$‹N ‹V‹R¶ A‰N ‹Nˆ‹NA…Û‰NuŸë»‹V‹B,…Àt‹F;Çv‹M0+ÇP‹FÇPQèƒÄ ‰E0…Ûu ‰^ ÇF[ƒ~[…³‹V‹B$…À„ž‹~›‹F;F u7‹N‹Q,…Òt;Çv‹V+ÇP‹E0×RPèƒÄ ‰E0‹Åè‹F;F ‹øt$‹N ‹V‹R$¶ A‰N ‹Nˆ‹NA…Û‰NuŸë»‹V‹B,…Àt‹F;Çv‹M0+ÇP‹FÇPQèƒÄ ‰E0…ÛuÇFgƒ~gue‹V‹B,…ÀtT‹F‹N ƒÀ;Áv‹Åè‹F‹V H;Êw:ŠM0‹Vˆ ‹N‹VA‰N‹ÁŠM1ˆ ‹Fj@jj‰FèƒÄ ‰E0ÇFq‹F…Àt‹Åè‹E…Àu7ÇF(ÿÿÿÿ_[^3À]ËE…À‹\$u";\$ƒût‹_[^‰U¸ûÿÿÿ]Ë\$‹F=š‹Mu…Ét¡_[‰E^¸ûÿÿÿ]Ã…Éu‹Nt…Éu…Û„¢=š„—‹†„S @VÿƒÄƒøtƒøuÇFš…À„Tƒø„Kƒøu[;Øu VèƒÄë:jjjVèƒÄƒûu&‹VL‹FDfÇDPþ‹NL‹~DL þ‹ÑÁé3Àó«‹Ê#Ëóª‹Åè‹E…À„íþÿÿƒû…ëþÿÿ‹F…À _[^¸]Ãø…‹NŠU0‹Fˆ‹V‹NB‰V‹ÂŠU1ˆ‹NA‰NŠU2‹Á‹Nˆ‹F‹N@‰FŠU3ˆ‹^‹NC‰^ŠU‹Ãˆ‹~‹NG‰~ŠU ‹Çˆ‹V‹NB‰V‹ÂŠU ˆ‹NA‰NŠU ‹Á‹NˆÿFë·M2‹Æè‹M0áÿÿè‹Åè‹F…À~÷؉F‹N_[3À…É^”À]ËE…À…þýÿÿ_[ÇF(ÿÿÿÿ^3À]á‰E^¸þÿÿÿ]Ãe< ;«;/.A.O.Z´;Á3 ;„;‘3ç;D;Q3§;Ü3;13b<‰<Æú: 9@3..3T<c8V‹t$…ö„²‹F…À„§W‹xƒÿ*t)ƒÿEt$ƒÿItƒÿ[tƒÿgtƒÿqtÿšt_¸þÿÿÿ^Ë@…Àt P‹F(PÿV$ƒÄ‹N‹AD…Àt ‹V(PRÿV$ƒÄ‹F‹@@…Àt ‹N(PQÿV$ƒÄ‹V‹B8…Àt P‹F(PÿV$ƒÄ‹N‹V(QRÿV$ƒÄ3Àƒÿq•À_ÇF^Hƒàýøþÿÿÿ^ÃÆAUV‹t$…ö„‘‹l$ …í„…‹F…À‰D$„vSW¹‹ýhÀó¥‹E(jPÿU ‹ØƒÄ …Û„F‹t$‰]¹°‹ûó¥‹K,j‰+‹U(QRÿU ‰C8‹C,‹M(jPQÿU ‹SLj‰C@‹E(RPÿU ‹‹œj‰CD‹U(QRÿU ‹{8ƒÄ0…ÿ‰C„Ú‹K@…É„Ï‹KD…É„Ä…À„¼‹K,‹T$‹r8Ñá‹éÁéó¥‹Íƒáó¤‹r@‹K,‹{@Ñá‹éÁéó¥‹Íƒáó¤‹rD‹KL‹{DÑá‹éÁéó¥‹Íƒáó¤‹r‹K ‹{‹éÁéó¥‹Íƒáó¤‹z‹J‹s+ÏΉK‹‹œ‹ÑÑêPNщƒ¤‰“˜ƒ”‹ˆ “| _‰ƒ ‰‹$ ‰“0 [^3À]ÃUèƒÄ_[^¸üÿÿÿ]Ã^¸þÿÿÿ]ÃŽA§F‹CU‹è;év‹é…íu3À]Ã+ʼnC‹C‹@ƒøu‹ ‹S0UQRèëƒøu‹‹K0UPQèƒÄ ‰C0V‹3W‹|$‹Í‹ÑÁéó¥‹Êƒáó¤‹C‹ Å_͉C^‹Å‰ ]Ã-A;wK‹B,‹JLÑà‰B<‹BDSV3öf‰tHþ‹JLL þ‹ÙÁéW‹zD3Àó«‹Ëƒá󪋂„@Áà·ˆ‰Š€·ˆ‰ŠŒ·ˆ‰Š·€_‰B|‰rl‰r\‰rt¸‰rh‰rH^‰Bx‰B`[éAN[hQ‘$P‹N8‹FlSŠU‹l$ Š)ÁÍ:ÓW¸…’ŠQ:P…†ƒÀƒÁŠPŠY@A:ÓuXŠPŠY@A:ÓuLŠPŠY@A:Óu@ŠPŠY@A:Óu4ŠPŠY@A:Óu(ŠPŠY@A:ÓuŠPŠY@A:ÓuŠPŠY@A:Óu;Çrœ+ǃø|‹Nt;Á‰npv _]‹Á[ø_][ÃÀVSU‹l$ ‹E,VW‰D$ë‹D$‹Ut‹]<‹Ml+Ú‹U,”úþÿÿ+Ù;Êro‹}8‹È‹ÑÁé4ó¥‹Êƒáó¤‹up‹Ul‹M\+ð+Ð+ȉup‹uL‰M\‹MD‰Ulq·Jþƒê;Èr+Èë3ÉNf‰ ué‹U@‹ðB·Jþƒê;Èr+Èë3ÉNf‰ uéØ‹E‹H…Ét_‹Mt‹Ul‹}8ÊÏQ‹Ë‹Øè‹Mtȋуăú‰Mtr ‹El‹M84¶‹MX‰EHÓà¶N3Á#ET‰EHús‹U‹B…À… ÿÿÿ_^][üK [QS‹\$ ‹C UƒÀû=ÿÿVWÇD$ÿÿs‰D$‹CtƒøwSè‹CtƒÄ…À„h‹KlÈ‹D$‰Kl‹K\‹SlÇCtt;Ђ–+ЅɉSt‰Cl|‹S8Ñë3Òj+ÁPRSè‹Kl‹‰K\‹p‹V‹HƒÄ;Ñv‹Ñ…ÒtJ‹v‹x ‹Ê‹éÁéó¥‹Íƒáó¤‹x ‹Hú‰x Q‹h‹x‹Hê‰h+ú‰x)Q‹@‹H…Éu‹P‰P‹‹H…É„¤‹S\‹Kl‹C,+Ê-;È‚ÿÿÿ…Ò|‹C8Âë3ÀjQPSè‹Kl‹‰K\‹p‹V‹HƒÄ;Ñv‹Ñ…ÒtJ‹v‹x ‹Ê‹éÁéó¥‹Íƒáó¤‹x ‹Hú‰x Q‹h‹x‹Hê‰h+ú‰x)Q‹@‹H…Éu‹P‰P‹‹H…É…„þÿÿ_^]3À[YË|$…ÿtð‹s\…ö|‹C8Æë3À‹Sl3Ƀÿ”Á+ÖQRPSè‹Cl‰C\‹ƒÄè‹ ‹A…Àu3Àƒÿ•À_^][HƒàYÃ3Àƒÿ”À_^][DYÃ,[a%aÐaà3`QSU‹l$VW3ÿ‰|$‹\$‹Et=s#Uè‹EtƒÄ=s…Û„õ…À„õƒørO‹EH‹MX‹Ul‹u4Óà‹M8¶L3Á#ET‹MD‰EHf‹A#ò‹U@f‰r‹E4‹Ml‹U@#È·ÇF‰n,‰VX‹W(URÿW ‰F8‹F,‹O(jPQÿW ‹VLj‰F@‹G(RPÿW ‰FDK¸Óàj‰†œ‹O(PQÿW ‹Žœ‰V ‹V8ƒÄ0…Ò‰FtP‹V@…ÒtI‹VD…ÒtB…Àt>‹ÑÑêPHÁ‹L$‰–¤‹T$(W‰†˜‰Ž„‰–ˆÆF$èƒÄ^[_]ÃÇFš¡W‰GèƒÄ^[_¸üÿÿÿ]Ã[_¸þÿÿÿ]øúÿÿÿ]ÃD€Sús<A8 ~‹D$‹L$ ‹T$P‹D$QjjjjRPèƒÄ Ã~%….fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\deflate.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S».rdata¶ Q¥Y°'8<.textÿä-ÎO _adler32 .debug$F.text%p'x+e .debug$F.text<û¯<¡w .debug$F .text ==ëîý… .debug$F  .text ;ÏtG§’   .debug$F  .text'a‘¯ .debug$F.textdɼ$K¼ .debug$F.textc“h©&_deflate Ë Ý _crc32 è.debug$F.textÆ5Iz!ò .debug$F.text§º„þ .debug$F.textwr iÕ  .debug$F.text‘Kçͱ_lm_init  .debug$F.textÀ¢ô ó! .debug$F.text Ù­ 5 .debug$F.text {ø\B R .debug$F! .text"š ¾l c" q}‹ .debug$F#".text$ ÎÊš$ .debug$F%$.text&‘ÎW7¨& ¶ .debug$F'&.text(Ùs4#¶À( .debug$F)(.text*8TWŸÏ* _zcfree _zcalloc .debug$F+*.text,%ô’4¸Þ, .debug$F-,ì?my_version@?1??deflateInit2_@@9@9_configuration_table_deflate_copyright_deflateSetDictionary_deflateSetHeader_deflatePrime_deflateTune_deflateBound_compressBound_putShortMSB_flush_pending__tr_stored_block__tr_align_z_errmsg_deflateEnd_deflateCopy_read_buf_match_init_longest_match_fast_fill_window_deflate_stored__tr_flush_block_deflate_fast__dist_code__length_code_longest_match_deflate_slow_deflateReset__tr_init_deflateParams_deflateInit2__deflateInit_ /462 1171549760 100666 13046 ` L@nÔE/1.drectve,¼ .debug$S¹è@B.rdata ¡@@@.text¡#§# P`.debug$F±#Á#@B.textÒË#&& P`.debug$F()(@B.text3(L+& P`.debug$FÈ,Ø,@B.textâ, P`.debug$Fù, -@B.text;- P`.debug$FN-^-@B.textGh-¯. P`.debug$FÃ.Ó.@B.textÝ.õ. P`.debug$Fÿ./@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" y rc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\crc32.obj8 Ž Ž!Microsoft (R) Optimizing Compiler–0w,aîºQ ™Ämôjp5¥c飕dž2ˆÛ¤¸ÜyéÕàˆÙÒ—+L¶ ½|±~-¸ç‘¿d·ò °jHq¹óÞA¾„}ÔÚëäÝmQµÔôÇ…ÓƒV˜lÀ¨kdzùbýìÉeŠO\Ùlcc=úõ È n;^iLäA`Õrqg¢Ñäjm ¨Zjz Ïäÿ “'® ±ž}D“ðÒ£‡hòþÂi]Wb÷Ëge€q6lçknvÔþà+Ó‰ZzÚÌJÝgoß¹ùùﾎC¾·ÕŽ°`è£ÖÖ~“Ñ¡ÄÂØ8RòßOñg»ÑgW¼¦Ýµ?K6²HÚ+ ØL ¯öJ6`zAÃï`ßUßg¨ïŽn1y¾iFŒ³a˃f¼ Òo%6âhR•w ÌG »¹"/&U¾;ºÅ( ½²’Z´+j³\§ÿ×Â1Ïе‹žÙ,®Þ[°Âd›&òc윣ju “m© œ?6ë…grW‚J¿•z¸â®+±{8¶ ›ŽÒ’ ¾Õå·ïÜ|!ßÛ ÔÒÓ†BâÔñø³ÝhnƒÚ;[&¹öáw°owG·æZˆpjÿÊ;f\ ÿžei®bøÓÿkaEÏlxâ  îÒ ×TƒN³9a&g§÷`ÐMGiIÛwn>JjÑ®ÜZÖÙf ß@ð;Ø7S®¼©Åž»ÞϲGéÿµ0ò½½ŠÂºÊ0“³S¦£´$6к“×Í)WÞT¿gÙ#.zf³¸JaÄh]”+o*7¾ ´¡Ž ÃßZï-A1‚b62ÃS-+ÅldEôw}†§ZVÇ–AOŠÙÈI»ÂÑŠèïúËÙôã Oµ¬M~®µŽ-ƒžÏ˜‡QÂJ#ÙSÓpôx’AïaU×®.æµ7×µ˜–„ƒY˜‚©›Ûú-°šË6©]]wællÿß?AÔžZÍ¢$„•ãŸŒ F²§aw©¾¦áèñçÐóè$ƒÞÃe²ÅÚª®]]ëŸFD(Ìkoiýpv®k19ïZ* ,  m8ó6Fß²]ÆqTpí0ekô÷ó*»¶Â1¢u‘‰4 û¼Ÿº„yÞ©%8ï²<ÿyós¾Hèj}ÅA<*ÞXOyðD~bé‡-OÂÆTÛŠ”@»ƒè#¦ÂÙ8¿ Å 8Lô»!§– Ζ Ì\H1×E‹búnÊSáwT]»ºl £Ö?ˆ—–‘P˜×Þ©ÌÇÒúáì“Ëúõ\×bræykÞµT@Ÿ„OYX#Úp8$›A#=§kýeæZæ|% ËWd8ÐN£®‘⟊!̧3`ý¼*¯á$­îÐ?´-ƒŸl² †«$HÉêSÐ)F~ûhweâöy?/·H$6t 5*ò¼SK³HRpÞey1ï~`þóæç¿Âýþ|‘ÐÕ= ËÌú6Šƒ»‘šxT¼±9e§¨K˜ƒ; ©˜"Éúµ ˆË®O]ï_lôFÍ?ÙmŒÂtCZó#AêÁplÁ€AwØG×6—æ-ŽÅµ¥„„¼ŠAq[»Zh˜èwCÙÙlZO-_~6 œ-'Ý>˜¹S1ƒ b®‹ÑSµ’ÅôÝWôïÄ”§ÂïÕ–Ùöé¼®¨·kÞ1œ*ï*…íykʬHpÓo]ø.*Fáá6Þf ÅcTèT"eóMåó²¤Â©g‘„0& Ÿ)¸®ÅäùŸÞý:ÌóÖ{ýèϼk©€ýZ²™> Ÿ²8„«°$,ñ52F*sw1´ápHõÐkQ6ƒFzw²]cN×úËæáÒ̵Ìù„×àJ–¯ #¶Èp ‰A»„F]#l8Ä?1…(B˜Og©T~ÀúyUËbLÅ8^ô#˜§³Ü–ªTåZ1Oü™bb×ØSyÎOáIV~úP•-×{ÔÌbŠ-R»–4‘è»ÐÙ ìó~^­ÂeGn‘Hl/ Suè6:© #jT$+e?äy§–¥H¼f‘¤'*Š½à¼Ëò¡ÐëbÞýÀ#ïæÙ½á¼üЧ ?ƒŠ&~²‘?¹$ÐpøËi;FæBzwý[µkeÜôZ~Å7 Sîv8H÷±® ¸ðŸ¡3Ì?Šrý$“7jÂnÔ„Y¾Fܨ ëÂ˲|…O¸Q;ÑÖ…— áïU dù S“Ø -ž =G\ p£&GÉäw¢)`¬ /›aíÂß«õµiÈò5ÿ˜÷¦&±‘LsZ<#0þzŽ¸MäzàFM8×,9Ž’É;¹ø :<îD? „†>R:À(ôq-Ãv³,šÈõ.­¢7/Àšp÷çXq®Ys™3Ür%“w+OQvrñtE›Õux܉~O¶K }!bÏ|¤t€y“BxÊ zýÊÆ{°.¼l‡D~mÞú8oéúnl†µk[ìwjR1h58ói¯b?mcf«+aQÁé`Ôצeã½ddº"fiàg Ë×H¡INSKyu‘JücÞOË N’·ZL¥Ý˜M˜šÄF¯ðGöN@EÁ$‚DD2ÍAsX@*æIBŒ‹CPhñTg3U>¼uW Ö·VŒÀøS»ª:Râ|PÕ~¾Qè9âZßS [†ífY±‡¤X4‘ë]û)\ZEo^m/­_€5á·q÷àîϱâÙ¥sã\³<ækÙþç2g¸å zä8J&ï äîVž¢ìaô`íäâ/èÓˆíéŠ6«ë½\iêð¸ýÇÒÑüžl—þ©Uÿ,úzØûBÄžùu®\øHéóƒÂò&=„ðWFñ”A ô£+Ëõú•÷ÍÿOö`]xÙW7ºØ‰üÚ9ã>Û¼õqÞ‹Ÿ³ßÒ!õÝåK7ÜØ k×ïf©Ö¶ØïÔ²-Õ¤bÐ3ΠÑjpæÓ]$Òþ^Å'”œÄ~*ÚÆI@ÇÌVWÂû<•Ã¢‚ÓÁ•èÀ¨¯MËŸÅÊÆ{ÉÈñ ÉtDÌCm†ÍÓÀÏ-¹Î@–¯‘wüm.B+’(é“œ>¦–«Td—òê"•Å€à”øǼŸÏ­~ž–8œ¡yú$oµ˜w™J»1›}Ñóš05‰_KŒ^á Ži‹Ï쀊Û÷B‹‚I‰µ#ƈˆdšƒ¿X‚æ°€ÑÚÜTÌ“„c¦Q…:‡ rÕ† Ðâ©—º ¨Îfªùn¤«|xë®K)¯¬o­%Æ­¬ñ§/ë3¦vUu¤A?·¥Ä)ø óC:¡ªý|£—¾¢Ðsĵç´¾§@¶‰Í‚· ÛͲ;±³bI±Ue‹°h"×»_HºöS¸1œ‘¹´ŠÞ¼ƒà½Ú^Z¿í4˜¾eg¼¸‹È ªî¯µW—b2ðÞ7Ü_k%¹8×ï(´ÅŠO}dà½o‡׸¿ÖJÝØjò3wßàVcXŸWPú0¥èŸúqø¬BÈÀ{ß­§ÇgCru&oÎÍp­•-û·¤?žÐ‡'èÏBs¢¬ Æ°ÉGz>¯2 [ÈŽµg; Ї²i8P/ _ì—âðY…‡—å=ч†e´à:ÝZOÏ?(3w†äêãwXR Øí@h¿Qø¡ø+ðÄŸ—H*0"ZOWžâöoI“õÇ}§@ÕÀümNП5+·#Å–Ÿ *'Gýº| A’ô÷èH¨=X›X?¨#¶1Ó÷¡‰jÏv¨Ê¬á¾„`ÃÒp ^·æY¸©ô<ßL…çÂÑà€~i/Ë{kHwâ ËÇh±s)ÇaL ¸Ùõ˜oDÿÓü~Pfî7ÚVM'¹(@¶Æï°¤£ˆ °Û×g9‘xÒ+ôn“÷&;fšƒˆ?/‘íX“)T`D´1ø ߨMºÏñ¦ìß’þ‰¸.Fg›Tp'ì»HðqÞ/LÉ0€ùÛUçEcœ ?kùǃÓh6ÁrŠyË7]ä®Pá\@ÿTN%˜èösˆ‹®ï7ø@‚'>¼$é!AxU™¯×à‹Ê°\3;¶Yí^ÑåU°~PGÕìÿl!;b F‡Úçé2È‚ŽŽpÔží(±ùQ_Vä‚:1X:ƒ §æn3Á† m¦:µ¤á@½Á†ü/)IJNõ¯óv"2–žŠx¾+˜Ù— KÉôx.®HÀÀýÒ¥fAj^–÷y9*O—–Ÿ]òñ#åkM`~×õŽÑbçë¶Þ_RŽ Â7éµzÙFh¼!¼Ðê1߈Vc0aùÖ"žjš½¦½ØÁ¿6n´­S šNrÿ)Î¥†{·táÇÍÙ’¨¾¬*F8#v¥€ufÆØz`þ®Ïr›ÉsÊ"ñ¤WG–ï©9­ýÌ^EîMvc‰ñÎ&DÜèAødQy/ù4“AÚ±&S¿ÖšëéÆù³Œ¡E bðiL¡¾Q›<Û6'„5™’–Pþ..™¹T&üÞèžq]Œwá4Î.6©«IŠEæ? ƒ»v‘àãö\[ýYéI˜>Uñ!‚lDa>Ԫ΋ÆÏ©7~8AÖ]&Ãn³‰v|ÖîÊÄoÖY ±¡áäóy¨K×i˲w«\¡Â¹9Æ~€þ©œå™$ 6 6nQŽ§f†ÂqÚ>,Þo,I¹Ó”ð •æ¸±{I £.±H>ÒC-YnûÃöÛ馑gQ©°ÌzÎ t”a¹fñÞw0–îa,™ QºmÄpjôéc¥5žd•£Ûˆ2yܸ¤àÕé—ÒÙˆ ¶L+~±|½ç¸-¿‘·dj° òó¹qH„¾AÞÚÔ}mÝäëôÔµQƒÓ…Çl˜Vdk¨ÀýbùzŠeÉì\OclÙú=c õ;n ÈLi^Õ`Aä¢gqr<äÑKÔGÒ …ý¥ µk5µ¨úB²˜lÛ»ÉÖ¬¼ù@2ØlãEß\uÜÖ Ï«Ñ=Y&Ù0¬QÞ:È×Q€¿Ða!´ôµV³Ä#Ϻ•™¸½¥(¸ž_ˆÆ Ù²± é$/o|‡XhLÁa«¶f-=vÜAÛq˜Ò ¼ïÕ*q±…‰¶µŸ¿ä¥è¸Ô3xÉ¢ù4– ¨Žá˜j »m=-‘dl—æc\kkQôlab…e0ØòbNl•í¥{‚ôÁõÄWe°ÙÆ·éP‹¾¸êü¹ˆ|bÝßÚ-IŒÓ|óûÔLeM²aX:µQΣ¼tÔ»0âJߥA=ؕפÑÄmÓÖôûCiéj4nÙü­gˆFÚ`¸ÐD-s3åª L_Ý |ÉPq<'Aª¾ É †Whµ% o…³¹fÔ ÎaäŸ^Þù)Ùɘ°Ð˜"Çר´Y³=.´ ·½\;Àºl­í¸ƒ š¿³¶¶â t±ÒšêÕG9Òw¯Û&s܃ãc ”d;„ mj>zjZ¨äÏ “ ÿ ®'}ž±ð“D‡£ÒòhiÂþ÷bW]€egËl6qnkçþÔv‰Ó+àÚzZgÝJÌù¹ßoŽ¾ïù·¾C`°ŽÕÖÖ£è¡Ñ“~8ØÂÄOßòRÑ»gñ¦¼Wg?µÝH²6KØ +Ú¯ L6JöAz`ß`ïègßU1nŽïFi¾yËa³Œ¼fƒ%oÒ Rhâ6Ì w•» G"¹U&/ź;¾²½ (+´Z’\³jÂ×ÿ§µÐÏ1,Ùž‹[Þ®›d°ìcò&uj£œm“ œ ©ë6?rg…W•¿J‚â¸z{±+® ¶8’ÒŽ›åÕ¾ |Üï· Ûß!†ÓÒÔñÔâBhݳøÚƒn¾Íö¹&[o°wá·GwˆZæÿjpf;Ê \ežÿøb®iakÿÓlÏE  âx× ÒîNƒT9³Â§g&aÐ`÷IiGM>nwÛ®ÑjJÙÖZÜ@ß f7Ø;𩼮SÞ»žÅG²Ï0µÿé½½òʺŠS³“0$´£¦ºÐ6ÍדTÞW)#Ùg¿³fz.ÄaJ¸]h*o+”´ ¾7à Ž¡Zß-ï1A26b‚+-SÃdlÅ}wôEVZ§†OA–ÇÈÙŠÑ»IúïèŠãôÙˬµO µ®~Mžƒ-Ž‡˜ÏJÂQSÙ#xôpÓaïA’.®×U7µæ˜µ×ƒ„–‚˜Y›©°-úÛ©6Ëšæw]]ÿllÔA?ßÍZž•„$¢ŒŸ㧲F ¾©wañèá¦èóÐçÃÞƒ$ÚŲe]]®ªDFŸëokÌ(vpýi91k® *Zï  ,8mßF6óÆ]²ípTqôke0»*ó÷¢1¶‰‘u 4Ÿ¼û„º%©Þy<²ï8sóyÿjèH¾AÅ}XÞ*<ðyOéb~DÂO-‡ÛTÆ”Š»@¦#胿8ÙÂ8 Å !»ôL –§–Î\Ì E×1Hnúb‹wáSʺ»]T£ lˆ?Ö‘–—ÞטPÇÌ©ìáúÒõúË“rb×\kyæ@TµÞYO„ŸX#$8pÚ=#A›eýk§|æZæWË %NÐ8d‘®£ŠŸâ3§Ì!*¼ý`­$᯴?Ð-† ²lÉH$«ÐSêû~F)âewh/?yö6$H· t*5KS¼òRH³yeÞp`~ï1çæóþþý¿ÕБ|ÌË =ƒŠ6úš‘»±¼Tx¨§e9;ƒ˜K"˜© µúɮˈ_ï]OFôlmÙ?ÍtÂŒóZCêA#ÁlpÁØwA€—6×GŽ-極ż„„qAŠhZ»[Cwè˜ZlÙÙ-O 6~_'-œ>ݹ˜ ƒ1S‹®b’µSÑÝôÅÄïôW倫öÙ–Õ®¼é·¨œ1Þk…*ï*ÊkyíÓpH¬ø]oáF*.fÞ6áÅ TèTcMóe"²óå©Â¤0„‘g)Ÿ &äÅ®¸ýÞŸùÖóÌ:Ïèý{€©k¼™²Zý²Ÿ >«„8,$°5ñ*F21wsHpá´QkÐõzFƒ6c]²wËú×NÒáæù̵Ìàׄ¯–J¶#  pÈ„»A‰#]F8l1?Ä(…gO˜B~T©UyúÀLbË8Ř#ô^³§ª–ÜåTüO1Z×bb™ÎySØIáOPú~V{×-•bÌÔ-Š4–»R»è‘ ÙÐ^~óìGe­lH‘nuS /:6è# ©$Tj?e+–§yä¼H¥¤‘f½Š*'ò˼àëСÀýÞbÙæï#¼á½ §Ðü&Šƒ??‘²~pÐ$¹iËøBæF;[ýwzÜekµÅ~ZôîS 7÷H8v¸ ®±¡ŸðŠ?Ì3“$ýrÂj7„ÔnF¾Y ¨ÜËÂë|²O…Q¸Ñ; —…Ö Uïá ùdØ“S ž- \G=&£päÉG¢w`)/ ¬ía›«ßÂiµõ5òÈ÷˜ÿ±&¦sL‘†„ <À:R=Pe6^X7œ}o5ÚÃ64©1W¿„0•Õ³2Ókê3Ý$kå%©§'ï1þ&-[É#bML" '{ æ™"!$ó*x´(+ºÞ)ü`F(> q-qô,³vÃ.õÈš/7¢­pšÀqXç÷sY®rÜ3™w“%vQO+tñruÕ›E~‰ÜxK¶O} |Ïb!y€t¤xB“z Ê{ÆÊýl¼.°m~D‡o8úÞnúékµ†ljwì[h1Rió85b¯cm?a+«f`éÁQe¦×Ôdd½ãf"ºgàiH×Ë I¡KSNJ‘uyOÞcüN ËLZ·’M˜Ý¥FÄš˜Gð¯E@NöD‚$ÁAÍ2D@XsBIæ*C‹ŒTñhPU3gWu¼>V·Ö SøÀŒR:ª»P|âQ¾~ÕZâ9è[ SßYfí†X¤‡±]ë‘4\)û^oEZ_­/má5€à÷q·â±Ïîãs¥Ùæ<³\çþÙkå¸g2äz ï&J8îä 좞Ví`ôaè/âäéíˆÓë«6Šêi\½ý¸ðüÑÒÇþ—lžÿU©ú,ûØzùžÄBø\®uóéHòƒð„=&ñFWô A”õË+£÷•úöOÿÍÙx]`غ7WÚü‰Û>ã9Þqõ¼ß³Ÿ‹Ýõ!ÒÜ7Kå×k ØÖ©fïÔïضÕ-²Ðb¤Ñ Î3ÓæpjÒ$]Å^þÄœ”'ÆÚ*~Ç@IÂWVÌÕ<ûÁÓ‚¢Àè•ËM¯¨ÊÅŸÈÉ{ÆÉ ñÌDt͆mCÏÀÓι-‘¯–@müw’+B.“é(–¦>œ—dT«•"êò”à€ÅŸ¼Çøž~­Ïœ8–úy¡˜µo$™w›1»JšóÑ}‰50ŒK_Ž á^Ï‹iŠ€ì‹B÷Û‰I‚ˆÆ#µƒšdˆ‚X¿€°æÜÚÑ„“ÌT…Q¦c‡:†Õr ©âР¨ º—ªfΫ¤nù®ëx|¯)K­o¬¬­Æ%§ñ¦3ë/¤uUv¥·?A ø)Ä¡:Có£|ýª¢¾—µÄsдç¶@§¾·‚͉²ÍÛ ³±;±Ib°‹eU»×"hºH_¸Sö¹‘œ1¼ÞŠ´½àƒ¿Z^Ú¾˜4í¸¼geª È‹µ¯îb—W7Þð2%k_Ü×8¹Å´(ï}OŠo½àdׇJÖ¿¸òjØÝàßw3XcVPWŸè¥0úúŸB¬øqß{ÀÈgǧ­urCÍÎo&•­p-?¤·û‡ОÏè'¢sB°Æ ¬zGÉ 2¯>ŽÈ[ ;gµ²‡Ð/P8i—ì_ …Yðâ=å—‡e†‡ÑÝ:à´ÏOZw3(?êä†RXwã@íØ øQ¿hð+ø¡H—ŸÄZ"0*âžWOIoöÇõ“Õ@§}müÀ5ŸÐN#·+Ÿ–Å'* ºýGA |ô’¨Hè÷›X=#¨?X1¶‰¡÷ÓvÏj¬Ê¨¾áÃ`„^ pÒæ·ô©¸YLß<ÑÂç…i~€à{Ë/ÃwHkË ¢s±hÇaÇ)Ù¸ LDo˜õüÓÿîfP~VÚ7¹'M¶@(¤°ïÆ ˆ£Û°9g×+Òx‘“nô;&÷ƒšf‘/?ˆ)“Xí´D`T ø1M¨ß¦ñϺþ’ßìF.¸‰T›gì'pqðH»ÉL/ÞÛù€0cEçUk? œÓƒÇùÁ6hyŠrä]7Ë\áP®NTÿ@öè˜%®‹ˆs7ï‚@ø¼>'!é$™UxA‹àׯ3\°ÊíY¶;UåÑ^GP~°ÿìÕb;!lÚ‡F È2éçpŽŽ‚(ížÔQù±‚äV_:X1:§ ƒ3næ †Áµ:¦m½@á¤ü†ÁI)/¯õNJ2"vóŠž–˜+¾x —ÙxôÉKÀH®.ÒýÀjAf¥÷–^O*9y]Ÿ–—å#ñòMkõ×~`çbÑŽ_޶렎Rzµé7hFÙм!¼ˆß1ê0cV"Öùašjž½¦½¿ÁØ­´n6 SrNš¥Î)ÿ·{†Çát’ÙÍ*¬¾¨8F€¥v#ØÆfu`zrÏ®þÊsÉ›W¤ñ"ï–Gý­9©E^ÌvMîÎñ‰cÜD&døAèù/yQA“4S&±ÚëšÖ¿³ùÆé E¡Œðb¡Li<›Q¾„'6Û–’™5..þP&T¹™žèÞüŒ]q4áw©6.ΊI«?æE»ƒ ãà‘v[\öIéYýñU>˜l‚!Ô>aDƋΪ~7©ÏÖA8nÃ&]|v‰³ÄÊîÖYÖoᡱ óäK¨yËi׫w²¹Â¡\~Æ9œ©þ€$™å6 6 ŽQn†f§>ÚqÂ,oÞ,”Ó¹I ð±¸æ•£ I{±.CÒ>HûnY-éÛöÃQg‘¦Ì°©t Îzf¹a”Þñ¸Ã QSV‹ò…ö÷Ðt&ëIöÁt3ÒŠ3Ðâÿ‹•Áè3ÃANu߃þ UW‚‹þÁï3‹ÐÁê¶Ü‹,¶Ò‹•3Ջ؉D$Áë‹,‹Y3Õ%ÿ3… 3Ó‹ÂÁè¶Þ‹,ƒÁ¶À‹…3Å‹Ú‰T$Áë‹,‹Y3Åâÿ3• 3ÃÁ‹ÐÁê¶Ü‹,¶Ò‹•3Ջ؉D$Áë‹,‹Y3Õ%ÿ3… 3ÓƒÁ‹ÂÁè¶Þ‹,¶À‹…‹Ú3ʼnT$Áë‹,‹Yâÿ3Å‹,• ƒÁ3Å3ËЃÁÁê¶Ò‹•‰D$¶Ü3‹ØÁë‹,‹3Õ%ÿ3… 3Ó‹ÂÁè¶Þ‹,¶À‹…3Å‹ÚÁë‹,‹Y3ʼnT$âÿ3• 3ÃÁ‹Ð¶Ü‹,Áê¶Ò‹•‹Ø3Õ‰D$Áë‹,‹Y%ÿ3Õ‹,… ƒÁ3Õ3Ó‹ÂÁè¶Þ‹,¶À‹…‹Ú3ÅÁë‹,‰T$âÿ‹• 3ŃÁ3Ãî O…êýÿÿƒþrH‹ÖÁê3¶Ü‹,‰D$¶|$‹<½‹Ø3ýÁë‹,%ÿ3ý3<… ƒÁƒîJ‹Çu½…ö_]t"›3ÒŠ3Ðâÿ‹•Áè3ÃANuä^÷Ð[YÃ$ N X j { Œ ™ « ½ Ñ Û í þ   . @ Y g s ƒ ” ž ¬ Â Ó à ò   # 1 B i y ‡ • ¿ ÒSV‹ð‹D$ 3ÛŠ|$W‹Ðâÿ‹øÁç×ÁâÓÁèÐ…ö÷Òt!‹ÿöÁt¶9‹ÂÁè3Ç‹…Áâ3ÓANuáƒþ UAü‚"‹þÁï‹X3Ӌʶދ,Áé¶É‹ 3̓À‹Ú‰T$Áë‹,‹X3Íâÿ3 •3Ë‹ÑÁê¶Ý‹,ƒÀ¶Ò‹•3Õ‹Ù‰L$Áë‹,‹X3Õáÿ33ÓƒÀ‹Ê¶Þ‹,Áé¶É‹ ‹Ú3͉T$Áë‹,‹Xâÿ3Í3 •3˃À‹ÑÁê¶Ý‹,¶Ò‹•‹Ù3ÕÁë‹,‹X‰L$áÿ3Õ‹,ƒÀ3Õ3ӋʃÀÁé‰T$¶É¶Þ‹,‹ 3Í‹ÚâÿÁë‹,‹3Í3 •3Ë‹ÑÁê¶Ò‹•¶Ý3‹ÙÁë‹,‹X3Õ‰L$áÿ33ӋʃÀ¶Þ‹,Áé‹Ú¶É‹ ‰T$âÿ3ÍÁë‹,‹•‹P3Í3Ë3ʃÀ‹ÑÁê¶Ý‹,¶Ò‹•‹Ù3ÕÁë‹,‰L$áÿ‹3Õ3Óƒî O…ãýÿÿƒþrL‹ÎÁé‹x3׃À¶Þ‹,‰T$¶|$‹<½‹Ú3ýÁë‹,âÿ3ý3<•ƒîI‹×u¹ƒÀ…ö]t¶8‹ÊÁé3Ï‹Áâ3Ó@Nuæ÷Ò‹Â%ÿ‹ÊÁáÁ‰T$3ÉŠl$Áà_Áê^[ÁÂÃB n {  ¢ ³ À Ò ä õ   & : D R h ˆ  £ ® ¿ É Õ ë ü   ! ( C M [ l – ¦ ´ à ä 3À…ÉtöÁt3ÑéƒÂ…ÉuðÃUVW‹ð‹û+þ½ ‹ÿ‹73Ò…À‹ËtëI¨t3ÑèƒÁ…Àuñ‰ƒÆMuÙ_^]Ã;$‹D$ ì…Àu‹„$ÄùÇ$ ƒ¸í‹Á›‰ „Ñá@ƒø |õSVW\$ „$Œèœ$ŒD$ è‹„$3ÿ‹L< 3ö…ÉT$ töÁt32ÑéƒÂ…Éuð‰´<ŒƒÇÿ€|Ћœ$öÃt3Ò…ÀŒ$Œt¨t3ÑèƒÁ…Àuñ‹ÂÑû…Ûtm3ÿ¤$‹Œ<Œ3ö…É”$ŒtöÁt32ÑéƒÂ…Éuð‰t< ƒÇÿ€|ÍöÃt3Ò…ÀL$ t¨t3ÑèƒÁ…Àuñ‹ÂÑû…Û‰œ$…1ÿÿÿ‹Œ$_^3Á[ÄÃJ$Z$G@ )‹L$…Éu3ÀËT$ ‹D$é..fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\crc32.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S¹.rdata —¨(ã.textôô .debug$F.textÒ&ÌTJ .debug$F.text&¿ó, .debug$F .text ‰Úàï7 .debug$F  .text ;i5ÏOI .debug$F  .textG¦^ØV\ .debug$F.textÀ °~_crc32 .debug$Fk_crc_table_get_crc_table_crc32_little_crc32_big_gf2_matrix_times_gf2_matrix_square_crc32_combine/496 1171549760 100666 1667 ` L @nÔEÑ!.drectve,| .debug$S¼¨@B.text©d  P`.rdata?@0@.debug$FEU@B.text_~ P`.debug$Fˆ˜@B.text¢ P`.debug$F·Ç@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" | uc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\compress.obj8 Ž Ž!Microsoft (R) Optimizing Compilerƒì8‹L$H‹T$<‹D$DS‹\$Dj8‰L$ ‹L$Th‰T$‰D$ ‹QT$R‰D$$ÇD$4ÇD$8ÇD$<èƒÄ…ÀuIVD$jPè‹ðƒÄƒþtL$QèƒÄ…ö¸ûÿÿÿt‹Æ^[ƒÄ8ËT$D$P‰èƒÄ^[ƒÄ8ÃPdxœ1.2.3©‹D$‹L$ ‹T$jÿP‹D$ QRPèƒÄËD$‹È‹ÐÁéÁê ÈD Ã.fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\compress.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S¼.text©y(Õ  _deflate  .rdata{M-).debug$F.textñÆÈG .debug$F.textù.?¼Q .debug$F `_compress2_deflateEnd_deflateInit_??_C@_05GDHACFMB@1?42?43?$AA@_compress_compressBound /533 1171549760 100666 1678 ` L@nÔEí.drectve, .debug$S»0@B.textAë P`.debug$F,<@B.textF P`.debug$FÓã@B/DEFAULTLIB:"LIBCMT" /DEFAULTLIB:"OLDNAMES" { tc:\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\projects\visualc6\Win32_LIB_ASM_Release\adler32.obj8 Ž Ž!Microsoft (R) Optimizing Compiler‹L$S‹\$W‹ùÁïáÿÿƒûu1‹D$¶Êùñÿréñÿùÿñÿrïñÿ‹ÇÁà_ Á[ÃV‹t$…öu ^_¸[Ãûs3…Ût ¶ÈFùKuõùñÿréñÿ‹Ç3Ò¾ñÿ÷ö^_[‹ÂÁà ÁÃû°‚ʸ¯©n^÷ãU‹êÁí ‹ÿë°¸[ëI¶Ê¶VùʶVùʶVùʶVùʶVùʶVùʶVùʶVùʶV ùʶV ùʶV ùʶV ùʶV ùʶVùʶVùÊùƒÆH…wÿÿÿ‹Á3Ò¹ñÿ÷ñ‹Ç¿ñÿ‹Ê3Ò÷÷M‹ú…Fÿÿÿ]…Û„Ãû‚‘‹ÃÁè¶Ê¶VùʶVùʶVùʶVùʶVùʶVùʶVùʶVùʶV ùʶV ùʶV ùʶV ùʶV ùʶVùʶVùʃëùƒÆH…tÿÿÿ…Ût ¶ÈFùKuõ‹Á3Ò¹ñÿ÷ñ‹Ç¾ñÿ‹Ê3Ò÷ö‹ú‹Ç^Áà_ Á[ÃA ‹D$ 3Ò¹ñÿ÷ñ‹L$SV‹ñæÿÿW‹Æ»ñÿÁé‹ú¯Ç3Ò÷ó‹D$‹ØÁèãÿÿÈ´ðÿ+Ïþñÿ„ ñÿvîñÿþñÿvîñÿ=âÿv-âÿ=ñÿv-ñÿÁà_ Æ^[Ã.fileþÿg\Documents and Settings\ncannasse\Bureau\zlib-1.2.3\zlib-1.2.3\adler32.c@comp.idŽ_ÿÿ@feat.00ÿÿ.drectve,.debug$S».textA÷Ù‚;_adler32 .debug$F.textPúŽ .debug$F_adler32_combinehaxe-3.0~svn6707/libs/extc/LICENSE0000644000175000017500000004313112172015137017106 0ustar bdefreesebdefreese GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. haxe-3.0~svn6707/libs/extc/extc_stubs.c0000644000175000017500000002546712172015137020444 0ustar bdefreesebdefreese/* * Extc : C common OCaml bindings * Copyright (c)2004 Nicolas Cannasse * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ #include #include #include #include #include #ifdef _WIN32 # include # include #else # include # include # include # include # include # include # include # include # include #endif #ifdef __APPLE__ # include # include # include #endif #ifdef __FreeBSD__ # include # include # include #endif #ifndef CLK_TCK # define CLK_TCK 100 #endif #define zval(z) ((z_streamp)(z)) value zlib_new_stream() { value z = alloc((sizeof(z_stream) + sizeof(value) - 1) / sizeof(value),Abstract_tag); z_stream *s = zval(z); s->zalloc = NULL; s->zfree = NULL; s->opaque = NULL; s->next_in = NULL; s->next_out = NULL; return z; } CAMLprim value zlib_deflate_init2(value lvl,value wbits) { value z = zlib_new_stream(); if( deflateInit2(zval(z),Int_val(lvl),Z_DEFLATED,Int_val(wbits),8,Z_DEFAULT_STRATEGY) != Z_OK ) failwith("zlib_deflate_init"); return z; } CAMLprim value zlib_deflate( value zv, value src, value spos, value slen, value dst, value dpos, value dlen, value flush ) { z_streamp z = zval(zv); value res; int r; z->next_in = (Bytef*)(String_val(src) + Int_val(spos)); z->next_out = (Bytef*)(String_val(dst) + Int_val(dpos)); z->avail_in = Int_val(slen); z->avail_out = Int_val(dlen); if( (r = deflate(z,Int_val(flush))) < 0 ) failwith("zlib_deflate"); z->next_in = NULL; z->next_out = NULL; res = alloc_small(3, 0); Field(res, 0) = Val_bool(r == Z_STREAM_END); Field(res, 1) = Val_int(Int_val(slen) - z->avail_in); Field(res, 2) = Val_int(Int_val(dlen) - z->avail_out); return res; } CAMLprim value zlib_deflate_bytecode(value * arg, int nargs) { return zlib_deflate(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],arg[7]); } CAMLprim value zlib_deflate_end(value zv) { if( deflateEnd(zval(zv)) != 0 ) failwith("zlib_deflate_end"); return Val_unit; } CAMLprim value zlib_inflate_init(value wbits) { value z = zlib_new_stream(); if( inflateInit2(zval(z),Int_val(wbits)) != Z_OK ) failwith("zlib_inflate_init"); return z; } CAMLprim value zlib_inflate( value zv, value src, value spos, value slen, value dst, value dpos, value dlen, value flush ) { z_streamp z = zval(zv); value res; int r; z->next_in = (Bytef*)(String_val(src) + Int_val(spos)); z->next_out = (Bytef*)(String_val(dst) + Int_val(dpos)); z->avail_in = Int_val(slen); z->avail_out = Int_val(dlen); if( (r = inflate(z,Int_val(flush))) < 0 ) failwith("zlib_inflate"); z->next_in = NULL; z->next_out = NULL; res = alloc_small(3, 0); Field(res, 0) = Val_bool(r == Z_STREAM_END); Field(res, 1) = Val_int(Int_val(slen) - z->avail_in); Field(res, 2) = Val_int(Int_val(dlen) - z->avail_out); return res; } CAMLprim value zlib_inflate_bytecode(value * arg, int nargs) { return zlib_inflate(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],arg[7]); } CAMLprim value zlib_inflate_end(value zv) { if( inflateEnd(zval(zv)) != 0 ) failwith("zlib_inflate_end"); return Val_unit; } CAMLprim value zlib_deflate_bound(value zv,value len) { return Val_int(deflateBound(zval(zv),Int_val(len))); } CAMLprim value executable_path(value u) { #ifdef _WIN32 char path[MAX_PATH]; if( GetModuleFileName(NULL,path,MAX_PATH) == 0 ) failwith("executable_path"); return caml_copy_string(path); #elif __APPLE__ char path[MAXPATHLEN+1]; uint32_t path_len = MAXPATHLEN; if ( _NSGetExecutablePath(path, &path_len) ) failwith("executable_path"); return caml_copy_string(path); #elif __FreeBSD__ char path[PATH_MAX]; int error, name[4]; size_t len; name[0] = CTL_KERN; name[1] = KERN_PROC; name[2] = KERN_PROC_PATHNAME; name[3] = (int)getpid(); len = sizeof(path); error = sysctl(name, 4, path, &len, NULL, 0); if( error < 0 ) failwith("executable_path"); return caml_copy_string(path); #else const char *p = getenv("_"); if( p != NULL ) return caml_copy_string(p); { char path[200]; int length = readlink("/proc/self/exe", path, sizeof(path)); if( length < 0 || length >= 200 ) failwith("executable_path"); path[length] = '\0'; return caml_copy_string(path); } #endif } CAMLprim value get_full_path( value f ) { #ifdef _WIN32 char path[MAX_PATH]; if( GetFullPathName(String_val(f),MAX_PATH,path,NULL) == 0 ) failwith("get_full_path"); return caml_copy_string(path); #else char path[4096]; if( realpath(String_val(f),path) == NULL ) failwith("get_full_path"); return caml_copy_string(path); #endif } #ifdef _WIN32 static void copyAscii( char *to, const char *from, int len ) { while( len-- > 0 ) { unsigned char c = *from; if( c < 128 ) *to = c; to++; from++; } } #endif CAMLprim value get_real_path( value path ) { #ifdef _WIN32 value path2 = caml_copy_string(String_val(path)); char *cur = String_val(path2); if( cur[0] == '\\' && cur[1] == '\\' ) { cur = strchr(cur,'\\'); if( cur != NULL ) cur++; } else if( cur[0] != 0 && cur[1] == ':' ) { char c = cur[0]; if( c >= 'a' && c <= 'z' ) cur[0] = c - 'a' + 'A'; cur += 2; if( cur[0] == '\\' ) cur++; } while( cur ) { char *next = strchr(cur,'\\'); SHFILEINFOA infos; if( next != NULL ) *next = 0; else if( *cur == 0 ) break; if( SHGetFileInfoA( String_val(path2), 0, &infos, sizeof(infos), SHGFI_DISPLAYNAME ) != 0 ) { // some special names might be expended to their localized name, so make sure we only // change the casing and not the whole content if( strcmpi(infos.szDisplayName,cur) == 0 ) copyAscii(cur,infos.szDisplayName,strlen(infos.szDisplayName)+1); } if( next != NULL ) { *next = '\\'; cur = next + 1; } else cur = NULL; } return path2; #else return path; #endif } CAMLprim value sys_time() { #ifdef _WIN32 #define EPOCH_DIFF (134774*24*60*60.0) static LARGE_INTEGER freq; static int freq_init = -1; LARGE_INTEGER counter; if( freq_init == -1 ) freq_init = QueryPerformanceFrequency(&freq); if( !freq_init || !QueryPerformanceCounter(&counter) ) { SYSTEMTIME t; FILETIME ft; ULARGE_INTEGER ui; GetSystemTime(&t); if( !SystemTimeToFileTime(&t,&ft) ) failwith("sys_cpu_time"); ui.LowPart = ft.dwLowDateTime; ui.HighPart = ft.dwHighDateTime; return caml_copy_double( ((double)ui.QuadPart) / 10000000.0 - EPOCH_DIFF ); } return caml_copy_double( ((double)counter.QuadPart) / ((double)freq.QuadPart) ); #else struct tms t; times(&t); return caml_copy_double( ((double)(t.tms_utime + t.tms_stime)) / CLK_TCK ); #endif } CAMLprim value sys_getch( value b ) { # ifdef _WIN32 return Val_int( Bool_val(b)?getche():getch() ); # else // took some time to figure out how to do that // without relying on ncurses, which clear the // terminal on initscr() int c; struct termios term, old; tcgetattr(fileno(stdin), &old); term = old; cfmakeraw(&term); tcsetattr(fileno(stdin), 0, &term); c = getchar(); tcsetattr(fileno(stdin), 0, &old); if( Bool_val(b) ) fputc(c,stdout); return Val_int(c); # endif } // --------------- Support for NekoVM Bridge CAMLprim value sys_dlopen( value lib ) { #ifdef _WIN32 return (value)LoadLibrary(String_val(lib)); #else return (value)dlopen(String_val(lib),RTLD_LAZY); #endif } CAMLprim value sys_dlsym( value dl, value name ) { #ifdef _WIN32 return (value)GetProcAddress((HANDLE)dl,String_val(name)); #else return (value)dlsym((void*)dl,String_val(name)); #endif } CAMLprim value sys_dlint( value i ) { return Int_val(i); } CAMLprim value sys_dltoint( value i ) { return Val_int((int)i); } CAMLprim value sys_dlint32( value i ) { return (value)Int32_val(i); } typedef value (*c_prim0)(); typedef value (*c_prim1)(value); typedef value (*c_prim2)(value,value); typedef value (*c_prim3)(value,value,value); typedef value (*c_prim4)(value,value,value,value); typedef value (*c_prim5)(value,value,value,value,value); CAMLprim value sys_dlcall0( value f ) { return ((c_prim0)f)(); } CAMLprim value sys_dlcall1( value f, value a ) { return ((c_prim1)f)(a); } CAMLprim value sys_dlcall2( value f, value a, value b ) { return ((c_prim2)f)(a,b); } CAMLprim value sys_dlcall3( value f, value a, value b, value c ) { return ((c_prim3)f)(a,b,c); } CAMLprim value sys_dlcall4( value f, value a, value b, value c, value d ) { return ((c_prim4)f)(a,b,c,d); } CAMLprim value sys_dlcall5( value f, value a, value b, value c, value d, value e ) { return ((c_prim5)f)(a,b,c,d,e); } CAMLprim value sys_dlcall5_bc( value *args, int nargs ) { return ((c_prim5)args[0])(args[1],args[2],args[3],args[4],args[5]); } CAMLprim value sys_dladdr( value v, value a ) { return (value)((char*)v + Int_val(a)); } CAMLprim value sys_dlptr( value v ) { return *((value*)v); } CAMLprim value sys_dlsetptr( value p, value v ) { *((value*)p) = v; return Val_unit; } CAMLprim value sys_dlalloc_string( value v ) { return caml_copy_string((char*)v); } CAMLprim value sys_dlmemcpy( value dst, value src, value len ) { memcpy((char*)dst,(char*)src,Int_val(len)); return Val_unit; } static value __callb0( value callb ) { return caml_callbackN(callb,0,NULL); } static value __callb1( value a, value callb ) { return caml_callback(callb,a); } static value __callb2( value a, value b, value callb ) { return caml_callback2(callb,a,b); } static value __callb3( value a, value b, value c, value callb ) { return caml_callback3(callb,a,b,c); } CAMLprim value sys_dlcallback( value nargs ) { switch( Int_val(nargs) ) { case 0: return (value)__callb0; case 1: return (value)__callb1; case 2: return (value)__callb2; case 3: return (value)__callb3; default: failwith("dlcallback(too_many_args)"); } return Val_unit; } static value __caml_callb1( value a ) { return caml_callback(*caml_named_value("dlcallb1"),a); } static value __caml_callb2( value a, value b ) { return caml_callback2(*caml_named_value("dlcallb2"),a,b); } CAMLprim value sys_dlcaml_callback( value nargs ) { switch( Int_val(nargs) ) { case 1: return (value)__caml_callb1; case 2: return (value)__caml_callb2; default: failwith("sys_dlcaml_callback(too_many_args)"); } return Val_unit; } haxe-3.0~svn6707/libs/ocamake/0000755000175000017500000000000012172015137016534 5ustar bdefreesebdefreesehaxe-3.0~svn6707/libs/ocamake/ocamake.dsp0000644000175000017500000000350712172015137020651 0ustar bdefreesebdefreese# Microsoft Developer Studio Project File - Name="ocamake" - Package Owner=<4> # Microsoft Developer Studio Generated Build File, Format Version 6.00 # ** DO NOT EDIT ** # TARGTYPE "Win32 (x86) External Target" 0x0106 CFG=ocamake - Win32 Native code !MESSAGE This is not a valid makefile. To build this project using NMAKE, !MESSAGE use the Export Makefile command and run !MESSAGE !MESSAGE NMAKE /f "ocamake.mak". !MESSAGE !MESSAGE You can specify a configuration when running NMAKE !MESSAGE by defining the macro CFG on the command line. For example: !MESSAGE !MESSAGE NMAKE /f "ocamake.mak" CFG="ocamake - Win32 Native code" !MESSAGE !MESSAGE Possible choices for configuration are: !MESSAGE !MESSAGE "ocamake - Win32 Native code" (based on "Win32 (x86) External Target") !MESSAGE # Begin Project # PROP AllowPerConfigDependencies 0 # PROP Scc_ProjName "" # PROP Scc_LocalPath "" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "" # PROP BASE Intermediate_Dir "" # PROP BASE Cmd_Line "ocamake -opt ocamake.dsp -o ocamake.exe" # PROP BASE Rebuild_Opt "-all" # PROP BASE Target_File "ocamake_opt.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 0 # PROP Output_Dir "" # PROP Intermediate_Dir "" # PROP Cmd_Line "ocamake str.cmxa unix.cmxa -opt ocamake.dsp -o ocadbg.exe" # PROP Rebuild_Opt "-all" # PROP Target_File "ocadbg.exe" # PROP Bsc_Name "" # PROP Target_Dir "" # Begin Target # Name "ocamake - Win32 Native code" !IF "$(CFG)" == "ocamake - Win32 Native code" !ENDIF # Begin Group "ML Files" # PROP Default_Filter "ml;mly;mll" # Begin Source File SOURCE=.\ocamake.ml # End Source File # End Group # Begin Group "MLI Files" # PROP Default_Filter "mli" # End Group # End Target # End Project haxe-3.0~svn6707/libs/ocamake/ocamake.dsw0000644000175000017500000000103112172015137020646 0ustar bdefreesebdefreeseMicrosoft Developer Studio Workspace File, Format Version 6.00 # WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! ############################################################################### Project: "ocamake"=.\ocamake.dsp - Package Owner=<4> Package=<5> {{{ }}} Package=<4> {{{ }}} ############################################################################### Global: Package=<5> {{{ }}} Package=<3> {{{ }}} ############################################################################### haxe-3.0~svn6707/libs/ocamake/ocamake.html0000644000175000017500000001272412172015137021030 0ustar bdefreesebdefreese
OCamake

OCamake - Copyright (c)2002-2003 Nicolas Cannasse & Motion Twin.
The last version of this software can be found at : http://tech.motion-twin.com

This software is provided "AS IS" without any warranty of any kind, merchantability or fitness for a particular purpose. You should use it at your own risks, as the author and his company won't be responsible for any problem that the usage of this software could raise.