diff --git a/Makefile b/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..eb8d60ffc9aa0108eb52d5a3b4f47a0db6b2e9df --- /dev/null +++ b/Makefile @@ -0,0 +1,171 @@ +# 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 diff --git a/Makefile.win b/Makefile.win new file mode 100644 index 0000000000000000000000000000000000000000..4064979391be99769738d8335111dc777b268937 --- /dev/null +++ b/Makefile.win @@ -0,0 +1,31 @@ +include 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) +endif \ No newline at end of file diff --git a/haxe/ast.ml b/ast.ml similarity index 50% rename from haxe/ast.ml rename to ast.ml index 885755d6e033d7e53d1f7a14de7847b1918d1094..1017568718bfe02287e91872def138c63b08faec 100755 --- a/haxe/ast.ml +++ b/ast.ml @@ -1,20 +1,23 @@ (* - * Haxe Compiler - * Copyright (c)2005 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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. *) type pos = { @@ -23,6 +26,118 @@ type pos = { pmax : int; } +module Meta = struct + type strict_meta = + | Abstract + | Access + | Allow + | Annotation + | ArrayAccess + | AutoBuild + | Bind + | Bitmap + | Build + | BuildXml + | Class + | ClassCode + | Commutative + | CompilerGenerated + | CoreApi + | CoreType + | CppFileCode + | CppNamespaceCode + | Debug + | Decl + | DefParam + | Depend + | Deprecated + | DynamicObject + | Enum + | EnumConstructorParam + | Expose + | Extern + | FakeEnum + | File + | Final + | Font + | From + | FunctionCode + | FunctionTailCode + | Generic + | Getter + | Hack + | HaxeGeneric + | HeaderClassCode + | HeaderCode + | HeaderNamespaceCode + | HxGen + | IfFeature + | Impl + | Include + | InitPackage + | Internal + | IsVar + | JavaNative + | Keep + | KeepInit + | KeepSub + | Meta + | Macro + | MaybeUsed + | MultiType + | Native + | NativeGen + | NativeGeneric + | NoCompletion + | NoDebug + | NoDoc + | NoImportGlobal + | NoPackageRestrict + | NoStack + | NotNull + | NoUsing + | Ns + | Op + | Optional + | Overload + | PrivateAccess + | Protected + | Public + | PublicFields + | ReadOnly + | RealPath + | Remove + | Require + | ReplaceReflection + | Rtti + | Runtime + | RuntimeValue + | Setter + | SkipCtor + | SkipReflection + | Sound + | Struct + | SuppressWarnings + | Throws + | To + | ToString + | Transient + | ValueUsed + | Volatile + | UnifyMinDynamic + | Unreflective + | Unsafe + | Usage + | Used + | Last + (* do not put any custom metadata after Last *) + | Dollar of string + | Custom of string + + let has m ml = List.exists (fun (m2,_,_) -> m = m2) ml + let get m ml = List.find (fun (m2,_,_) -> m = m2) ml +end + type keyword = | Function | Class @@ -59,9 +174,13 @@ type keyword = | Typedef | Dynamic | Package - | Callback | Inline | Using + | Null + | True + | False + | Abstract + | Macro type binop = | OpAdd @@ -86,6 +205,7 @@ type binop = | OpMod | OpAssignOp of binop | OpInterval + | OpArrow type unop = | Increment @@ -99,7 +219,6 @@ type constant = | Float of string | String of string | Ident of string - | Type of string | Regexp of string * string type token = @@ -122,9 +241,10 @@ type token = | DblDot | Arrow | IntInterval of string - | Macro of string + | Sharp of string | Question | At + | Dollar of string type unop_flag = | Prefix @@ -143,24 +263,21 @@ type type_path = { and type_param_or_const = | TPType of complex_type - | TPConst of constant - -and anonymous_field = - | AFVar of complex_type - | AFProp of complex_type * string * string - | AFFun of (string * bool * complex_type) list * complex_type + | TPExpr of expr and complex_type = | CTPath of type_path | CTFunction of complex_type list * complex_type - | CTAnonymous of (string * bool option * anonymous_field * pos) list + | CTAnonymous of class_field list | CTParent of complex_type - | CTExtend of type_path * (string * bool option * anonymous_field * pos) list + | CTExtend of type_path * class_field list + | CTOptional of complex_type -type func = { +and func = { + f_params : type_param list; f_args : (string * bool * complex_type option * expr option) list; f_type : complex_type option; - f_expr : expr; + f_expr : expr option; } and expr_def = @@ -168,7 +285,6 @@ and expr_def = | EArray of expr * expr | EBinop of binop * expr * expr | EField of expr * string - | EType of expr * string | EParenthesis of expr | EObjectDecl of (string * expr) list | EArrayDecl of expr list @@ -178,10 +294,11 @@ and expr_def = | EVars of (string * complex_type option * expr option) list | EFunction of string option * func | EBlock of expr list - | EFor of string * expr * expr + | EFor of expr * expr + | EIn of expr * expr | EIf of expr * expr * expr option | EWhile of expr * expr * while_flag - | ESwitch of expr * (expr list * expr) list * expr option + | ESwitch of expr * (expr list * expr option * expr option) list * expr option option | ETry of expr * (string * complex_type * expr) list | EReturn of expr option | EBreak @@ -192,29 +309,37 @@ and expr_def = | EDisplay of expr * bool | EDisplayNew of type_path | ETernary of expr * expr * expr + | ECheckType of expr * complex_type + | EMeta of metadata_entry * expr and expr = expr_def * pos -type type_param = string * type_path list +and type_param = { + tp_name : string; + tp_params : type_param list; + tp_constraints : complex_type list; +} -type documentation = string option +and documentation = string option -type metadata = (string * expr list * pos) list +and metadata_entry = (Meta.strict_meta * expr list * pos) +and metadata = metadata_entry list -type access = +and access = | APublic | APrivate | AStatic | AOverride | ADynamic | AInline + | AMacro -type class_field_kind = +and class_field_kind = | FVar of complex_type option * expr option - | FFun of type_param list * func - | FProp of string * string * complex_type + | FFun of func + | FProp of string * string * complex_type option * expr option -type class_field = { +and class_field = { cff_name : string; cff_doc : documentation; cff_pos : pos; @@ -234,7 +359,21 @@ type class_flag = | HExtends of type_path | HImplements of type_path -type enum_constructor = string * documentation * metadata * (string * bool * complex_type) list * pos +type abstract_flag = + | APrivAbstract + | AFromType of complex_type + | AToType of complex_type + | AIsType of complex_type + +type enum_constructor = { + ec_name : string; + ec_doc : documentation; + ec_meta : metadata; + ec_args : (string * bool * complex_type) list; + ec_pos : pos; + ec_params : type_param list; + ec_type : complex_type option; +} type ('a,'b) definition = { d_name : string; @@ -245,21 +384,36 @@ type ('a,'b) definition = { d_data : 'b; } +type import_mode = + | INormal + | IAsName of string + | IAll + type type_def = | EClass of (class_flag, class_field list) definition | EEnum of (enum_flag, enum_constructor list) definition | ETypedef of (enum_flag, complex_type) definition - | EImport of type_path + | EAbstract of (abstract_flag, class_field list) definition + | EImport of (string * pos) list * import_mode | EUsing of type_path type type_decl = type_def * pos type package = string list * type_decl list +let is_lower_ident i = + let rec loop p = + match String.unsafe_get i p with + | 'a'..'z' -> true + | '_' -> if p + 1 < String.length i then loop (p + 1) else true + | _ -> false + in + loop 0 + let pos = snd let is_postfix (e,_) = function - | Increment | Decrement -> (match e with EConst _ | EField _ | EType _ | EArray _ -> true | _ -> false) + | Increment | Decrement -> (match e with EConst _ | EField _ | EArray _ -> true | _ -> false) | Not | Neg | NegBits -> false let is_prefix = function @@ -277,6 +431,14 @@ let punion p p2 = pmax = max p.pmax p2.pmax; } +let rec punion_el el = match el with + | [] -> + null_pos + | (_,p) :: [] -> + p + | (_,p) :: el -> + punion p (punion_el el) + let s_type_path (p,s) = match p with [] -> s | _ -> String.concat "." p ^ "." ^ s let parse_path s = @@ -302,7 +464,6 @@ let s_constant = function | Float s -> s | String s -> "\"" ^ s_escape s ^ "\"" | Ident s -> s - | Type s -> s | Regexp (r,o) -> "~/" ^ r ^ "/" let s_access = function @@ -312,6 +473,7 @@ let s_access = function | AOverride -> "override" | ADynamic -> "dynamic" | AInline -> "inline" + | AMacro -> "macro" let s_keyword = function | Function -> "function" @@ -349,9 +511,13 @@ let s_keyword = function | Typedef -> "typedef" | Dynamic -> "dynamic" | Package -> "package" - | Callback -> "callback" | Inline -> "inline" | Using -> "using" + | Null -> "null" + | True -> "true" + | False -> "false" + | Abstract -> "abstract" + | Macro -> "macro" let rec s_binop = function | OpAdd -> "+" @@ -376,6 +542,7 @@ let rec s_binop = function | OpMod -> "%" | OpAssignOp op -> s_binop op ^ "=" | OpInterval -> "..." + | OpArrow -> "=>" let s_unop = function | Increment -> "++" @@ -404,9 +571,10 @@ let s_token = function | DblDot -> ":" | Arrow -> "->" | IntInterval s -> s ^ "..." - | Macro s -> "#" ^ s + | Sharp s -> "#" ^ s | Question -> "?" | At -> "@" + | Dollar v -> "$" ^ v let unescape s = let b = Buffer.create 0 in @@ -442,3 +610,69 @@ let unescape s = in loop false 0; Buffer.contents b + + +let map_expr loop (e,p) = + let opt f o = + match o with None -> None | Some v -> Some (f v) + in + let rec tparam = function + | TPType t -> TPType (ctype t) + | TPExpr e -> TPExpr (loop e) + and cfield f = + { f with cff_kind = (match f.cff_kind with + | FVar (t,e) -> FVar (opt ctype t, opt loop e) + | FFun f -> FFun (func f) + | FProp (get,set,t,e) -> FProp (get,set,opt ctype t,opt loop e)) + } + and ctype = function + | CTPath t -> CTPath (tpath t) + | CTFunction (cl,c) -> CTFunction (List.map ctype cl, ctype c) + | CTAnonymous fl -> CTAnonymous (List.map cfield fl) + | CTParent t -> CTParent (ctype t) + | CTExtend (t,fl) -> CTExtend (tpath t, List.map cfield fl) + | CTOptional t -> CTOptional (ctype t) + and tparamdecl t = + { tp_name = t.tp_name; tp_constraints = List.map ctype t.tp_constraints; tp_params = List.map tparamdecl t.tp_params } + and func f = + { + f_params = List.map tparamdecl f.f_params; + f_args = List.map (fun (n,o,t,e) -> n,o,opt ctype t,opt loop e) f.f_args; + f_type = opt ctype f.f_type; + f_expr = opt loop f.f_expr; + } + and tpath t = { t with tparams = List.map tparam t.tparams } + in + let e = (match e with + | EConst _ -> e + | EArray (e1,e2) -> EArray (loop e1, loop e2) + | EBinop (op,e1,e2) -> EBinop (op,loop e1, loop e2) + | EField (e,f) -> EField (loop e, f) + | EParenthesis e -> EParenthesis (loop e) + | EObjectDecl fl -> EObjectDecl (List.map (fun (f,e) -> f,loop e) fl) + | EArrayDecl el -> EArrayDecl (List.map loop el) + | ECall (e,el) -> ECall (loop e, List.map loop el) + | ENew (t,el) -> ENew (tpath t,List.map loop el) + | EUnop (op,f,e) -> EUnop (op,f,loop e) + | EVars vl -> EVars (List.map (fun (n,t,eo) -> n,opt ctype t,opt loop eo) vl) + | EFunction (n,f) -> EFunction (n,func f) + | EBlock el -> EBlock (List.map loop el) + | EFor (e1,e2) -> EFor (loop e1, loop e2) + | EIn (e1,e2) -> EIn (loop e1, loop e2) + | EIf (e,e1,e2) -> EIf (loop e, loop e1, opt loop e2) + | EWhile (econd,e,f) -> EWhile (loop econd, loop e, f) + | ESwitch (e,cases,def) -> ESwitch (loop e, List.map (fun (el,eg,e) -> List.map loop el, opt loop eg, opt loop e) cases, opt (opt loop) def) + | ETry (e, catches) -> ETry (loop e, List.map (fun (n,t,e) -> n,ctype t,loop e) catches) + | EReturn e -> EReturn (opt loop e) + | EBreak -> EBreak + | EContinue -> EContinue + | EUntyped e -> EUntyped (loop e) + | EThrow e -> EThrow (loop e) + | ECast (e,t) -> ECast (loop e,opt ctype t) + | EDisplay (e,f) -> EDisplay (loop e,f) + | EDisplayNew t -> EDisplayNew (tpath t) + | ETernary (e1,e2,e3) -> ETernary (loop e1,loop e2,loop e3) + | ECheckType (e,t) -> ECheckType (loop e, ctype t) + | EMeta (m,e) -> EMeta(m, loop e) + ) in + (e,p) diff --git a/codegen.ml b/codegen.ml new file mode 100644 index 0000000000000000000000000000000000000000..078b8c545e20c26ec86154e09643682651b4351d --- /dev/null +++ b/codegen.ml @@ -0,0 +1,2155 @@ +(* + * 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;; diff --git a/common.ml b/common.ml new file mode 100644 index 0000000000000000000000000000000000000000..04452133aa4e5364d580e5fe9c821021e520fa67 --- /dev/null +++ b/common.ml @@ -0,0 +1,826 @@ +(* + * 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 + +type package_rule = + | Forbidden + | Directory of string + | Remap of string + +type pos = Ast.pos + +type basic_types = { + mutable tvoid : t; + mutable tint : t; + mutable tfloat : t; + mutable tbool : t; + mutable tnull : t -> t; + mutable tstring : t; + mutable tarray : t -> t; +} + +type stats = { + s_files_parsed : int ref; + s_classes_built : int ref; + s_methods_typed : int ref; + s_macros_called : int ref; +} + +type platform = + | Cross + | Flash8 + | Js + | Neko + | Flash + | Php + | Cpp + | Cs + | Java + +(** + The capture policy tells which handling we make of captured locals + (the locals which are referenced in local functions) + + See details/implementation in Codegen.captured_vars +*) +type capture_policy = + (** do nothing, let the platform handle it *) + | CPNone + (** wrap all captured variables into a single-element array to allow modifications *) + | CPWrapRef + (** similar to wrap ref, but will only apply to the locals that are declared in loops *) + | CPLoopVars + +type platform_config = { + (** has a static type system, with not-nullable basic types (Int/Float/Bool) *) + pf_static : bool; + (** has access to the "sys" package *) + pf_sys : bool; + (** local variables are block-scoped *) + pf_locals_scope : bool; + (** captured local variables are scoped *) + pf_captured_scope : bool; + (** generated locals must be absolutely unique wrt the current function *) + pf_unique_locals : bool; + (** which expressions can be generated to initialize member variables (or will be moved into the constructor *) + pf_can_init_member : tclass_field -> bool; + (** captured variables handling (see before) *) + pf_capture_policy : capture_policy; + (** when calling a method with optional args, do we replace the missing args with "null" constants *) + pf_pad_nulls : bool; + (** add a final return to methods not having one already - prevent some compiler warnings *) + pf_add_final_return : bool; + (** does the platform natively support overloaded functions *) + pf_overload : bool; +} + +type context = { + (* config *) + version : int; + args : string list; + mutable sys_args : string list; + mutable display : bool; + mutable debug : bool; + mutable verbose : bool; + mutable foptimize : bool; + mutable platform : platform; + mutable config : platform_config; + mutable std_path : string list; + mutable class_path : string list; + mutable main_class : Type.path option; + mutable defines : (string,string) PMap.t; + mutable package_rules : (string,package_rule) PMap.t; + mutable error : string -> pos -> unit; + mutable warning : string -> pos -> unit; + mutable load_extern_type : (path -> pos -> (string * Ast.package) option) list; (* allow finding types which are not in sources *) + mutable filters : (unit -> unit) list; + mutable defines_signature : string option; + mutable print : string -> unit; + mutable get_macros : unit -> context option; + mutable run_command : string -> int; + (* output *) + mutable file : string; + mutable flash_version : float; + mutable features : (string,bool) Hashtbl.t; + mutable modules : Type.module_def list; + mutable main : Type.texpr option; + mutable types : Type.module_type list; + mutable resources : (string,string) Hashtbl.t; + mutable neko_libs : string list; + mutable php_front : string option; + mutable php_lib : string option; + mutable php_prefix : string option; + mutable swf_libs : (string * (unit -> Swf.swf) * (unit -> ((string list * string),As3hl.hl_class) Hashtbl.t)) list; + mutable java_libs : (string * bool * (unit -> unit) * (unit -> ((string list * string) list)) * ((string list * string) -> ((JData.jclass * string * string) option))) list; + mutable js_gen : (unit -> unit) option; + (* typing *) + mutable basic : basic_types; +} + +exception Abort of string * Ast.pos + +let display_default = ref false + +module Define = struct + + type strict_defined = + | AbsolutePath + | AdvancedTelemetry + | As3 + | CheckXmlProxy + | CoreApi + | Dce + | DceDebug + | Debug + | Display + | DisplayMode + | DllExport + | DllImport + | DocGen + | Dump + | DumpDependencies + | Fdb + | FlashStrict + | FlashUseStage + | FormatWarning + | GencommonDebug + | HaxeBoot + | HaxeVer + | Interp + | JavaVer + | JsClassic + | Macro + | MacroTimes + | NekoSource + | NekoV1 + | NetworkSandbox + | NoCompilation + | NoCOpt + | NoInline + | NoOpt + | NoPatternMatching + | NoRoot + | NoSwfCompress + | NoTraces + | PhpPrefix + | RealPosition + | ReplaceFiles + | Scriptable + | Swc + | SwfCompressLevel + | SwfDebugPassword + | SwfDirectBlit + | SwfGpu + | SwfMark + | SwfMetadata + | SwfPreloaderFrame + | SwfProtected + | SwfScriptTimeout + | Sys + | UseNekoc + | UseRttiDoc + | Vcproj + | NoMacroCache + | Last (* must be last *) + + let infos = function + | AbsolutePath -> ("absolute_path","Print absoluate file path in trace output") + | AdvancedTelemetry -> ("advanced-telemetry","Allow the SWF to be measured with Monocle tool") + | As3 -> ("as3","Defined when outputing flash9 as3 source code") + | CheckXmlProxy -> ("check_xml_proxy","Check the used fields of the xml proxy") + | CoreApi -> ("core_api","Defined in the core api context") + | Dce -> ("dce","The current DCE mode") + | DceDebug -> ("dce_debug","Show DCE log") + | Debug -> ("debug","Activated when compiling with -debug") + | Display -> ("display","Activated during completion") + | DisplayMode -> ("display_mode", "The display mode to use (default, position, metadata, usage)") + | DllExport -> ("dll_export", "GenCPP experimental linking") + | DllImport -> ("dll_import", "GenCPP experimental linking") + | DocGen -> ("doc_gen","Do not perform any removal/change in order to correctly generate documentation") + | Dump -> ("dump","Dump the complete typed AST for internal debugging") + | DumpDependencies -> ("dump_dependencies","Dump the classes dependencies") + | Fdb -> ("fdb","Enable full flash debug infos for FDB interactive debugging") + | FlashStrict -> ("flash_strict","More strict typing for flash target") + | FlashUseStage -> ("flash_use_stage","Keep the SWF library initial stage") + | FormatWarning -> ("format_warning","Print a warning for each formated string, for 2.x compatibility") + | GencommonDebug -> ("gencommon_debug","GenCommon internal") + | HaxeBoot -> ("haxe_boot","Given the name 'haxe' to the flash boot class instead of a generated name") + | HaxeVer -> ("haxe_ver","The current Haxe version value") + | Interp -> ("interp","The code is compiled to be run with --interp") + | JavaVer -> ("java_ver", " Sets the Java version to be targeted") + | JsClassic -> ("js_classic","Don't use a function wrapper and strict mode in JS output") + | Macro -> ("macro","Defined when we compile code in the macro context") + | MacroTimes -> ("macro_times","Display per-macro timing when used with --times") + | NekoSource -> ("neko_source","Output neko source instead of bytecode") + | NekoV1 -> ("neko_v1","Keep Neko 1.x compatibility") + | NetworkSandbox -> ("network-sandbox","Use local network sandbox instead of local file access one") + | NoCompilation -> ("no-compilation","Disable CPP final compilation") + | NoCOpt -> ("no_copt","Disable completion optimization (for debug purposes)") + | NoOpt -> ("no_opt","Disable optimizations") + | NoPatternMatching -> ("no_pattern_matching","Disable pattern matching") + | NoInline -> ("no_inline","Disable inlining") + | NoRoot -> ("no_root","GenCS internal") + | NoMacroCache -> ("no_macro_cache","Disable macro context caching") + | NoSwfCompress -> ("no_swf_compress","Disable SWF output compression") + | NoTraces -> ("no_traces","Disable all trace calls") + | PhpPrefix -> ("php_prefix","Compiled with --php-prefix") + | RealPosition -> ("real_position","Disables haxe source mapping when targetting C#") + | ReplaceFiles -> ("replace_files","GenCommon internal") + | Scriptable -> ("scriptable","GenCPP internal") + | Swc -> ("swc","Output a SWC instead of a SWF") + | SwfCompressLevel -> ("swf_compress_level"," Set the amount of compression for the SWF output") + | SwfDebugPassword -> ("swf_debug_password", "Set a password for debugging.") + | SwfDirectBlit -> ("swf_direct_blit", "Use hardware acceleration to blit graphics") + | SwfGpu -> ("swf_gpu", "Use GPU compositing features when drawing graphics") + | SwfMark -> ("swf_mark","GenSWF8 internal") + | SwfMetadata -> ("swf_metadata", "= Include contents of as metadata in the swf.") + | SwfPreloaderFrame -> ("swf_preloader_frame", "Insert empty first frame in swf") + | SwfProtected -> ("swf_protected","Compile Haxe private as protected in the SWF instead of public") + | SwfScriptTimeout -> ("swf_script_timeout", "Maximum ActionScript processing time before script stuck dialog box displays (in seconds)") + | Sys -> ("sys","Defined for all system platforms") + | UseNekoc -> ("use_nekoc","Use nekoc compiler instead of internal one") + | UseRttiDoc -> ("use_rtti_doc","Allows access to documentation during compilation") + | Vcproj -> ("vcproj","GenCPP internal") + | Last -> assert false +end + +module MetaInfo = struct + open Meta + type meta_usage = + | TClass + | TClassField + | TAbstract + | TAbstractField + | TEnum + | TTypedef + | TAnyField + + type meta_parameter = + | HasParam of string + | Platform of platform + | Platforms of platform list + | UsedOn of meta_usage + | UsedOnEither of meta_usage list + | Internal + + let to_string = function + | Abstract -> ":abstract",("Sets the underlying class implementation as 'abstract'",[Platforms [Java;Cs]]) + | Access -> ":access",("Forces private access to package, type or field",[HasParam "Target path";UsedOnEither [TClass;TClassField]]) + | Allow -> ":allow",("Allows private access from package, type or field",[HasParam "Target path";UsedOnEither [TClass;TClassField]]) + | Annotation -> ":annotation",("Annotation (@interface) definitions on -java-lib imports will be annotated with this metadata. Has no effect on types compiled by Haxe",[Platform Java; UsedOn TClass]) + | ArrayAccess -> ":arrayAccess",("Allows [] access on an abstract",[UsedOnEither [TAbstract;TAbstractField]]) + | AutoBuild -> ":autoBuild",("Extends @:build metadata to all extending and implementing classes",[HasParam "Build macro call";UsedOn TClass]) + | Bind -> ":bind",("Override Swf class declaration",[Platform Flash;UsedOn TClass]) + | Bitmap -> ":bitmap",("Embeds given bitmap data into the class (must extend flash.display.BitmapData)",[HasParam "Bitmap file path";UsedOn TClass;Platform Flash]) + | Build -> ":build",("Builds a class or enum from a macro",[HasParam "Build macro call";UsedOnEither [TClass;TEnum]]) + | BuildXml -> ":buildXml",("",[Platform Cpp]) + | Class -> ":class",("Used internally to annotate an enum that will be generated as a class",[Platforms [Java;Cs]; UsedOn TEnum; Internal]) + | ClassCode -> ":classCode",("Used to inject platform-native code into a class",[Platforms [Java;Cs]; UsedOn TClass]) + | Commutative -> ":commutative",("Declares an abstract operator as commutative",[UsedOn TAbstractField]) + | CompilerGenerated -> ":compilerGenerated",("Marks a field as generated by the compiler. Shouldn't be used by the end user",[Platforms [Java;Cs]]) + | CoreApi -> ":coreApi",("Identifies this class as a core api class (forces Api check)",[UsedOnEither [TClass;TEnum;TTypedef;TAbstract]]) + | CoreType -> ":coreType",("Identifies an abstract as core type so that it requires no implementation",[UsedOn TAbstract]) + | CppFileCode -> ":cppFileCode",("",[Platform Cpp]) + | CppNamespaceCode -> ":cppNamespaceCode",("",[Platform Cpp]) + | Debug -> ":debug",("Forces debug information to be generated into the Swf even without -debug",[UsedOnEither [TClass;TClassField]; Platform Flash]) + | Decl -> ":decl",("",[Platform Cpp]) + | DefParam -> ":defParam",("?",[]) + | Depend -> ":depend",("",[Platform Cpp]) + | Deprecated -> ":deprecated",("Automatically added by -java-lib on class fields annotated with @Deprecated annotation. Has no effect on types compiled by Haxe.",[Platform Java; UsedOnEither [TClass;TEnum;TClassField]]) + | DynamicObject -> ":dynamicObject",("Used internally to identify the Dynamic Object implementation",[Platforms [Java;Cs]; UsedOn TClass; Internal]) + | Enum -> ":enum",("Used internally to annotate a class that was generated from an enum",[Platforms [Java;Cs]; UsedOn TClass; Internal]) + | EnumConstructorParam -> ":enumConstructorParam",("Used internally to annotate GADT type parameters",[UsedOn TClass; Internal]) + | Expose -> ":expose",("Makes the class available on the window object",[HasParam "?Name=Class path";UsedOn TClass;Platform Js]) + | Extern -> ":extern",("Marks the field as extern so it is not generated",[UsedOn TClassField]) + | FakeEnum -> ":fakeEnum",("Treat enum as collection of values of the specified type",[HasParam "Type name";UsedOn TEnum]) + | File -> ":file",("Includes a given binary file into the target Swf and associates it with the class (must extend flash.utils.ByteArray)",[HasParam "File path";UsedOn TClass;Platform Flash]) + | Final -> ":final",("Prevents a class from being extended",[UsedOn TClass]) + | Font -> ":font",("Embeds the given TrueType font into the class (must extend flash.text.Font)",[HasParam "TTF path";HasParam "Range String";UsedOn TClass]) + | From -> ":from",("Specifies that the field of the abstract is a cast operation from the type identified in the function",[UsedOn TAbstractField]) + | FunctionCode -> ":functionCode",("",[Platform Cpp]) + | FunctionTailCode -> ":functionTailCode",("",[Platform Cpp]) + | Generic -> ":generic",("Marks a class or class field as generic so each type parameter combination generates its own type/field",[UsedOnEither [TClass;TClassField]]) + | Getter -> ":getter",("Generates a native getter function on the given field",[HasParam "Class field name";UsedOn TClassField;Platform Flash]) + | Hack -> ":hack",("Allows extending classes marked as @:final",[UsedOn TClass]) + | HaxeGeneric -> ":haxeGeneric",("Used internally to annotate non-native generic classes",[Platform Cs; UsedOnEither[TClass;TEnum]; Internal]) + | HeaderClassCode -> ":headerClassCode",("",[Platform Cpp]) + | HeaderCode -> ":headerCode",("",[Platform Cpp]) + | HeaderNamespaceCode -> ":headerNamespaceCode",("",[Platform Cpp]) + | HxGen -> ":hxGen",("Annotates that an extern class was generated by Haxe",[Platforms [Java;Cs]; UsedOnEither [TClass;TEnum]]) + | IfFeature -> ":ifFeature",("Causes a field to be kept by DCE if the given feature is part of the compilation",[HasParam "Feature name";UsedOn TClassField]) + | Impl -> ":impl",("Used internally to mark abstract implementation fields",[UsedOn TAbstractField; Internal]) + | Include -> ":include",("",[Platform Cpp]) + | InitPackage -> ":initPackage",("?",[]) + | Meta.Internal -> ":internal",("Generates the annotated field/class with 'internal' access",[Platforms [Java;Cs]; UsedOnEither[TClass;TEnum;TClassField]]) + | IsVar -> ":isVar",("Forces a physical field to be generated for properties that otherwise would not require one",[UsedOn TClassField]) + | JavaNative -> ":javaNative",("Automatically added by -java-lib on classes generated from JAR/class files",[Platform Java; UsedOnEither[TClass;TEnum]; Internal]) + | Keep -> ":keep",("Causes a field or type to be kept by DCE",[]) + | KeepInit -> ":keepInit",("Causes a class to be kept by DCE even if all its field are removed",[UsedOn TClass]) + | KeepSub -> ":keepSub",("Extends @:keep metadata to all implementing and extending classes",[UsedOn TClass]) + | Meta -> ":meta",("Internally used to mark a class field as being the metadata field",[]) + | Macro -> ":macro",("(deprecated)",[]) + | MaybeUsed -> ":maybeUsed",("Internally used by DCE to mark fields that might be kept",[Internal]) + | MultiType -> ":multiType",("Specifies that an abstract chooses its this-type from its @:to functions",[UsedOn TAbstract]) + | Native -> ":native",("Rewrites the path of a class or enum during generation",[HasParam "Output type path";UsedOnEither [TClass;TEnum]]) + | NativeGen -> ":nativeGen",("Annotates that a type should be treated as if it were an extern definition - platform native",[Platforms [Java;Cs]; UsedOnEither[TClass;TEnum]]) + | NativeGeneric -> ":nativeGeneric",("Used internally to annotate native generic classes",[Platform Cs; UsedOnEither[TClass;TEnum]; Internal]) + | NoCompletion -> ":noCompletion",("Prevents the compiler from suggesting completion on this field",[UsedOn TClassField]) + | NoDebug -> ":noDebug",("Does not generate debug information into the Swf even if -debug is set",[UsedOnEither [TClass;TClassField];Platform Flash]) + | NoDoc -> ":noDoc",("Prevents a type from being included in documentation generation",[]) + | NoImportGlobal -> ":noImportGlobal",("Prevents a static field from being imported with import Class.*",[UsedOn TAnyField]) + | NoPackageRestrict -> ":noPackageRestrict",("?",[]) + | NoStack -> ":noStack",("",[Platform Cpp]) + | NotNull -> ":notNull",("Declares an abstract type as not accepting null values",[UsedOn TAbstract]) + | NoUsing -> ":noUsing",("Prevents a field from being used with 'using'",[UsedOn TClassField]) + | Ns -> ":ns",("Internally used by the Swf generator to handle namespaces",[Platform Flash]) + | Op -> ":op",("Declares an abstract field as being an operator overload",[HasParam "The operation";UsedOn TAbstractField]) + | Optional -> ":optional",("Marks the field of a structure as optional",[UsedOn TClassField]) + | Overload -> ":overload",("Allows the field to be called with different argument types",[HasParam "Function specification (no expression)";UsedOn TClassField]) + | Public -> ":public",("Marks a class field as being public",[UsedOn TClassField]) + | PublicFields -> ":publicFields",("Forces all class fields of inheriting classes to be public",[UsedOn TClass]) + | PrivateAccess -> ":privateAccess",("Internally used by the typer to allow context-sensitive private access",[Internal]) + | Protected -> ":protected",("Marks a class field as being protected",[UsedOn TClassField]) + | ReadOnly -> ":readOnly",("Generates a field with the 'readonly' native keyword",[Platform Cs; UsedOn TClassField]) + | RealPath -> ":realPath",("Internally used on @:native types to retain original path information",[Internal]) + | Remove -> ":remove",("Causes an interface to be removed from all implementing classes before generation",[UsedOn TClass]) + | Require -> ":require",("Allows access to a field only if the specified compiler flag is set",[HasParam "Compiler flag to check";UsedOn TClassField]) + | ReplaceReflection -> ":replaceReflection",("Used internally to specify a function that should replace its internal __hx_functionName counterpart",[Platforms [Java;Cs]; UsedOnEither[TClass;TEnum]; Internal]) + | Rtti -> ":rtti",("Adds runtime type informations",[UsedOn TClass]) + | Runtime -> ":runtime",("?",[]) + | RuntimeValue -> ":runtimeValue",("Marks an abstract as being a runtime value",[UsedOn TAbstract]) + | Setter -> ":setter",("Generates a native getter function on the given field",[HasParam "Class field name";UsedOn TClassField;Platform Flash]) + | SkipCtor -> ":skipCtor",("Used internally to generate a constructor as if it were a native type (no __hx_ctor)",[Platforms [Java;Cs]; Internal]) + | SkipReflection -> ":skipReflection",("Used internally to annotate a field that shouldn't have its reflection data generated",[Platforms [Java;Cs]; UsedOn TClassField; Internal]) + | Sound -> ":sound",( "Includes a given .wav or .mp3 file into the target Swf and associates it with the class (must extend flash.media.Sound)",[HasParam "File path";UsedOn TClass;Platform Flash]) + | Struct -> ":struct",("Marks a class definition as a struct.",[Platform Cs; UsedOn TClass]) + | SuppressWarnings -> ":suppressWarnings",("Adds a SuppressWarnings annotation for the generated Java class",[Platform Java; UsedOn TClass]) + | Throws -> ":throws",("Adds a 'throws' declaration to the generated function.",[HasParam "Type as String"; Platform Java; UsedOn TClassField]) + | To -> ":to",("Specifies that the field of the abstract is a cast operation to the type identified in the function",[UsedOn TAbstractField]) + | ToString -> ":toString",("Internally used",[Internal]) + | Transient -> ":transient",("Adds the 'transient' flag to the class field",[Platform Java; UsedOn TClassField]) + | ValueUsed -> ":valueUsed",("Internally used by DCE to mark an abstract value as used",[Internal]) + | Volatile -> ":volatile",("",[Platforms [Java;Cs]]) + | UnifyMinDynamic -> ":unifyMinDynamic",("Allows a collection of types to unify to Dynamic",[UsedOn TClassField]) + | Unreflective -> ":unreflective",("",[Platform Cpp]) + | Unsafe -> ":unsafe",("Declares a class, or a method with the C#'s 'unsafe' flag",[Platform Cs; UsedOnEither [TClass;TClassField]]) + | Usage -> ":usage",("?",[]) + | Used -> ":used",("Internally used by DCE to mark a class or field as used",[Internal]) + | Last -> assert false + (* do not put any custom metadata after Last *) + | Dollar s -> "$" ^ s,("",[]) + | Custom s -> s,("",[]) + + let hmeta = + let h = Hashtbl.create 0 in + let rec loop i = + let m = Obj.magic i in + if m <> Last then begin + Hashtbl.add h (fst (to_string m)) m; + loop (i + 1); + end; + in + loop 0; + h + + let parse s = try Hashtbl.find hmeta (":" ^ s) with Not_found -> Custom (":" ^ s) + + let from_string s = + if s = "" then Custom "" else match s.[0] with + | ':' -> (try Hashtbl.find hmeta s with Not_found -> Custom s) + | '$' -> Dollar (String.sub s 1 (String.length s - 1)) + | _ -> Custom s +end + +let stats = + { + s_files_parsed = ref 0; + s_classes_built = ref 0; + s_methods_typed = ref 0; + s_macros_called = ref 0; + } + +let default_config = + { + pf_static = true; + pf_sys = true; + pf_locals_scope = true; + pf_captured_scope = true; + pf_unique_locals = false; + pf_can_init_member = (fun _ -> true); + pf_capture_policy = CPNone; + pf_pad_nulls = false; + pf_add_final_return = false; + pf_overload = false; + } + +let get_config com = + let defined f = PMap.mem (fst (Define.infos f)) com.defines in + match com.platform with + | Cross -> + default_config + | Flash8 -> + { + pf_static = false; + pf_sys = false; + pf_locals_scope = com.flash_version > 6.; + pf_captured_scope = false; + pf_unique_locals = false; + pf_can_init_member = (fun _ -> true); + pf_capture_policy = CPLoopVars; + pf_pad_nulls = false; + pf_add_final_return = false; + pf_overload = false; + } + | Js -> + { + pf_static = false; + pf_sys = false; + pf_locals_scope = false; + pf_captured_scope = false; + pf_unique_locals = false; + pf_can_init_member = (fun _ -> false); + pf_capture_policy = CPLoopVars; + pf_pad_nulls = false; + pf_add_final_return = false; + pf_overload = false; + } + | Neko -> + { + pf_static = false; + pf_sys = true; + pf_locals_scope = true; + pf_captured_scope = true; + pf_unique_locals = false; + pf_can_init_member = (fun _ -> false); + pf_capture_policy = CPNone; + pf_pad_nulls = true; + pf_add_final_return = false; + pf_overload = false; + } + | Flash when defined Define.As3 -> + { + pf_static = true; + pf_sys = false; + pf_locals_scope = false; + pf_captured_scope = true; + pf_unique_locals = true; + pf_can_init_member = (fun _ -> true); + pf_capture_policy = CPLoopVars; + pf_pad_nulls = false; + pf_add_final_return = true; + pf_overload = false; + } + | Flash -> + { + pf_static = true; + pf_sys = false; + pf_locals_scope = true; + pf_captured_scope = true; (* handled by genSwf9 *) + pf_unique_locals = false; + pf_can_init_member = (fun _ -> false); + pf_capture_policy = CPLoopVars; + pf_pad_nulls = false; + pf_add_final_return = false; + pf_overload = false; + } + | Php -> + { + pf_static = false; + pf_sys = true; + pf_locals_scope = false; (* some duplicate work is done in genPhp *) + pf_captured_scope = false; + pf_unique_locals = false; + pf_can_init_member = (fun cf -> + match cf.cf_kind, cf.cf_expr with + | Var { v_write = AccCall }, _ -> false + | _, Some { eexpr = TTypeExpr _ } -> false + | _ -> true + ); + pf_capture_policy = CPNone; + pf_pad_nulls = true; + pf_add_final_return = false; + pf_overload = false; + } + | Cpp -> + { + pf_static = true; + pf_sys = true; + pf_locals_scope = true; + pf_captured_scope = true; + pf_unique_locals = false; + pf_can_init_member = (fun _ -> false); + pf_capture_policy = CPWrapRef; + pf_pad_nulls = true; + pf_add_final_return = true; + pf_overload = false; + } + | Cs -> + { + pf_static = true; + pf_sys = true; + pf_locals_scope = false; + pf_captured_scope = true; + pf_unique_locals = true; + pf_can_init_member = (fun _ -> false); + pf_capture_policy = CPWrapRef; + pf_pad_nulls = true; + pf_add_final_return = false; + pf_overload = true; + } + | Java -> + { + pf_static = true; + pf_sys = true; + pf_locals_scope = false; + pf_captured_scope = true; + pf_unique_locals = false; + pf_can_init_member = (fun _ -> false); + pf_capture_policy = CPWrapRef; + pf_pad_nulls = true; + pf_add_final_return = false; + pf_overload = true; + } + +let create v args = + let m = Type.mk_mono() in + { + version = v; + args = args; + sys_args = args; + debug = false; + display = !display_default; + verbose = false; + foptimize = true; + features = Hashtbl.create 0; + platform = Cross; + config = default_config; + print = (fun s -> print_string s; flush stdout); + run_command = Sys.command; + std_path = []; + class_path = []; + main_class = None; + defines = PMap.add "true" "1" (if !display_default then PMap.add "display" "1" PMap.empty else PMap.empty); + package_rules = PMap.empty; + file = ""; + types = []; + filters = []; + modules = []; + main = None; + flash_version = 10.; + resources = Hashtbl.create 0; + php_front = None; + php_lib = None; + swf_libs = []; + java_libs = []; + neko_libs = []; + php_prefix = None; + js_gen = None; + load_extern_type = []; + defines_signature = None; + get_macros = (fun() -> None); + warning = (fun _ _ -> assert false); + error = (fun _ _ -> assert false); + basic = { + tvoid = m; + tint = m; + tfloat = m; + tbool = m; + tnull = (fun _ -> assert false); + tstring = m; + tarray = (fun _ -> assert false); + }; + } + +let log com str = + if com.verbose then com.print (str ^ "\n") + +let clone com = + let t = com.basic in + { com with basic = { t with tvoid = t.tvoid }; main_class = None; features = Hashtbl.create 0; } + +let file_time file = + try (Unix.stat file).Unix.st_mtime with _ -> 0. + +let get_signature com = + match com.defines_signature with + | Some s -> s + | None -> + let str = String.concat "@" (PMap.foldi (fun k v acc -> + (* don't make much difference between these special compilation flags *) + match k with + | "display" | "use_rtti_doc" | "macrotimes" -> acc + | _ -> k :: v :: acc + ) com.defines []) in + let s = Digest.string str in + com.defines_signature <- Some s; + s + +let file_extension file = + match List.rev (ExtString.String.nsplit file ".") with + | e :: _ -> String.lowercase e + | [] -> "" + +let platforms = [ + Flash8; + Js; + Neko; + Flash; + Php; + Cpp; + Cs; + Java; +] + +let platform_name = function + | Cross -> "cross" + | Flash8 -> "flash8" + | Js -> "js" + | Neko -> "neko" + | Flash -> "flash" + | Php -> "php" + | Cpp -> "cpp" + | Cs -> "cs" + | Java -> "java" + +let flash_versions = List.map (fun v -> + let maj = int_of_float v in + let min = int_of_float (mod_float (v *. 10.) 10.) in + v, string_of_int maj ^ (if min = 0 then "" else "_" ^ string_of_int min) +) [9.;10.;10.1;10.2;10.3;11.;11.1;11.2;11.3;11.4;11.5;11.6;11.7;11.8] + +let raw_defined ctx v = + PMap.mem v ctx.defines + +let defined ctx v = + raw_defined ctx (fst (Define.infos v)) + +let raw_defined_value ctx k = + PMap.find k ctx.defines + +let defined_value ctx v = + raw_defined_value ctx (fst (Define.infos v)) + +let defined_value_safe ctx v = + try defined_value ctx v + with Not_found -> "" + +let raw_define ctx v = + let k,v = try ExtString.String.split v "=" with _ -> v,"1" in + ctx.defines <- PMap.add k v ctx.defines; + let k = String.concat "_" (ExtString.String.nsplit k "-") in + ctx.defines <- PMap.add k v ctx.defines; + ctx.defines_signature <- None + +let define_value ctx k v = + raw_define ctx (fst (Define.infos k) ^ "=" ^ v) + +let define ctx v = + raw_define ctx (fst (Define.infos v)) + +let init_platform com pf = + com.platform <- pf; + let name = platform_name pf in + let forbid acc p = if p = name || PMap.mem p acc then acc else PMap.add p Forbidden acc in + com.package_rules <- List.fold_left forbid com.package_rules (List.map platform_name platforms); + com.config <- get_config com; +(* if com.config.pf_static then define com "static"; *) + if com.config.pf_sys then define com Define.Sys else com.package_rules <- PMap.add "sys" Forbidden com.package_rules; + raw_define com name + +let add_feature com f = + Hashtbl.replace com.features f true + +let has_dce com = + (try defined_value com Define.Dce <> "no" with Not_found -> false) + +let rec has_feature com f = + try + Hashtbl.find com.features f + with Not_found -> + if com.types = [] then not (has_dce com) else + match List.rev (ExtString.String.nsplit f ".") with + | [] -> assert false + | [cl] -> has_feature com (cl ^ ".*") + | meth :: cl :: pack -> + let r = (try + let path = List.rev pack, cl in + (match List.find (fun t -> t_path t = path && not (Ast.Meta.has Ast.Meta.RealPath (t_infos t).mt_meta)) com.types with + | t when meth = "*" -> (match t with TAbstractDecl a -> Ast.Meta.has Ast.Meta.ValueUsed a.a_meta | _ -> Ast.Meta.has Ast.Meta.Used (t_infos t).mt_meta) + | TClassDecl ({cl_extern = true} as c) -> Meta.has Meta.Used (try PMap.find meth c.cl_statics with Not_found -> PMap.find meth c.cl_fields).cf_meta + | TClassDecl c -> PMap.exists meth c.cl_statics || PMap.exists meth c.cl_fields + | _ -> false) + with Not_found -> + false + ) in + let r = r || not (has_dce com) in + Hashtbl.add com.features f r; + r + +let allow_package ctx s = + try + if (PMap.find s ctx.package_rules) = Forbidden then ctx.package_rules <- PMap.remove s ctx.package_rules + with Not_found -> + () + +let error msg p = raise (Abort (msg,p)) + +let platform ctx p = ctx.platform = p + +let add_filter ctx f = + ctx.filters <- f :: ctx.filters + +let find_file ctx f = + let rec loop = function + | [] -> raise Not_found + | p :: l -> + let file = p ^ f in + if Sys.file_exists file then + file + else + loop l + in + loop ctx.class_path + +let get_full_path f = try Extc.get_full_path f with _ -> f + +let unique_full_path = if Sys.os_type = "Win32" || Sys.os_type = "Cygwin" then (fun f -> String.lowercase (get_full_path f)) else get_full_path + +let normalize_path p = + let l = String.length p in + if l = 0 then + "./" + else match p.[l-1] with + | '\\' | '/' -> p + | _ -> p ^ "/" + +(* ------------------------- TIMERS ----------------------------- *) + +type timer_infos = { + name : string; + mutable start : float list; + mutable total : float; +} + +let get_time = Extc.time +let htimers = Hashtbl.create 0 + +let new_timer name = + try + let t = Hashtbl.find htimers name in + t.start <- get_time() :: t.start; + t + with Not_found -> + let t = { name = name; start = [get_time()]; total = 0.; } in + Hashtbl.add htimers name t; + t + +let curtime = ref [] + +let close t = + let start = (match t.start with + | [] -> assert false + | s :: l -> t.start <- l; s + ) in + let now = get_time() in + let dt = now -. start in + t.total <- t.total +. dt; + let rec loop() = + match !curtime with + | [] -> failwith ("Timer " ^ t.name ^ " closed while not active") + | tt :: l -> curtime := l; if t != tt then loop() + in + loop(); + (* because of rounding errors while adding small times, we need to make sure that we don't have start > now *) + List.iter (fun ct -> ct.start <- List.map (fun t -> let s = t +. dt in if s > now then now else s) ct.start) !curtime + +let timer name = + let t = new_timer name in + curtime := t :: !curtime; + (function() -> close t) + +let rec close_times() = + match !curtime with + | [] -> () + | t :: _ -> close t; close_times() + diff --git a/dce.ml b/dce.ml new file mode 100644 index 0000000000000000000000000000000000000000..d8fb612b47d7ccfc3b9a804d501ba8cad0d5734f --- /dev/null +++ b/dce.ml @@ -0,0 +1,497 @@ +(* + * 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 Common +open Type + +type dce = { + com : context; + full : bool; + std_dirs : string list; + debug : bool; + follow_expr : dce -> texpr -> unit; + mutable added_fields : (tclass * tclass_field * bool) list; + mutable marked_fields : tclass_field list; + mutable marked_maybe_fields : tclass_field list; + mutable t_stack : t list; +} + +(* checking *) + +(* check for @:keepSub metadata, which forces @:keep on child classes *) +let rec super_forces_keep c = + Meta.has Meta.KeepSub c.cl_meta || match c.cl_super with + | Some (csup,_) -> super_forces_keep csup + | _ -> false + +let is_std_file dce file = + List.exists (ExtString.String.starts_with file) dce.std_dirs + +(* check if a class is kept entirely *) +let keep_whole_class dce c = + Meta.has Meta.Keep c.cl_meta + || not (dce.full || is_std_file dce c.cl_module.m_extra.m_file) + || super_forces_keep c + || (match c with + | { cl_extern = true; cl_path = ([],("Math"|"Array"))} when dce.com.platform = Js -> false + | { cl_extern = true } + | { cl_path = ["flash";"_Boot"],"RealBoot" } -> true + | { cl_path = [],"String" } + | { cl_path = [],"Array" } -> not (dce.com.platform = Js) + | _ -> false) + +(* check if a metadata contains @:ifFeature with a used feature argument *) +let has_used_feature com meta = + try + let _,el,_ = Meta.get Meta.IfFeature meta in + List.exists (fun e -> match fst e with + | EConst(String s) when Common.has_feature com s -> true + | _ -> false + ) el + with Not_found -> + false + +(* check if a field is kept *) +let keep_field dce cf = + Meta.has Meta.Keep cf.cf_meta + || Meta.has Meta.Used cf.cf_meta + || cf.cf_name = "__init__" + || has_used_feature dce.com cf.cf_meta + +(* marking *) + +(* mark a field as kept *) +let rec mark_field dce c cf stat = + let add () = + if not (Meta.has Meta.Used cf.cf_meta) then begin + cf.cf_meta <- (Meta.Used,[],cf.cf_pos) :: cf.cf_meta; + dce.added_fields <- (c,cf,stat) :: dce.added_fields; + dce.marked_fields <- cf :: dce.marked_fields + end + in + if not (PMap.mem cf.cf_name (if stat then c.cl_statics else c.cl_fields)) then begin + match c.cl_super with + | None -> add() + | Some (c,_) -> mark_field dce c cf stat + end else + add() + +let rec update_marked_class_fields dce c = + (* mark all :?used fields as surely :used now *) + List.iter (fun cf -> + if Meta.has Meta.MaybeUsed cf.cf_meta then mark_field dce c cf true + ) c.cl_ordered_statics; + List.iter (fun cf -> + if Meta.has Meta.MaybeUsed cf.cf_meta then mark_field dce c cf false + ) c.cl_ordered_fields; + (* we always have to keep super classes and implemented interfaces *) + (match c.cl_init with None -> () | Some init -> dce.follow_expr dce init); + List.iter (fun (c,_) -> mark_class dce c) c.cl_implements; + (match c.cl_super with None -> () | Some (csup,pl) -> mark_class dce csup) + +(* mark a class as kept. If the class has fields marked as @:?keep, make sure to keep them *) +and mark_class dce c = if not (Meta.has Meta.Used c.cl_meta) then begin + c.cl_meta <- (Meta.Used,[],c.cl_pos) :: c.cl_meta; + update_marked_class_fields dce c; +end + +let rec mark_enum dce e = if not (Meta.has Meta.Used e.e_meta) then begin + e.e_meta <- (Meta.Used,[],e.e_pos) :: e.e_meta; + PMap.iter (fun _ ef -> mark_t dce ef.ef_type) e.e_constrs; +end + +and mark_abstract dce a = if not (Meta.has Meta.Used a.a_meta) then + a.a_meta <- (Meta.Used,[],a.a_pos) :: a.a_meta + +(* mark a type as kept *) +and mark_t dce t = match follow t with + | TInst({cl_kind = KTypeParameter tl} as c,pl) -> + if not (Meta.has Meta.Used c.cl_meta) then begin + c.cl_meta <- (Meta.Used,[],c.cl_pos) :: c.cl_meta; + List.iter (mark_t dce) tl; + end; + List.iter (mark_t dce) pl + | TInst(c,pl) -> + mark_class dce c; + List.iter (mark_t dce) pl + | TFun(args,ret) -> + List.iter (fun (_,_,t) -> mark_t dce t) args; + mark_t dce ret + | TEnum(e,pl) -> + mark_enum dce e; + List.iter (mark_t dce) pl + | TAbstract(a,pl) -> + mark_abstract dce a; + List.iter (mark_t dce) pl + | TLazy _ | TDynamic _ | TAnon _ | TType _ | TMono _ -> () + +let mark_mt dce mt = match mt with + | TClassDecl c -> + mark_class dce c; + | TEnumDecl e -> + mark_enum dce e + | TAbstractDecl a -> + (* abstract 'feature' is defined as the abstract type beeing used as a value, not as a type *) + if not (Meta.has Meta.ValueUsed a.a_meta) then a.a_meta <- (Meta.ValueUsed,[],a.a_pos) :: a.a_meta; + mark_abstract dce a + | TTypeDecl _ -> + () + +(* find all dependent fields by checking implementing/subclassing types *) +let rec mark_dependent_fields dce csup n stat = + List.iter (fun mt -> match mt with + | TClassDecl c when is_parent csup c -> + let rec loop c = + (try + let cf = PMap.find n (if stat then c.cl_statics else c.cl_fields) in + (* if it's clear that the class is kept, the field has to be kept as well. This is also true for + extern interfaces because we cannot remove fields from them *) + if Meta.has Meta.Used c.cl_meta || (csup.cl_interface && csup.cl_extern) then mark_field dce c cf stat + (* otherwise it might be kept if the class is kept later, so mark it as :?used *) + else if not (Meta.has Meta.MaybeUsed cf.cf_meta) then begin + cf.cf_meta <- (Meta.MaybeUsed,[],cf.cf_pos) :: cf.cf_meta; + dce.marked_maybe_fields <- cf :: dce.marked_maybe_fields; + end + with Not_found -> + (* if the field is not present on current class, it might come from a base class *) + (match c.cl_super with None -> () | Some (csup,_) -> loop csup)) + in + loop c + | _ -> () + ) dce.com.types + +(* expr and field evaluation *) + +let opt f e = match e with None -> () | Some e -> f e + +let rec to_string dce t = + let push t = + dce.t_stack <- t :: dce.t_stack; + fun () -> dce.t_stack <- List.tl dce.t_stack + in + let t = follow t in + if not (List.exists (fun t2 -> Type.fast_eq t t2) dce.t_stack) then match follow t with + | TInst(c,pl) as t -> + let pop = push t in + field dce c "toString" false; + List.iter (to_string dce) pl; + pop(); + | TEnum(en,pl) as t -> + let pop = push t in + PMap.iter (fun _ ef -> to_string dce ef.ef_type) en.e_constrs; + List.iter (to_string dce) pl; + pop(); + | TAnon a as t -> + let pop = push t in + PMap.iter (fun _ cf -> to_string dce cf.cf_type) a.a_fields; + pop(); + | TFun(args,r) as t -> + let pop = push t in + List.iter (fun (_,_,t) -> to_string dce t) args; + to_string dce r; + pop(); + | _ -> () + +and field dce c n stat = + let find_field n = + if n = "new" then match c.cl_constructor with + | None -> raise Not_found + | Some cf -> cf + else PMap.find n (if stat then c.cl_statics else c.cl_fields) + in + (try + let cf = find_field n in + mark_field dce c cf stat; + with Not_found -> try + (* me might have a property access on an interface *) + let l = String.length n - 4 in + if l < 0 then raise Not_found; + let prefix = String.sub n 0 4 in + let pn = String.sub n 4 l in + let cf = find_field pn in + if not (Meta.has Meta.Used cf.cf_meta) then begin + let keep () = + mark_dependent_fields dce c n stat; + field dce c pn stat + in + (match prefix,cf.cf_kind with + | "get_",Var {v_read = AccCall} when "get_" ^ cf.cf_name = n -> keep() + | "set_",Var {v_write = AccCall} when "set_" ^ cf.cf_name = n -> keep() + | _ -> raise Not_found + ); + end; + raise Not_found + with Not_found -> try + if c.cl_interface then begin + let rec loop cl = match cl with + | [] -> raise Not_found + | (c,_) :: cl -> + try field dce c n stat with Not_found -> loop cl + in + loop c.cl_implements + end else match c.cl_super with Some (csup,_) -> field dce csup n stat | None -> raise Not_found + with Not_found -> try + match c.cl_kind with + | KTypeParameter tl -> + let rec loop tl = match tl with + | [] -> raise Not_found + | TInst(c,_) :: cl -> + (try field dce c n stat with Not_found -> loop cl) + | t :: tl -> + loop tl + in + loop tl + | _ -> raise Not_found + with Not_found -> + if dce.debug then prerr_endline ("[DCE] Field " ^ n ^ " not found on " ^ (s_type_path c.cl_path)) else ()) + +and expr dce e = + mark_t dce e.etype; + match e.eexpr with + | TNew(c,pl,el) -> + mark_class dce c; + let rec loop c = + field dce c "new" false; + match c.cl_super with None -> () | Some (csup,_) -> loop csup + in + loop c; + List.iter (expr dce) el; + List.iter (mark_t dce) pl; + | TVars vl -> + List.iter (fun (v,e) -> + opt (expr dce) e; + mark_t dce v.v_type; + ) vl; + | TCast(e, Some mt) -> + mark_mt dce mt; + expr dce e; + | TTypeExpr mt -> + mark_mt dce mt + | TTry(e, vl) -> + expr dce e; + List.iter (fun (v,e) -> + expr dce e; + mark_t dce v.v_type; + ) vl; + | TCall ({eexpr = TLocal ({v_name = "__define_feature__"})},[{eexpr = TConst (TString ft)};e]) -> + Common.add_feature dce.com ft; + expr dce e + (* keep toString method when the class is argument to Std.string or haxe.Log.trace *) + | TCall ({eexpr = TField({eexpr = TTypeExpr (TClassDecl ({cl_path = (["haxe"],"Log")} as c))},FStatic (_,{cf_name="trace"}))} as ef, ([e2;_] as args)) + | TCall ({eexpr = TField({eexpr = TTypeExpr (TClassDecl ({cl_path = ([],"Std")} as c))},FStatic (_,{cf_name="string"}))} as ef, ([e2] as args)) -> + mark_class dce c; + to_string dce e2.etype; + expr dce ef; + List.iter (expr dce) args; + | TCall ({eexpr = TConst TSuper} as e,el) -> + mark_t dce e.etype; + List.iter (expr dce) el; + | TField(e,fa) -> + begin match fa with + | FStatic(c,cf) -> + mark_class dce c; + mark_field dce c cf true; + | FInstance(c,cf) -> + mark_class dce c; + mark_field dce c cf false; + | _ -> + let n = field_name fa in + begin match follow e.etype with + | TInst(c,_) -> + mark_class dce c; + field dce c n false; + | TAnon a -> + (match !(a.a_status) with + | Statics c -> + mark_class dce c; + field dce c n true; + | _ -> ()) + | _ -> () + end; + end; + expr dce e; + | TThrow e -> + to_string dce e.etype; + expr dce e + | _ -> + Type.iter (expr dce) e + +let run com main full = + let dce = { + com = com; + full = full; + std_dirs = if full then [] else List.map Common.unique_full_path com.std_path; + debug = Common.defined com Define.DceDebug; + added_fields = []; + follow_expr = expr; + marked_fields = []; + marked_maybe_fields = []; + t_stack = []; + } in + begin match main with + | Some {eexpr = TCall({eexpr = TField(e,(FStatic(c,cf)))},_)} -> + cf.cf_meta <- (Meta.Keep,[],cf.cf_pos) :: cf.cf_meta + | _ -> + () + end; + (* first step: get all entry points, which is the main method and all class methods which are marked with @:keep *) + List.iter (fun t -> match t with + | TClassDecl c -> + let keep_class = keep_whole_class dce c && (not c.cl_extern || c.cl_interface) in + let loop stat cf = + if keep_class || keep_field dce cf then mark_field dce c cf stat + in + List.iter (loop true) c.cl_ordered_statics; + List.iter (loop false) c.cl_ordered_fields; + begin match c.cl_constructor with + | Some cf -> loop false cf + | None -> () + end + | _ -> + () + ) com.types; + if dce.debug then begin + List.iter (fun (c,cf,_) -> match cf.cf_expr with + | None -> () + | Some _ -> print_endline ("[DCE] Entry point: " ^ (s_type_path c.cl_path) ^ "." ^ cf.cf_name) + ) dce.added_fields; + end; + (* second step: initiate DCE passes and keep going until no new fields were added *) + let rec loop () = + match dce.added_fields with + | [] -> () + | cfl -> + dce.added_fields <- []; + (* extend to dependent (= overriding/implementing) class fields *) + List.iter (fun (c,cf,stat) -> mark_dependent_fields dce c cf.cf_name stat) cfl; + (* mark fields as used *) + List.iter (fun (c,cf,stat) -> + mark_class dce c; + mark_field dce c cf stat; + mark_t dce cf.cf_type + ) cfl; + (* follow expressions to new types/fields *) + List.iter (fun (_,cf,_) -> + opt (expr dce) cf.cf_expr; + List.iter (fun cf -> if cf.cf_expr <> None then opt (expr dce) cf.cf_expr) cf.cf_overloads + ) cfl; + loop () + in + loop (); + (* third step: filter types *) + let rec loop acc types = + match types with + | (TClassDecl c) as mt :: l when keep_whole_class dce c -> + loop (mt :: acc) l + | (TClassDecl c) as mt :: l -> + (* add :keep so subsequent filter calls do not process class fields again *) + c.cl_meta <- (Meta.Keep,[],c.cl_pos) :: c.cl_meta; + c.cl_ordered_statics <- List.filter (fun cf -> + let b = keep_field dce cf in + if not b then begin + if dce.debug then print_endline ("[DCE] Removed field " ^ (s_type_path c.cl_path) ^ "." ^ (cf.cf_name)); + c.cl_statics <- PMap.remove cf.cf_name c.cl_statics; + end; + b + ) c.cl_ordered_statics; + c.cl_ordered_fields <- List.filter (fun cf -> + let b = keep_field dce cf in + if not b then begin + if dce.debug then print_endline ("[DCE] Removed field " ^ (s_type_path c.cl_path) ^ "." ^ (cf.cf_name)); + c.cl_fields <- PMap.remove cf.cf_name c.cl_fields; + end; + b + ) c.cl_ordered_fields; + (match c.cl_constructor with Some cf when not (keep_field dce cf) -> c.cl_constructor <- None | _ -> ()); + (* we keep a class if it was used or has a used field *) + if Meta.has Meta.Used c.cl_meta || c.cl_ordered_statics <> [] || c.cl_ordered_fields <> [] then loop (mt :: acc) l else begin + (match c.cl_init with + | Some f when Meta.has Meta.KeepInit c.cl_meta -> + (* it means that we only need the __init__ block *) + c.cl_extern <- true; + loop (mt :: acc) l + | _ -> + if dce.debug then print_endline ("[DCE] Removed class " ^ (s_type_path c.cl_path)); + loop acc l) + end + | (TEnumDecl e) as mt :: l when Meta.has Meta.Used e.e_meta || Meta.has Meta.Keep e.e_meta || e.e_extern || not (dce.full || is_std_file dce e.e_module.m_extra.m_file) -> + loop (mt :: acc) l + | TEnumDecl e :: l -> + if dce.debug then print_endline ("[DCE] Removed enum " ^ (s_type_path e.e_path)); + loop acc l + | mt :: l -> + loop (mt :: acc) l + | [] -> + acc + in + com.types <- loop [] (List.rev com.types); + + (* extra step to adjust properties that had accessors removed (required for Php and Cpp) *) + List.iter (fun mt -> match mt with + | (TClassDecl c) -> + let rec has_accessor c n stat = + PMap.mem n (if stat then c.cl_statics else c.cl_fields) + || match c.cl_super with Some (csup,_) -> has_accessor csup n stat | None -> false + in + let check_prop stat cf = + (match cf.cf_kind with + | Var {v_read = AccCall; v_write = a} -> + let s = "get_" ^ cf.cf_name in + cf.cf_kind <- Var {v_read = if has_accessor c s stat then AccCall else AccNever; v_write = a} + | _ -> ()); + (match cf.cf_kind with + | Var {v_write = AccCall; v_read = a} -> + let s = "set_" ^ cf.cf_name in + cf.cf_kind <- Var {v_write = if has_accessor c s stat then AccCall else AccNever; v_read = a} + | _ -> ()) + in + List.iter (check_prop true) c.cl_ordered_statics; + List.iter (check_prop false) c.cl_ordered_fields; + | _ -> () + ) com.types; + + (* remove "override" from fields that do not override anything anymore *) + List.iter (fun mt -> match mt with + | TClassDecl c -> + c.cl_overrides <- List.filter (fun s -> + let rec loop c = + match c.cl_super with + | Some (csup,_) when PMap.mem s.cf_name csup.cl_fields -> true + | Some (csup,_) -> loop csup + | None -> false + in + loop c + ) c.cl_overrides; + | _ -> () + ) com.types; + + (* cleanup added fields metadata - compatibility with compilation server *) + let rec remove_meta m = function + | [] -> [] + | (m2,_,_) :: l when m = m2 -> l + | x :: l -> x :: remove_meta m l + in + List.iter (fun cf -> cf.cf_meta <- remove_meta Meta.Used cf.cf_meta) dce.marked_fields; + List.iter (fun cf -> cf.cf_meta <- remove_meta Meta.MaybeUsed cf.cf_meta) dce.marked_maybe_fields; + + diff --git a/haxe/doc/CHANGES.txt b/doc/CHANGES.txt similarity index 78% rename from haxe/doc/CHANGES.txt rename to doc/CHANGES.txt index e118eaba5de8c8b9282d228321cffe29365957d2..0c8a3a90b13c6c9e057c266627cd94ae2ee0a394 100644 --- a/haxe/doc/CHANGES.txt +++ b/doc/CHANGES.txt @@ -1,3 +1,249 @@ +2013-05-25: 3.0.0 + all : added haxe.ds.BalancedTree + all : added haxe.ds.EnumValueMap + all : allow enum constructors as keys to Map + all : haxe.ds.ObjectMap is now correctly constrained on all targets + all : preliminary support of -D display-mode=usage|position|metadata + all : improved pattern matcher error messages + all : allow inline constructors + all : allow abstract member macros (not for @:op, @:arrayAccess, @:from, @:to) + all : allow abstract type parameter variance + all : do not generate hidden null on if without else + macro : made abstract structure available + +2013-05-08: 3.0.0-RC2 + all : improved abstract support + all : renamed HAXE_LIBRARY_PATH to HAXE_STD_PATH + all : added inlinable constructors + all : renamed haxe.ds.FastCell to GenericCell + all : fixed >= operator in #if conditionals + all : improved completion support for Unknown results + all : allowed [] access for Map + all : added haxe.ds.WeakMap (not yet supported on all platforms) + all : all trace parameters are now printed by default + all : added --help-metas + all : improved completion + all : improved pattern matching variable capture and GADT support + js : cached $bind results (unique closure creation per instance) + js : removed --js-modern (now as default) + cpp : added socket.setFastSend + flash : update player 11.7 api + flash : improved @:font, @:sound and @:bitmap support + neko/java/cs : improved Array performances when growing with [] + java : added -java-lib support + java : added sys.net package implementation (alpha) + java : complete java std library through hxjava haxelib + java/cs : added support for overloaded function declarations + java/cs : overload selection algorithm + cs : operator overloading is now accessible through Haxe + cs : source mapping; can be disabled with -D real_position + as3 : fixed rare syntax ambiguity + php : removed initialization of some inline fields + macro : fixed several issues with 'using' a macro function + macro : improved expression printing + +2013-02-24: 3.0.0-RC + flash : updated player 11.4 api + all : allowed named functions as r-value + all : fixed using + overload usage + all : allow any type constraint for type parameters + all : make property type optional (when a initial value is set) + all : Std.random(x) when x <= 0 is now always 0 + spod : added serialized data with SData + all : Dispatcher will now throw DETooManyValues + all : speed up neko compilation by using native compiler + all : allow @:generic on functions + all : allow constructing generic type parameters + swf : added support for SWC files in -swf-lib + macro : added Context.onTypeNotFound callback for unresolved types + js : no JS embed as default (use -D embed-js instead) + all : added abstract types (Int/Float/Bool/Void/Class/Enum/EnumValue) + all : added --help-defines + all : changed DCE with three modes : std(default), no and full + all : Haxe3 packages changes (see http://haxe.org/manual/haxe3) + all : Removed haxe.Int32, haxe.Firebug, haxe.TimerQueue + all : added -D key=value and #if (key >= value) operations + all : StringTools.htmlEscape/unescape nows handle "/" and '/' + all : using and import must now appear before any type declaration in a file + all : no longer create variable fields for pure getter/setter properties (unless @:isVar is used) + all : use default get_prop/set_prop instead of custom getter/setter names for properties + js : added JQuery.delegateTarget + macro : removed EType and CType, added EMeta, modified ESwitch + all : allow @metadata expr + all : replaced haxe.rtti.Generic interface with @:generic metadata + all : no longer infer arrays of mixed types as Array + all : all type/import/enum constructor resolution now follows the shadowing principle (latest has priority) + all : added EReg.matchSub, renamed EReg.customReplace to map + all : no longer allow initialization of extern non-inline variables + swf : fixed out of memory errors on very large swf-lib files + swf : added -D swf_preloader_frame, swf_gpu, swf_direct_blit + swf : added -D swf_script_timeout=seconds, swf_debug_password=password, swf_metadata=file + swf : added -swf-lib-extern + swf : added @:font support (beta) + all : added GADT support in enums + all : added pattern matching (beta) + all : changed callback(func, args) to func.bind(args) + macro : added haxe.macro.ExprTools/ComplexTypeTools/TypeTools + macro : changed reification syntax to ${expr}, $a{array}, $p{path}, $v{value} + macro : allow macro @:pos(pos-expr) to inject positions for reification + all : added array comprehension + flash : Vector.length is now Int instead of UInt + all : moved haxe.BaseCode, haxe.Md5 and haxe.SHA1 to haxe.crypto package + all : disallow Void variables and arguments (still allow S -> T to S -> Void) + all : added Array.map/filter + all : added spell check suggestions for enum constructors and fields + all : added opaque abstract(T) types + all : allow operator overloading on opaque abstract types + all : renamed IntIter to IntIterator + all : added Map + all : added haxe.ds with StringMap, IntMap, HashMap, ObjectMap, Vector, GenericStack + all : removed Hash, IntHash and haxe.FastList in favor of the types in haxe.ds + all : haxe.xml.Parser now handles entities consistently across platforms + all : renamed HAXE_LIBRARY_PATH environment variable to HAXE_STD_PATH + +2012-07-16: 2.10 + java/cs : added two new targets (beta) + all : fixed List and Null for first, last, pop + js : added js.Lib.debug() + flash : fixed Xml.parent() when no parent + flash : fixed haxe.io.Bytes.blit when len=0 + js/php/flash8 : fixed haxe.Int32.mul overflow on 52 bits + js : fixed haxe.Utf8 usage (static 'length' issue) + all : does not allow overriding var/prop + flash : removed wrapping for Xml nodes, use instead specific compare when comparing two typed nodes + js : use new haxe.xml.Parser (faster, not based on Regexp) + flash : fixed completion issue with for( x in Vector ) + all : optimized Std.int(123) and Std.int(123.45) + flash : bugfix for @:bitmap with 24-bits PNG (flash decode wrong colors) + as3 : fixed EnumValue becomes Object + js : removed js.Lib.isIE/isOpera (not complete, use js.JQuery.browser instead) + all : function parameters are nullable if they are declared with '?' + all : added support for finding common base types of multiple types (unify_min) for array, switch, if + php : do not implement duplicate interfaces + haxelib : added git support through haxelib git + all : allow derived classes to widen method visibility + macro : added haxe.macro.Context.getLocalMethod + macro : improved support of "using" macro functions + php : optimized Xml implementation + php : fixed Reflect.get/setProperty not working on PHP < 5.3 + all : support for callback(f, _, x) + all : allow private access between classes that have a common base class + all : added Output.writeFloat/Double and Input.readFloat/Double + all : support for var:{x:Float} = { x = 1 } constant structure subtyping + all : allow contravariant function arguments and covariant function returns in overrides + macro : support for final Array argument as rest argument + macro : use top-down inference on macro calls + all : made "using" imply "import" + all : made String concat more consistent across platforms (add Std.string wrappers) + all : allow direct member variable/property and static property initialization + js : greatly reduced amount of generated code by using smarter DCE + php : made modulo operations more consistent + all : allow local functions to have both type parameters and be inlined + all : functions type parameters can be constraint (will be checked at end of compilation) + macro : use NekoVM runtime for regexps, process and xml parsing + flash : allow @:getter/@:setter in interfaces + flash : added support for "arguments" in methods + all : not used enums and inline var/methods are now removed by DCE + all : allow @:overload to use type parameters and not-absolute type paths + all : ensure that Std.string of arrays and enums are now consistent across platforms + all : allow to inline functions containing other functions + xml : added metadata output to xml generator + macro : added macro and macro : reification + all : renamed type(e) to $type(e) + as3 : support for metadata and resources, and other fixes + +2012-04-14: 2.09 + all : optimized const == const and const != const (with different const types) + all : add Type.allEnums(e) + all : big improvements with completion speed and fixed many issues + flash9 : fixed -D swfprotected with swc output + neko : added ~ implementation + js : upgraded jquery version, more api overloads + sys : added "in" operator for spod macros, added relation access in expressions + macro : added ECheckType + macro : added TLazy for not-yet-typed class fields + js/php/neko : added haxe.web.Request + all : added Std.format + js : trace() output fallback on console.log if no id="haxe:trace" + all : ensure that Std.is(2.0,Int) returns true on all platforms + js : replaced $closure by function.$bind + changes in output format + all : allowed @:extern on static methods (no generate + no closure + force inlining) + all : added documentation in --display infos + display overloads in completion + js : removed --js-namespace, added $hxClasses + flash : output traces to native trace() when using -D fdb or -D nativeTrace + all : allowed abitrary string fields in anonymous objects + all : allowed optional structure fields (for constant structs) + all : allowed optional args in functions types (?Int -> Void) + all : added Reflect.getProperty/setProperty (except flash8) + all : added --wait and --cwd and --connect (parsed files and module caching) + all : fixed completion in macros calls arguments + all : fixed DCE removing empty but still used interfaces/superclasses + all : added haxe.Utf8 (crossplatform) + neko : Reflect now uses $fasthash (require neko 1.8.2) + all : allow \uXXXX in regexp (although not supported everywhere) + js : make difference between values and statements expressions in JSGenApi + js : added source mapping with -debug (replace previous stack emulation) + flash : added @:file("a.dat") class File extends flash.utils.ByteArray + flash : added @:sound("file.wav|mp3") class S extends flash.media.Sound + js : added --js-modern for wrapping output in a closure and ES5 strict mode + all : null, true and false are now keywords + all : neko.io.Path, cpp.io.Path and php.io.Path are now haxe.io.Path + neko, cpp, php : added Sys class, sys.io and sys.net packages and "sys" define + all : allow to access root package with std prefix (std.Type for example) + all : added haxe.EnumFlags + sys : io.File.getChar/stdin/stdout/stderr are now in Sys class + cpp : Reflect.getField and Reflect.setField no longer call property functions. Use Reflect.getProperty and Refelect.setProperty instead. + cpp : Default arguments now use Null for performance increase and interface compatibility + cpp : Added metadata options for injecting native cpp code into headers, classes and functions + php : added php.Lib.mail + (hotfix) fixed bug in completion and disabled profiling on Linux + (hotfix) fixed $ssize when doing new String(v) in neko + (hotfix) fixed bug with properties in interfaces for Flash & PHP + +2011-09-25: 2.08 + js : added js.JQuery + all : added @:overload + js : upgraded js.SWFObject from 1.4.4 inlined to 1.5 embedded + js : code generator beautify + all : ensure that modifying returned Type.getEnumConstructs array does not affect enum + all : allow macro typed parameters (other than Expr) + flash : added flash11 apis + neko : added support for https to haxe.Http (using hxssl library) + all : added haxe.Int64 + all : added haxe.Int32 isNeg,isZero,ucompare, fixed overflows for js/flash8/php + all : bugfix when optimizing inlined immediate function call + all : fixed "using" on macro function + all : allowed member macros functions (called as static) + neko : allowed serialization of haxe.Int32 (as Int) + all : fixed invalid optimization of two constant numbers comparison + flash8 : bugfix Std.parseInt with some hex values + flash9 : added flash.utils.RegExp + all : changed @:build behavior, now takes/returns a var with anonymous fields + all : added @:native support for enums + neko : changed the result of array-assign expression (was null) + flash9 : no longer auto create enums from SWF classes + (need explicit "enum" type patch) + all : optimized variable tracking/renaming + all : optimized macro engine (speed x2) + all : added -D macrotimes support + flash9 : store resources in bytes tag instead of bytecode + all : allow $ prefixed identifiers (for macros usage only) + all : allow to access modules subtype statics with pack.Mod.Type.value + and fixed identifier resolution order + flash9 : added @:bitmap("file") for simple embedding + all : added haxe.web.Dispatch + js : added js.Storage + all : allow this + member variables access in local functions + added untyped __this__ support and transition error + all : added haxe.macro.MacroType + neko : neko.Lib.serialize/unserialize now returns bytes + neko : added sys.db package (crossplatform with -D spod_macro support) + spod_macro now uses wrappers for Bytes (require neko 1.8.2) + php : added --php-prefix for prefixing generated files and class names + all : added type_expr_with_type enum support + php/js : fixed adding 'null' to StringBuf + all : added haxe.macro.Context.defineType + 2011-01-30: 2.07 all : fixed completion support with --remap all : added macros, added --interp diff --git a/doc/CONTRIB.txt b/doc/CONTRIB.txt new file mode 100644 index 0000000000000000000000000000000000000000..eb519d63e9a0c5d60d2f6c19a156c6110e7bf8af --- /dev/null +++ b/doc/CONTRIB.txt @@ -0,0 +1,25 @@ +Contributor License Agreement : + +You accept and agree to the following terms and conditions for Your present and future Contributions submitted to the project Haxe : + +1) Definitions + + "Contribution" : any source code, documentation, including any modifications or additions to an existing work that is intentionally submitted by You to the Haxe Foundation for inclusion in, or documentation of, any of the products managed and maintained by the Haxe Foundation. + + "Submitted" means any form or electronic, verbal or written communication, including but not limited to communication on electronic mailing lists, source code control systems and issue tracking system that are managed by, or on behalf of, the Haxe Foundation for the purpose of improving Haxe. + +2) Grant of Copyright License. Subject to the terms and conditions of this Grant, You hereby grant to the Haxe Foundation and to recipients of software distributed by the Haxe Foundation a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare derivative works of, publicly display, publicly perform, sublicense, and distribute Your Contributions and such derivative works. + +3) You represent that you are legally entitled to grant the above license. If your employer(s) has rights to intellectual property that you create that includes your Contributions, you represent that you have received permission to make Contributions on behalf of that employer, that your employer has waived such rights for your Contributions to the Haxe Foundation, or that your employer has executed a separate Corporate Contributor License Grant with the Haxe Foundation. + +4) You represent that each of Your Contributions is Your original creation (see section 7 for submissions on behalf of others). You represent that Your Contribution submissions include complete details of any third-party license or other restriction (including, but not limited to, related patents and trademarks) of which you are personally aware and which are associated with any part of Your Contributions. + +5) You are not expected to provide support for Your Contributions, except to the extent You desire to provide support. You may provide support for free, for a fee, or not at all. Unless required by applicable law or agreed to in writing, You provide Your Contributions on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON- INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. + +Full Name : +Email : +Mailing Address : +Country : + + +Signature: \ No newline at end of file diff --git a/doc/EnvVarUpdate.nsh b/doc/EnvVarUpdate.nsh new file mode 100644 index 0000000000000000000000000000000000000000..839d6a0206281b02147dd84061e4b2ccd9e7e24d --- /dev/null +++ b/doc/EnvVarUpdate.nsh @@ -0,0 +1,327 @@ +/** + * EnvVarUpdate.nsh + * : Environmental Variables: append, prepend, and remove entries + * + * WARNING: If you use StrFunc.nsh header then include it before this file + * with all required definitions. This is to avoid conflicts + * + * Usage: + * ${EnvVarUpdate} "ResultVar" "EnvVarName" "Action" "RegLoc" "PathString" + * + * Credits: + * Version 1.0 + * * Cal Turney (turnec2) + * * Amir Szekely (KiCHiK) and e-circ for developing the forerunners of this + * function: AddToPath, un.RemoveFromPath, AddToEnvVar, un.RemoveFromEnvVar, + * WriteEnvStr, and un.DeleteEnvStr + * * Diego Pedroso (deguix) for StrTok + * * Kevin English (kenglish_hi) for StrContains + * * Hendri Adriaens (Smile2Me), Diego Pedroso (deguix), and Dan Fuhry + * (dandaman32) for StrReplace + * + * Version 1.1 (compatibility with StrFunc.nsh) + * * techtonik + * + * http://nsis.sourceforge.net/Environmental_Variables:_append%2C_prepend%2C_and_remove_entries + * + */ + + +!ifndef ENVVARUPDATE_FUNCTION +!define ENVVARUPDATE_FUNCTION +!verbose push +!verbose 3 +!include "LogicLib.nsh" +!include "WinMessages.NSH" +!include "StrFunc.nsh" + +; ---- Fix for conflict if StrFunc.nsh is already includes in main file ----------------------- +!macro _IncludeStrFunction StrFuncName + !ifndef ${StrFuncName}_INCLUDED + ${${StrFuncName}} + !endif + !ifndef Un${StrFuncName}_INCLUDED + ${Un${StrFuncName}} + !endif + !define un.${StrFuncName} "${Un${StrFuncName}}" +!macroend + +!insertmacro _IncludeStrFunction StrTok +!insertmacro _IncludeStrFunction StrStr +!insertmacro _IncludeStrFunction StrRep + +; ---------------------------------- Macro Definitions ---------------------------------------- +!macro _EnvVarUpdateConstructor ResultVar EnvVarName Action Regloc PathString + Push "${EnvVarName}" + Push "${Action}" + Push "${RegLoc}" + Push "${PathString}" + Call EnvVarUpdate + Pop "${ResultVar}" +!macroend +!define EnvVarUpdate '!insertmacro "_EnvVarUpdateConstructor"' + +!macro _unEnvVarUpdateConstructor ResultVar EnvVarName Action Regloc PathString + Push "${EnvVarName}" + Push "${Action}" + Push "${RegLoc}" + Push "${PathString}" + Call un.EnvVarUpdate + Pop "${ResultVar}" +!macroend +!define un.EnvVarUpdate '!insertmacro "_unEnvVarUpdateConstructor"' +; ---------------------------------- Macro Definitions end------------------------------------- + +;----------------------------------- EnvVarUpdate start---------------------------------------- +!define hklm_all_users 'HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"' +!define hkcu_current_user 'HKCU "Environment"' + +!macro EnvVarUpdate UN + +Function ${UN}EnvVarUpdate + + Push $0 + Exch 4 + Exch $1 + Exch 3 + Exch $2 + Exch 2 + Exch $3 + Exch + Exch $4 + Push $5 + Push $6 + Push $7 + Push $8 + Push $9 + Push $R0 + + /* After this point: + ------------------------- + $0 = ResultVar (returned) + $1 = EnvVarName (input) + $2 = Action (input) + $3 = RegLoc (input) + $4 = PathString (input) + $5 = Orig EnvVar (read from registry) + $6 = Len of $0 (temp) + $7 = tempstr1 (temp) + $8 = Entry counter (temp) + $9 = tempstr2 (temp) + $R0 = tempChar (temp) */ + + ; Step 1: Read contents of EnvVarName from RegLoc + ; + ; Check for empty EnvVarName + ${If} $1 == "" + SetErrors + DetailPrint "ERROR: EnvVarName is blank" + Goto EnvVarUpdate_Restore_Vars + ${EndIf} + + ; Check for valid Action + ${If} $2 != "A" + ${AndIf} $2 != "P" + ${AndIf} $2 != "R" + SetErrors + DetailPrint "ERROR: Invalid Action - must be A, P, or R" + Goto EnvVarUpdate_Restore_Vars + ${EndIf} + + ${If} $3 == HKLM + ReadRegStr $5 ${hklm_all_users} $1 ; Get EnvVarName from all users into $5 + ${ElseIf} $3 == HKCU + ReadRegStr $5 ${hkcu_current_user} $1 ; Read EnvVarName from current user into $5 + ${Else} + SetErrors + DetailPrint 'ERROR: Action is [$3] but must be "HKLM" or HKCU"' + Goto EnvVarUpdate_Restore_Vars + ${EndIf} + + ; Check for empty PathString + ${If} $4 == "" + SetErrors + DetailPrint "ERROR: PathString is blank" + Goto EnvVarUpdate_Restore_Vars + ${EndIf} + + ; Make sure we've got some work to do + ${If} $5 == "" + ${AndIf} $2 == "R" + SetErrors + DetailPrint "$1 is empty - Nothing to remove" + Goto EnvVarUpdate_Restore_Vars + ${EndIf} + + ; Step 2: Scrub EnvVar + ; + StrCpy $0 $5 ; Copy the contents to $0 + ; Remove spaces around semicolons (NOTE: spaces before the 1st entry or + ; after the last one are not removed here but instead in Step 3) + ${If} $0 != "" ; If EnvVar is not empty ... + ${Do} + ${${UN}StrStr} $7 $0 " ;" + ${If} $7 == "" + ${ExitDo} + ${EndIf} + ${${UN}StrRep} $0 $0 " ;" ";" ; Remove ';' + ${Loop} + ${Do} + ${${UN}StrStr} $7 $0 "; " + ${If} $7 == "" + ${ExitDo} + ${EndIf} + ${${UN}StrRep} $0 $0 "; " ";" ; Remove ';' + ${Loop} + ${Do} + ${${UN}StrStr} $7 $0 ";;" + ${If} $7 == "" + ${ExitDo} + ${EndIf} + ${${UN}StrRep} $0 $0 ";;" ";" + ${Loop} + + ; Remove a leading or trailing semicolon from EnvVar + StrCpy $7 $0 1 0 + ${If} $7 == ";" + StrCpy $0 $0 "" 1 ; Change ';' to '' + ${EndIf} + StrLen $6 $0 + IntOp $6 $6 - 1 + StrCpy $7 $0 1 $6 + ${If} $7 == ";" + StrCpy $0 $0 $6 ; Change ';' to '' + ${EndIf} + ; DetailPrint "Scrubbed $1: [$0]" ; Uncomment to debug + ${EndIf} + + /* Step 3. Remove all instances of the target path/string (even if "A" or "P") + $6 = bool flag (1 = found and removed PathString) + $7 = a string (e.g. path) delimited by semicolon(s) + $8 = entry counter starting at 0 + $9 = copy of $0 + $R0 = tempChar */ + + ${If} $5 != "" ; If EnvVar is not empty ... + StrCpy $9 $0 + StrCpy $0 "" + StrCpy $8 0 + StrCpy $6 0 + + ${Do} + ${${UN}StrTok} $7 $9 ";" $8 "0" ; $7 = next entry, $8 = entry counter + + ${If} $7 == "" ; If we've run out of entries, + ${ExitDo} ; were done + ${EndIf} ; + + ; Remove leading and trailing spaces from this entry (critical step for Action=Remove) + ${Do} + StrCpy $R0 $7 1 + ${If} $R0 != " " + ${ExitDo} + ${EndIf} + StrCpy $7 $7 "" 1 ; Remove leading space + ${Loop} + ${Do} + StrCpy $R0 $7 1 -1 + ${If} $R0 != " " + ${ExitDo} + ${EndIf} + StrCpy $7 $7 -1 ; Remove trailing space + ${Loop} + ${If} $7 == $4 ; If string matches, remove it by not appending it + StrCpy $6 1 ; Set 'found' flag + ${ElseIf} $7 != $4 ; If string does NOT match + ${AndIf} $0 == "" ; and the 1st string being added to $0, + StrCpy $0 $7 ; copy it to $0 without a prepended semicolon + ${ElseIf} $7 != $4 ; If string does NOT match + ${AndIf} $0 != "" ; and this is NOT the 1st string to be added to $0, + StrCpy $0 $0;$7 ; append path to $0 with a prepended semicolon + ${EndIf} ; + + IntOp $8 $8 + 1 ; Bump counter + ${Loop} ; Check for duplicates until we run out of paths + ${EndIf} + + ; Step 4: Perform the requested Action + ; + ${If} $2 != "R" ; If Append or Prepend + ${If} $6 == 1 ; And if we found the target + DetailPrint "Target is already present in $1. It will be removed and" + ${EndIf} + ${If} $0 == "" ; If EnvVar is (now) empty + StrCpy $0 $4 ; just copy PathString to EnvVar + ${If} $6 == 0 ; If found flag is either 0 + ${OrIf} $6 == "" ; or blank (if EnvVarName is empty) + DetailPrint "$1 was empty and has been updated with the target" + ${EndIf} + ${ElseIf} $2 == "A" ; If Append (and EnvVar is not empty), + StrCpy $0 $0;$4 ; append PathString + ${If} $6 == 1 + DetailPrint "appended to $1" + ${Else} + DetailPrint "Target was appended to $1" + ${EndIf} + ${Else} ; If Prepend (and EnvVar is not empty), + StrCpy $0 $4;$0 ; prepend PathString + ${If} $6 == 1 + DetailPrint "prepended to $1" + ${Else} + DetailPrint "Target was prepended to $1" + ${EndIf} + ${EndIf} + ${Else} ; If Action = Remove + ${If} $6 == 1 ; and we found the target + DetailPrint "Target was found and removed from $1" + ${Else} + DetailPrint "Target was NOT found in $1 (nothing to remove)" + ${EndIf} + ${If} $0 == "" + DetailPrint "$1 is now empty" + ${EndIf} + ${EndIf} + + ; Step 5: Update the registry at RegLoc with the updated EnvVar and announce the change + ; + ClearErrors + ${If} $3 == HKLM + WriteRegExpandStr ${hklm_all_users} $1 $0 ; Write it in all users section + ${ElseIf} $3 == HKCU + WriteRegExpandStr ${hkcu_current_user} $1 $0 ; Write it to current user section + ${EndIf} + + IfErrors 0 +4 + MessageBox MB_OK|MB_ICONEXCLAMATION "Could not write updated $1 to $3" + DetailPrint "Could not write updated $1 to $3" + Goto EnvVarUpdate_Restore_Vars + + ; "Export" our change + SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000 + + EnvVarUpdate_Restore_Vars: + ; + ; Restore the user's variables and return ResultVar + Pop $R0 + Pop $9 + Pop $8 + Pop $7 + Pop $6 + Pop $5 + Pop $4 + Pop $3 + Pop $2 + Pop $1 + Push $0 ; Push my $0 (ResultVar) + Exch + Pop $0 ; Restore his $0 + +FunctionEnd + +!macroend ; EnvVarUpdate UN +!insertmacro EnvVarUpdate "" +!insertmacro EnvVarUpdate "un." +;----------------------------------- EnvVarUpdate end---------------------------------------- + +!verbose pop +!endif diff --git a/haxe/doc/ImportAll.hx b/doc/ImportAll.hx similarity index 70% rename from haxe/doc/ImportAll.hx rename to doc/ImportAll.hx index ed7949a0c365eea49e3e489502239865967bd19c..3b279f67c7cddc125743adda7d55d12dddc9500a 100644 --- a/haxe/doc/ImportAll.hx +++ b/doc/ImportAll.hx @@ -27,7 +27,10 @@ import haxe.macro.Context; class ImportAll { public static function run( ?pack ) { - if( pack == null ) pack = ""; + if( pack == null ) { + pack = ""; + haxe.macro.Compiler.define("doc_gen"); + } switch( pack ) { case "php": if( !Context.defined("php") ) return; @@ -37,41 +40,56 @@ class ImportAll { if( !Context.defined("js") ) return; case "cpp": if( !Context.defined("cpp") ) return; - case "flash": + case "flash8": if( !Context.defined("flash") || Context.defined("flash9") ) return; - case "flash9": + case "flash": if( !Context.defined("flash9") ) return; case "mt","mtwin": return; + case "sys": + if( !Context.defined("neko") && !Context.defined("php") && !Context.defined("cpp") ) return; + case "java": + if( !Context.defined("java") ) return; + case "cs": + if( !Context.defined("cs") ) return; case "tools": return; + case "build-tool": + return; } for( p in Context.getClassPath() ) { + if( p == "/" ) + continue; + // skip if we have a classpath to haxe + if( pack.length == 0 && sys.FileSystem.exists(p+"std") ) + continue; var p = p + pack.split(".").join("/"); if( StringTools.endsWith(p,"/") ) p = p.substr(0,-1); - if( !neko.FileSystem.exists(p) || !neko.FileSystem.isDirectory(p) ) + if( !sys.FileSystem.exists(p) || !sys.FileSystem.isDirectory(p) ) continue; - for( file in neko.FileSystem.readDirectory(p) ) { + for( file in sys.FileSystem.readDirectory(p) ) { if( file == ".svn" || file == "_std" ) continue; var full = (pack == "") ? file : pack + "." + file; if( StringTools.endsWith(file, ".hx") ) { var cl = full.substr(0, full.length - 3); - if( StringTools.startsWith(cl,"flash9.") ) + if( StringTools.startsWith(cl,"flash8.") ) cl = "flash."+cl.substr(7); switch( cl ) { - case "haxe.TimerQueue": if( Context.defined("neko") || Context.defined("php") ) continue; - case "haxe.ImportAll": continue; - case "haxe.macro.DefaultJSGenerator","haxe.macro.Context", "haxe.macro.Compiler": if( !Context.defined("neko") ) continue; + case "ImportAll", "neko.db.MacroManager": continue; + case "haxe.TimerQueue": if( Context.defined("neko") || Context.defined("php") || Context.defined("cpp") ) continue; + case "Sys": if( !(Context.defined("neko") || Context.defined("php") || Context.defined("cpp")) ) continue; + case "haxe.web.Request": if( !(Context.defined("neko") || Context.defined("php") || Context.defined("js")) ) continue; + case "haxe.macro.ExampleJSGenerator","haxe.macro.Context", "haxe.macro.Compiler": if( !Context.defined("neko") ) continue; case "haxe.remoting.SocketWrapper": if( !Context.defined("flash") ) continue; case "haxe.remoting.SyncSocketConnection": if( !(Context.defined("neko") || Context.defined("php") || Context.defined("cpp")) ) continue; } Context.getModule(cl); - } else if( neko.FileSystem.isDirectory(p + "/" + file) ) + } else if( sys.FileSystem.isDirectory(p + "/" + file) ) run(full); } } } -} \ No newline at end of file +} diff --git a/haxe/doc/LICENSE.txt b/doc/LICENSE.txt similarity index 96% rename from haxe/doc/LICENSE.txt rename to doc/LICENSE.txt index 0a4a5b55e116288e03ec1b89798301838d494e44..0711f5194f547369ec3ffd6fec17fefba07cc7b9 100644 --- a/haxe/doc/LICENSE.txt +++ b/doc/LICENSE.txt @@ -1,35 +1,32 @@ -haXe Licenses +Haxe Licenses ------------- -For details about haXe Licenses, please read http://haxe.org/license +For details about Haxe Licenses, please read http://haxe.org/doc/license - -The BSD 2-Clause Licence : +The MIT Licence : -------------------------- -Copyright (c) 2005, the haXe Project Contributors -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - - Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY -EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR ANY -DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -The haXe compiler GPL License : +Copyright (C)2005-2012 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. + +The Haxe compiler GPL License : ------------------------------- GNU GENERAL PUBLIC LICENSE @@ -466,7 +463,7 @@ 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 diff --git a/haxe/doc/all.hxml b/doc/all.hxml similarity index 58% rename from haxe/doc/all.hxml rename to doc/all.hxml index 28d0d6f254237d958ae6bdb1ff41d45f1d7177a3..8ec5dc88e81ad53d30e0d62b7cd3b4b26283ac27 100644 --- a/haxe/doc/all.hxml +++ b/doc/all.hxml @@ -1,48 +1,52 @@ --neko all.n --no-output --xml neko.xml --macro ImportAll.run() +-D doc-gen +--each + +-neko all.n +-xml neko.xml --next -swf all.swf -swf-version 8 ---no-output --xml flash.xml +-xml flash8.xml -D flash_lite ---macro ImportAll.run() --next -js all.js ---no-output -xml js.xml ---macro ImportAll.run() --next -swf all9.swf ---no-output -xml flash9.xml ---macro ImportAll.run() +-swf-version 11.4 --next -php all_php ---no-output -xml php.xml ---macro ImportAll.run() --next -cpp all_cpp ---no-output -xml cpp.xml -D xmldoc -D HXCPP_MULTI_THREADED ---macro ImportAll.run() + +--next +-java all_java +-xml java.xml +-D xmldoc + +--next +-cs all_cs +-D unsafe +-xml cs.xml +-D xmldoc --next -xml cross.xml ---macro ImportAll.run() diff --git a/doc/all.hxproj b/doc/all.hxproj new file mode 100644 index 0000000000000000000000000000000000000000..568981f18141d5aaa128fefd09f343843ec0f34e --- /dev/null +++ b/doc/all.hxproj @@ -0,0 +1,55 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + haxe all.hxml + + + + + + + + \ No newline at end of file diff --git a/doc/extract.hxml b/doc/extract.hxml new file mode 100644 index 0000000000000000000000000000000000000000..ce658c4ca861fff0f8b14a8ae8d2f7ee55d54e58 --- /dev/null +++ b/doc/extract.hxml @@ -0,0 +1,6 @@ +-debug +-swf-lib library.swf +-swf test.swf +-swf-version 11.7 +--macro patchTypes("../doc/extract.patch") +--gen-hx-classes \ No newline at end of file diff --git a/haxe/doc/extract.patch b/doc/extract.patch similarity index 71% rename from haxe/doc/extract.patch rename to doc/extract.patch index 0a72116341208e1eb509ddebd3e0427b45df7217..d94524f15c4afd722c2cc65b212e650f1f2cb83f 100644 --- a/haxe/doc/extract.patch +++ b/doc/extract.patch @@ -1,5 +1,7 @@ // types patches configuration for playerglobal.swc +flash.display.DisplayObject.filters : Array; + -flash.accessibility.Accessibility.new @:require(flash10_1) flash.accessibility.ISearchableText @:require(flash10_1) flash.accessibility.ISimpleTextSelection @@ -17,6 +19,12 @@ flash.desktop.Clipboard.formats : Array; flash.desktop.Clipboard.$format : ClipboardFormats; flash.desktop.Clipboard.$transferMode : ClipboardTransferMode; +enum flash.desktop.ClipboardFormats; +enum flash.desktop.ClipboardTransferMode; + +enum flash.display.PixelSnapping; +enum flash.display.BlendMode; + @:require(flash10) flash.desktop.Clipboard @:require(flash10) flash.desktop.ClipboardFormats @:require(flash10) flash.desktop.ClipboardTransferMode @@ -61,6 +69,22 @@ flash.display.DisplayObjectContainer.getObjectsUnderPoint : Array @:require(flash10_1) flash.display.Stage.wmodeGPU; +enum flash.display.GradientType; +enum flash.display.CapsStyle; +enum flash.display.JointStyle; +enum flash.display.GraphicsPathWinding; +enum flash.display.TriangleCulling; +enum flash.display.InterpolationMethod; +enum flash.display.LineScaleMode; +enum flash.display.ShaderParameterType; +enum flash.display.ShaderPrecision; +enum flash.display.SpreadMethod; +enum flash.display.StageAlign; +enum flash.display.StageDisplayState; +enum flash.display.StageQuality; +enum flash.display.StageScaleMode; +-flash.display.SWFVersion.new + flash.display.Graphics.$type : GradientType; flash.display.Graphics.$colors : Array; flash.display.Graphics.$spreadMethod : SpreadMethod; @@ -99,9 +123,9 @@ flash.display.GraphicsPath.$winding : GraphicsPathWinding; flash.display.GraphicsStroke.scaleMode : LineScaleMode; flash.display.GraphicsStroke.caps : CapsStyle; flash.display.GraphicsStroke.joints : JointStyle; -flash.display.GraphicsStroke.$_scaleMode : LineScaleMode; -flash.display.GraphicsStroke.$_caps : CapsStyle; -flash.display.GraphicsStroke.$_joints : JointStyle; +flash.display.GraphicsStroke.$scaleMode : LineScaleMode; +flash.display.GraphicsStroke.$caps : CapsStyle; +flash.display.GraphicsStroke.$joints : JointStyle; flash.display.GraphicsTrianglePath.culling : TriangleCulling; flash.display.GraphicsTrianglePath.$culling : TriangleCulling; @@ -109,10 +133,13 @@ flash.display.GraphicsTrianglePath.$culling : TriangleCulling; @:require(flash10) flash.display.Loader.unloadAndStop +enum flash.display.ActionScriptVersion; +enum flash.display.ColorCorrection; +enum flash.display.ColorCorrectionSupport; + -flash.display.LoaderInfo.new flash.display.LoaderInfo.parameters : Dynamic; flash.display.LoaderInfo.actionScriptVersion : ActionScriptVersion; -flash.display.LoaderInfo.swfVersion : SWFVersion; -flash.display.MorphShape.new @@ -173,7 +200,11 @@ flash.display.Stage.displayState : StageDisplayState; flash.events.IEventDispatcher.$listener : Dynamic -> Void; flash.events.EventDispatcher.$listener : Dynamic -> Void; +enum flash.events.EventPhase; +enum flash.events.GesturePhase; + flash.events.Event.eventPhase : EventPhase; + flash.events.KeyboardEvent.keyLocation : flash.ui.KeyLocation; flash.events.KeyboardEvent.$keyLocationValue : flash.ui.KeyLocation; flash.events.KeyboardEvent.$keyLocation : flash.ui.KeyLocation; @@ -191,6 +222,9 @@ flash.events.KeyboardEvent.$keyLocation : flash.ui.KeyLocation; -flash.external.ExternalInterface.new +enum flash.filters.BitmapFilterType; +enum flash.filters.DisplacementMapFilterMode; + flash.filters.BevelFilter.type : BitmapFilterType; flash.filters.BevelFilter.$type : BitmapFilterType; @@ -200,6 +234,8 @@ flash.filters.DisplacementMapFilter.$mode : DisplacementMapFilterMode; flash.filters.GradientGlowFilter.type : BitmapFilterType; flash.filters.GradientGlowFilter.$type : BitmapFilterType; +enum flash.geom.Orientation3D; + flash.geom.Matrix3D.$orientationStyle : Orientation3D; @:require(flash10) flash.geom.Matrix3D; @@ -215,6 +251,8 @@ flash.geom.Matrix3D.$orientationStyle : Orientation3D; @:require(flash10_1) static flash.media.Camera.isSupported; @:require(flash10_1) static flash.media.Camera._scanHardware; +enum flash.media.SoundCodec; + flash.media.Microphone.codec : SoundCodec; @:require(flash10) flash.media.Microphone.codec; @@ -242,20 +280,10 @@ flash.net.FileReference.$typeFilter : Array; flash.net.FileReferenceList.fileList : Array; flash.net.FileReferenceList.$typeFilter : Array; -flash.net.NetStreamPlayOptions.transition : NetStreamPlayTransitions; - @:require(flash10_1) flash.net.GroupSpecifier; @:require(flash10_1) flash.net.NetGroup; @:require(flash10_1) flash.net.NetGroupInfo; @:require(flash10_1) flash.net.NetStreamMulticastInfo; -flash.net.NetGroup.receiveMode : NetGroupReceiveMode; -flash.net.NetGroup.replicationStrategy : NetGroupReplicationStrategy; -flash.net.NetGroup.$sendMode : NetGroupSendMode; -flash.net.NetGroup.sendToAllNeighbors : NetGroupSendResult; -flash.net.NetGroup.sendToNearest : NetGroupSendResult; -flash.net.NetGroup.sendToNeighbor : NetGroupSendResult; - -flash.net.NetStream.$netStreamAppendBytesAction : NetStreamAppendBytesAction; @:require(flash10) flash.net.NetConnection.farID; @:require(flash10) flash.net.NetConnection.farNonce; @@ -312,12 +340,15 @@ flash.net.NetStream.$netStreamAppendBytesAction : NetStreamAppendBytesAction; -flash.net.ObjectEncoding.new -flash.net.URLRequestMethod.new +enum flash.net.URLLoaderDataFormat; + flash.net.Socket.endian : flash.utils.Endian; flash.net.URLLoader.dataFormat : URLLoaderDataFormat; flash.net.URLRequest.requestHeaders : Array; -flash.net.SharedObject.flush : SharedObjectFlushStatus; flash.net.URLStream.endian : flash.utils.Endian; +enum flash.printing.PrintJobOrientation; + flash.printing.PrintJob.orientation : PrintJobOrientation; @:require(flash10_1) static flash.printing.PrintJob.isSupported; @@ -332,6 +363,9 @@ flash.sampler.Sample.stack : Array; -flash.system.Capabilities.new -flash.system.IME.new -flash.system.FSCommand.new + +enum flash.system.IMEConversionMode; + static flash.system.IME.conversionMode : IMEConversionMode @:require(flash10) flash.system.ApplicationDomain.domainMemory; @@ -346,6 +380,8 @@ static flash.system.IME.conversionMode : IMEConversionMode @:require(flash10_1) static flash.system.Capabilities.touchscreenType; static flash.system.Capabilities.touchscreenType : TouchscreenType; +enum flash.system.TouchscreenType; + @:require(flash10_1) static flash.system.IME.isSupported; @:require(flash10_1) static flash.system.IME.compositionAbandoned; @@ -370,12 +406,25 @@ static flash.system.Capabilities.touchscreenType : TouchscreenType; @:require(flash10_1) static flash.system.System.disposeXML; @:require(flash10_1) static flash.system.System.nativeConstructionOnly; +enum flash.system.SecurityPanel; + -flash.system.Security.new flash.system.Security.$panel : SecurityPanel -flash.system.SecurityDomain.new -flash.system.System.new flash.system.SystemUpdater.$typer : SystemAdapterType; +enum flash.text.AntiAliasType; +enum flash.text.GridFitType; +enum flash.text.FontStyle; +enum flash.text.FontType; +enum flash.text.TextDisplayMode; +enum flash.text.TextFieldType; +enum flash.text.TextFieldAutoSize; +enum flash.text.TextFormatAlign; +enum flash.text.TextFormatDisplay; +enum flash.text.TextColorType; + flash.text.Font.fontStyle : FontStyle; flash.text.Font.fontType : FontType; static flash.text.Font.enumerateFonts : Array; @@ -434,6 +483,26 @@ flash.text.engine.EastAsianJustifier.justificationStyle : JustificationStyle; flash.text.engine.EastAsianJustifier.$justificationStyle : JustificationStyle; flash.text.engine.EastAsianJustifier.$lineJustification : LineJustification; +enum flash.text.engine.BreakOpportunity; +enum flash.text.engine.CFFHinting; +enum flash.text.engine.DigitCase; +enum flash.text.engine.DigitWidth; +enum flash.text.engine.FontLookup; +enum flash.text.engine.FontPosture; +enum flash.text.engine.FontWeight; +enum flash.text.engine.JustificationStyle; +enum flash.text.engine.Kerning; +enum flash.text.engine.LigatureLevel; +enum flash.text.engine.LineJustification; +enum flash.text.engine.RenderingMode; +enum flash.text.engine.TabAlignment; +enum flash.text.engine.TextBaseline; +enum flash.text.engine.TextLineCreationResult; +enum flash.text.engine.TextLineValidity; +enum flash.text.engine.TextRotation; +enum flash.text.engine.TypographicCase; + + flash.text.engine.ElementFormat.alignmentBaseline : TextBaseline; flash.text.engine.ElementFormat.breakOpportunity : BreakOpportunity; flash.text.engine.ElementFormat.digitCase : DigitCase; @@ -493,6 +562,8 @@ flash.text.engine.TextLine.baseline : TextBaseline; -flash.ui.Keyboard.new -flash.ui.Mouse.new +enum flash.ui.MultitouchInputMode; + -flash.ui.Multitouch.new flash.ui.Multitouch.inputMode : MultitouchInputMode; @@ -502,9 +573,8 @@ flash.ui.Multitouch.inputMode : MultitouchInputMode; @:require(flash10_1) static flash.ui.ContextMenu.isSupported; - -static flash.ui.Mouse.cursor : MouseCursor; @:require(flash10) static flash.ui.Mouse.cursor; +static flash.ui.Mouse.cursor : Dynamic; @:require(flash10_1) static flash.ui.Keyboard.A; @:require(flash10_1) static flash.ui.Keyboard.B; @@ -560,6 +630,9 @@ static flash.ui.Mouse.cursor : MouseCursor; @:require(flash10_1) static flash.ui.Keyboard.hasVirtualKeyboard; @:require(flash10_1) static flash.ui.Keyboard.physicalKeyboardType; +enum flash.ui.KeyboardType; +enum flash.ui.KeyLocation; + static flash.ui.Keyboard.physicalKeyboardType : KeyboardType; @:require(flash10_1) flash.ui.Multitouch; @@ -714,6 +787,11 @@ static flash.ui.Multitouch.inputMode : MultitouchInputMode; @:require(flash10_1) static flash.ui.Mouse.supportsCursor; +enum flash.utils.Endian; + +@:native("RegExp") flash.utils.RegExp; +-static flash.utils.RegExp.length; + flash.utils.ObjectInput.endian : Endian; flash.utils.ObjectOutput.endian : Endian; flash.utils.ByteArray.endian : Endian; @@ -734,6 +812,8 @@ flash.utils.IDataOutput.endian : Endian; -flash.utils.QName.valueOf -static flash.utils.QName.length +enum flash.xml.XMLNodeType; + flash.xml.XMLNode.nodeType : XMLNodeType; flash.xml.XMLNode.$type : XMLNodeType; @@ -744,6 +824,8 @@ flash.xml.XMLList.parent : XML; flash.xml.XMLTag.type : XMLNodeType; +enum flash.system.SystemUpdaterType; + @:require(flash10_1) flash.system.SystemUpdater; flash.system.SystemUpdater.$type : SystemUpdaterType; @@ -758,6 +840,13 @@ flash.system.SystemUpdater.$type : SystemUpdaterType; @:require(flash10_1) flash.globalization.NumberFormatter; @:require(flash10_1) flash.globalization.NumberParseResult; +enum flash.globalization.CollatorMode; +enum flash.globalization.DateTimeNameContext; +enum flash.globalization.DateTimeNameStyle; +enum flash.globalization.DateTimeStyle; +enum flash.globalization.LastOperationStatus; +enum flash.globalization.NationalDigitsType; + flash.globalization.Collator.lastOperationStatus : LastOperationStatus; flash.globalization.Collator.$initialMode : CollatorMode; flash.globalization.CurrencyFormatter.lastOperationStatus : LastOperationStatus; @@ -777,7 +866,7 @@ flash.globalization.StringTools.lastOperationStatus : LastOperationStatus; // FP 10.2 -@:require(flash10_2) flash.display.MouseCursorData; +@:require(flash10_2) flash.ui.MouseCursorData; @:require(flash10_2) flash.events.StageVideoEvent; @:require(flash10_2) flash.events.VideoEvent; @:require(flash10_2) flash.media.MicrophoneEnhancedMode; @@ -827,4 +916,309 @@ flash.globalization.StringTools.lastOperationStatus : LastOperationStatus; @:require(flash10_2) static flash.ui.Mouse.registerCursor; +enum flash.media.MicrophoneEnhancedMode; + flash.media.MicrophoneEnhancedOptions.mode : MicrophoneEnhancedMode; + +enum flash.display.FocusDirection; + + +// FLASH 11 FEATURES + +-flash.automation.Configuration.new + +@:require(flash11) flash.display.DisplayObjectContainer.removeChildren; +@:require(flash11) flash.display.Graphics.cubicCurveTo; +@:require(flash11) flash.display.GraphicsPath.cubicCurveTo; + +@:require(flash11) flash.display.InteractiveObject.needsSoftKeyboard; +@:require(flash11) flash.display.InteractiveObject.softKeyboardInputAreaOfInterest; +@:require(flash11) flash.display.InteractiveObject.requestSoftKeyboard; + +@:require(flash11) flash.display.MovieClip.isPlaying; + +@:require(flash11) flash.display.Stage.allowsFullScreen; +@:require(flash11) flash.display.Stage.displayContextInfo; +@:require(flash11) flash.display.Stage.softKeyboardRect; +@:require(flash11) flash.display.Stage.stage3Ds; +@:require(flash11) flash.display.Stage3D; + +-flash.display.Stage.constructor; +-flash.display.Stage.hasOwnProperty; +-flash.display.Stage.isPrototypeOf; +-flash.display.Stage.propertyIsEnumerable; +-flash.display.Stage.setPropertyIsEnumerable; +-flash.display.Stage.toLocaleString; +-flash.display.Stage.valueOf; + +enum flash.display3D.Context3DBlendFactor; +enum flash.display3D.; + +@:require(flash11) static flash.events.Event.CONTEXT3D_CREATE; +@:require(flash11) static flash.events.Event.TEXT_INTERACTION_MODE_CHANGE; + +@:require(flash11) static flash.events.StageVideoEvent.RENDER_STATUS_AVAILABLE; +@:require(flash11) static flash.events.StageVideoEvent.STAGE_VIDEO_STATE; + +@:require(flash11) flash.geom.Matrix3D.copyColumnFrom; +@:require(flash11) flash.geom.Matrix3D.copyColumnTo; +@:require(flash11) flash.geom.Matrix3D.copyFrom; +@:require(flash11) flash.geom.Matrix3D.copyRawDataFrom; +@:require(flash11) flash.geom.Matrix3D.copyRawDataTo; +@:require(flash11) flash.geom.Matrix3D.copyRowFrom; +@:require(flash11) flash.geom.Matrix3D.copyRowTo; +@:require(flash11) flash.geom.Matrix3D.copyToMatrix3D; + +@:require(flash11) flash.geom.Matrix.copyColumnFrom; +@:require(flash11) flash.geom.Matrix.copyColumnTo; +@:require(flash11) flash.geom.Matrix.copyFrom; +@:require(flash11) flash.geom.Matrix.copyRowFrom; +@:require(flash11) flash.geom.Matrix.copyRowTo; +@:require(flash11) flash.geom.Matrix.setTo; + +@:require(flash11) flash.geom.Point.copyFrom; +@:require(flash11) flash.geom.Point.setTo; + +@:require(flash11) flash.geom.Rectangle.copyFrom; +@:require(flash11) flash.geom.Rectangle.setTo; + +@:require(flash11) flash.geom.Vector3D.copyFrom; +@:require(flash11) flash.geom.Vector3D.setTo; + + + +@:require(flash11) flash.media.Sound.loadCompressedDataFromByteArray; +@:require(flash11) flash.media.Sound.loadPCMFromByteArray; + +@:require(flash11) flash.net.Socket.bytesPending; + +-flash.display3D.Context3DClearMask.new; +enum flash.display3D.Context3DCompareMode; +enum flash.display3D.Context3DProgramType; +enum flash.display3D.Context3DRenderMode; +enum flash.display3D.Context3DStencilAction; +enum flash.display3D.Context3DTextureFormat; +enum flash.display3D.Context3DTriangleFace; +enum flash.display3D.Context3DVertexBufferFormat; + +-flash.display.Stage3D.new; +-flash.display3D.Context3D.new; +-flash.display3D.IndexBuffer3D.new; +-flash.display3D.Program3D.new; +-flash.display3D.VertexBuffer3D.new; +-flash.display3D.textures.CubeTexture.new; +-flash.display3D.textures.TextureBase.new; +-flash.display3D.textures.Texture.new; + +flash.display3D.Context3D.$sourceFactor : Context3DBlendFactor; +flash.display3D.Context3D.$destinationFactor : Context3DBlendFactor; +flash.display3D.Context3D.$format : Context3DTextureFormat; +flash.display3D.Context3D.$triangleFaceToCull : Context3DTriangleFace; +flash.display3D.Context3D.$triangleFace : Context3DTriangleFace; +flash.display3D.Context3D.$passCompareMode : Context3DCompareMode; +flash.display3D.Context3D.$compareMode : Context3DCompareMode; +flash.display3D.Context3D.$programType : Context3DProgramType; +flash.display3D.Context3D.$actionOnBothPass : Context3DStencilAction; +flash.display3D.Context3D.$actionOnDepthFail : Context3DStencilAction; +flash.display3D.Context3D.$actionOnDepthPassStencilFail : Context3DStencilAction; +flash.display3D.Context3D.$setVertexBufferAt__format : Context3DVertexBufferFormat; + +@:require(flash11) flash.net.NetStream.useHardwareDecoder; +@:require(flash11) flash.net.NetStream.videoStreamSettings; + +@:require(flash11) flash.net.SecureSocket; +@:require(flash11) flash.net.NetMonitor; + +@:require(flash11) static flash.system.Capabilities.hasMultiChannelAudio; + +@:require(flash11) flash.system.LoaderContext.imageDecodingPolicy; +@:require(flash11) flash.system.LoaderContext.parameters; +@:require(flash11) flash.system.LoaderContext.requestedContentParent; + +enum flash.system.ImageDecodingPolicy; + +flash.system.LoaderContext.imageDecodingPolicy : ImageDecodingPolicy; + +@:require(flash11) static flash.system.Security.pageDomain; + +@:require(flash11) static flash.system.System.processCPUUsage; +@:require(flash11) static flash.system.System.pauseForGCIfCollectionImminent; + +@:require(flash11) static flash.ui.Mouse.supportsNativeCursor; +@:require(flash11) static flash.ui.Mouse.unregisterCursor; + +-flash.ui.MouseCursor.new; + +@:require(flash11) flash.utils.CompressionAlgorithm; +enum flash.utils.CompressionAlgorithm; + +@:require(flash11) flash.xml.XML.toJSON; +@:require(flash11) flash.xml.XMLList.toJSON; + +flash.utils.ByteArray.$algorithm : CompressionAlgorithm; + +@:require(flash11) flash.text.TextField.textInteractionMode; + +enum flash.text.TextInteractionMode; + +flash.text.TextField.textInteractionMode : TextInteractionMode; + +// 11.2 + +enum flash.display.BitmapCompressColorSpace; + +@:require(flash11_2) flash.display.BitmapData.compress; +@:require(flash11_2) flash.media.Camera.position; +@:require(flash11_2) flash.net.NetStream.dispose; + +@:require(flash11_2) flash.display.StageWorker; +@:require(flash11_2) flash.display.Worker; +@:require(flash11_2) flash.events.GameInputEvent; +@:require(flash11_2) flash.events.ThrottleEvent; + +flash.events.ThrottleEvent.$type : ThrottleType; + +enum flash.events.ThrottleType; + +@:require(flash11_2) flash.ui.GameInput; +@:require(flash11_2) flash.ui.GameInputDevice; +-flash.ui.GameInput.new; + +@:require(flash11_2) flash.utils.Telemetry; + +enum flash.ui.GameInputFinger; +enum flash.ui.GameInputHand; +enum flash.ui.GameInputControlType; + +flash.ui.GameInputControl.finger : flash.ui.GameInputFinger; +flash.ui.GameInputControl.hand : flash.ui.GameInputHand; +flash.ui.GameInputControl.type : flash.ui.GameInputControlType; + + +// 11.2 + +@:require(flash11_2) flash.display3D.Context3D.setProgramConstantsFromByteArray +@:require(flash11_2) flash.display.Stage.mouseLock; + +@:require(flash11_2) flash.events.MouseEvent.movementX; +@:require(flash11_2) flash.events.MouseEvent.movementY; + +@:require(flash11_2) static flash.events.MouseEvent.CONTEXT_MENU; +@:require(flash11_2) static flash.events.MouseEvent.MIDDLE_CLICK; +@:require(flash11_2) static flash.events.MouseEvent.MIDDLE_MOUSE_DOWN; +@:require(flash11_2) static flash.events.MouseEvent.MIDDLE_MOUSE_UP; +@:require(flash11_2) static flash.events.MouseEvent.RIGHT_CLICK; +@:require(flash11_2) static flash.events.MouseEvent.RIGHT_MOUSE_DOWN; +@:require(flash11_2) static flash.events.MouseEvent.RIGHT_MOUSE_UP; + + +// 11.3 + +@:require(flash11_3) flash.display.BitmapData.drawWithQuality + +flash.display.BitmapData.$quality : StageQuality; + +enum flash.display.BitmapEncodingColorSpace; + +flash.display.JPEGXREncoderOptions.$colorSpace : BitmapEncodingColorSpace; +flash.display.JPEGXREncoderOptions.colorSpace : BitmapEncodingColorSpace; + +@:require(flash11_3) flash.display.BitmapData.encode +@:require(flash11_3) flash.display.Stage.allowsFullScreenInteractive + +@:require(flash11_3) static flash.events.Event.FRAME_LABEL; +@:require(flash11_3) static flash.events.Event.SUSPEND; + +@:require(flash11_3) static flash.events.FullScreenEvent.FULL_SCREEN_INTERACTIVE_ACCEPTED; +@:require(flash11_3) flash.events.FullScreenEvent.interactive; + +@:require(flash11_3) static flash.events.MouseEvent.RELEASE_OUTSIDE; + +@:require(flash11_3) flash.net.NetStream.useJitterBuffer; + +@:require(flash11_3) flash.system.ApplicationDomain.getQualifiedDefinitionNames; + +@:require(flash11_3) flash.system.SecurityDomain.domainID; + +@:require(flash11_3) flash.system.ApplicationInstaller; +@:require(flash11_3) flash.system.AuthorizedFeatures; +@:require(flash11_3) flash.system.AuthorizedFeaturesLoader; + +@:require(flash11_3) static flash.events.Event.TEXTURE_READY; + + +// 11.4 + +@:require(flash11_4) flash.display3D.Context3D.createRectangleTexture +@:require(flash11_4) flash.display.BitmapData.copyPixelsToByteArray; + +@:require(flash11_4) flash.concurrent.Mutex; +@:require(flash11_4) flash.concurrent.Condition; + +enum flash.display3D.Context3DProfile; + +flash.display.Stage3D.$profile : flash.display3D.Context3DProfile; + +@:require(flash11_4) flash.display.LoaderInfo.childSandboxBridge; +@:require(flash11_4) flash.display.LoaderInfo.parentSandboxBridge; + +@:require(flash11_4) flash.display.Stage.contentsScaleFactor; + + +@:require(flash11_4) flash.media.Camera.copyToByteArray; +@:require(flash11_4) flash.media.Camera.copyToVector; +@:require(flash11_4) flash.media.Camera.drawToBitmapData; +@:require(flash11_4) flash.media.StageVideo.attachCamera; + +@:require(flash11_4) flash.net.URLStream.diskCacheEnabled; +@:require(flash11_4) flash.net.URLStream.length; +@:require(flash11_4) flash.net.URLStream.position; +@:require(flash11_4) flash.net.URLStream.stop; + +@:require(flash11_4) flash.system.AuthorizedFeatures.enableDiskCache; +@:require(flash11_4) flash.system.AuthorizedFeatures.isFeatureEnabled; +@:require(flash11_4) flash.system.AuthorizedFeatures.isNegativeToken; +@:require(flash11_4) flash.system.AuthorizedFeaturesLoader.makeGlobal; + +@:require(flash11_4) flash.utils.ByteArray.shareable; +@:require(flash11_4) flash.utils.ByteArray.atomicCompareAndSwapIntAt; +@:require(flash11_4) flash.utils.ByteArray.atomicCompareAndSwapLength; + +//not supported @:require(flash11_4) flash.utils.CompressionAlgorithm.LZMA; + +@:require(flash11_4) flash.system.Worker; +@:require(flash11_4) flash.system.WorkerDomain; + +@:require(flash11_4) flash.system.MessageChannel; + +-flash.system.Worker.new; +-flash.system.MessageChannel.new; + +flash.system.Worker.state : WorkerState; +flash.system.MessageChannel.state : MessageChannelState; + +enum flash.system.WorkerState; + + +// --- 11.6 API + +enum flash.display3D.Context3DMipFilter +enum flash.display3D.Context3DTextureFilter +enum flash.display3D.Context3DWrapMode +enum flash.system.ApplicationInstallerMode + +@:require(flash11_6) flash.display3D.Context3D.setSamplerStateAt +flash.display3D.Context3D.$wrap : Context3DWrapMode; +flash.display3D.Context3D.$filter : Context3DTextureFilter; +flash.display3D.Context3D.$mipfilter : Context3DMipFilter; + +-flash.display.DisplayObject.metaData + +@:require(flash11_6) flash.display.Graphics.readGraphicsData + +@:require(flash11_7) flash.media.StageVideo.attachAVStream; +@:require(flash11_7) static flash.net.SharedObject.preventBackup; +@:require(flash11_7) flash.system.AuthorizedFeatures.enableHLSPlayback; +@:require(flash11_7) flash.system.AuthorizedFeaturesLoader.loadAuthorizedFeaturesFromData; + + diff --git a/doc/images/Banner.bmp b/doc/images/Banner.bmp new file mode 100644 index 0000000000000000000000000000000000000000..e81d610c61a2a78760cb20521c69e7ae8ca90aca Binary files /dev/null and b/doc/images/Banner.bmp differ diff --git a/doc/images/Wizard.bmp b/doc/images/Wizard.bmp new file mode 100644 index 0000000000000000000000000000000000000000..8bbd1799c33f877dd50da82f3ec5269c00e05cf3 Binary files /dev/null and b/doc/images/Wizard.bmp differ diff --git a/haxe/doc/install.ml b/doc/install.ml similarity index 63% rename from haxe/doc/install.ml rename to doc/install.ml index 6dee0ea707482568da53ae7fe423dd3884df21b2..b4db78fcfbb897aa4cb172a5f7fa5dbd06b649ce 100644 --- a/haxe/doc/install.ml +++ b/doc/install.ml @@ -36,14 +36,14 @@ let exe_ext = match os_type with "Win32" | "Cygwin" -> ".exe" | _ -> "" let ocamloptflags = match os_type with "Unix" -> "-cclib -fno-stack-protector " | _ -> "" let zlib_path = match os_type with - | "Win32" -> "../ocaml/extc/zlib/" + | "Win32" -> "libs/extc/zlib/" | _ -> "./" let zlib = match os_type with | "Win32" -> zlib_path ^ "zlib.lib" | _ -> try - List.find Sys.file_exists ["/usr/lib/libz.dylib";"/usr/lib64/libz.so.1";"/usr/lib/libz.so.1";"/lib/libz.so.1";"/usr/lib/libz.so.4.1"] + List.find Sys.file_exists ["/usr/lib/libz.dylib";"/usr/lib64/libz.so.1";"/usr/lib/libz.so.1";"/lib/libz.so.1";"/usr/lib/libz.so.4.1";"/lib/x86_64-linux-gnu/libz.so.1"] with Not_found -> failwith "LibZ was not found on your system, please install it or modify the search directories in the install script" @@ -68,102 +68,135 @@ let modules l ext = ;; -let motiontwin = ":pserver:anonymous@cvs.motion-twin.com:/cvsroot" in - -let download_libs() = - cvs motiontwin "co ocaml/swflib"; - cvs motiontwin "co ocaml/extc"; - cvs motiontwin "co ocaml/extlib-dev"; - cvs motiontwin "co ocaml/xml-light"; - cvs motiontwin "co neko/libs/include/ocaml" -in let download() = command "svn co http://haxe.googlecode.com/svn/trunk haxe"; - download_libs(); in let compile_libs() = + Sys.chdir "haxe/libs"; + (* EXTLIB *) - Sys.chdir "ocaml/extlib-dev"; + Sys.chdir "extlib"; command ("ocaml install.ml -nodoc -d .. " ^ (if bytecode then "-b " else "") ^ (if native then "-n" else "")); msg ""; - Sys.chdir "../.."; + Sys.chdir ".."; (* EXTC *) - Sys.chdir "ocaml/extc"; + Sys.chdir "extc"; let c_opts = (if Sys.ocaml_version < "3.08" then " -ccopt -Dcaml_copy_string=copy_string " else " ") in - command ("ocamlc" ^ c_opts ^ " -I .. -I ../" ^ zlib_path ^ " extc_stubs.c"); + command ("ocamlc" ^ c_opts ^ " -I .. -I ../../" ^ zlib_path ^ " extc_stubs.c"); - let options = "-cclib ../ocaml/extc/extc_stubs" ^ obj_ext ^ " -cclib " ^ zlib ^ " extc.ml" in + let options = "-cclib libs/extc/extc_stubs" ^ obj_ext ^ " -cclib " ^ zlib ^ " extc.ml" in + let options = if Sys.os_type = "Win32" then options ^ " -cclib shell32.lib" else options in if bytecode then command ("ocamlc -a -I .. -o extc.cma " ^ options); if native then command ("ocamlopt -a -I .. -o extc.cmxa " ^ options); - Sys.chdir "../.."; + Sys.chdir ".."; (* SWFLIB *) - Sys.chdir "ocaml/swflib"; - let files = "-I .. -I ../extc as3.mli as3hl.mli as3code.ml as3parse.ml as3hlparse.ml swf.ml actionScript.ml swfParser.ml" in + Sys.chdir "swflib"; + let files = "-I .. -I ../extc as3.mli as3hl.mli as3code.ml as3parse.ml as3hlparse.ml swf.ml actionScript.ml swfParser.ml png.mli png.ml" in if bytecode then command ("ocamlc -a -o swflib.cma " ^ files); if native then command ("ocamlopt -a -o swflib.cmxa " ^ files); - Sys.chdir "../.."; + Sys.chdir ".."; + + (* NEKO *) + Sys.chdir "neko"; + let files = "-I .. nast.ml nxml.ml binast.ml nbytecode.ml ncompile.ml" in + if bytecode then command ("ocamlc -a -o neko.cma " ^ files); + if native then command ("ocamlopt -a -o neko.cmxa " ^ files); + Sys.chdir ".."; + + (* ZIPLIB *) + Sys.chdir "ziplib"; + let files = "-I .. -I ../extc zlib.mli zlib.ml zip.mli zip.ml" in + if bytecode then command ("ocamlc -a -o zip.cma " ^ files); + if native then command ("ocamlopt -a -o zip.cmxa " ^ files); + Sys.chdir ".."; + + (* JAVALIB *) + Sys.chdir "javalib"; + let files = "-I .. jData.ml jReader.ml" in + if bytecode then command ("ocamlc -a -o java.cma " ^ files); + if native then command ("ocamlopt -a -o java.cmxa " ^ files); + Sys.chdir ".."; + + (* TTFLIB *) + Sys.chdir "ttflib"; + let files = "-I .. -I ../extlib -I ../swflib tTFData.ml tTFParser.ml tTFTools.ml tTFSwfWriter.ml tTFCanvasWriter.ml tTFJsonWriter.ml main.ml" in + if bytecode then command ("ocamlc -a -o ttf.cma " ^ files); + if native then command ("ocamlopt -a -o ttf.cmxa " ^ files); + Sys.chdir ".."; (* XML-LIGHT *) - Sys.chdir "ocaml/xml-light"; + Sys.chdir "xml-light"; command ("ocamlyacc xml_parser.mly"); command ("ocamlc xml.mli dtd.mli xml_parser.mli xml_lexer.mli"); command ("ocamllex xml_lexer.mll"); let files = "xml_parser.ml xml_lexer.ml dtd.ml xmlParser.mli xmlParser.ml xml.ml" in if bytecode then command ("ocamlc -a -o xml-light.cma " ^ files); if native then command ("ocamlopt -a -o xml-light.cmxa " ^ files); - Sys.chdir "../.."; + Sys.chdir ".."; + Sys.chdir "../.."; in let compile() = (try Unix.mkdir "bin" 0o740 with Unix.Unix_error(Unix.EEXIST,_,_) -> ()); - compile_libs(); - - (* HAXE *) Sys.chdir "haxe"; + (* HAXE *) command "ocamllex lexer.mll"; let libs = [ - "../ocaml/extLib"; - "../ocaml/extc/extc"; - "../ocaml/swflib/swflib"; - "../ocaml/xml-light/xml-light"; + "libs/extLib"; + "libs/extc/extc"; + "libs/swflib/swflib"; + "libs/xml-light/xml-light"; + "libs/neko/neko"; + "libs/javalib/java"; "unix"; - "str" + "libs/ziplib/zip"; + "str"; + "libs/ttflib/ttf" ] in - let neko = "../neko/libs/include/ocaml" in let paths = [ - "../ocaml"; - "../ocaml/swflib"; - "../ocaml/xml-light"; - "../ocaml/extc"; - neko + "libs"; + "libs/swflib"; + "libs/xml-light"; + "libs/extc"; + "libs/neko"; + "libs/ziplib"; + "libs/javalib"; + "libs/ttflib" ] in let mlist = [ "ast";"lexer";"type";"common";"parser";"typecore"; - "genxml";"typeload";"codegen";"optimizer"; - neko^"/nast";neko^"/binast";neko^"/nxml"; - "genneko";"genas3";"genjs";"genswf8";"genswf9";"genswf";"genphp";"gencpp"; - "interp";"typer";"main"; + "genxml";"optimizer";"typeload";"codegen"; + "gencommon"; "genneko";"genas3";"genjs";"genswf8";"genswf9";"genswf";"genphp";"gencpp"; "gencs";"genjava"; + "interp";"typer";"matcher";"dce";"main"; ] in let path_str = String.concat " " (List.map (fun s -> "-I " ^ s) paths) in let libs_str ext = " " ^ String.concat " " (List.map (fun l -> l ^ ext) libs) ^ " " in ocamlc (path_str ^ " -pp camlp4o " ^ modules mlist ".ml"); if bytecode then command ("ocamlc -custom -o ../bin/haxe-byte" ^ exe_ext ^ libs_str ".cma" ^ modules mlist ".cmo"); if native then command ("ocamlopt -o ../bin/haxe" ^ exe_ext ^ libs_str ".cmxa" ^ modules mlist ".cmx"); +in + +let make_std() = + + if Sys.file_exists "../bin/std" then command (if os_type = "Win32" then "rmdir /S /Q ..\\bin\\std" else "rm -rf ../bin/std"); + command "svn export -q std ../bin/std"; in let startdir = Sys.getcwd() in try download(); + compile_libs(); compile(); + make_std(); Sys.chdir startdir; with Failure msg -> Sys.chdir startdir; - prerr_endline msg; exit 1 \ No newline at end of file + prerr_endline msg; exit 1 diff --git a/doc/installer.nsi b/doc/installer.nsi new file mode 100644 index 0000000000000000000000000000000000000000..c8d1481974edff744a8848306d3ed24aae24dbd6 --- /dev/null +++ b/doc/installer.nsi @@ -0,0 +1,183 @@ +; Haxe/Neko Install script + +;-------------------------------- + +!include "MUI.nsh" +!include "LogicLib.nsh" +!include "WordFunc.nsh" +!include "winmessages.nsh" +!include "EnvVarUpdate.nsh" + +;-------------------------------- + +; Define version info +!define VERSION "3.0.0" + +; Define Neko info +!define NEKO_VERSION "2.0.0" + +; Installer details +VIAddVersionKey "CompanyName" "Haxe Foundation" +VIAddVersionKey "ProductName" "Haxe Installer" +VIAddVersionKey "LegalCopyright" "Haxe Foundation 2005-2013" +VIAddVersionKey "FileDescription" "Haxe Installer" +VIAddVersionKey "ProductVersion" "${VERSION}.0" +VIAddVersionKey "FileVersion" "${VERSION}.0" +VIProductVersion "${VERSION}.0" + +; The name of the installer +Name "Haxe ${VERSION}" + +; The captions of the installer +Caption "Haxe ${VERSION} Setup" +UninstallCaption "Haxe ${VERSION} Uninstall" + +; The file to write +OutFile "haxe-${VERSION}-win.exe" + +; Default installation folder +InstallDir "C:\HaxeToolkit\" + +; Define executable files +!define EXECUTABLE "$INSTDIR\haxe\haxe.exe" +!define HaxeLIB "$INSTDIR\Haxe\haxelib.exe" +!define NEKOEXE "$INSTDIR\neko\neko.exe" + +; Vista redirects $SMPROGRAMS to all users without this +RequestExecutionLevel admin + +; Use replace and version compare +!insertmacro WordReplace +!insertmacro VersionCompare + +; Required props +SetFont /LANG=${LANG_ENGLISH} "Tahoma" 8 +SetCompressor /SOLID lzma +CRCCheck on +XPStyle on + +;-------------------------------- + +; Interface Configuration + +!define MUI_HEADERIMAGE +!define MUI_ABORTWARNING +!define MUI_HEADERIMAGE_BITMAP "images\Banner.bmp" +!define MUI_WELCOMEFINISHPAGE_BITMAP "images\Wizard.bmp" +!define MUI_UNWELCOMEFINISHPAGE_BITMAP "images\Wizard.bmp" +!define MUI_PAGE_HEADER_SUBTEXT "Please view the license before installing Haxe ${VERSION}." +!define MUI_WELCOMEPAGE_TEXT "This wizard will guide you through the installation of $(^NameDA).\r\n\r\nIt is recommended that you close all other applications before starting Setup. This will make it possible to update relevant system files without having to reboot your computer.\r\n\r\n$_CLICK" + +;-------------------------------- + +; Pages + +!insertmacro MUI_PAGE_WELCOME +!insertmacro MUI_PAGE_COMPONENTS +!insertmacro MUI_PAGE_DIRECTORY +!insertmacro MUI_PAGE_INSTFILES +!insertmacro MUI_PAGE_FINISH +!insertmacro MUI_UNPAGE_WELCOME +!insertmacro MUI_UNPAGE_CONFIRM +!insertmacro MUI_UNPAGE_COMPONENTS +!insertmacro MUI_UNPAGE_INSTFILES +!insertmacro MUI_UNPAGE_FINISH +!insertmacro MUI_LANGUAGE "English" + +;-------------------------------- + +; InstallTypes + +InstType "Default" +InstType "un.Default" +InstType "un.Full" + +;-------------------------------- + +; Functions + + + +Function .onInit + + + +FunctionEnd + +;-------------------------------- + +; Install Sections + +!define env_hklm 'HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"' +!define env_hkcu 'HKCU "Environment"' + +Section "Haxe ${VERSION}" Main + + SectionIn 1 2 RO + SetOverwrite on + + SetOutPath "$INSTDIR\haxe" + + File /r /x .svn /x *.db /x Exceptions.log /x .local /x .multi /x *.pdb /x *.vshost.exe /x *.vshost.exe.config /x *.vshost.exe.manifest "resources\haxe\*.*" + + ExecWait "$INSTDIR\haxe\haxesetup.exe -silent" + + WriteUninstaller "$INSTDIR\Uninstall.exe" + +SectionEnd + +Section "Neko ${NEKO_VERSION}" Neko + + SectionIn 1 2 + SetOverwrite on + + SetOutPath "$INSTDIR\neko" + + File /r /x .svn /x *.db /x Exceptions.log /x .local /x .multi /x *.pdb /x *.vshost.exe /x *.vshost.exe.config /x *.vshost.exe.manifest "resources\neko\*.*" + +SectionEnd + + + + +;-------------------------------- + +; Install section strings + +!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN +!insertmacro MUI_DESCRIPTION_TEXT ${Main} "Installs Haxe and other core files." +!insertmacro MUI_DESCRIPTION_TEXT ${Neko} "Installs Neko, which is required by various Haxe tools." +!insertmacro MUI_FUNCTION_DESCRIPTION_END + +;-------------------------------- + +; Uninstall Sections + +Section "un.Haxe" UninstMain + + RMDir /r "$INSTDIR\haxe" + ${un.EnvVarUpdate} $0 "PATH" "R" "HKCU" "%HAXEPATH%" + DeleteRegValue ${env_hkcu} HAXEPATH + SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000 + +SectionEnd + +Section "un.Neko" UninstNeko + + RMDir /r "$INSTDIR\neko" + ${un.EnvVarUpdate} $0 "PATH" "R" "HKCU" "%NEKO_INSTPATH%" + DeleteRegValue ${env_hkcu} NEKO_INSTPATH + SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000 + +SectionEnd + +;-------------------------------- + +; Uninstall section strings + +!insertmacro MUI_UNFUNCTION_DESCRIPTION_BEGIN +!insertmacro MUI_DESCRIPTION_TEXT ${UninstMain} "Uninstalls Haxe and other core files." +!insertmacro MUI_DESCRIPTION_TEXT ${UninstNeko} "Uninstalls Neko." +!insertmacro MUI_UNFUNCTION_DESCRIPTION_END + +;-------------------------------- diff --git a/haxe/doc/release.neko b/doc/release.neko similarity index 75% rename from haxe/doc/release.neko rename to doc/release.neko index 3c552b405f9f873dc3855c1b01ca8e17af7cd420..ac37abc218dc23c05e174e3d843b507e0143f6fa 100644 --- a/haxe/doc/release.neko +++ b/doc/release.neko @@ -36,12 +36,16 @@ cmd("rm -rf "+dir); mkdir(dir); mkdir(dir+"/doc"); -if( sys == "Windows" ) +if( sys == "Windows" ) { cmd("cp ../haxe.exe ../haxesetup.exe haxeserver.bat "+dir); -else + // copy if available (means we build on recent OCaml/MSVC) + try cmd("cp C:/Windows/System32/msvcr100.dll "+dir) catch e {}; +} else cmd("cp ../haxe "+dir); -cmd("cp -R CHANGES.txt LICENSE.txt ../std "+dir); +cmd("cp -pR CHANGES.txt LICENSE.txt ../std "+dir); + +if( sys == "Windows" ) cmd("chmod -R 777 "+dir); cmd("haxe all.hxml"); chdir(dir+"/std/tools"); @@ -50,7 +54,7 @@ chdir(dir+"/std/tools"); chdir("haxedoc"); cmd("haxe haxedoc.hxml"); -cmd(curdir+"haxedoc \"../../../../flash.xml;flash\" \"../../../../neko.xml;neko\" \"../../../../js.xml;js\" \"../../../../flash9.xml;flash9;flash\" \"../../../../php.xml;php\" \"../../../../cpp.xml;cpp\""); +cmd(curdir+"haxedoc -v \"../../../../flash8.xml;flash8;flash\" \"../../../../neko.xml;neko\" \"../../../../js.xml;js\" \"../../../../flash9.xml;flash\" \"../../../../php.xml;php\" \"../../../../cpp.xml;cpp\""); cmd("mv index.html content ../../../doc"); cmd("mv haxedoc"+binext+" ../../.."); chdir(".."); @@ -64,7 +68,7 @@ chdir(".."); chdir(".."); -cmd("rm -rf .svn */.svn */*/.svn */*/*/.svn"); +cmd("rm -rf .svn */.svn */*/.svn */*/*/.svn */*/*/*/.svn"); cmd("rm -rf all.n all.js *.swf *.xml"); chdir("tools"); diff --git a/haxe/doc/setup.cpp b/doc/setup.cpp similarity index 100% rename from haxe/doc/setup.cpp rename to doc/setup.cpp diff --git a/haxe/genas3.ml b/genas3.ml similarity index 64% rename from haxe/genas3.ml rename to genas3.ml index 742ad1cd244b3e79f4a2b7de6120d4215d992ade..e017b2ce28b9511cc5d5ed0aedcb415e70934d92 100644 --- a/haxe/genas3.ml +++ b/genas3.ml @@ -1,21 +1,25 @@ (* - * Haxe Compiler - * Copyright (c)2005-2007 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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 Type open Common @@ -31,16 +35,31 @@ type context = { mutable get_sets : (string * bool,string) Hashtbl.t; mutable curclass : tclass; mutable tabs : string; - mutable in_value : string option; + mutable in_value : tvar option; mutable in_static : bool; mutable handle_break : bool; mutable imports : (string,string list list) Hashtbl.t; - mutable locals : (string,string) PMap.t; - mutable inv_locals : (string,string) PMap.t; + mutable gen_uid : int; mutable local_types : t list; mutable constructor_block : bool; + mutable block_inits : (unit -> unit) option; } +let is_var_field f = + match f with + | FStatic (_,f) | FInstance (_,f) -> + (match f.cf_kind with Var _ -> true | _ -> false) + | _ -> + false + +let is_special_compare e1 e2 = + match e1.eexpr, e2.eexpr with + | TConst TNull, _ | _ , TConst TNull -> None + | _ -> + match follow e1.etype, follow e2.etype with + | TInst ({ cl_path = [],"Xml" } as c,_) , _ | _ , TInst ({ cl_path = [],"Xml" } as c,_) -> Some c + | _ -> None + let protect name = match name with | "Error" | "Namespace" -> "_" ^ name @@ -55,6 +74,7 @@ let s_path ctx stat path p = | "Dynamic" -> "Object" | "Bool" -> "Boolean" | "Enum" -> "Class" + | "EnumValue" -> "enum" | _ -> name) | (["flash"],"FlashXml__") -> "Xml" @@ -83,27 +103,32 @@ let reserved = List.iter (fun l -> Hashtbl.add h l ()) (* these ones are defined in order to prevent recursion in some Std functions *) ["is";"as";"int";"uint";"const";"getTimer";"typeof";"parseInt";"parseFloat"; - (* AS3 keywords which are not haXe ones *) - "each";"label";"finally";"with";"final";"internal";"native";"const";"namespace";"include";"delete"; + (* AS3 keywords which are not Haxe ones *) + "finally";"with";"final";"internal";"native";"namespace";"include";"delete"; (* some globals give some errors with Flex SDK as well *) - "print"; + "print";"trace"; (* we don't include get+set since they are not 'real' keywords, but they can't be used as method names *) + "function";"class";"var";"if";"else";"while";"do";"for";"break";"continue";"return";"extends";"implements"; + "import";"switch";"case";"default";"static";"public";"private";"try";"catch";"new";"this";"throw";"interface"; + "override";"package";"null";"true";"false";"void" ]; h + (* "each", "label" : removed (actually allowed in locals and fields accesses) *) + let s_ident n = if Hashtbl.mem reserved n then "_" ^ n else n +let rec create_dir 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_dir (d :: acc) l + let init infos path = - 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 let dir = infos.com.file :: fst path in - create [] dir; + create_dir [] dir; let ch = open_out (String.concat "/" dir ^ "/" ^ snd path ^ ".as") in let imports = Hashtbl.create 0 in Hashtbl.add imports (snd path) [fst path]; @@ -118,11 +143,11 @@ let init infos path = handle_break = false; imports = imports; curclass = null_class; - locals = PMap.empty; - inv_locals = PMap.empty; + gen_uid = 0; local_types = []; get_sets = Hashtbl.create 0; constructor_block = false; + block_inits = None; } let close ctx = @@ -136,22 +161,9 @@ let close ctx = output_string ctx.ch (Buffer.contents ctx.buf); close_out ctx.ch -let save_locals ctx = - let old = ctx.locals in - (fun() -> ctx.locals <- old) - -let define_local ctx l = - let rec loop n = - let name = (if n = 1 then s_ident l else l ^ string_of_int n) in - if PMap.mem name ctx.inv_locals then - loop (n+1) - else begin - ctx.locals <- PMap.add l name ctx.locals; - ctx.inv_locals <- PMap.add name l ctx.inv_locals; - name - end - in - loop 1 +let gen_local ctx l = + ctx.gen_uid <- ctx.gen_uid + 1; + if ctx.gen_uid = 1 then l else l ^ string_of_int ctx.gen_uid let spr ctx s = Buffer.add_string ctx.buf s let print ctx = Printf.kprintf (fun s -> Buffer.add_string ctx.buf s) @@ -161,12 +173,16 @@ let unsupported p = error "This expression cannot be generated to AS3" p let newline ctx = let rec loop p = match Buffer.nth ctx.buf p with - | '}' | '{' | ':' -> print ctx "\n%s" ctx.tabs + | '}' | '{' | ':' | ';' -> print ctx "\n%s" ctx.tabs | '\n' | '\t' -> loop (p - 1) | _ -> print ctx ";\n%s" ctx.tabs in loop (Buffer.length ctx.buf - 1) +let block_newline ctx = match Buffer.nth ctx.buf (Buffer.length ctx.buf - 1) with + | '}' -> print ctx ";\n%s" ctx.tabs + | _ -> newline ctx + let rec concat ctx s f = function | [] -> () | [x] -> f x @@ -196,14 +212,24 @@ let rec type_str ctx t p = match t with | TEnum _ | TInst _ when List.memq t ctx.local_types -> "*" + | TAbstract ({ a_impl = Some _ } as a,pl) -> + type_str ctx (apply_params a.a_types pl a.a_this) p + | TAbstract (a,_) -> + (match a.a_path with + | [], "Void" -> "void" + | [], "UInt" -> "uint" + | [], "Int" -> "int" + | [], "Float" -> "Number" + | [], "Bool" -> "Boolean" + | _ -> s_path ctx true a.a_path p) | TEnum (e,_) -> if e.e_extern then (match e.e_path with | [], "Void" -> "void" | [], "Bool" -> "Boolean" - | _ -> + | _ -> let rec loop = function | [] -> "Object" - | (":fakeEnum",[Ast.EConst (Ast.Type n),_],_) :: _ -> + | (Ast.Meta.FakeEnum,[Ast.EConst (Ast.Ident n),_],_) :: _ -> (match n with | "Int" -> "int" | "UInt" -> "uint" @@ -214,11 +240,13 @@ let rec type_str ctx t p = ) else s_path ctx true e.e_path p | TInst ({ cl_path = ["flash"],"Vector" },[pt]) -> - "Vector.<" ^ type_str ctx pt p ^ ">" - | TInst (c,_) -> + (match pt with + | TInst({cl_kind = KTypeParameter _},_) -> "*" + | _ -> "Vector.<" ^ type_str ctx pt p ^ ">") + | TInst (c,_) -> (match c.cl_kind with - | KNormal | KGeneric | KGenericInstance _ -> s_path ctx false c.cl_path p - | KTypeParameter | KExtension _ | KConstant _ -> "*") + | KNormal | KGeneric | KGenericInstance _ | KAbstractImpl _ -> s_path ctx false c.cl_path p + | KTypeParameter _ | KExtension _ | KExpr _ | KMacroType -> "*") | TFun _ -> "Function" | TMono r -> @@ -232,6 +260,10 @@ let rec type_str ctx t p = (match args with | [t] -> (match follow t with + | TAbstract ({ a_path = [],"UInt" },_) + | TAbstract ({ a_path = [],"Int" },_) + | TAbstract ({ a_path = [],"Float" },_) + | TAbstract ({ a_path = [],"Bool" },_) | TInst ({ cl_path = [],"Int" },_) | TInst ({ cl_path = [],"Float" },_) | TEnum ({ e_path = [],"Bool" },_) -> "*" @@ -278,6 +310,40 @@ let escape_bin s = done; Buffer.contents b +let generate_resources infos = + if Hashtbl.length infos.com.resources <> 0 then begin + let dir = (infos.com.file :: ["__res"]) in + create_dir [] dir; + let add_resource name data = + let ch = open_out_bin (String.concat "/" (dir @ [name])) in + output_string ch data; + close_out ch + in + Hashtbl.iter (fun name data -> add_resource name data) infos.com.resources; + let ctx = init infos ([],"__resources__") in + spr ctx "\timport flash.utils.Dictionary;\n"; + spr ctx "\tpublic class __resources__ {\n"; + spr ctx "\t\tpublic static var list:Dictionary;\n"; + let inits = ref [] in + let k = ref 0 in + Hashtbl.iter (fun name _ -> + let varname = ("v" ^ (string_of_int !k)) in + k := !k + 1; + print ctx "\t\t[Embed(source = \"__res/%s\", mimeType = \"application/octet-stream\")]\n" name; + print ctx "\t\tpublic static var %s:Class;\n" varname; + inits := ("list[\"" ^name^ "\"] = " ^ varname ^ ";") :: !inits; + ) infos.com.resources; + spr ctx "\t\tstatic public function __init__():void {\n"; + spr ctx "\t\t\tlist = new Dictionary();\n"; + List.iter (fun init -> + print ctx "\t\t\t%s\n" init + ) !inits; + spr ctx "\t\t}\n"; + spr ctx "\t}\n"; + spr ctx "}"; + close ctx; + end + let gen_constant ctx p = function | TInt i -> print ctx "%ld" i | TFloat s -> spr ctx s @@ -289,24 +355,33 @@ let gen_constant ctx p = function let gen_function_header ctx name f params p = let old = ctx.in_value in - let old_l = ctx.locals in - let old_li = ctx.inv_locals in let old_t = ctx.local_types in + let old_bi = ctx.block_inits in ctx.in_value <- None; ctx.local_types <- List.map snd params @ ctx.local_types; + let init () = + List.iter (fun (v,o) -> match o with + | Some c when is_nullable v.v_type && c <> TNull -> + newline ctx; + print ctx "if(%s==null) %s=" v.v_name v.v_name; + gen_constant ctx p c; + | _ -> () + ) f.tf_args; + ctx.block_inits <- None; + in + ctx.block_inits <- Some init; print ctx "function%s(" (match name with None -> "" | Some (n,meta) -> let rec loop = function | [] -> n - | (":getter",[Ast.EConst (Ast.Ident i | Ast.Type i),_],_) :: _ -> "get " ^ i - | (":setter",[Ast.EConst (Ast.Ident i | Ast.Type i),_],_) :: _ -> "set " ^ i + | (Ast.Meta.Getter,[Ast.EConst (Ast.Ident i),_],_) :: _ -> "get " ^ i + | (Ast.Meta.Setter,[Ast.EConst (Ast.Ident i),_],_) :: _ -> "set " ^ i | _ :: l -> loop l in " " ^ loop meta ); - concat ctx "," (fun (arg,c,t) -> - let arg = define_local ctx arg in - let tstr = type_str ctx t p in - print ctx "%s : %s" arg tstr; + concat ctx "," (fun (v,c) -> + let tstr = type_str ctx v.v_type p in + print ctx "%s : %s" (s_ident v.v_name) tstr; match c with | None -> if ctx.constructor_block then print ctx " = %s" (default_value tstr); @@ -317,9 +392,8 @@ let gen_function_header ctx name f params p = print ctx ") : %s " (type_str ctx f.tf_type p); (fun () -> ctx.in_value <- old; - ctx.locals <- old_l; - ctx.inv_locals <- old_li; ctx.local_types <- old_t; + ctx.block_inits <- old_bi; ) let rec gen_call ctx e el r = @@ -331,88 +405,75 @@ let rec gen_call ctx e el r = spr ctx "("; concat ctx "," (gen_value ctx) el; spr ctx ")"; - | TLocal "__is__" , [e1;e2] -> + | TLocal { v_name = "__is__" } , [e1;e2] -> gen_value ctx e1; spr ctx " is "; gen_value ctx e2; - | TLocal "__as__" , [e1;e2] -> + | TLocal { v_name = "__as__" }, [e1;e2] -> gen_value ctx e1; spr ctx " as "; gen_value ctx e2; - | TLocal "__int__" , [e] -> + | TLocal { v_name = "__int__" }, [e] -> spr ctx "int("; gen_value ctx e; spr ctx ")"; - | TLocal "__float__" , [e] -> + | TLocal { v_name = "__float__" }, [e] -> spr ctx "Number("; gen_value ctx e; spr ctx ")"; - | TLocal "__typeof__", [e] -> + | TLocal { v_name = "__typeof__" }, [e] -> spr ctx "typeof "; gen_value ctx e; - | TLocal "__keys__", [e] -> + | TLocal { v_name = "__keys__" }, [e] -> let ret = (match ctx.in_value with None -> assert false | Some r -> r) in - print ctx "%s = new Array()" ret; + print ctx "%s = new Array()" ret.v_name; newline ctx; - let b = save_locals ctx in - let tmp = define_local ctx "$k" in + let tmp = gen_local ctx "$k" in print ctx "for(var %s : String in " tmp; gen_value ctx e; - print ctx ") %s.push(%s)" ret tmp; - b(); - | TLocal "__hkeys__", [e] -> + print ctx ") %s.push(%s)" ret.v_name tmp; + | TLocal { v_name = "__hkeys__" }, [e] -> let ret = (match ctx.in_value with None -> assert false | Some r -> r) in - print ctx "%s = new Array()" ret; + print ctx "%s = new Array()" ret.v_name; newline ctx; - let b = save_locals ctx in - let tmp = define_local ctx "$k" in + let tmp = gen_local ctx "$k" in print ctx "for(var %s : String in " tmp; gen_value ctx e; - print ctx ") %s.push(%s.substr(1))" ret tmp; - b(); - | TLocal "__foreach__", [e] -> + print ctx ") %s.push(%s.substr(1))" ret.v_name tmp; + | TLocal { v_name = "__foreach__" }, [e] -> let ret = (match ctx.in_value with None -> assert false | Some r -> r) in - print ctx "%s = new Array()" ret; + print ctx "%s = new Array()" ret.v_name; newline ctx; - let b = save_locals ctx in - let tmp = define_local ctx "$k" in + let tmp = gen_local ctx "$k" in print ctx "for each(var %s : * in " tmp; gen_value ctx e; - print ctx ") %s.push(%s)" ret tmp; - b(); - | TLocal "__new__", e :: args -> + print ctx ") %s.push(%s)" ret.v_name tmp; + | TLocal { v_name = "__new__" }, e :: args -> spr ctx "new "; gen_value ctx e; spr ctx "("; concat ctx "," (gen_value ctx) args; spr ctx ")"; - | TLocal "__delete__", [e;f] -> + | TLocal { v_name = "__delete__" }, [e;f] -> spr ctx "delete("; gen_value ctx e; spr ctx "["; gen_value ctx f; spr ctx "]"; spr ctx ")"; - | TLocal "__unprotect__", [e] -> + | TLocal { v_name = "__unprotect__" }, [e] -> gen_value ctx e - | TLocal "__vector__", [e] -> + | TLocal { v_name = "__vector__" }, [e] -> spr ctx (type_str ctx r e.epos); spr ctx "("; gen_value ctx e; spr ctx ")" - | TField ({ eexpr = TTypeExpr (TClassDecl { cl_path = (["flash"],"Lib") }) },f), args -> - (match f, args with - | "as", [e1;e2] -> - gen_value ctx e1; - spr ctx " as "; - gen_value ctx e2 - | _ -> - gen_value ctx e; - spr ctx "("; - concat ctx "," (gen_value ctx) el; - spr ctx ")") - | TField ({ eexpr = TTypeExpr (TClassDecl { cl_path = (["flash"],"Vector") }) },f), args -> - (match f, args with + | TField (_, FStatic( { cl_path = (["flash"],"Lib") }, { cf_name = "as" })), [e1;e2] -> + gen_value ctx e1; + spr ctx " as "; + gen_value ctx e2 + | TField (_, FStatic ({ cl_path = (["flash"],"Vector") }, cf)), args -> + (match cf.cf_name, args with | "ofArray", [e] | "convert", [e] -> (match follow r with | TInst ({ cl_path = (["flash"],"Vector") },[t]) -> @@ -421,6 +482,13 @@ let rec gen_call ctx e el r = print ctx ")"; | _ -> assert false) | _ -> assert false) + | TField (ee,f), args when is_var_field f -> + spr ctx "("; + gen_value ctx e; + spr ctx ")"; + spr ctx "("; + concat ctx "," (gen_value ctx) el; + spr ctx ")" | _ -> gen_value ctx e; spr ctx "("; @@ -447,9 +515,14 @@ and gen_field_access ctx t s = | [], "Date", "now" | [], "Date", "fromTime" | [], "Date", "fromString" - | [], "String", "charCodeAt" -> print ctx "[\"%s\"]" s + | [], "String", "charCodeAt" -> + spr ctx "[\"charCodeAtHX\"]" + | [], "Array", "map" -> + spr ctx "[\"mapHX\"]" + | [], "Array", "filter" -> + spr ctx "[\"filterHX\"]" | [], "Date", "toString" -> print ctx "[\"toStringHX\"]" | [], "String", "cca" -> @@ -472,11 +545,9 @@ and gen_expr ctx e = match e.eexpr with | TConst c -> gen_constant ctx e.epos c - | TLocal s -> - spr ctx (try PMap.find s ctx.locals with Not_found -> error ("Unknown local " ^ s) e.epos) - | TEnumField (en,s) -> - print ctx "%s.%s" (s_path ctx true en.e_path e.epos) (s_ident s) - | TArray ({ eexpr = TLocal "__global__" },{ eexpr = TConst (TString s) }) -> + | TLocal v -> + spr ctx (s_ident v.v_name) + | TArray ({ eexpr = TLocal { v_name = "__global__" } },{ eexpr = TConst (TString s) }) -> let path = Ast.parse_path s in spr ctx (s_path ctx false path e.epos) | TArray (e1,e2) -> @@ -484,20 +555,34 @@ and gen_expr ctx e = spr ctx "["; gen_value ctx e2; spr ctx "]"; - | TBinop (op,{ eexpr = TField (e1,s) },e2) -> + | TBinop (Ast.OpEq,e1,e2) when (match is_special_compare e1 e2 with Some c -> true | None -> false) -> + let c = match is_special_compare e1 e2 with Some c -> c | None -> assert false in + gen_expr ctx (mk (TCall (mk (TField (mk (TTypeExpr (TClassDecl c)) t_dynamic e.epos,FDynamic "compare")) t_dynamic e.epos,[e1;e2])) ctx.inf.com.basic.tbool e.epos); + (* what is this used for? *) +(* | TBinop (op,{ eexpr = TField (e1,s) },e2) -> gen_value_op ctx e1; gen_field_access ctx e1.etype s; print ctx " %s " (Ast.s_binop op); - gen_value_op ctx e2; + gen_value_op ctx e2; *) | TBinop (op,e1,e2) -> gen_value_op ctx e1; print ctx " %s " (Ast.s_binop op); gen_value_op ctx e2; - | TField ({ eexpr = TTypeExpr t },s) when t_path t = ctx.curclass.cl_path && not (PMap.mem s ctx.locals) -> - print ctx "%s" (s_ident s) - | TField (e,s) | TClosure (e,s) -> + (* variable fields on interfaces are generated as (class["field"] as class) *) + | TField ({etype = TInst({cl_interface = true} as c,_)} as e,FInstance (_,{ cf_name = s })) + when (try (match (PMap.find s c.cl_fields).cf_kind with Var _ -> true | _ -> false) with Not_found -> false) -> + spr ctx "("; + gen_value ctx e; + print ctx "[\"%s\"]" s; + print ctx " as %s)" (type_str ctx e.etype e.epos); + | TField({eexpr = TArrayDecl _} as e1,s) -> + spr ctx "("; + gen_expr ctx e1; + spr ctx ")"; + gen_field_access ctx e1.etype (field_name s) + | TField (e,s) -> gen_value ctx e; - gen_field_access ctx e.etype s + gen_field_access ctx e.etype (field_name s) | TTypeExpr t -> spr ctx (s_path ctx true (t_path t) e.epos) | TParenthesis e -> @@ -509,10 +594,16 @@ and gen_expr ctx e = (match eo with | None -> spr ctx "return" - | Some e when (match follow e.etype with TEnum({ e_path = [],"Void" },[]) -> true | _ -> false) -> + | Some e when (match follow e.etype with TEnum({ e_path = [],"Void" },[]) | TAbstract ({ a_path = [],"Void" },[]) -> true | _ -> false) -> + print ctx "{"; + let bend = open_block ctx in + newline ctx; gen_value ctx e; newline ctx; - spr ctx "return" + spr ctx "return"; + bend(); + newline ctx; + print ctx "}"; | Some e -> spr ctx "return "; gen_value ctx e); @@ -522,10 +613,7 @@ and gen_expr ctx e = | TContinue -> if ctx.in_value <> None then unsupported e.epos; spr ctx "continue" - | TBlock [] -> - spr ctx "null" | TBlock el -> - let b = save_locals ctx in print ctx "{"; let bend = open_block ctx in let cb = (if not ctx.constructor_block then @@ -538,17 +626,17 @@ and gen_expr ctx e = print ctx " if( !%s.skip_constructor ) {" (s_path ctx true (["flash"],"Boot") e.epos); (fun() -> print ctx "}") end) in - List.iter (fun e -> newline ctx; gen_expr ctx e) el; + (match ctx.block_inits with None -> () | Some i -> i()); + List.iter (fun e -> block_newline ctx; gen_expr ctx e) el; bend(); newline ctx; cb(); print ctx "}"; - b(); | TFunction f -> let h = gen_function_header ctx None f [] e.epos in let old = ctx.in_static in ctx.in_static <- true; - gen_expr ctx (mk_block f.tf_expr); + gen_expr ctx f.tf_expr; ctx.in_static <- old; h(); | TCall (v,el) -> @@ -564,10 +652,9 @@ and gen_expr ctx e = () | TVars vl -> spr ctx "var "; - concat ctx ", " (fun (n,t,v) -> - let n = define_local ctx n in - print ctx "%s : %s" n (type_str ctx t e.epos); - match v with + concat ctx ", " (fun (v,eo) -> + print ctx "%s : %s" (s_ident v.v_name) (type_str ctx v.v_type e.epos); + match eo with | None -> () | Some e -> spr ctx " = "; @@ -614,81 +701,69 @@ and gen_expr ctx e = spr ctx "{ "; concat ctx ", " (fun (f,e) -> print ctx "%s : " (s_ident f); gen_value ctx e) fields; spr ctx "}" - | TFor (v,t,it,e) -> + | TFor (v,it,e) -> let handle_break = handle_break ctx e in - let b = save_locals ctx in - let tmp = define_local ctx "$it" in + let tmp = gen_local ctx "$it" in print ctx "{ var %s : * = " tmp; gen_value ctx it; newline ctx; - let v = define_local ctx v in - print ctx "while( %s.hasNext() ) { var %s : %s = %s.next()" tmp v (type_str ctx t e.epos) tmp; + print ctx "while( %s.hasNext() ) { var %s : %s = %s.next()" tmp (s_ident v.v_name) (type_str ctx v.v_type e.epos) tmp; newline ctx; gen_expr ctx e; newline ctx; spr ctx "}}"; - b(); handle_break(); | TTry (e,catchs) -> spr ctx "try "; - gen_expr ctx (mk_block e); - List.iter (fun (v,t,e) -> + gen_expr ctx e; + List.iter (fun (v,e) -> newline ctx; - let b = save_locals ctx in - let v = define_local ctx v in - print ctx "catch( %s : %s )" v (type_str ctx t e.epos); - gen_expr ctx (mk_block e); - b(); + print ctx "catch( %s : %s )" (s_ident v.v_name) (type_str ctx v.v_type e.epos); + gen_expr ctx e; ) catchs; | TMatch (e,_,cases,def) -> print ctx "{"; let bend = open_block ctx in newline ctx; - let b = save_locals ctx in - let tmp = define_local ctx "$e" in + let tmp = gen_local ctx "$e" in print ctx "var %s : enum = " tmp; gen_value ctx e; newline ctx; print ctx "switch( %s.index ) {" tmp; - newline ctx; List.iter (fun (cl,params,e) -> List.iter (fun c -> - print ctx "case %d:" c; newline ctx; + print ctx "case %d:" c; ) cl; - let b = save_locals ctx in (match params with | None | Some [] -> () | Some l -> let n = ref (-1) in - let l = List.fold_left (fun acc (v,t) -> incr n; match v with None -> acc | Some v -> (v,t,!n) :: acc) [] l in + let l = List.fold_left (fun acc v -> incr n; match v with None -> acc | Some v -> (v,!n) :: acc) [] l in match l with | [] -> () | l -> + newline ctx; spr ctx "var "; - concat ctx ", " (fun (v,t,n) -> - let v = define_local ctx v in - print ctx "%s : %s = %s.params[%d]" v (type_str ctx t e.epos) tmp n; - ) l; - newline ctx); - gen_expr ctx (mk_block e); + concat ctx ", " (fun (v,n) -> + print ctx "%s : %s = %s.params[%d]" (s_ident v.v_name) (type_str ctx v.v_type e.epos) tmp n; + ) l); + gen_block ctx e; print ctx "break"; - newline ctx; - b() ) cases; (match def with | None -> () | Some e -> + newline ctx; spr ctx "default:"; - gen_expr ctx (mk_block e); + gen_block ctx e; print ctx "break"; - newline ctx; ); + newline ctx; spr ctx "}"; bend(); newline ctx; spr ctx "}"; - b() | TSwitch (e,cases,def) -> spr ctx "switch"; gen_value ctx (parent e); @@ -700,7 +775,7 @@ and gen_expr ctx e = gen_value ctx e; spr ctx ":"; ) el; - gen_expr ctx (mk_block e2); + gen_block ctx e2; print ctx "break"; newline ctx; ) cases; @@ -708,7 +783,7 @@ and gen_expr ctx e = | None -> () | Some e -> spr ctx "default:"; - gen_expr ctx (mk_block e); + gen_block ctx e; print ctx "break"; newline ctx; ); @@ -720,19 +795,29 @@ and gen_expr ctx e = | TCast (e1,Some t) -> gen_expr ctx (Codegen.default_cast ctx.inf.com e1 t e.etype e.epos) +and gen_block ctx e = + newline ctx; + match e.eexpr with + | TBlock [] -> () + | _ -> + gen_expr ctx e; + newline ctx + and gen_value ctx e = let assign e = mk (TBinop (Ast.OpAssign, - mk (TLocal (match ctx.in_value with None -> assert false | Some v -> "$r")) t_dynamic e.epos, + mk (TLocal (match ctx.in_value with None -> assert false | Some r -> r)) t_dynamic e.epos, e )) e.etype e.epos in + let block e = + mk (TBlock [e]) e.etype e.epos + in let value block = let old = ctx.in_value in let t = type_str ctx e.etype e.epos in - let locs = save_locals ctx in - let tmp = define_local ctx "$r" in - ctx.in_value <- Some tmp; + let r = alloc_var (gen_local ctx "$r") e.etype in + ctx.in_value <- Some r; if ctx.in_static then print ctx "function() : %s " t else @@ -741,7 +826,7 @@ and gen_value ctx e = spr ctx "{"; let b = open_block ctx in newline ctx; - print ctx "var %s : %s" tmp t; + print ctx "var %s : %s" r.v_name t; newline ctx; b end else @@ -750,13 +835,12 @@ and gen_value ctx e = (fun() -> if block then begin newline ctx; - print ctx "return %s" tmp; + print ctx "return %s" r.v_name; b(); newline ctx; spr ctx "}"; end; ctx.in_value <- old; - locs(); if ctx.in_static then print ctx "()" else @@ -764,17 +848,15 @@ and gen_value ctx e = ) in match e.eexpr with - | TCall ({ eexpr = TLocal "__keys__" },_) | TCall ({ eexpr = TLocal "__hkeys__" },_) -> + | TCall ({ eexpr = TLocal { v_name = "__keys__" } },_) | TCall ({ eexpr = TLocal { v_name = "__hkeys__" } },_) -> let v = value true in gen_expr ctx e; v() | TConst _ | TLocal _ - | TEnumField _ | TArray _ | TBinop _ | TField _ - | TClosure _ | TTypeExpr _ | TParenthesis _ | TObjectDecl _ @@ -784,8 +866,17 @@ and gen_value ctx e = | TUnop _ | TFunction _ -> gen_expr ctx e - | TCast (e1,t) -> - gen_value ctx (match t with None -> e1 | Some t -> Codegen.default_cast ctx.inf.com e1 t e.etype e.epos) + | TCast (e1,None) -> + let s = type_str ctx e.etype e1.epos in + if s = "*" then + gen_value ctx e1 + else begin + print ctx "%s(" s; + gen_value ctx e1; + spr ctx ")"; + end + | TCast (e1,Some t) -> + gen_value ctx (Codegen.default_cast ctx.inf.com e1 t e.etype e.epos) | TReturn _ | TBreak | TContinue -> @@ -798,6 +889,8 @@ and gen_value ctx e = let v = value true in gen_expr ctx e; v() + | TBlock [] -> + spr ctx "null" | TBlock [e] -> gen_value ctx e | TBlock el -> @@ -840,22 +933,47 @@ and gen_value ctx e = v() | TTry (b,catchs) -> let v = value true in - gen_expr ctx (mk (TTry (assign b, - List.map (fun (v,t,e) -> v, t , assign e) catchs + gen_expr ctx (mk (TTry (block (assign b), + List.map (fun (v,e) -> v, block (assign e)) catchs )) e.etype e.epos); v() +let final m = + if Ast.Meta.has Ast.Meta.Final m then "final " else "" + let generate_field ctx static f = newline ctx; ctx.in_static <- static; - ctx.locals <- PMap.empty; - ctx.inv_locals <- PMap.empty; - let public = f.cf_public || Hashtbl.mem ctx.get_sets (f.cf_name,static) || (f.cf_name = "main" && static) || f.cf_name = "resolve" in + ctx.gen_uid <- 0; + List.iter (fun(m,pl,_) -> + match m,pl with + | Ast.Meta.Meta, [Ast.ECall ((Ast.EConst (Ast.Ident n),_),args),_] -> + let mk_arg (a,p) = + match a with + | Ast.EConst (Ast.String s) -> (None, s) + | Ast.EBinop (Ast.OpAssign,(Ast.EConst (Ast.Ident n),_),(Ast.EConst (Ast.String s),_)) -> (Some n, s) + | _ -> error "Invalid meta definition" p + in + print ctx "[%s" n; + (match args with + | [] -> () + | _ -> + print ctx "("; + concat ctx "," (fun a -> + match mk_arg a with + | None, s -> gen_constant ctx (snd a) (TString s) + | Some s, e -> print ctx "%s=" s; gen_constant ctx (snd a) (TString e) + ) args; + print ctx ")"); + print ctx "]"; + | _ -> () + ) f.cf_meta; + let public = f.cf_public || Hashtbl.mem ctx.get_sets (f.cf_name,static) || (f.cf_name = "main" && static) || f.cf_name = "resolve" || Ast.Meta.has Ast.Meta.Public f.cf_meta in let rights = (if static then "static " else "") ^ (if public then "public" else "protected") in let p = ctx.curclass.cl_pos in match f.cf_expr, f.cf_kind with | Some { eexpr = TFunction fd }, Method (MethNormal | MethInline) -> - print ctx "%s " rights; + print ctx "%s%s " rights (if static then "" else final f.cf_meta); let rec loop c = match c.cl_super with | None -> () @@ -867,70 +985,74 @@ let generate_field ctx static f = in if not static then loop ctx.curclass; let h = gen_function_header ctx (Some (s_ident f.cf_name, f.cf_meta)) fd f.cf_params p in - gen_expr ctx (mk_block fd.tf_expr); + gen_expr ctx fd.tf_expr; h(); newline ctx | _ -> - let is_getset = (match f.cf_kind with Var { v_read = AccCall _ } | Var { v_write = AccCall _ } -> true | _ -> false) in + let is_getset = (match f.cf_kind with Var { v_read = AccCall } | Var { v_write = AccCall } -> true | _ -> false) in if ctx.curclass.cl_interface then match follow f.cf_type with | TFun (args,r) -> - print ctx "function %s(" f.cf_name; + let rec loop = function + | [] -> f.cf_name + | (Ast.Meta.Getter,[Ast.EConst (Ast.String name),_],_) :: _ -> "get " ^ name + | (Ast.Meta.Setter,[Ast.EConst (Ast.String name),_],_) :: _ -> "set " ^ name + | _ :: l -> loop l + in + print ctx "function %s(" (loop f.cf_meta); concat ctx "," (fun (arg,o,t) -> let tstr = type_str ctx t p in print ctx "%s : %s" arg tstr; if o then print ctx " = %s" (default_value tstr); ) args; print ctx ") : %s " (type_str ctx r p); - | _ when is_getset -> + | _ when is_getset -> let t = type_str ctx f.cf_type p in let id = s_ident f.cf_name in (match f.cf_kind with | Var v -> (match v.v_read with - | AccNormal | AccCall _ -> print ctx "function get %s() : %s;" id t; + | AccNormal -> print ctx "function get %s() : %s;" id t; + | AccCall -> print ctx "function %s() : %s;" ("get_" ^ f.cf_name) t; | _ -> ()); (match v.v_write with - | AccNormal | AccCall _ -> print ctx "function set %s( __v : %s ) : void;" id t; + | AccNormal -> print ctx "function set %s( __v : %s ) : void;" id t; + | AccCall -> print ctx "function %s( __v : %s ) : %s;" ("set_" ^ f.cf_name) t t; | _ -> ()); | _ -> assert false) | _ -> () else + let gen_init () = match f.cf_expr with + | None -> () + | Some e -> + print ctx " = "; + gen_value ctx e + in if is_getset then begin let t = type_str ctx f.cf_type p in let id = s_ident f.cf_name in let v = (match f.cf_kind with Var v -> v | _ -> assert false) in - (match v.v_read with - | AccNormal -> + (match v.v_read with + | AccNormal | AccNo | AccNever -> print ctx "%s function get %s() : %s { return $%s; }" rights id t id; newline ctx - | AccCall m -> - print ctx "%s function get %s() : %s { return %s(); }" rights id t m; + | AccCall -> + print ctx "%s function get %s() : %s { return %s(); }" rights id t ("get_" ^ f.cf_name); newline ctx - | AccNo | AccNever -> - print ctx "%s function get %s() : %s { return $%s; }" (if v.v_read = AccNo then "protected" else "private") id t id; - newline ctx - | _ -> - ()); + | _ -> ()); (match v.v_write with - | AccNormal -> + | AccNormal | AccNo | AccNever -> print ctx "%s function set %s( __v : %s ) : void { $%s = __v; }" rights id t id; newline ctx - | AccCall m -> - print ctx "%s function set %s( __v : %s ) : void { %s(__v); }" rights id t m; - newline ctx - | AccNo | AccNever -> - print ctx "%s function set %s( __v : %s ) : void { $%s = __v; }" (if v.v_write = AccNo then "protected" else "private") id t id; + | AccCall -> + print ctx "%s function set %s( __v : %s ) : void { %s(__v); }" rights id t ("set_" ^ f.cf_name); newline ctx | _ -> ()); - print ctx "protected var $%s : %s" (s_ident f.cf_name) (type_str ctx f.cf_type p); + print ctx "%sprotected var $%s : %s" (if static then "static " else "") (s_ident f.cf_name) (type_str ctx f.cf_type p); + gen_init() end else begin print ctx "%s var %s : %s" rights (s_ident f.cf_name) (type_str ctx f.cf_type p); - match f.cf_expr with - | None -> () - | Some e -> - print ctx " = "; - gen_value ctx e + gen_init() end let rec define_getset ctx stat c = @@ -941,22 +1063,21 @@ let rec define_getset ctx stat c = match f.cf_kind with | Method _ -> () | Var v -> - (match v.v_read with AccCall m -> def f m | _ -> ()); - (match v.v_write with AccCall m -> def f m | _ -> ()) + (match v.v_read with AccCall -> def f ("get_" ^ f.cf_name) | _ -> ()); + (match v.v_write with AccCall -> def f ("set_" ^ f.cf_name) | _ -> ()) in List.iter field (if stat then c.cl_ordered_statics else c.cl_ordered_fields); match c.cl_super with | Some (c,_) when not stat -> define_getset ctx stat c | _ -> () - let generate_class ctx c = ctx.curclass <- c; define_getset ctx true c; define_getset ctx false c; ctx.local_types <- List.map snd c.cl_types; let pack = open_block ctx in - print ctx "\tpublic %s%s %s " (match c.cl_dynamic with None -> "" | Some _ -> if c.cl_interface then "" else "dynamic ") (if c.cl_interface then "interface" else "class") (snd c.cl_path); + print ctx "\tpublic %s%s%s %s " (final c.cl_meta) (match c.cl_dynamic with None -> "" | Some _ -> if c.cl_interface then "" else "dynamic ") (if c.cl_interface then "interface" else "class") (snd c.cl_path); (match c.cl_super with | None -> () | Some (csup,_) -> print ctx "extends %s " (s_path ctx true csup.cl_path c.cl_pos)); @@ -1018,7 +1139,7 @@ let generate_enum ctx e = ctx.local_types <- List.map snd e.e_types; let pack = open_block ctx in let ename = snd e.e_path in - print ctx "\tpublic class %s extends enum {" ename; + print ctx "\tpublic final class %s extends enum {" ename; let cl = open_block ctx in newline ctx; print ctx "public static const __isenum : Boolean = true"; @@ -1047,7 +1168,7 @@ let generate_enum ctx e = print ctx "public static var __meta__ : * = "; gen_expr ctx e; newline ctx); - print ctx "public static var __constructs__ : Array = [%s];" (String.concat "," (List.map (fun s -> "\"" ^ Ast.s_escape s ^ "\"") e.e_names)); + print ctx "public static var __constructs__ : Array = [%s];" (String.concat "," (List.map (fun s -> "\"" ^ Ast.s_escape s ^ "\"") e.e_names)); cl(); newline ctx; print ctx "}"; @@ -1058,7 +1179,9 @@ let generate_enum ctx e = let generate_base_enum ctx = let pack = open_block ctx in - spr ctx "\tpublic class enum {"; + spr ctx "\timport flash.Boot"; + newline ctx; + spr ctx "public class enum {"; let cl = open_block ctx in newline ctx; spr ctx "public var tag : String"; @@ -1066,6 +1189,8 @@ let generate_base_enum ctx = spr ctx "public var index : int"; newline ctx; spr ctx "public var params : Array"; + newline ctx; + spr ctx "public function toString() : String { return flash.Boot.enum_to_string(this); }"; cl(); newline ctx; print ctx "}"; @@ -1078,6 +1203,7 @@ let generate com = let infos = { com = com; } in + generate_resources infos; let ctx = init infos ([],"enum") in generate_base_enum ctx; close ctx; @@ -1101,13 +1227,13 @@ let generate com = | TEnumDecl e -> let pack,name = e.e_path in let e = { e with e_path = (pack,protect name) } in - if e.e_extern && e.e_path <> ([],"Void") then + if e.e_extern then () else let ctx = init infos e.e_path in generate_enum ctx e; close ctx - | TTypeDecl t -> + | TTypeDecl _ | TAbstractDecl _ -> () ) com.types; (match com.main with diff --git a/gencommon.ml b/gencommon.ml new file mode 100644 index 0000000000000000000000000000000000000000..ea5f74f43bba3d3d31a6893215a598bbf7bdd594 --- /dev/null +++ b/gencommon.ml @@ -0,0 +1,10282 @@ +(* + * 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. + *) + +(* + Gen Common API + + This module intends to be a common set of utilities common to all targets. + + It's intended to provide a set of tools to be able to make targets in haXe more easily, and to + allow the programmer to have more control of how the target language will handle the program. + + For example, as of now, the hxcpp target, while greatly done, relies heavily on cpp's own operator + overloading, and implicit conversions, which make it very hard to deliver a similar solution for languages + that lack these features. + + So this little framework is here so you can manipulate the HaXe AST and start bringing the AST closer + to how it's intenteded to be in your host language. + + Rules + + Design goals + + Naming convention + + Weaknesses and TODO's +*) + +open Ast +open Type +open Common +open Option +open Printf + +let debug_type_ctor = function + | TMono _ -> "TMono" + | TEnum _ -> "TEnum" + | TInst _ -> "TInst" + | TType _ -> "TType" + | TFun _ -> "TFun" + | TAnon _ -> "TAnon" + | TDynamic _ -> "TDynamic" + | TLazy _ -> "TLazy" + | TAbstract _ -> "TAbstract" + +let debug_type = (s_type (print_context())) + +let debug_expr = s_expr debug_type + +let rec like_float t = + match follow t with + | TAbstract({ a_path = ([], "Float") },[]) + | TAbstract({ a_path = ([], "Int") },[]) -> true + | TAbstract(a, _) -> List.exists (fun (t,_) -> like_float t) a.a_from || List.exists (fun (t,_) -> like_float t) a.a_to + | _ -> false + +let rec like_int t = + match follow t with + | TAbstract({ a_path = ([], "Int") },[]) -> true + | TAbstract(a, _) -> List.exists (fun (t,_) -> like_int t) a.a_from || List.exists (fun (t,_) -> like_float t) a.a_to + | _ -> false + + +let follow_once t = + match t with + | TMono r -> + (match !r with + | Some t -> t + | _ -> t_dynamic (* avoid infinite loop / should be the same in this context *)) + | TLazy f -> + !f() + | TType (t,tl) -> + apply_params t.t_types tl t.t_type + | _ -> t + +let t_empty = TAnon({ a_fields = PMap.empty; a_status = ref (Closed) }) + +(* the undefined is a special var that works like null, but can have special meaning *) +let v_undefined = alloc_var "__undefined__" t_dynamic + +let undefined pos = { eexpr = TLocal(v_undefined); etype = t_dynamic; epos = pos } + +module ExprHashtblHelper = +struct + type hash_texpr_t = + { + hepos : pos; + heexpr : int; + hetype : int; + } + + let mk_heexpr = function + | TConst _ -> 0 | TLocal _ -> 1 | TArray _ -> 3 | TBinop _ -> 4 | TField _ -> 5 | TTypeExpr _ -> 7 | TParenthesis _ -> 8 | TObjectDecl _ -> 9 + | TArrayDecl _ -> 10 | TCall _ -> 11 | TNew _ -> 12 | TUnop _ -> 13 | TFunction _ -> 14 | TVars _ -> 15 | TBlock _ -> 16 | TFor _ -> 17 | TIf _ -> 18 | TWhile _ -> 19 + | TSwitch _ -> 20 | TMatch _ -> 21 | TTry _ -> 22 | TReturn _ -> 23 | TBreak -> 24 | TContinue -> 25 | TThrow _ -> 26 | TCast _ -> 27 + + let mk_heetype = function + | TMono _ -> 0 | TEnum _ -> 1 | TInst _ -> 2 | TType _ -> 3 | TFun _ -> 4 + | TAnon _ -> 5 | TDynamic _ -> 6 | TLazy _ -> 7 | TAbstract _ -> 8 + + let mk_type e = + { + hepos = e.epos; + heexpr = mk_heexpr e.eexpr; + hetype = mk_heetype e.etype; + } +end;; + +open ExprHashtblHelper;; +(* Expression Hashtbl. This shouldn't be kept indefinately as it's not a weak Hashtbl. *) +module ExprHashtbl = Hashtbl.Make( + struct + type t = Type.texpr + + let equal = (==) + let hash t = Hashtbl.hash (mk_type t) + end +);; + +(* ******************************************* *) +(* Gen Common + +This is the key module for generation of Java and C# sources +In order for both modules to share as much code as possible, some +rules were devised: + +- every feature has its own submodule, and may contain the following methods: + - configure + sets all the configuration variables for the module to run. If a module has this method, + it *should* be called once before running any filter + - run_filter -> + runs the filter immediately on the context + - add_filter -> + adds the filter to an expr->expr list. Most filter modules will provide this option so the filter + function can only run once. +- most submodules will have side-effects so the order of operations will matter. + When running configure / add_filter this might be taken care of with the rule-based dispatch system working + underneath, but still there might be some incompatibilities. There will be an effort to document it. + The modules can hint on the order by suffixing their functions with _first or _last. +- any of those methods might have different parameters, that configure how the filter will run. + For example, a simple filter that maps switch() expressions to if () .. else if... might receive + a function that filters what content should be mapped +- Other targets can use those filters on their own code. In order to do that, + a simple configuration step is needed: you need to initialize a generator_ctx type with + Gencommon.new_gen (context:Common.context) + with a generator_ctx context you will be able to add filters to your code, and execute them with + Gencommon.run_filters (gen_context:Gencommon.generator_ctx) + + After running the filters, you can run your own generator normally. + + (* , or you can run + Gencommon.generate_modules (gen_context:Gencommon.generator_ctx) (extension:string) (module_gen:module_type list->bool) + where module_gen will take a whole module (can be *) + +*) + +(* ******************************************* *) +(* common helpers *) +(* ******************************************* *) + +let assertions = false (* when assertions == true, many assertions will be made to guarantee the quality of the data input *) +let debug_mode = ref false +let trace s = if !debug_mode then print_endline s else () +let timer name = if !debug_mode then Common.timer name else fun () -> () + +let is_string t = match follow t with | TInst({ cl_path = ([], "String") }, []) -> true | _ -> false + +(* helper function for creating Anon types of class / enum modules *) + +let anon_of_classtype cl = + TAnon { + a_fields = cl.cl_statics; + a_status = ref (Statics cl) + } + +let anon_of_enum e = + TAnon { + a_fields = PMap.empty; + a_status = ref (EnumStatics e) + } + +let anon_of_abstract a = + TAnon { + a_fields = PMap.empty; + a_status = ref (AbstractStatics a) + } + +let anon_of_mt mt = match mt with + | TClassDecl cl -> anon_of_classtype cl + | TEnumDecl e -> anon_of_enum e + | TAbstractDecl a -> anon_of_abstract a + | _ -> assert false + +let anon_class t = + match follow t with + | TAnon anon -> + (match !(anon.a_status) with + | Statics (cl) -> Some(TClassDecl(cl)) + | EnumStatics (e) -> Some(TEnumDecl(e)) + | AbstractStatics (a) -> Some(TAbstractDecl(a)) + | _ -> None) + | _ -> None + +let path_s path = + match path with | ([], s) -> s | (p, s) -> (String.concat "." (fst path)) ^ "." ^ (snd path) + + let rec t_to_md t = match t with + | TInst (cl,_) -> TClassDecl cl + | TEnum (e,_) -> TEnumDecl e + | TType (t,_) -> TTypeDecl t + | TAbstract (a,_) -> TAbstractDecl a + | TAnon anon -> + (match !(anon.a_status) with + | EnumStatics e -> TEnumDecl e + | Statics cl -> TClassDecl cl + | AbstractStatics a -> TAbstractDecl a + | _ -> assert false) + | TLazy f -> t_to_md (!f()) + | TMono r -> (match !r with | Some t -> t_to_md t | None -> assert false) + | _ -> assert false + +let get_cl mt = match mt with | TClassDecl cl -> cl | _ -> failwith ("Unexpected module type of '" ^ path_s (t_path mt) ^ "'") + +let get_tdef mt = match mt with | TTypeDecl t -> t | _ -> assert false + +let mk_mt_access mt pos = { eexpr = TTypeExpr(mt); etype = anon_of_mt mt; epos = pos } + +let is_void t = match follow t with + | TEnum({ e_path = ([], "Void") }, []) + | TAbstract ({ a_path = ([], "Void") },[]) -> + true + | _ -> false + +let mk_local var pos = { eexpr = TLocal(var); etype = var.v_type; epos = pos } + +(* this function is used by CastDetection module *) +let get_fun t = + match follow t with | TFun(r1,r2) -> (r1,r2) | _ -> (trace (s_type (print_context()) (follow t) )); assert false + +let mk_cast t e = + { eexpr = TCast(e, None); etype = t; epos = e.epos } + +let mk_classtype_access cl pos = + { eexpr = TTypeExpr(TClassDecl(cl)); etype = anon_of_classtype cl; epos = pos } + +let mk_static_field_access_infer cl field pos params = + try + let cf = (PMap.find field cl.cl_statics) in + { eexpr = TField(mk_classtype_access cl pos, FStatic(cl, cf)); etype = (if params = [] then cf.cf_type else apply_params cf.cf_params params cf.cf_type); epos = pos } + with | Not_found -> failwith ("Cannot find field " ^ field ^ " in type " ^ (path_s cl.cl_path)) + +let mk_static_field_access cl field fieldt pos = + { (mk_static_field_access_infer cl field pos []) with etype = fieldt } + +(* stolen from Hugh's sources ;-) *) +(* this used to be a class, but there was something in there that crashed ocaml native compiler in windows *) +module SourceWriter = +struct + + type source_writer = + { + sw_buf : Buffer.t; + mutable sw_has_content : bool; + mutable sw_indent : string; + mutable sw_indents : string list; + } + + let new_source_writer () = + { + sw_buf = Buffer.create 0; + sw_has_content = false; + sw_indent = ""; + sw_indents = []; + } + + let add_writer w_write w_read = Buffer.add_buffer w_read.sw_buf w_write.sw_buf + + let contents w = Buffer.contents w.sw_buf + + let len w = Buffer.length w.sw_buf + + let write w x = + (if not w.sw_has_content then begin w.sw_has_content <- true; Buffer.add_string w.sw_buf w.sw_indent; Buffer.add_string w.sw_buf x; end else Buffer.add_string w.sw_buf x); + let len = (String.length x)-1 in + if len >= 0 && String.get x len = '\n' then begin w.sw_has_content <- false end else w.sw_has_content <- true + + let push_indent w = w.sw_indents <- "\t"::w.sw_indents; w.sw_indent <- String.concat "" w.sw_indents + + let pop_indent w = + match w.sw_indents with + | h::tail -> w.sw_indents <- tail; w.sw_indent <- String.concat "" w.sw_indents + | [] -> w.sw_indent <- "/*?*/" + + let newline w = write w "\n" + + let begin_block w = (if w.sw_has_content then newline w); write w "{"; push_indent w; newline w + + let end_block w = pop_indent w; (if w.sw_has_content then newline w); write w "}"; newline w + + let print w = + (if not w.sw_has_content then begin w.sw_has_content <- true; Buffer.add_string w.sw_buf w.sw_indent end); + bprintf w.sw_buf; + +end;; + +(* rule_dispatcher's priority *) +type priority = + | PFirst + | PLast + | PZero + | PCustom of float + +exception DuplicateName of string +exception NoRulesApplied + +let indent = ref [] + +(* the rule dispatcher is the primary way to deal with distributed "plugins" *) +(* we will define rules that will form a distributed / extensible match system *) +class ['tp, 'ret] rule_dispatcher name ignore_not_found = + object(self) + val tbl = Hashtbl.create 16 + val mutable keys = [] + val names = Hashtbl.create 16 + val mutable temp = 0 + + method add ?(name : string option) (* name helps debugging *) ?(priority : priority = PZero) (rule : 'tp->'ret option) = + let p = match priority with + | PFirst -> infinity + | PLast -> neg_infinity + | PZero -> 0.0 + | PCustom i -> i + in + + let q = if not( Hashtbl.mem tbl p ) then begin + let q = Stack.create() in + Hashtbl.add tbl p q; + keys <- p :: keys; + keys <- List.sort (fun x y -> - (compare x y)) keys; + q + end else Hashtbl.find tbl p in + let name = match name with + | None -> temp <- temp + 1; "$_" ^ (string_of_int temp) + | Some s -> s + in + (if Hashtbl.mem names name then raise (DuplicateName(name))); + Hashtbl.add names name q; + + Stack.push (name, rule) q + + method describe = + Hashtbl.iter (fun s _ -> (trace s)) names; + + method remove (name : string) = + if Hashtbl.mem names name then begin + let q = Hashtbl.find names name in + let q_temp = Stack.create () in + Stack.iter (function + | (n, _) when n = name -> () + | _ as r -> Stack.push r q_temp + ) q; + + Stack.clear q; + Stack.iter (fun r -> Stack.push r q) q_temp; + + Hashtbl.remove names name; + true + end else false + + method run_f tp = get (self#run tp) + + method did_run tp = is_some (self#run tp) + + method get_list = + let ret = ref [] in + List.iter (fun key -> + let q = Hashtbl.find tbl key in + Stack.iter (fun (_, rule) -> ret := rule :: !ret) q + ) keys; + + List.rev !ret + + method run_from (priority:float) (tp:'tp) : 'ret option = + let ok = ref ignore_not_found in + let ret = ref None in + indent := "\t" :: !indent; + + (try begin + List.iter (fun key -> + if key < priority then begin + let q = Hashtbl.find tbl key in + Stack.iter (fun (n, rule) -> + let t = if !debug_mode then Common.timer ("rule dispatcher rule: " ^ n) else fun () -> () in + let r = rule(tp) in + t(); + if is_some r then begin ret := r; raise Exit end + ) q + end + ) keys + + end with Exit -> ok := true); + + (match !indent with + | [] -> () + | h::t -> indent := t); + + (if not (!ok) then raise NoRulesApplied); + !ret + + method run (tp:'tp) : 'ret option = + self#run_from infinity tp + +end;; + +(* this is a special case where tp = tret and you stack their output as the next's input *) +class ['tp] rule_map_dispatcher name = + object(self) + inherit ['tp, 'tp] rule_dispatcher name true as super + + method run_f tp = get (self#run tp) + + method run_from (priority:float) (tp:'tp) : 'ret option = + let cur = ref tp in + (try begin + List.iter (fun key -> + + if key < priority then begin + let q = Hashtbl.find tbl key in + Stack.iter (fun (n, rule) -> + trace ("running rule " ^ n); + let t = if !debug_mode then Common.timer ("rule map dispatcher rule: " ^ n) else fun () -> () in + let r = rule(!cur) in + t(); + if is_some r then begin cur := get r end + ) q + end + ) keys + + end with Exit -> ()); + Some (!cur) + +end;; + + +type generator_ctx = +{ + (* these are the basic context fields. If another target is using this context, *) + (* this is all you need to care about *) + mutable gcon : Common.context; + + gclasses : gen_classes; + + gtools : gen_tools; + + (* + configurable function that receives a desired name and makes it "internal", doing the best + to ensure that it will not be called from outside. + To avoid name clashes between internal names, user must specify two strings: a "namespace" and the name itself + *) + mutable gmk_internal_name : string->string->string; + + (* + module filters run before module filters and they should generate valid haxe syntax as a result. + Module filters shouldn't go through the expressions as it adds an unnecessary burden to the GC, + and it can all be done in a single step with gexpr_filters and proper priority selection. + + As a convention, Module filters should end their name with Modf, so they aren't mistaken with expression filters + *) + gmodule_filters : (module_type) rule_map_dispatcher; + + (* + expression filters are the most common filters to be applied. + They should also generate only valid haxe expressions, so e.g. calls to non-existant methods + should be avoided, although there are some ways around them (like gspecial_methods) + *) + gexpr_filters : (texpr) rule_map_dispatcher; + (* + syntax filters are also expression filters but they no longer require + that the resulting expressions be valid haxe expressions. + They then have no guarantee that either the input expressions or the output one follow the same + rules as normal haxe code. + *) + gsyntax_filters : (texpr) rule_map_dispatcher; + + (* these are more advanced features, but they would require a rewrite of targets *) + (* they are just helpers to ditribute functions like "follow" or "type to string" *) + (* so adding a module will already take care of correctly following a certain type of *) + (* variable, for example *) + + (* follows the type through typedefs, lazy typing, etc. *) + (* it's the place to put specific rules to handle typedefs, like *) + (* other basic types like UInt *) + gfollow : (t, t) rule_dispatcher; + + gtypes : (path, module_type) Hashtbl.t; + + (* cast detection helpers / settings *) + (* this is a cache for all field access types *) + greal_field_types : (path * string, (tclass_field (* does the cf exist *) * t (*cf's type in relation to current class type params *) * t * tclass (* declared class *) ) option) Hashtbl.t; + (* this function allows any code to handle casts as if it were inside the cast_detect module *) + mutable ghandle_cast : t->t->texpr->texpr; + (* when an unsafe cast is made, we can warn the user *) + mutable gon_unsafe_cast : t->t->pos->unit; + (* does this type needs to be boxed? Normally always false, unless special type handling must be made *) + mutable gneeds_box : t->bool; + (* does this 'special type' needs cast to this other type? *) + (* this is here so we can implement custom behavior for "opaque" typedefs *) + mutable gspecial_needs_cast : t->t->bool; + (* sometimes we may want to support unrelated conversions on cast detection *) + (* for example, haxe.lang.Null -> T on C# *) + (* every time an unrelated conversion is found, each to/from path is searched on this hashtbl *) + (* if found, the function will be executed with from_type, to_type. If returns true, it means that *) + (* it is a supported conversion, and the unsafe cast routine changes to a simple cast *) + gsupported_conversions : (path, t->t->bool) Hashtbl.t; + + (* API for filters *) + (* add type can be called at any time, and will add a new module_def that may or may not be filtered *) + (* module_type -> should_filter *) + mutable gadd_type : module_type -> bool -> unit; + (* during expr filters, add_to_module will be available so module_types can be added to current module_def. we must pass the priority argument so the filters can be resumed *) + mutable gadd_to_module : module_type -> float -> unit; + (* during expr filters, shows the current class path *) + mutable gcurrent_path : path; + (* current class *) + mutable gcurrent_class : tclass option; + (* current class field, if any *) + mutable gcurrent_classfield : tclass_field option; + + (* events *) + (* is executed once every new classfield *) + mutable gon_classfield_start : (unit -> unit) list; + (* is executed once every new module type *) + mutable gon_new_module_type : (unit -> unit) list; + (* after module filters ended *) + mutable gafter_mod_filters_ended : (unit -> unit) list; + (* after expression filters ended *) + mutable gafter_expr_filters_ended : (unit -> unit) list; + (* after all filters are run *) + mutable gafter_filters_ended : (unit -> unit) list; + + mutable gbase_class_fields : (string, tclass_field) PMap.t; + + (* real type is the type as it is read by the target. *) + (* This function is here because most targets don't have *) + (* a 1:1 translation between haxe types and its native types *) + (* But types aren't changed to this representation as we might lose *) + (* some valuable type information in the process *) + mutable greal_type : t -> t; + (* + the same as greal_type but for type parameters. + *) + mutable greal_type_param : module_type -> tparams -> tparams; + (* + is the type a value type? + This may be used in some optimizations where reference types and value types + are handled differently. At first the default is very good to use, and if tweaks are needed, + it's best to be done by adding @:struct meta to the value types + * + mutable gis_value_type : t -> bool;*) + + (* misc configuration *) + (* + Should the target allow type parameter dynamic conversion, + or should we add a cast to those cases as well? + *) + mutable gallow_tp_dynamic_conversion : bool; + + (* + Does the target support type parameter constraints? + If not, they will be ignored when detecting casts + *) + mutable guse_tp_constraints : bool; + + (* internal apis *) + (* param_func_call : used by TypeParams and CastDetection *) + mutable gparam_func_call : texpr->texpr->tparams->texpr list->texpr; + (* does it already have a type parameter cast handler? This is used by CastDetect to know if it should handle type parameter casts *) + mutable ghas_tparam_cast_handler : bool; + (* type parameter casts - special cases *) + (* function cast_from, cast_to -> texpr *) + gtparam_cast : (path, (texpr->t->texpr)) Hashtbl.t; + + (* + special vars are used for adding special behavior to + *) + gspecial_vars : (string, bool) Hashtbl.t; +} + +and gen_classes = +{ + cl_reflect : tclass; + cl_type : tclass; + cl_dyn : tclass; + + t_iterator : tdef; +} + +(* add here all reflection transformation additions *) +and gen_tools = +{ + (* (klass : texpr, t : t) : texpr *) + mutable r_create_empty : texpr->t->texpr; + (* Reflect.fields(). The bool is if we are iterating in a read-only manner. If it is read-only we might not need to allocate a new array *) + mutable r_fields : bool->texpr->texpr; + (* (first argument = return type. should be void in most cases) Reflect.setField(obj, field, val) *) + mutable r_set_field : t->texpr->texpr->texpr->texpr; + (* Reflect.field. bool indicates if is safe (no error throwing) or unsafe; t is the expected return type true = safe *) + mutable r_field : bool->t->texpr->texpr->texpr; + + (* + these are now the functions that will later be used when creating the reflection classes + *) + + (* on the default implementation (at OverloadingCtors), it will be new SomeClass(EmptyInstance) *) + mutable rf_create_empty : tclass->tparams->pos->texpr; +} + +let get_type types path = + List.find (fun md -> match md with + | TClassDecl cl when cl.cl_path = path -> true + | TEnumDecl e when e.e_path = path -> true + | TTypeDecl t when t.t_path = path -> true + | TAbstractDecl a when a.a_path = path -> true + | _ -> false + ) types + +let new_ctx con = + let types = Hashtbl.create (List.length con.types) in + List.iter (fun mt -> + match mt with + | TClassDecl cl -> Hashtbl.add types cl.cl_path mt + | TEnumDecl e -> Hashtbl.add types e.e_path mt + | TTypeDecl t -> Hashtbl.add types t.t_path mt + | TAbstractDecl a -> Hashtbl.add types a.a_path mt + ) con.types; + + let cl_dyn = match get_type con.types ([], "Dynamic") with + | TClassDecl c -> c + | TAbstractDecl a -> + mk_class a.a_module ([], "Dynamic") a.a_pos + | _ -> assert false + in + + let rec gen = { + gcon = con; + gclasses = { + cl_reflect = get_cl (get_type con.types ([], "Reflect")); + cl_type = get_cl (get_type con.types ([], "Type")); + cl_dyn = cl_dyn; + + t_iterator = get_tdef (get_type con.types ([], "Iterator")); + }; + gtools = { + r_create_empty = (fun eclass t -> + let fieldcall = mk_static_field_access_infer gen.gclasses.cl_type "createEmptyInstance" eclass.epos [t] in + { eexpr = TCall(fieldcall, [eclass]); etype = t; epos = eclass.epos } + ); + r_fields = (fun is_used_only_by_iteration expr -> + let fieldcall = mk_static_field_access_infer gen.gclasses.cl_reflect "fields" expr.epos [] in + { eexpr = TCall(fieldcall, [expr]); etype = gen.gcon.basic.tarray gen.gcon.basic.tstring; epos = expr.epos } + ); + (* Reflect.setField(obj, field, val). t by now is ignored. FIXME : fix this implementation *) + r_set_field = (fun t obj field v -> + let fieldcall = mk_static_field_access_infer gen.gclasses.cl_reflect "setField" v.epos [] in + { eexpr = TCall(fieldcall, [obj; field; v]); etype = t_dynamic; epos = v.epos } + ); + (* Reflect.field. bool indicates if is safe (no error throwing) or unsafe. true = safe *) + r_field = (fun is_safe t obj field -> + let fieldcall = mk_static_field_access_infer gen.gclasses.cl_reflect "field" obj.epos [] in + (* FIXME: should we see if needs to cast? *) + mk_cast t { eexpr = TCall(fieldcall, [obj; field]); etype = t_dynamic; epos = obj.epos } + ); + + rf_create_empty = (fun cl p pos -> + gen.gtools.r_create_empty { eexpr = TTypeExpr(TClassDecl cl); epos = pos; etype = t_dynamic } (TInst(cl,p)) + ); (* TODO: Maybe implement using normal reflection? Type.createEmpty(MyClass) *) + }; + gmk_internal_name = (fun ns s -> sprintf "__%s_%s" ns s); + gexpr_filters = new rule_map_dispatcher "gexpr_filters"; + gmodule_filters = new rule_map_dispatcher "gmodule_filters"; + gsyntax_filters = new rule_map_dispatcher "gsyntax_filters"; + gfollow = new rule_dispatcher "gfollow" false; + gtypes = types; + + greal_field_types = Hashtbl.create 0; + ghandle_cast = (fun to_t from_t e -> mk_cast to_t e); + gon_unsafe_cast = (fun t t2 pos -> (gen.gcon.warning ("Type " ^ (debug_type t2) ^ " is being cast to the unrelated type " ^ (s_type (print_context()) t)) pos)); + gneeds_box = (fun t -> false); + gspecial_needs_cast = (fun to_t from_t -> true); + gsupported_conversions = Hashtbl.create 0; + + gadd_type = (fun md should_filter -> + if should_filter then begin + con.types <- md :: con.types; + con.modules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake } :: con.modules + end else gen.gafter_filters_ended <- (fun () -> + con.types <- md :: con.types; + con.modules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake } :: con.modules + ) :: gen.gafter_filters_ended; + ); + gadd_to_module = (fun md pr -> failwith "module added outside expr filters"); + gcurrent_path = ([],""); + gcurrent_class = None; + gcurrent_classfield = None; + + gon_classfield_start = []; + gon_new_module_type = []; + gafter_mod_filters_ended = []; + gafter_expr_filters_ended = []; + gafter_filters_ended = []; + + gbase_class_fields = PMap.empty; + + greal_type = (fun t -> t); + greal_type_param = (fun _ t -> t); + + gallow_tp_dynamic_conversion = false; + + guse_tp_constraints = false; + + (* as a default, ignore the params *) + gparam_func_call = (fun ecall efield params elist -> { ecall with eexpr = TCall(efield, elist) }); + ghas_tparam_cast_handler = false; + gtparam_cast = Hashtbl.create 0; + + gspecial_vars = Hashtbl.create 0; + } in + + (*gen.gtools.r_create_empty <- + gen.gtools.r_get_class <- + gen.gtools.r_fields <- *) + + gen + +let init_ctx gen = + (* ultimately add a follow once handler as the last follow handler *) + let follow_f = gen.gfollow#run in + let follow t = + match t with + | TMono r -> + (match !r with + | Some t -> follow_f t + | _ -> Some t) + | TLazy f -> + follow_f (!f()) + | TType (t,tl) -> + follow_f (apply_params t.t_types tl t.t_type) + | _ -> Some t + in + gen.gfollow#add ~name:"final" ~priority:PLast follow + +(* run_follow (gen:generator_ctx) (t:t) *) +let run_follow gen = gen.gfollow#run_f + +let reorder_modules gen = + let modules = Hashtbl.create 20 in + List.iter (fun md -> + Hashtbl.add modules ( (t_infos md).mt_module ).m_path md + ) gen.gcon.types; + + let con = gen.gcon in + con.modules <- []; + let processed = Hashtbl.create 20 in + Hashtbl.iter (fun md_path _ -> + if not (Hashtbl.mem processed md_path) then begin + Hashtbl.add processed md_path true; + con.modules <- { m_id = alloc_mid(); m_path = md_path; m_types = List.rev ( Hashtbl.find_all modules md_path ); m_extra = module_extra "" "" 0. MFake } :: con.modules + end + ) modules + +let run_filters_from gen t filters = + match t with + | TClassDecl c -> + trace (snd c.cl_path); + gen.gcurrent_path <- c.cl_path; + gen.gcurrent_class <- Some(c); + + List.iter (fun fn -> fn()) gen.gon_new_module_type; + + gen.gcurrent_classfield <- None; + let rec process_field f = + gen.gcurrent_classfield <- Some(f); + List.iter (fun fn -> fn()) gen.gon_classfield_start; + + trace f.cf_name; + (match f.cf_expr with + | None -> () + | Some e -> + f.cf_expr <- Some (List.fold_left (fun e f -> f e) e filters)); + List.iter process_field f.cf_overloads; + in + List.iter process_field c.cl_ordered_fields; + List.iter process_field c.cl_ordered_statics; + + gen.gcurrent_classfield <- None; + (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 run_filters gen = + (* first of all, we have to make sure that the filters won't trigger a major Gc collection *) + let t = Common.timer "gencommon_filters" in + (if Common.defined gen.gcon Define.GencommonDebug then debug_mode := true); + let run_filters filter = + let rec loop acc mds = + match mds with + | [] -> acc + | md :: tl -> + let filters = [ filter#run_f ] in + let added_types = ref [] in + gen.gadd_to_module <- (fun md_type priority -> + gen.gcon.types <- md_type :: gen.gcon.types; + added_types := (md_type, priority) :: !added_types + ); + + run_filters_from gen md filters; + + let added_types = List.map (fun (t,p) -> + run_filters_from gen t [ fun e -> get (filter#run_from p e) ]; + if Hashtbl.mem gen.gtypes (t_path t) then begin + let rec loop i = + let p = t_path t in + let new_p = (fst p, snd p ^ "_" ^ (string_of_int i)) in + if Hashtbl.mem gen.gtypes new_p then + loop (i+1) + else + match t with + | TClassDecl cl -> cl.cl_path <- new_p + | TEnumDecl e -> e.e_path <- new_p + | TTypeDecl _ | TAbstractDecl _ -> () + in + loop 0 + end; + Hashtbl.add gen.gtypes (t_path t) t; + t + ) !added_types in + + loop (added_types @ (md :: acc)) tl + in + List.rev (loop [] gen.gcon.types) + in + + let run_mod_filter filter = + let last_add_to_module = gen.gadd_to_module in + let added_types = ref [] in + gen.gadd_to_module <- (fun md_type priority -> + Hashtbl.add gen.gtypes (t_path md_type) md_type; + added_types := (md_type, priority) :: !added_types + ); + + let rec loop processed not_processed = + match not_processed with + | hd :: tl -> + let new_hd = filter#run_f hd in + + let added_types_new = !added_types in + added_types := []; + let added_types = List.map (fun (t,p) -> + get (filter#run_from p t) + ) added_types_new in + + loop ( added_types @ (new_hd :: processed) ) tl + | [] -> + processed + in + + let filtered = loop [] gen.gcon.types in + gen.gadd_to_module <- last_add_to_module; + gen.gcon.types <- List.rev (filtered) + in + + run_mod_filter gen.gmodule_filters; + List.iter (fun fn -> fn()) gen.gafter_mod_filters_ended; + + let last_add_to_module = gen.gadd_to_module in + gen.gcon.types <- run_filters gen.gexpr_filters; + gen.gadd_to_module <- last_add_to_module; + + List.iter (fun fn -> fn()) gen.gafter_expr_filters_ended; + (* Codegen.post_process gen.gcon.types [gen.gexpr_filters#run_f]; *) + gen.gcon.types <- run_filters gen.gsyntax_filters; + List.iter (fun fn -> fn()) gen.gafter_filters_ended; + + reorder_modules gen; + t() + +(* ******************************************* *) +(* basic generation module that source code compilation implementations can use *) +(* ******************************************* *) + +let write_file gen w source_dir path extension = + let t = timer "write file" in + let s_path = gen.gcon.file ^ "/" ^ source_dir ^ "/" ^ (String.concat "/" (fst path)) ^ "/" ^ (snd path) ^ "." ^ (extension) in + (* create the folders if they don't exist *) + 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 + let p = gen.gcon.file :: source_dir :: fst path in + create [] p; + + let contents = SourceWriter.contents w in + let should_write = if not (Common.defined gen.gcon Define.ReplaceFiles) && Sys.file_exists s_path then begin + let in_file = open_in s_path in + let old_contents = Std.input_all in_file in + close_in in_file; + contents <> old_contents + end else true in + + if should_write then begin + let f = open_out s_path in + output_string f contents; + close_out f + end; + t() + +let dump_descriptor gen name path_s module_s = + let w = SourceWriter.new_source_writer () in + (* dump called path *) + SourceWriter.write w (Sys.getcwd()); + SourceWriter.newline w; + (* dump all defines. deprecated *) + SourceWriter.write w "begin defines"; + SourceWriter.newline w; + PMap.iter (fun name _ -> + SourceWriter.write w name; + SourceWriter.newline w + ) gen.gcon.defines; + SourceWriter.write w "end defines"; + SourceWriter.newline w; + (* dump all defines with their values; keeping the old defines for compatibility *) + SourceWriter.write w "begin defines_data"; + SourceWriter.newline w; + PMap.iter (fun name v -> + SourceWriter.write w name; + SourceWriter.write w "="; + SourceWriter.write w v; + SourceWriter.newline w + ) gen.gcon.defines; + SourceWriter.write w "end defines_data"; + SourceWriter.newline w; + (* dump all generated types *) + SourceWriter.write w "begin modules"; + SourceWriter.newline w; + let main_paths = Hashtbl.create 0 in + List.iter (fun md_def -> + SourceWriter.write w "M "; + SourceWriter.write w (path_s md_def.m_path); + SourceWriter.newline w; + List.iter (fun m -> + match m with + | TClassDecl cl when not cl.cl_extern -> + SourceWriter.write w "C "; + let s = module_s m in + Hashtbl.add main_paths cl.cl_path s; + SourceWriter.write w (s); + SourceWriter.newline w + | TEnumDecl e when not e.e_extern -> + SourceWriter.write w "E "; + SourceWriter.write w (module_s m); + SourceWriter.newline w + | _ -> () (* still no typedef or abstract is generated *) + ) md_def.m_types + ) gen.gcon.modules; + SourceWriter.write w "end modules"; + SourceWriter.newline w; + (* dump all resources *) + (match gen.gcon.main_class with + | Some path -> + SourceWriter.write w "begin main"; + SourceWriter.newline w; + (try + SourceWriter.write w (Hashtbl.find main_paths path) + with + | Not_found -> SourceWriter.write w (path_s path)); + SourceWriter.newline w; + SourceWriter.write w "end main"; + SourceWriter.newline w + | _ -> () + ); + SourceWriter.write w "begin resources"; + SourceWriter.newline w; + Hashtbl.iter (fun name _ -> + SourceWriter.write w name; + SourceWriter.newline w + ) gen.gcon.resources; + SourceWriter.write w "end resources"; + SourceWriter.newline w; + SourceWriter.write w "begin libs"; + SourceWriter.newline w; + if Common.platform gen.gcon Java then + List.iter (fun (s,std,_,_,_) -> + if not std then begin + SourceWriter.write w s; + SourceWriter.newline w; + end + ) gen.gcon.java_libs; + SourceWriter.write w "end libs"; + + let contents = SourceWriter.contents w in + let f = open_out (gen.gcon.file ^ "/" ^ name) in + output_string f contents; + close_out f + +(* + helper function to create the source structure. Will send each module_def to the function passed. + If received true, it means that module_gen has generated this content, so the file must be saved. + See that it will write a whole module +*) +let generate_modules gen extension source_dir (module_gen : SourceWriter.source_writer->module_def->bool) = + List.iter (fun md_def -> + let w = SourceWriter.new_source_writer () in + (*let should_write = List.fold_left (fun should md -> module_gen w md or should) false md_def.m_types in*) + let should_write = module_gen w md_def in + if should_write then begin + let path = md_def.m_path in + write_file gen w source_dir path extension; + + + end + ) gen.gcon.modules + +let generate_modules_t gen extension source_dir change_path (module_gen : SourceWriter.source_writer->module_type->bool) = + List.iter (fun md -> + let w = SourceWriter.new_source_writer () in + (*let should_write = List.fold_left (fun should md -> module_gen w md or should) false md_def.m_types in*) + let should_write = module_gen w md in + if should_write then begin + let path = change_path (t_path md) in + write_file gen w source_dir path extension; + end + ) gen.gcon.types + +(* + various helper functions +*) + +let mk_paren e = + match e.eexpr with | TParenthesis _ -> e | _ -> { e with eexpr=TParenthesis(e) } + +(* private *) +let tmp_count = ref 0 + +let get_real_fun gen t = + match follow t with + | TFun(args,t) -> TFun(List.map (fun (n,o,t) -> n,o,gen.greal_type t) args, gen.greal_type t) + | _ -> t + +let mk_int gen i pos = { eexpr = TConst(TInt ( Int32.of_int i)); etype = gen.gcon.basic.tint; epos = pos } + +let mk_return e = { eexpr = TReturn (Some e); etype = e.etype; epos = e.epos } + +let mk_temp gen name t = + incr tmp_count; + let name = gen.gmk_internal_name "temp" (name ^ (string_of_int !tmp_count)) in + alloc_var name t + +let ensure_local gen block name e = + match e.eexpr with + | TLocal _ -> e + | _ -> + let var = mk_temp gen name e.etype in + block := { e with eexpr = TVars([ var, Some e ]); etype = gen.gcon.basic.tvoid; } :: !block; + { e with eexpr = TLocal var } + +let reset_temps () = tmp_count := 0 + +let follow_module follow_func md = match md with + | TClassDecl _ + | TEnumDecl _ + | TAbstractDecl _ -> md + | TTypeDecl tdecl -> match (follow_func (TType(tdecl, List.map snd tdecl.t_types))) with + | TInst(cl,_) -> TClassDecl cl + | TEnum(e,_) -> TEnumDecl e + | TType(t,_) -> TTypeDecl t + | TAbstract(a,_) -> TAbstractDecl a + | _ -> assert false + +(* + hxgen means if the type was generated by haxe. If a type was generated by haxe, it means + it will contain special constructs for speedy reflection, for example + + @see SetHXGen module + *) +let rec is_hxgen md = + match md with + | TClassDecl cl -> Meta.has Meta.HxGen cl.cl_meta + | TEnumDecl e -> Meta.has Meta.HxGen e.e_meta + | TTypeDecl t -> Meta.has Meta.HxGen t.t_meta || ( match follow t.t_type with | TInst(cl,_) -> is_hxgen (TClassDecl cl) | TEnum(e,_) -> is_hxgen (TEnumDecl e) | _ -> false ) + | TAbstractDecl a -> Meta.has Meta.HxGen a.a_meta + +let is_hxgen_t t = + match t with + | TInst (cl, _) -> Meta.has Meta.HxGen cl.cl_meta + | TEnum (e, _) -> Meta.has Meta.HxGen e.e_meta + | TAbstract (a, _) -> Meta.has Meta.HxGen a.a_meta + | TType (t, _) -> Meta.has Meta.HxGen t.t_meta + | _ -> false + +let mt_to_t_dyn md = + match md with + | TClassDecl cl -> TInst(cl, List.map (fun _ -> t_dynamic) cl.cl_types) + | TEnumDecl e -> TEnum(e, List.map (fun _ -> t_dynamic) e.e_types) + | TAbstractDecl a -> TAbstract(a, List.map (fun _ -> t_dynamic) a.a_types) + | TTypeDecl t -> TType(t, List.map (fun _ -> t_dynamic) t.t_types) + +let mt_to_t mt params = + match mt with + | TClassDecl (cl) -> TInst(cl, params) + | TEnumDecl (e) -> TEnum(e, params) + | TAbstractDecl a -> TAbstract(a, params) + | _ -> assert false + +let t_to_mt t = + match follow t with + | TInst(cl, _) -> TClassDecl(cl) + | TEnum(e, _) -> TEnumDecl(e) + | TAbstract(a, _) -> TAbstractDecl a + | _ -> assert false + +let mk_paren e = + match e.eexpr with + | TParenthesis _ -> e + | _ -> { e with eexpr = TParenthesis(e) } + +let rec get_last_ctor cl = + Option.map_default (fun (super,_) -> if is_some super.cl_constructor then Some(get super.cl_constructor) else get_last_ctor super) None cl.cl_super + +let add_constructor cl cf = + match cl.cl_constructor with + | None -> cl.cl_constructor <- Some cf + | Some ctor -> + if ctor != cf && not (List.memq cf ctor.cf_overloads) then + ctor.cf_overloads <- cf :: ctor.cf_overloads + +(* replace open TMonos with TDynamic *) +let rec replace_mono t = + match follow t with + | TMono t -> t := Some t_dynamic + | TEnum (_,p) | TInst (_,p) | TType (_,p) | TAbstract (_,p) -> + List.iter replace_mono p + | TFun (args,ret) -> + List.iter (fun (_,_,t) -> replace_mono t) args; + replace_mono ret + | TAnon _ + | TDynamic _ -> () + | _ -> assert false + + +(* helper *) +let mk_class_field name t public pos kind params = + { + cf_name = name; + cf_type = t; + cf_public = public; + cf_pos = pos; + cf_doc = None; + cf_meta = [ Meta.CompilerGenerated, [], Ast.null_pos ]; (* annotate that this class field was generated by the compiler *) + cf_kind = kind; + cf_params = params; + cf_expr = None; + cf_overloads = []; + } + +(* this helper just duplicates the type parameter class, which is assumed that cl is. *) +(* This is so we can use class parameters on function parameters, without running the risk of name clash *) +(* between both *) +let map_param cl = + let ret = mk_class cl.cl_module cl.cl_path cl.cl_pos in + ret.cl_implements <- cl.cl_implements; + ret.cl_kind <- cl.cl_kind; + ret + +let get_cl_t t = + match follow t with | TInst (cl,_) -> cl | _ -> assert false + +let mk_class m path pos = + let cl = Type.mk_class m path pos in + cl.cl_meta <- [ Meta.CompilerGenerated, [], Ast.null_pos ]; + cl + +type tfield_access = + | FClassField of tclass * tparams * tclass (* declared class *) * tclass_field * bool (* is static? *) * t (* the actual cf type, in relation to the class type params *) * t (* declared type *) + | FEnumField of tenum * tenum_field * bool (* is parameterized enum ? *) + | FAnonField of tclass_field + | FDynamicField of t + | FNotFound + +let find_first_declared_field gen orig_cl ?exact_field field = + let chosen = ref None in + let is_overload = ref false in + let rec loop_cl depth c tl tlch = + (try + let ret = PMap.find field c.cl_fields in + if Meta.has Meta.Overload ret.cf_meta then is_overload := true; + match !chosen, exact_field with + | Some(d,_,_,_,_), _ when depth <= d -> () + | _, None -> + chosen := Some(depth,ret,c,tl,tlch) + | _, Some f2 -> + List.iter (fun f -> + let declared_t = apply_params c.cl_types tl f.cf_type in + if Typeload.same_overload_args declared_t f2.cf_type f f2 then + chosen := Some(depth,f,c,tl,tlch) + ) (ret :: ret.cf_overloads) + with | Not_found -> ()); + (match c.cl_super with + | Some (sup,stl) -> + let tl = List.map (apply_params c.cl_types tl) stl in + let stl = gen.greal_type_param (TClassDecl sup) stl in + let tlch = List.map (apply_params c.cl_types tlch) stl in + loop_cl (depth+1) sup tl tlch + | None -> ()); + if c.cl_interface then + List.iter (fun (sup,stl) -> + let tl = List.map (apply_params c.cl_types tl) stl in + let stl = gen.greal_type_param (TClassDecl sup) stl in + let tlch = List.map (apply_params c.cl_types tlch) stl in + loop_cl (depth+1) sup tl tlch + ) c.cl_implements + in + loop_cl 0 orig_cl (List.map snd orig_cl.cl_types) (List.map snd orig_cl.cl_types); + match !chosen with + | None -> None + | Some(_,f,c,tl,tlch) -> + if !is_overload && not (Meta.has Meta.Overload f.cf_meta) then + f.cf_meta <- (Meta.Overload,[],f.cf_pos) :: f.cf_meta; + let declared_t = apply_params c.cl_types tl f.cf_type in + let params_t = apply_params c.cl_types tlch f.cf_type in + let actual_t = match follow params_t with + | TFun(args,ret) -> TFun(List.map (fun (n,o,t) -> (n,o,gen.greal_type t)) args, gen.greal_type ret) + | _ -> gen.greal_type params_t in + Some(f,actual_t,declared_t,params_t,c,tl,tlch) + +let field_access gen (t:t) (field:string) : (tfield_access) = + (* + t can be either an haxe-type as a real-type; + 'follow' should be applied here since we can generalize that a TType will be accessible as its + underlying type. + *) + + match follow t with + | TInst(cl, params) -> + let orig_cl = cl in + let orig_params = params in + let rec not_found cl params = + match cl.cl_dynamic with + | Some t -> + let t = apply_params cl.cl_types params t in + FDynamicField t + | None -> + match cl.cl_super with + | None -> FNotFound + | Some (super,p) -> not_found super p + in + + let not_found () = + try + let cf = PMap.find field gen.gbase_class_fields in + FClassField (orig_cl, orig_params, gen.gclasses.cl_dyn, cf, false, cf.cf_type, cf.cf_type) + with + | Not_found -> not_found cl params + in + + (* this is a hack for C#'s different generic types with same path *) + let hashtbl_field = (String.concat "" (List.map (fun _ -> "]") cl.cl_types)) ^ field in + let types = try + Hashtbl.find gen.greal_field_types (orig_cl.cl_path, hashtbl_field) + with | Not_found -> + let ret = find_first_declared_field gen cl field in + let ret = match ret with + | None -> None + | Some(cf,t,dt,_,cl,_,_) -> Some(cf,t,dt,cl) + in + Hashtbl.add gen.greal_field_types (orig_cl.cl_path, hashtbl_field) ret; + ret + in + (match types with + | None -> not_found() + | Some (cf, actual_t, declared_t, declared_cl) -> + FClassField(orig_cl, orig_params, declared_cl, cf, false, actual_t, declared_t)) + | TEnum _ | TAbstract _ -> + (* enums have no field *) FNotFound + | TAnon anon -> + (try match !(anon.a_status) with + | Statics cl -> + let cf = PMap.find field cl.cl_statics in + FClassField(cl, List.map (fun _ -> t_dynamic) cl.cl_types, cl, cf, true, cf.cf_type, cf.cf_type) + | EnumStatics e -> + let f = PMap.find field e.e_constrs in + let is_param = match follow f.ef_type with | TFun _ -> true | _ -> false in + FEnumField(e, f, is_param) + | _ when PMap.mem field gen.gbase_class_fields -> + let cf = PMap.find field gen.gbase_class_fields in + FClassField(gen.gclasses.cl_dyn, [t_dynamic], gen.gclasses.cl_dyn, cf, false, cf.cf_type, cf.cf_type) + | _ -> + FAnonField(PMap.find field anon.a_fields) + with | Not_found -> FNotFound) + | _ when PMap.mem field gen.gbase_class_fields -> + let cf = PMap.find field gen.gbase_class_fields in + FClassField(gen.gclasses.cl_dyn, [t_dynamic], gen.gclasses.cl_dyn, cf, false, cf.cf_type, cf.cf_type) + | TDynamic t -> FDynamicField t + | TMono _ -> FDynamicField t_dynamic + | _ -> FNotFound + +let mk_field_access gen expr field pos = + match field_access gen expr.etype field with + | FClassField(c,p,dc,cf,false,at,_) -> + { eexpr = TField(expr, FInstance(dc,cf)); etype = apply_params c.cl_types p at; epos = pos } + | FClassField(c,p,dc,cf,true,at,_) -> + { eexpr = TField(expr, FStatic(dc,cf)); etype = at; epos = pos } + | FAnonField cf -> + { eexpr = TField(expr, FAnon cf); etype = cf.cf_type; epos = pos } + | FDynamicField t -> + { eexpr = TField(expr, FDynamic field); etype = t; epos = pos } + | FNotFound -> + { eexpr = TField(expr, FDynamic field); etype = t_dynamic; epos = pos } + | FEnumField _ -> assert false + +let mk_iterator_access gen t expr = + let pos = expr.epos in + let itf = mk_field_access gen expr "iterator" pos in + { eexpr = TCall(itf, []); epos = pos; etype = snd (get_fun itf.etype) } + +(* ******************************************* *) +(* Module dependency resolution *) +(* ******************************************* *) + +type t_dependency = + | DAfter of float + | DBefore of float + +exception ImpossibleDependency of string + +let max_dep = 10000.0 +let min_dep = - (10000.0) + +let solve_deps name (deps:t_dependency list) = + let vmin = min_dep -. 1.0 in + let vmax = max_dep +. 1.0 in + let rec loop dep vmin vmax = + match dep with + | [] -> + (if vmin >= vmax then raise (ImpossibleDependency name)); + (vmin +. vmax) /. 2.0 + | head :: tail -> + match head with + | DBefore f -> + loop tail (max vmin f) vmax + | DAfter f -> + loop tail vmin (min vmax f) + in + loop deps vmin vmax + +(* type resolution *) + +exception TypeNotFound of path + +let get_type gen path = + try Hashtbl.find gen.gtypes path with | Not_found -> raise (TypeNotFound path) + +(* ******************************************* *) +(* follow all module *) +(* ******************************************* *) + +(* + this module will follow each and every type using the rules defined in + gen.gfollow. This is a minor helper module, so we don't end up + having to follow the same time multiple times in the many filter iterations + because of this, it will be one of the first modules to run. +*) +module FollowAll = +struct + + let follow gen e = + let follow_func = gen.gfollow#run_f in + Some (Type.map_expr_type (fun e->e) (follow_func) (fun tvar-> tvar.v_type <- (follow_func tvar.v_type); tvar) e) + + let priority = max_dep + + (* will add an expression filter as the first filter *) + let configure gen = + gen.gexpr_filters#add ~name:"follow_all" ~priority:(PCustom(priority)) (follow gen) + +end;; + +(* ******************************************* *) +(* set hxgen module *) +(* ******************************************* *) + +(* + goes through all module types and sets the :hxgen meta on all which + then is_hxgen_func returns true. There is a default is_hxgen_func implementation also +*) + +module SetHXGen = +struct + + (* + basically, everything that is extern is assumed to not be hxgen, unless meta :hxgen is set, and + everything that is not extern is assumed to be hxgen, unless meta :nativegen is set + *) + let default_hxgen_func md = + match md with + | TClassDecl cl -> + let rec is_hxgen_class c = + if c.cl_extern then begin + if Meta.has Meta.HxGen c.cl_meta then true else Option.map_default (fun (c,_) -> is_hxgen_class c) false c.cl_super + end else begin + if Meta.has Meta.NativeGen c.cl_meta then Option.map_default (fun (c, _) -> is_hxgen_class c) false c.cl_super else true + end + in + + is_hxgen_class cl + | TEnumDecl e -> if e.e_extern then Meta.has Meta.HxGen e.e_meta else not (Meta.has Meta.NativeGen e.e_meta) + | TAbstractDecl a -> not (Meta.has Meta.NativeGen a.a_meta) + | TTypeDecl t -> (* TODO see when would we use this *) + false + + (* + by now the only option is to run it eagerly, because it must be one of the first filters to run, + since many others depend of it + *) + let run_filter gen is_hxgen_func = + let filter md = + if is_hxgen_func md then begin + match md with + | TClassDecl cl -> cl.cl_meta <- (Meta.HxGen, [], cl.cl_pos) :: cl.cl_meta + | TEnumDecl e -> e.e_meta <- (Meta.HxGen, [], e.e_pos) :: e.e_meta + | TTypeDecl t -> t.t_meta <- (Meta.HxGen, [], t.t_pos) :: t.t_meta + | TAbstractDecl a -> a.a_meta <- (Meta.HxGen, [], a.a_pos) :: a.a_meta + end + in + List.iter filter gen.gcon.types + +end;; + +(* ******************************************* *) +(* overloading reflection constructors *) +(* ******************************************* *) + +(* + this module works on languages that support function overloading and + enable function hiding via static functions. + it takes the constructor body out of the constructor and adds it to a special ctor + static function. The static function will receive the same parameters as the constructor, + plus the special "me" var, which will replace "this" + + Then it always adds two constructors to the function: one that receives a special class, + indicating that it should be constructed without any parameters, and one that receives its normal constructor. + Both will only include a super() call to the superclasses' emtpy constructor. + + + This enables two things: + empty construction without the need of incompatibility with the platform's native construction method + the ability to call super() constructor in any place in the constructor + + This will insert itself in the default reflection-related module filter +*) +module OverloadingConstructor = +struct + + let priority = 0.0 + + let name = "overloading_constructor" + + let set_new_create_empty gen empty_ctor_expr = + let old = gen.gtools.rf_create_empty in + gen.gtools.rf_create_empty <- (fun cl params pos -> + if is_hxgen (TClassDecl cl) then + { eexpr = TNew(cl,params,[empty_ctor_expr]); etype = TInst(cl,params); epos = pos } + else + old cl params pos + ) + + let rec cur_ctor c tl = + match c.cl_constructor with + | Some ctor -> ctor, c, tl + | None -> match c.cl_super with + | None -> raise Not_found + | Some (sup,stl) -> + cur_ctor sup (List.map (apply_params c.cl_types tl) stl) + + let rec prev_ctor c tl = + match c.cl_super with + | None -> raise Not_found + | Some (sup,stl) -> let stl = List.map (apply_params c.cl_types tl) stl in + match sup.cl_constructor with + | None -> prev_ctor sup stl + | Some ctor -> ctor, sup, stl + + (* replaces super() call with last static constructor call *) + let replace_super_call gen name c tl with_params me p = + let rec loop_super c tl = match c.cl_super with + | None -> raise Not_found + | Some(sup,stl) -> + let stl = List.map (apply_params c.cl_types tl) stl in + try + let static_ctor_name = name ^ "_" ^ (String.concat "_" (fst sup.cl_path)) ^ "_" ^ (snd sup.cl_path) in + sup, stl, PMap.find static_ctor_name sup.cl_statics + with | Not_found -> + loop_super sup stl + in + let sup, stl, cf = loop_super c tl in + let with_params = { eexpr = TLocal me; etype = me.v_type; epos = p } :: with_params in + let cf = match cf.cf_overloads with + (* | [] -> cf *) + | _ -> try + (* choose best super function *) + List.iter (fun e -> replace_mono e.etype) with_params; + List.find (fun cf -> + replace_mono cf.cf_type; + let args, _ = get_fun (apply_params cf.cf_params stl cf.cf_type) in + try + List.for_all2 (fun (_,_,t) e -> try + unify e.etype t; true + with | Unify_error _ -> false) args with_params + with | Invalid_argument("List.for_all2") -> false + ) (cf :: cf.cf_overloads) + with | Not_found -> + gen.gcon.error "No suitable overload for the super call arguments was found" p; cf + in + { + eexpr = TCall({ + eexpr = TField( + mk_classtype_access sup p, + FStatic(sup,cf)); + etype = apply_params cf.cf_params stl cf.cf_type; + epos = p}, + with_params); + etype = gen.gcon.basic.tvoid; + epos = p; + } + + (* will create a static counterpart of 'ctor', and replace its contents to a call to the static version*) + let create_static_ctor gen ~empty_ctor_expr cl name ctor = + match Meta.has Meta.SkipCtor ctor.cf_meta with + | true -> () + | false when is_none ctor.cf_expr -> () + | false -> + let static_ctor_name = name ^ "_" ^ (String.concat "_" (fst cl.cl_path)) ^ "_" ^ (snd cl.cl_path) in + (* create the static constructor *) + let basic = gen.gcon.basic in + let ctor_types = List.map (fun (s,t) -> (s, TInst(map_param (get_cl_t t), []))) cl.cl_types in + let me = mk_temp gen "me" (TInst(cl, List.map snd ctor_types)) in + me.v_capture <- true; + + let fn_args, _ = get_fun ctor.cf_type in + let ctor_params = List.map snd ctor_types in + let fn_type = TFun((me.v_name,false, me.v_type) :: List.map (fun (n,o,t) -> (n,o,apply_params cl.cl_types ctor_params t)) fn_args, basic.tvoid) in + let cur_tf_args = match ctor.cf_expr with + | Some { eexpr = TFunction(tf) } -> tf.tf_args + | _ -> assert false + in + + let changed_tf_args = List.map (fun (v,_) -> (v,None)) cur_tf_args in + + let local_map = Hashtbl.create (List.length cur_tf_args) in + let static_tf_args = (me, None) :: List.map (fun (v,b) -> + let new_v = alloc_var v.v_name (apply_params cl.cl_types ctor_params v.v_type) in + Hashtbl.add local_map v.v_id new_v; + (new_v, b) + ) cur_tf_args in + + let static_ctor = mk_class_field static_ctor_name fn_type false ctor.cf_pos (Method MethNormal) ctor_types in + + (* change ctor contents to reference the 'me' var instead of 'this' *) + let actual_super_call = ref None in + let rec map_expr ~is_first e = match e.eexpr with + | TCall (({ eexpr = TConst TSuper } as tsuper), params) -> (try + let params = List.map (fun e -> map_expr ~is_first:false e) params in + actual_super_call := Some { e with eexpr = TCall(tsuper, [empty_ctor_expr]) }; + replace_super_call gen name cl ctor_params params me e.epos + with | Not_found -> + (* last static function was not found *) + actual_super_call := Some e; + if not is_first then + gen.gcon.error "Super call must be the first call when extending native types" e.epos; + { e with eexpr = TBlock([]) }) + | TFunction tf when is_first -> + do_map ~is_first:true e + | TConst TThis -> + mk_local me e.epos + | TBlock (fst :: bl) -> + let fst = map_expr ~is_first:is_first fst in + { e with eexpr = TBlock(fst :: List.map (fun e -> map_expr ~is_first:false e) bl); etype = apply_params cl.cl_types ctor_params e.etype } + | _ -> + do_map e + and do_map ?(is_first=false) e = + let do_t = apply_params cl.cl_types ctor_params in + let do_v v = try + Hashtbl.find local_map v.v_id + with | Not_found -> + v.v_type <- do_t v.v_type; v + in + Type.map_expr_type (map_expr ~is_first:is_first) do_t do_v e + in + + let expr = do_map ~is_first:true (get ctor.cf_expr) in + let expr = match expr.eexpr with + | TFunction(tf) -> + { expr with etype = fn_type; eexpr = TFunction({ tf with tf_args = static_tf_args }) } + | _ -> assert false in + static_ctor.cf_expr <- Some expr; + (* add to the statics *) + (try + let stat = PMap.find static_ctor_name cl.cl_statics in + stat.cf_overloads <- static_ctor :: stat.cf_overloads + with | Not_found -> + cl.cl_ordered_statics <- static_ctor :: cl.cl_ordered_statics; + cl.cl_statics <- PMap.add static_ctor_name static_ctor cl.cl_statics); + (* change current super call *) + match ctor.cf_expr with + | Some({ eexpr = TFunction(tf) } as e) -> + let block_contents, p = match !actual_super_call with + | None -> [], ctor.cf_pos + | Some super -> [super], super.epos + in + let block_contents = block_contents @ [{ + eexpr = TCall( + { + eexpr = TField( + mk_classtype_access cl p, + FStatic(cl, static_ctor)); + etype = apply_params static_ctor.cf_params (List.map snd cl.cl_types) static_ctor.cf_type; + epos = p + }, + [{ eexpr = TConst TThis; etype = TInst(cl, List.map snd cl.cl_types); epos = p }] + @ List.map (fun (v,_) -> mk_local v p) cur_tf_args + ); + etype = basic.tvoid; + epos = p + }] in + ctor.cf_expr <- Some { e with eexpr = TFunction({ tf with tf_expr = { tf.tf_expr with eexpr = TBlock block_contents }; tf_args = changed_tf_args }) } + | _ -> assert false + + (* makes constructors that only call super() for the 'ctor' argument *) + let clone_ctors gen ctor sup stl cl = + let basic = gen.gcon.basic in + let rec clone cf = + let ncf = mk_class_field "new" (apply_params sup.cl_types stl cf.cf_type) cf.cf_public cf.cf_pos cf.cf_kind cf.cf_params in + let args, ret = get_fun ncf.cf_type in + (* single expression: call to super() *) + let tf_args = List.map (fun (name,_,t) -> + (* the constructor will have no optional arguments, as presumably this will be handled by the underlying expr *) + alloc_var name t, None + ) args in + let super_call = + { + eexpr = TCall( + { eexpr = TConst TSuper; etype = TInst(cl, List.map snd cl.cl_types); epos = ctor.cf_pos }, + List.map (fun (v,_) -> mk_local v ctor.cf_pos) tf_args); + etype = basic.tvoid; + epos = ctor.cf_pos; + } in + ncf.cf_expr <- Some + { + eexpr = TFunction { + tf_args = tf_args; + tf_type = basic.tvoid; + tf_expr = mk_block super_call; + }; + etype = ncf.cf_type; + epos = ctor.cf_pos; + }; + ncf + in + (* take off createEmpty *) + let all = List.filter (fun cf -> replace_mono cf.cf_type; not (Meta.has Meta.SkipCtor cf.cf_meta)) (ctor :: ctor.cf_overloads) in + let clones = List.map clone all in + match clones with + | [] -> + (* raise Not_found *) + assert false (* should never happen *) + | cf :: [] -> cf + | cf :: overl -> + cf.cf_meta <- (Meta.Overload,[],cf.cf_pos) :: cf.cf_meta; + cf.cf_overloads <- overl; cf + + let rec descends_from_native_or_skipctor cl = + not (is_hxgen (TClassDecl cl)) || Meta.has Meta.SkipCtor cl.cl_meta || match cl.cl_super with + | None -> false + | Some(c,_) -> descends_from_native_or_skipctor c + + let ensure_super_is_first gen cf = + let rec loop e = + match e.eexpr with + | TBlock (b :: block) -> + loop b + | TBlock [] + | TCall({ eexpr = TConst TSuper },_) -> () + | _ -> + gen.gcon.error "Types that derive from a native class must have its super() call as the first statement in the constructor" cf.cf_pos + in + match cf.cf_expr with + | None -> () + | Some e -> Type.iter loop e + + (* major restructring made at r6493 *) + let configure ~(empty_ctor_type : t) ~(empty_ctor_expr : texpr) ~supports_ctor_inheritance gen = + set_new_create_empty gen empty_ctor_expr; + + let basic = gen.gcon.basic in + let should_change cl = not cl.cl_interface && (not cl.cl_extern || is_hxgen (TClassDecl cl)) in + let static_ctor_name = gen.gmk_internal_name "hx" "ctor" in + let msize = List.length gen.gcon.types in + let processed, empty_ctors = Hashtbl.create msize, Hashtbl.create msize in + + + let rec get_last_empty cl = + try + Hashtbl.find empty_ctors cl.cl_path + with | Not_found -> + match cl.cl_super with + | None -> raise Not_found + | Some (sup,_) -> get_last_empty sup + in + + let rec change cl = + match Hashtbl.mem processed cl.cl_path with + | true -> () + | false -> + Hashtbl.add processed cl.cl_path true; + (* make sure we've processed the super types *) + (match cl.cl_super with + | Some (super,_) when should_change super && not (Hashtbl.mem processed super.cl_path) -> + change super + | _ -> ()); + + (* implement static hx_ctor and reimplement constructors *) + (try + let ctor = match cl.cl_constructor with + | Some ctor -> ctor + | None -> try + let sctor, sup, stl = prev_ctor cl (List.map snd cl.cl_types) in + (* we have a previous constructor. if we support inheritance, exit *) + if supports_ctor_inheritance then raise Exit; + (* we'll make constructors that will only call super() *) + let ctor = clone_ctors gen sctor sup stl cl in + cl.cl_constructor <- Some ctor; + ctor + with | Not_found -> (* create default constructor *) + let ctor = mk_class_field "new" (TFun([], basic.tvoid)) false cl.cl_pos (Method MethNormal) [] in + ctor.cf_expr <- Some + { + eexpr = TFunction { + tf_args = []; + tf_type = basic.tvoid; + tf_expr = { eexpr = TBlock[]; etype = basic.tvoid; epos = cl.cl_pos }; + }; + etype = ctor.cf_type; + epos = ctor.cf_pos; + }; + cl.cl_constructor <- Some ctor; + ctor + in + (* now that we made sure we have a constructor, exit if native gen *) + if not (is_hxgen (TClassDecl cl)) || Meta.has Meta.SkipCtor cl.cl_meta then raise Exit; + + (* if cl descends from a native class, we cannot use the static constructor strategy *) + if descends_from_native_or_skipctor cl && is_some cl.cl_super then + List.iter (fun cf -> ensure_super_is_first gen cf) (ctor :: ctor.cf_overloads) + else + (* now that we have a current ctor, create the static counterparts *) + List.iter (fun cf -> + create_static_ctor gen ~empty_ctor_expr:empty_ctor_expr cl static_ctor_name cf + ) (ctor :: ctor.cf_overloads) + with | Exit -> ()); + + (* implement empty ctor *) + (try + (* now that we made sure we have a constructor, exit if native gen *) + if not (is_hxgen (TClassDecl cl)) then raise Exit; + (* get first *) + let empty_type = TFun(["empty",false,empty_ctor_type],basic.tvoid) in + let super = match cl.cl_super with + | None -> (* implement empty *) + [] + | Some (sup,_) -> try + ignore (get_last_empty sup); + if supports_ctor_inheritance && is_none cl.cl_constructor then raise Exit; + [{ + eexpr = TCall( + { eexpr = TConst TSuper; etype = TInst(cl, List.map snd cl.cl_types); epos = cl.cl_pos }, + [ empty_ctor_expr ]); + etype = basic.tvoid; + epos = cl.cl_pos + }] + with | Not_found -> try + (* super type is native: find super constructor with least arguments *) + let sctor, sup, stl = prev_ctor cl (List.map snd cl.cl_types) in + let rec loop remaining (best,n) = + match remaining with + | [] -> best + | cf :: r -> + let args,_ = get_fun cf.cf_type in + if (List.length args) < n then + loop r (cf,List.length args) + else + loop r (best,n) + in + let args,_ = get_fun sctor.cf_type in + let best = loop sctor.cf_overloads (sctor, List.length args) in + let args,_ = get_fun best.cf_type in + [{ + eexpr = TCall( + { eexpr = TConst TSuper; etype = TInst(cl, List.map snd cl.cl_types); epos = cl.cl_pos }, + List.map (fun (n,o,t) -> null t cl.cl_pos) args); + etype = basic.tvoid; + epos = cl.cl_pos + }] + with | Not_found -> + (* extends native type, but no ctor found *) + [] + in + let ctor = mk_class_field "new" empty_type false cl.cl_pos (Method MethNormal) [] in + ctor.cf_expr <- Some { + eexpr = TFunction { + tf_type = basic.tvoid; + tf_args = [alloc_var "empty" empty_ctor_type, None]; + tf_expr = { eexpr = TBlock super; etype = basic.tvoid; epos = cl.cl_pos } + }; + etype = empty_type; + epos = cl.cl_pos; + }; + ctor.cf_meta <- [Meta.SkipCtor, [], ctor.cf_pos]; + Hashtbl.add empty_ctors cl.cl_path ctor; + match cl.cl_constructor with + | None -> cl.cl_constructor <- Some ctor + | Some c -> c.cf_overloads <- ctor :: c.cf_overloads + with | Exit -> ()); + + in + let module_filter md = match md with + | TClassDecl cl when should_change cl && not (Hashtbl.mem processed cl.cl_path) -> + change cl; + None + | _ -> None + in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) module_filter + + end;; + + (* ******************************************* *) + (* init function module *) + (* ******************************************* *) + + (* + This module will take proper care of the init function, by taking off all expressions from static vars and putting them + in order in the init function. + It will also initialize dynamic functions, both by putting them in the constructor and in the init function + + depends on: + (syntax) must run before ExprStatement module + (ok) must run before OverloadingCtor module so the constructor can be in the correct place + (syntax) must run before FunctionToClass module + *) + + module InitFunction = + struct + + let name = "init_funcs" + + let priority = solve_deps name [DBefore OverloadingConstructor.priority] + + let configure gen should_handle_dynamic_functions = + let handle_override_dynfun acc e this field = + let add_expr = ref None in + let v = mk_temp gen ("super_" ^ field) e.etype in + v.v_capture <- true; + + let rec loop e = + match e.eexpr with + | TField({ eexpr = TConst(TSuper) }, f) -> + let n = field_name f in + (if n <> field then assert false); + let local = mk_local v e.epos in + (match !add_expr with + | None -> + add_expr := Some { e with eexpr = TVars([v, Some this]) } + | Some _ -> ()); + local + | TConst TSuper -> assert false + | _ -> Type.map_expr loop e + in + let e = loop e in + + match !add_expr with + | None -> e :: acc + | Some add_expr -> add_expr :: e :: acc + in + + let handle_class cl = + let init = match cl.cl_init with + | None -> [] + | Some i -> [i] + in + let init = List.fold_left (fun acc cf -> + match cf.cf_kind, should_handle_dynamic_functions with + | (Var _, _) + | (Method (MethDynamic), true) when not (Type.is_extern_field cf) -> + (match cf.cf_expr with + | Some e -> + (match cf.cf_params with + | [] -> + let var = { eexpr = TField(mk_classtype_access cl cf.cf_pos, FStatic(cl,cf)); etype = cf.cf_type; epos = cf.cf_pos } in + let ret = ({ eexpr = TBinop(Ast.OpAssign, var, e); etype = cf.cf_type; epos = cf.cf_pos; }) in + cf.cf_expr <- None; + + ret :: acc + | _ -> + let params = List.map (fun _ -> t_dynamic) cf.cf_params in + let fn = apply_params cf.cf_params params in + let var = { eexpr = TField(mk_classtype_access cl cf.cf_pos, FStatic(cl,cf)); etype = fn cf.cf_type; epos = cf.cf_pos } in + let rec change_expr e = + Type.map_expr_type (change_expr) fn (fun v -> v.v_type <- fn v.v_type; v) e + in + + let ret = ({ eexpr = TBinop(Ast.OpAssign, var, change_expr e); etype = fn cf.cf_type; epos = cf.cf_pos; }) in + cf.cf_expr <- None; + ret :: acc + ) + | None -> acc) + | _ -> acc + ) init cl.cl_ordered_statics + in + let init = List.rev init in + (match init with + | [] -> cl.cl_init <- None + | _ -> cl.cl_init <- Some { eexpr = TBlock(init); epos = cl.cl_pos; etype = gen.gcon.basic.tvoid; }); + + (* FIXME: find a way to tell OverloadingCtors to execute this code even with empty constructors *) + if should_handle_dynamic_functions then begin + let funs = List.fold_left (fun acc cf -> + match cf.cf_kind with + | Var _ + | Method(MethDynamic) -> + (match cf.cf_expr, cf.cf_params with + | Some e, [] -> + let var = { eexpr = TField({ eexpr = TConst(TThis); epos = cf.cf_pos; etype = TInst(cl, List.map snd cl.cl_types); }, FInstance(cl, cf)); etype = cf.cf_type; epos = cf.cf_pos } in + let ret = ({ eexpr = TBinop(Ast.OpAssign, var, e); etype = cf.cf_type; epos = cf.cf_pos; }) in + cf.cf_expr <- None; + let is_override = List.memq cf cl.cl_overrides in + + if is_override then begin + cl.cl_ordered_fields <- List.filter (fun f -> f.cf_name <> cf.cf_name) cl.cl_ordered_fields; + cl.cl_fields <- PMap.remove cf.cf_name cl.cl_fields; + handle_override_dynfun acc ret var cf.cf_name + end else ret :: acc + | Some e, _ -> + let params = List.map (fun _ -> t_dynamic) cf.cf_params in + let fn = apply_params cf.cf_params params in + let var = { eexpr = TField({ eexpr = TConst(TThis); epos = cf.cf_pos; etype = TInst(cl, List.map snd cl.cl_types); }, FInstance(cl, cf)); etype = cf.cf_type; epos = cf.cf_pos } in + let rec change_expr e = + Type.map_expr_type (change_expr) fn (fun v -> v.v_type <- fn v.v_type; v) e + in + + let ret = ({ eexpr = TBinop(Ast.OpAssign, var, change_expr e); etype = fn cf.cf_type; epos = cf.cf_pos; }) in + cf.cf_expr <- None; + let is_override = List.memq cf cl.cl_overrides in + + if is_override then begin + cl.cl_ordered_fields <- List.filter (fun f -> f.cf_name <> cf.cf_name) cl.cl_ordered_fields; + cl.cl_fields <- PMap.remove cf.cf_name cl.cl_fields; + handle_override_dynfun acc ret var cf.cf_name + end else ret :: acc + | None, _ -> acc) + | _ -> acc + ) [] cl.cl_ordered_fields + in + (* see if there is any *) + (match funs with + | [] -> () + | _ -> + (* if there is, we need to find the constructor *) + let ctors = match cl.cl_constructor with + | Some ctor -> ctor + | None -> try + let sctor, sup, stl = OverloadingConstructor.prev_ctor cl (List.map snd cl.cl_types) in + let ctor = OverloadingConstructor.clone_ctors gen sctor sup stl cl in + cl.cl_constructor <- Some ctor; + ctor + with | Not_found -> + let basic = gen.gcon.basic in + let ctor = mk_class_field "new" (TFun([], basic.tvoid)) false cl.cl_pos (Method MethNormal) [] in + ctor.cf_expr <- Some + { + eexpr = TFunction { + tf_args = []; + tf_type = basic.tvoid; + tf_expr = { eexpr = TBlock[]; etype = basic.tvoid; epos = cl.cl_pos }; + }; + etype = ctor.cf_type; + epos = ctor.cf_pos; + }; + cl.cl_constructor <- Some ctor; + ctor + in + + let process ctor = + let func = match ctor.cf_expr with + | Some({eexpr = TFunction(tf)} as e) -> + let rec add_fn e = match e.eexpr with + | TBlock(hd :: tl) -> (match hd.eexpr with + | TCall({ eexpr = TConst TSuper }, _) -> + { e with eexpr = TBlock(hd :: (funs @ tl)) } + | TBlock(_) -> + { e with eexpr = TBlock( (add_fn hd) :: tl ) } + | _ -> + { e with eexpr = TBlock( funs @ (hd :: tl) ) }) + | _ -> Codegen.concat { e with eexpr = TBlock(funs) } e + in + let tf_expr = add_fn (mk_block tf.tf_expr) in + { e with eexpr = TFunction({ tf with tf_expr = tf_expr }) } + | _ -> assert false + in + ctor.cf_expr <- Some(func) + in + List.iter process (ctors :: ctors.cf_overloads) + ) + end + + in + + let mod_filter = function + | TClassDecl cl -> (if not cl.cl_extern then handle_class cl); None + | _ -> None in + + gen.gmodule_filters#add ~name:"init_funcs" ~priority:(PCustom priority) mod_filter + + end;; + + (* ******************************************* *) + (* Dynamic Binop/Unop handler *) + (* ******************************************* *) + + (* + On some languages there is limited support for operations on + dynamic variables, so those operations must be changed. + + There are 5 types of binary operators: + 1 - can take any variable and returns a bool (== and !=) + 2 - can take either a string, or a number and returns either a bool or the underlying type ( >, < for bool and + for returning its type) + 3 - take numbers and return a number ( *, /, ...) + 4 - take ints and return an int (bit manipulation) + 5 - take a bool and returns a bool ( &&, || ...) + + On the default implementation, type 1 and the plus function will be handled with a function call; + Type 2 will be handled with the parameter "compare_handler", which will do something like Reflect.compare(x1, x2); + Types 3, 4 and 5 will perform a cast to double, int and bool, which will then be handled normally by the platform + + Unary operators are the most difficult to handle correctly. + With unary operators, there are 2 types: + + 1 - can take a number, changes and returns the result (++, --, ~) + 2 - can take a number (-) or bool (!), and returns the result + + The first case is much trickier, because it doesn't seem a good idea to change any variable to double just because it is dynamic, + but this is how we will handle right now. + something like that: + + var x:Dynamic = 10; + x++; + + will be: + object x = 10; + x = ((IConvertible)x).ToDouble(null) + 1; + + depends on: + (syntax) must run before expression/statment normalization because it may generate complex expressions + must run before OverloadingCtor due to later priority conflicts. Since ExpressionUnwrap is only + defined afterwards, we will set this value with absolute values + *) + + module DynamicOperators = + struct + + let name = "dyn_ops" + + let priority = 0.0 + + let priority_as_synf = 100.0 (*solve_deps name [DBefore ExpressionUnwrap.priority]*) + + let abstract_implementation gen ?(handle_strings = true) (should_change:texpr->bool) (equals_handler:texpr->texpr->texpr) (dyn_plus_handler:texpr->texpr->texpr->texpr) (compare_handler:texpr->texpr->texpr) = + + + let get_etype_one e = + if like_int e.etype then + (gen.gcon.basic.tint, { eexpr = TConst(TInt(Int32.one)); etype = gen.gcon.basic.tint; epos = e.epos }) + else + (gen.gcon.basic.tfloat, { eexpr = TConst(TFloat("1.0")); etype = gen.gcon.basic.tfloat; epos = e.epos }) + in + + let basic = gen.gcon.basic in + + let rec run e = + match e.eexpr with + | TBinop (OpAssignOp op, e1, e2) when should_change e -> (* e1 will never contain another TBinop *) + (match e1.eexpr with + | TLocal _ -> + mk_paren { e with eexpr = TBinop(OpAssign, e1, run { e with eexpr = TBinop(op, e1, e2) }) } + | TField _ | TArray _ -> + let eleft, rest = match e1.eexpr with + | TField(ef, f) -> + let v = mk_temp gen "dynop" ef.etype in + { e1 with eexpr = TField(mk_local v ef.epos, f) }, [ { eexpr = TVars([v,Some (run ef)]); etype = basic.tvoid; epos = ef.epos } ] + | TArray(e1a, e2a) -> + let v = mk_temp gen "dynop" e1a.etype in + let v2 = mk_temp gen "dynopi" e2a.etype in + { e1 with eexpr = TArray(mk_local v e1a.epos, mk_local v2 e2a.epos) }, [ { eexpr = TVars([v,Some (run e1a); v2, Some (run e2a)]); etype = basic.tvoid; epos = e1.epos } ] + | _ -> assert false + in + { e with + eexpr = TBlock (rest @ [ { e with eexpr = TBinop(OpAssign, eleft, run { e with eexpr = TBinop(op, eleft, e2) }) } ]); + } + | _ -> + assert false + ) + + | TBinop (OpAssign, e1, e2) + | TBinop (OpInterval, e1, e2) -> Type.map_expr run e + | TBinop (op, e1, e2) when should_change e-> + (match op with + | OpEq -> (* type 1 *) + equals_handler (run e1) (run e2) + | OpNotEq -> (* != -> !equals() *) + mk_paren { eexpr = TUnop(Ast.Not, Prefix, (equals_handler (run e1) (run e2))); etype = gen.gcon.basic.tbool; epos = e.epos } + | OpAdd -> + if handle_strings && (is_string e.etype or is_string e1.etype or is_string e2.etype) then + { e with eexpr = TBinop(op, mk_cast gen.gcon.basic.tstring (run e1), mk_cast gen.gcon.basic.tstring (run e2)) } + else + dyn_plus_handler e (run e1) (run e2) + | OpGt | OpGte | OpLt | OpLte -> (* type 2 *) + { eexpr = TBinop(op, compare_handler (run e1) (run e2), { eexpr = TConst(TInt(Int32.zero)); etype = gen.gcon.basic.tint; epos = e.epos} ); etype = gen.gcon.basic.tbool; epos = e.epos } + | OpMult | OpDiv | OpSub -> (* always cast everything to double *) + let etype, _ = get_etype_one e in + { e with eexpr = TBinop(op, mk_cast etype (run e1), mk_cast etype (run e2)) } + | OpBoolAnd | OpBoolOr -> + { e with eexpr = TBinop(op, mk_cast gen.gcon.basic.tbool (run e1), mk_cast gen.gcon.basic.tbool (run e2)) } + | OpAnd | OpOr | OpXor | OpShl | OpShr | OpUShr | OpMod -> + { e with eexpr = TBinop(op, mk_cast gen.gcon.basic.tint (run e1), mk_cast gen.gcon.basic.tint (run e2)) } + | OpAssign | OpAssignOp _ | OpInterval | OpArrow -> assert false) + | TUnop (Increment as op, flag, e1) + | TUnop (Decrement as op, flag, e1) when should_change e -> + (* + some naming definitions: + * ret => the returning variable + * _g => the get body + * getvar => the get variable expr + + This will work like this: + - if e1 is a TField, set _g = get body, getvar = (get body).varname + - if Prefix, return getvar = getvar + 1.0 + - if Postfix, set ret = getvar; getvar = getvar + 1.0; ret; + *) + let etype, one = get_etype_one e in + let op = (match op with Increment -> OpAdd | Decrement -> OpSub | _ -> assert false) in + + let tvars, getvar = + match e1.eexpr with + | TField(fexpr, field) -> + let tmp = mk_temp gen "getvar" fexpr.etype in + let tvars = [tmp, Some(run fexpr)] in + (tvars, { eexpr = TField( { fexpr with eexpr = TLocal(tmp) }, field); etype = etype; epos = e1.epos }) + | _ -> + ([], e1) + in + + (match flag with + | Prefix -> + let tvars = match tvars with + | [] -> [] + | _ -> [{ eexpr = TVars(tvars); etype = gen.gcon.basic.tvoid; epos = e.epos }] + in + let block = tvars @ + [ + mk_cast etype { e with eexpr = TBinop(OpAssign, getvar,{ eexpr = TBinop(op, mk_cast etype getvar, one); etype = etype; epos = e.epos }); etype = getvar.etype; } + ] in + { eexpr = TBlock(block); etype = etype; epos = e.epos } + | Postfix -> + let ret = mk_temp gen "ret" etype in + let tvars = { eexpr = TVars(tvars @ [ret, Some (mk_cast etype getvar)]); etype = gen.gcon.basic.tvoid; epos = e.epos } in + let retlocal = { eexpr = TLocal(ret); etype = etype; epos = e.epos } in + let block = tvars :: + [ + { e with eexpr = TBinop(OpAssign, getvar, { eexpr = TBinop(op, retlocal, one); etype = getvar.etype; epos = e.epos }) }; + retlocal + ] in + { eexpr = TBlock(block); etype = etype; epos = e.epos } + ) + | TUnop (op, flag, e1) when should_change e -> + let etype = match op with | Not -> gen.gcon.basic.tbool | _ -> gen.gcon.basic.tint in + mk_paren { eexpr = TUnop(op, flag, mk_cast etype (run e1)); etype = etype; epos = e.epos } + | _ -> Type.map_expr run e + in + run + + let configure gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:"dyn_ops" ~priority:(PCustom priority) map + + let configure_as_synf gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:"dyn_ops" ~priority:(PCustom priority_as_synf) map + +end;; + +(* ******************************************* *) +(* Closure Detection *) +(* ******************************************* *) + +(* + + Just a small utility filter that detects when a closure must be created. + On the default implementation, this means when a function field is being accessed + not via reflection and not to be called instantly + +*) + +module FilterClosures = +struct + + let priority = 0.0 + + let traverse gen (should_change:texpr->string->bool) (filter:texpr->texpr->string->bool->texpr) = + let rec run e = + match e.eexpr with + (*(* this is precisely the only case where we won't even ask if we should change, because it is a direct use of TClosure *) + | TCall ( {eexpr = TClosure(e1,s)} as clos, args ) -> + { e with eexpr = TCall({ clos with eexpr = TClosure(run e1, s) }, List.map run args ) } + | TCall ( clos, args ) -> + let rec loop clos = match clos.eexpr with + | TClosure(e1,s) -> Some (clos, e1, s) + | TParenthesis p -> loop p + | _ -> None + in + let clos = loop clos in + (match clos with + | Some (clos, e1, s) -> { e with eexpr = TCall({ clos with eexpr = TClosure(run e1, s) }, List.map run args ) } + | None -> Type.map_expr run e)*) + | TCall(({ eexpr = TField(_, _) } as ef), params) -> + { e with eexpr = TCall(Type.map_expr run ef, List.map run params) } + | TField(ef, FEnum(en, field)) -> + (* FIXME replace t_dynamic with actual enum Anon field *) + let ef = run ef in + (match follow field.ef_type with + | TFun _ when should_change ef field.ef_name -> + filter e ef field.ef_name true + | _ -> + { e with eexpr = TField(ef, FEnum(en,field)) } + ) + | TField(({ eexpr = TTypeExpr _ } as tf), f) -> + (match field_access gen tf.etype (field_name f) with + | FClassField(_,_,_,cf,_,_,_) -> + (match cf.cf_kind with + | Method(MethDynamic) + | Var _ -> + e + | _ when should_change tf cf.cf_name -> + filter e tf cf.cf_name true + | _ -> + e + ) + | _ -> e) + | TField(e1, FClosure (Some _, cf)) when should_change e1 cf.cf_name -> + (match cf.cf_kind with + | Method MethDynamic | Var _ -> + Type.map_expr run e + | _ -> + filter e (run e1) cf.cf_name false) + | _ -> Type.map_expr run e + in + run + + let configure gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:"closures_filter" ~priority:(PCustom priority) map + +end;; + +(* ******************************************* *) +(* Dynamic Field Access *) +(* ******************************************* *) + +(* + This module will filter every dynamic field access in haxe. + + On platforms that do not support dynamic access, it is with this that you should + replace dynamic calls with x.field / Reflect.setField calls, and guess what - + this is the default implemenation! + Actually there is a problem with Reflect.setField because it returns void, which is a bad thing for us, + so even in the default implementation, the function call should be specified to a Reflect.setField version that returns + the value that was set + + (TODO: should it be separated?) + As a plus, the default implementation adds something that doesn't hurt anybody, it looks for + TAnon with Statics / EnumStatics field accesses and transforms them into real static calls. + This means it will take this + + var m = Math; + for (i in 0...1000) m.cos(10); + + which is an optimization in dynamic platforms, but performs horribly on strongly typed platforms + and transform into: + + var m = Math; + for (i in 0...1000) Math.cos(10); + + (addendum:) + configure_generate_classes will already take care of generating the reflection-enabled class fields and calling abstract_implementation + with the right arguments. + + Also + + depends on: + (ok) must run AFTER Binop/Unop handler - so Unops / Binops are already unrolled +*) + +module DynamicFieldAccess = +struct + + let name = "dynamic_field_access" + + let priority = solve_deps name [DAfter DynamicOperators.priority] + + let priority_as_synf = solve_deps name [DAfter DynamicOperators.priority_as_synf] + + (* + is_dynamic (expr) (field_access_expr) (field) : a function that indicates if the field access should be changed + + change_expr (expr) (field_access_expr) (field) (setting expr) (is_unsafe) : changes the expression + call_expr (expr) (field_access_expr) (field) (call_params) : changes a call expression + *) + let abstract_implementation gen (is_dynamic:texpr->texpr->string->bool) (change_expr:texpr->texpr->string->texpr option->bool->texpr) (call_expr:texpr->texpr->string->texpr list->texpr) = + let rec run e = + match e.eexpr with + (* class types *) + | TField(fexpr, f) when is_some (anon_class fexpr.etype) -> + let decl = get (anon_class fexpr.etype) in + let name = field_name f in + (try + match decl with + | TClassDecl cl -> + let cf = PMap.find name cl.cl_statics in + { e with eexpr = TField({ fexpr with eexpr = TTypeExpr decl }, FStatic(cl, cf)) } + | TEnumDecl en -> + let ef = PMap.find name en.e_constrs in + { e with eexpr = TField({ fexpr with eexpr = TTypeExpr decl }, FEnum(en, ef)) } + | TAbstractDecl _ -> (* abstracts don't have TFields *) assert false + | TTypeDecl _ -> (* anon_class doesn't return TTypeDecl *) assert false + with + | Not_found -> + change_expr e { fexpr with eexpr = TTypeExpr decl } (field_name f) None true + ) + | TField(fexpr, f) when is_dynamic e fexpr (field_name f) -> + change_expr e (run fexpr) (field_name f) None true + | TCall( + { eexpr = TField(_, FStatic({ cl_path = ([], "Reflect") }, { cf_name = "field" })) } , + [obj; { eexpr = TConst(TString(field)) }] + ) -> + change_expr (mk_field_access gen obj field obj.epos) (run obj) field None false + | TCall( + { eexpr = TField(_, FStatic({ cl_path = ([], "Reflect") }, { cf_name = "setField" } )) }, + [obj; { eexpr = TConst(TString(field)) }; evalue] + ) -> + change_expr (mk_field_access gen obj field obj.epos) (run obj) field (Some (run evalue)) false + | TBinop(OpAssign, ({eexpr = TField(fexpr, f)}), evalue) when is_dynamic e fexpr (field_name f) -> + change_expr e (run fexpr) (field_name f) (Some (run evalue)) true + | TBinop(OpAssign, { eexpr = TField(fexpr, f) }, evalue) -> + (match field_access gen fexpr.etype (field_name f) with + | FClassField(_,_,_,cf,false,t,_) when (try PMap.find cf.cf_name gen.gbase_class_fields == cf with Not_found -> false) -> + change_expr e (run fexpr) (field_name f) (Some (run evalue)) true + | _ -> Type.map_expr run e + ) +(* #if debug *) + | TBinop(OpAssignOp op, ({eexpr = TField(fexpr, f)}), evalue) when is_dynamic e fexpr (field_name f) -> assert false (* this case shouldn't happen *) + | TUnop(Increment, _, ({eexpr = TField( ( { eexpr=TLocal(local) } as fexpr ), f)})) + | TUnop(Decrement, _, ({eexpr = TField( ( { eexpr=TLocal(local) } as fexpr ), f)})) when is_dynamic e fexpr (field_name f) -> assert false (* this case shouldn't happen *) +(* #end *) + | TCall( ({ eexpr = TField(fexpr, f) }), params ) when is_dynamic e fexpr (field_name f) -> + call_expr e (run fexpr) (field_name f) (List.map run params) + | _ -> Type.map_expr run e + in run + + (* + this function will already configure with the abstract implementation, and also will create the needed class fields to + enable reflection on platforms that don't support reflection. + + this means it will create the following class methods: + - getField(field, isStatic) - gets the value of the field. isStatic + - setField - + - + *) + let configure_generate_classes gen optimize (runtime_getset_field:texpr->texpr->string->texpr option->texpr) (runtime_call_expr:texpr->texpr->string->texpr list->texpr) = + () + + let configure gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:"dynamic_field_access" ~priority:(PCustom(priority)) map + + let configure_as_synf gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:"dynamic_field_access" ~priority:(PCustom(priority_as_synf)) map + +end;; + +(* ******************************************* *) +(* Dynamic TArray Handling *) +(* ******************************************* *) + +(* + In some languages you cannot overload the [] operator, + so we need to decide what is kept as TArray and what gets mapped. + + - in order to do this you must ensure that + + depends on: + (syntax) must run before expression/statment normalization because it may generate complex expressions + (ok) must run before binop transformations because it may generate some untreated binop ops + (ok) must run before dynamic field access is transformed into reflection +*) + +module TArrayTransform = +struct + + let name = "dyn_tarray" + + let priority = solve_deps name [DBefore DynamicOperators.priority; DBefore DynamicFieldAccess.priority] + + let priority_as_synf = solve_deps name [DBefore DynamicOperators.priority_as_synf; DBefore DynamicFieldAccess.priority_as_synf] + + let default_implementation gen (should_change:texpr->bool) (get_fun:string) (set_fun:string) = + let basic = gen.gcon.basic in + let mk_get e e1 e2 = + let efield = mk_field_access gen e1 get_fun e.epos in + { e with eexpr = TCall(efield, [e2]) } + in + let mk_set e e1 e2 evalue = + let efield = mk_field_access gen e1 set_fun e.epos in + { e with eexpr = TCall(efield, [e2; evalue]) } + in + let rec run e = + match e.eexpr with + | TArray(e1, e2) -> + (* e1 should always be a var; no need to map there *) + if should_change e then mk_get e (run e1) (run e2) else Type.map_expr run e + | TBinop (Ast.OpAssign, ({ eexpr = TArray(e1a,e2a) } as earray), evalue) when should_change earray -> + mk_set e (run e1a) (run e2a) (run evalue) + | TBinop (Ast.OpAssignOp op,({ eexpr = TArray(e1a,e2a) } as earray) , evalue) when should_change earray -> + (* cache all arguments in vars so they don't get executed twice *) + (* let ensure_local gen block name e = *) + let block = ref [] in + + let arr_local = ensure_local gen block "array" (run e1a) in + let idx_local = ensure_local gen block "index" (run e2a) in + block := (mk_set e arr_local idx_local ( { e with eexpr=TBinop(op, mk_get earray arr_local idx_local, run evalue) } )) :: !block; + + { e with eexpr = TBlock (List.rev !block) } + | TUnop(op, flag, ({ eexpr = TArray(e1a, e2a) } as earray)) -> + if should_change earray && match op with | Not | Neg -> false | _ -> true then begin + + let block = ref [] in + + let actual_t = match op with + | Ast.Increment | Ast.Decrement -> (match follow earray.etype with + | TInst _ | TAbstract _ | TEnum _ -> earray.etype + | _ -> basic.tfloat) + | Ast.Not -> basic.tbool + | _ -> basic.tint + in + + let val_v = mk_temp gen "arrVal" actual_t in + let ret_v = mk_temp gen "arrRet" actual_t in + + let arr_local = ensure_local gen block "arr" (run e1a) in + let idx_local = ensure_local gen block "arrIndex" (run e2a) in + + let val_local = { earray with eexpr = TLocal(val_v) } in + let ret_local = { earray with eexpr = TLocal(ret_v) } in + (* var idx = 1; var val = x._get(idx); var ret = val++; x._set(idx, val); ret; *) + block := { eexpr = TVars( + [ + val_v, Some(mk_get earray arr_local idx_local); (* var val = x._get(idx) *) + ret_v, Some { e with eexpr = TUnop(op, flag, val_local) } (* var ret = val++ *) + ]); + etype = gen.gcon.basic.tvoid; + epos = e2a.epos + } :: !block; + block := (mk_set e arr_local idx_local val_local) (*x._set(idx,val)*) :: !block; + block := ret_local :: !block; + { e with eexpr = TBlock (List.rev !block) } + end else + Type.map_expr run e + | _ -> Type.map_expr run e + + in run + + let configure gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:"dyn_tarray" ~priority:(PCustom priority) map + + let configure_as_synf gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:"dyn_tarray" ~priority:(PCustom priority_as_synf) map + +end;; + +(* ******************************************* *) +(* Try / Catch + throw native types handling *) +(* ******************************************* *) + +(* + + Some languages/vm's do not support throwing any kind of value. For them, only + special kinds of objects can be thrown. Because of this, we must wrap some throw + statements with an expression, and also we must unwrap it on the catch() phase, and + maybe manually test with Std.is() + + dependencies: + must run before dynamic field access (?) TODO review + It's a syntax filter, as it alters types (throw wrapper) + +*) + +module TryCatchWrapper = +struct + + let priority = solve_deps "try_catch" [DBefore DynamicFieldAccess.priority] + + (* + should_wrap : does the type should be wrapped? This of course works on the reverse way, so it tells us if the type should be unwrapped as well + wrap_throw : the wrapper for throw (throw expr->expr inside throw->returning wrapped expression) + unwrap_expr : the other way around : given the catch var (maybe will need casting to wrapper_type) , return the unwrap expr + rethrow_expr : how to rethrow ane exception in the platform + catchall_type : the class used for catchall (e:Dynamic) + wrapper_type : the wrapper type, so we can test if exception is of type 'wrapper' + catch_map : maps the catch expression to include some intialization code (e.g. setting up Stack.exceptionStack) + *) + let traverse gen (should_wrap:t->bool) (wrap_throw:texpr->texpr->texpr) (unwrap_expr:tvar->pos->texpr) (rethrow_expr:texpr->texpr) (catchall_type:t) (wrapper_type:t) (catch_map:tvar->texpr->texpr) = + let rec run e = + match e.eexpr with + | TThrow texpr when should_wrap texpr.etype -> wrap_throw e (run texpr) + | TTry (ttry, catches) -> + let nowrap_catches, must_wrap_catches, catchall = List.fold_left (fun (nowrap_catches, must_wrap_catches, catchall) (v, catch) -> + (* first we'll see if the type is Dynamic (catchall) *) + match follow v.v_type with + | TDynamic _ -> + assert (is_none catchall); + (nowrap_catches, must_wrap_catches, Some(v,catch_map v (run catch))) + (* see if we should unwrap it *) + | _ when should_wrap (follow v.v_type) -> + (nowrap_catches, (v,catch_map v (run catch)) :: must_wrap_catches, catchall) + | _ -> + ( (v,catch_map v (run catch)) :: nowrap_catches, must_wrap_catches, catchall ) + ) ([], [], None) catches + in + (* + 1st catch all nowrap "the easy way" + 2nd see if there are any must_wrap or catchall. If there is, + do a catchall first with a temp var. + then get catchall var (as dynamic) (or create one), and declare it = catchall exception + then test if it is of type wrapper_type. If it is, unwrap it + then start doing Std.is() tests for each catch type + if there is a catchall in the end, end with it. If there isn't, rethrow + *) + let dyn_catch = match (catchall, must_wrap_catches) with + | Some (v,c), _ + | _, (v, c) :: _ -> + let pos = c.epos in + let temp_var = mk_temp gen "catchallException" catchall_type in + let temp_local = { eexpr=TLocal(temp_var); etype = temp_var.v_type; epos = pos } in + let catchall_var = (*match catchall with + | None -> *) mk_temp gen "catchall" t_dynamic + (*| Some (v,_) -> v*) + in + let catchall_decl = { eexpr = TVars([catchall_var, Some(temp_local)]); etype=gen.gcon.basic.tvoid; epos = pos } in + let catchall_local = { eexpr = TLocal(catchall_var); etype = t_dynamic; epos = pos } in + (* if it is of type wrapper_type, unwrap it *) + let std_is = mk_static_field_access (get_cl (get_type gen ([],"Std"))) "is" (TFun(["v",false,t_dynamic;"cl",false,mt_to_t (get_type gen ([], "Class")) [t_dynamic]],gen.gcon.basic.tbool)) pos in + let mk_std_is t pos = { eexpr = TCall(std_is, [catchall_local; mk_mt_access (t_to_mt t) pos]); etype = gen.gcon.basic.tbool; epos = pos } in + + let if_is_wrapper_expr = { eexpr = TIf(mk_std_is wrapper_type pos, + { eexpr = TBinop(OpAssign, catchall_local, unwrap_expr temp_var pos); etype = t_dynamic; epos = pos } + , None); etype = gen.gcon.basic.tvoid; epos = pos } in + let rec loop must_wrap_catches = match must_wrap_catches with + | (vcatch,catch) :: tl -> + { eexpr = TIf(mk_std_is vcatch.v_type catch.epos, + { eexpr = TBlock({ eexpr=TVars([vcatch, Some(mk_cast vcatch.v_type catchall_local)]); etype=gen.gcon.basic.tvoid; epos=catch.epos } :: [catch] ); etype = catch.etype; epos = catch.epos }, + Some (loop tl)); + etype = catch.etype; epos = catch.epos } + | [] -> + match catchall with + | Some (v,s) -> + Codegen.concat { eexpr = TVars([v, Some(catchall_local)]); etype = gen.gcon.basic.tvoid; epos = pos } s + | None -> + mk_block (rethrow_expr temp_local) + in + [ ( temp_var, { e with eexpr = TBlock([ catchall_decl; if_is_wrapper_expr; loop must_wrap_catches ]) } ) ] + | _ -> + [] + in + { e with eexpr = TTry(run ttry, (List.rev nowrap_catches) @ dyn_catch) } + | _ -> 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:"try_catch" ~priority:(PCustom priority) map + +end;; + +let fun_args = List.map (function | (v,s) -> (v.v_name, (match s with | None -> false | Some _ -> true), v.v_type)) + +(* ******************************************* *) +(* Closures To Class *) +(* ******************************************* *) + +(* + + This is a very important filter. It will take all anonymous functions from the AST, will search for all captured variables, and will create a class + that implements an abstract interface for calling functions. This is very important for targets that don't support anonymous functions to work correctly. + Also it is possible to implement some strategies to avoid value type boxing, such as NaN tagging or double/object arguments. All this will be abstracted away + from this interface. + + + dependencies: + must run after dynamic field access, because of conflicting ways to deal with invokeField + (module filter) must run after OverloadingCtor so we can also change the dynamic function expressions + + uses TArray expressions for array. TODO see interaction + uses TThrow expressions. +*) + +module ClosuresToClass = +struct + + let name = "closures_to_class" + + let priority = solve_deps name [ DAfter DynamicFieldAccess.priority ] + + let priority_as_synf = solve_deps name [ DAfter DynamicFieldAccess.priority_as_synf ] + + type closures_ctx = + { + fgen : generator_ctx; + + mutable func_class : tclass; + + (* + this is what will actually turn the function into class field. + The standard implementation by default will already take care of creating the class, and setting the captured variables. + + It will also return the super arguments to be called + *) + mutable closure_to_classfield : tfunc->t->pos->tclass_field * (texpr list); + + (* + when a dynamic function call is made, we need to convert it as if it were calling the dynamic function interface. + + TCall expr -> new TCall expr + *) + mutable dynamic_fun_call : texpr->texpr; + + (* + called once so the implementation can make one of a time initializations in the base class + for all functions + *) + mutable initialize_base_class : tclass->unit; + + (* + Base classfields are the class fields for the abstract implementation of either the Function implementation, + or the invokeField implementation for the classes + They will either try to call the right function or will fail with + + (tclass - subject (so we know the type of this)) -> is_function_base -> additional arguments for each function (at the beginning) -> list of the abstract implementation class fields + *) + mutable get_base_classfields_for : tclass->bool->(unit->(tvar * tconstant option) list)->tclass_field list; + + (* + This is a more complex version of get_base_classfields_for. + It's meant to provide a toolchain so we can easily create classes that extend Function + and add more functionality on top of it. + + arguments: + tclass -> subject (so we know the type of this) + bool -> is it a function type + ( int -> (int->t->tconstant option->texpr) -> ( (tvar * tconstant option) list * texpr) ) + int -> current arity of the function whose member will be mapped; -1 for dynamic function. It is guaranteed that dynamic function will be called last + t -> the return type of the function + (int->t->tconstant option->texpr) -> api to get exprs that unwrap arguments correctly + int -> argument wanted to unwrap + t -> solicited type + tconstant option -> map to this default value if null + returns a texpr that tells how the default + should return a list with additional arguments (only works if is_function_base = true) + and the underlying function expression + *) + mutable map_base_classfields : tclass->bool->( int -> t -> (tvar list) -> (int->t->tconstant option->texpr) -> ( (tvar * tconstant option) list * texpr) )->tclass_field list; + + mutable transform_closure : texpr->texpr->string->texpr; + + } + + (* + the default implementation will take 3 transformation functions: + * one that will transform closures that are not called immediately (instance.myFunc). + normally on this case it's best to have a runtime handler that will take the instance, the function and call its invokeField when invoked + * one that will actually handle the anonymous functions themselves. + * one that will transform calling a dynamic function. So for example, dynFunc(arg1, arg2) might turn into dynFunc.apply2(arg1, arg2); + ( suspended ) * an option to match papplied functions + *) + + let traverse gen (transform_closure:texpr->texpr->string->texpr) (handle_anon_func:texpr->tfunc->texpr) (dynamic_func_call:texpr->texpr) e = + let rec run e = + match e.eexpr with + | TCall( { eexpr = TField(_, FEnum _) }, _ ) -> + Type.map_expr run e + (* if a TClosure is being call immediately, there's no need to convert it to a TClosure *) + | TCall(( { eexpr = TField(ecl,f) } as e1), params) -> + (* check to see if called field is known and if it is a MethNormal (only MethNormal fields can be called directly) *) + let name = field_name f in + (match field_access gen (gen.greal_type ecl.etype) name with + | FClassField(_,_,_,cf,_,_,_) -> + (match cf.cf_kind with + | Method MethNormal + | Method MethInline -> + { e with eexpr = TCall({ e1 with eexpr = TField(run ecl, f) }, List.map run params) } + | _ -> + match gen.gfollow#run_f e1.etype with + | TFun _ -> + dynamic_func_call { e with eexpr = TCall(run e1, List.map run params) } + | _ -> + let i = ref 0 in + let t = TFun(List.map (fun e -> incr i; "arg" ^ (string_of_int !i), false, e.etype) params, e.etype) in + dynamic_func_call { e with eexpr = TCall( mk_cast t (run e1), List.map run params ) } + ) + (* | FNotFound -> + { e with eexpr = TCall({ e1 with eexpr = TField(run ecl, f) }, List.map run params) } + (* expressions by now may have generated invalid expressions *) *) + | _ -> + match gen.gfollow#run_f e1.etype with + | TFun _ -> + dynamic_func_call { e with eexpr = TCall(run e1, List.map run params) } + | _ -> + let i = ref 0 in + let t = TFun(List.map (fun e -> incr i; "arg" ^ (string_of_int !i), false, e.etype) params, e.etype) in + dynamic_func_call { e with eexpr = TCall( mk_cast t (run e1), List.map run params ) } + ) + | TField(ecl, FClosure (_,cf)) -> + transform_closure e (run ecl) cf.cf_name + | TFunction tf -> + handle_anon_func e { tf with tf_expr = run tf.tf_expr } + | TCall({ eexpr = TConst(TSuper) }, _) -> + Type.map_expr run e + | TCall({ eexpr = TLocal(v) }, args) when String.get v.v_name 0 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name -> + Type.map_expr run e + | TCall(tc,params) -> + let i = ref 0 in + let may_cast = match gen.gfollow#run_f tc.etype with + | TFun _ -> fun e -> e + | _ -> + let t = TFun(List.map (fun e -> + incr i; + ("p" ^ (string_of_int !i), false, e.etype) + ) params, e.etype) + in + fun e -> mk_cast t e + in + dynamic_func_call { e with eexpr = TCall(run (may_cast tc), List.map run params) } + | _ -> Type.map_expr run e + in + + (match e.eexpr with + | TFunction(tf) -> Type.map_expr run e + | _ -> run e) + + let rec get_type_params acc t = + match t with + | TInst(( { cl_kind = KTypeParameter _ } as cl), []) -> + if List.memq cl acc then acc else cl :: acc + | TFun (params,tret) -> + List.fold_left get_type_params acc ( tret :: List.map (fun (_,_,t) -> t) params ) + | TDynamic t -> + (match t with | TDynamic _ -> acc | _ -> get_type_params acc t) + | TAbstract ({ a_impl = Some _ } as a, pl) -> + get_type_params acc ( Codegen.Abstract.get_underlying_type a pl) + | TAnon a -> + PMap.fold (fun cf acc -> get_type_params acc cf.cf_type) a.a_fields acc + | TType(_, []) + | TAbstract (_, []) + | TInst(_, []) + | TEnum(_, []) -> + acc + | TType(_, params) + | TAbstract(_, params) + | TEnum(_, params) + | TInst(_, params) -> + List.fold_left get_type_params acc params + | TMono r -> (match !r with + | Some t -> get_type_params acc t + | None -> acc) + | _ -> get_type_params acc (follow_once t) + + let get_captured expr = + let ret = Hashtbl.create 1 in + let ignored = Hashtbl.create 0 in + + let params = ref [] in + let check_params t = params := get_type_params !params t in + let rec traverse expr = + match expr.eexpr with + | TFor (v, _, _) -> + Hashtbl.add ignored v.v_id v; + check_params v.v_type; + Type.iter traverse expr + | TFunction(tf) -> + List.iter (fun (v,_) -> check_params v.v_type; Hashtbl.add ignored v.v_id v) tf.tf_args; + check_params tf.tf_type; + Type.iter traverse expr + | TVars (vars) -> + List.iter (fun (v, opt) -> check_params v.v_type; Hashtbl.add ignored v.v_id v; ignore(Option.map traverse opt)) vars; + | TLocal(( { v_capture = true } ) as v) -> + (if not (Hashtbl.mem ignored v.v_id || Hashtbl.mem ret v.v_id) then begin check_params v.v_type; Hashtbl.replace ret v.v_id expr end); + | _ -> Type.iter traverse expr + in traverse expr; + ret, !params + + (* + OPTIMIZEME: + + Take off from Codegen the code that wraps captured variables, + + traverse through all variables, looking for their use (just like local_usage) + three possible outcomes for captured variables: + - become a function member variable <- best performance. + Will not work on functions that can be created more than once (functions inside a loop or functions inside functions) + The function will have to be created on top of the block, so its variables can be filled in instead of being declared + - single-element array - the most compatible way, though also creates a slight overhead. + - we'll have some labels for captured variables: + - used in loop + *) + + (* + The default implementation will impose a naming convention: + invoke(arity)_(o for returning object/d for returning double) when arity < max_arity + invoke_dynamic_(o/d) when arity > max_arity + + This means that it also imposes that the dynamic function return types may only be Dynamic or Float, and all other basic types must be converted to/from it. + *) + + let default_implementation ft parent_func_class (* e.g. new haxe.lang.ClassClosure *) = + let gen = ft.fgen in + ft.initialize_base_class parent_func_class; + let cfs = ft.get_base_classfields_for parent_func_class true (fun () -> []) in + List.iter (fun cf -> + (if cf.cf_name = "new" then parent_func_class.cl_constructor <- Some cf else + parent_func_class.cl_fields <- PMap.add cf.cf_name cf parent_func_class.cl_fields + ) + ) cfs; + + parent_func_class.cl_ordered_fields <- (List.filter (fun cf -> cf.cf_name <> "new") cfs) @ parent_func_class.cl_ordered_fields; + + ft.func_class <- parent_func_class; + + traverse + ft.fgen + (* (transform_closure:texpr->texpr->string->texpr) (handle_anon_func:texpr->tfunc->texpr) (dynamic_func_call:texpr->texpr->texpr list->texpr) *) + ft.transform_closure + (fun fexpr tfunc -> (* (handle_anon_func:texpr->tfunc->texpr) *) + (* get all captured variables it uses *) + let captured_ht, tparams = get_captured fexpr in + let captured = Hashtbl.fold (fun _ e acc -> e :: acc) captured_ht [] in + + (*let cltypes = List.map (fun cl -> (snd cl.cl_path, TInst(map_param cl, []) )) tparams in*) + let cltypes = List.map (fun cl -> (snd cl.cl_path, TInst(cl, []) )) tparams in + + (* create a new class that extends abstract function class, with a ctor implementation that will setup all captured variables *) + let buf = Buffer.create 72 in + ignore (Type.map_expr (fun e -> + Buffer.add_string buf (Marshal.to_string (ExprHashtblHelper.mk_type e) [Marshal.Closures]); + e + ) tfunc.tf_expr); + let digest = Digest.to_hex (Digest.string (Buffer.contents buf)) in + let path = (fst ft.fgen.gcurrent_path, "Fun_" ^ (String.sub digest 0 8)) in + let cls = mk_class (get ft.fgen.gcurrent_class).cl_module path tfunc.tf_expr.epos in + cls.cl_module <- (get ft.fgen.gcurrent_class).cl_module; + cls.cl_types <- cltypes; + + let mk_this v pos = + { + (mk_field_access gen { eexpr = TConst TThis; etype = TInst(cls, List.map snd cls.cl_types); epos = pos } v.v_name pos) + with etype = v.v_type + } + in + + let mk_this_assign v pos = + { + eexpr = TBinop(OpAssign, mk_this v pos, { eexpr = TLocal(v); etype = v.v_type; epos = pos }); + etype = v.v_type; + epos = pos + } in + + (* mk_class_field name t public pos kind params *) + let ctor_args, ctor_sig, ctor_exprs = List.fold_left (fun (ctor_args, ctor_sig, ctor_exprs) lexpr -> + match lexpr.eexpr with + | TLocal(v) -> + let cf = mk_class_field v.v_name v.v_type false lexpr.epos (Var({ v_read = AccNormal; v_write = AccNormal; })) [] in + cls.cl_fields <- PMap.add v.v_name cf cls.cl_fields; + cls.cl_ordered_fields <- cf :: cls.cl_ordered_fields; + + let ctor_v = alloc_var v.v_name v.v_type in + ((ctor_v, None) :: ctor_args, (v.v_name, false, v.v_type) :: ctor_sig, (mk_this_assign v cls.cl_pos) :: ctor_exprs) + | _ -> assert false + ) ([],[],[]) captured in + + (* change all captured variables to this.capturedVariable *) + let rec change_captured e = + match e.eexpr with + | TLocal( ({ v_capture = true }) as v ) when Hashtbl.mem captured_ht v.v_id -> + mk_this v e.epos + | _ -> Type.map_expr change_captured e + in + let func_expr = change_captured tfunc.tf_expr in + + let invoke_field, super_args = ft.closure_to_classfield { tfunc with tf_expr = func_expr } fexpr.etype fexpr.epos in + + + (* create the constructor *) + (* todo properly abstract how type var is set *) + + cls.cl_super <- Some(parent_func_class, []); + let pos = cls.cl_pos in + let super_call = + { + eexpr = TCall({ eexpr = TConst(TSuper); etype = TInst(parent_func_class,[]); epos = pos }, super_args); + etype = ft.fgen.gcon.basic.tvoid; + epos = pos; + } in + + let ctor_type = (TFun(ctor_sig, ft.fgen.gcon.basic.tvoid)) in + let ctor = mk_class_field "new" ctor_type true cls.cl_pos (Method(MethNormal)) [] in + ctor.cf_expr <- Some( + { + eexpr = TFunction( + { + tf_args = ctor_args; + tf_type = ft.fgen.gcon.basic.tvoid; + tf_expr = { eexpr = TBlock(super_call :: ctor_exprs); etype = ft.fgen.gcon.basic.tvoid; epos = cls.cl_pos } + }); + etype = ctor_type; + epos = cls.cl_pos; + }); + cls.cl_constructor <- Some(ctor); + + (* add invoke function to the class *) + cls.cl_ordered_fields <- invoke_field :: cls.cl_ordered_fields; + cls.cl_fields <- PMap.add invoke_field.cf_name invoke_field cls.cl_fields; + cls.cl_overrides <- invoke_field :: cls.cl_overrides; + + (* add this class to the module with gadd_to_module *) + ft.fgen.gadd_to_module (TClassDecl(cls)) priority; + + (* if there are no captured variables, we can create a cache so subsequent calls don't need to create a new function *) + match captured, tparams with + | [], [] -> + let cache_var = ft.fgen.gmk_internal_name "hx" "current" in + let cache_cf = mk_class_field cache_var (TInst(cls,[])) false func_expr.epos (Var({ v_read = AccNormal; v_write = AccNormal })) [] in + cls.cl_ordered_statics <- cache_cf :: cls.cl_ordered_statics; + cls.cl_statics <- PMap.add cache_var cache_cf cls.cl_statics; + + (* if (FuncClass.hx_current != null) FuncClass.hx_current; else (FuncClass.hx_current = new FuncClass()); *) + + (* let mk_static_field_access cl field fieldt pos = *) + let hx_current = mk_static_field_access cls cache_var (TInst(cls,[])) func_expr.epos in + + let pos = func_expr.epos in + { + fexpr with + + eexpr = TIf( + { + eexpr = TBinop(OpNotEq, hx_current, null (TInst(cls,[])) pos); + etype = ft.fgen.gcon.basic.tbool; + epos = pos; + }, + + hx_current, + + Some( + { + eexpr = TBinop(OpAssign, hx_current, { fexpr with eexpr = TNew(cls, [], captured) }); + etype = (TInst(cls,[])); + epos = pos; + })) + + } + + | _ -> + (* change the expression so it will be a new "added class" ( captured variables arguments ) *) + { fexpr with eexpr = TNew(cls, List.map (fun cl -> TInst(cl,[])) tparams, List.rev captured) } + + + ) + ft.dynamic_fun_call + (* (dynamic_func_call:texpr->texpr->texpr list->texpr) *) + + + let configure gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map + + let configure_as_synf gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority_as_synf) map + + + (* + this submodule will provide the default implementation for the C# and Java targets. + + it will have two return types: double and dynamic, and + *) + module DoubleAndDynamicClosureImpl = + struct + + let get_ctx gen max_arity = + + let basic = gen.gcon.basic in + + let func_args_i i = + + let rec loop i (acc1,acc2) = + if i = 0 then (acc1,acc2) else begin + let vfloat = alloc_var (gen.gmk_internal_name "fn" ("float" ^ string_of_int i)) basic.tfloat in + let vdyn = alloc_var (gen.gmk_internal_name "fn" ("dyn" ^ string_of_int i)) t_dynamic in + + loop (i - 1) ((vfloat, None) :: acc1 , (vdyn, None) :: acc2) + end + in + let acc1, acc2 = loop i ([],[]) in + acc1 @ acc2 + + in + + let args_real_to_func args = + + let arity = List.length args in + if arity >= max_arity then + [ alloc_var (gen.gmk_internal_name "fn" "dynargs") (basic.tarray t_dynamic), None ] + else func_args_i arity + in + + let func_sig_i i = + + let rec loop i (acc1,acc2) = + if i = 0 then (acc1,acc2) else begin + let vfloat = gen.gmk_internal_name "fn" ("float" ^ string_of_int i) in + let vdyn = gen.gmk_internal_name "fn" ("dyn" ^ string_of_int i) in + + loop (i - 1) ((vfloat, false, basic.tfloat) :: acc1 , (vdyn, false, t_dynamic) :: acc2) + end + in + let acc1, acc2 = loop i ([],[]) in + acc1 @ acc2 + + in + + let args_real_to_func_sig args = + + let arity = List.length args in + if arity >= max_arity then + [gen.gmk_internal_name "fn" "dynargs", false, basic.tarray t_dynamic] + else begin + func_sig_i arity + end + + in + + let rettype_real_to_func t = + if like_float t then + (1, basic.tfloat) + else + (0, t_dynamic) + in + + let args_real_to_func_call el (pos:Ast.pos) = + if List.length el >= max_arity then + [{ eexpr = TArrayDecl el; etype = basic.tarray t_dynamic; epos = pos }] + else begin + let acc1,acc2 = List.fold_left (fun (acc_f,acc_d) e -> + if like_float (gen.greal_type e.etype) then + ( e :: acc_f, undefined e.epos :: acc_d ) + else + ( null basic.tfloat e.epos :: acc_f, e :: acc_d ) + ) ([],[]) (List.rev el) in + acc1 @ acc2 + end + in + + let const_type c def = + match c with + | TString _ -> basic.tstring | TInt _ -> basic.tint + | TFloat _ -> basic.tfloat | TBool _ -> basic.tbool + | _ -> def + in + + let get_args_func args changed_args pos = + let arity = List.length args in + let mk_const const elocal t = + match const with + | None -> mk_cast t elocal + | Some const -> + { eexpr = TIf( + { elocal with eexpr = TBinop(Ast.OpEq, elocal, null elocal.etype elocal.epos); etype = basic.tbool }, + { elocal with eexpr = TConst(const); etype = const_type const t }, + Some ( mk_cast t elocal ) + ); etype = t; epos = elocal.epos } + in + + if arity >= max_arity then begin + let varray = match changed_args with | [v,_] -> v | _ -> assert false in + let varray_local = mk_local varray pos in + let mk_varray i = { eexpr = TArray(varray_local, { eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos }); etype = t_dynamic; epos = pos } in + + snd (List.fold_left (fun (count,acc) (v,const) -> + (count + 1, + { + eexpr = TVars([v, Some(mk_const const ( mk_varray count ) v.v_type)]); + etype = basic.tvoid; + epos = pos; + } :: acc) + ) (0,[]) args) + end else begin + let _, dyn_args, float_args = List.fold_left (fun (count,fargs, dargs) arg -> + if count > arity then + (count + 1, fargs, arg :: dargs) + else + (count + 1, arg :: fargs, dargs) + ) (1,[],[]) (List.rev changed_args) in + + let rec loop acc args fargs dargs = + match args, fargs, dargs with + | [], [], [] -> acc + | (v,const) :: args, (vf,_) :: fargs, (vd,_) :: dargs -> + let acc = { eexpr = TVars([ v, Some( + { + eexpr = TIf( + { eexpr = TBinop(Ast.OpEq, mk_local vd pos, undefined pos); etype = basic.tbool; epos = pos }, + mk_cast v.v_type (mk_local vf pos), + Some ( mk_const const (mk_local vd pos) v.v_type ) + ); + etype = v.v_type; + epos = pos + } ) ]); etype = basic.tvoid; epos = pos } :: acc in + loop acc args fargs dargs + | _ -> assert false + in + + loop [] args float_args dyn_args + end + in + + let closure_to_classfield tfunc old_sig pos = + (* change function signature *) + let old_args = tfunc.tf_args in + let changed_args = args_real_to_func old_args in + + (* + FIXME properly handle int64 cases, which will break here (because of inference to int) + UPDATE: the fix will be that Int64 won't be a typedef to Float/Int + *) + let changed_sig, arity, type_number, changed_sig_ret, is_void, is_dynamic_func = match follow old_sig with + | TFun(_sig, ret) -> + let type_n, ret_t = rettype_real_to_func ret in + let arity = List.length _sig in + let is_dynamic_func = arity >= max_arity in + let ret_t = if is_dynamic_func then t_dynamic else ret_t in + + (TFun(args_real_to_func_sig _sig, ret_t), arity, type_n, ret_t, is_void ret, is_dynamic_func) + | _ -> (trace (s_type (print_context()) (follow old_sig) )); assert false + in + + let tf_expr = if is_void then begin + let rec map e = + match e.eexpr with + | TReturn None -> { e with eexpr = TReturn (Some (null t_dynamic e.epos)) } + | _ -> Type.map_expr map e + in + let e = mk_block (map tfunc.tf_expr) in + match e.eexpr with + | TBlock(bl) -> + { e with eexpr = TBlock(bl @ [{ eexpr = TReturn (Some (null t_dynamic e.epos)); etype = t_dynamic; epos = e.epos }]) } + | _ -> assert false + end else tfunc.tf_expr in + + let changed_sig_ret = if is_dynamic_func then t_dynamic else changed_sig_ret in + + (* get real arguments on top of function body *) + let get_args = get_args_func tfunc.tf_args changed_args pos in + (* + FIXME HACK: in order to be able to run the filters that have already ran for this piece of code, + we will cheat and run it as if it was the whole code + We could just make ClosuresToClass run before TArrayTransform, but we cannot because of the + dependency between ClosuresToClass (after DynamicFieldAccess, and before TArrayTransform) + + maybe a way to solve this would be to add an "until" field to run_from + *) + let real_get_args = gen.gexpr_filters#run_f { eexpr = TBlock(get_args); etype = basic.tvoid; epos = pos } in + + let func_expr = Codegen.concat real_get_args tf_expr in + + (* set invoke function *) + (* todo properly abstract how naming for invoke is made *) + let invoke_name = if is_dynamic_func then "invokeDynamic" else ("invoke" ^ (string_of_int arity) ^ (if type_number = 0 then "_o" else "_f")) in + let invoke_name = gen.gmk_internal_name "hx" invoke_name in + let invoke_field = mk_class_field invoke_name changed_sig false func_expr.epos (Method(MethNormal)) [] in + let invoke_fun = + { + eexpr = TFunction( + { + tf_args = changed_args; + tf_type = changed_sig_ret; + tf_expr = func_expr; + }); + etype = changed_sig; + epos = func_expr.epos; + } in + invoke_field.cf_expr <- Some(invoke_fun); + + (invoke_field, [ + { eexpr = TConst(TInt( Int32.of_int arity )); etype = gen.gcon.basic.tint; epos = pos }; + { eexpr = TConst(TInt( Int32.of_int type_number )); etype = gen.gcon.basic.tint; epos = pos }; + ]) + in + + let dynamic_fun_call call_expr = + let tc, params = match call_expr.eexpr with + | TCall(tc, params) -> (tc, params) + | _ -> assert false + in + let postfix, ret_t = + if like_float (gen.greal_type call_expr.etype) then + "_f", gen.gcon.basic.tfloat + else + "_o", t_dynamic + in + let params_len = List.length params in + let ret_t = if params_len >= max_arity then t_dynamic else ret_t in + + let invoke_fun = if params_len >= max_arity then "invokeDynamic" else "invoke" ^ (string_of_int params_len) ^ postfix in + let invoke_fun = gen.gmk_internal_name "hx" invoke_fun in + let fun_t = match follow tc.etype with + | TFun(_sig, _) -> + TFun(args_real_to_func_sig _sig, ret_t) + | _ -> + let i = ref 0 in + let _sig = List.map (fun p -> let name = "arg" ^ (string_of_int !i) in incr i; (name,false,p.etype) ) params in + TFun(args_real_to_func_sig _sig, ret_t) + in + + let may_cast = match follow call_expr.etype with + | TEnum({ e_path = ([], "Void")}, []) + | TAbstract ({ a_path = ([], "Void") },[]) -> (fun e -> e) + | _ -> mk_cast call_expr.etype + in + + may_cast + { + eexpr = TCall( + { (mk_field_access gen { tc with etype = gen.greal_type tc.etype } invoke_fun tc.epos) with etype = fun_t }, + args_real_to_func_call params call_expr.epos + ); + etype = ret_t; + epos = call_expr.epos + } + in + + let iname is_function i is_float = + let postfix = if is_float then "_f" else "_o" in + gen.gmk_internal_name "hx" ("invoke" ^ (if not is_function then "Field" else "") ^ string_of_int i) ^ postfix + in + + let map_base_classfields cl is_function map_fn = + + let pos = cl.cl_pos in + let this_t = TInst(cl,List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + + let mk_invoke_i i is_float = + let cf = mk_class_field (iname is_function i is_float) (TFun(func_sig_i i, if is_float then basic.tfloat else t_dynamic)) false pos (Method MethNormal) [] in + cf + in + + let type_name = gen.gmk_internal_name "fn" "type" in + + let dynamic_arg = alloc_var (gen.gmk_internal_name "fn" "dynargs") (basic.tarray t_dynamic) in + + let mk_invoke_complete_i i is_float = + + let arity = i in + let args = func_args_i i in + + (* api fn *) + + (* only cast if needed *) + let mk_cast tto efrom = gen.ghandle_cast (gen.greal_type tto) (gen.greal_type efrom.etype) efrom in + let api i t const = + let vf, _ = List.nth args i in + let vo, _ = List.nth args (i + arity) in + + let needs_cast, is_float = match t, like_float t with + | TInst({ cl_path = ([], "Float") }, []), _ + | TAbstract({ a_path = ([], "Float") },[]), _ -> false, true + | _, true -> true, true + | _ -> false,false + in + + let olocal = mk_local vo pos in + let flocal = mk_local vf pos in + + let get_from_obj e = match const with + | None -> mk_cast t e + | Some tc -> + { + eexpr = TIf( + { eexpr = TBinop(Ast.OpEq, olocal, null t_dynamic pos); etype = basic.tbool; epos = pos } , + { eexpr = TConst(tc); etype = t; epos = pos }, + Some (mk_cast t e) + ); + etype = t; + epos = pos; + } + in + + { + eexpr = TIf( + { eexpr = TBinop(Ast.OpEq, olocal, undefined pos); etype = basic.tbool; epos = pos }, + (if needs_cast then mk_cast t flocal else flocal), + Some ( get_from_obj olocal ) + ); + etype = t; + epos = pos + } + in + (* end of api fn *) + + let ret = if is_float then basic.tfloat else t_dynamic in + + let added_args, fn_expr = map_fn i ret (List.map fst args) api in + let args = added_args @ args in + + let t = TFun(fun_args args, ret) in + + let tfunction = + { + eexpr = TFunction({ + tf_args = args; + tf_type = ret; + tf_expr = + mk_block fn_expr + }); + etype = t; + epos = pos; + } + in + + let cf = mk_invoke_i i is_float in + cf.cf_expr <- Some tfunction; + cf + in + + let rec loop i cfs = + if i < 0 then cfs else begin + (*let mk_invoke_complete_i i is_float =*) + (mk_invoke_complete_i i false) :: (mk_invoke_complete_i i true) :: (loop (i-1) cfs) + end + in + + let cfs = loop max_arity [] in + + let added_s_args, switch = + let api i t const = + match i with + | -1 -> + mk_local dynamic_arg pos + | _ -> + mk_cast t { + eexpr = TArray( + mk_local dynamic_arg pos, + { eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos }); + etype = t; + epos = pos; + } + in + map_fn (-1) t_dynamic [dynamic_arg] api + in + + let args = added_s_args @ [dynamic_arg, None] in + let dyn_t = TFun(fun_args args, t_dynamic) in + let dyn_cf = mk_class_field (gen.gmk_internal_name "hx" "invokeDynamic") dyn_t false pos (Method MethNormal) [] in + + dyn_cf.cf_expr <- + Some { + eexpr = TFunction({ + tf_args = args; + tf_type = t_dynamic; + tf_expr = mk_block switch + }); + etype = dyn_t; + epos = pos; + }; + + let additional_cfs = if is_function then begin + let new_t = TFun(["arity", false, basic.tint; "type", false, basic.tint],basic.tvoid) in + let new_cf = mk_class_field "new" (new_t) true pos (Method MethNormal) [] in + let v_arity, v_type = alloc_var "arity" basic.tint, alloc_var "type" basic.tint in + let mk_assign v field = { eexpr = TBinop(Ast.OpAssign, mk_this field v.v_type, mk_local v pos); etype = v.v_type; epos = pos } in + + let arity_name = gen.gmk_internal_name "hx" "arity" in + new_cf.cf_expr <- + Some { + eexpr = TFunction({ + tf_args = [v_arity, None; v_type, None]; + tf_type = basic.tvoid; + tf_expr = + { + eexpr = TBlock([ + mk_assign v_type type_name; + mk_assign v_arity arity_name + ]); + etype = basic.tvoid; + epos = pos; + } + }); + etype = new_t; + epos = pos; + } + ; + + [ + new_cf; + mk_class_field type_name basic.tint true pos (Var { v_read = AccNormal; v_write = AccNormal }) []; + mk_class_field arity_name basic.tint true pos (Var { v_read = AccNormal; v_write = AccNormal }) []; + ] + end else [] in + + dyn_cf :: (additional_cfs @ cfs) + in + + (* maybe another param for prefix *) + let get_base_classfields_for cl is_function mk_additional_args = + let pos = cl.cl_pos in + + let this_t = TInst(cl,List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + + let rec mk_dyn_call arity api = + let zero = { eexpr = TConst(TFloat("0.0")); etype = basic.tfloat; epos = pos } in + let rec loop i (acc1,acc2) = + if i = 0 then (acc1,acc2) else begin + let arr = api (i-1) t_dynamic None in + loop (i - 1) (zero :: acc1, arr :: acc2) + end + in + let acc1, acc2 = loop arity ([],[]) in + acc1 @ acc2 + in + + let mk_invoke_switch i (api:(int->t->tconstant option->texpr)) = + + let t = TFun(func_sig_i i,t_dynamic) in + + (* case i: return this.invokeX_o(0, 0, 0, 0, 0, ... arg[0], args[1]....); *) + ( [{ eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos }], + { + eexpr = TReturn(Some( { + eexpr = TCall(mk_this (iname is_function i false) t, mk_dyn_call i api); + etype = t_dynamic; + epos = pos; + } )); + etype = t_dynamic; + epos = pos; + } ) + in + + let cl_t = TInst(cl,List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = cl_t; epos = pos } in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + let mk_int i = { eexpr = TConst(TInt ( Int32.of_int i)); etype = basic.tint; epos = pos } in + let mk_string s = { eexpr = TConst(TString s); etype = basic.tstring; epos = pos } in + + (* + if it is the Function class, the base class fields will be + * hx::invokeX_d|o (where X is from 0 to max_arity) (args) + { + if (this.type == 0|1) return invokeX_o|d(args); else throw "Invalid number of arguments." + } + + hx::invokeDynamic, which will work in the same way + + new(arity, type) + { + if (type != 0 && type != 1) throw "Invalid type"; + this.arity = arity; + this.type = type; + } + *) + let type_name = gen.gmk_internal_name "fn" "type" in + + let mk_expr i is_float vars = + + let name = if is_function then "invoke" else "invokeField" in + + let look_ahead = alloc_var "lookAhead" basic.tbool in + let add_args = if not is_function then mk_additional_args() else [] in + let vars = if not is_function then (List.map fst add_args) @ (look_ahead :: vars) else vars in + + let call_expr = + + let call_t = TFun(List.map (fun v -> (v.v_name, false, v.v_type)) vars, if is_float then t_dynamic else basic.tfloat) in + { + eexpr = TCall(mk_this (gen.gmk_internal_name "hx" (name ^ (string_of_int i) ^ (if is_float then "_o" else "_f"))) call_t, List.map (fun v -> if v.v_id = look_ahead.v_id then ( { eexpr = TConst(TBool false); etype = basic.tbool; epos = pos } ) else mk_local v pos) vars ); + etype = if is_float then t_dynamic else basic.tfloat; + epos = pos + } + in + (*let call_expr = if is_float then mk_cast basic.tfloat call_expr else call_expr in*) + + let if_cond = if is_function then + { eexpr=TBinop(Ast.OpNotEq, mk_this type_name basic.tint, mk_int (if is_float then 0 else 1) ); etype = basic.tbool; epos = pos } + else + mk_local look_ahead pos + in + + let if_expr = if is_function then + { + eexpr = TIf(if_cond, + { eexpr = TThrow(mk_string "Wrong number of arguments"); etype = basic.tstring; epos = pos }, + Some( { eexpr = TReturn( Some( call_expr ) ); etype = call_expr.etype; epos = pos } ) + ); + etype = t_dynamic; + epos = pos; + } + else + { + eexpr = TIf(if_cond, + { eexpr = TReturn( Some( call_expr ) ); etype = call_expr.etype; epos = pos }, + Some( { eexpr = TThrow(mk_string "Field not found or wrong number of arguments"); etype = basic.tstring; epos = pos } ) + ); + etype = t_dynamic; + epos = pos; + } + in + + let args = if not is_function then (mk_additional_args()) @ [look_ahead, None] else [] in + (args, if_expr) + in + + let arities_processed = Hashtbl.create 10 in + let max_arity = ref 0 in + + let rec loop_cases api arity acc = + if arity < 0 then acc else + loop_cases api (arity - 1) (mk_invoke_switch arity api :: acc) + in + (* let rec loop goes here *) + let map_fn cur_arity fun_ret_type vars (api:(int->t->tconstant option->texpr)) = + let is_float = like_float fun_ret_type in + match cur_arity with + | -1 -> + let dynargs = api (-1) (t_dynamic) None in + let switch_cond = mk_field_access gen dynargs "length" pos in + let switch_cond = { + eexpr = TIf( + { eexpr = TBinop(Ast.OpEq, dynargs, null dynargs.etype pos); etype = basic.tbool; epos = pos; }, + { eexpr = TConst(TInt(Int32.zero)); etype = basic.tint; epos = pos }, + Some switch_cond); + etype = basic.tint; + epos = pos; + } in + + let switch = + { + eexpr = TSwitch( switch_cond, + loop_cases api !max_arity [], + Some({ eexpr = TThrow(mk_string "Too many arguments"); etype = basic.tvoid; epos = pos; }) ); + etype = basic.tvoid; + epos = pos; + } in + + ( (if not is_function then mk_additional_args () else []), switch ) + | _ -> + if not (Hashtbl.mem arities_processed cur_arity) then begin + Hashtbl.add arities_processed cur_arity true; + if cur_arity > !max_arity then max_arity := cur_arity + end; + + mk_expr cur_arity is_float vars + in + + map_base_classfields cl is_function map_fn + in + + let initialize_base_class cl = + () + in + + { + fgen = gen; + + func_class = null_class; + + closure_to_classfield = closure_to_classfield; + + dynamic_fun_call = dynamic_fun_call; + + (* + called once so the implementation can make one of a time initializations in the base class + for all functions + *) + initialize_base_class = initialize_base_class; + + (* + Base classfields are the class fields for the abstract implementation of either the Function implementation, + or the invokeField implementation for the classes + They will either try to call the right function or will fail with + + (tclass - subject (so we know the type of this)) -> is_function_base -> list of the abstract implementation class fields + *) + get_base_classfields_for = get_base_classfields_for; + + map_base_classfields = map_base_classfields; + + (* + for now we won't deal with the closures. + They can be dealt with the module ReflectionCFs, + or a custom implementation + *) + transform_closure = (fun tclosure texpr str -> tclosure); + + } + + end;; + +end;; + +(* ******************************************* *) +(* Type Parameters *) +(* ******************************************* *) + +(* + + This module will handle type parameters. There are lots of changes we need to do to correctly support type parameters: + + traverse will: + V Detect when parameterized function calls are made + * Detect when a parameterized class instance is being cast to another parameter + * Change new<> parameterized function calls + * + + extras: + * On languages that support "real" type parameters, a Cast function is provided that will convert from a to the requested type. + This cast will call createEmpty with the correct type, and then set each variable to the new form. Some types will be handled specially, namely the Native Array. + Other implementations may be delegated to the runtime. + * parameterized classes will implement a new interface (with only a Cast<> function added to it), so we can access the type parameter for them. Also any reference to will be replaced by a reference to this interface. (also on TTypeExpr - Std.is()) + * Type parameter renaming to avoid name clash + * Detect type parameter casting and call Cast<> instead + + for java: + * for specially assigned classes, parameters will be replaced by _d and _i versions of parameterized functions. This will only work for parameterized classes, not functions. + + dependencies: + must run after casts are detected. This will be ensured at CastDetect module. + +*) + +module TypeParams = +struct + + let name = "type_params" + + let priority = max_dep -. 20. + + (* this function will receive the original function argument, the applied function argument and the original function parameters. *) + (* from this info, it will infer the applied tparams for the function *) + (* this function is used by CastDetection module *) + let infer_params gen pos (original_args:((string * bool * t) list * t)) (applied_args:((string * bool * t) list * t)) (params:(string * t) list) calls_parameters_explicitly : tparams = + match params with + | [] -> [] + | _ -> + let args_list args = (if not calls_parameters_explicitly then t_dynamic else snd args) :: (List.map (fun (n,o,t) -> t) (fst args)) in + + let monos = List.map (fun _ -> mk_mono()) params in + let original = args_list (get_fun (apply_params params monos (TFun(fst original_args,snd original_args)))) in + let applied = args_list applied_args in + + (try + List.iter2 (fun a o -> + unify a o + (* type_eq EqStrict a o *) + ) applied original + (* unify applied original *) + with | Unify_error el -> + (* List.iter (fun el -> gen.gcon.warning (Typecore.unify_error_msg (print_context()) el) pos) el; *) + gen.gcon.warning ("This expression may be invalid") pos + | Invalid_argument("List.map2") -> + gen.gcon.warning ("This expression may be invalid") pos + ); + + List.map (fun t -> + match follow t with + | TMono _ -> t_empty + | t -> t + ) monos + + (* ******************************************* *) + (* Real Type Parameters Module *) + (* ******************************************* *) + + (* + This submodule is by now specially made for the .NET platform. There might be other targets that will + make use of this, but it IS very specific. + + On the .NET platform, generics are real specialized classes that are JIT compiled. For this reason, we cannot + cast from one type parameter to another. Also there is no common type for the type parameters, so for example + an instance of type Array will return false for instance is Array . + + So we need to: + 1. create a common interface (without type parameters) (e.g. "Array") which will only contain a __Cast<> function, which will cast from one type into another + 2. Implement the __Cast function. This part is a little hard, as we must identify all type parameter-dependent fields contained in the class and convert them. + In most cases the conversion will just be to call .__Cast<>() on the instances, or just a simple cast. But when the instance is a @:nativegen type, there will be no .__Cast + function, and we will need to deal with this case either at compile-time (added handlers - specially for NativeArray), or at runtime (adding new runtime handlers) + 3. traverse the AST looking for casts involving type parameters, and replace them with .__Cast<>() calls. If type is @:nativegen, throw a warning. If really casting from one type parameter to another on a @:nativegen context, throw an error. + + + special literals: + it will use the special literal __typehandle__ that the target must implement in order to run this. This literal is a way to get the typehandle of e.g. the type parameters, + so we can compare them. In C# it's the equivalent of typeof(T).TypeHandle (TypeHandle compare is faster than System.Type.Equals()) + + dependencies: + (module filter) Interface creation must run AFTER enums are converted into classes, otherwise there is no way to tell parameterized enums to implement an interface + Must run AFTER CastDetect. This will be ensured per CastDetect + + *) + + module RealTypeParams = + struct + + let name = "real_type_params" + + let priority = priority + + let cast_field_name = "cast" + + let rec has_type_params t = + match follow t with + | TInst( { cl_kind = KTypeParameter _ }, _) -> true + | TAbstract(_, params) + | TEnum(_, params) + | TInst(_, params) -> List.fold_left (fun acc t -> acc || has_type_params t) false params + | _ -> false + + let is_hxgeneric = function + | TClassDecl(cl) -> + not (Meta.has Meta.NativeGeneric cl.cl_meta) + | TEnumDecl(e) -> + not (Meta.has Meta.NativeGeneric e.e_meta) + | TTypeDecl(t) -> + not (Meta.has Meta.NativeGeneric t.t_meta) + | TAbstractDecl a -> + not (Meta.has Meta.NativeGeneric a.a_meta) + + let rec set_hxgeneric gen mds isfirst md = + let path = t_path md in + if List.exists (fun m -> path = t_path m) mds then begin + if isfirst then + None (* we still can't determine *) + else + Some true (* if we're in second pass and still can't determine, it's because it can be hxgeneric *) + end else begin + let has_unresolved = ref false in + let is_false v = + match v with + | Some false -> true + | None -> has_unresolved := true; false + | Some true -> false + in + + let mds = md :: mds in + match md with + | TClassDecl(cl) -> + (* first see if any meta is present (already processed) *) + if Meta.has Meta.NativeGeneric cl.cl_meta then + Some false + else if Meta.has Meta.HaxeGeneric cl.cl_meta then + Some true + else if not (is_hxgen md) then + (cl.cl_meta <- (Meta.NativeGeneric, [], cl.cl_pos) :: cl.cl_meta; + Some false) + else begin + (* + if it's not present, see if any superclass is nativegeneric. + nativegeneric is inherited, while hxgeneric can be later changed to nativegeneric + *) + (* on the first pass, our job is to find any evidence that makes it not be hxgeneric. Otherwise it will be hxgeneric *) + match cl.cl_super with + | Some (c,_) when is_false (set_hxgeneric gen mds isfirst (TClassDecl c)) -> + cl.cl_meta <- (Meta.NativeGeneric, [], cl.cl_pos) :: cl.cl_meta; + Some false + | _ -> + (* see if it's a generic class *) + match cl.cl_types with + | [] -> + (* if it's not, then it will be hxgeneric *) + cl.cl_meta <- (Meta.HaxeGeneric, [], cl.cl_pos) :: cl.cl_meta; + Some true + | _ -> + (* if it is, loop through all fields + statics and look for non-hxgeneric + generic classes that have KTypeParameter as params *) + let rec loop cfs = + match cfs with + | [] -> false + | cf :: cfs -> + let t = follow (gen.greal_type cf.cf_type) in + match t with + | TInst( { cl_kind = KTypeParameter _ }, _ ) -> loop cfs + | TInst(cl,p) when has_type_params t && is_false (set_hxgeneric gen mds isfirst (TClassDecl cl)) -> + if not (Hashtbl.mem gen.gtparam_cast cl.cl_path) then true else loop cfs + | TEnum(e,p) when has_type_params t && is_false (set_hxgeneric gen mds isfirst (TEnumDecl e)) -> + if not (Hashtbl.mem gen.gtparam_cast e.e_path) then true else loop cfs + | _ -> loop cfs (* TAbstracts / Dynamics can't be generic *) + in + if loop cl.cl_ordered_fields then begin + cl.cl_meta <- (Meta.NativeGeneric, [], cl.cl_pos) :: cl.cl_meta; + Some false + end else if isfirst && !has_unresolved then + None + else begin + cl.cl_meta <- (Meta.HaxeGeneric, [], cl.cl_pos) :: cl.cl_meta; + Some true + end + end + | TEnumDecl e -> + if Meta.has Meta.NativeGeneric e.e_meta then + Some false + else if Meta.has Meta.HaxeGeneric e.e_meta then + Some true + else if not (is_hxgen (TEnumDecl e)) then begin + e.e_meta <- (Meta.NativeGeneric, [], e.e_pos) :: e.e_meta; + Some false + end else begin + (* if enum is not generic, then it's hxgeneric *) + match e.e_types with + | [] -> + e.e_meta <- (Meta.HaxeGeneric, [], e.e_pos) :: e.e_meta; + Some true + | _ -> + let rec loop efs = + match efs with + | [] -> false + | ef :: efs -> + let t = follow (gen.greal_type ef.ef_type) in + match t with + | TFun(args, _) -> + if List.exists (fun (n,o,t) -> + let t = follow t in + match t with + | TInst( { cl_kind = KTypeParameter _ }, _ ) -> + false + | TInst(cl,p) when has_type_params t && is_false (set_hxgeneric gen mds isfirst (TClassDecl cl)) -> + not (Hashtbl.mem gen.gtparam_cast cl.cl_path) + | TEnum(e,p) when has_type_params t && is_false (set_hxgeneric gen mds isfirst (TEnumDecl e)) -> + not (Hashtbl.mem gen.gtparam_cast e.e_path) + | _ -> false + ) args then + true + else + loop efs + | _ -> loop efs + in + let efs = PMap.fold (fun ef acc -> ef :: acc) e.e_constrs [] in + if loop efs then begin + e.e_meta <- (Meta.NativeGeneric, [], e.e_pos) :: e.e_meta; + Some false + end else if isfirst && !has_unresolved then + None + else begin + e.e_meta <- (Meta.HaxeGeneric, [], e.e_pos) :: e.e_meta; + Some true + end + end + | _ -> assert false + end + + let set_hxgeneric gen md = + match set_hxgeneric gen [] true md with + | None -> + get (set_hxgeneric gen [] false md) + | Some v -> v + + let params_has_tparams params = + List.fold_left (fun acc t -> acc || has_type_params t) false params + + (* ******************************************* *) + (* RealTypeParamsModf *) + (* ******************************************* *) + + (* + + This is the module filter of Real Type Parameters. It will traverse through all types and look for hxgeneric classes (only classes). + When found, a parameterless interface will be created and associated via the "ifaces" Hashtbl to the original class. + Also a "cast" function will be automatically generated which will handle unsafe downcasts to more specific type parameters (necessary for serialization) + + dependencies: + Anything that may create hxgeneric classes must run before it. + Should run before ReflectionCFs (this dependency will be added to ReflectionCFs), so the added interfaces also get to be real IHxObject's + + *) + + module RealTypeParamsModf = + struct + + let name = "real_type_params_modf" + + let priority = solve_deps name [] + + let rec get_fields gen cl params_cl params_cf acc = + let fields = List.fold_left (fun acc cf -> + match follow (gen.greal_type (gen.gfollow#run_f (cf.cf_type))) with + | TInst(cli, ((_ :: _) as p)) when (not (is_hxgeneric (TClassDecl cli))) && params_has_tparams p -> + (cf, apply_params cl.cl_types params_cl cf.cf_type, apply_params cl.cl_types params_cf cf.cf_type) :: acc + | TEnum(e, ((_ :: _) as p)) when not (is_hxgeneric (TEnumDecl e)) && params_has_tparams p -> + (cf, apply_params cl.cl_types params_cl cf.cf_type, apply_params cl.cl_types params_cf cf.cf_type) :: acc + | _ -> acc + ) [] cl.cl_ordered_fields in + match cl.cl_super with + | Some(cs, tls) -> + get_fields gen cs (List.map (apply_params cl.cl_types params_cl) tls) (List.map (apply_params cl.cl_types params_cf) tls) (fields @ acc) + | None -> (fields @ acc) + + (* overrides all needed cast functions from super classes / interfaces to call the new cast function *) + let create_stub_casts gen cl cast_cfield = + (* go through superclasses and interfaces *) + let p = cl.cl_pos in + let this = { eexpr = TConst TThis; etype = (TInst(cl, List.map snd cl.cl_types)); epos = p } in + + let rec loop cls tls level reverse_params = + if (level <> 0 || cls.cl_interface) && tls <> [] && is_hxgeneric (TClassDecl cls) then begin + let cparams = List.map (fun (s,t) -> (s, TInst (map_param (get_cl_t t), []))) cls.cl_types in + let name = String.concat "_" ((fst cls.cl_path) @ [snd cls.cl_path; cast_field_name]) in + if not (PMap.mem name cl.cl_fields) then begin + let reverse_params = List.map (apply_params cls.cl_types (List.map snd cparams)) reverse_params in + let cfield = mk_class_field name (TFun([], t_dynamic)) false cl.cl_pos (Method MethNormal) cparams in + let field = { eexpr = TField(this, FInstance(cl,cast_cfield)); etype = apply_params cast_cfield.cf_params reverse_params cast_cfield.cf_type; epos = p } in + let call = + { + eexpr = TCall(field, []); + etype = t_dynamic; + epos = p; + } in + let call = gen.gparam_func_call call field reverse_params [] in + let delay () = + cfield.cf_expr <- + Some { + eexpr = TFunction( + { + tf_args = []; + tf_type = t_dynamic; + tf_expr = + { + eexpr = TReturn( Some call ); + etype = t_dynamic; + epos = p; + } + }); + etype = cfield.cf_type; + epos = p; + } + in + gen.gafter_filters_ended <- delay :: gen.gafter_filters_ended; (* do not let filters alter this expression content *) + cl.cl_ordered_fields <- cfield :: cl.cl_ordered_fields; + cl.cl_fields <- PMap.add cfield.cf_name cfield cl.cl_fields; + if level <> 0 then cl.cl_overrides <- cfield :: cl.cl_overrides + end + end; + let get_reverse super supertl = + let kv = List.map2 (fun (_,tparam) applied -> (follow applied, follow tparam)) super.cl_types supertl in + List.map (fun t -> + try + List.assq (follow t) kv + with | Not_found -> t + ) reverse_params + in + (match cls.cl_super with + | None -> () + | Some(super, supertl) -> + loop super supertl (level + 1) (get_reverse super supertl)); + List.iter (fun (iface, ifacetl) -> + loop iface ifacetl level (get_reverse iface ifacetl) + ) cls.cl_implements + in + loop cl (List.map snd cl.cl_types) 0 (List.map snd cl.cl_types) + + (* + Creates a cast classfield, with the desired name + + Will also look for previous cast() definitions and override them, to reflect the current type and fields + + FIXME: this function still doesn't support generics that extend generics, and are cast as one of its subclasses. This needs to be taken care, by + looking at previous superclasses and whenever a generic class is found, its cast argument must be overriden. the toughest part is to know how to type + the current type correctly. + *) + let create_cast_cfield gen cl name = + let basic = gen.gcon.basic in + let cparams = List.map (fun (s,t) -> (s, TInst (map_param (get_cl_t t), []))) cl.cl_types in + let cfield = mk_class_field name (TFun([], t_dynamic)) false cl.cl_pos (Method MethNormal) cparams in + let params = List.map snd cparams in + + let fields = get_fields gen cl (List.map snd cl.cl_types) params [] in + + (* now create the contents of the function *) + (* + it will look something like: + if (typeof(T) == typeof(T2)) return this; + + var new_me = new CurrentClass(EmptyInstnace); + + for (field in Reflect.fields(this)) + { + switch(field) + { + case "aNativeArray": + var newArray = new NativeArray(this.aNativeArray.Length); + + default: + Reflect.setField(new_me, field, Reflect.field(this, field)); + } + } + *) + + let new_t = TInst(cl, params) in + let pos = cl.cl_pos in + + let new_me_var = alloc_var "new_me" new_t in + let local_new_me = { eexpr = TLocal(new_me_var); etype = new_t; epos = pos } in + let this = { eexpr = TConst(TThis); etype = (TInst(cl, List.map snd cl.cl_types)); epos = pos } in + let field_var = alloc_var "field" gen.gcon.basic.tstring in + let local_field = { eexpr = TLocal(field_var); etype = field_var.v_type; epos = pos } in + + let get_path t = + match follow t with + | TInst(cl,_) -> cl.cl_path + | TEnum(e,_) -> e.e_path + | TAbstract(a,_) -> a.a_path + | TMono _ + | TDynamic _ -> ([], "Dynamic") + | _ -> assert false + in + + (* this will take all fields that were *) + let fields_to_cases fields = + List.map (fun (cf, t_cl, t_cf) -> + let this_field = { eexpr = TField(this, FInstance(cl, cf)); etype = t_cl; epos = pos } in + let expr = + { + eexpr = TBinop(OpAssign, { eexpr = TField(local_new_me, FInstance(cl, cf) ); etype = t_cf; epos = pos }, + try (Hashtbl.find gen.gtparam_cast (get_path t_cf)) this_field t_cf with | Not_found -> (* if not found tparam cast, it shouldn't be a valid hxgeneric *) assert false + ); + etype = t_cf; + epos = pos; + } in + + ([{ eexpr = TConst(TString(cf.cf_name)); etype = gen.gcon.basic.tstring; epos = pos }], expr) + ) fields + in + + let mk_typehandle = + let thandle = alloc_var "__typeof__" t_dynamic in + (fun cl -> { eexpr = TCall(mk_local thandle pos, [ mk_classtype_access cl pos ]); etype = t_dynamic; epos = pos }) + in + let mk_eq cl1 cl2 = + { eexpr = TBinop(Ast.OpEq, mk_typehandle cl1, mk_typehandle cl2); etype = basic.tbool; epos = pos } + in + + let rec mk_typehandle_cond thisparams cfparams = + match thisparams, cfparams with + | TInst(cl_this,[]) :: [], TInst(cl_cf,[]) :: [] -> + mk_eq cl_this cl_cf + | TInst(cl_this,[]) :: hd, TInst(cl_cf,[]) :: hd2 -> + { eexpr = TBinop(Ast.OpBoolAnd, mk_eq cl_this cl_cf, mk_typehandle_cond hd hd2); etype = basic.tbool; epos = pos } + | v :: hd, v2 :: hd2 -> + (match follow v, follow v2 with + | (TInst(cl1,[]) as v), (TInst(cl2,[]) as v2) -> + mk_typehandle_cond (v :: hd) (v2 :: hd2) + | _ -> + assert false + ) + | _ -> assert false + in + + let ref_fields = gen.gtools.r_fields true this in + let fn = + { + tf_args = []; + tf_type = t_dynamic; + tf_expr = + { + eexpr = TBlock([ + (* if (typeof(T) == typeof(T2)) return this *) + { + eexpr = TIf( + mk_typehandle_cond (List.map snd cl.cl_types) params, + mk_return this, + None); + etype = basic.tvoid; + epos = pos; + }; + (* var new_me = /*special create empty with tparams construct*/ *) + { eexpr = TVars([new_me_var, Some( + gen.gtools.rf_create_empty cl params pos + )]); etype = gen.gcon.basic.tvoid; epos = pos }; + { eexpr = TFor( (* for (field in Reflect.fields(this)) *) + field_var, + mk_iterator_access gen gen.gcon.basic.tstring ref_fields, + (* { *) + (* switch(field) *) + { + eexpr = TSwitch(local_field, fields_to_cases fields, Some( + (* default: Reflect.setField(new_me, field, Reflect.field(this, field)) *) + gen.gtools.r_set_field (gen.gcon.basic.tvoid) local_new_me local_field (gen.gtools.r_field false t_dynamic this local_field) + )); + etype = t_dynamic; + epos = pos; + } + (* } *) + ); etype = t_dynamic; epos = pos }; + (* return new_me *) + mk_return (mk_local new_me_var pos) + ]); + etype = t_dynamic; + epos = pos; + }; + } + in + + cfield.cf_expr <- Some( { eexpr = TFunction(fn); etype = cfield.cf_type; epos = pos } ); + + cfield + + let create_static_cast_cf gen iface cf = + let p = iface.cl_pos in + let basic = gen.gcon.basic in + let cparams = List.map (fun (s,t) -> ("To_" ^ s, TInst (map_param (get_cl_t t), []))) cf.cf_params in + let me_type = TInst(iface,[]) in + let cfield = mk_class_field "__hx_cast" (TFun(["me",false,me_type], t_dynamic)) false iface.cl_pos (Method MethNormal) (cparams) in + let params = List.map snd cparams in + + let me = alloc_var "me" me_type in + let field = { eexpr = TField(mk_local me p, FInstance(iface,cf)); etype = apply_params cf.cf_params params cf.cf_type; epos = p } in + let call = + { + eexpr = TCall(field, []); + etype = t_dynamic; + epos = p; + } in + let call = gen.gparam_func_call call field params [] in + + (* since object.someCall() isn't allowed on Haxe, we need to directly apply the params and delay this call *) + let delay () = + cfield.cf_expr <- + Some { + eexpr = TFunction( + { + tf_args = [me,None]; + tf_type = t_dynamic; + tf_expr = + { + eexpr = TReturn( Some + { + eexpr = TIf( + { eexpr = TBinop(Ast.OpNotEq, mk_local me p, null me.v_type p); etype = basic.tbool; epos = p }, + call, + Some( null me.v_type p ) + ); + etype = t_dynamic; + epos = p; + }); + etype = basic.tvoid; + epos = p; + } + }); + etype = cfield.cf_type; + epos = p; + } + in + cfield, delay + + let get_cast_name cl = String.concat "_" ((fst cl.cl_path) @ [snd cl.cl_path; cast_field_name]) (* explicitly define it *) + + let default_implementation gen ifaces base_generic = + let add_iface cl = + gen.gadd_to_module (TClassDecl cl) (max_dep); + in + + let implement_stub_cast cthis iface tl = + let name = get_cast_name iface in + if not (PMap.mem name cthis.cl_fields) then begin + let cparams = List.map (fun (s,t) -> ("To_" ^ s, TInst(map_param (get_cl_t t), []))) iface.cl_types in + let field = mk_class_field name (TFun([],t_dynamic)) false iface.cl_pos (Method MethNormal) cparams in + let this = { eexpr = TConst TThis; etype = TInst(cthis, List.map snd cthis.cl_types); epos = cthis.cl_pos } in + field.cf_expr <- Some { + etype = TFun([],t_dynamic); + epos = this.epos; + eexpr = TFunction { + tf_type = t_dynamic; + tf_args = []; + tf_expr = mk_block { this with + eexpr = TReturn (Some this) + } + } + }; + cthis.cl_ordered_fields <- field :: cthis.cl_ordered_fields; + cthis.cl_fields <- PMap.add name field cthis.cl_fields + end + in + + let rec run md = + match md with + | TClassDecl ({ cl_extern = false; cl_types = [] } as cl) -> + (* see if we're implementing any generic interface *) + let rec check (iface,tl) = + if tl <> [] && set_hxgeneric gen (TClassDecl iface) then + (* implement cast stub *) + implement_stub_cast cl iface tl; + List.iter (fun (s,stl) -> check (s, List.map (apply_params iface.cl_types tl) stl)) iface.cl_implements; + in + List.iter (check) cl.cl_implements; + md + | TClassDecl ({ cl_extern = false; cl_types = hd :: tl } as cl) when set_hxgeneric gen md -> + let iface = mk_class cl.cl_module cl.cl_path cl.cl_pos in + iface.cl_array_access <- Option.map (apply_params (cl.cl_types) (List.map (fun _ -> t_dynamic) cl.cl_types)) cl.cl_array_access; + iface.cl_module <- cl.cl_module; + iface.cl_meta <- (Meta.HxGen, [], cl.cl_pos) :: iface.cl_meta; + Hashtbl.add ifaces cl.cl_path iface; + + iface.cl_implements <- (base_generic, []) :: iface.cl_implements; + iface.cl_interface <- true; + cl.cl_implements <- (iface, []) :: cl.cl_implements; + + let name = get_cast_name cl in + let cast_cf = create_cast_cfield gen cl name in + if not cl.cl_interface then create_stub_casts gen cl cast_cf; + + let rec loop c = match c.cl_super with + | None -> () + | Some(sup,_) -> try + let siface = Hashtbl.find ifaces sup.cl_path in + iface.cl_implements <- (siface,[]) :: iface.cl_implements; + () + with | Not_found -> loop sup + in + loop cl; + + (if not cl.cl_interface then cl.cl_ordered_fields <- cast_cf :: cl.cl_ordered_fields); + let iface_cf = mk_class_field name cast_cf.cf_type false cast_cf.cf_pos (Method MethNormal) cast_cf.cf_params in + let cast_static_cf, delay = create_static_cast_cf gen iface iface_cf in + + cl.cl_ordered_statics <- cast_static_cf :: cl.cl_ordered_statics; + cl.cl_statics <- PMap.add cast_static_cf.cf_name cast_static_cf cl.cl_statics; + gen.gafter_filters_ended <- delay :: gen.gafter_filters_ended; (* do not let filters alter this expression content *) + + iface_cf.cf_type <- cast_cf.cf_type; + iface.cl_fields <- PMap.add name iface_cf iface.cl_fields; + iface.cl_ordered_fields <- [iface_cf]; + + add_iface iface; + md + | TTypeDecl _ | TAbstractDecl _ -> md + | TEnumDecl _ -> + ignore (set_hxgeneric gen md); + md + | _ -> ignore (set_hxgeneric gen md); md + in + run + + let configure gen mapping_func = + let map e = Some(mapping_func e) in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map + + end;; + + (* create a common interface without type parameters and only a __Cast<> function *) + let default_implementation gen (dyn_tparam_cast:texpr->t->texpr) ifaces = + let change_expr e cl iface params = + let field = mk_static_field_access_infer cl "__hx_cast" e.epos params in + let elist = [mk_cast (TInst(iface,[])) e] in + let call = { eexpr = TCall(field, elist); etype = t_dynamic; epos = e.epos } in + + gen.gparam_func_call call field params elist + in + + let rec run e = + match e.eexpr with + | TCast(cast_expr, _) -> + (* see if casting to a native generic class *) + let t = follow (gen.greal_type e.etype) in + (match t with + | TInst(cl, p1 :: pl) when is_hxgeneric (TClassDecl cl) -> + let iface = Hashtbl.find ifaces cl.cl_path in + mk_cast e.etype (change_expr (Type.map_expr run cast_expr) cl iface (p1 :: pl)) + | _ -> Type.map_expr run e + ) + | _ -> Type.map_expr run e + in + run + + let configure gen traverse = + gen.ghas_tparam_cast_handler <- true; + let map e = Some(traverse e) in + gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map + + let default_config gen (dyn_tparam_cast:texpr->t->texpr) ifaces base_generic = + configure gen (default_implementation gen dyn_tparam_cast ifaces); + RealTypeParamsModf.configure gen (RealTypeParamsModf.default_implementation gen ifaces base_generic) + + end;; + + (* ******************************************* *) + (* Rename Type Parameters *) + (* ******************************************* *) + + (* + + This module should run after everything is already applied, + it will look for possible type parameter name clashing and change the classes names to a + + dependencies: + should run after everything is already applied. There's no configure on this module, only 'run'. + + *) + + module RenameTypeParameters = + struct + + let name = "rename_type_parameters" + + let run gen = + let i = ref 0 in + let found_types = ref PMap.empty in + let check_type name on_changed = + let rec loop name = + incr i; + let changed_name = (name ^ (string_of_int !i)) in + if PMap.mem changed_name !found_types then loop name else changed_name + in + if PMap.mem name !found_types then begin + let new_name = loop name in + found_types := PMap.add new_name true !found_types; + on_changed new_name + end else found_types := PMap.add name true !found_types + in + + let get_cls t = + match follow t with + | TInst(cl,_) -> cl + | _ -> assert false + in + + let iter_types (_,t) = + let cls = get_cls t in + check_type (snd cls.cl_path) (fun name -> cls.cl_path <- (fst cls.cl_path, name)) + in + + List.iter (function + | TClassDecl cl -> + i := 0; + + found_types := PMap.empty; + List.iter iter_types cl.cl_types; + let cur_found_types = !found_types in + List.iter (fun cf -> + found_types := cur_found_types; + List.iter iter_types cf.cf_params + ) (cl.cl_ordered_fields @ cl.cl_ordered_statics) + + | TEnumDecl ( ({ e_types = hd :: tl }) ) -> + i := 0; + found_types := PMap.empty; + List.iter iter_types (hd :: tl) + + | TAbstractDecl { a_types = hd :: tl } -> + i := 0; + found_types := PMap.empty; + List.iter iter_types (hd :: tl) + + | _ -> () + + ) gen.gcon.types + + end;; + + + let configure gen (param_func_call:texpr->texpr->tparams->texpr list->texpr) = + (*let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map*) + gen.gparam_func_call <- param_func_call + +end;; + +(**************************************************************************************************************************) +(* SYNTAX FILTERS *) +(**************************************************************************************************************************) + +(* ******************************************* *) +(* Expression Unwrap *) +(* ******************************************* *) + +(* + + This is the most important module for source-code based targets. It will follow a convention of what's an expression and what's a statement, + and will unwrap statements where expressions are expected, and vice-versa. + + It should be one of the first syntax filters to be applied. As a consequence, it's applied after all filters that add code to the AST, and by being + the first of the syntax filters, it will also have the AST retain most of the meaning of normal HaXe code. So it's easier to detect cases which are + side-effects free, for example + + Any target can make use of this, but there is one requirement: The target must accept null to be set to any kind of variable. For example, + var i:Int = null; must be accepted. The best way to deal with this is to (like it's done in C#) make null equal to "default(Type)" + + dependencies: + While it's best for Expression Unwrap to delay its execution as much as possible, since theoretically any + filter can return an expression that needs to be unwrapped, it is also desirable for ExpresionUnwrap to have + the AST as close as possible as HaXe's, so it can make some correct predictions (for example, so it can + more accurately know what can be side-effects-free and what can't). + This way, it will run slightly after the Normal priority, so if you don't say that a syntax filter must run + before Expression Unwrap, it will run after it. + + TODO : While statement must become do / while, with the actual block inside an if for the condition, and else for 'break' +*) + +module ExpressionUnwrap = +struct + + let name = "expression_unwrap" + + (* priority: first syntax filter *) + let priority = -10.0 + + (* + We always need to rely on Blocks to be able to unwrap expressions correctly. + So the the standard traverse will always be based on blocks. + Normal block statements, like for(), while(), if(), ... will be mk_block'ed so there is always a block inside of them. + + At the block level, we'll define an "add_statement" function, which will allow the current expression to + add statements to the block. This statement may or may not contain statements as expressions, so the texpr will be evaluated recursively before being added. + + - traverse will always evaluate TBlocks + - for each texpr in a TBlock list, + check shallow type + if type is Statement or Both when it has problematic expression (var problematic_expr = count_problematic_expressions), + if we can eagerly call unwrap_statement on the whole expression (try_call_unwrap_statement), use the return expression + else + check expr_type of each underlying type (with expr_stat_map) + if it has ExprWithStatement or Statement, + call problematic_expression_unwrap in it + problematic_expr-- + else if problematic_expr == 0, just add the unchanged expression + else if NoSideEffects and doesn't have short-circuit, just add the unchanged expression + else call problematic_expression_unwrap in it + if type is Expression, check if there are statements or Both inside. + if there are, problematic_expression_unwrap in it + aftewards, use on_expr_as_statement to get it + + helpers: + try_call_unwrap_statement: (returns texpr option) + if underlying statement is TBinop(OpAssign/OpAssignOp), or TVars, with the right side being a Statement or a short circuit op, we can call apply_assign. + + apply_assign: + if is TVar, first declare the tvar with default expression = null; + will receive the left and right side of the assignment; right-side must be Statement + see if right side is a short-circuit operation, call short_circuit_op_unwrap + else see eexpr of the right side + if it's void, just add the statement with add_statement, and set the right side as null; + if not, it will have a block inside. set the left side = to the last expression on each block inside. add_statement for it. + + short_circuit_op_unwrap: x() && (1 + {var x = 0; x + 1;} == 2) && z() + -> var x = x(); + var y = false; + var z = false; + if (x) //for &&, neg for || + { + var temp = null; + { + var x = 0; + temp = x + 1; + } + + y = (1 + temp) == 2; + if (y) + { + z = z(); + } + } + expects to receive a texpr with TBinop(OpBoolAnd/OpBoolOr) + will traverse the AST while there is a TBinop(OpBoolAnd/OpBoolOr) as a right-side expr, and declare new temp vars in the for each found. + will collect the return value, a mapped expr with all exprs as TLocal of the temp vars created + + + problematic_expression_unwrap: + check expr_kind: + if it is NoSideEffects and not short-circuit, leave it there + if it is ExprWithStatement and not short-circuit, call Type.map_expr problematic_expression_unwrap + if it is Statement or Expression or short-circuit expr, call add_assign for this expression + + add_assign: + see if the type is void. If it is, just add_statement the expression argument, and return a null value + else create a new variable, set TVars with Some() with the expression argument, add TVar with add_statement, and return the TLocal of this expression. + + map_problematic_expr: + call expr_stat_map on statement with problematic_expression_unwrap + + types: + type shallow_expr_type = | Statement | Expression | Both (* shallow expression classification. Both means that they can be either Statements as Expressions *) + + type expr_kind = | NormalExpr | ExprNoSideEffects (* -> short-circuit is considered side-effects *) | ExprWithStatement | Statement + evaluates an expression (as in not a statement) type. If it is ExprWithStatement or Statement, it means it contains errors + + functions: + shallow_expr_type (expr:texpr) : shallow_expr_type + + expr_kind (expr:texpr) : expr_kind + deeply evaluates an expression type + + expr_stat_map (fn:texpr->texpr) (expr:texpr) : texpr + it will traverse the AST looking for places where an expression is expected, and map the value according to fn + + aggregate_expr_type (is_side_effects_free:bool) (children:expr_type list) : expr_type + helper function to deal with expr_type aggregation (e.g. an Expression + a Statement as a children, is a ExprWithStatement) + + check_statement_in_expression (expr:texpr) : texpr option : + will check + + *) + + type shallow_expr_type = | Statement | Expression of texpr | Both of texpr (* shallow expression classification. Both means that they can be either Statements as Expressions *) + + type expr_kind = | KNormalExpr | KNoSideEffects (* -> short-circuit is considered side-effects *) | KExprWithStatement | KStatement + + let rec no_paren e = + match e.eexpr with + | TParenthesis e -> no_paren e + | _ -> e + + (* must be called in a statement. Will execute fn whenever an expression (not statement) is expected *) + let expr_stat_map fn (expr:texpr) = + match (no_paren expr).eexpr with + | TBinop ( (Ast.OpAssign as op), left_e, right_e ) + | TBinop ( (Ast.OpAssignOp _ as op), left_e, right_e ) -> + { expr with eexpr = TBinop(op, fn left_e, fn right_e) } + | TParenthesis _ -> assert false + | TCall(left_e, params) -> + { expr with eexpr = TCall(fn left_e, List.map fn params) } + | TNew(cl, tparams, params) -> + { expr with eexpr = TNew(cl, tparams, List.map fn params) } + | TVars(vars) -> + { expr with eexpr = TVars( List.map (fun (v,eopt) -> (v, Option.map fn eopt)) vars ) } + | TFor (v,cond,block) -> + { expr with eexpr = TFor(v, fn cond, block) } + | TIf(cond,eif,eelse) -> + { expr with eexpr = TIf(fn cond, eif, eelse) } + | TWhile(cond, block, flag) -> + { expr with eexpr = TWhile(fn cond, block, flag) } + | TSwitch(cond, el_block_l, default) -> + { expr with eexpr = TSwitch( fn cond, List.map (fun (el,block) -> (List.map fn el, block)) el_block_l, default ) } + | TMatch(cond, enum, cases, default) -> + { expr with eexpr = TMatch(fn cond, enum, cases, default) } + | TReturn(eopt) -> + { expr with eexpr = TReturn(Option.map fn eopt) } + | TThrow (texpr) -> + { expr with eexpr = TThrow(fn texpr) } + | TBreak + | TContinue + | TTry _ + | TUnop (Ast.Increment, _, _) + | TUnop (Ast.Decrement, _, _) (* unop is a special case because the haxe compiler won't let us generate complex expressions with Increment/Decrement *) + | TBlock _ -> expr (* there is no expected expression here. Only statements *) + | _ -> assert false (* we only expect valid statements here. other expressions aren't valid statements *) + + let is_expr = function | Expression _ -> true | _ -> false + + let aggregate_expr_type map_fn side_effects_free children = + let rec loop acc children = + match children with + | [] -> acc + | hd :: children -> + match acc, map_fn hd with + | _, KExprWithStatement + | _, KStatement + | KExprWithStatement, _ + | KStatement, _ -> KExprWithStatement + | KNormalExpr, KNoSideEffects + | KNoSideEffects, KNormalExpr + | KNormalExpr, KNormalExpr -> loop KNormalExpr children + | KNoSideEffects, KNoSideEffects -> loop KNoSideEffects children + in + loop (if side_effects_free then KNoSideEffects else KNormalExpr) children + + (* statements: *) + (* Error CS0201: Only assignment, call, increment, *) + (* decrement, and new object expressions can be used as a *) + (* statement (CS0201). *) + let rec shallow_expr_type expr : shallow_expr_type = + match expr.eexpr with + | TCall _ when not (is_void expr.etype) -> Both expr + | TNew _ + | TUnop (Ast.Increment, _, _) + | TUnop (Ast.Decrement, _, _) + | TBinop (Ast.OpAssign, _, _) + | TBinop (Ast.OpAssignOp _, _, _) -> Both expr + | TIf (cond, eif, Some(eelse)) -> (match aggregate_expr_type expr_kind true [cond;eif;eelse] with + | KExprWithStatement -> Statement + | _ -> Both expr) + | TConst _ + | TLocal _ + | TArray _ + | TBinop _ + | TField _ + | TTypeExpr _ + | TObjectDecl _ + | TArrayDecl _ + | TFunction _ + | TCast _ + | TUnop _ -> Expression (expr) + | TParenthesis p -> shallow_expr_type p + | TBlock ([e]) -> shallow_expr_type e + | TCall _ + | TVars _ + | TBlock _ + | TFor _ + | TWhile _ + | TSwitch _ + | TMatch _ + | TTry _ + | TReturn _ + | TBreak + | TContinue + | TIf _ + | TThrow _ -> Statement + + and expr_kind expr = + match shallow_expr_type expr with + | Statement -> KStatement + | Both expr | Expression expr -> + let aggregate = aggregate_expr_type expr_kind in + match expr.eexpr with + | TConst _ + | TLocal _ + | TFunction _ + | TTypeExpr _ -> + KNoSideEffects + | TCall (ecall, params) -> + aggregate false (ecall :: params) + | TNew (_,_,params) -> + aggregate false params + | TUnop (Increment,_,e) + | TUnop (Decrement,_,e) -> + aggregate false [e] + | TUnop (_,_,e) -> + aggregate true [e] + | TBinop (Ast.OpBoolAnd, e1, e2) + | TBinop (Ast.OpBoolOr, e1, e2) -> (* TODO: should OpBool never be side-effects free? *) + aggregate true [e1;e2] + | TBinop (Ast.OpAssign, e1, e2) + | TBinop (Ast.OpAssignOp _, e1, e2) -> + aggregate false [e1;e2] + | TBinop (_, e1, e2) -> + aggregate true [e1;e2] + | TIf (cond, eif, Some(eelse)) -> (match aggregate true [cond;eif;eelse] with + | KExprWithStatement -> KStatement + | k -> k) + | TArray (e1,e2) -> + aggregate true [e1;e2] + | TParenthesis e + | TField (e,_) -> + aggregate true [e] + | TArrayDecl (el) -> + aggregate true el + | TObjectDecl (sel) -> + aggregate true (List.map snd sel) + | TCast (e,_) -> + aggregate true [e] + | _ -> trace (debug_expr expr); assert false (* should have been read as Statement by shallow_expr_type *) + + let is_side_effects_free e = + match expr_kind e with | KNoSideEffects -> true | _ -> false + + let get_kinds (statement:texpr) = + let kinds = ref [] in + ignore (expr_stat_map (fun e -> + kinds := (expr_kind e) :: !kinds; + e + ) statement); + List.rev !kinds + + let has_problematic_expressions (kinds:expr_kind list) = + let rec loop kinds = + match kinds with + | [] -> false + | KStatement :: _ + | KExprWithStatement :: _ -> true + | _ :: tl -> loop tl + in + loop kinds + + let count_problematic_expressions (statement:texpr) = + let count = ref 0 in + ignore (expr_stat_map (fun e -> + (match expr_kind e with + | KStatement | KExprWithStatement -> incr count + | _ -> () + ); + e + ) statement); + !count + + let apply_assign_block assign_fun elist = + let rec assign acc elist = + match elist with + | [] -> acc + | last :: [] -> + (assign_fun last) :: acc + | hd :: tl -> + assign (hd :: acc) tl + in + List.rev (assign [] elist) + + let mk_get_block assign_fun e = + match e.eexpr with + | TBlock [] -> e + | TBlock (el) -> + { e with eexpr = TBlock(apply_assign_block assign_fun el) } + | _ -> + { e with eexpr = TBlock([ assign_fun e ]) } + + let add_assign gen add_statement expr = + match expr.eexpr, follow expr.etype with + | _, TEnum({ e_path = ([],"Void") },[]) + | _, TAbstract ({ a_path = ([],"Void") },[]) + | TThrow _, _ -> + add_statement expr; + null expr.etype expr.epos + | _ -> + let var = mk_temp gen "stmt" expr.etype in + let tvars = { expr with eexpr = TVars([var,Some(expr)]) } in + let local = { expr with eexpr = TLocal(var) } in + add_statement tvars; + local + + (* requirement: right must be a statement *) + let rec apply_assign assign_fun right = + match right.eexpr with + | TBlock el -> + { right with eexpr = TBlock(apply_assign_block assign_fun el) } + | TSwitch (cond, elblock_l, default) -> + { right with eexpr = TSwitch(cond, List.map (fun (el,block) -> (el, mk_get_block assign_fun block)) elblock_l, Option.map (mk_get_block assign_fun) default) } + | TMatch (cond, ep, il_vlo_e_l, default) -> + { right with eexpr = TMatch(cond, ep, List.map (fun (il,vlo,e) -> (il,vlo,mk_get_block assign_fun e)) il_vlo_e_l, Option.map (mk_get_block assign_fun) default) } + | TTry (block, catches) -> + { right with eexpr = TTry(mk_get_block assign_fun block, List.map (fun (v,block) -> (v,mk_get_block assign_fun block) ) catches) } + | TIf (cond,eif,eelse) -> + { right with eexpr = TIf(cond, mk_get_block assign_fun eif, Option.map (mk_get_block assign_fun) eelse) } + | TThrow _ + | TWhile _ + | TFor _ + | TReturn _ + | TBreak + | TContinue -> right + | TParenthesis p -> + apply_assign assign_fun p + | _ -> + match follow right.etype with + | TEnum( { e_path = ([], "Void") }, [] ) + | TAbstract ({ a_path = ([], "Void") },[]) -> + right + | _ -> trace (debug_expr right); assert false (* a statement is required *) + + let short_circuit_op_unwrap gen add_statement expr :texpr = + let do_not expr = + { expr with eexpr = TUnop(Ast.Not, Ast.Prefix, expr) } + in + + (* loop will always return its own TBlock, and the mapped expression *) + let rec loop acc expr = + match expr.eexpr with + | TBinop ( (Ast.OpBoolAnd as op), left, right) -> + let var = mk_temp gen "boolv" right.etype in + let tvars = { right with eexpr = TVars([var, Some( { right with eexpr = TConst(TBool false); etype = gen.gcon.basic.tbool } )]); etype = gen.gcon.basic.tvoid } in + let local = { right with eexpr = TLocal(var) } in + + let mapped_left, ret_acc = loop ( (local, { right with eexpr = TBinop(Ast.OpAssign, local, right) } ) :: acc) left in + + add_statement tvars; + ({ expr with eexpr = TBinop(op, mapped_left, local) }, ret_acc) + (* we only accept OpBoolOr when it's the first to be evaluated *) + | TBinop ( (Ast.OpBoolOr as op), left, right) when acc = [] -> + let left = match left.eexpr with + | TLocal _ | TConst _ -> left + | _ -> add_assign gen add_statement left + in + + let var = mk_temp gen "boolv" right.etype in + let tvars = { right with eexpr = TVars([var, Some( { right with eexpr = TConst(TBool false); etype = gen.gcon.basic.tbool } )]); etype = gen.gcon.basic.tvoid } in + let local = { right with eexpr = TLocal(var) } in + add_statement tvars; + + ({ expr with eexpr = TBinop(op, left, local) }, [ do_not left, { right with eexpr = TBinop(Ast.OpAssign, local, right) } ]) + | _ when acc = [] -> assert false + | _ -> + let var = mk_temp gen "boolv" expr.etype in + let tvars = { expr with eexpr = TVars([var, Some( { expr with etype = gen.gcon.basic.tbool } )]); etype = gen.gcon.basic.tvoid } in + let local = { expr with eexpr = TLocal(var) } in + + let last_local = ref local in + let acc = List.map (fun (local, assign) -> + let l = !last_local in + last_local := local; + (l, assign) + ) acc in + + add_statement tvars; + (local, acc) + in + + let mapped_expr, local_assign_list = loop [] expr in + + let rec loop local_assign_list : texpr = + match local_assign_list with + | [local, assign] -> + { eexpr = TIf(local, assign, None); etype = gen.gcon.basic.tvoid; epos = assign.epos } + | (local, assign) :: tl -> + { eexpr = TIf(local, + { + eexpr = TBlock ( assign :: [loop tl] ); + etype = gen.gcon.basic.tvoid; + epos = assign.epos; + }, + None); etype = gen.gcon.basic.tvoid; epos = assign.epos } + | [] -> assert false + in + + add_statement (loop local_assign_list); + mapped_expr + + (* there are two short_circuit fuctions as I'm still testing the best way to do it *) + (*let short_circuit_op_unwrap gen add_statement expr :texpr = + let block = ref [] in + let rec short_circuit_op_unwrap is_first last_block expr = + match expr.eexpr with + | TBinop ( (Ast.OpBoolAnd as op), left, right) + | TBinop ( (Ast.OpBoolOr as op), left, right) -> + let var = mk_temp gen "boolv" left.etype in + let tvars = { left with eexpr = TVars([var, if is_first then Some(left) else Some( { left with eexpr = TConst(TBool false) } )]); etype = gen.gcon.basic.tvoid } in + let local = { left with eexpr = TLocal(var) } in + if not is_first then begin + last_block := !last_block @ [ { left with eexpr = TBinop(Ast.OpAssign, local, left) } ] + end; + + add_statement tvars; + let local_op = match op with | Ast.OpBoolAnd -> local | Ast.OpBoolOr -> { local with eexpr = TUnop(Ast.Not, Ast.Prefix, local) } | _ -> assert false in + + let new_block = ref [] in + let new_right = short_circuit_op_unwrap false new_block right in + last_block := !last_block @ [ { expr with eexpr = TIf(local_op, { right with eexpr = TBlock(!new_block) }, None) } ]; + + { expr with eexpr = TBinop(op, local, new_right) } + | _ when is_first -> assert false + | _ -> + let var = mk_temp gen "boolv" expr.etype in + let tvars = { expr with eexpr = TVars([var, Some ( { expr with eexpr = TConst(TBool false) } ) ]); etype = gen.gcon.basic.tvoid } in + let local = { expr with eexpr = TLocal(var) } in + last_block := !last_block @ [ { expr with eexpr = TBinop(Ast.OpAssign, local, expr) } ]; + add_statement tvars; + + local + in + let mapped_expr = short_circuit_op_unwrap true block expr in + add_statement { eexpr = TBlock(!block); etype = gen.gcon.basic.tvoid; epos = expr.epos }; + mapped_expr*) + + let twhile_with_condition_statement gen add_statement twhile cond e1 flag = + (* when a TWhile is found with a problematic condition *) + let basic = gen.gcon.basic in + + let block = if flag = Ast.NormalWhile then + { e1 with eexpr = TIf(cond, e1, Some({ e1 with eexpr = TBreak; etype = basic.tvoid })) } + else + Codegen.concat e1 { e1 with + eexpr = TIf({ + eexpr = TUnop(Ast.Not, Ast.Prefix, mk_paren cond); + etype = basic.tbool; + epos = cond.epos + }, { e1 with eexpr = TBreak; etype = basic.tvoid }, None); + etype = basic.tvoid + } + in + + add_statement { twhile with + eexpr = TWhile( + { eexpr = TConst(TBool true); etype = basic.tbool; epos = cond.epos }, + block, + Ast.DoWhile + ); + } + + let try_call_unwrap_statement gen problematic_expression_unwrap (add_statement:texpr->unit) (expr:texpr) : texpr option = + let check_left left = + match expr_kind left with + | KExprWithStatement -> + problematic_expression_unwrap add_statement left KExprWithStatement + | KStatement -> assert false (* doesn't make sense a KStatement as a left side expression *) + | _ -> left + in + + let handle_assign op left right = + let left = check_left left in + Some (apply_assign (fun e -> { e with eexpr = TBinop(op, left, if is_void left.etype then e else gen.ghandle_cast left.etype e.etype e) }) right ) + in + + let handle_return e = + Some( apply_assign (fun e -> + match e.eexpr with + | TThrow _ -> e + | _ when is_void e.etype -> + { e with eexpr = TBlock([e; { e with eexpr = TReturn None }]) } + | _ -> + { e with eexpr = TReturn( Some e ) } + ) e ) + in + + let is_problematic_if right = + match expr_kind right with + | KStatement | KExprWithStatement -> true + | _ -> false + in + + match expr.eexpr with + | TBinop((Ast.OpAssign as op),left,right) + | TBinop((Ast.OpAssignOp _ as op),left,right) when shallow_expr_type right = Statement -> + handle_assign op left right + | TReturn( Some right ) when shallow_expr_type right = Statement -> + handle_return right + | TBinop((Ast.OpAssign as op),left, ({ eexpr = TBinop(Ast.OpBoolAnd,_,_) } as right) ) + | TBinop((Ast.OpAssign as op),left,({ eexpr = TBinop(Ast.OpBoolOr,_,_) } as right)) + | TBinop((Ast.OpAssignOp _ as op),left,({ eexpr = TBinop(Ast.OpBoolAnd,_,_) } as right) ) + | TBinop((Ast.OpAssignOp _ as op),left,({ eexpr = TBinop(Ast.OpBoolOr,_,_) } as right) ) -> + let right = short_circuit_op_unwrap gen add_statement right in + Some { expr with eexpr = TBinop(op, check_left left, right) } + | TVars([v,Some({ eexpr = TBinop(Ast.OpBoolAnd,_,_) } as right)]) + | TVars([v,Some({ eexpr = TBinop(Ast.OpBoolOr,_,_) } as right)]) -> + let right = short_circuit_op_unwrap gen add_statement right in + Some { expr with eexpr = TVars([v, Some(right)]) } + | TVars([v,Some(right)]) when shallow_expr_type right = Statement -> + add_statement ({ expr with eexpr = TVars([v, Some(null right.etype right.epos)]) }); + handle_assign Ast.OpAssign { expr with eexpr = TLocal(v); etype = v.v_type } right + (* TIf handling *) + | TBinop((Ast.OpAssign as op),left, ({ eexpr = TIf _ } as right)) + | TBinop((Ast.OpAssignOp _ as op),left,({ eexpr = TIf _ } as right)) when is_problematic_if right -> + handle_assign op left right + | TVars([v,Some({ eexpr = TIf _ } as right)]) when is_problematic_if right -> + add_statement ({ expr with eexpr = TVars([v, Some(null right.etype right.epos)]) }); + handle_assign Ast.OpAssign { expr with eexpr = TLocal(v); etype = v.v_type } right + | TWhile(cond, e1, flag) when is_problematic_if cond -> + twhile_with_condition_statement gen add_statement expr cond e1 flag; + Some (null expr.etype expr.epos) + | _ -> None + + + let traverse gen (on_expr_as_statement:texpr->texpr option) = + + let add_assign = add_assign gen in + + let problematic_expression_unwrap add_statement expr e_type = + let rec problematic_expression_unwrap is_first expr e_type = + match e_type, expr.eexpr with + | _, TBinop(Ast.OpBoolAnd, _, _) + | _, TBinop(Ast.OpBoolOr, _, _) -> add_assign add_statement expr (* add_assign so try_call_unwrap_expr *) + | KNoSideEffects, _ -> expr + | KStatement, _ + | KNormalExpr, _ -> add_assign add_statement expr + | KExprWithStatement, TCall _ + | KExprWithStatement, TNew _ + | KExprWithStatement, TBinop (Ast.OpAssign,_,_) + | KExprWithStatement, TBinop (Ast.OpAssignOp _,_,_) + | KExprWithStatement, TUnop (Ast.Increment,_,_) (* all of these may have side-effects, so they must also be add_assign'ed . is_first avoids infinite loop *) + | KExprWithStatement, TUnop (Ast.Decrement,_,_) when not is_first -> add_assign add_statement expr + + (* bugfix: Type.map_expr doesn't guarantee the correct order of execution *) + | KExprWithStatement, TBinop(op,e1,e2) -> + let e1 = problematic_expression_unwrap false e1 (expr_kind e1) in + let e2 = problematic_expression_unwrap false e2 (expr_kind e2) in + { expr with eexpr = TBinop(op, e1, e2) } + | KExprWithStatement, TArray(e1,e2) -> + let e1 = problematic_expression_unwrap false e1 (expr_kind e1) in + let e2 = problematic_expression_unwrap false e2 (expr_kind e2) in + { expr with eexpr = TArray(e1, e2) } + (* bugfix: calls should not be transformed into closure calls *) + | KExprWithStatement, TCall(( { eexpr = TField (ef_left, f) } as ef ), eargs) -> + { expr with eexpr = TCall( + { ef with eexpr = TField(problematic_expression_unwrap false ef_left (expr_kind ef_left), f) }, + List.map (fun e -> problematic_expression_unwrap false e (expr_kind e)) eargs) + } + | KExprWithStatement, _ -> Type.map_expr (fun e -> problematic_expression_unwrap false e (expr_kind e)) expr + in + problematic_expression_unwrap true expr e_type + in + + let rec traverse e = + match e.eexpr with + | TBlock el -> + let new_block = ref [] in + let rec process_statement e = + let e = no_paren e in + match e.eexpr, shallow_expr_type e with + | TVars( (hd1 :: hd2 :: _) as vars ), _ -> + List.iter (fun v -> process_statement { e with eexpr = TVars([v]) }) vars + | TCall( { eexpr = TLocal v } as elocal, elist ), _ when String.get v.v_name 0 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name -> + new_block := { e with eexpr = TCall( elocal, List.map (fun e -> + match e.eexpr with + | TBlock _ -> traverse e + | _ -> e + ) elist ) } :: !new_block + | _, Statement | _, Both _ -> + let e = match e.eexpr with | TReturn (Some ({ eexpr = TThrow _ } as ethrow)) -> ethrow | _ -> e in + let kinds = get_kinds e in + if has_problematic_expressions kinds then begin + match try_call_unwrap_statement gen problematic_expression_unwrap add_statement e with + | Some { eexpr = TConst(TNull) } (* no op *) + | Some { eexpr = TBlock [] } -> () + | Some e -> + if has_problematic_expressions (get_kinds e) then begin + process_statement e + end else + new_block := (traverse e) :: !new_block + | None -> + ( + let acc = ref kinds in + let new_e = expr_stat_map (fun e -> + match !acc with + | hd :: tl -> + acc := tl; + if has_problematic_expressions (hd :: tl) then begin + problematic_expression_unwrap add_statement e hd + end else + e + | [] -> assert false + ) e in + + new_block := (traverse new_e) :: !new_block + ) + end else begin new_block := (traverse e) :: !new_block end + | _, Expression e -> + match on_expr_as_statement e with + | None -> () + | Some e -> process_statement e + and add_statement expr = + process_statement expr + in + + List.iter (process_statement) el; + let block = List.rev !new_block in + { e with eexpr = TBlock(block) } + | TTry (block, catches) -> + { e with eexpr = TTry(traverse (mk_block block), List.map (fun (v,block) -> (v, traverse (mk_block block))) catches) } + | TMatch (cond,ep,il_vol_e_l,default) -> + { e with eexpr = TMatch(cond,ep,List.map (fun (il,vol,e) -> (il,vol,traverse (mk_block e))) il_vol_e_l, Option.map (fun e -> traverse (mk_block e)) default) } + | TSwitch (cond,el_e_l, default) -> + { e with eexpr = TSwitch(cond, List.map (fun (el,e) -> (el, traverse (mk_block e))) el_e_l, Option.map (fun e -> traverse (mk_block e)) default) } + | TWhile (cond,block,flag) -> + {e with eexpr = TWhile(cond,traverse (mk_block block), flag) } + | TIf (cond, eif, eelse) -> + { e with eexpr = TIf(cond, traverse (mk_block eif), Option.map (fun e -> traverse (mk_block e)) eelse) } + | TFor (v,it,block) -> + { e with eexpr = TFor(v,it, traverse (mk_block block)) } + | TFunction (tfunc) -> + { e with eexpr = TFunction({ tfunc with tf_expr = traverse (mk_block tfunc.tf_expr) }) } + | _ -> e (* if expression doesn't have a block, we will exit *) + in + traverse + + 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;; + +(* ******************************************* *) +(* Casts detection v2 *) +(* ******************************************* *) + +(* + + Will detect implicit casts and add TCast for them. Since everything is already followed by follow_all, typedefs are considered a new type altogether + + Types shouldn't be cast if: + * When an instance is being coerced to a superclass or to an implemented interface + * When anything is being coerced to Dynamic + + edit: + As a matter of performance, we will also run the type parameters casts in here. Otherwise the exact same computation would have to be performed twice, + with maybe even some loss of information + + * TAnon / TDynamic will call + * Type parameter handling will be abstracted + + dependencies: + Must run before ExpressionUnwrap + +*) + +module CastDetect = +struct + + let name = "cast_detect_2" + + let priority = solve_deps name [DBefore TypeParams.priority; DBefore ExpressionUnwrap.priority] + + (* ******************************************* *) + (* ReturnCast *) + (* ******************************************* *) + + (* + + Cast detection for return types can't be done at CastDetect time, since we need an + unwrapped expression to make sure we catch all return cast detections. So this module + is specifically to deal with that, and is configured automatically by CastDetect + + dependencies: + + + *) + + module ReturnCast = + struct + + let name = "return_cast" + + let priority = solve_deps name [DAfter priority; DAfter ExpressionUnwrap.priority] + + let default_implementation gen = + let rec extract_expr e = match e.eexpr with + | TParenthesis e + | TCast(e,_) -> extract_expr e + | _ -> e + in + let current_ret_type = ref None in + let handle e tto tfrom = gen.ghandle_cast (gen.greal_type tto) (gen.greal_type tfrom) e in + let in_value = ref false in + + let rec run e = + let was_in_value = !in_value in + in_value := true; + match e.eexpr with + | TReturn (eopt) -> + (* a return must be inside a function *) + let ret_type = match !current_ret_type with | Some(s) -> s | None -> gen.gcon.error "Invalid return outside function declaration." e.epos; assert false in + (match eopt with + | None when not (is_void ret_type) -> + { e with eexpr = TReturn( Some(null ret_type e.epos)) } + | None -> e + | Some eret -> + { e with eexpr = TReturn( Some(handle (run eret) ret_type eret.etype ) ) }) + | TFunction(tfunc) -> + let last_ret = !current_ret_type in + current_ret_type := Some(tfunc.tf_type); + let ret = Type.map_expr run e in + current_ret_type := last_ret; + ret + | TBlock el -> + { e with eexpr = TBlock ( List.map (fun e -> in_value := false; run e) el ) } + | TBinop ( (Ast.OpAssign as op),e1,e2) + | TBinop ( (Ast.OpAssignOp _ as op),e1,e2) when was_in_value -> + let e1 = extract_expr (run e1) in + let r = { e with eexpr = TBinop(op, e1, handle (run e2) e1.etype e2.etype); etype = e1.etype } in + handle r e.etype e1.etype + | TBinop ( (Ast.OpAssign as op),({ eexpr = TField(tf, f) } as e1), e2 ) + | TBinop ( (Ast.OpAssignOp _ as op),({ eexpr = TField(tf, f) } as e1), e2 ) -> + (match field_access gen (gen.greal_type tf.etype) (field_name f) with + | FClassField(cl,params,_,_,is_static,actual_t,_) -> + let actual_t = if is_static then actual_t else apply_params cl.cl_types params actual_t in + let e1 = extract_expr (run e1) in + { e with eexpr = TBinop(op, e1, handle (run e2) actual_t e2.etype); etype = e1.etype } + | _ -> + let e1 = extract_expr (run e1) in + { e with eexpr = TBinop(op, e1, handle (run e2) e1.etype e2.etype); etype = e1.etype } + ) + | TBinop ( (Ast.OpAssign as op),e1,e2) + | TBinop ( (Ast.OpAssignOp _ as op),e1,e2) -> + let e1 = extract_expr (run e1) in + { e with eexpr = TBinop(op, e1, handle (run e2) e1.etype e2.etype); etype = e1.etype } + | _ -> Type.map_expr run e + in + run + + let configure gen = + let map e = Some(default_implementation gen e) in + gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map + + end;; + + let get_args t = match follow t with + | TFun(args,ret) -> args,ret + | _ -> trace (debug_type t); assert false + + let s_path (pack,n) = (String.concat "." (pack @ [n])) + + (* + Since this function is applied under native-context only, the type paraters will already be changed + *) + let map_cls gen also_implements fn super = + let rec loop c tl = + if c == super then + fn c tl + else (match c.cl_super with + | None -> false + | Some (cs,tls) -> + let tls = gen.greal_type_param (TClassDecl cs) tls in + loop cs (List.map (apply_params c.cl_types tl) tls) + ) || (if also_implements then List.exists (fun (cs,tls) -> + loop cs (List.map (apply_params c.cl_types tl) tls) + ) c.cl_implements else false) + in + loop + + let follow_dyn t = match follow t with + | TMono _ | TLazy _ -> t_dynamic + | t -> t + + (* + this has a slight change from the type.ml version, in which it doesn't + change a TMono into the other parameter + *) + let rec type_eq gen param a b = + if a == b then + () + else match follow_dyn (gen.greal_type a) , follow_dyn (gen.greal_type b) with + | TEnum (e1,tl1) , TEnum (e2,tl2) -> + if e1 != e2 && not (param = EqCoreType && e1.e_path = e2.e_path) then Type.error [cannot_unify a b]; + List.iter2 (type_eq gen param) tl1 tl2 + | TAbstract (a1,tl1) , TAbstract (a2,tl2) -> + if a1 != a2 && not (param = EqCoreType && a1.a_path = a2.a_path) then Type.error [cannot_unify a b]; + List.iter2 (type_eq gen param) tl1 tl2 + | TInst (c1,tl1) , TInst (c2,tl2) -> + if c1 != c2 && not (param = EqCoreType && c1.cl_path = c2.cl_path) && (match c1.cl_kind, c2.cl_kind with KExpr _, KExpr _ -> false | _ -> true) then Type.error [cannot_unify a b]; + List.iter2 (type_eq gen param) tl1 tl2 + | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 -> + (try + type_eq gen param r1 r2; + List.iter2 (fun (n,o1,t1) (_,o2,t2) -> + if o1 <> o2 then Type.error [Not_matching_optional n]; + type_eq gen param t1 t2 + ) l1 l2 + with + Unify_error l -> Type.error (cannot_unify a b :: l)) + | TDynamic a , TDynamic b -> + type_eq gen param a b + | TAnon a1, TAnon a2 -> + (try + PMap.iter (fun n f1 -> + try + let f2 = PMap.find n a2.a_fields in + if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then Type.error [invalid_kind n f1.cf_kind f2.cf_kind]; + try + type_eq gen param f1.cf_type f2.cf_type + with + Unify_error l -> Type.error (invalid_field n :: l) + with + Not_found -> + if is_closed a2 then Type.error [has_no_field b n]; + if not (link (ref None) b f1.cf_type) then Type.error [cannot_unify a b]; + a2.a_fields <- PMap.add n f1 a2.a_fields + ) a1.a_fields; + PMap.iter (fun n f2 -> + if not (PMap.mem n a1.a_fields) then begin + if is_closed a1 then Type.error [has_no_field a n]; + if not (link (ref None) a f2.cf_type) then Type.error [cannot_unify a b]; + a1.a_fields <- PMap.add n f2 a1.a_fields + end; + ) a2.a_fields; + with + Unify_error l -> Type.error (cannot_unify a b :: l)) + | _ , _ -> + if b == t_dynamic && (param = EqRightDynamic || param = EqBothDynamic) then + () + else if a == t_dynamic && param = EqBothDynamic then + () + else + Type.error [cannot_unify a b] + + let type_iseq gen a b = + try + type_eq gen EqStrict a b; + true + with + Unify_error _ -> false + + (* will return true if both arguments are compatible. If it's not the case, a runtime error is very likely *) + let is_cl_related gen cl tl super superl = + let is_cl_related cl tl super superl = map_cls gen (gen.guse_tp_constraints || (match cl.cl_kind,super.cl_kind with KTypeParameter _, _ | _,KTypeParameter _ -> false | _ -> true)) (fun _ _ -> true) super cl tl in + is_cl_related cl tl super superl || is_cl_related super superl cl tl + + + let rec is_unsafe_cast gen to_t from_t = + match (follow to_t, follow from_t) with + | TInst(cl_to, to_params), TInst(cl_from, from_params) -> + not (is_cl_related gen cl_from from_params cl_to to_params) + | TEnum(e_to, _), TEnum(e_from, _) -> + e_to.e_path <> e_from.e_path + | TFun _, TFun _ -> + (* functions are never unsafe cast by default. This behavior might be changed *) + (* with a later AST pass which will run through TFun to TFun casts *) + false + | TMono _, _ + | _, TMono _ + | TDynamic _, _ + | _, TDynamic _ -> + false + | TAnon _, _ + | _, TAnon _ -> + (* anonymous are never unsafe also. *) + (* Though they will generate a cast, so if this cast is unneeded it's better to avoid them by tweaking gen.greal_type *) + false + | TAbstract _, _ + | _, TAbstract _ -> + (try + unify from_t to_t; + false + with | Unify_error _ -> + try + unify to_t from_t; (* still not unsafe *) + false + with | Unify_error _ -> + true) + | _ -> true + + let do_unsafe_cast gen from_t to_t e = + let t_path t = + match t with + | TInst(cl, _) -> cl.cl_path + | TEnum(e, _) -> e.e_path + | TType(t, _) -> t.t_path + | TAbstract(a, _) -> a.a_path + | TDynamic _ -> ([], "Dynamic") + | _ -> raise Not_found + in + let do_default () = + gen.gon_unsafe_cast to_t e.etype e.epos; + mk_cast to_t (mk_cast t_dynamic e) + in + (* TODO: there really should be a better way to write that *) + try + if (Hashtbl.find gen.gsupported_conversions (t_path from_t)) from_t to_t then + mk_cast to_t e + else + do_default() + with + | Not_found -> + try + if (Hashtbl.find gen.gsupported_conversions (t_path to_t)) from_t to_t then + mk_cast to_t e + else + do_default() + with + | Not_found -> do_default() + + (* ****************************** *) + (* cast handler *) + (* decides if a cast should be emitted, given a from and a to type *) + (* + this function is like a mini unify, without e.g. subtyping, which makes sense + at the backend level, since most probably Anons and TInst will have a different representation there + *) + let rec handle_cast gen e real_to_t real_from_t = + let do_unsafe_cast () = do_unsafe_cast gen real_from_t real_to_t { e with etype = real_from_t } in + let to_t, from_t = real_to_t, real_from_t in + + let mk_cast t e = + match e.eexpr with + (* TThrow is always typed as Dynamic, we just need to type it accordingly *) + | TThrow _ -> { e with etype = t } + | _ -> mk_cast t e + in + + let e = { e with etype = real_from_t } in + if try fast_eq real_to_t real_from_t with Invalid_argument("List.for_all2") -> false then e else + match real_to_t, real_from_t with + (* string is the only type that can be implicitly converted from any other *) + | TInst( { cl_path = ([], "String") }, []), _ -> + mk_cast to_t e + | TInst(cl_to, params_to), TInst(cl_from, params_from) -> + let ret = ref None in + (* + this is a little confusing: + we are here mapping classes until we have the same to and from classes, applying the type parameters in each step, so we can + compare the type parameters; + + If a class is found - meaning that the cl_from can be converted without a cast into cl_to, + we still need to check their type parameters. + *) + ignore (map_cls gen (gen.guse_tp_constraints || (match cl_from.cl_kind,cl_to.cl_kind with KTypeParameter _, _ | _,KTypeParameter _ -> false | _ -> true)) (fun _ tl -> + try + (* type found, checking type parameters *) + List.iter2 (type_eq gen EqStrict) tl params_to; + ret := Some e; + true + with | Unify_error _ -> + (* type parameters need casting *) + if gen.ghas_tparam_cast_handler then begin + (* + if we are already handling type parameter casts on other part of code (e.g. RealTypeParameters), + we'll just make a cast to indicate that this place needs type parameter-involved casting + *) + ret := Some (mk_cast to_t e); + true + end else + (* + if not, we're going to check if we only need a simple cast, + or if we need to first cast into the dynamic version of it + *) + try + List.iter2 (type_eq gen EqRightDynamic) tl params_to; + ret := Some (mk_cast to_t e); + true + with | Unify_error _ -> + ret := Some (mk_cast to_t (mk_cast (TInst(cl_to, List.map (fun _ -> t_dynamic) params_to)) e)); + true + ) cl_to cl_from params_from); + if is_some !ret then + get !ret + else if is_cl_related gen cl_from params_from cl_to params_to then + mk_cast to_t e + else + (* potential unsafe cast *) + (do_unsafe_cast ()) + | TMono _, TMono _ + | TMono _, TDynamic _ + | TDynamic _, TDynamic _ + | TDynamic _, TMono _ -> + e + | TMono _, _ + | TDynamic _, _ + | TAnon _, _ when gen.gneeds_box real_from_t -> + mk_cast to_t e + | TMono _, _ + | TDynamic _, _ -> e + | _, TMono _ + | _, TDynamic _ -> mk_cast to_t e + | TAnon (a_to), TAnon (a_from) -> + if a_to == a_from then + e + else if type_iseq gen to_t from_t then (* FIXME apply unify correctly *) + e + else + mk_cast to_t e + | _, TAnon(anon) -> (try + let p2 = match !(anon.a_status) with + | Statics c -> TInst(c,List.map (fun _ -> t_dynamic) c.cl_types) + | EnumStatics e -> TEnum(e, List.map (fun _ -> t_dynamic) e.e_types) + | AbstractStatics a -> TAbstract(a, List.map (fun _ -> t_dynamic) a.a_types) + | _ -> raise Not_found + in + let tclass = match get_type gen ([],"Class") with + | TAbstractDecl(a) -> a + | _ -> assert false in + handle_cast gen e real_to_t (gen.greal_type (TAbstract(tclass, [p2]))) + with | Not_found -> + mk_cast to_t e) + | TAbstract (a_to, _), TAbstract(a_from, _) when a_to == a_from -> + e + | TAbstract _, _ + | _, TAbstract _ -> + (try + unify from_t to_t; + mk_cast to_t e + with | Unify_error _ -> + try + unify to_t from_t; + mk_cast to_t e + with | Unify_error _ -> + do_unsafe_cast()) + | TEnum(e_to, []), TEnum(e_from, []) -> + if e_to == e_from then + e + else + (* potential unsafe cast *) + (do_unsafe_cast ()) + | TEnum(e_to, params_to), TEnum(e_from, params_from) when e_to.e_path = e_from.e_path -> + (try + List.iter2 (type_eq gen (if gen.gallow_tp_dynamic_conversion then EqRightDynamic else EqStrict)) params_from params_to; + e + with + | Unify_error _ -> do_unsafe_cast () + ) + | TEnum(en, params_to), TInst(cl, params_from) + | TInst(cl, params_to), TEnum(en, params_from) -> + (* this is here for max compatibility with EnumsToClass module *) + if en.e_path = cl.cl_path && en.e_extern then begin + (try + List.iter2 (type_eq gen (if gen.gallow_tp_dynamic_conversion then EqRightDynamic else EqStrict)) params_from params_to; + e + with + | Invalid_argument("List.iter2") -> + (* + this is a hack for RealTypeParams. Since there is no way at this stage to know if the class is the actual + EnumsToClass derived from the enum, we need to imply from possible ArgumentErrors (because of RealTypeParams interfaces), + that they would only happen if they were a RealTypeParams created interface + *) + e + | Unify_error _ -> do_unsafe_cast () + ) + end else + do_unsafe_cast () + | TType(t_to, params_to), TType(t_from, params_from) when t_to == t_from -> + if gen.gspecial_needs_cast real_to_t real_from_t then + (try + List.iter2 (type_eq gen (if gen.gallow_tp_dynamic_conversion then EqRightDynamic else EqStrict)) params_from params_to; + e + with + | Unify_error _ -> do_unsafe_cast () + ) + else + e + | TType(t_to, _), TType(t_from,_) -> + if gen.gspecial_needs_cast real_to_t real_from_t then + mk_cast to_t e + else + e + | TType _, _ when gen.gspecial_needs_cast real_to_t real_from_t -> + mk_cast to_t e + | _, TType _ when gen.gspecial_needs_cast real_to_t real_from_t -> + mk_cast to_t e + (*| TType(t_to, _), TType(t_from, _) -> + if t_to.t_path = t_from.t_path then + e + else if is_unsafe_cast gen real_to_t real_from_t then (* is_unsafe_cast will already follow both *) + (do_unsafe_cast ()) + else + mk_cast to_t e*) + | TType _, _ + | _, TType _ -> + if is_unsafe_cast gen real_to_t real_from_t then (* is_unsafe_cast will already follow both *) + (do_unsafe_cast ()) + else + mk_cast to_t e + | TAnon anon, _ -> + if PMap.is_empty anon.a_fields then + e + else + mk_cast to_t e + | TFun(args, ret), TFun(args2, ret2) -> + let get_args = List.map (fun (_,_,t) -> t) in + (try List.iter2 (type_eq gen (EqBothDynamic)) (ret :: get_args args) (ret2 :: get_args args2); e with | Unify_error _ | Invalid_argument("List.iter2") -> mk_cast to_t e) + | _, _ -> + do_unsafe_cast () + + (* end of cast handler *) + (* ******************* *) + + let is_static_overload c name = + match c.cl_super with + | None -> false + | Some (sup,_) -> + let rec loop c = + (PMap.mem name c.cl_statics) || (match c.cl_super with + | None -> false + | Some (sup,_) -> loop sup) + in + loop sup + + let does_unify a b = + try + unify a b; + true + with | Unify_error _ -> false + + (* this is a workaround for issue #1743, as FInstance() is returning the incorrect classfield *) + let select_overload gen applied_f overloads types params = + let rec check_arg arglist elist = + match arglist, elist with + | [], [] -> true (* it is valid *) + | (_,_,t) :: arglist, (_,_,et) :: elist when Type.type_iseq et t -> + check_arg arglist elist + | _ -> false + in + match follow applied_f with + | TFun _ -> + replace_mono applied_f; + let args, _ = get_fun applied_f in + let elist = List.rev args in + let rec check_overload overloads = + match overloads with + | (t, cf) :: overloads -> + let cft = apply_params types params t in + let cft = monomorphs cf.cf_params cft in + let args, _ = get_fun cft in + if check_arg (List.rev args) elist then + cf,t,false + else if overloads = [] then + cf,t,true (* no compatible overload was found *) + else + check_overload overloads + | [] -> assert false + in + check_overload overloads + | _ -> match overloads with (* issue #1742 *) + | (t,cf) :: [] -> cf,t,true + | (t,cf) :: _ -> cf,t,false + | _ -> assert false + + let choose_ctor gen cl tparams etl maybe_empty_t p = + let ctor, sup, stl = OverloadingConstructor.cur_ctor cl tparams in + (* get returned stl, with Dynamic as t_empty *) + let rec get_changed_stl c tl = + if c == sup then + tl + else match c.cl_super with + | None -> stl + | Some(sup,stl) -> get_changed_stl sup (List.map (apply_params c.cl_types tl) stl) + in + let ret_tparams = List.map (fun t -> match follow t with + | TDynamic _ | TMono _ -> t_empty + | _ -> t) tparams in + let ret_stl = get_changed_stl cl ret_tparams in + let ctors = ctor :: ctor.cf_overloads in + List.iter replace_mono etl; + (* first filter out or select outright maybe_empty *) + let ctors, is_overload = match etl, maybe_empty_t with + | [t], Some empty_t -> + let count = ref 0 in + let is_empty_call = Type.type_iseq t empty_t in + let ret = List.filter (fun cf -> match follow cf.cf_type with + (* | TFun([_,_,t],_) -> incr count; true *) + | TFun([_,_,t],_) -> replace_mono t; incr count; is_empty_call = (Type.type_iseq t empty_t) + | _ -> false) ctors in + ret, !count > 1 + | _ -> + let len = List.length etl in + let ret = List.filter (fun cf -> List.length (fst (get_fun cf.cf_type)) = len) ctors in + ret, (match ret with | _ :: [] -> false | _ -> true) + in + let rec check_arg arglist elist = + match arglist, elist with + | [], [] -> true + | (_,_,t) :: arglist, et :: elist -> (try + unify et t; + check_arg arglist elist + with | Unify_error el -> + (* List.iter (fun el -> gen.gcon.warning (Typecore.unify_error_msg (print_context()) el) p) el; *) + false) + | _ -> false + in + let rec check_cf cf = + let t = apply_params sup.cl_types stl cf.cf_type in + replace_mono t; + let args, _ = get_fun t in + check_arg args etl + in + is_overload, List.find check_cf ctors, sup, ret_stl + + (* + + Type parameter handling + It will detect if/what type parameters were used, and call the cast handler + It will handle both TCall(TField) and TCall by receiving a texpr option field: e + Also it will transform the type parameters with greal_type_param and make + + handle_impossible_tparam - should cases where the type parameter is impossible to be determined from the called parameters be Dynamic? + e.g. static function test():T {} + *) + + (* match e.eexpr with | TCall( ({ eexpr = TField(ef, f) }) as e1, elist ) -> *) + let handle_type_parameter gen e e1 ef ~clean_ef ~overloads_cast_to_base f elist calls_parameters_explicitly = + (* the ONLY way to know if this call has parameters is to analyze the calling field. *) + (* To make matters a little worse, on both C# and Java only in some special cases that type parameters will be used *) + (* Namely, when using reflection type parameters are useless, of course. This also includes anonymous types *) + (* this will have to be handled by gparam_func_call *) + + let return_var efield = + match e with + | None -> + efield + | Some ecall -> + match follow efield.etype with + | TFun(_,ret) -> + (* closures will be handled by the closure handler. So we will just hint what's the expected type *) + (* FIXME: should closures have also its arguments cast correctly? In the current implementation I think not. TO_REVIEW *) + handle_cast gen { ecall with eexpr = TCall(efield, elist) } (gen.greal_type ecall.etype) ret + | _ -> + { ecall with eexpr = TCall(efield, elist) } + in + + let real_type = gen.greal_type ef.etype in + (* this part was rewritten at roughly r6477 in order to correctly support overloads *) + (match field_access gen real_type (field_name f) with + | FClassField (cl, params, _, cf, is_static, actual_t, declared_t) when e <> None && (cf.cf_kind = Method MethNormal || cf.cf_kind = Method MethInline) -> + (* C# target changes params with a real_type function *) + let params = match follow clean_ef.etype with + | TInst(_,params) -> params + | _ -> params in + let ecall = get e in + let ef = ref ef in + let is_overload = cf.cf_overloads <> [] || Meta.has Meta.Overload cf.cf_meta || (is_static && is_static_overload cl (field_name f)) in + let cf, actual_t, error = match is_overload with + | false -> + (* since actual_t from FClassField already applies greal_type, we're using the get_overloads helper to get this info *) + cf,declared_t,false + | true -> + let (cf, actual_t, error), is_static = match f with + | FInstance(c,cf) | FClosure(Some c,cf) -> + (* get from overloads *) + (* FIXME: this is a workaround for issue #1743 . Uncomment this code after it was solved *) + (* let t, cf = List.find (fun (t,cf2) -> cf == cf2) (Typeload.get_overloads cl (field_name f)) in *) + (* cf, t, false *) + select_overload gen e1.etype (Typeload.get_overloads cl (field_name f)) cl.cl_types params, false + | FStatic(c,f) -> + (* workaround for issue #1743 *) + (* f,f.cf_type, false *) + select_overload gen e1.etype ((f.cf_type,f) :: List.map (fun f -> f.cf_type,f) f.cf_overloads) [] [], true + | _ -> + gen.gcon.warning "Overloaded classfield typed as anonymous" ecall.epos; + (cf, actual_t, true), true + in + if not (is_static || error) then match find_first_declared_field gen cl ~exact_field:{ cf with cf_type = actual_t } cf.cf_name with + | Some(_,actual_t,_,_,declared_cl,tl,tlch) -> + if declared_cl != cl && overloads_cast_to_base then begin + let pos = (!ef).epos in + ef := { + eexpr = TCall( + { eexpr = TLocal(alloc_var "__as__" t_dynamic); etype = t_dynamic; epos = pos }, + [!ef]); + etype = TInst(declared_cl,List.map (apply_params cl.cl_types params) tl); + epos = pos + } + end; + cf,actual_t,false + | None -> + gen.gcon.warning "Cannot find matching overload" ecall.epos; + cf, actual_t, true + else + cf,actual_t,error + in + let error = error || (match follow actual_t with | TFun _ -> false | _ -> true) in + if error then (* if error, ignore arguments *) + mk_cast ecall.etype { ecall with eexpr = TCall({ e1 with eexpr = TField(!ef, f) }, elist ) } + else begin + (* infer arguments *) + (* let called_t = TFun(List.map (fun e -> "arg",false,e.etype) elist, ecall.etype) in *) + let called_t = match follow e1.etype with | TFun _ -> e1.etype | _ -> TFun(List.map (fun e -> "arg",false,e.etype) elist, ecall.etype) in (* workaround for issue #1742 *) + let fparams = TypeParams.infer_params gen ecall.epos (get_fun (apply_params cl.cl_types params actual_t)) (get_fun called_t) cf.cf_params calls_parameters_explicitly in + (* get what the backend actually sees *) + (* actual field's function *) + let actual_t = get_real_fun gen actual_t in + let real_params = gen.greal_type_param (TClassDecl cl) params in + let function_t = apply_params cl.cl_types real_params actual_t in + let real_fparams = if calls_parameters_explicitly then + gen.greal_type_param (TClassDecl cl) fparams + else + gen.greal_type_param (TClassDecl cl) (TypeParams.infer_params gen ecall.epos (get_fun function_t) (get_fun (get_real_fun gen called_t)) cf.cf_params calls_parameters_explicitly) in + let function_t = get_real_fun gen (apply_params cf.cf_params real_fparams function_t) in + let args_ft, ret_ft = get_fun function_t in + (* applied function *) + let applied = elist in + (* check types list *) + let new_ecall, elist = try + let elist = List.map2 (fun applied (_,_,funct) -> + match is_overload, applied.eexpr with + | true, TConst TNull -> + mk_cast (gen.greal_type funct) applied + | true, _ -> (* when not (type_iseq gen (gen.greal_type applied.etype) funct) -> *) + let ret = handle_cast gen applied (funct) (gen.greal_type applied.etype) in + (match ret.eexpr with + | TCast _ -> ret + | _ -> mk_cast (funct) ret) + | _ -> + handle_cast gen applied (funct) (gen.greal_type applied.etype) + ) applied args_ft in + { ecall with + eexpr = TCall( + { e1 with eexpr = TField(!ef, f) }, + elist); + }, elist + with | Invalid_argument("List.map2") -> + gen.gcon.warning ("This expression may be invalid" ) ecall.epos; + { ecall with eexpr = TCall({ e1 with eexpr = TField(!ef, f) }, elist) }, elist + in + let new_ecall = if fparams <> [] then gen.gparam_func_call new_ecall { e1 with eexpr = TField(!ef, f) } fparams elist else new_ecall in + handle_cast gen new_ecall (gen.greal_type ecall.etype) (gen.greal_type ret_ft) + end + | FClassField (cl,params,_,{ cf_kind = (Method MethDynamic | Var _) },_,actual_t,_) -> + (* if it's a var, we will just try to apply the class parameters that have been changed with greal_type_param *) + let t = apply_params cl.cl_types (gen.greal_type_param (TClassDecl cl) params) (gen.greal_type actual_t) in + return_var (handle_cast gen { e1 with eexpr = TField(ef, f) } (gen.greal_type e1.etype) (gen.greal_type t)) + | FClassField (cl,params,_,cf,_,actual_t,_) -> + return_var (handle_cast gen { e1 with eexpr = TField({ ef with etype = t_dynamic }, f) } e1.etype t_dynamic) (* force dynamic and cast back to needed type *) + | FEnumField (en, efield, true) -> + let ecall = match e with | None -> trace (field_name f); trace efield.ef_name; gen.gcon.error "This field should be called immediately" ef.epos; assert false | Some ecall -> ecall in + (match en.e_types with + (* + | [] -> + let args, ret = get_args (efield.ef_type) in + let ef = { ef with eexpr = TTypeExpr( TEnumDecl en ); etype = TEnum(en, []) } in + handle_cast gen { ecall with eexpr = TCall({ e1 with eexpr = TField(ef, FEnum(en, efield)) }, List.map2 (fun param (_,_,t) -> handle_cast gen param (gen.greal_type t) (gen.greal_type param.etype)) elist args) } (gen.greal_type ecall.etype) (gen.greal_type ret) + *) + | _ -> + let pt = match e with | None -> real_type | Some _ -> snd (get_fun e1.etype) in + let _params = match follow pt with | TEnum(_, p) -> p | _ -> gen.gcon.warning (debug_expr e1) e1.epos; assert false in + let args, ret = get_args efield.ef_type in + let actual_t = TFun(List.map (fun (n,o,t) -> (n,o,gen.greal_type t)) args, gen.greal_type ret) in + (* + because of differences on how is handled on the platforms, this is a hack to be able to + correctly use class field type parameters with RealTypeParams + *) + let cf_params = List.map (fun t -> match follow t with | TDynamic _ -> t_empty | _ -> t) _params in + (* params are inverted *) + let cf_params = List.rev cf_params in + let t = apply_params en.e_types (gen.greal_type_param (TEnumDecl en) cf_params) actual_t in + let t = apply_params efield.ef_params (List.map (fun _ -> t_dynamic) efield.ef_params) t in + + let args, ret = get_args t in + + let elist = List.map2 (fun param (_,_,t) -> handle_cast gen (param) (gen.greal_type t) (gen.greal_type param.etype)) elist args in + let e1 = { e1 with eexpr = TField({ ef with eexpr = TTypeExpr( TEnumDecl en ); etype = TEnum(en, _params) }, FEnum(en, efield) ) } in + let new_ecall = gen.gparam_func_call ecall e1 _params elist in + + handle_cast gen new_ecall (gen.greal_type ecall.etype) (gen.greal_type ret) + ) + | FEnumField _ when is_some e -> assert false + | FEnumField (en,efield,_) -> + return_var { e1 with eexpr = TField({ ef with eexpr = TTypeExpr( TEnumDecl en ); },FEnum(en,efield)) } + (* no target by date will uses this.so this code may not be correct at all *) + | FAnonField cf -> + let t = gen.greal_type cf.cf_type in + return_var (handle_cast gen { e1 with eexpr = TField(ef, f) } (gen.greal_type e1.etype) t) + | FNotFound + | FDynamicField _ -> + if is_some e then + return_var { e1 with eexpr = TField(ef, f) } + else + return_var (handle_cast gen { e1 with eexpr = TField({ ef with etype = t_dynamic }, f) } e1.etype t_dynamic) (* force dynamic and cast back to needed type *) + ) + + (* end of type parameter handling *) + (* ****************************** *) + + (** overloads_cast_to_base argument will cast overloaded function types to the class that declared it. **) + (** This is necessary for C#, and if true, will require the target to implement __as__, as a `quicker` form of casting **) + let default_implementation gen ?(native_string_cast = true) ?(overloads_cast_to_base = false) maybe_empty_t calls_parameters_explicitly = + let handle e t1 t2 = handle_cast gen e (gen.greal_type t1) (gen.greal_type t2) in + + let in_value = ref false in + + let rec run ?(just_type = false) e = + let handle = if not just_type then handle else fun e t1 t2 -> { e with etype = gen.greal_type t2 } in + let was_in_value = !in_value in + in_value := true; + match e.eexpr with + | TBinop ( (Ast.OpAssign | Ast.OpAssignOp _ as op), e1, e2 ) -> + { e with eexpr = TBinop(op, run ~just_type:true e1, run e2) } + | TField(ef, f) -> + handle_type_parameter gen None e (run ef) ~clean_ef:ef ~overloads_cast_to_base:overloads_cast_to_base f [] calls_parameters_explicitly + | TArrayDecl el -> + let et = e.etype in + let base_type = match follow et with + | TInst({ cl_path = ([], "Array") } as cl, bt) -> gen.greal_type_param (TClassDecl cl) bt + | _ -> assert false + in + let base_type = List.hd base_type in + { e with eexpr = TArrayDecl( List.map (fun e -> handle (run e) base_type e.etype) el ); etype = et } + | TCall( ({ eexpr = TLocal v } as local), params ) when String.get v.v_name 0 = '_' && String.get v.v_name 1 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name -> + { e with eexpr = TCall(local, List.map run params) } + | TCall( ({ eexpr = TField(ef, f) }) as e1, elist ) -> + handle_type_parameter gen (Some e) (e1) (run ef) ~clean_ef:ef ~overloads_cast_to_base:overloads_cast_to_base f (List.map run elist) calls_parameters_explicitly + + (* the TNew and TSuper code was modified at r6497 *) + | TCall( { eexpr = TConst TSuper } as ef, eparams ) -> + let cl, tparams = match follow ef.etype with + | TInst(cl,p) -> cl, p + | _ -> assert false in + (try + let is_overload, cf, sup, stl = choose_ctor gen cl tparams (List.map (fun e -> e.etype) eparams) maybe_empty_t e.epos in + let handle e t1 t2 = + if is_overload then + let ret = handle e t1 t2 in + match ret.eexpr with + | TCast _ -> ret + | _ -> mk_cast (gen.greal_type t1) e + else + handle e t1 t2 + in + let stl = gen.greal_type_param (TClassDecl sup) stl in + let args, _ = get_fun (apply_params sup.cl_types stl cf.cf_type) in + let eparams = List.map2 (fun e (_,_,t) -> + handle (run e) t e.etype + ) eparams args in + { e with eexpr = TCall(ef, eparams) } + with | Not_found -> + gen.gcon.warning "No overload found for this constructor call" e.epos; + { e with eexpr = TCall(ef, List.map run eparams) }) + | TCall (ef, eparams) -> + (match ef.etype with + | TFun(p, ret) -> + handle ({ e with eexpr = TCall(run ef, List.map2 (fun param (_,_,t) -> handle (run param) t param.etype) eparams p) }) e.etype ret + | _ -> Type.map_expr run e + ) + (* the TNew and TSuper code was modified at r6497 *) + | TNew (cl, tparams, eparams) -> (try + let is_overload, cf, sup, stl = choose_ctor gen cl tparams (List.map (fun e -> e.etype) eparams) maybe_empty_t e.epos in + let handle e t1 t2 = + if true then + let ret = handle e t1 t2 in + match ret.eexpr with + | TCast _ -> ret + | _ -> mk_cast (gen.greal_type t1) e + else + handle e t1 t2 + in + let stl = gen.greal_type_param (TClassDecl sup) stl in + let args, _ = get_fun (apply_params sup.cl_types stl cf.cf_type) in + let eparams = List.map2 (fun e (_,_,t) -> + handle (run e) t e.etype + ) eparams args in + { e with eexpr = TNew(cl, tparams, eparams) } + with | Not_found -> + gen.gcon.warning "No overload found for this constructor call" e.epos; + { e with eexpr = TNew(cl, tparams, List.map run eparams) }) + | TArray(arr, idx) -> + let arr_etype = match follow arr.etype with + | (TInst _ as t) -> t + | TAbstract ({ a_impl = Some _ } as a, pl) -> + follow (Codegen.Abstract.get_underlying_type a pl) + | t -> t in + let idx = match gen.greal_type idx.etype with + | TAbstract({ a_path = [],"Int" },_) -> run idx + | _ -> match handle (run idx) gen.gcon.basic.tint (gen.greal_type idx.etype) with + | ({ eexpr = TCast _ } as idx) -> idx + | idx -> mk_cast gen.gcon.basic.tint idx + in + let e = { e with eexpr = TArray(run arr, idx) } in + (* get underlying class (if it's a class *) + (match arr_etype with + | TInst(cl, params) -> + (* see if it implements ArrayAccess *) + (match cl.cl_array_access with + | None -> e + | Some t -> + (* if it does, apply current parameters (and change them) *) + (* let real_t = apply_params_internal (List.map (gen.greal_type_param (TClassDecl cl))) cl params t in *) + let param = apply_params cl.cl_types (gen.greal_type_param (TClassDecl cl) params) t in + let real_t = apply_params cl.cl_types params param in + (* see if it needs a cast *) + + handle (e) (gen.greal_type e.etype) (gen.greal_type real_t) + ) + | _ -> Type.map_expr run e) + | TVars (veopt_l) -> + { e with eexpr = TVars (List.map (fun (v,eopt) -> + match eopt with + | None -> (v,eopt) + | Some e -> + (v, Some( handle (run e) v.v_type e.etype )) + ) veopt_l) } + (* FIXME deal with in_value when using other statements that may not have a TBlock wrapped on them *) + | TIf (econd, ethen, Some(eelse)) when was_in_value -> + { e with eexpr = TIf (handle (run econd) gen.gcon.basic.tbool econd.etype, handle (run ethen) e.etype ethen.etype, Some( handle (run eelse) e.etype eelse.etype ) ) } + | TIf (econd, ethen, eelse) -> + { e with eexpr = TIf (handle (run econd) gen.gcon.basic.tbool econd.etype, run (mk_block ethen), Option.map (fun e -> run (mk_block e)) eelse) } + | TWhile (econd, e1, flag) -> + { e with eexpr = TWhile (handle (run econd) gen.gcon.basic.tbool econd.etype, run (mk_block e1), flag) } + | TSwitch (cond, el_e_l, edef) -> + { e with eexpr = TSwitch(run cond, List.map (fun (el,e) -> (List.map run el, run (mk_block e))) el_e_l, Option.map (fun e -> run (mk_block e)) edef) } + | TMatch (cond, en, il_vl_e_l, edef) -> + { e with eexpr = TMatch(run cond, en, List.map (fun (il, vl, e) -> (il, vl, run (mk_block e))) il_vl_e_l, Option.map (fun e -> run (mk_block e)) edef) } + | TFor (v,cond,e1) -> + { e with eexpr = TFor(v, run cond, run (mk_block e1)) } + | TTry (e, ve_l) -> + { e with eexpr = TTry(run (mk_block e), List.map (fun (v,e) -> (v, run (mk_block e))) ve_l) } + | TBlock el -> + { e with eexpr = TBlock ( List.map (fun e -> in_value := false; run e) el ) } + | TCast (expr, md) when is_void (follow e.etype) -> + run expr + | TCast (expr, md) -> + let rec get_null e = + match e.eexpr with + | TConst TNull -> Some e + | TParenthesis e -> get_null e + | _ -> None + in + (match get_null expr with + | Some enull -> { enull with etype = e.etype } + | _ -> + let last_unsafe = gen.gon_unsafe_cast in + gen.gon_unsafe_cast <- (fun t t2 pos -> ()); + let ret = handle (run expr) e.etype expr.etype in + gen.gon_unsafe_cast <- last_unsafe; + match ret.eexpr with + | TCast _ -> ret + | _ -> { e with eexpr = TCast(ret,md); etype = gen.greal_type e.etype } + ) + (*| TCast _ -> + (* if there is already a cast, we should skip this cast check *) + Type.map_expr run e*) + | _ -> Type.map_expr run e + in + run + + let configure gen (mapping_func:texpr->texpr) = + gen.ghandle_cast <- (fun tto tfrom expr -> handle_cast gen expr (gen.greal_type tto) (gen.greal_type tfrom)); + let map e = Some(mapping_func e) in + gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map; + ReturnCast.configure gen + +end;; + +(* ******************************************* *) +(* Reflection-enabling Class fields *) +(* ******************************************* *) + +(* + This is the most hardcore codegen part of the code. There's much to improve so this code can be more readable, but at least it's running correctly right now! This will be improved. (TODO) + + This module will create class fields that enable reflection for targets that have a slow or inexistent reflection abilities. Because of the similarity + of strategies between what should have been different modules, they are all unified in this reflection-enabling class fields. + + They include: + * Get(isStatic, throwErrors, isCheck) / Set fields . Remember to allow implements Dynamic also. + * Invoke fields(isStatic) -> You need to configure how many invoke_field fields there will be. + invokeDynamic + * Has field -> parameter in get field that returns __undefined__ if it doesn't exist. + + * GetType -> return the current Class<> / Enum<> + * Fields(isStatic) -> returns all the fields / static fields. Remember to allow implements Dynamic also + + * Create(arguments array), CreateEmpty - calls new() or create empty + * getInstanceFields / getClassFields -> show even function fields, everything! + + * deleteField -> only for implements Dynamic + + for enums: + * createEnum -> invokeField for classes + * createEnumIndex -> use invokeField as well, and use numbers e.g. "0", "1", "2" .... For this, use "@:alias" metadata + * getEnumConstructs -> fields() + + need to be solved outside: + * getEnumName + * enumIndex + * + + need to be solved by haxe code: + * enumParameters -> for (field in Reflect.fields(enum)) arr.push(Reflect.field(enum, field)) + + Standard: + if a class contains a @:$enum metadata, it's treated as a converted enum to class + + + Optimizations: + * if optimize is true, all fields will be hashed by the same hashing function as neko (31 bits int : always positive). Every function that expects a string for the field will expect also an int, for the hash + a string (which is nullable for compile-time hashes) + an int. + At compile-time, a collision will throw an error (like neko). + At runtime, a collision will make a negative int. Negative ints will always resolve to a special Hash<> field which takes a string. + * if optimize is true, Reflect.field/setField will be replaced by either the runtime version (with already hashed string), either by the own .Field()/.SetField() HxObject's version, + if the type is detected to already be hxgen + * TODO: if for() optimization for arrays is disabled, we can replace for(field in Reflect.fields(obj)) to: + for (field in ( (Std.is(obj, HxObject) ? ((HxObject)obj).Fields() : Reflect.fields(obj)) )) // no array copying . for further optimization this could be guaranteed to return + the already hashed fields. + + Mappings: + * if create Dynamic class is true, TObjectDecl will be mapped to new DynamicClass(fields, [hashedFields], values) + * + + dependencies: + There is no big dependency from this target. Though it should be a syntax filter, mainly one of the first so most expression generation has already been done, + while the AST has its meaning close to haxe's. + Should run before InitFunction so it detects variables containing expressions as "always-execute" expressions, even when using CreateEmpty + + * Must run before switch() syntax changes + +*) + +open ClosuresToClass;; +module ReflectionCFs = +struct + + let name = "reflection_cfs" + + type rcf_ctx = + { + rcf_gen : generator_ctx; + rcf_ft : ClosuresToClass.closures_ctx; + rcf_optimize : bool; + mutable rcf_float_special_case : bool; + + mutable rcf_object_iface : tclass; + + mutable rcf_create_getsetinvoke_fields : bool; + (* should we create the get type (get Class)? *) + mutable rcf_create_get_type : bool; + (* should we handle implements dynamic? *) + mutable rcf_handle_impl_dynamic : bool; + (* + create_dyn_overloading_ctor : + when creating the implements dynamic code, we can also create a special constructor for + the actual DynamicObject class, which will receive all its fields from the code outside. + Note that this will only work on targets that support overloading contrstuctors, as any class that extends + our DynamicObject will have an empty super() call + *) + mutable rcf_create_dyn_ctor : bool; + + mutable rcf_max_func_arity : int; + + (* + the hash lookup function. can be an inlined expr or simply a function call. + its only needed features is that it should return the index of the key if found, and the + complement of the index of where it should be inserted if not found (Ints). + + hash->hash_array->returning expression + *) + mutable rcf_hash_function : texpr->texpr->texpr; + + mutable rcf_lookup_function : texpr->texpr; + + (* + class_cl is the real class for Class<> instances. + In the current implementation, due to some targets' limitations, (in particular, Java), + we have to use an empty object so we can access its virtual mehtods. + FIXME find a better way to create Class<> objects in a performant way + *) + mutable rcf_class_cl : tclass option; + (* + Also about the Class<> type, should we crate all classes eagerly? + If false, it means that we should have a way at runtime to create the class when needed by + Type.resolveClass/Enum + *) + mutable rcf_class_eager_creation : bool; + + rcf_hash_fields : (int, string) Hashtbl.t; + + (* + main expr -> field expr -> field string -> possible hash int (if optimize) -> possible set expr -> should_throw_exceptions -> changed expression + + Changes a get / set field to the runtime resolution function + *) + mutable rcf_on_getset_field : texpr->texpr->string->int32 option->texpr option->bool->texpr; + + mutable rcf_on_call_field : texpr->texpr->string->int32 option->texpr list->texpr; + + mutable rcf_handle_statics : bool; + } + + let new_ctx gen ft object_iface optimize dynamic_getset_field dynamic_call_field hash_function lookup_function handle_statics = + { + rcf_gen = gen; + rcf_ft = ft; + + rcf_optimize = optimize; + + rcf_float_special_case = true; + + rcf_object_iface = object_iface; + + rcf_create_getsetinvoke_fields = true; + rcf_create_get_type = true; + + rcf_handle_impl_dynamic = true; + rcf_create_dyn_ctor = true; + + rcf_max_func_arity = 10; + + rcf_hash_function = hash_function; + rcf_lookup_function = lookup_function; + + rcf_class_cl = None; + rcf_class_eager_creation = false; + + rcf_hash_fields = Hashtbl.create 100; + + rcf_on_getset_field = dynamic_getset_field; + rcf_on_call_field = dynamic_call_field; + + rcf_handle_statics = handle_statics; + } + + (* + methods as a bool option is a little laziness of my part. + None means that methods are included with normal fields; + Some(true) means collect only methods + Some(false) means collect only fields (and MethDynamic fields) + *) + let collect_fields cl (methods : bool option) (statics : bool option) = + let collected = Hashtbl.create 0 in + let collect cf acc = + if Meta.has Meta.CompilerGenerated cf.cf_meta || Meta.has Meta.SkipReflection cf.cf_meta then + acc + else match methods, cf.cf_kind with + | None, _ when not (Hashtbl.mem collected cf.cf_name) -> Hashtbl.add collected cf.cf_name true; ([cf.cf_name], cf) :: acc + | Some true, Method MethDynamic -> acc + | Some true, Method _ when not (Hashtbl.mem collected cf.cf_name) -> Hashtbl.add collected cf.cf_name true; ([cf.cf_name], cf) :: acc + | Some false, Method MethDynamic + | Some false, Var _ when not (Hashtbl.mem collected cf.cf_name) -> Hashtbl.add collected cf.cf_name true; ([cf.cf_name], cf) :: acc + | _ -> acc + in + let collect_cfs cfs acc = + let rec loop cfs acc = + match cfs with + | [] -> acc + | hd :: tl -> loop tl (collect hd acc) + in + loop cfs acc + in + let rec loop cl acc = + let acc = match statics with + | None -> collect_cfs cl.cl_ordered_fields (collect_cfs cl.cl_ordered_statics acc) + | Some true -> collect_cfs cl.cl_ordered_statics acc + | Some false -> collect_cfs cl.cl_ordered_fields acc + in + match cl.cl_super with + | None -> acc + | Some(cl,_) -> + if not (is_hxgen (TClassDecl cl)) then loop cl acc else acc + in + + loop cl [] + + 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 hash_field ctx f pos = + let h = hash f in + (try + let f2 = Hashtbl.find ctx.rcf_hash_fields h in + if f <> f2 then ctx.rcf_gen.gcon.error ("Field conflict between " ^ f ^ " and " ^ f2) pos + with Not_found -> + Hashtbl.add ctx.rcf_hash_fields h f); + h + + (* ( tf_args, switch_var ) *) + let field_type_args ctx pos = + match ctx.rcf_optimize with + | true -> + let field_name, field_hash = alloc_var "field" ctx.rcf_gen.gcon.basic.tstring, alloc_var "hash" ctx.rcf_gen.gcon.basic.tint in + + [field_name, None; field_hash, None], field_hash + | false -> + let field_name = alloc_var "field" ctx.rcf_gen.gcon.basic.tstring in + [field_name, None], field_name + + let hash_field_i32 ctx pos field_name = + let i = hash_field ctx field_name pos in + let i = Int32.of_int (i) in + if i < Int32.zero then + Int32.logor (Int32.logand i (Int32.of_int 0x3FFFFFFF)) (Int32.shift_left Int32.one 30) + else i + + let switch_case ctx pos field_name = + match ctx.rcf_optimize with + | true -> + let i = hash_field_i32 ctx pos field_name in + { eexpr = TConst(TInt(i)); etype = ctx.rcf_gen.gcon.basic.tint; epos = pos } + | false -> + { eexpr = TConst(TString(field_name)); etype = ctx.rcf_gen.gcon.basic.tstring; epos = pos } + + (* + Will implement getField / setField which will follow the following rule: + function getField(field, isStatic, throwErrors, isCheck, handleProperty, isFirst):Dynamic + { + if (isStatic) + { + switch(field) + { + case "aStaticField": return ThisClass.aStaticField; + case "aDynamicField": return ThisClass.aDynamicField; + default: + if (isFirst) return getField_d(field, isStatic, throwErrors, handleProperty, false); + if(throwErrors) throw "Field not found"; else if (isCheck) return __undefined__ else return null; + } + } else { + switch(field) + { + case "aNormalField": return this.aNormalField; + case "aBoolField": return this.aBoolField; + case "aDoubleField": return this.aDoubleField; + default: return getField_d(field, isStatic, throwErrors, isCheck); + } + } + } + + function getField_d(field, isStatic, throwErrors, handleProperty, isFirst):Float + { + if (isStatic) + { + switch(field) + { + case "aDynamicField": return cast ThisClass.aDynamicField; + default: if (throwErrors) throw "Field not found"; else return null; + } + } + etc... + } + + function setField(field, value, isStatic):Dynamic {} + function setField_d(field, value:Float, isStatic):Float {} + *) + + let call_super ctx fn_args ret_t cf cl this_t pos = + { + eexpr = TCall({ + eexpr = TField({ eexpr = TConst(TSuper); etype = this_t; epos = pos }, FInstance(cl,cf)); + etype = TFun(fun_args fn_args, ret_t); + epos = pos; + }, List.map (fun (v,_) -> mk_local v pos) fn_args); + etype = ret_t; + epos = pos; + } + + let mk_string ctx str pos = + { eexpr = TConst(TString(str)); etype = ctx.rcf_gen.gcon.basic.tstring; epos = pos } + + let mk_int ctx i pos = + { eexpr = TConst(TInt(Int32.of_int i)); etype = ctx.rcf_gen.gcon.basic.tint; epos = pos } + + let mk_bool ctx b pos = + { eexpr = TConst(TBool(b)); etype = ctx.rcf_gen.gcon.basic.tbool; epos = pos } + + let mk_throw ctx str pos = { eexpr = TThrow (mk_string ctx str pos); etype = ctx.rcf_gen.gcon.basic.tvoid; epos = pos } + + let enumerate_dynamic_fields ctx cl when_found = + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let pos = cl.cl_pos in + + let mk_for arr = + let t = if ctx.rcf_optimize then basic.tint else basic.tstring in + let convert_str e = if ctx.rcf_optimize then ctx.rcf_lookup_function e else e in + let var = mk_temp gen "field" t in + { + eexpr = TFor(var, mk_iterator_access gen t arr, mk_block (when_found (convert_str (mk_local var pos)))); + etype = basic.tvoid; + epos = pos; + } + in + + let this_t = TInst(cl, List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + if ctx.rcf_optimize then + [ + mk_for (mk_this (gen.gmk_internal_name "hx" "hashes") (basic.tarray basic.tint)); + mk_for (mk_this (gen.gmk_internal_name "hx" "hashes_f") (basic.tarray basic.tint)); + ] else [ + mk_for (mk_this (gen.gmk_internal_name "hx" "hashes") (basic.tarray basic.tstring)); + mk_for (mk_this (gen.gmk_internal_name "hx" "hashes_f") (basic.tarray basic.tstring)); + ] + + (* ********************* + Dynamic lookup + ********************* + + This is the behavior of standard classes. It will replace the error throwing + if a field doesn't exists when looking it up. + + In order for it to work, an implementation for hash_function must be created. + hash_function is the function to be called/inlined that will allow us to lookup the hash into a sorted array of hashes. + A binary search or linear search algorithm may be implemented. The only need is that if not found, the NegBits of + the place where it should be inserted must be returned. + *) + let abstract_dyn_lookup_implementation ctx this hash_local may_value is_float pos = + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + let a_t = if ctx.rcf_optimize then basic.tint else basic.tstring in + let hx_hashes = mk_this (gen.gmk_internal_name "hx" "hashes") (basic.tarray a_t) in + let hx_hashes_f = mk_this (gen.gmk_internal_name "hx" "hashes_f") (basic.tarray a_t) in + let hx_dynamics = mk_this (gen.gmk_internal_name "hx" "dynamics") (basic.tarray t_empty) in + let hx_dynamics_f = mk_this (gen.gmk_internal_name "hx" "dynamics_f") (basic.tarray basic.tfloat) in + let res = alloc_var "res" basic.tint in + let fst_hash, snd_hash, fst_dynamics, snd_dynamics = + if is_float then hx_hashes_f, hx_hashes, hx_dynamics_f, hx_dynamics else hx_hashes, hx_hashes_f, hx_dynamics, hx_dynamics_f + in + let res_local = mk_local res pos in + let gte = { + eexpr = TBinop(Ast.OpGte, res_local, { eexpr = TConst(TInt(Int32.zero)); etype = basic.tint; epos = pos }); + etype = basic.tbool; + epos = pos; + } in + let get_array_t t = match follow t with | TInst({ cl_path = ([],"Array") },[arrtype]) -> arrtype | _ -> assert false in + let mk_tarray arr idx = + let t = get_array_t arr.etype in + { + eexpr = TArray(arr, idx); + etype = t; + epos = pos; + } + in + let ret_t = if is_float then basic.tfloat else t_dynamic in + + match may_value with + | None -> + (* + var res = lookup(this.__hx_hashes/f, hash); + if (res < 0) + { + res = lookup(this.__hx_hashes_f/_, hash); + if(res < 0) + return null; + else + return __hx_dynamics_f[res]; + } else { + return __hx_dynamics[res]; + } + *) + let block = + [ + { eexpr = TVars([res, Some(ctx.rcf_hash_function hash_local fst_hash)]); etype = basic.tvoid; epos = pos }; + { eexpr = TIf(gte, mk_return (mk_tarray fst_dynamics res_local), Some({ + eexpr = TBlock( + [ + { eexpr = TBinop(Ast.OpAssign, res_local, ctx.rcf_hash_function hash_local snd_hash); etype = basic.tint; epos = pos }; + { eexpr = TIf(gte, mk_return (mk_tarray snd_dynamics res_local), None); etype = ret_t; epos = pos } + ]); + etype = ret_t; + epos = pos; + })); etype = ret_t; epos = pos } + ] in + block + | Some value_local -> + (* + //if is not float: + //if (isNumber(value_local)) return this.__hx_setField_f(field, getNumber(value_local), false(not static)); + var res = lookup(this.__hx_hashes/f, hash); + if (res >= 0) + { + return __hx_dynamics/f[res] = value_local; + } else { + res = lookup(this.__hx_hashes_f/_, hash); + if (res >= 0) + { + __hx_dynamics_f/_.splice(res,1); + __hx_hashes_f/_.splice(res,1); + } + } + + __hx_hashses/_f.insert(~res, hash); + __hx_dynamics/_f.insert(~res, value_local); + return value_local; + *) + let mk_splice arr at_pos = { + eexpr = TCall( + mk_field_access gen arr "splice" pos, + [at_pos; { eexpr = TConst(TInt Int32.one); etype = basic.tint; epos = pos }] + ); + etype = arr.etype; + epos = pos + } in + + let mk_insert arr at_pos value = { + eexpr = TCall( + mk_field_access gen arr "insert" pos, + [at_pos; value]); + etype = basic.tvoid; + epos = pos + } in + + let neg_res = { eexpr = TUnop(Ast.NegBits, Ast.Prefix, res_local); etype = basic.tint; epos = pos } in + + let res2 = alloc_var "res2" basic.tint in + let res2_local = mk_local res2 pos in + + let block = + [ + { eexpr = TVars([res, Some(ctx.rcf_hash_function hash_local fst_hash)]); etype = basic.tvoid; epos = pos }; + { + eexpr = TIf(gte, + mk_return { eexpr = TBinop(Ast.OpAssign, mk_tarray fst_dynamics res_local, value_local); etype = value_local.etype; epos = pos }, + Some({ eexpr = TBlock([ + { eexpr = TVars([ res2, Some(ctx.rcf_hash_function hash_local snd_hash)]); etype = basic.tvoid; epos = pos }; + { + eexpr = TIf(gte, { eexpr = TBlock([ + mk_splice snd_hash res2_local; + mk_splice snd_dynamics res2_local + ]); etype = t_dynamic; epos = pos }, None); + etype = t_dynamic; + epos = pos; + } + ]); etype = t_dynamic; epos = pos })); + etype = t_dynamic; + epos = pos; + }; + mk_insert fst_hash neg_res hash_local; + mk_insert fst_dynamics neg_res value_local; + mk_return value_local + ] in + block + + let get_delete_field ctx cl is_dynamic = + let pos = cl.cl_pos in + let this_t = TInst(cl, List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let tf_args, switch_var = field_type_args ctx pos in + let local_switch_var = mk_local switch_var pos in + let fun_type = TFun(fun_args tf_args,basic.tbool) in + let cf = mk_class_field (gen.gmk_internal_name "hx" "deleteField") fun_type false pos (Method MethNormal) [] in + let body = if is_dynamic then begin + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + let a_t = if ctx.rcf_optimize then basic.tint else basic.tstring in + let hx_hashes = mk_this (gen.gmk_internal_name "hx" "hashes") (basic.tarray a_t) in + let hx_hashes_f = mk_this (gen.gmk_internal_name "hx" "hashes_f") (basic.tarray a_t) in + let hx_dynamics = mk_this (gen.gmk_internal_name "hx" "dynamics") (basic.tarray t_empty) in + let hx_dynamics_f = mk_this (gen.gmk_internal_name "hx" "dynamics_f") (basic.tarray basic.tfloat) in + let res = alloc_var "res" basic.tint in + let res_local = mk_local res pos in + let gte = { + eexpr = TBinop(Ast.OpGte, res_local, { eexpr = TConst(TInt(Int32.zero)); etype = basic.tint; epos = pos }); + etype = basic.tbool; + epos = pos; + } in + let mk_splice arr at_pos = { + eexpr = TCall( + mk_field_access gen arr "splice" pos, + [at_pos; { eexpr = TConst(TInt Int32.one); etype = basic.tint; epos = pos }] + ); + etype = arr.etype; + epos = pos + } in + (* + var res = lookup(this.__hx_hashes, hash); + if (res >= 0) + { + __hx_dynamics.splice(res,1); + __hx_hashes.splice(res,1); + + return true; + } else { + res = lookup(this.__hx_hashes_f, hash); + if (res >= 0) + { + __hx_dynamics_f.splice(res,1); + __hx_hashes_f.splice(res,1); + + return true; + } + } + + return false; + *) + [ + { eexpr = TVars([res,Some(ctx.rcf_hash_function local_switch_var hx_hashes)]); etype = basic.tvoid; epos = pos }; + { + eexpr = TIf(gte, { eexpr = TBlock([ + mk_splice hx_hashes res_local; + mk_splice hx_dynamics res_local; + mk_return { eexpr = TConst(TBool true); etype = basic.tbool; epos = pos } + ]); etype = t_dynamic; epos = pos }, Some({ eexpr = TBlock([ + { eexpr = TBinop(Ast.OpAssign, res_local, ctx.rcf_hash_function local_switch_var hx_hashes_f); etype = basic.tint; epos = pos }; + { eexpr = TIf(gte, { eexpr = TBlock([ + mk_splice hx_hashes_f res_local; + mk_splice hx_dynamics_f res_local; + mk_return { eexpr = TConst(TBool true); etype = basic.tbool; epos = pos } + ]); etype = t_dynamic; epos = pos }, None); etype = t_dynamic; epos = pos } + ]); etype = t_dynamic; epos = pos })); + etype = t_dynamic; + epos = pos; + }; + mk_return { eexpr = TConst(TBool false); etype = basic.tbool; epos = pos } + ] + end else + [ + mk_return { eexpr = TConst(TBool false); etype = basic.tbool; epos = pos } + ] in + + (* create function *) + let fn = + { + tf_args = tf_args; + tf_type = basic.tbool; + tf_expr = { eexpr = TBlock(body); etype = t_dynamic; epos = pos } + } in + cf.cf_expr <- Some({ eexpr = TFunction(fn); etype = fun_type; epos = pos }); + cf + + let rec is_first_dynamic cl = + match cl.cl_super with + | Some(cl,_) -> + if is_some cl.cl_dynamic then false else is_first_dynamic cl + | None -> true + + let is_override cl = match cl.cl_super with + | Some (cl, _) when is_hxgen (TClassDecl cl) -> true + | _ -> false + + let get_args t = match follow t with + | TFun(args,ret) -> args,ret + | _ -> assert false + + (* WARNING: this will only work if overloading contructors is possible on target language *) + let implement_dynamic_object_ctor ctx cl = + let rec is_side_effects_free e = + match e.eexpr with + | TConst _ + | TLocal _ + | TFunction _ + | TTypeExpr _ -> + true + | TNew(clnew,[],params) when clnew == cl -> + List.for_all is_side_effects_free params + | TUnop(Increment,_,_) + | TUnop(Decrement,_,_) + | TBinop(OpAssign,_,_) + | TBinop(OpAssignOp _,_,_) -> + false + | TUnop(_,_,e) -> + is_side_effects_free e + | TArray(e1,e2) + | TBinop(_,e1,e2) -> + is_side_effects_free e1 && is_side_effects_free e2 + | TIf(cond,e1,Some e2) -> + is_side_effects_free cond && is_side_effects_free e1 && is_side_effects_free e2 + | TField(e,_) + | TParenthesis e -> is_side_effects_free e + | TArrayDecl el -> List.for_all is_side_effects_free el + | TCast(e,_) -> is_side_effects_free e + | _ -> false + in + + let pos = cl.cl_pos in + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let hasht = if ctx.rcf_optimize then basic.tint else basic.tstring in + + let fields = + [ + gen.gmk_internal_name "hx" "hashes", basic.tarray hasht; + gen.gmk_internal_name "hx" "dynamics", basic.tarray t_empty; + gen.gmk_internal_name "hx" "hashes_f", basic.tarray hasht; + gen.gmk_internal_name "hx" "dynamics_f", basic.tarray basic.tfloat; + ] in + let tf_args = List.map (fun (name, t) -> + alloc_var name t, None + ) fields in + + let this = { eexpr = TConst TThis; etype = TInst(cl, List.map snd cl.cl_types); epos = pos } in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + let fun_t = TFun(fun_args tf_args,basic.tvoid) in + let ctor = mk_class_field "new" fun_t true pos (Method MethNormal) [] in + ctor.cf_expr <- Some( + { + eexpr = TFunction({ + tf_args = tf_args; + tf_type = basic.tvoid; + tf_expr = + { + eexpr = TBlock(List.map (fun (v,_) -> + { eexpr = TBinop(Ast.OpAssign, mk_this v.v_name v.v_type, mk_local v pos); etype = v.v_type; epos = pos } + ) tf_args); + etype = basic.tvoid; + epos = pos + } + }); + etype = fun_t; + epos = pos + }); + + add_constructor cl ctor; + (* default ctor also *) + let ctor = mk_class_field "new" (TFun([],basic.tvoid)) false pos (Method MethNormal) [] in + ctor.cf_expr <- Some { + eexpr = TFunction { + tf_type = basic.tvoid; + tf_args = []; + tf_expr = { + eexpr = TBlock(List.map (fun (f,t) -> + { eexpr = TBinop(Ast.OpAssign, mk_this f t,{ eexpr = TArrayDecl([]); etype = t; epos = pos; }); etype = t; epos = pos } + ) fields); + etype = basic.tvoid; + epos = pos; + } + }; + etype = ctor.cf_type; + epos = pos; + }; + add_constructor cl ctor; + (* and finally we will return a function that transforms a TObjectDecl into a new DynamicObject() call *) + let rec loop objdecl acc acc_f = + match objdecl with + | [] -> acc,acc_f + | (name,expr) :: tl -> + let real_t = gen.greal_type expr.etype in + match follow expr.etype with + | TInst ( { cl_path = ["haxe"], "Int64" }, [] ) -> + loop tl ((name, gen.ghandle_cast t_dynamic real_t expr) :: acc) acc_f + | _ -> + if like_float real_t then + loop tl acc ((name, gen.ghandle_cast basic.tfloat real_t expr) :: acc_f) + else + loop tl ((name, gen.ghandle_cast t_dynamic real_t expr) :: acc) acc_f + in + + let may_hash_field s = + if ctx.rcf_optimize then begin + (* let hash_field ctx f pos = *) + { eexpr = TConst(TInt (hash_field_i32 ctx pos s)); etype = basic.tint; epos = pos } + end else begin + { eexpr = TConst(TString s); etype = basic.tstring; epos = pos } + end + in + + let do_objdecl e objdecl = + let exprs_before = ref [] in + let rec change_exprs decl acc = match decl with + | (name,expr) :: tl -> + if is_side_effects_free expr then + change_exprs tl ((name,expr) :: acc) + else begin + let var = mk_temp gen "odecl" expr.etype in + exprs_before := { eexpr = TVars([var,Some expr]); etype = basic.tvoid; epos = expr.epos } :: !exprs_before; + change_exprs tl ((name,mk_local var expr.epos) :: acc) + end + | [] -> acc + in + let objdecl = change_exprs objdecl [] in + + let odecl, odecl_f = loop objdecl [] [] in + let changed_expr = List.map (fun (s,e) -> (may_hash_field s,e)) in + let odecl, odecl_f = changed_expr odecl, changed_expr odecl_f in + let sort_fn (e1,_) (e2,_) = + match e1.eexpr, e2.eexpr with + | TConst(TInt i1), TConst(TInt i2) -> compare i1 i2 + | TConst(TString s1), TConst(TString s2) -> compare s1 s2 + | _ -> assert false + in + + let odecl, odecl_f = List.sort sort_fn odecl, List.sort sort_fn odecl_f in + + let mk_arrdecl el t = { eexpr = TArrayDecl(el); etype = t; epos = pos } in + let ret = { + e with eexpr = TNew(cl,[], + [ + mk_arrdecl (List.map fst odecl) (basic.tarray hasht); + mk_arrdecl (List.map snd odecl) (basic.tarray t_empty); + mk_arrdecl (List.map fst odecl_f) (basic.tarray hasht); + mk_arrdecl (List.map snd odecl_f) (basic.tarray basic.tfloat) + ]); + } in + match !exprs_before with + | [] -> ret + | block -> + { + eexpr = TBlock(List.rev block @ [ret]); + etype = ret.etype; + epos = ret.epos; + } + in + do_objdecl + + let implement_dynamics ctx cl = + let pos = cl.cl_pos in + let is_override = is_override cl in + if is_some cl.cl_dynamic then begin + if is_first_dynamic cl then begin + (* + * add hx_hashes, hx_hashes_f, hx_dynamics, hx_dynamics_f to class + * implement hx_deleteField + *) + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let hasht = if ctx.rcf_optimize then basic.tint else basic.tstring in + + let new_fields = + [ + mk_class_field (gen.gmk_internal_name "hx" "hashes") (basic.tarray hasht) false pos (Var { v_read = AccNormal; v_write = AccNormal }) []; + mk_class_field (gen.gmk_internal_name "hx" "dynamics") (basic.tarray t_empty) false pos (Var { v_read = AccNormal; v_write = AccNormal }) []; + mk_class_field (gen.gmk_internal_name "hx" "hashes_f") (basic.tarray hasht) false pos (Var { v_read = AccNormal; v_write = AccNormal }) []; + mk_class_field (gen.gmk_internal_name "hx" "dynamics_f") (basic.tarray basic.tfloat) false pos (Var { v_read = AccNormal; v_write = AccNormal }) []; + ] in + + (if cl.cl_path <> (["haxe"; "lang"], "DynamicObject") then + List.iter (fun cf -> cf.cf_expr <- Some { eexpr = TArrayDecl([]); etype = cf.cf_type; epos = cf.cf_pos }) new_fields + ); + + let delete = get_delete_field ctx cl true in + List.iter (fun cf -> + cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields + ) (delete :: new_fields); + + (* + let rec last_ctor cl = + match cl.cl_constructor with + | None -> (match cl.cl_super with | None -> None | Some (cl,_) -> last_ctor cl) + | Some c -> Some c + in + *) + (* + in order for the next to work, we need to execute our script before InitFunction, so the expressions inside the variables are initialized by the constructor + *) + (* + Now we need to add their initialization. + This will consist of different parts: + Check if there are constructors. If not, create one and add initialization to it (calling super, ok) + If there are, add as first statement (or second if there is a super() call in the first) + If class has @:$DynamicObject meta, also create another new() class with its parameters as constructor arguments + *) + + List.iter (fun cf -> + cf.cf_expr <- Some({ eexpr = TArrayDecl([]); etype = cf.cf_type; epos = cf.cf_pos }) + ) new_fields; + + cl.cl_ordered_fields <- cl.cl_ordered_fields @ (delete :: new_fields); + if is_override then cl.cl_overrides <- delete :: cl.cl_overrides + end + end else if not is_override then begin + let delete = get_delete_field ctx cl false in + cl.cl_ordered_fields <- cl.cl_ordered_fields @ [delete]; + cl.cl_fields <- PMap.add delete.cf_name delete cl.cl_fields + end + + let implement_create_empty ctx cl = + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let pos = cl.cl_pos in + let is_override = is_override cl in + let tparams = List.map (fun _ -> t_empty) cl.cl_types in + + let create = + let arr = alloc_var "arr" (basic.tarray t_dynamic) in + let tf_args = [ arr, None ] in + let t = TFun(fun_args tf_args, t_dynamic) in + let cf = mk_class_field (gen.gmk_internal_name "hx" "create") t false pos (Method MethNormal) [] in + let i = ref 0 in + + let arr_local = mk_local arr pos in + let ctor = if is_some cl.cl_constructor then cl.cl_constructor else get_last_ctor cl in + let params = match ctor with + | None -> [] + | Some ctor -> + List.map (fun (n,_,t) -> + let old = !i in + incr i; + { + eexpr = TArray(arr_local, { eexpr = TConst(TInt (Int32.of_int old)); etype = basic.tint; epos = pos } ); + etype = t_dynamic; + epos = pos + } + ) ( fst ( get_fun ctor.cf_type ) ) + in + let expr = mk_return { + eexpr = TNew(cl, tparams, params); + etype = TInst(cl, tparams); + epos = pos + } in + let fn = { + eexpr = TFunction({ + tf_args = tf_args; + tf_type = t_dynamic; + tf_expr = mk_block expr + }); + etype = t; + epos = pos + } in + cf.cf_expr <- Some fn; + cf + in + + let create_empty = + let t = TFun([],t_dynamic) in + let cf = mk_class_field (gen.gmk_internal_name "hx" "createEmpty") t false pos (Method MethNormal) [] in + let fn = { + eexpr = TFunction({ + tf_args = []; + tf_type = t_dynamic; + tf_expr = mk_block (mk_return ( gen.gtools.rf_create_empty cl tparams pos )) + }); + etype = t; + epos = pos + } in + cf.cf_expr <- Some fn; + cf + in + + (* if rcf_handle_statics is false, there is no reason to make createEmpty/create not be static *) + if ctx.rcf_handle_statics then begin + cl.cl_ordered_fields <- cl.cl_ordered_fields @ [create_empty; create]; + cl.cl_fields <- PMap.add create_empty.cf_name create_empty cl.cl_fields; + cl.cl_fields <- PMap.add create.cf_name create cl.cl_fields; + if is_override then begin + cl.cl_overrides <- create_empty :: create :: cl.cl_overrides + end + end else begin + cl.cl_ordered_statics <- cl.cl_ordered_statics @ [create_empty; create]; + cl.cl_statics <- PMap.add create_empty.cf_name create_empty cl.cl_statics; + cl.cl_statics <- PMap.add create.cf_name create cl.cl_statics + end + + + (* + Implements: + __hx_lookupField(field:String, throwErrors:Bool, isCheck:Bool, handleProperties:Bool, isFirst:Bool):Dynamic + + __hx_lookupField_f(field:String, throwErrors:Bool, handleProperties:Bool, isFirst:Bool):Float + + __hx_lookupSetField(field:String, value:Dynamic, handleProperties:Bool, isFirst:Bool):Dynamic; + + __hx_lookupSetField(field:String, value:Float, handleProperties:Bool, isFirst:Bool):Float; + *) + let implement_final_lookup ctx cl = + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let pos = cl.cl_pos in + let is_override = is_override cl in + + let this = { eexpr = TConst(TThis); etype = TInst(cl, List.map snd cl.cl_types); epos = pos } in + + (* + this function will create the class fields and call callback for each version + + callback : is_float fields_args switch_var throw_errors_option is_check_option value_option : texpr list + *) + let create_cfs is_dynamic callback = + let create_cf is_float is_set = + let name = gen.gmk_internal_name "hx" ( (if is_set then "lookupSetField" else "lookupField") ^ (if is_float then "_f" else "") ) in + let field_args, switch_var = field_type_args ctx pos in + let ret_t = if is_float then basic.tfloat else t_dynamic in + let tf_args, throw_errors_opt = + if is_set then + field_args, None + else + let v = alloc_var "throwErrors" basic.tbool in + field_args @ [v,None], Some v + in + let tf_args, is_check_opt = + if is_set || is_float then + tf_args, None + else + let v = alloc_var "isCheck" basic.tbool in + tf_args @ [v,None], Some v + in + let tf_args, value_opt = + if not is_set then + tf_args, None + else + let v = alloc_var "value" ret_t in + field_args @ [v,None], Some v + in + + let fun_t = TFun(fun_args tf_args, ret_t) in + let cf = mk_class_field name fun_t false pos (Method MethNormal) [] in + let block = callback is_float field_args switch_var throw_errors_opt is_check_opt value_opt in + let block = if not is_set then let tl = begin + let throw_errors_local = mk_local (get throw_errors_opt) pos in + let mk_check_throw msg = + { + eexpr = TIf(throw_errors_local, mk_throw ctx msg pos, Some (mk_return (null ret_t pos))); + etype = ret_t; + epos = pos + } in + + let mk_may_check_throw msg = if is_dynamic then mk_return (null ret_t pos) else mk_check_throw msg in + if is_float then begin + [ + mk_may_check_throw "Field not found or incompatible field type."; + ] + end else begin + let undefined = alloc_var "__undefined__" t_dynamic in + let undefined_local = mk_local undefined pos in + let is_check_local = mk_local (get is_check_opt) pos in + [ + { + eexpr = TIf(is_check_local, mk_return undefined_local, Some( mk_may_check_throw "Field not found." )); + etype = ret_t; + epos = pos; + } + ] + end + end in block @ tl else block in + cf.cf_expr <- Some( + { + eexpr = TFunction({ + tf_args = tf_args; + tf_type = ret_t; + tf_expr = { eexpr = TBlock(block); etype = ret_t; epos = pos } + }); + etype = fun_t; + epos = pos + } + ); + cf + in + let cfs = + [ + create_cf false false; + create_cf true false; + create_cf false true; + create_cf true true + ] in + cl.cl_ordered_fields <- cl.cl_ordered_fields @ cfs; + List.iter (fun cf -> + cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields; + if is_override then cl.cl_overrides <- cf :: cl.cl_overrides + ) cfs + in + + if is_some cl.cl_dynamic then begin + (* let abstract_dyn_lookup_implementation ctx this hash_local may_value is_float pos = *) + (* callback : is_float fields_args switch_var throw_errors_option is_check_option value_option : texpr list *) + if is_first_dynamic cl then + create_cfs true (fun is_float fields_args switch_var _ _ value_opt -> + abstract_dyn_lookup_implementation ctx this (mk_local switch_var pos) (Option.map (fun v -> mk_local v pos) value_opt) is_float pos + ) + end else if not is_override then begin + create_cfs false (fun is_float fields_args switch_var _ _ value_opt -> + match value_opt with + | None -> (* is not set *) + [] + | Some _ -> (* is set *) + if is_float then + [ mk_throw ctx "Cannot access field for writing or incompatible type." pos ] + else + [ mk_throw ctx "Cannot access field for writing." pos ] + ) + end + + (* *) + let implement_get_set ctx cl = + let gen = ctx.rcf_gen in + let mk_cfield is_set is_float = + let pos = cl.cl_pos in + let basic = ctx.rcf_gen.gcon.basic in + let tf_args, switch_var = field_type_args ctx pos in + let field_args = tf_args in + let local_switch_var = { eexpr = TLocal(switch_var); etype = switch_var.v_type; epos = pos } in + let is_static = alloc_var "isStatic" basic.tbool in + let is_static_local = { eexpr = TLocal(is_static); etype = basic.tbool; epos = pos } in + + let handle_prop = alloc_var "handleProperties" basic.tbool in + let handle_prop_local = mk_local handle_prop pos in + + let this = { eexpr = TConst TThis; etype = TInst(cl, List.map snd cl.cl_types); epos = pos } in + let mk_this_call_raw name fun_t params = + { eexpr = TCall( { (mk_field_access gen this name pos) with etype = fun_t; }, params ); etype = snd (get_args fun_t); epos = pos } + in + + let tf_args = if ctx.rcf_handle_statics then tf_args @ [is_static, None] else tf_args in + + let fun_type = ref (TFun([], basic.tvoid)) in + let fun_name = ctx.rcf_gen.gmk_internal_name "hx" ( (if is_set then "setField" else "getField") ^ (if is_float then "_f" else "") ) in + let cfield = mk_class_field fun_name !fun_type false pos (Method MethNormal) [] in + + let maybe_cast e = e in + + let t = TInst(cl, List.map snd cl.cl_types) in + + (* if it's not latest hxgen class -> check super *) + let mk_do_default args do_default = + match cl.cl_super with + | None -> fun () -> maybe_cast (do_default ()) + | Some (super, sparams) when not (is_hxgen (TClassDecl super)) -> + fun () -> maybe_cast (do_default ()) + | _ -> + fun () -> + mk_return { + eexpr = TCall( + { eexpr = TField({ eexpr = TConst TSuper; etype = t; epos = pos }, FInstance(cl, cfield)); etype = !fun_type; epos = pos }, + (List.map (fun (v,_) -> mk_local v pos) args) ); + etype = if is_float then basic.tfloat else t_dynamic; + epos = pos; + }; + in + + (* if it is set function, there are some different set fields to do *) + let do_default, do_default_static , do_field, tf_args = if is_set then begin + let value_var = alloc_var "value" (if is_float then basic.tfloat else t_dynamic) in + let value_local = { eexpr = TLocal(value_var); etype = value_var.v_type; epos = pos } in + let tf_args = tf_args @ [value_var,None; handle_prop, None; ] in + let lookup_name = gen.gmk_internal_name "hx" ("lookupSetField" ^ if is_float then "_f" else "") in + + let do_default = + fun () -> + mk_return (mk_this_call_raw lookup_name (TFun(fun_args (field_args @ [value_var,None]),value_var.v_type)) ( List.map (fun (v,_) -> mk_local v pos) field_args @ [ value_local ] )) + in + + let do_field cf cf_type is_static = + let get_field ethis = { eexpr = TField (ethis, if is_static then FStatic (cl, cf) else FInstance(cl, cf)); etype = cf_type; epos = pos } in + let this = if is_static then mk_classtype_access cl pos else { eexpr = TConst(TThis); etype = t; epos = pos } in + + let ret = + { + eexpr = TBlock([ + { + eexpr = TBinop(Ast.OpAssign, + get_field this, + mk_cast cf_type value_local); + etype = cf_type; + epos = pos; + }; + mk_return value_local + ]); + etype = cf_type; + epos = pos; + } in + match cf.cf_kind with + | Var { v_write = AccCall } -> + let bl = + [ + mk_this_call_raw ("set_" ^ cf.cf_name) (TFun(["value",false,cf.cf_type], cf.cf_type)) [ value_local ]; + mk_return value_local + ] in + if Type.is_extern_field cf then + { eexpr = TBlock bl; etype = value_local.etype; epos = pos } + else + { + eexpr = TIf( + handle_prop_local, + { eexpr = TBlock bl; etype = value_local.etype; epos = pos }, + Some ret); + etype = value_local.etype; + epos = pos; + } + | _ -> + ret + in + + (mk_do_default tf_args do_default, do_default, do_field, tf_args) + end else begin + (* (field, isStatic, throwErrors, isCheck):Dynamic *) + let throw_errors = alloc_var "throwErrors" basic.tbool in + let throw_errors_local = mk_local throw_errors pos in + let do_default, tf_args = if not is_float then begin + let is_check = alloc_var "isCheck" basic.tbool in + let is_check_local = mk_local is_check pos in + + let tf_args = tf_args @ [ throw_errors,None; ] in + + (* default: if (isCheck) return __undefined__ else if(throwErrors) throw "Field not found"; else return null; *) + let lookup_name = gen.gmk_internal_name "hx" "lookupField" in + let do_default = + fun () -> + mk_return (mk_this_call_raw lookup_name (TFun(fun_args (field_args @ [throw_errors,None;is_check,None; ]),t_dynamic)) ( List.map (fun (v,_) -> mk_local v pos) field_args @ [ throw_errors_local; is_check_local; ] )) + in + + (do_default, tf_args @ [ is_check,None; handle_prop,None; ]) + end else begin + let tf_args = tf_args @ [ throw_errors,None; ] in + + let lookup_name = gen.gmk_internal_name "hx" "lookupField_f" in + let do_default = + fun () -> + mk_return (mk_this_call_raw lookup_name (TFun(fun_args (field_args @ [throw_errors,None; ]),basic.tfloat)) ( List.map (fun (v,_) -> mk_local v pos) field_args @ [ throw_errors_local; ] )) + in + + (do_default, tf_args @ [ handle_prop,None; ]) + end in + + let get_field cf cf_type ethis cl name = + match cf.cf_kind with + | Var { v_read = AccCall } when Type.is_extern_field cf -> + mk_return (mk_this_call_raw ("get_" ^ cf.cf_name) (TFun(["value",false,cf.cf_type], cf.cf_type)) [ ]) + | Var { v_read = AccCall } -> + { + eexpr = TIf( + handle_prop_local, + mk_return (mk_this_call_raw ("get_" ^ cf.cf_name) (TFun(["value",false,cf.cf_type], cf.cf_type)) [ ]), + Some { eexpr = TField (ethis, FInstance(cl, cf)); etype = cf_type; epos = pos } + ); + etype = cf_type; + epos = pos; + } + | Var _ + | Method MethDynamic -> { eexpr = TField (ethis, FInstance(cl,cf)); etype = cf_type; epos = pos } + | _ -> + { eexpr = TField (this, FClosure(Some cl, cf)); etype = cf_type; epos = pos } + in + + let do_field cf cf_type static = + let this = if static then mk_classtype_access cl pos else { eexpr = TConst(TThis); etype = t; epos = pos } in + match is_float, follow cf_type with + | true, TInst( { cl_kind = KTypeParameter _ }, [] ) -> + mk_return (mk_cast basic.tfloat (mk_cast t_dynamic (get_field cf cf_type this cl cf.cf_name))) + | _ -> + mk_return (maybe_cast (get_field cf cf_type this cl cf.cf_name )) + in + (mk_do_default tf_args do_default, do_default, do_field, tf_args) + end in + + let get_fields static = + let ret = collect_fields cl ( if is_float || is_set then Some (false) else None ) (Some static) in + let ret = if is_set then List.filter (fun (_,cf) -> + match cf.cf_kind with + | Var { v_write = AccNever } -> false + | _ -> not (Meta.has Meta.ReadOnly cf.cf_meta)) ret + else + List.filter (fun (_,cf) -> + match cf.cf_kind with + | Var { v_read = AccNever } -> false + | _ -> true) ret in + if is_float then + List.filter (fun (_,cf) -> (* TODO: maybe really apply_params in cf.cf_type. The benefits would be limited, though *) + match follow (ctx.rcf_gen.greal_type (ctx.rcf_gen.gfollow#run_f cf.cf_type)) with + | TDynamic _ | TMono _ + | TInst ({ cl_kind = KTypeParameter _ }, _) -> true + | t when like_float t -> true + | _ -> false + ) ret + else + (* dynamic will always contain all references *) + ret + in + + (* now we have do_default, do_field and tf_args *) + (* so create the switch expr *) + fun_type := TFun(List.map (fun (v,_) -> (v.v_name, false, v.v_type)) tf_args, if is_float then basic.tfloat else t_dynamic ); + let has_fields = ref false in + + let mk_switch static = + let fields = get_fields static in + let fields = List.filter (fun (_, cf) -> match is_set, cf.cf_kind with + | true, Var { v_write = AccCall } -> true + | false, Var { v_read = AccCall } -> true + | _ -> not (Type.is_extern_field cf)) fields + in + (if fields <> [] then has_fields := true); + let cases = List.map (fun (names, cf) -> + (if names = [] then assert false); + (List.map (switch_case ctx pos) names, do_field cf cf.cf_type static) + ) fields in + let default = Some(if static then do_default_static() else do_default()) in + + { eexpr = TSwitch(local_switch_var, cases, default); etype = basic.tvoid; epos = pos } + in + + let content = if ctx.rcf_handle_statics then + mk_block { eexpr = TIf(is_static_local, mk_switch true, Some(mk_switch false)); etype = basic.tvoid; epos = pos } + else + mk_block (mk_switch false) + in + + let is_override = match cl.cl_super with + | Some (cl, _) when is_hxgen (TClassDecl cl) -> true + | _ -> false + in + + if !has_fields || (not is_override) then begin + let func = + { + tf_args = tf_args; + tf_type = if is_float then basic.tfloat else t_dynamic; + tf_expr = content; + } in + + let func = { eexpr = TFunction(func); etype = !fun_type; epos = pos } in + + cfield.cf_type <- !fun_type; + cfield.cf_expr <- Some func; + + cl.cl_ordered_fields <- cl.cl_ordered_fields @ [cfield]; + cl.cl_fields <- PMap.add fun_name cfield cl.cl_fields; + + (if is_override then cl.cl_overrides <- cfield :: cl.cl_overrides) + end else () + in + (if ctx.rcf_float_special_case then mk_cfield true true); + mk_cfield true false; + mk_cfield false false; + (if ctx.rcf_float_special_case then mk_cfield false true) + + let mk_field_access_r ctx pos local field is_float is_static throw_errors set_option = + let is_set = is_some set_option in + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + + let fun_name = ctx.rcf_gen.gmk_internal_name "hx" ( (if is_set then "setField" else "getField") ^ (if is_float then "_f" else "") ) in + let tf_args, _ = field_type_args ctx pos in + let tf_args, args = fun_args tf_args, field in + + let rett = if is_float then basic.tfloat else t_dynamic in + let tf_args, args = if ctx.rcf_handle_statics then tf_args @ [ "isStatic", false, basic.tbool ], args @ [is_static] else tf_args, args in + let tf_args, args = if is_set then tf_args @ [ "setVal", false, rett ], args @ [get set_option] else tf_args, args in + let tf_args, args = tf_args @ [ "throwErrors",false,basic.tbool ], args @ [throw_errors] in + let tf_args, args = if is_set || is_float then tf_args, args else tf_args @ [ "isCheck", false, basic.tbool ], args @ [{ eexpr = TConst(TBool false); etype = basic.tbool; epos = pos }] in + let tf_args, args = tf_args @ [ "handleProperties",false,basic.tbool; ], args @ [ mk_bool ctx false pos; ] in + + { + eexpr = TCall( + { (mk_field_access gen local fun_name pos) with etype = TFun(tf_args, rett) }, + args); + etype = rett; + epos = pos; + } + + + let implement_fields ctx cl = + (* + implement two kinds of fields get: + classFields + generic 'fields': receives a parameter isInstance + will receive an Array and start pushing the fields into it. + //add all common fields + if(isInstance) + { + //add methods + } else { + super.fields(isInstance, array); + } + *) + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let pos = cl.cl_pos in + (* + let rec has_no_dynamic cl = + if is_some cl.cl_dynamic then + false + else match cl.cl_super with + | None -> true + | Some(cl,_) -> has_no_dynamic cl + in + *) + (* Type.getClassFields() *) + if ctx.rcf_handle_statics then begin + let name = gen.gmk_internal_name "hx" "classFields" in + let v_base_arr = alloc_var "baseArr" (basic.tarray basic.tstring) in + let base_arr = mk_local v_base_arr pos in + + let tf_args = [v_base_arr,None] in + let t = TFun(fun_args tf_args, basic.tvoid) in + let cf = mk_class_field name t false pos (Method MethNormal) [] in + cl.cl_ordered_fields <- cl.cl_ordered_fields @ [cf]; + cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields; + (if is_override cl then cl.cl_overrides <- cf :: cl.cl_overrides); + (* + var newarr = ["field1", "field2"] ...; + *) + let fields = collect_fields cl None (Some true) in + let mk_push value = + { eexpr = TCall({ (mk_field_access gen base_arr "push" pos) with etype = TFun(["x", false, basic.tstring], basic.tint) }, [value] ); etype = basic.tint; epos = pos } + in + + let new_arr_contents = + { + eexpr = TBlock( + List.map (fun (_,cf) -> mk_push { eexpr = TConst(TString(cf.cf_name)); etype = basic.tstring; epos = pos }) fields + ); + etype = basic.tvoid; + epos = pos + } in + + let expr = new_arr_contents in + let fn = + { + tf_args = tf_args; + tf_type = basic.tvoid; + tf_expr = mk_block expr + } in + + cf.cf_expr <- Some { eexpr = TFunction(fn); etype = t; epos = pos } + end; + + let fields = + (* + function __hx_fields(baseArr:Array, isInstanceFields:Bool) + { + //add all variable fields + //then: + if (isInstanceFields) + { + //add all method fields as well + } else { + super.__hx_fields(baseArr, isInstanceFields); + } + } + *) + let name = gen.gmk_internal_name "hx" "getFields" in + let v_base_arr, v_is_inst = alloc_var "baseArr" (basic.tarray basic.tstring), alloc_var "isInstanceFields" basic.tbool in + let base_arr, is_inst = mk_local v_base_arr pos, mk_local v_is_inst pos in + + let tf_args = (v_base_arr,None) :: (if ctx.rcf_handle_statics then [v_is_inst, None] else []) in + let t = TFun(fun_args tf_args, basic.tvoid) in + let cf = mk_class_field name t false pos (Method MethNormal) [] in + + let mk_push value = + { eexpr = TCall({ (mk_field_access gen base_arr "push" pos) with etype = TFun(["x", false, basic.tstring], basic.tint); }, [value] ); etype = basic.tint; epos = pos } + in + + let has_value = ref false in + let map_fields = + List.map (fun (_,cf) -> + match cf.cf_kind with + | Var _ + | Method MethDynamic when not (List.memq cf cl.cl_overrides) -> + has_value := true; + mk_push { eexpr = TConst(TString(cf.cf_name)); etype = basic.tstring; epos = pos } + | _ -> null basic.tvoid pos + ) + in + + (* + if it is first_dynamic, then we need to enumerate the dynamic fields + *) + let if_not_inst = if is_some cl.cl_dynamic && is_first_dynamic cl then begin + has_value := true; + Some (enumerate_dynamic_fields ctx cl mk_push) + end else + None + in + + let if_not_inst = if is_override cl then + Some( + { + eexpr = TBlock( + (if is_some if_not_inst then get if_not_inst else []) @ + [{ + eexpr = TCall( + { eexpr = TField({ eexpr = TConst TSuper; etype = TInst(cl, List.map snd cl.cl_types); epos = pos }, FInstance(cl, cf)); etype = t; epos = pos }, + base_arr :: (if ctx.rcf_handle_statics then [is_inst] else []) + ); + etype = basic.tvoid; + epos = pos + }] + ); + etype = basic.tvoid; + epos = pos + } + ) else if is_some if_not_inst then + Some({ eexpr = TBlock(get if_not_inst); etype = basic.tvoid; epos = pos }) + else + None + in + + let expr_contents = map_fields (collect_fields cl (Some false) (Some false)) in + let expr_contents = if ctx.rcf_handle_statics then + expr_contents @ + [ { + eexpr = TIf(is_inst, + { eexpr = TBlock( map_fields (collect_fields cl (Some true) (Some false)) ); etype = basic.tvoid; epos = pos }, + if_not_inst + ); + etype = basic.tvoid; + epos = pos + } ] + else + expr_contents @ (if is_some if_not_inst then [ get if_not_inst ] else []) + in + + let expr = + { + eexpr = TBlock( expr_contents ); + etype = basic.tvoid; + epos = pos; + } in + + let fn = + { + tf_args = tf_args; + tf_type = basic.tvoid; + tf_expr = expr + } in + + (if !has_value || (not (is_override cl)) then begin + cl.cl_ordered_fields <- cl.cl_ordered_fields @ [cf]; + cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields; + (if is_override cl then cl.cl_overrides <- cf :: cl.cl_overrides) + end); + cf.cf_expr <- Some { eexpr = TFunction(fn); etype = t; epos = pos } + in + ignore fields + + let implement_class_methods ctx cl = + ctx.rcf_class_cl <- Some cl; + + let pos = cl.cl_pos in + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + (* + fields -> redirected to classFields + getField -> redirected to getField with isStatic true + setField -> isStatic true + invokeField -> isStatic true + getClass -> null + create -> proxy + createEmpty -> proxy + *) + let is_override = is_override cl in + let name = "classProxy" in + let t = (TInst(ctx.rcf_object_iface,[])) in + (* let cf = mk_class_field name t false pos (Var { v_read = AccNormal; v_write = AccNormal }) [] in *) + let register_cf cf override = + cl.cl_ordered_fields <- cf :: cl.cl_ordered_fields; + cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields; + if override then cl.cl_overrides <- cf :: cl.cl_overrides + in + (* register_cf cf false; *) + + let this_t = TInst(cl, List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + let proxy = mk_this name t in + + (*let ctor = + let cls = alloc_var "cls" t in + let tf_args = [cls, None] in + let t = TFun(fun_args tf_args, basic.tvoid) in + let cf = mk_class_field "new" t true pos (Method MethNormal) [] in + cf.cf_expr <- Some({ + eexpr = TFunction({ + tf_args = tf_args; + tf_type = basic.tvoid; + tf_expr = mk_block { + eexpr = TBinop(Ast.OpAssign, proxy, mk_local cls pos); + etype = cls.v_type; + epos = pos; + } + }); + etype = t; + epos = pos; + }); + cf + in + register_cf ctor false;*) + + (* setting it as DynamicObject makes getClass return null *) + let get_class = + cl.cl_meta <- (Meta.DynamicObject, [], pos) :: cl.cl_meta + in + ignore get_class; + + (* fields -> if isInstanceField, redir the method. If not, return classFields *) + let fields = + let name = gen.gmk_internal_name "hx" "getFields" in + let v_base_arr, v_is_inst = alloc_var "baseArr" (basic.tarray basic.tstring), alloc_var "isInstanceFields" basic.tbool in + let base_arr, is_inst = mk_local v_base_arr pos, mk_local v_is_inst pos in + + let tf_args = [ v_base_arr,None; v_is_inst, None ] in + let t = TFun(fun_args tf_args, basic.tvoid) in + let cf = mk_class_field name t false pos (Method MethNormal) [] in + cf.cf_expr <- Some({ + eexpr = TFunction({ + tf_args = tf_args; + tf_type = basic.tvoid; + tf_expr = mk_block { + eexpr = TIf(is_inst, + { eexpr = TCall( { (mk_field_access gen proxy name pos) with etype = t }, [base_arr;is_inst]); etype = basic.tvoid; epos = pos }, + Some { eexpr = TCall(mk_this (gen.gmk_internal_name "hx" "classFields") (TFun(["baseArr",false,basic.tarray basic.tstring], basic.tvoid)), [base_arr]); etype = basic.tvoid; epos = pos }); + etype = basic.tvoid; + epos = pos + } + }); + etype = t; + epos = pos; + }); + cf + in + register_cf fields (is_override); + + let do_proxy field tf_args ret is_static_argnum = + let field = gen.gmk_internal_name "hx" field in + let t = TFun(fun_args tf_args, ret) in + let cf = mk_class_field field t false pos (Method MethNormal) [] in + let is_void = is_void ret in + let may_return e = if is_void then mk_block e else mk_block (mk_return e) in + let i = ref 0 in + cf.cf_expr <- Some({ + eexpr = TFunction({ + tf_args = tf_args; + tf_type = ret; + tf_expr = may_return { + eexpr = TCall( + { (mk_field_access gen proxy field pos) with etype = t }, + List.map (fun (v,_) -> + let lasti = !i in + incr i; + if lasti = is_static_argnum then + { eexpr = TConst(TBool true); etype = basic.tbool; epos = pos } + else + mk_local v pos + ) tf_args); + etype = ret; + epos = pos + } + }); + etype = t; + epos = pos; + }); + cf + in + + (* getClassFields -> redir *) + register_cf (do_proxy "classFields" [ alloc_var "baseArr" (basic.tarray basic.tstring), None ] basic.tvoid (-1)) true; + + (*register_cf (do_proxy "classFields" [ alloc_var "baseArr" (basic.tarray basic.tstring), None ] basic.tvoid (-1)) true;*) + + let fst_args, _ = field_type_args ctx pos in + let fst_args_len = List.length fst_args in + + (* getField -> redir the method with static = true *) + (* setField -> redir the methods with static = true *) + (if ctx.rcf_float_special_case then + register_cf (do_proxy "getField_f" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "throwErrors" basic.tbool, None ]) basic.tfloat fst_args_len) true; + register_cf (do_proxy "setField_f" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "value" basic.tfloat, None ]) basic.tfloat fst_args_len) true + ); + register_cf (do_proxy "getField" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "throwErrors" basic.tbool, None; alloc_var "isCheck" basic.tbool, None; alloc_var "handleProperties" basic.tbool,None; ]) t_dynamic fst_args_len) true; + register_cf (do_proxy "setField" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "value" t_dynamic, None; alloc_var "handleProperties" basic.tbool,None; ]) t_dynamic fst_args_len) true; + + (* invokeField -> redir the method with static = true *) + register_cf (do_proxy "invokeField" (fst_args @ [ alloc_var "isStatic" basic.tbool, None; alloc_var "dynArgs" (basic.tarray t_dynamic), None ]) t_dynamic fst_args_len) true; + + (* create / createEmpty -> redir the method *) + register_cf (do_proxy "create" [ alloc_var "arr" (basic.tarray t_dynamic), None ] t_dynamic (-1)) true; + register_cf (do_proxy "createEmpty" [ ] t_dynamic (-1)) true + + let implement_get_class ctx cl = + (* + if it is DynamicObject, return null; + if it is not, just do the following: + if (typehandle(this.class) == typehandle(MyClass)) + return (MyClass.__hx_class != null ? MyClass.__hx_class : MyClass.__hx_class = create_empty(MyClass)); + return MyClass.__hx_class = haxe.lang.Runtime.getClass(MyClass); + + implement both on static and non-static contexts. This way we can call without references. + *) + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let pos = cl.cl_pos in + + let tclass = get_cl ( (Hashtbl.find gen.gtypes ([],"Class")) ) in + let cls = TInst(tclass, [ TInst(cl, List.map (fun _ -> t_dynamic) cl.cl_types) ]) in + let cls_dyn = TInst(tclass, [t_dynamic]) in + + let expr, static_cfs = + if Meta.has Meta.DynamicObject cl.cl_meta then + mk_return (null t_dynamic pos), [] + else + let cache_name = (gen.gmk_internal_name "hx" "class") in + let cache = mk_class_field cache_name cls false pos (Var { v_read = AccNormal; v_write = AccNormal }) [] in + cl.cl_ordered_statics <- cl.cl_ordered_statics @ [ cache ]; + cl.cl_statics <- PMap.add cache_name cache cl.cl_statics; + + let cache_access = mk_static_field_access cl cache_name cls pos in + + + let create_expr = { + eexpr = TNew(get ctx.rcf_class_cl, [], [gen.gtools.rf_create_empty cl (List.map (fun _ -> t_dynamic) cl.cl_types) pos]); + etype = cls; + epos = pos + } in + + (if ctx.rcf_class_eager_creation then cache.cf_expr <- Some(create_expr)); + + let expr = if ctx.rcf_class_eager_creation then + mk_return cache_access + else + mk_return { + eexpr = TIf( + { eexpr = TBinop(Ast.OpNotEq, cache_access, null cls pos); etype = basic.tbool; epos = pos }, + cache_access, + Some({ eexpr = TBinop(Ast.OpAssign, cache_access, create_expr); etype = cls; epos = pos }) + ); + etype = cls; + epos = pos + } + in + expr, [] + in + + let func = + { + eexpr = TFunction({ + tf_args = []; + tf_type = cls_dyn; + tf_expr = expr + }); + etype = TFun([],cls_dyn); + epos = pos + } in + + let get_cl_static = mk_class_field (gen.gmk_internal_name "hx" "getClassStatic") (TFun([],cls_dyn)) false pos (Method MethNormal) [] in + let get_cl = mk_class_field (gen.gmk_internal_name "hx" "getClass") (TFun([],cls_dyn)) false pos (Method MethNormal) [] in + + get_cl_static.cf_expr <- Some func; + get_cl.cf_expr <- Some func; + + let all_f = [get_cl] in + cl.cl_ordered_fields <- cl.cl_ordered_fields @ all_f; + List.iter (fun cf -> cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields) all_f; + + let all_f = get_cl_static :: static_cfs in + cl.cl_ordered_statics <- cl.cl_ordered_statics @ all_f; + List.iter (fun cf -> cl.cl_statics <- PMap.add cf.cf_name cf cl.cl_statics) all_f; + + if is_override cl then cl.cl_overrides <- get_cl :: cl.cl_overrides + + let implement_invokeField ctx ~slow_invoke cl = + (* + There are two ways to implement an haxe reflection-enabled class: + When we extend a non-hxgen class, and when we extend the base HxObject class. + + Because of the added boiler plate we'd add every time we extend a non-hxgen class to implement a big IHxObject + interface, we'll handle the cases differently when implementing each interface. + + At the IHxObject interface, there's only invokeDynamic(field, args[]), while at the HxObject class there are + the other, more optimized methods, that follow the Function class interface. + + Since this will only be called by the Closure class, this conversion can be properly dealt with later. + + TODO: create the faster version. By now only invokeDynamic will be implemented + *) + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let pos = cl.cl_pos in + + let has_method = ref false in + + let is_override = ref false in + let rec extends_hxobject cl = + match cl.cl_super with + | None -> true + | Some (cl,_) when is_hxgen (TClassDecl cl) -> is_override := true; extends_hxobject cl + | _ -> false + in + + let field_args, switch_var = field_type_args ctx cl.cl_pos in + let field_args_exprs = List.map (fun (v,_) -> mk_local v pos) field_args in + + let is_static = alloc_var "isStatic" basic.tbool in + let dynamic_arg = alloc_var "dynargs" (basic.tarray t_dynamic) in + let all_args = field_args @ (if ctx.rcf_handle_statics then [ is_static,None; dynamic_arg,None ] else [ dynamic_arg, None ] ) in + let fun_t = TFun(fun_args all_args, t_dynamic) in + + let this_t = TInst(cl, List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in + let apply_object cf = apply_params cf.cf_params (List.map (fun _ -> t_dynamic) cf.cf_params) cf.cf_type in + + let mk_this_call_raw name fun_t params = + { eexpr = TCall( { (mk_field_access gen this name pos) with etype = fun_t }, params ); etype = snd (get_args fun_t); epos = pos } + in + + let mk_this_call cf params = + let t = apply_object cf in + (* the return type transformation into Dynamic *) + (* is meant to avoid return-type casting after functions with *) + (* type parameters are properly inferred at TypeParams.infer_params *) + (* e.g. function getArray(t:T):Array; after infer_params, *) + (* T will be inferred as SomeType, but the returned type will still be typed *) + (* as Array *) + let args, ret = get_args t in + let ret = match follow ret with + | TEnum({ e_path = ([], "Void") }, []) + | TAbstract ({ a_path = ([], "Void") },[]) -> ret + | _ -> ret + in + mk_this_call_raw cf.cf_name (TFun(args, ret)) params + in + + let mk_static_call cf params = + let t = apply_object cf in + let _, ret = get_fun (follow t) in + { eexpr = TCall( mk_static_field_access cl cf.cf_name t pos, params ); etype = ret; epos = pos } + in + + let extends_hxobject = extends_hxobject cl in + ignore extends_hxobject; + (* creates a dynamicInvoke of the class fields listed here *) + (* + function dynamicInvoke(field, isStatic, dynargs) + { + switch(field) + { + case "a": this.a(dynargs[0], dynargs[1], dynargs[2]...); + default: super.dynamicInvoke //or this.getField(field).invokeField(dynargs) + } + } + *) + + let dyn_fun = mk_class_field (ctx.rcf_gen.gmk_internal_name "hx" "invokeField") fun_t false cl.cl_pos (Method MethNormal) [] in + + let mk_switch_dyn cfs static old = + (* mk_class_field name t public pos kind params = *) + + let get_case (names,cf) = + has_method := true; + let i = ref 0 in + let dyn_arg_local = mk_local dynamic_arg pos in + let cases = List.map (switch_case ctx pos) names in + (cases, + { eexpr = TReturn(Some ( (if static then mk_static_call else mk_this_call) cf (List.map (fun (name,_,t) -> + let ret = { eexpr = TArray(dyn_arg_local, mk_int ctx !i pos); etype = t_dynamic; epos = pos } in + incr i; + ret + ) (fst (get_args (cf.cf_type))) ) )); + etype = basic.tvoid; + epos = pos + } + ) + in + + let cfs = List.filter (fun (_,cf) -> match cf.cf_kind with + | Method _ -> if List.memq cf cl.cl_overrides then false else true + | _ -> true) cfs + in + + let cases = List.map get_case cfs in + let cases = match old with + | [] -> cases + | _ -> + let ncases = List.map (fun cf -> switch_case ctx pos cf.cf_name) old in + ( ncases, mk_return ((get slow_invoke) this (mk_local (fst (List.hd field_args)) pos) (mk_local dynamic_arg pos)) ) :: cases + in + + let default = if !is_override && not(static) then + (* let call_super ctx fn_args ret_t fn_name this_t pos = *) + { eexpr = TReturn(Some (call_super ctx all_args t_dynamic dyn_fun cl this_t pos) ); etype = basic.tvoid; epos = pos } + (*else if ctx.rcf_create_getsetinvoke_fields then (* we always need to run create_getset before *) + let get_field_name = gen.gmk_internal_name "hx" "getField" in + { eexpr = TReturn( Some (mk_this_call (PMap.find get_field_name cl.cl_fields) [mk_local dynamic_arg pos] ) ); etype = basic.tvoid; epos = pos }*) + else ( + (*let field = (gen.gtools.r_field false (TInst(ctx.rcf_ft.func_class,[])) this (mk_local (fst (List.hd all_args)) pos)) in*) + (* let mk_field_access ctx pos local field is_float is_static throw_errors set_option = *) + let field = mk_field_access_r ctx pos this field_args_exprs false {eexpr = TConst(TBool static); etype = basic.tbool; epos = pos} { eexpr = TConst(TBool true); etype = basic.tbool; epos = pos } None in + let field = mk_cast (TInst(ctx.rcf_ft.func_class,[])) field in + mk_return { + eexpr = TCall( + mk_field_access gen field (gen.gmk_internal_name "hx" "invokeDynamic") pos, + [mk_local dynamic_arg pos]); + etype = t_dynamic; + epos = pos + } ) + in + + { + eexpr = TSwitch(mk_local switch_var pos, cases, Some default); + etype = basic.tvoid; + epos = pos; + } + in + + let contents = + let statics = collect_fields cl (Some true) (Some true) in + let nonstatics = collect_fields cl (Some true) (Some false) in + + let old_nonstatics = ref [] in + + let nonstatics = match slow_invoke with + | None -> nonstatics + | Some _ -> + List.filter (fun (n,cf) -> + let is_old = not (PMap.mem cf.cf_name cl.cl_fields) || List.memq cf cl.cl_overrides in + (if is_old then old_nonstatics := cf :: !old_nonstatics); + not is_old + ) nonstatics + in + + if ctx.rcf_handle_statics then + { + eexpr = TIf(mk_local is_static pos, mk_switch_dyn statics true [], Some(mk_switch_dyn nonstatics false !old_nonstatics)); + etype = basic.tvoid; + epos = pos; + } else + mk_switch_dyn nonstatics false !old_nonstatics + in + + dyn_fun.cf_expr <- Some + { + eexpr = TFunction( + { + tf_args = all_args; + tf_type = t_dynamic; + tf_expr = mk_block contents; + }); + etype = TFun(fun_args all_args, t_dynamic); + epos = pos; + }; + if !is_override && not (!has_method) then () else begin + cl.cl_ordered_fields <- cl.cl_ordered_fields @ [dyn_fun]; + cl.cl_fields <- PMap.add dyn_fun.cf_name dyn_fun cl.cl_fields; + (if !is_override then cl.cl_overrides <- dyn_fun :: cl.cl_overrides) + end + + let implement_varargs_cl ctx cl = + let pos = cl.cl_pos in + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + + let this_t = TInst(cl, List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t ; epos = pos } in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + + let invokedyn = gen.gmk_internal_name "hx" "invokeDynamic" in + let idyn_t = TFun([gen.gmk_internal_name "fn" "dynargs", false, basic.tarray t_dynamic], t_dynamic) in + let this_idyn = mk_this invokedyn idyn_t in + + let map_fn arity ret vars api = + + let rec loop i acc = + if i < 0 then + acc + else + let obj = api i t_dynamic None in + loop (i - 1) (obj :: acc) + in + + let call_arg = if arity = (-1) then + api (-1) t_dynamic None + else if arity = 0 then + null (basic.tarray t_empty) pos + else + { eexpr = TArrayDecl(loop (arity - 1) []); etype = basic.tarray t_empty; epos = pos } + in + + let expr = { + eexpr = TCall( + this_idyn, + [ call_arg ] + ); + etype = t_dynamic; + epos = pos + } in + + let expr = if like_float ret && not (like_int ret) then mk_cast ret expr else expr in + + [], mk_return expr + in + + let all_cfs = List.filter (fun cf -> cf.cf_name <> "new" && cf.cf_name <> (invokedyn) && match cf.cf_kind with Method _ -> true | _ -> false) (ctx.rcf_ft.map_base_classfields cl true map_fn) in + + cl.cl_ordered_fields <- cl.cl_ordered_fields @ all_cfs; + List.iter (fun cf -> + cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields + ) all_cfs; + + List.iter (fun cf -> + cl.cl_overrides <- cf :: cl.cl_overrides + ) cl.cl_ordered_fields + + let implement_closure_cl ctx cl = + let pos = cl.cl_pos in + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + + let field_args, _ = field_type_args ctx pos in + let obj_arg = alloc_var "target" (TInst(ctx.rcf_object_iface, [])) in + + let this_t = TInst(cl, List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t ; epos = pos } in + let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in + + let tf_args = field_args @ [obj_arg, None] in + let cfs, ctor_body = List.fold_left (fun (acc_cf,acc_expr) (v,_) -> + let cf = mk_class_field v.v_name v.v_type false pos (Var { v_read = AccNormal; v_write = AccNormal } ) [] in + let expr = { eexpr = TBinop(Ast.OpAssign, mk_this v.v_name v.v_type, mk_local v pos); etype = v.v_type; epos = pos } in + (cf :: acc_cf, expr :: acc_expr) + ) ([], []) tf_args in + + let map_fn arity ret vars api = + let this_obj = mk_this "target" (TInst(ctx.rcf_object_iface, [])) in + + let rec loop i acc = + if i < 0 then + acc + else + let obj = api i t_dynamic None in + loop (i - 1) (obj :: acc) + in + + let call_arg = if arity = (-1) then + api (-1) t_dynamic None + else if arity = 0 then + null (basic.tarray t_empty) pos + else + { eexpr = TArrayDecl(loop (arity - 1) []); etype = basic.tarray t_empty; epos = pos } + in + + let expr = { + eexpr = TCall( + mk_field_access gen this_obj (gen.gmk_internal_name "hx" "invokeField") pos, + (List.map (fun (v,_) -> mk_this v.v_name v.v_type) field_args) @ + (if ctx.rcf_handle_statics then + [ { eexpr = TConst(TBool false); etype = basic.tbool; epos = pos }; call_arg ] + else + [ call_arg ] + ) + ); + etype = t_dynamic; + epos = pos + } in + + let expr = if like_float ret && not (like_int ret) then mk_cast ret expr else expr in + + [], mk_return expr + in + + let all_cfs = List.filter (fun cf -> cf.cf_name <> "new" && match cf.cf_kind with Method _ -> true | _ -> false) (ctx.rcf_ft.map_base_classfields cl true map_fn) in + + List.iter (fun cf -> + cl.cl_overrides <- cf :: cl.cl_overrides + ) all_cfs; + let all_cfs = cfs @ all_cfs in + + cl.cl_ordered_fields <- cl.cl_ordered_fields @ all_cfs; + List.iter (fun cf -> + cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields + ) all_cfs; + + let ctor_t = TFun(fun_args tf_args, basic.tvoid) in + let ctor_cf = mk_class_field "new" ctor_t true pos (Method MethNormal) [] in + ctor_cf.cf_expr <- Some { + eexpr = TFunction({ + tf_args = tf_args; + tf_type = basic.tvoid; + tf_expr = { eexpr = TBlock({ + eexpr = TCall({ eexpr = TConst(TSuper); etype = TInst(cl,[]); epos = pos }, [mk_int ctx (-1) pos; mk_int ctx (-1) pos]); + etype = basic.tvoid; + epos = pos + } :: ctor_body); etype = basic.tvoid; epos = pos } + }); + etype = ctor_t; + epos = pos + }; + + cl.cl_constructor <- Some ctor_cf; + + let closure_fun eclosure e field is_static = + let f = { eexpr = TConst(TString field); etype = basic.tstring; epos = eclosure.epos } in + let args = if ctx.rcf_optimize then [ f; { eexpr = TConst(TInt (hash_field_i32 ctx eclosure.epos field)); etype = basic.tint; epos = eclosure.epos } ] else [ f ] in + let args = args @ [ mk_cast (TInst(ctx.rcf_object_iface, [])) e ] in + + { eclosure with eexpr = TNew(cl,[],args) } + in + closure_fun + + let get_closure_func ctx closure_cl = + let gen = ctx.rcf_gen in + let basic = gen.gcon.basic in + let closure_func eclosure e field is_static = + mk_cast eclosure.etype { eclosure with + eexpr = TNew(closure_cl, [], [ + e; + { eexpr = TConst(TString field); etype = basic.tstring; epos = eclosure.epos } + ] @ ( + if ctx.rcf_optimize then [ { eexpr = TConst(TInt (hash_field_i32 ctx eclosure.epos field)); etype = basic.tint; epos = eclosure.epos } ] else [] + )); + etype = TInst(closure_cl,[]) + } + in + closure_func + + (* + main expr -> field expr -> field string -> possible set expr -> should_throw_exceptions -> changed expression + + Changes a get / set + * + mutable rcf_on_getset_field : texpr->texpr->string->texpr option->bool->texpr;*) + + let configure_dynamic_field_access ctx is_synf = + let gen = ctx.rcf_gen in + let is_dynamic expr fexpr field = match field_access gen (gen.greal_type fexpr.etype) field with + | FEnumField _ + | FClassField _ -> false + | _ -> true + in + + let configure = if is_synf then DynamicFieldAccess.configure_as_synf else DynamicFieldAccess.configure in + let maybe_hash = if ctx.rcf_optimize then fun str pos -> Some (hash_field_i32 ctx pos str) else fun str pos -> None in + configure gen (DynamicFieldAccess.abstract_implementation gen is_dynamic + (fun expr fexpr field set is_unsafe -> + let hash = maybe_hash field fexpr.epos in + ctx.rcf_on_getset_field expr fexpr field hash set is_unsafe + ) + (fun ecall fexpr field call_list -> + let hash = maybe_hash field fexpr.epos in + ctx.rcf_on_call_field ecall fexpr field hash call_list + ) + ); + () + + let replace_reflection ctx cl = + let gen = ctx.rcf_gen in + let pos = cl.cl_pos in + + let this_t = TInst(cl, List.map snd cl.cl_types) in + let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in + + let last_fields = match cl.cl_super with + | None -> PMap.empty + | Some (super,_) -> super.cl_fields + in + + let new_fields = ref [] in + let process_cf static cf = + match cf.cf_kind with + | Var _ -> () + | _ when Meta.has Meta.ReplaceReflection cf.cf_meta -> + let name = if String.get cf.cf_name 0 = '_' then String.sub cf.cf_name 1 (String.length cf.cf_name - 1) else cf.cf_name in + let new_name = gen.gmk_internal_name "hx" name in + let new_cf = mk_class_field new_name cf.cf_type cf.cf_public cf.cf_pos cf.cf_kind cf.cf_params in + let fn_args, ret = get_fun (follow cf.cf_type) in + + let tf_args = List.map (fun (name,_,t) -> alloc_var name t, None) fn_args in + let is_void = is_void ret in + let expr = { + eexpr = TCall( + { + eexpr = (if static then TField(mk_classtype_access cl pos, FStatic(cl, cf)) else TField(this, FInstance(cl, cf))); + etype = cf.cf_type; + epos = cf.cf_pos; + }, + List.map (fun (v,_) -> mk_local v cf.cf_pos) tf_args); + etype = ret; + epos = cf.cf_pos + } in + + let new_f = + { + tf_args = tf_args; + tf_type = ret; + tf_expr = { + eexpr = TBlock([if is_void then expr else mk_return expr]); + etype = ret; + epos = pos; + } + } in + + new_cf.cf_expr <- Some({ eexpr = TFunction(new_f); etype = cf.cf_type; epos = cf.cf_pos}); + + new_fields := new_cf :: !new_fields; + + (if static then cl.cl_statics <- PMap.add new_name new_cf cl.cl_statics else cl.cl_fields <- PMap.add new_name new_cf cl.cl_fields); + + if not static && PMap.mem new_name last_fields then cl.cl_overrides <- new_cf :: cl.cl_overrides + | _ -> () + in + + List.iter (process_cf false) cl.cl_ordered_fields; + cl.cl_ordered_fields <- cl.cl_ordered_fields @ !new_fields; + new_fields := []; + List.iter (process_cf true) cl.cl_ordered_statics; + cl.cl_ordered_statics <- cl.cl_ordered_statics @ !new_fields + + (* ******************************************* *) + (* UniversalBaseClass *) + (* ******************************************* *) + + (* + + Sets the universal base class for hxgen types (HxObject / IHxObject) + + dependencies: + As a rule, it should be one of the last module filters to run so any @:hxgen class created in the process + -Should- only run after TypeParams.RealTypeParams.Modf, since + + *) + + module UniversalBaseClass = + struct + + let name = "rcf_universal_base_class" + + let priority = min_dep +. 10. + + let default_implementation gen baseclass baseinterface basedynamic = + (* baseinterface.cl_meta <- (Meta.BaseInterface, [], baseinterface.cl_pos) :: baseinterface.cl_meta; *) + let rec run md = + (if is_hxgen md then + match md with + | TClassDecl ( { cl_interface = true } as cl ) when cl.cl_path <> baseclass.cl_path && cl.cl_path <> baseinterface.cl_path && cl.cl_path <> basedynamic.cl_path -> + cl.cl_implements <- (baseinterface, []) :: cl.cl_implements + | TClassDecl ( { cl_super = None } as cl ) when cl.cl_path <> baseclass.cl_path && cl.cl_path <> baseinterface.cl_path && cl.cl_path <> basedynamic.cl_path -> + if is_some cl.cl_dynamic then + cl.cl_super <- Some (basedynamic,[]) + else + cl.cl_super <- Some (baseclass,[]) + | TClassDecl ( { cl_super = Some(super,_) } as cl ) when cl.cl_path <> baseclass.cl_path && cl.cl_path <> baseinterface.cl_path && not ( is_hxgen (TClassDecl super) ) -> + cl.cl_implements <- (baseinterface, []) :: cl.cl_implements + | _ -> () + ); + md + in + run + + let configure gen mapping_func = + let map e = Some(mapping_func e) in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map + + let default_config gen baseclass baseinterface basedynamic = + let impl = (default_implementation gen baseclass baseinterface basedynamic) in + configure gen impl + + end;; + + (* + Priority: must run AFTER UniversalBaseClass + *) + let priority = solve_deps name [DAfter UniversalBaseClass.priority] + + let configure ?slow_invoke ctx baseinterface = + let gen = ctx.rcf_gen in + let run = (fun md -> match md with + | TClassDecl cl when is_hxgen md && ( not cl.cl_interface || cl.cl_path = baseinterface.cl_path ) -> + (if Meta.has Meta.ReplaceReflection cl.cl_meta then replace_reflection ctx cl); + (implement_dynamics ctx cl); + (if not (PMap.mem (gen.gmk_internal_name "hx" "lookupField") cl.cl_fields) then implement_final_lookup ctx cl); + (if not (PMap.mem (gen.gmk_internal_name "hx" "getField") cl.cl_fields) then implement_get_set ctx cl); + (if not (PMap.mem (gen.gmk_internal_name "hx" "invokeField") cl.cl_fields) then implement_invokeField ctx ~slow_invoke:slow_invoke cl); + (if not (PMap.mem (gen.gmk_internal_name "hx" "classFields") cl.cl_fields) then implement_fields ctx cl); + (if ctx.rcf_handle_statics && not (PMap.mem (gen.gmk_internal_name "hx" "getClassStatic") cl.cl_statics) then implement_get_class ctx cl); + (if not cl.cl_interface && not (PMap.mem (gen.gmk_internal_name "hx" "create") cl.cl_fields) then implement_create_empty ctx cl); + None + | _ -> None) + in + + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) run + +end;; + +(* ******************************************* *) +(* Object Declaration Mapper *) +(* ******************************************* *) + +(* + + A simple Object Declaration Mapper. By default it will be a syntax filter, which only runs + after + + dependencies: + + +*) + +module ObjectDeclMap = +struct + + let name = "object_decl_map" + + let priority = solve_deps name [] + + let traverse gen map_fn = + let rec run e = + match e.eexpr with + | TObjectDecl odecl -> + let e = Type.map_expr run e in + (match e.eexpr with | TObjectDecl odecl -> map_fn e odecl | _ -> assert false) + | _ -> 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;; + + +(* ******************************************* *) +(* EnumToClass *) +(* ******************************************* *) + +(* + + For languages that don't support parameterized enums and/or metadata in enums, we need to transform + enums into normal classes. This is done at the first module pass by creating new classes with the same + path inside the modules, and removing the actual enum module by setting it as en extern. + + Later, on the last expression pass, it will transform the TMatch codes into TSwitch. it will introduce a new + dependency, though: + * The target must create its own strategy to deal with reflection. As it is right now, we will have a base class + which the class will extend, create @:$IsEnum metadata for the class, and create @:alias() metadatas for the fields, + with their tag order (as a string) as their alias. If you are using ReflectionCFs, then you don't have to worry + about that, as it's already generating all information needed by the haxe runtime. + so they can be + + dependencies: + The MatchToSwitch part must run after ExprStatementUnwrap as modified expressions might confuse it (not so true anymore) + +*) + +module EnumToClass = +struct + + let name = "enum_to_class" + + let priority = solve_deps name [] + + type t = { + ec_tbl : (path, tclass) Hashtbl.t; + } + + let new_t () = + { + ec_tbl = Hashtbl.create 10 + } + + (* ******************************************* *) + (* EnumToClassModf *) + (* ******************************************* *) + + (* + + The actual Module Filter that will transform the enum into a class + + dependencies: + Should run before ReflectionCFs, in order to enable proper reflection access. + Should run before TypeParams.RealTypeParams.RealTypeParamsModf, since generic enums must be first converted to generic classes + *) + + module EnumToClassModf = + struct + + let name = "enum_to_class_mod" + + let priority = solve_deps name [DBefore ReflectionCFs.priority; DBefore TypeParams.RealTypeParams.RealTypeParamsModf.priority] + + let pmap_exists fn pmap = try PMap.iter (fun a b -> if fn a b then raise Exit) pmap; false with | Exit -> true + + let has_any_meta en = + let has_meta meta = List.exists (fun (m,_,_) -> match m with Meta.Custom _ -> true | _ -> false) meta in + has_meta en.e_meta || pmap_exists (fun _ ef -> has_meta ef.ef_meta) en.e_constrs + + let has_parameters e = + try + (PMap.iter (fun _ ef -> match follow ef.ef_type with | TFun _ -> raise Exit | _ -> ()) e.e_constrs); + false + with | Exit -> true + + let convert gen t base_class en should_be_hxgen handle_type_params = + let basic = gen.gcon.basic in + let pos = en.e_pos in + + (* create the class *) + let cl = mk_class en.e_module en.e_path pos in + Hashtbl.add t.ec_tbl en.e_path cl; + + (match Codegen.build_metadata gen.gcon (TEnumDecl en) with + | Some expr -> + let cf = mk_class_field "__meta__" expr.etype false expr.epos (Var { v_read = AccNormal; v_write = AccNormal }) [] in + cf.cf_expr <- Some expr; + cl.cl_statics <- PMap.add "__meta__" cf cl.cl_statics; + cl.cl_ordered_statics <- cf :: cl.cl_ordered_statics + | _ -> () + ); + + cl.cl_super <- Some(base_class,[]); + cl.cl_extern <- en.e_extern; + en.e_extern <- true; + en.e_meta <- (Meta.Class, [], pos) :: en.e_meta; + cl.cl_module <- en.e_module; + cl.cl_meta <- ( Meta.Enum, [], pos ) :: cl.cl_meta; + let c_types = + if handle_type_params then + List.map (fun (s,t) -> (s, TInst (map_param (get_cl_t t), []))) en.e_types + else + [] + in + + cl.cl_types <- c_types; + + let i = ref 0 in + let cfs = List.map (fun name -> + let ef = PMap.find name en.e_constrs in + let pos = ef.ef_pos in + let old_i = !i in + incr i; + + let cf = match follow ef.ef_type with + | TFun(params,ret) -> + let dup_types = + if handle_type_params then + List.map (fun (s,t) -> (s, TInst (map_param (get_cl_t t), []))) en.e_types + else + [] + in + + let ef_type = + let fn, types = if handle_type_params then snd, dup_types else (fun _ -> t_dynamic), en.e_types in + let t = apply_params en.e_types (List.map fn types) ef.ef_type in + apply_params ef.ef_params (List.map fn ef.ef_params) t + in + + let params, ret = get_fun ef_type in + let cf_params = if handle_type_params then dup_types @ ef.ef_params else [] in + + let cf = mk_class_field name ef_type true pos (Method MethNormal) cf_params in + cf.cf_meta <- []; + + let tf_args = List.map (fun (name,opt,t) -> (alloc_var name t, if opt then Some TNull else None) ) params in + let arr_decl = { eexpr = TArrayDecl(List.map (fun (v,_) -> mk_local v pos) tf_args); etype = basic.tarray t_empty; epos = pos } in + let expr = { + eexpr = TFunction({ + tf_args = tf_args; + tf_type = ret; + tf_expr = mk_block ( mk_return { eexpr = TNew(cl,List.map snd dup_types, [mk_int gen old_i pos; arr_decl] ); etype = TInst(cl, List.map snd dup_types); epos = pos } ); + }); + etype = ef_type; + epos = pos + } in + cf.cf_expr <- Some expr; + cf + | _ -> + let actual_t = match follow ef.ef_type with + | TEnum(e, p) -> TEnum(e, List.map (fun _ -> t_dynamic) p) + | _ -> assert false + in + let cf = mk_class_field name actual_t true pos (Var { v_read = AccNormal; v_write = AccNormal }) [] in + cf.cf_meta <- []; + cf.cf_expr <- Some { + eexpr = TNew(cl, List.map (fun _ -> t_empty) cl.cl_types, [mk_int gen old_i pos; { eexpr = TArrayDecl []; etype = basic.tarray t_empty; epos = pos }]); + etype = TInst(cl, List.map (fun _ -> t_empty) cl.cl_types); + epos = pos; + }; + cf + in + cl.cl_statics <- PMap.add cf.cf_name cf cl.cl_statics; + cf + ) en.e_names in + let constructs_cf = mk_class_field "constructs" (basic.tarray basic.tstring) true pos (Var { v_read = AccNormal; v_write = AccNormal }) [] in + constructs_cf.cf_meta <- []; + constructs_cf.cf_expr <- Some { + eexpr = TArrayDecl (List.map (fun s -> { eexpr = TConst(TString s); etype = basic.tstring; epos = pos }) en.e_names); + etype = basic.tarray basic.tstring; + epos = pos; + }; + + cl.cl_ordered_statics <- constructs_cf :: cfs @ cl.cl_ordered_statics ; + cl.cl_statics <- PMap.add "constructs" constructs_cf cl.cl_statics; + + (if should_be_hxgen then + cl.cl_meta <- (Meta.HxGen,[],cl.cl_pos) :: cl.cl_meta + else begin + (* create the constructor *) + let tf_args = [ alloc_var "index" basic.tint, None; alloc_var "params" (basic.tarray t_empty), None ] in + let ftype = TFun(fun_args tf_args, basic.tvoid) in + let ctor = mk_class_field "new" ftype true pos (Method MethNormal) [] in + let me = TInst(cl, List.map snd cl.cl_types) in + ctor.cf_expr <- + Some { + eexpr = TFunction( + { + tf_args = tf_args; + tf_type = basic.tvoid; + tf_expr = mk_block { + eexpr = TCall({ eexpr = TConst TSuper; etype = me; epos = pos }, List.map (fun (v,_) -> mk_local v pos) tf_args); + etype = basic.tvoid; + epos = pos; + } + }); + etype = ftype; + epos = pos + }; + + cl.cl_constructor <- Some ctor + end); + gen.gadd_to_module (TClassDecl cl) (max_dep); + + TEnumDecl en + + (* + traverse + gen - gen context + convert_all : bool - should we convert all enums? If set, convert_if_has_meta will be ignored. + convert_if_has_meta : bool - should we convert only if it has meta? + enum_base_class : tclass - the enum base class. + should_be_hxgen : bool - should the created enum be hxgen? + *) + let traverse gen t convert_all convert_if_has_meta enum_base_class should_be_hxgen handle_tparams = + let convert e = convert gen t enum_base_class e should_be_hxgen handle_tparams in + let run md = match md with + | TEnumDecl e when is_hxgen md -> + if convert_all then + convert e + else if convert_if_has_meta && has_any_meta e then + convert e + else if has_parameters e then + convert e + else begin + (* take off the :hxgen meta from it, if there's any *) + e.e_meta <- List.filter (fun (n,_,_) -> not (n = Meta.HxGen)) e.e_meta; + md + end + | _ -> md + in + run + + let configure gen (mapping_func:module_type->module_type) = + let map md = Some(mapping_func md) in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map + + end;; + + (* ******************************************* *) + (* EnumToClassExprf *) + (* ******************************************* *) + + (* + + Enum to class Expression Filter + + will convert TMatch into TSwitch + + dependencies: + Should run before TArrayTransform, since it generates array access expressions + + *) + + module EnumToClassExprf = + struct + + let name = "enum_to_class_exprf" + + let priority = solve_deps name [DBefore TArrayTransform.priority] + + let ensure_local gen cond = + let exprs_before, new_cond = match cond.eexpr with + | TLocal v -> + [], cond + | _ -> + let v = mk_temp gen "cond" cond.etype in + [ { eexpr = TVars([v, Some cond]); etype = gen.gcon.basic.tvoid; epos = cond.epos } ], mk_local v cond.epos + in + exprs_before, new_cond + + let get_index gen cond cls tparams = + { (mk_field_access gen { cond with etype = TInst(cls, tparams) } "index" cond.epos) with etype = gen.gcon.basic.tint } + + (* stolen from Hugh's hxcpp sources *) + let tmatch_params_to_vars 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,!n) :: acc) [] l) + + let tmatch_params_to_exprs gen params cond_local = + let vars = tmatch_params_to_vars params in + let cond_array = { (mk_field_access gen cond_local "params" cond_local.epos) with etype = gen.gcon.basic.tarray t_empty } in + let tvars = List.map (fun (v, n) -> + (v, Some({ eexpr = TArray(cond_array, mk_int gen n cond_array.epos); etype = t_dynamic; epos = cond_array.epos })) + ) vars in + match vars with + | [] -> + [] + | _ -> + [ { eexpr = TVars(tvars); etype = gen.gcon.basic.tvoid; epos = cond_local.epos } ] + + let traverse gen t opt_get_native_enum_tag = + let rec run e = + match e.eexpr with + | TMatch(cond,(en,eparams),cases,default) -> + let cond = run cond in (* being safe *) + (* check if en was converted to class *) + (* if it was, switch on tag field and change cond type *) + let exprs_before, cond_local, cond = try + let cl = Hashtbl.find t.ec_tbl en.e_path in + let cond = { cond with etype = TInst(cl, eparams) } in + let exprs_before, new_cond = ensure_local gen cond in + exprs_before, new_cond, get_index gen new_cond cl eparams + with | Not_found -> + (* + if it's not a class, we'll either use get_native_enum_tag or in a last resource, + call Type.getEnumIndex + *) + match opt_get_native_enum_tag with + | Some get_native_etag -> + [], cond, get_native_etag cond + | None -> + [], cond, { eexpr = TCall(mk_static_field_access_infer gen.gclasses.cl_type "enumIndex" e.epos [], [cond]); etype = gen.gcon.basic.tint; epos = cond.epos } + in + + (* for each case, change cases to expr int, and see if there is any var create *) + let change_case (il, params, expr) = + let expr = run expr in + (* if there are, set var with tarray *) + let exprs = tmatch_params_to_exprs gen params cond_local in + let expr = match expr.eexpr with + | TBlock(bl) -> { expr with eexpr = TBlock(exprs @ bl) } + | _ -> { expr with eexpr = TBlock ( exprs @ [expr] ) } + in + (List.map (fun i -> mk_int gen i e.epos) il, expr) + in + + let tswitch = { e with eexpr = TSwitch(cond, List.map change_case cases, Option.map run default) } in + (match exprs_before with + | [] -> tswitch + | _ -> { e with eexpr = TBlock(exprs_before @ [tswitch]) }) + | _ -> Type.map_expr run e + in + + run + + let configure gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map + + end;; + + let configure gen opt_get_native_enum_tag convert_all convert_if_has_meta enum_base_class should_be_hxgen handle_tparams = + let t = new_t () in + EnumToClassModf.configure gen (EnumToClassModf.traverse gen t convert_all convert_if_has_meta enum_base_class should_be_hxgen handle_tparams); + EnumToClassExprf.configure gen (EnumToClassExprf.traverse gen t opt_get_native_enum_tag) + +end;; + +(* ******************************************* *) +(* IteratorsInterface *) +(* ******************************************* *) + +(* + + This module will handle with Iterators, Iterables and TFor() expressions. + At first, a module filter will receive a Iterator and Iterable interface, which will be implemented + if hasNext(), next() or iterator() fields are detected with the correct type. + At this part a custom function will be called which can adequate the class fields so they are compatible with + native Iterators as well + + The expression filter part of this module will look for TFor() expressions, and transform like that: + for (anInt in value.iterator()) + { + + } + + { + var s:haxe.lang.Iterator = ExternalFunction.getIterator(value.iterator()); + while (s.hasNext()) + { + var anInt:Int = s.next(); + + } + } + + dependencies: + None. + +*) + +module IteratorsInterface = +struct + + let name = "iterators_interface" + (* TODO later + (* ******************************************* *) + (* IteratorsInterfaceModf *) + (* ******************************************* *) + + (* + + The module filter for Iterators Interface, which will implement the iterator/iterable interface on each + class that conforms with the typedefs Iterator<> and Iterable<> + + It's a very simple module and it will rely on cast detection to work correctly. This is so that + when the + + dependencies: + Must run at the Module Filters, so cast detection can detect a cast to the interface and we can + + *) + + module IteratorsInterfaceModf = + struct + + let name = "iterators_interface_modf" + + let conforms_cfs has_next next = + try (match follow has_next.cf_type with + | TFun([],ret) when + (match follow ret with | TEnum({ e_path = ([], "Bool") }, []) -> () | _ -> raise Not_found) -> + () + | _ -> raise Not_found); + (match follow next.cf_type with + | TFun([], ret) -> ret + | _ -> raise Not_found + ) + + let conforms_type_iterator t = + try match follow t with + | TInst(cl,params) -> + let has_next = PMap.find "hasNext" cl.cl_fields in + let next = PMap.find "next" cl.cl_fields in + Some (conforms_cfs has_next next) + | TAnon(anon) -> + let has_next = PMap.find "hasNext" anon.a_fields in + let next = PMap.find "next" anon.a_fields in + Some (conforms_cfs has_next next) + | _ -> None + with | Not_found -> None + + let conforms_as_iterable cl = + try + let iterator = PMap.find "iterator" cl.cl_fields in + match follow iterator.cf_type with + | TFun([], ret) -> conforms_type_iterator ret + | _ -> None + with | Not_found -> None + + let conforms_as_iterator cl = + try + let has_next = PMap.find "hasNext" cl.cl_fields in + let next = PMap.find "next" cl.cl_fields in + Some (conforms_cfs has_next next) + with | Not_found -> None + + let priority = solve_deps name [] + + let traverse gen iterator_iface iterable_iface on_found_iterator on_found_iterable = + let rec run md = + match md with + | TClassDecl cl when not cl.cl_extern && is_hxgen cl -> + let conforms_iterator = conforms_as_iterator cl in + let conforms_iterable = conforms_as_iterable cl in + if is_some conforms_iterator then begin + let it_t = get conforms_iterator in + cl.cl_interfaces <- (iterator_iface, [it_t]); + on_found_iterator cl + end; + if is_some conforms_iterable then begin + let it_t = get conforms_iterable in + cl.cl_interfaces <- (iterable_iface, [it_t]); + on_found_iterable cl + end; + + md + | _ -> md + in + run + + let configure gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map + + end;; + *) + + (* ******************************************* *) + (* IteratorsInterfaceExprf *) + (* ******************************************* *) + + (* + + The expression filter for Iterators. Will look for TFor, transform it into + { + var iterator = // in expression here + while (iterator.hasNext()) + { + var varName = iterator.next(); + } + } + + dependencies: + Must run before Dynamic fields access is run + + *) + + module IteratorsInterfaceExprf = + struct + + let name = "iterators_interface_exprf" + + let priority = solve_deps name [DBefore DynamicFieldAccess.priority] + + let priority_as_synf = solve_deps name [DBefore DynamicFieldAccess.priority_as_synf] + + let mk_access gen v name pos = + let field_t = + try match follow v.v_type with + | TInst(cl, params) -> + let field = PMap.find name cl.cl_fields in + apply_params cl.cl_types params field.cf_type + | TAnon(anon) -> + let field = PMap.find name anon.a_fields in + field.cf_type + | _ -> t_dynamic + with | Not_found -> t_dynamic + in + { (mk_field_access gen (mk_local v pos) name pos) with etype = field_t } + + let traverse gen change_in_expr = + let basic = gen.gcon.basic in + let rec run e = + match e.eexpr with + | TFor(var, in_expr, block) -> + let in_expr = change_in_expr (run in_expr) in + let temp = mk_temp gen "iterator" in_expr.etype in + let block = + [ + { eexpr = TVars([temp, Some(in_expr)]); etype = basic.tvoid; epos = in_expr.epos }; + { + eexpr = TWhile( + { eexpr = TCall(mk_access gen temp "hasNext" in_expr.epos, []); etype = basic.tbool; epos = in_expr.epos }, + Codegen.concat ({ + eexpr = TVars([var, Some({ eexpr = TCall(mk_access gen temp "next" in_expr.epos, []); etype = var.v_type; epos = in_expr.epos })]); + etype = basic.tvoid; + epos = in_expr.epos + }) ( run block ), + Ast.NormalWhile); + etype = basic.tvoid; + epos = e.epos + } + ] in + { eexpr = TBlock(block); etype = e.etype; epos = e.epos } + | _ -> Type.map_expr run e + in + run + + let configure gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map + + let configure_as_synf gen (mapping_func:texpr->texpr) = + let map e = Some(mapping_func e) in + gen.gexpr_filters#add ~name:name ~priority:(PCustom priority_as_synf) map + + end;; + + let configure gen change_in_expr = + IteratorsInterfaceExprf.configure gen (IteratorsInterfaceExprf.traverse gen change_in_expr) + + let configure_as_synf gen change_in_expr = + IteratorsInterfaceExprf.configure_as_synf gen (IteratorsInterfaceExprf.traverse gen change_in_expr) + +end;; + +(* ******************************************* *) +(* SwitchToIf *) +(* ******************************************* *) + +(* + + Just a syntax filter which changes switch expressions to if() else if() else if() ... + It can be also an expression filter + dependencies: + + +*) + +module SwitchToIf = +struct + + let name = "switch_to_if" + + let priority = solve_deps name [] + + let traverse gen (should_convert:texpr->bool) (handle_nullables:bool) = + let basic = gen.gcon.basic in + let rec run e = + match e.eexpr with + | TSwitch(cond,cases,default) when should_convert e -> + let cond_etype, should_cache = match handle_nullables, gen.gfollow#run_f cond.etype with + | true, TType({ t_path = ([], "Null") }, [t]) -> + let rec take_off_nullable t = match gen.gfollow#run_f t with + | TType({ t_path = ([], "Null") }, [t]) -> take_off_nullable t + | _ -> t + in + + take_off_nullable t, true + | _, _ -> cond.etype, false + in + + if should_cache && not (should_convert { e with eexpr = TSwitch({ cond with etype = cond_etype }, cases, default) }) then begin + { e with eexpr = TSwitch(mk_cast cond_etype (run cond), List.map (fun (cs,e) -> (List.map run cs, run e)) cases, Option.map run default) } + end else begin + let local, fst_block = match cond.eexpr, should_cache with + | TLocal _, false -> cond, [] + | _ -> + let var = mk_temp gen "switch" cond_etype in + let cond = run cond in + let cond = if should_cache then mk_cast cond_etype cond else cond in + + mk_local var cond.epos, [ { eexpr = TVars([var,Some(cond)]); etype = basic.tvoid; epos = cond.epos } ] + in + + let mk_eq cond = + { eexpr = TBinop(Ast.OpEq, local, cond); etype = basic.tbool; epos = cond.epos } + in + + let rec mk_many_cond conds = + match conds with + | cond :: [] -> + mk_eq cond + | cond :: tl -> + { eexpr = TBinop(Ast.OpBoolOr, mk_eq (run cond), mk_many_cond tl); etype = basic.tbool; epos = cond.epos } + | [] -> assert false + in + + let mk_many_cond conds = + let ret = mk_many_cond conds in + (* + this might be considered a hack. But since we're on a syntax filter and + the condition is guaranteed to not have run twice, we can really run the + expr filters again for it (so to change e.g. OpEq accordingly + *) + gen.gexpr_filters#run_f ret + in + + let rec loop cases = match cases with + | (conds,e) :: [] -> + { eexpr = TIf(mk_many_cond conds, run e, Option.map run default); etype = e.etype; epos = e.epos } + | (conds,e) :: tl -> + { eexpr = TIf(mk_many_cond conds, run e, Some(loop tl)); etype = e.etype; epos = e.epos } + | [] -> match default with + | None -> gen.gcon.error "Empty switch" e.epos; assert false + | Some d -> run d + in + + { e with eexpr = TBlock(fst_block @ [loop cases]) } + end + | _ -> 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;; + +(* ******************************************* *) +(* Anonymous Class object handling *) +(* ******************************************* *) + +(* + + (syntax) + When we pass a class as an object, in some languages we will need a special construct to be able to + access its statics as if they were normal object fields. On C# and Java the way found to do that is + by handling statics reflection also by a normal instance. This also happens in hxcpp and neko, so I + guess it's a valid practice. + So if we want to handle the reflection of the static MyClass, here's roughly how it will be done: + + var x = MyClass; + gets converted into + Haxe.Lang.Class x = Haxe.Lang.Runtime.GetType(typeof(MyClass).RuntimeHandle); + + which will in turn look in its cache but roughly would do: + Haxe.Lang.Class x = new Haxe.Lang.Class(new MyClass(EmptyObject.EMPTY)); + + This module will of course let the caller choose how this will be implemented. It will just identify all + uses of class that will require it to be cast as an object. + + dependencies: + +*) + +module ClassInstance = +struct + + let priority = solve_deps "class_instance" [] + + let traverse gen (change_expr:texpr->module_type->texpr) = + let rec run e = + match e.eexpr with + | TCall( ({ eexpr = TLocal(v) } as local), calls ) when String.get v.v_name 0 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name -> + { e with eexpr = TCall(local, List.map (fun e -> + match e.eexpr with + | TTypeExpr _ -> e + | _ -> run e) calls) } + | TField({ eexpr = TTypeExpr(mt) }, f) -> + e + | TField(ef, f) -> + (match anon_class ef.etype with + | None -> Type.map_expr run e + | Some t -> + { e with eexpr = TField( { ef with eexpr = TTypeExpr(t) }, f) } + ) + | TTypeExpr(mt) -> change_expr e mt + | _ -> 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:"class_instance" ~priority:(PCustom priority) map + +end;; + +(* ******************************************* *) +(* HardNullableSynf *) +(* ******************************************* *) + +(* + + This module will handle Null types for languages that offer a way of dealing with + stack-allocated structures or tuples and generics. Essentialy on those targets a Null + will be a tuple ( 'a * bool ), where bool is whether the value is null or not. + + At first (configure-time), we will modify the follow function so it can follow correctly nested Null>, + and do not follow Null to its underlying type + + Then we will run a syntax filter, which will look for casts to Null and replace them by + a call to the new Null creation; + Also casts from Null to T or direct uses of Null (call, field access, array access, closure) + will result in the actual value being accessed + For compatibility with the C# target, HardNullable will accept both Null and haxe.lang.Null types + + dependencies: + Needs to be run after all cast detection modules + + +*) + +module HardNullableSynf = +struct + + let name = "hard_nullable" + + let priority = solve_deps name [DAfter CastDetect.ReturnCast.priority] + + let rec is_null_t gen t = match gen.greal_type t with + | TType( { t_path = ([], "Null") }, [of_t]) + | TInst( { cl_path = (["haxe";"lang"], "Null") }, [of_t]) -> + let rec take_off_null t = + match is_null_t gen t with | None -> t | Some s -> take_off_null s + in + + Some (take_off_null of_t) + | TMono r -> (match !r with | Some t -> is_null_t gen t | None -> None) + | TLazy f -> is_null_t gen (!f()) + | TType (t, tl) -> + is_null_t gen (apply_params t.t_types tl t.t_type) + | _ -> None + + let follow_addon gen t = + let rec strip_off_nullable t = + let t = gen.gfollow#run_f t in + match t with + (* haxe.lang.Null> wouldn't be a valid construct, so only follow Null<> *) + | TType ( { t_path = ([], "Null") }, [of_t] ) -> strip_off_nullable of_t + | _ -> t + in + + match t with + | TType( ({ t_path = ([], "Null") } as tdef), [of_t]) -> + Some( TType(tdef, [ strip_off_nullable of_t ]) ) + | _ -> None + + let traverse gen unwrap_null wrap_val null_to_dynamic has_value opeq_handler handle_opeq handle_cast = + let handle_unwrap to_t e = + let e_null_t = get (is_null_t gen e.etype) in + match gen.greal_type to_t with + | TDynamic _ | TMono _ | TAnon _ -> + (match e_null_t with + | TDynamic _ | TMono _ | TAnon _ -> + gen.ghandle_cast to_t e_null_t (unwrap_null e) + | _ -> null_to_dynamic e + ) + | _ -> + gen.ghandle_cast to_t e_null_t (unwrap_null e) + in + + let handle_wrap e t = + match e.eexpr with + | TConst(TNull) -> + wrap_val e t false + | _ -> + wrap_val e t true + in + + let is_null_t = is_null_t gen in + let rec run e = + match e.eexpr with + | TCast(v, _) -> + let null_et = is_null_t e.etype in + let null_vt = is_null_t v.etype in + (match null_vt, null_et with + | Some(vt), None -> + (match v.eexpr with + (* is there an unnecessary cast to Nullable? *) + | TCast(v2, _) -> + run { v with etype = e.etype } + | _ -> + handle_unwrap e.etype (run v) + ) + | None, Some(et) -> + handle_wrap (run v) et + | Some(vt), Some(et) when handle_cast -> + handle_wrap (gen.ghandle_cast et vt (handle_unwrap vt (run v))) et + | _ -> + Type.map_expr run e + ) + | TField(ef, field) when is_some (is_null_t ef.etype) -> + let to_t = get (is_null_t ef.etype) in + { e with eexpr = TField(handle_unwrap to_t (run ef), field) } + | TCall(ecall, params) when is_some (is_null_t ecall.etype) -> + let to_t = get (is_null_t ecall.etype) in + { e with eexpr = TCall(handle_unwrap to_t (run ecall), List.map run params) } + | TArray(earray, p) when is_some (is_null_t earray.etype) -> + let to_t = get (is_null_t earray.etype) in + { e with eexpr = TArray(handle_unwrap to_t (run earray), p) } + | TBinop(op, e1, e2) -> + let e1_t = is_null_t e1.etype in + let e2_t = is_null_t e2.etype in + + (match op with + | Ast.OpAssign + | Ast.OpAssignOp _ -> + (match e1_t, e2_t with + | Some t1, Some t2 -> + (match op with + | Ast.OpAssign -> + { e with eexpr = TBinop( op, run e1, handle_wrap ( handle_unwrap t2 (run e2) ) t1 ) } + | Ast.OpAssignOp op -> + (match e1.eexpr with + | TLocal _ -> + { e with eexpr = TBinop( Ast.OpAssign, e1, handle_wrap { e with eexpr = TBinop (op, handle_unwrap t1 e1, handle_unwrap t2 (run e2) ) } t1 ) } + | _ -> + let v, e1, evars = match e1.eexpr with + | TField(ef, f) -> + let v = mk_temp gen "nullbinop" ef.etype in + v, { e1 with eexpr = TField(mk_local v ef.epos, f) }, ef + | _ -> + let v = mk_temp gen "nullbinop" e1.etype in + v, mk_local v e1.epos, e1 + in + { e with eexpr = TBlock([ + { eexpr = TVars([v, Some evars ]); etype = gen.gcon.basic.tvoid; epos = e.epos }; + { e with eexpr = TBinop( Ast.OpAssign, e1, handle_wrap { e with eexpr = TBinop (op, handle_unwrap t1 e1, handle_unwrap t2 (run e2) ) } t1 ) } + ]) } + ) + | _ -> assert false + ) + + | _ -> + Type.map_expr run e (* casts are already dealt with normal CastDetection module *) + ) + | Ast.OpEq | Ast.OpNotEq when not handle_opeq -> + Type.map_expr run e + | Ast.OpEq | Ast.OpNotEq -> + (match e1.eexpr, e2.eexpr with + | TConst(TNull), _ when is_some e2_t -> + let e = has_value e2 in + if op = Ast.OpEq then + { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) } + else + e + | _, TConst(TNull) when is_some e1_t -> + let e = has_value e1 in + if op = Ast.OpEq then + { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) } + else + e + | _ when is_some e1_t || is_some e2_t -> + let e1, e2 = + if not (is_some e1_t) then + run e2, handle_wrap (run e1) (get e2_t) + else if not (is_some e2_t) then + run e1, handle_wrap (run e2) (get e1_t) + else + run e1, run e2 + in + let e = opeq_handler e1 e2 in + if op = Ast.OpEq then + { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) } + else + e + | _ -> + Type.map_expr run e + ) + | _ -> + let e1 = if is_some e1_t then + handle_unwrap (get e1_t) (run e1) + else run e1 in + let e2 = if is_some e2_t then + handle_unwrap (get e2_t) (run e2) + else + run e2 in + + (* if it is Null, we need to convert the result again to null *) + let e_t = (is_null_t e.etype) in + if is_some e_t then + wrap_val { eexpr = TBinop(op, e1, e2); etype = get e_t; epos = e.epos } (get e_t) true + else + { e with eexpr = TBinop(op, e1, e2) } + ) + (*| TUnop( (Ast.Increment as op)*) + | _ -> Type.map_expr run e + in + run + + let configure gen (mapping_func:texpr->texpr) = + gen.gfollow#add ~name:(name ^ "_follow") (follow_addon gen); + + let map e = Some(mapping_func e) in + gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map + +end;; + +(* ******************************************* *) +(* ArrayDeclSynf *) +(* ******************************************* *) + +(* + + A syntax filter that will change array declarations to the actual native array declarations plus + the haxe array initialization + + dependencies: + Must run after ObjectDeclMap since it can add TArrayDecl expressions + +*) + +module ArrayDeclSynf = +struct + + let name = "array_decl_synf" + + let priority = solve_deps name [DAfter ObjectDeclMap.priority] + + let default_implementation gen native_array_cl = + let rec run e = + match e.eexpr with + | TArrayDecl el -> + let cl, params = match follow e.etype with + | TInst(({ cl_path = ([], "Array") } as cl), ( _ :: _ as params)) -> cl, params + | TInst(({ cl_path = ([], "Array") } as cl), []) -> cl, [t_dynamic] + | _ -> assert false + in + + let changed_params = gen.greal_type_param (TClassDecl cl) params in + { e with eexpr = TNew(cl, changed_params, [ { e with eexpr = TArrayDecl(List.map run el); etype = TInst(native_array_cl, changed_params) } ] ); } + | _ -> 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;; + +(* ******************************************* *) +(* SwitchBreakSynf *) +(* ******************************************* *) + +(* + + In most languages, 'break' is used as a statement also to break from switch statements. + This generates an incompatibility with haxe code, as we can use break to break from loops from inside a switch + + This script will detect 'breaks' inside switch statements, and will offer the opportunity to change both + when this pattern is found. + + Some options are possible: + On languages that support goto, 'break' may mean goto " after the loop ". There also can be special labels for + loops, so you can write "break label" (javascript, java, d) + On languages that do not support goto, a custom solution must be enforced + + dependencies: + Since UnreachableCodeElimination must run before it, and Unreachable should be one of the + very last filters to run, we will make a fixed value which runs after UnreachableCodeElimination + (meaning: it's the very last filter) + +*) + +module SwitchBreakSynf = +struct + + let name = "switch_break_synf" + + let priority = min_dep -. 150.0 + + type add_to_block_api = texpr->bool->unit + + let traverse gen (change_loop:texpr->int->add_to_block_api->texpr) (change_break:texpr->int->add_to_block_api->texpr) = + let in_switch = ref false in + let cur_block = ref [] in + let to_add = ref [] in + let did_found = ref (-1) in + + let api expr before = + if before then cur_block := expr :: !cur_block else to_add := expr :: !to_add + in + let num = ref 0 in + let cur_num = ref 0 in + + let rec run e = + match e.eexpr with + | TFunction _ -> + let old_num = !num in + num := 0; + let ret = Type.map_expr run e in + num := old_num; + ret + | TFor _ + | TWhile _ -> + let last_switch = !in_switch in + let last_found = !did_found in + let last_num = !cur_num in + in_switch := false; + incr num; + cur_num := !num; + did_found := -1; + let new_e = Type.map_expr run e in (* assuming that no loop will be found in the condition *) + let new_e = if !did_found <> -1 then change_loop new_e !did_found api else new_e in + did_found := last_found; + in_switch := last_switch; + cur_num := last_num; + + new_e + | TSwitch _ + | TMatch _ -> + let last_switch = !in_switch in + in_switch := true; + + let new_e = Type.map_expr run e in + + in_switch := last_switch; + new_e + | TBlock bl -> + let last_block = !cur_block in + let last_toadd = !to_add in + to_add := []; + cur_block := []; + + List.iter (fun e -> + let new_e = run e in + cur_block := new_e :: !cur_block; + match !to_add with + | [] -> () + | _ -> cur_block := !to_add @ !cur_block; to_add := [] + ) bl; + + let ret = List.rev !cur_block in + cur_block := last_block; + to_add := last_toadd; + + { e with eexpr = TBlock(ret) } + | TBreak -> + if !in_switch then (did_found := !cur_num; change_break e !cur_num api) else e + | _ -> 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;; + +(* ******************************************* *) +(* Unreachable Code Elimination *) +(* ******************************************* *) + +(* + + In some source code platforms, the code won't compile if there is Unreachable code, so this filter will take off any unreachable code. + If the parameter "handle_switch_break" is set to true, it will already add a "break" statement on switch cases when suitable; + in order to not confuse with while break, it will be a special expression __sbreak__ + If the parameter "handle_not_final_returns" is set to true, it will also add final returns when functions are detected to be lacking of them. + (Will respect __fallback__ expressions) + If the parameter "java_mode" is set to true, some additional checks following the java unreachable specs + (http://docs.oracle.com/javase/specs/jls/se7/html/jls-14.html#jls-14.21) will be added + + dependencies: + This must run before SwitchBreakSynf (see SwitchBreakSynf dependecy value) + This must be the LAST syntax filter to run. It expects ExpressionUnwrap to have run correctly, since this will only work for source-code based targets + +*) + +module UnreachableCodeEliminationSynf = +struct + + let name = "unreachable_synf" + + let priority = min_dep -. 100.0 + + type uexpr_kind = + | Normal + | BreaksLoop + | BreaksFunction + + let aggregate_kind e1 e2 = + match e1, e2 with + | Normal, _ + | _, Normal -> Normal + | BreaksLoop, _ + | _, BreaksLoop -> BreaksLoop + | BreaksFunction, BreaksFunction -> BreaksFunction + + let aggregate_constant op c1 c2= + match op, c1, c2 with + | OpEq, Some v1, Some v2 -> Some (TBool (v1 = v2)) + | OpNotEq, Some v1, Some v2 -> Some (TBool (v1 <> v2)) + | OpBoolOr, Some (TBool v1) , Some (TBool v2) -> Some (TBool (v1 || v2)) + | OpBoolAnd, Some (TBool v1) , Some (TBool v2) -> Some (TBool (v1 && v2)) + | OpAssign, _, Some v2 -> Some v2 + | _ -> None + + let rec get_constant_expr e = + match e.eexpr with + | TConst (v) -> Some v + | TBinop(op, v1, v2) -> aggregate_constant op (get_constant_expr v1) (get_constant_expr v2) + | TParenthesis(e) -> get_constant_expr e + | _ -> None + + let traverse gen should_warn handle_switch_break handle_not_final_returns java_mode = + let basic = gen.gcon.basic in + + let do_warn = + if should_warn then gen.gcon.warning "Unreachable code" else (fun pos -> ()) + in + + let return_loop expr kind = + match kind with + | Normal | BreaksLoop -> expr, Normal + | _ -> expr, kind + in + + let sbreak = alloc_var "__sbreak__" t_dynamic in + let mk_sbreak = mk_local sbreak in + + let rec has_fallback expr = match expr.eexpr with + | TBlock(bl) -> (match List.rev bl with + | { eexpr = TLocal { v_name = "__fallback__" } } :: _ -> true + | ({ eexpr = TBlock(_) } as bl) :: _ -> has_fallback bl + | _ -> false) + | TLocal { v_name = "__fallback__" } -> true + | _ -> false + in + + let handle_case = if handle_switch_break then + (fun (expr,kind) -> + match kind with + | Normal when has_fallback expr -> expr + | Normal -> Codegen.concat expr (mk_sbreak expr.epos) + | BreaksLoop | BreaksFunction -> expr + ) + else + fst + in + + let has_break = ref false in + + let rec process_expr expr = + match expr.eexpr with + | TReturn _ | TThrow _ -> expr, BreaksFunction + | TContinue -> expr, BreaksLoop + | TBreak -> has_break := true; expr, BreaksLoop + | TCall( { eexpr = TLocal { v_name = "__goto__" } }, _ ) -> expr, BreaksLoop + + | TBlock bl -> + let new_block = ref [] in + let is_unreachable = ref false in + let ret_kind = ref Normal in + + List.iter (fun e -> + if !is_unreachable then + do_warn e.epos + else begin + let changed_e, kind = process_expr e in + new_block := changed_e :: !new_block; + match kind with + | BreaksLoop | BreaksFunction -> + ret_kind := kind; + is_unreachable := true + | _ -> () + end + ) bl; + + { expr with eexpr = TBlock(List.rev !new_block) }, !ret_kind + | TFunction tf -> + let changed, kind = process_expr tf.tf_expr in + let changed = if handle_not_final_returns && not (is_void tf.tf_type) && kind <> BreaksFunction then + Codegen.concat changed { eexpr = TReturn( Some (null tf.tf_type expr.epos) ); etype = basic.tvoid; epos = expr.epos } + else + changed + in + + { expr with eexpr = TFunction({ tf with tf_expr = changed }) }, Normal + | TFor(var, cond, block) -> + let last_has_break = !has_break in + has_break := false; + + let changed_block, _ = process_expr block in + has_break := last_has_break; + let expr = { expr with eexpr = TFor(var, cond, changed_block) } in + return_loop expr Normal + | TIf(cond, eif, None) -> + if java_mode then + match get_constant_expr cond with + | Some (TBool true) -> + process_expr eif + | _ -> + { expr with eexpr = TIf(cond, fst (process_expr eif), None) }, Normal + else + { expr with eexpr = TIf(cond, fst (process_expr eif), None) }, Normal + | TIf(cond, eif, Some eelse) -> + let eif, eif_k = process_expr eif in + let eelse, eelse_k = process_expr eelse in + let k = aggregate_kind eif_k eelse_k in + { expr with eexpr = TIf(cond, eif, Some eelse) }, k + | TWhile(cond, block, flag) -> + let last_has_break = !has_break in + has_break := false; + + let block, k = process_expr block in + if java_mode then + match get_constant_expr cond, !has_break with + | Some (TBool true), false -> + has_break := last_has_break; + { expr with eexpr = TWhile(cond, block, flag) }, BreaksFunction + | Some (TBool false), _ -> + has_break := last_has_break; + do_warn expr.epos; + null expr.etype expr.epos, Normal + | _ -> + has_break := last_has_break; + return_loop { expr with eexpr = TWhile(cond,block,flag) } Normal + else begin + has_break := last_has_break; + return_loop { expr with eexpr = TWhile(cond,block,flag) } Normal + end + | TSwitch(cond, el_e_l, None) -> + { expr with eexpr = TSwitch(cond, List.map (fun (el, e) -> (el, handle_case (process_expr e))) el_e_l, None) }, Normal + | TSwitch(cond, el_e_l, Some def) -> + let def, k = process_expr def in + let def = handle_case (def, k) in + let k = ref k in + let ret = { expr with eexpr = TSwitch(cond, List.map (fun (el, e) -> + let e, ek = process_expr e in + k := aggregate_kind !k ek; + (el, handle_case (e, ek)) + ) el_e_l, Some def) } in + ret, !k + | TMatch(cond, ep, il_vopt_e_l, None) -> + { expr with eexpr = TMatch(cond, ep, List.map (fun (il, vopt, e) -> (il, vopt, handle_case (process_expr e))) il_vopt_e_l, None) }, Normal + | TMatch(cond, ep, il_vopt_e_l, Some def) -> + let def, k = process_expr def in + let def = handle_case (def, k) in + let k = ref k in + let ret = { expr with eexpr = TMatch(cond, ep, List.map (fun (il, vopt, e) -> + let e, ek = process_expr e in + k := aggregate_kind !k ek; + (il, vopt, handle_case (e, ek)) + ) il_vopt_e_l, Some def) } in + ret, !k + | TTry (e, catches) -> + let e, k = process_expr e in + let k = ref k in + let ret = { expr with eexpr = TTry(e, List.map (fun (v, e) -> + let e, ek = process_expr e in + k := aggregate_kind !k ek; + (v, e) + ) catches) } in + ret, !k + | _ -> expr, Normal + in + + let run e = fst (process_expr 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;; + +(* ******************************************* *) +(* DefaultArguments *) +(* ******************************************* *) + +(* + + This Module Filter will go through all defined functions in all modules and change them + so they set all default arguments to be of a Nullable type, and adds the unroll from nullable to + the not-nullable type in the beginning of the function. + + dependencies: + It must run before OverloadingCtors, since OverloadingCtors will change optional structures behavior + +*) + +module DefaultArguments = +struct + + let name = "default_arguments" + + let priority = solve_deps name [ DBefore OverloadingConstructor.priority ] + + let add_opt gen block pos (var,opt) = + match opt with + | None | Some TNull -> (var,opt) + | Some (TString str) -> + block := Codegen.set_default gen.gcon var (TString str) pos :: !block; + (var, opt) + | Some const -> + let basic = gen.gcon.basic in + let nullable_var = mk_temp gen var.v_name (basic.tnull var.v_type) in + let orig_name = var.v_name in + var.v_name <- nullable_var.v_name; + nullable_var.v_name <- orig_name; + let const_t = match const with + | TString _ -> basic.tstring | TInt _ -> basic.tint | TFloat _ -> basic.tfloat + | TNull -> var.v_type | TBool _ -> basic.tbool | _ -> assert false + in + (* var v = (temp_var == null) ? const : cast temp_var; *) + block := + { + eexpr = TVars([var, Some( + { + eexpr = TIf( + { eexpr = TBinop(Ast.OpEq, mk_local nullable_var pos, null nullable_var.v_type pos); etype = basic.tbool; epos = pos }, + mk_cast var.v_type { eexpr = TConst(const); etype = const_t; epos = pos }, + Some(mk_cast var.v_type (mk_local nullable_var pos)) + ); + etype = var.v_type; + epos = pos; + })]); + etype = basic.tvoid; + epos = pos; + } :: !block; + (nullable_var, opt) + + let change_func gen cf = + let basic = gen.gcon.basic in + match cf.cf_kind, follow cf.cf_type with + | Var _, _ | Method MethDynamic, _ -> () + | _, TFun(args, ret) -> + let found = ref false in + let args = ref (List.map (fun (n,opt,t) -> + (n,opt, if opt then (found := true; basic.tnull t) else t) + ) args) in + (match !found, cf.cf_expr with + | true, Some ({ eexpr = TFunction tf } as texpr) -> + let block = ref [] in + let tf_args = List.map (add_opt gen block tf.tf_expr.epos) tf.tf_args in + + args := fun_args tf_args; + cf.cf_expr <- Some( {texpr with eexpr = TFunction( { tf with + tf_args = tf_args; + tf_expr = Codegen.concat { tf.tf_expr with eexpr = TBlock(!block); etype = basic.tvoid } tf.tf_expr + } ); etype = TFun(!args, ret) } ); + cf.cf_type <- TFun(!args, ret) + + | _ -> () + ); + (if !found then cf.cf_type <- TFun(!args, ret)) + | _, _ -> assert false + + let traverse gen = + let run md = match md with + | TClassDecl cl -> + List.iter (change_func gen) cl.cl_ordered_fields; + List.iter (change_func gen) cl.cl_ordered_statics; + (match cl.cl_constructor with | None -> () | Some cf -> change_func gen cf); + md + | _ -> md + in + run + + let configure gen (mapping_func:module_type->module_type) = + let map md = Some(mapping_func md) in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map + +end;; + +(* ******************************************* *) +(* Interface Variables Removal Modf *) +(* ******************************************* *) + +(* + + This module filter will take care of sanitizing interfaces for targets that do not support + variables declaration in interfaces. By now this will mean that if anything is typed as the interface, + and a variable access is made, a FNotFound will be returned for the field_access, so + the field will be only accessible by reflection. + Speed-wise, ideally it would be best to create getProp/setProp functions in this case and change + the AST to call them when accessing by interface. (TODO) + But right now it will be accessed by reflection. + + dependencies: + + +*) + +module InterfaceVarsDeleteModf = +struct + + let name = "interface_vars" + + let priority = solve_deps name [] + + let run gen = + let run md = match md with + | TClassDecl ( { cl_interface = true } as cl ) -> + let to_add = ref [] in + let fields = List.filter (fun cf -> + match cf.cf_kind with + | Var vkind -> + (match vkind.v_read with + | AccCall -> + let newcf = mk_class_field ("get_" ^ cf.cf_name) (TFun([],cf.cf_type)) true cf.cf_pos (Method MethNormal) [] in + to_add := newcf :: !to_add; + | _ -> () + ); + (match vkind.v_write with + | AccCall -> + let newcf = mk_class_field ("set_" ^ cf.cf_name) (TFun(["val",false,cf.cf_type],cf.cf_type)) true cf.cf_pos (Method MethNormal) [] in + to_add := newcf :: !to_add; + | _ -> () + ); + cl.cl_fields <- PMap.remove cf.cf_name cl.cl_fields; + false + | _ -> true + ) cl.cl_ordered_fields in + + cl.cl_ordered_fields <- fields; + + List.iter (fun cf -> + if not (PMap.mem cf.cf_name cl.cl_fields) then begin + cl.cl_ordered_fields <- cf :: cl.cl_ordered_fields; + cl.cl_fields <- PMap.add cf.cf_name cf cl.cl_fields + end + ) !to_add; + + md + | _ -> md + in + run + + let configure gen = + let run = run gen in + let map md = Some(run md) in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map + + +end;; + +(* ******************************************* *) +(* Int Division Synf *) +(* ******************************************* *) + +(* + + On targets that support int division, this module will force a float division to be performed, + so compatibility with current haxe targets is ensured. + If catch_int_div is set to true, though, it will look for casts to int or use of Std.int() to optimize + this kind of operation. + + dependencies: + since it depends on nothing, but many modules might generate division expressions, + it will be one of the last modules to run + +*) + +module IntDivisionSynf = +struct + + let name = "int_division_synf" + + let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority ] + + let is_int = like_int + + let default_implementation gen catch_int_div = + let basic = gen.gcon.basic in + let rec run e = + match e.eexpr with + | TBinop((Ast.OpDiv as op), e1, e2) when is_int e1.etype && is_int e2.etype -> + { e with eexpr = TBinop(op, mk_cast basic.tfloat (run e1), run e2) } + | TCall( + { eexpr = TField(_, FStatic({ cl_path = ([], "Std") }, { cf_name = "int" })) }, + [ ({ eexpr = TBinop((Ast.OpDiv as op), e1, e2) } as ebinop ) ] + ) when catch_int_div && is_int e1.etype && is_int e2.etype -> + { ebinop with eexpr = TBinop(op, run e1, run e2); etype = basic.tint } + | TCast( ({ eexpr = TBinop((Ast.OpDiv as op), e1, e2) } as ebinop ), _ ) + | TCast( ({ eexpr = TBinop(( (Ast.OpAssignOp Ast.OpDiv) as op), e1, e2) } as ebinop ), _ ) when catch_int_div && is_int e1.etype && is_int e2.etype && is_int e.etype -> + { ebinop with eexpr = TBinop(op, run e1, run e2); etype = basic.tint } + | _ -> 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;; + +(* ******************************************* *) +(* UnnecessaryCastsRemoval *) +(* ******************************************* *) + +(* + + This module will take care of simplifying unnecessary casts, specially those made by the compiler + when inlining. Right now, it will only take care of casts used as a statement, which are always useless; + TODO: Take care of more cases, e.g. when the to and from types are the same + + dependencies: + This must run after CastDetection, but before ExpressionUnwrap + +*) + +module UnnecessaryCastsRemoval = +struct + + let name = "casts_removal" + + let priority = solve_deps name [DAfter CastDetect.priority; DBefore ExpressionUnwrap.priority] + + let rec take_off_cast run e = + match e.eexpr with + | TCast (c, _) -> + take_off_cast run c + | _ -> run e + + let default_implementation gen = + let rec traverse e = + match e.eexpr with + | TBlock bl -> + let bl = List.map (fun e -> + take_off_cast traverse e + ) bl in + { e with eexpr = TBlock bl } + | TTry (block, catches) -> + { e with eexpr = TTry(traverse (mk_block block), List.map (fun (v,block) -> (v, traverse (mk_block block))) catches) } + | TMatch (cond,ep,il_vol_e_l,default) -> + { e with eexpr = TMatch(cond,ep,List.map (fun (il,vol,e) -> (il,vol,traverse (mk_block e))) il_vol_e_l, Option.map (fun e -> traverse (mk_block e)) default) } + | TSwitch (cond,el_e_l, default) -> + { e with eexpr = TSwitch(cond, List.map (fun (el,e) -> (el, traverse (mk_block e))) el_e_l, Option.map (fun e -> traverse (mk_block e)) default) } + | TWhile (cond,block,flag) -> + {e with eexpr = TWhile(cond,traverse (mk_block block), flag) } + | TIf (cond, eif, eelse) -> + { e with eexpr = TIf(cond, traverse (mk_block eif), Option.map (fun e -> traverse (mk_block e)) eelse) } + | TFor (v,it,block) -> + { e with eexpr = TFor(v,it, traverse (mk_block block)) } + | TFunction (tfunc) -> + { e with eexpr = TFunction({ tfunc with tf_expr = traverse (mk_block tfunc.tf_expr) }) } + | _ -> e (* if expression doesn't have a block, we will exit *) + in + traverse + + let configure gen = + let map e = Some(default_implementation gen e) in + gen.gsyntax_filters#add ~name:name ~priority:(PCustom priority) map + +end;; + +(* ******************************************* *) +(* OverrideFix *) +(* ******************************************* *) + +(* + + When DCE is on, sometimes a field is marked as override when it + really doesn't override anything. This module filter will take care of this. + + dependencies: + No dependencies + +*) + +module OverrideFix = +struct + + let name = "override_fix" + + let priority = solve_deps name [] + + let default_implementation gen = + let rec run e = + match e.eexpr with + | _ -> Type.map_expr run e + in + run + + let configure gen = + let map md = + match md with + | TClassDecl cl -> + cl.cl_overrides <- List.filter (fun s -> + let rec loop cl = + match cl.cl_super with + | Some (cl,_) when PMap.mem s.cf_name cl.cl_fields -> true + | Some (cl,_) -> loop cl + | None -> false + in + loop cl + ) cl.cl_overrides; + Some md + | _ -> Some md + in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map + +end;; + +(* ******************************************* *) +(* AbstractImplementationFix *) +(* ******************************************* *) + +(* + + This module filter will map the compiler created classes from abstract + implementations to valid haxe code, as needed by gencommon + + dependencies: + No dependencies + +*) + +module AbstractImplementationFix = +struct + + let name = "abstract_implementation_fix" + + let priority = solve_deps name [] + + let default_implementation gen = + let rec run md = + match md with + | TClassDecl ({ cl_kind = KAbstractImpl a } as c) -> + List.iter (function + | cf when Meta.has Meta.Impl cf.cf_meta -> + (* add type parameters to all implementation functions *) + cf.cf_params <- cf.cf_params @ a.a_types + | _ -> () + ) c.cl_ordered_statics; + Some md + | _ -> Some md + in + run + + let configure gen = + let map = default_implementation gen in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map + +end;; + +(* ******************************************* *) +(* FixOverrides *) +(* ******************************************* *) + +(* + + Covariant return types, contravariant function arguments and applied type parameters may change + in a way that expected implementations / overrides aren't recognized as such. + This filter will fix that. + + dependencies: + FixOverrides expects that the target platform is able to deal with overloaded functions + It must run after DefaultArguments, otherwise code added by the default arguments may be invalid + +*) + +module FixOverrides = +struct + + let name = "fix_overrides" + + let priority = solve_deps name [DAfter DefaultArguments.priority] + + (* + if the platform allows explicit interface implementation (C#), + specify a explicit_fn_name function (tclass->string->string) + Otherwise, it expects the platform to be able to handle covariant return types + *) + let run ~explicit_fn_name gen = + let implement_explicitly = is_some explicit_fn_name in + let run md = match md with + | TClassDecl ( { cl_interface = true; cl_extern = false } as c ) -> + (* overrides can be removed from interfaces *) + c.cl_ordered_fields <- List.filter (fun f -> + try + if Meta.has Meta.Overload f.cf_meta then raise Not_found; + let f2 = Codegen.find_field c f in + if f2 == 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; + md + | TClassDecl({ cl_extern = false } as c) -> + let this = { eexpr = TConst TThis; etype = TInst(c,List.map snd c.cl_types); epos = c.cl_pos } in + (* look through all interfaces, and try to find a type that applies exactly *) + let rec loop_iface (iface:tclass) itl = + List.iter (fun (s,stl) -> loop_iface s (List.map (apply_params iface.cl_types itl) stl)) iface.cl_implements; + let real_itl = gen.greal_type_param (TClassDecl iface) itl in + let rec loop_f f = + List.iter loop_f f.cf_overloads; + let ftype = apply_params iface.cl_types itl f.cf_type in + let real_ftype = get_real_fun gen (apply_params iface.cl_types real_itl f.cf_type) in + replace_mono real_ftype; + let overloads = Typeload.get_overloads c f.cf_name in + try + let t2, f2 = + match overloads with + | (_, cf) :: _ when Meta.has Meta.Overload cf.cf_meta -> (* overloaded function *) + (* try to find exact function *) + List.find (fun (t,f2) -> + Typeload.same_overload_args ftype t f f2 + ) overloads + | _ :: _ -> + (match field_access gen (TInst(c, List.map snd c.cl_types)) f.cf_name with + | FClassField(_,_,_,f2,false,t,_) -> t,f2 (* if it's not an overload, all functions should have the same signature *) + | _ -> raise Not_found) + | [] -> raise Not_found + in + replace_mono t2; + (* if we find a function with the exact type of real_ftype, it means this interface has already been taken care of *) + if not (type_iseq (get_real_fun gen (apply_params f2.cf_params (List.map snd f.cf_params) t2)) real_ftype) then begin + (match f.cf_kind with | Method (MethNormal | MethInline) -> () | _ -> raise Not_found); + let t2 = get_real_fun gen t2 in + if List.length f.cf_params <> List.length f2.cf_params then raise Not_found; + replace_mono t2; + match follow (apply_params f2.cf_params (List.map snd f.cf_params) t2), follow real_ftype with + | TFun(a1,r1), TFun(a2,r2) when not implement_explicitly && not (type_iseq r1 r2) && Typeload.same_overload_args real_ftype t2 f f2 -> + (* different return types are the trickiest cases to deal with *) + (* check for covariant return type *) + let is_covariant = match follow r1, follow r2 with + | _, TDynamic _ -> true + | r1, r2 -> try + unify r1 r2; + true + with | Unify_error _ -> false + in + (* we only have to worry about non-covariant issues *) + if not is_covariant then begin + (* override return type and cast implemented function *) + let args, newr = match follow t2, follow (apply_params f.cf_params (List.map snd f2.cf_params) real_ftype) with + | TFun(a,_), TFun(_,r) -> a,r + | _ -> assert false + in + f2.cf_type <- TFun(args,newr); + (match f2.cf_expr with + | Some ({ eexpr = TFunction tf } as e) -> + f2.cf_expr <- Some { e with eexpr = TFunction { tf with tf_type = newr } } + | _ -> ()) + end + | TFun(a1,r1), TFun(a2,r2) -> + (* just implement a function that will call the main one *) + let name, is_explicit = match explicit_fn_name with + | Some fn when not (type_iseq r1 r2) && Typeload.same_overload_args real_ftype t2 f f2 -> + fn iface itl f.cf_name, true + | _ -> f.cf_name, false + in + let p = f2.cf_pos in + let newf = mk_class_field name real_ftype true f.cf_pos (Method MethNormal) f.cf_params in + let vars = List.map (fun (n,_,t) -> alloc_var n t) a2 in + + let args = List.map2 (fun v (_,_,t) -> mk_cast t (mk_local v f2.cf_pos)) vars a1 in + let field = { eexpr = TField(this, FInstance(c,f2)); etype = TFun(a1,r1); epos = p } in + let call = { eexpr = TCall(field, args); etype = r1; epos = p } in + (* let call = gen.gparam_func_call call field (List.map snd f.cf_params) args in *) + let is_void = is_void r2 in + + newf.cf_expr <- Some { + eexpr = TFunction({ + tf_args = List.map (fun v -> v,None) vars; + tf_type = r2; + tf_expr = (if is_void then call else { + eexpr = TReturn (Some (mk_cast r2 call)); + etype = r2; + epos = p + }) + }); + etype = real_ftype; + epos = p; + }; + (* delayed: add to class *) + let delay () = + try + let fm = PMap.find f.cf_name c.cl_fields in + fm.cf_overloads <- newf :: fm.cf_overloads + with | Not_found -> + c.cl_fields <- PMap.add f.cf_name newf c.cl_fields; + c.cl_ordered_fields <- newf :: c.cl_ordered_fields + in + (* gen.gafter_filters_ended <- delay :: gen.gafter_filters_ended *) + delay(); + | _ -> assert false + end + with | Not_found -> () + in + List.iter loop_f iface.cl_ordered_fields + in + List.iter (fun (iface,itl) -> loop_iface iface itl) c.cl_implements; + (* now go through all overrides, *) + let rec check_f f = + (* find the first declared field *) + let is_overload = Meta.has Meta.Overload f.cf_meta in + let decl = if is_overload then + find_first_declared_field gen c ~exact_field:f f.cf_name + else + find_first_declared_field gen c f.cf_name + in + match decl with + | Some(f2,actual_t,_,t,declared_cl,_,_) + when not (Typeload.same_overload_args actual_t (get_real_fun gen f.cf_type) f2 f) -> + if Meta.has Meta.Overload f.cf_meta then begin + (* if it is overload, create another field with the requested type *) + let f3 = mk_class_field f.cf_name t f.cf_public f.cf_pos f.cf_kind f.cf_params in + let p = f.cf_pos in + let old_args, old_ret = get_fun f.cf_type in + let args, ret = get_fun t in + let tf_args = List.map (fun (n,o,t) -> alloc_var n t, None) args in + f3.cf_expr <- Some { + eexpr = TFunction({ + tf_args = tf_args; + tf_type = ret; + tf_expr = mk_block (mk_return (mk_cast ret { + eexpr = TCall( + { + eexpr = TField( + { eexpr = TConst TThis; etype = TInst(c, List.map snd c.cl_types); epos = p }, + FInstance(c,f)); + etype = f.cf_type; + epos = p + }, + List.map2 (fun (v,_) (_,_,t) -> mk_cast t (mk_local v p)) tf_args old_args); + etype = old_ret; + epos = p + })) + }); + etype = t; + epos = p; + }; + gen.gafter_filters_ended <- ((fun () -> + f.cf_overloads <- f3 :: f.cf_overloads; + ) :: gen.gafter_filters_ended); + f3 + end else begin match f.cf_expr with + | Some({ eexpr = TFunction(tf) } as e) -> + (* if it's not overload, just cast the vars *) + let actual_args, _ = get_fun (get_real_fun gen actual_t) in + let new_args, vardecl = List.fold_left2 (fun (args,vdecl) (v,_) (_,_,t) -> + if not (type_iseq (gen.greal_type v.v_type) (gen.greal_type t)) then begin + let new_var = mk_temp gen v.v_name t in + (new_var,None) :: args, (v, Some(mk_cast v.v_type (mk_local new_var f.cf_pos))) :: vdecl + end else + (v,None) :: args, vdecl + ) ([],[]) tf.tf_args actual_args in + if vardecl <> [] then + f.cf_expr <- Some({ e with + eexpr = TFunction({ tf with + tf_args = List.rev new_args; + tf_expr = Codegen.concat { eexpr = TVars(vardecl); etype = gen.gcon.basic.tvoid; epos = e.epos } tf.tf_expr + }); + }); + f + | _ -> f + end + | _ -> f + in + if not c.cl_extern then + c.cl_overrides <- List.map (fun f -> check_f f) c.cl_overrides; + md + | _ -> md + in + run + + let configure ?explicit_fn_name gen = + let delay () = + Hashtbl.clear gen.greal_field_types + in + gen.gafter_mod_filters_ended <- delay :: gen.gafter_mod_filters_ended; + let run = run ~explicit_fn_name:explicit_fn_name gen in + let map md = Some(run md) in + gen.gmodule_filters#add ~name:name ~priority:(PCustom priority) map +end;; + +(* ******************************************* *) +(* NormalizeType *) +(* ******************************************* *) + +(* + + - Filters out enum constructor type parameters from the AST; See Issue #1796 + - Filters out monomorphs + + dependencies: + No dependencies; but it still should be one of the first filters to run, + as it will help normalize the AST + +*) + +module NormalizeType = +struct + + let name = "normalize_type" + + let priority = max_dep + + let rec filter_param t = match t with + | TInst({ cl_kind = KTypeParameter _ } as c,_) when Meta.has Meta.EnumConstructorParam c.cl_meta -> + t_dynamic + | TMono r -> (match !r with + | None -> t_dynamic + | Some t -> filter_param t) + | TInst(_,[]) | TEnum(_,[]) | TType(_,[]) | TAbstract(_,[]) -> t + | TType(t,tl) -> TType(t,List.map filter_param tl) + | TInst(c,tl) -> TInst(c,List.map filter_param tl) + | TEnum(e,tl) -> TEnum(e,List.map filter_param tl) + | TAbstract(a,tl) -> TAbstract(a, List.map filter_param tl) + | TAnon a -> + TAnon { + a_fields = PMap.map (fun f -> { f with cf_type = filter_param f.cf_type }) a.a_fields; + a_status = a.a_status; + } + | TFun(args,ret) -> TFun(List.map (fun (n,o,t) -> (n,o,filter_param t)) args, filter_param ret) + | TDynamic _ -> t + | TLazy f -> filter_param (!f()) + + let default_implementation gen = + let rec run e = + map_expr_type (fun e -> run e) filter_param (fun v -> v.v_type <- filter_param v.v_type; v) e + in + run + + let configure gen = + let map e = Some(default_implementation gen e) in + gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map + +end;; + +(* +(* ******************************************* *) +(* Example *) +(* ******************************************* *) + +(* + + description + + dependencies: + + +*) + +module Example = +struct + + let name = "example" + + let priority = solve_deps name [] + + let default_implementation gen = + let rec run e = + match e.eexpr with + | _ -> 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;; +*) diff --git a/haxe/gencpp.ml b/gencpp.ml similarity index 57% rename from haxe/gencpp.ml rename to gencpp.ml index 5232cca50c55ce90683bfd409b65d69565651dd5..366c0e370cdfae54b77728b520735d5fed045976 100644 --- a/haxe/gencpp.ml +++ b/gencpp.ml @@ -1,26 +1,30 @@ (* - * haXe/CPP Compiler - * Copyright (c)2008 Hugh Sanderson - * based on and including code by (c)2005-2008 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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. @@ -113,7 +117,7 @@ let rec make_class_directories base dir_list = ( ((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 + make_class_directories (if (path="") then "/" else path) remaining );; @@ -143,25 +147,29 @@ type context = 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_do_safe_point : bool; mutable ctx_real_this_ptr : bool; mutable ctx_dynamic_this_ptr : bool; - mutable ctx_push_src_pos : string; + 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 = +let new_context common_ctx writer debug file_info = { ctx_common = common_ctx; ctx_writer = writer; @@ -171,10 +179,11 @@ let new_context common_ctx writer debug = ctx_assigning = false; ctx_debug = debug; ctx_debug_type = debug; - ctx_push_src_pos = ""; + 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_do_safe_point = false; ctx_real_this_ptr = true; ctx_dynamic_this_ptr = false; ctx_static_id_curr = 0; @@ -182,11 +191,20 @@ let new_context common_ctx writer debug = 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 *) @@ -201,12 +219,27 @@ let is_internal_class = function (* 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 is_internal_header = function - | ([],"@Main") -> true - | (["cpp"], "CppInt32__") | ([],"Math") -> false - | path -> is_internal_class path +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 ;; @@ -236,27 +269,51 @@ let hash_iterate hash visitor = let keyword_remap name = match name with | "int" - | "auto" | "char" | "const" | "delete" | "double" | "enum" + | "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" + | "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" + | "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" + | "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 +;; -(* - While #include "Math.h" sould be different from "#include ", and it may be possible - to use include paths to get this right, I think it is easier just to chnage the name *) -let include_remap = function | ([],"Math") -> ([],"hxMath") | x -> x;; +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 (include_remap class_path);; + writer#add_include class_path;; (* This gets the class include order correct. In the header files, we forward declare @@ -269,8 +326,9 @@ let gen_forward_decl writer class_path = writer#add_include class_path else begin let output = writer#write in - output ("HX_DECLARE_CLASS" ^ (string_of_int (List.length (fst class_path) ) ) ^ "("); - List.iter (fun package_part -> output (package_part ^ ",") ) (fst class_path); + 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;; @@ -281,6 +339,19 @@ List.filter (function (t,pl) -> | _ -> 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) -> @@ -296,7 +367,7 @@ let has_field_integer_numeric_lookup class_def = (* Output required code to place contents in required namespace *) let gen_open_namespace output class_path = - List.iter (fun namespace -> output ("namespace " ^ namespace ^ "{\n")) (fst 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 @@ -304,57 +375,67 @@ let gen_close_namespace output class_path = (fst class_path);; (* The basic types can have default values and are passesby value *) -let cant_be_null = function - | "Int" | "Bool" | "Float" | "::String" | "::haxe::io::Unsigned_char__" -> true - | "int" | "bool" | "double" -> true +let is_numeric = function + | "Int" | "Bool" | "Float" | "::haxe::io::Unsigned_char__" | "unsigned char" -> true + | "int" | "bool" | "double" | "float" -> true | _ -> false -let is_type_param haxe_type = - (match follow haxe_type with - | TInst (klass,params) -> - (match klass.cl_path with - | ([],"Array") | ([],"Class") | (["cpp"],"FastIterator") -> false - | _ -> klass.cl_kind = KTypeParameter - ) - | _ -> 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_type_param (List.hd params) -> "Dynamic" + | ([],"Array") when is_dynamic_array_param (List.hd params) -> "Dynamic" | ([],"Array") -> (snd klass.cl_path) ^ suffix ^ "< " ^ (String.concat "," - (List.map type_string params) ) ^ " >" + (List.map array_element_type params) ) ^ " >" (* FastIterator class *) | (["cpp"],"FastIterator") -> "::cpp::FastIterator" ^ suffix ^ "< " ^ (String.concat "," (List.map type_string params) ) ^ " >" - | _ when klass.cl_kind=KTypeParameter -> "Dynamic" + | _ 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); + | _ -> assert false); (* Normal class *) - | _ -> "::" ^ (join_class_path klass.cl_path "::") ^ suffix + | 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") },[]) -> "double" + | TInst ({ cl_path = ([],"Float") },[]) -> "Float" | TInst ({ cl_path = ([],"Int") },[]) -> "int" - | TEnum (enum,params) -> "::" ^ (join_class_path enum.e_path "::") ^ suffix + | 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 @@ -362,6 +443,9 @@ and type_string_suff suffix haxe_type = (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 @@ -369,6 +453,7 @@ and type_string_suff suffix haxe_type = | _ -> assert false); | [] , "Array" -> (match params with + | [t] when (type_string (follow t)) = "Dynamic" -> "Dynamic" | [t] -> "Array< " ^ (type_string (follow t) ) ^ " >" | _ -> assert false) | ["cpp"] , "FastIterator" -> @@ -387,23 +472,65 @@ and type_string_suff suffix haxe_type = *) | 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 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) -> + | TInst (klass,params) -> (match klass.cl_path with - | [] , "Array" -> not (is_type_param (List.hd params)) + | [] , "Array" -> not (is_dynamic_array_param (List.hd params)) | _ -> false ) | TType (type_def,params) -> (match type_def.t_path with - | [] , "Array" -> not (is_type_param (List.hd params)) + | [] , "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 *) @@ -429,10 +556,12 @@ let is_interface_type t = 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 = +let is_internal_member member = match member with | "__Field" | "__IField" | "__Run" | "__Is" | "__GetClass" | "__GetType" | "__ToString" | "__s" | "__GetPtr" | "__SetField" | "__length" | "__IsArray" | "__SetThis" | "__Internal" @@ -441,9 +570,10 @@ let is_internal_member member = | _ -> false;; -let is_dynamic_accessor name acc field class_def = +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 ) ;; @@ -452,10 +582,22 @@ let gen_arg_type_name name default_val arg_type prefix = 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) -> ("Dynamic",prefix ^ 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 = @@ -463,7 +605,7 @@ let gen_arg name default_val arg_type prefix = (fst pair) ^ " " ^ (snd pair);; let rec gen_arg_list arg_list prefix = - String.concat "," (List.map (fun (name,o,arg_type) -> (gen_arg name o arg_type prefix) ) arg_list) + 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 = @@ -519,37 +661,42 @@ let special_to_hex s = 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 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_null s = +let escape_command s = let b = Buffer.create 0 in - String.iter (fun ch -> if (ch=='\x00') then Buffer.add_string b "\\000" else Buffer.add_char b ch ) s; + 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 - let null_escaped = escape_null escaped in - if (has_utf8_chars escaped) then begin - (* Output both wide and thin versions - let the compiler choose ... *) - let l = ref (String.length escaped) in - let q = escape_stringw (Ast.s_escape s) l in - ("HX_CSTRING2(" ^ q ^ "," ^ (string_of_int !l) ^ ",\"" ^ (special_to_hex null_escaped) ^ "\" )") - end else - (* The wide and thin versions are the same ... *) - ("HX_CSTRING(\"" ^ null_escaped ^ "\")") + ("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. + 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 @@ -595,7 +742,6 @@ let rec iter_retval f retval e = match e.eexpr with | TConst _ | TLocal _ - | TEnumField _ | TBreak | TContinue | TTypeExpr _ -> @@ -607,12 +753,11 @@ let rec iter_retval f retval e = | TWhile (e1,e2,_) -> f true e1; f false e2; - | TFor (_,_,e1,e2) -> + | TFor (_,e1,e2) -> f true e1; f false e2; | TThrow e | TField (e,_) - | TClosure (e,_) | TUnop (_,_,e) -> f true e | TParenthesis e -> @@ -634,7 +779,7 @@ let rec iter_retval f retval e = f true e; List.iter (f true) el | TVars vl -> - List.iter (fun (_,_,e) -> match e with None -> () | Some e -> f true e) 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) -> @@ -651,9 +796,11 @@ let rec iter_retval f retval e = (match def with None -> () | Some e -> f false e) | TTry (e,catches) -> f retval e; - List.iter (fun (_,_,e) -> f false e) catches + 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 ;; @@ -671,7 +818,7 @@ let only_int_cases cases = match cases with | [] -> false | _ -> - not (List.exists (fun (cases,expression) -> + not (List.exists (fun (cases,expression) -> List.exists (fun case -> match case.eexpr with TConst (TInt _) -> false | _ -> true ) cases ) cases );; @@ -683,7 +830,7 @@ let contains_break expression = let rec check_all expression = Type.iter (fun expr -> match expr.eexpr with | TBreak -> raise BreakFound - | TFor (_,_,_,_) + | TFor _ | TFunction _ | TWhile (_,_,_) -> () | _ -> check_all expr; @@ -704,30 +851,13 @@ let tmatch_params_to_args params = | Some l -> let n = ref (-1) in List.fold_left - (fun acc (v,t) -> incr n; match v with None -> acc | Some v -> (v,t,!n) :: acc) [] l) - -exception AlreadySafe;; -exception PossibleRecursion;; - -let expression_needs_safe_point expression = - try ( - let rec needs_safe expression always_executed = - (* TODO - fill this out *) - Type.iter (fun expr -> match expr.eexpr with - | TNew (_,_,_) when always_executed -> raise AlreadySafe - | TCall (_,_) -> raise PossibleRecursion - | _ -> needs_safe expr false; - ) expression in - needs_safe expression true; - false; - ) with AlreadySafe -> false - | PossibleRecursion -> true -;; + (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 ;; @@ -737,30 +867,30 @@ let find_undeclared_variables_ctx ctx undeclared declarations this_suffix allow_ let rec find_undeclared_variables undeclared declarations this_suffix allow_this expression = match expression.eexpr with | TVars var_list -> - List.iter (fun (var_name, var_type, optional_init) -> - Hashtbl.add declarations (keyword_remap var_name) (); + List.iter (fun (tvar, optional_init) -> + Hashtbl.add declarations (keyword_remap tvar.v_name) (); if (ctx.ctx_debug) then - output ("/* found var " ^ var_name ^ "*/ "); + 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 (arg_name, opt_val, arg_type) -> + | TFunction func -> List.iter ( fun (tvar, opt_val) -> if (ctx.ctx_debug) then - output ("/* found arg " ^ arg_name ^ " = " ^ (type_string arg_type) ^ " */ "); - Hashtbl.add declarations (keyword_remap arg_name) () ) func.tf_args; + 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 (name,t,catch_expt) -> + List.iter (fun (tvar,catch_expt) -> let old_decs = Hashtbl.copy declarations in - Hashtbl.add declarations (keyword_remap name) (); + 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 local_name -> - let name = keyword_remap local_name in + | 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) -> @@ -769,20 +899,20 @@ let find_undeclared_variables_ctx ctx undeclared declarations this_suffix allow_ let old_decs = Hashtbl.copy declarations in (match params with | None -> () - | Some l -> List.iter (fun (opt_name,t) -> - match opt_name with | Some name -> Hashtbl.add declarations (keyword_remap name) () | _ -> () ) + | Some l -> List.iter (fun (opt_var) -> + match opt_var with | Some v -> Hashtbl.add declarations (keyword_remap v.v_name) () | _ -> () ) l ); - Type.iter (find_undeclared_variables undeclared declarations this_suffix allow_this) expression; + 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 -> - Type.iter (find_undeclared_variables undeclared declarations this_suffix allow_this) expr; + find_undeclared_variables undeclared declarations this_suffix allow_this expr; ); - | TFor (var_name, var_type, init, loop) -> + | TFor (tvar, init, loop) -> let old_decs = Hashtbl.copy declarations in - Hashtbl.add declarations (keyword_remap var_name) (); + 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; @@ -811,7 +941,9 @@ let rec is_dynamic_in_cpp ctx expr = else begin let result = ( match expr.eexpr with - | TField( obj, name ) -> ctx.ctx_dbgout ("/* ?tfield "^name^" */"); + | 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 */"; @@ -834,13 +966,14 @@ let rec is_dynamic_in_cpp ctx expr = dyn; | TTypeExpr _ -> false | TCall(func,args) -> - (match follow func.etype with + (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 - | TLocal name when name = "__global__" -> false + | TCast (e,None) -> is_dynamic_in_cpp ctx e + | TLocal { v_name = "__global__" } -> false | TConst TNull -> true | _ -> ctx.ctx_dbgout "/* other */"; false (* others ? *) ) in @@ -898,6 +1031,106 @@ let cast_if_required ctx expr 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". @@ -917,44 +1150,62 @@ let rec define_local_function_ctx ctx func_name func_def = 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_name, opt_val, arg_type) -> + List.iter ( fun (arg_var, opt_val) -> if (ctx.ctx_debug) then - output ("/* found arg " ^ arg_name ^ " = " ^ (type_string arg_type) ^" */ "); - Hashtbl.add declarations (keyword_remap arg_name) () ) func_def.tf_args; + 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" ^ (list_num typed_vars) ^ "(" ^ func_name_sep ^ + 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 (name,_,arg_type) -> (type_string arg_type) ^ " " ^ name ) func_def.tf_args in + (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(" ^ (String.concat "," args_and_types) ^ ")"); + 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 - let do_safe = expression_needs_safe_point func_def.tf_expr 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 - writer#begin_block; - ctx.ctx_do_safe_point <- do_safe; + output_i ""; gen_expression ctx false func_def.tf_expr; output_i "return null();\n"; - writer#end_block; end else begin - writer#begin_block; - if (do_safe) then output_i "__SAFE_POINT;\n"; (* Save old values, and equalize for new input ... *) let pop_names = push_anon_names ctx in - find_local_functions_ctx ctx func_def.tf_expr; - find_local_return_blocks_ctx ctx false func_def.tf_expr; + 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") -> @@ -970,14 +1221,11 @@ let rec define_local_function_ctx ctx func_name func_def = output ";\n"; output_i "return null();\n"; pop_names(); - writer#end_block; end; - pop_real_this_ptr(); + writer#end_block; - if (has_this) then begin - output_i "Dynamic __this;\n"; - output_i "void __SetThis(Dynamic inThis) { __this = inThis; }\n"; - end; + 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"); @@ -990,61 +1238,60 @@ let rec define_local_function_ctx ctx func_name func_def = in define_local_function func_name func_def -and find_local_functions_ctx ctx expression = +and find_local_functions_and_return_blocks_ctx ctx retval expression = let output = ctx.ctx_output in - let rec find_local_functions expression = - match expression.eexpr with - | TBlock _ - | TObjectDecl _ -> () (* stop at block - since that block will define the function *) - (*| TCall (e,el) -> (* visit function object first, then args *) - find_local_functions e; - List.iter find_local_functions 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) -> ( ) - | _ -> Type.iter find_local_functions expression - in find_local_functions expression - -and find_local_return_blocks_ctx ctx retval expression = - let rec find_local_return_blocks retval expression = + 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); + define_local_return_block_ctx ctx expression (next_anon_function_name ctx) true; end (* else we are done *) - | TFunction func -> () - | TArray ( obj, _ ) when (is_null obj)-> ( ) - | TField ( obj, _ ) when (is_null obj)-> ( ) | TMatch (_, _, _, _) | TTry (_, _) | TSwitch (_, _, _) when retval -> - define_local_return_block_ctx ctx expression (next_anon_function_name ctx) + 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 - (* - List.iter (fun (name,expr) -> iter_retval find_local_return_blocks true expr) decl_list; - *) - define_local_return_block_ctx ctx expression name; - | _ -> iter_retval find_local_return_blocks retval expression - in - find_local_return_blocks retval expression - -and define_local_return_block_ctx ctx expression name = + 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" | name -> " &" ^name 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 @@ -1052,17 +1299,18 @@ and define_local_return_block_ctx ctx expression name = Hashtbl.replace ctx.ctx_local_return_block_args name args; output_i ("struct " ^ name); writer#begin_block; - let ret_type = match expression.eexpr with - | TObjectDecl _ -> "Dynamic" | _ -> type_string expression.etype in + 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 - if (not return_data) then begin - writer#begin_block; - output_i ""; - end; + 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 @@ -1071,10 +1319,10 @@ and define_local_return_block_ctx ctx expression name = 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_return_blocks_ctx ctx true value; - find_local_functions_ctx ctx 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(); @@ -1084,15 +1332,23 @@ and define_local_return_block_ctx ctx expression name = 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); ); - if (not return_data) then begin - output_i "return null();\n"; - writer#end_block; - end; + output_i "return null();\n"; + writer#end_block; pop_real_this_ptr(); writer#end_block_line; output ";\n"; @@ -1110,12 +1366,12 @@ and gen_expression ctx retval expression = 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 do_safe_point = ctx.ctx_do_safe_point in - ctx.ctx_do_safe_point <- false; - let push_src_pos = ctx.ctx_push_src_pos in - ctx.ctx_push_src_pos <- ""; + 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 *) @@ -1140,7 +1396,7 @@ and gen_expression ctx retval expression = let cast = (match op with | ">>" | "<<" | "&" | "|" | "^" -> "int(" | "&&" | "||" -> "bool(" - | "/" -> "double(" + | "/" -> "Float(" | _ -> "") in if (op <> "=") then output "("; if ( cast <> "") then output cast; @@ -1195,25 +1451,86 @@ and gen_expression ctx retval expression = | _ -> gen_bin_op_string expr1 (Ast.s_binop op) expr2 in - (match expression.eexpr with - | TConst TNull when not retval -> - output "Dynamic()"; - | TCall (func, arg_list) when (match func.eexpr with | TConst TSuper -> true | _ -> false ) -> - output "super::__construct("; - gen_expression_list arg_list; - output ")"; - | TCall (func, arg_list) -> - let expr_type = type_string expression.etype in - if (ctx.ctx_debug_type) then output ("/* TCALL ret=" ^ expr_type ^ "*/"); - ctx.ctx_calling <- true; - gen_expression ctx true func; - output "("; - gen_expression_list arg_list; - output ")"; - | TBlock expr_list -> - if (retval) then begin - let func_name = use_anon_function_name ctx 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) ^ ")" ) @@ -1221,20 +1538,113 @@ and gen_expression ctx retval expression = (*error ("Block function " ^ func_name ^ " not found" ) expression.epos;*) output ("/* Block function " ^ func_name ^ " not found */" ); ) - end else begin + 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; - if (do_safe_point) then output_i "__SAFE_POINT\n"; - if (push_src_pos<>"") then output_i ("HX_SOURCE_PUSH(\"" ^ push_src_pos ^ "\")\n"); + 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 -> - find_local_functions_ctx ctx expression; let want_value = (return_from_block && !remaining = 1) in - find_local_return_blocks_ctx ctx want_value expression; - let line = Lexer.get_error_line expression.epos in - output_i ("HX_SOURCE_POS(\"" ^ (Ast.s_escape expression.epos.pfile) ^ "\"," - ^ (string_of_int line) ^ ")\n" ); + 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 "; @@ -1246,9 +1656,11 @@ and gen_expression ctx retval expression = pop_names() end | TTypeExpr type_expr -> - let klass = "::" ^ (join_class_path (t_path type_expr) "::" ) in + 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 @@ -1264,28 +1676,41 @@ and gen_expression ctx retval expression = | TConst const -> (match const with - | TInt i -> output (Printf.sprintf "(int)%ld" i) + | 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 "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 local_name -> output (keyword_remap local_name); - | TEnumField (enum, name) -> - output ("::" ^ (join_class_path enum.e_path "::") ^ "_obj::" ^ name) + | 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 - gen_expression ctx true array_expr; - output "["; - gen_expression ctx true index; - output "]"; + 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(("; @@ -1303,52 +1728,14 @@ and gen_expression ctx retval expression = 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()" - | TClosure (field_object,member) - | TField (field_object,member) -> - 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 (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 name when 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 */"; - if (is_internal_member member) then begin - output ( "->" ^ member ); - end else if (is_dynamic_member_lookup_in_cpp ctx field_object member) then begin - let access = (if assigning then "->__FieldRef" else "->__Field") in - (* output ( "/* " ^ (type_string field_object.etype) ^ " */" ); *) - output ( access ^ "(" ^ (str member) ^ ")" ); - 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 ) - end; - end; - ); - if ( (not !already_dynamic) && (not calling) && (not assigning) && (is_function_member expression) ) then - output "_dyn()"; - + | TField (field_object,field) -> + gen_tfield field_object field | TParenthesis expr when not retval -> gen_expression ctx retval expr; @@ -1360,12 +1747,7 @@ and gen_expression ctx retval expression = ("methodName", { eexpr = (TConst (TString meth)) }) :: [] ) -> output ("hx::SourceInfo(" ^ (str file) ^ "," ^ (Printf.sprintf "%ld" line) ^ "," ^ (str class_name) ^ "," ^ (str meth) ^ ")" ) - | TObjectDecl decl_list -> - 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 -> - output ("/* TObjectDecl block " ^ func_name ^ " not found */" ); ) + | TObjectDecl decl_list -> gen_local_block_call() | TArrayDecl decl_list -> (* gen_type output expression.etype; *) let tstr = (type_string_suff "_obj" expression.etype) in @@ -1379,7 +1761,7 @@ and gen_expression ctx retval expression = if tstr="Dynamic" then output ")"; | TNew (klass,params,expressions) -> let is_param_array = match klass.cl_path with - | ([],"Array") when is_type_param (List.hd params) -> true | _ -> false + | ([],"Array") when is_dynamic_array_param (List.hd params) -> true | _ -> false in if is_param_array then output "Dynamic( Array_obj::__new() )" @@ -1420,46 +1802,39 @@ and gen_expression ctx retval expression = | TVars var_list -> let count = ref (List.length var_list) in - List.iter (fun (var_name, var_type, optional_init) -> + 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 - gen_type ctx var_type; - output (" " ^ (keyword_remap var_name) ); + 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 (var_name, var_type, init, loop) -> - output ("for(::cpp::FastIterator_obj< " ^ (type_string var_type) ^ - " > *__it = ::cpp::CreateFastIterator< "^(type_string var_type) ^ " >("); + | 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 var_type) ^ " " ^ (keyword_remap var_name) ^ " = __it->next();\n" ); + output_i ( (type_string tvar.v_type) ^ " " ^ (keyword_remap tvar.v_name) ^ " = __it->next();\n" ); output_i ""; gen_expression ctx false loop; output ";\n"; - output_i "__SAFE_POINT\n"; ctx.ctx_writer#end_block; | TIf (condition, if_expr, optional_else_expr) -> - let output_if_expr expr terminate = - (match expr.eexpr with - | TBlock _ -> gen_expression ctx false expr - | _ -> output "\n"; - output_i ""; - writer#indent_one; - gen_expression ctx false expr; - if (terminate) then output ";\n" - ) in - (match optional_else_expr with - | Some else_expr -> + | Some else_expr -> if (retval) then begin output "( ("; gen_expression ctx true condition; @@ -1486,17 +1861,15 @@ and gen_expression ctx retval expression = | _ -> output "if ("; gen_expression ctx true condition; output ")"; - output_if_expr if_expr false + gen_expression ctx false (to_block if_expr); ) | TWhile (condition, repeat, Ast.NormalWhile ) -> output "while("; gen_expression ctx true condition; output ")"; - ctx.ctx_do_safe_point <- true; gen_expression ctx false (to_block repeat) | TWhile (condition, repeat, Ast.DoWhile ) -> output "do"; - ctx.ctx_do_safe_point <- true; gen_expression ctx false (to_block repeat); output "while("; gen_expression ctx true condition; @@ -1506,13 +1879,7 @@ and gen_expression ctx retval expression = | TTry (_,_) | TSwitch (_,_,_) | TMatch (_, _, _, _) when (retval && (not return_from_internal_node) )-> - 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 -> - output ("/* return block " ^ func_name ^ " not found */" ); ) - (*error ("return block " ^ func_name ^ " not found" ) expression.epos;*) - + 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 @@ -1566,59 +1933,56 @@ and gen_expression ctx retval expression = ); end | TMatch (condition, enum, cases, default) -> - let tmp_var = get_switch_var ctx in - writer#begin_block; - output ( (type_string condition.etype) ^ " " ^ 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) ^ " " ^ 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; + 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"; @@ -1630,15 +1994,16 @@ and gen_expression ctx retval expression = ctx.ctx_writer#begin_block; let seen_dynamic = ref false in let else_str = ref "" in - List.iter (fun (name,t,expression) -> - let type_name = type_string t 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 (type_name ^ " " ^ name ^ " = __e;"); + 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); @@ -1655,10 +2020,13 @@ and gen_expression ctx retval expression = | TThrow expression -> output "hx::Throw ("; gen_expression ctx true expression; output ")" - | TCast (expression,None) -> - gen_expression ctx retval expression + | 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 (t_path t) "::" ) in + let class_name = (join_class_path_remap (t_path t) "::" ) in if (class_name="Array") then output ("hx::TCastToArray(" ) else @@ -1692,72 +2060,34 @@ let is_data_member field = | _ -> true;; -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 (name,o,arg_type) -> let type_str = type_string arg_type in - match o with - | Some TNull -> () - | Some const when (type_str=="::String") -> - ctx.ctx_output ("if (" ^ name ^ " == null() ) " - ^ name ^ "=" ^ (default_value_string const) ^ ");\n") - | Some const -> - ctx.ctx_output (type_str ^ " " ^ name ^ " = " ^ prefix ^ name ^ ".Default(" ^ - (default_value_string const) ^ ");\n") - | _ -> () ) args;; - - -let has_default_values args = - List.exists ( fun (_,o,_) -> match o with - | Some TNull -> false - | Some _ -> true - | _ -> false ) args ;; +let is_override class_def field = + List.exists (fun f -> f.cf_name = field) class_def.cl_overrides +;; -(* - When a specialized class inherits from a templated class, the inherited class - contains the specialized type, rather than the generic template (Dynamic) type. - C++ needs the inhertied functions to have the same types as the base types. - - use Codegen.fix_overrides -*) -(* -let rec inherit_temlpate_types class_def name is_static in_def = - match class_def.cl_super with - | None -> in_def - | Some (super,params) -> - let funcs = if is_static then super.cl_statics else super.cl_fields in - if (PMap.mem name funcs) then begin - let field = PMap.find name funcs in - match field.cf_expr with - | Some { eexpr = TFunction parent_def } -> - inherit_temlpate_types super name is_static - { - tf_args = List.map2 (fun (n,_,_) (_,c,t) -> n,c,t) in_def.tf_args parent_def.tf_args; - tf_type = parent_def.tf_type; - tf_expr = in_def.tf_expr; - } - | _ -> inherit_temlpate_types super name is_static in_def; - end else - inherit_temlpate_types super name is_static in_def; +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) + | _ -> [] ) ;; -*) -let gen_field ctx class_def class_name ptr_name is_static is_external is_interface field = + (* 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 - if (is_external || is_interface) then begin + 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 with - | TFun (args,result) -> + 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)) ^ @@ -1770,7 +2100,18 @@ let gen_field ctx class_def class_name ptr_name is_static is_external is_interfa 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 src_name = class_name ^ "::" ^ field.cf_name 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 *) @@ -1780,29 +2121,37 @@ let gen_field ctx class_def class_name ptr_name is_static is_external is_interfa output ")"; ctx.ctx_real_this_ptr <- true; ctx.ctx_dynamic_this_ptr <- false; - ctx.ctx_do_safe_point <- expression_needs_safe_point function_def.tf_expr; + 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_"; - output ("\tHX_SOURCE_PUSH(\"" ^ src_name ^ "\");\n"); + 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 - if (is_void) then ctx.ctx_writer#begin_block; - ctx.ctx_push_src_pos <- src_name; + 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); - if (is_void) then begin - output "return null();\n"; + 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 (is_static) then output "STATIC_"; - output ("HX_DEFINE_DYNAMIC_FUNC" ^ nargs ^ "(" ^ class_name ^ "," ^ + 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; @@ -1811,7 +2160,7 @@ let gen_field ctx class_def class_name ptr_name is_static is_external is_interfa output ("HX_BEGIN_DEFAULT_FUNC(" ^ func_name ^ "," ^ class_name ^ ")\n"); output return_type; output (" run(" ^ (gen_arg_list function_def.tf_args "") ^ ")"); - ctx.ctx_push_src_pos <- src_name; + 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; @@ -1828,8 +2177,13 @@ let gen_field ctx class_def class_name ptr_name is_static is_external is_interfa 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 @@ -1849,61 +2203,52 @@ let gen_field_init ctx field = if (is_dynamic_haxe_method field) then begin let func_name = "__default_" ^ (remap_name) in - output ( " hx::Static(" ^ remap_name ^ ") = new " ^ func_name ^ ";\n\n" ); + output ( " " ^ remap_name ^ " = new " ^ func_name ^ ";\n\n" ); end (* Data field *) | _ -> (match field.cf_expr with | Some expr -> - find_local_functions_ctx ctx expr; - find_local_return_blocks_ctx ctx true expr; - output ( " hx::Static(" ^ remap_name ^ ") = "); + 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" - | _ -> - output ( " hx::Static(" ^ remap_name ^ ");\n"); + | _ -> ( ) ); ) ;; -let gen_member_def ctx class_def is_static is_extern is_interface field = +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 - output (if is_static then " static " else " "); - if (is_extern || is_interface) then begin - match follow field.cf_type with - | TFun (args,return_type) -> + 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 (String.concat "," (List.map (fun (name,opt,typ) -> - (type_string typ) ^ " " ^ name ^ (if opt then "=null()" else "")) args)); + output (gen_tfun_interface_arg_list args); output (if (not is_static) then ")=0;\n" else ");\n"); - (*if (not is_interface) then begin*) - output (if is_static then " static " else " "); - output ("Dynamic " ^ remap_name ^ "_dyn();\n" ); - (*end else - output (" virtual Dynamic " ^ remap_name ^ "_dyn() = 0;\n\n" );*) - | _ -> - if (is_interface) then begin - (* - output "virtual "; - gen_type ctx field.cf_type; - output (" & __get_" ^ remap_name ^ "()=0;\n" ) *) - output "\n"; - end else begin - gen_type ctx field.cf_type; - output (" " ^ remap_name ^ ";\n" ); - end - end else (match field.cf_expr with + 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 - output ("Dynamic " ^ remap_name ^ ";\n"); - output (if is_static then " static " else " "); - (* external mem Dynamic & *) - output ("inline Dynamic &" ^ remap_name ^ "_dyn() " ^ "{return " ^ remap_name^ "; }\n") + 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 "; @@ -1911,42 +2256,55 @@ let gen_member_def ctx class_def is_static is_extern is_interface field = output (" " ^ remap_name ^ "( " ); output (gen_arg_list function_def.tf_args "" ); output ");\n"; - output (if is_static then " static " else " "); - output ("Dynamic " ^ remap_name ^ "_dyn();\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 ^ "; /* REM */ \n" ); + output (" " ^ remap_name ^ ";\n" ); (* Add a "dyn" function for variable to unify variable/function access *) (match follow field.cf_type with | TFun (_,_) -> - output " "; + 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 name } when (is_dynamic_accessor name "get" field class_def) -> + | 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 name } when (is_dynamic_accessor name "set" field class_def) -> + | 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. + 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 = +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 @@ -1956,6 +2314,13 @@ let find_referenced_types ctx obj super_deps constructor_deps header_only = 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) @@ -1967,27 +2332,36 @@ let find_referenced_types ctx obj super_deps constructor_deps header_only = | TInst (klass,params) -> (match klass.cl_path with | ([],"Array") | ([],"Class") | (["cpp"],"FastIterator") -> List.iter visit_type params - | _ -> if (klass.cl_kind <> KTypeParameter ) then add_type klass.cl_path; + | (["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 ... *) + (* Expand out TTypeExpr (ie, the name of a class, as used for static access etc ... *) (match expression.eexpr with - | TTypeExpr type_def -> add_type (t_path type_def) + | 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 (_,catch_type,_) -> visit_type catch_type) catches + List.iter (fun (v,_) -> visit_type v.v_type) catches (* Must visit the enum param types, Type.iter will visit the rest ... *) - | TMatch (_,_,cases,_) -> + | TMatch (_,enum,cases,_) -> + add_type (fst enum).e_path; List.iter (fun (case_ids,params,expression) -> (match params with | None -> () - | Some l -> List.iter (fun (v,t) -> visit_type t) l ) ) cases; + | 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)); @@ -1998,10 +2372,18 @@ let find_referenced_types ctx obj super_deps constructor_deps header_only = end (* Must visit type too, Type.iter will visit the expressions ... *) | TVars var_list -> - List.iter (fun (_, var_type, _) -> visit_type var_type ) 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 (_,_,arg_type) -> visit_type arg_type) func_def.tf_args; + 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; @@ -2022,6 +2404,9 @@ let find_referenced_types ctx obj super_deps constructor_deps header_only = 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 @@ -2047,65 +2432,105 @@ let find_referenced_types ctx obj super_deps constructor_deps header_only = | 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 _ -> (* These are expanded *) ()); - List.sort inc_cmp (List.filter (fun path -> not (is_internal_header path) ) (pmap_keys !types)) + | 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 boot_classes init_classes = - let base_dir = common_ctx.file in +let generate_main common_ctx member_types super_deps class_def file_info = (* main routine should be a single static function *) - let main_expression = + let main_expression = (match class_def.cl_ordered_statics with | [{ cf_expr = Some expression }] -> expression; | _ -> assert false ) in - let referenced = find_referenced_types common_ctx (TClassDecl class_def) super_deps (Hashtbl.create 0) 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 - let ctx = new_context common_ctx cpp_file false in - ctx.ctx_class_name <- "?"; - ctx.ctx_class_member_types <- member_types; output_main "#include \n\n"; output_main "#include \n\n"; - List.iter ( add_include cpp_file ) referenced; + 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) false main_expression; + 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; + 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 (include_remap class_path) "/" ) ^ ".h>\n") + ( 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 class_path "::" ) ^ "_obj::__register();\n") ) boot_classes; + output_boot ("::" ^ ( join_class_path_remap class_path "::" ) ^ "_obj::__register();\n") ) boot_classes; List.iter ( fun class_path -> - output_boot ("::" ^ ( join_class_path class_path "::" ) ^ "_obj::__init__();\n") ) (List.rev init_classes); + 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 class_path "::" ) ^ "_obj::__boot();\n") ) (List.rev boot_classes); + 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"); @@ -2113,12 +2538,12 @@ let begin_header_file output_h def_string = output_h "#include \n"; output_h "#endif\n\n";; -let end_header_file output_h def_string = +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 "vcproj" ) then begin + 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) ) ^ "-" ^ @@ -2128,7 +2553,7 @@ let new_placed_cpp_file common_ctx class_path = -let generate_enum_files common_ctx enum_def super_deps meta = +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 @@ -2137,15 +2562,14 @@ let generate_enum_files common_ctx enum_def super_deps meta = 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 in - let has_meta = ( match meta with Some _ -> true | _ -> 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 in + 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; @@ -2154,7 +2578,7 @@ let generate_enum_files common_ctx enum_def super_deps meta = PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in match constructor.ef_type with - | TFun (args,_) -> + | 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) ^ "," ^ @@ -2205,9 +2629,7 @@ let generate_enum_files common_ctx enum_def super_deps meta = output_cpp ("}\n\n"); (* Dynamic "Get" Field function - string version *) - output_cpp ("Dynamic " ^ class_name ^ "::__Field(const ::String &inName)\n{\n"); - if (has_meta) then - output_cpp " if (inName==HX_CSTRING(\"__meta__\")) return __meta__;\n"; + 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) ); @@ -2215,21 +2637,19 @@ let generate_enum_files common_ctx enum_def super_deps meta = output_cpp (";\n") in PMap.iter dump_constructor_test enum_def.e_constrs; - output_cpp (" return super::__Field(inName);\n}\n\n"); - - if (has_meta) then output_cpp ("Dynamic " ^ class_name ^ "::__meta__;\n"); + 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.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 function - only used with internal GC *) + (* 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 @@ -2237,10 +2657,18 @@ let generate_enum_files common_ctx enum_def super_deps meta = | TFun (_,_) -> () | _ -> output_cpp (" HX_MARK_MEMBER_NAME(" ^ class_name ^ "::" ^ name ^ ",\"" ^ name ^ "\");\n") ) enum_def.e_constrs; - if (has_meta) then - output_cpp (" HX_MARK_MEMBER_NAME(" ^ class_name ^ "::__meta__,\"__meta__\");\n"); 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"; @@ -2250,18 +2678,18 @@ let generate_enum_files common_ctx enum_def super_deps meta = output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); let text_name = str (join_class_path class_path ".") in - output_cpp ("\nStatic(__mClass) = hx::RegisterClass(" ^ text_name ^ + 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);\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 in - find_local_return_blocks_ctx ctx true expr; - output_cpp ("Static(__meta__) = "); + 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" | _ -> () ); @@ -2270,7 +2698,7 @@ let generate_enum_files common_ctx enum_def super_deps meta = match constructor.ef_type with | TFun (_,_) -> () | _ -> - output_cpp ( "Static(" ^ (keyword_remap name) ^ ") = hx::CreateEnum< " ^ class_name ^ " >(" ^ (str name) ^ "," ^ + 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"); @@ -2309,17 +2737,17 @@ let generate_enum_files common_ctx enum_def super_deps meta = (str (just_class_name ^ ".") )^ " + tag; }\n\n"); - if (has_meta) then - output_h (" static Dynamic __meta__;\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,_) -> + | TFun (args,_) -> output_h ( "(" ^ (gen_tfun_arg_list args) ^");\n"); output_h ( " static Dynamic " ^ name ^ "_dyn();\n"); | _ -> - output_h ";\n" + output_h ";\n"; + output_h ( " static inline " ^ smart_class_name ^ " " ^ name ^ + "_dyn() { return " ^name ^ "; }\n" ); ) enum_def.e_constrs; output_h "};\n\n"; @@ -2328,25 +2756,49 @@ let generate_enum_files common_ctx enum_def super_deps meta = end_header_file output_h def_string; h_file#close; - referenced;; + 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 generate_class_files common_ctx member_types super_deps constructor_deps class_def = - let is_extern = class_def.cl_extern in +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_def.cl_path) ^ "_obj" in - let smart_class_name = (snd 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 in - ctx.ctx_class_name <- "::" ^ (join_class_path class_path "::"); + 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); @@ -2354,13 +2806,14 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla let constructor_type_var_list = match class_def.cl_constructor with | Some definition -> - (match definition.cf_type with - | TFun (args,_) -> List.map (fun (a,_,t) -> (type_string t,a) ) args - | _ -> (match definition.cf_expr with + (match definition.cf_expr with | Some { eexpr = TFunction function_def } -> - List.map (fun (name,o,arg_type) -> gen_arg_type_name name o arg_type "__o_") + 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 @@ -2372,12 +2825,13 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla output_cpp "#include \n\n"; - let field_integer_dynamic = has_field_integer_lookup class_def in - let field_integer_numeric = has_field_integer_numeric_lookup class_def in + 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 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 -> @@ -2392,55 +2846,57 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla ) (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 - if (not is_extern) 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 } -> - 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 ("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"; - end; (* 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"); - if (not is_extern) then - output_cpp ("Dynamic " ^ class_name ^ "::__CreateEmpty() { return new " ^ class_name ^ "; }\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 ext = - if (ext) then - output_cpp ("{ " ^ ptr_name ^ " result = __CreateEmpty();\n") - else - output_cpp ("{ " ^ ptr_name ^ " result = new " ^ class_name ^ "();\n"); + let create_result () = + output_cpp ("{ " ^ ptr_name ^ " result = new " ^ class_name ^ "();\n"); in - create_result is_extern; + 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 is_extern; + 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 type_info &inType) {\n"); + 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"); @@ -2451,19 +2907,23 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla end; (match class_def.cl_init with - | Some expression -> - output_cpp ("void " ^ class_name^ "::__init__()"); - gen_expression (new_context common_ctx cpp_file debug) false expression; - output_cpp "\n\n"; + | 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 is_extern class_def.cl_interface) + (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 is_extern class_def.cl_interface) - class_def.cl_ordered_statics; + (gen_field ctx class_def class_name smart_class_name true class_def.cl_interface) statics_except_meta; output_cpp "\n"; @@ -2483,38 +2943,60 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla class_def.cl_ordered_fields; output_cpp "}\n\n"; - (* MARK function - only used with internal GC *) + + 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 - (fun field -> - if (is_data_member field) then begin - let remap_name = keyword_remap field.cf_name in - output_cpp (" HX_MARK_MEMBER_NAME(" ^ remap_name ^ ",\"" ^ field.cf_name^ "\");\n"); - - (match field.cf_kind with Var { v_read = AccCall name } when (is_dynamic_accessor name "get" field class_def) -> - output_cpp ("\tHX_MARK_MEMBER_NAME(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n" ) | _ -> ()); - (match field.cf_kind with Var { v_write = AccCall name } when (is_dynamic_accessor name "set" field class_def) -> - output_cpp ("\tHX_MARK_MEMBER_NAME(" ^ name ^ "," ^ "\"" ^ name ^ "\");\n" ) | _ -> ()); - end - - ) class_def.cl_ordered_fields; + 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 - | _ -> (not is_extern) || - (match follow field.cf_type with | TFun _ -> false | _ -> true) ) in - - let all_fields = class_def.cl_ordered_statics @ class_def.cl_ordered_fields in - let all_variables = List.filter variable_field all_fields in + | _ -> 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 @@ -2536,20 +3018,21 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla (* Dynamic "Get" Field function - string version *) - output_cpp ("Dynamic " ^ class_name ^ "::__Field(const ::String &inName)\n{\n"); + 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 prop } -> (keyword_remap prop) ^ "()" + | 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 all_fields); + 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);\n}\n\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 @@ -2558,52 +3041,56 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla output_cpp ("static int __id_" ^ remap_name ^ " = __hxcpp_field_to_id(\"" ^ (field.cf_name) ^ "\");\n"); ) in - List.iter dump_static_ids all_fields; + List.iter dump_static_ids reflect_readable; output_cpp "\n\n"; - let output_ifield return_type function_name = + 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="double") then "hx::ToDouble( " else "" ) ^ + ( if (return_type="Float") then "hx::ToDouble( " else "" ) ^ (match f.cf_kind with - | Var { v_read = AccCall prop } -> (keyword_remap prop) ^ "()" - | _ -> ((keyword_remap f.cf_name) ^ if ( variable_field f) then "" else "_dyn()") - ) ^ ( if (return_type="double") then " ) " else "" ) ^ ";\n"); + | 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 all_fields; + 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"; - if (field_integer_numeric) then output_ifield "double" "__INumField"; + 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)\n{\n"); + 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 prop } -> "return " ^ (keyword_remap prop) ^ "(inValue);" - | _ -> (keyword_remap f.cf_name) ^ "=inValue.Cast< " ^ (type_string f.cf_type) ^ - " >(); return inValue;" - ) ) + | 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 all_variables); + dump_quick_field_test (set_field_dat reflect_write_variables); if (implement_dynamic) then begin - output_cpp (" try { return super::__SetField(inName,inValue); }\n"); + 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);\n}\n\n"); + output_cpp (" return super::__SetField(inName,inValue,inCallProp);\n}\n\n"); (* For getting a list of data members (eg, for serialization) *) let append_field = @@ -2617,25 +3104,86 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla output_cpp " super::__GetFields(outFields);\n"; output_cpp "};\n\n"; - - let dump_field_name = (fun field -> output_cpp (" " ^ (str field.cf_name) ^ ",\n")) in output_cpp "static ::String sStaticFields[] = {\n"; - List.iter dump_field_name class_def.cl_ordered_statics; + List.iter dump_field_name implemented_fields; output_cpp " String(null()) };\n\n"; - output_cpp "static ::String sMemberFields[] = {\n"; - List.iter dump_field_name class_def.cl_ordered_fields; - output_cpp " String(null()) };\n\n"; + end; (* cl_interface *) - (* MARK function - only used with internal GC *) - output_cpp "static void sMarkStatics(HX_MARK_PARAMS) {\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") ) - class_def.cl_ordered_statics; - output_cpp "};\n\n"; + output_cpp "static ::String sMemberFields[] = {\n"; + List.iter dump_field_name implemented_instance_fields; + output_cpp " String(null()) };\n\n"; - end; + + (* 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; @@ -2648,24 +3196,36 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla output_cpp ("Class " ^ class_name ^ "::__mClass;\n\n"); output_cpp ("void " ^ class_name ^ "::__register()\n{\n"); - output_cpp (" Static(__mClass) = hx::RegisterClass(" ^ (str class_name_text) ^ + 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);\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"); - if (not is_extern) then begin - output_cpp ("void " ^ class_name ^ "::__boot()\n{\n"); - List.iter (gen_field_init ctx ) class_def.cl_ordered_statics; - output_cpp ("}\n\n"); - end; + 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; - if (is_extern) then begin - output_cpp ("\n\n#include\n\n"); - end; cpp_file#close; @@ -2695,23 +3255,26 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla (* 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 in + 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 " ^ class_name ^ " : public " ^ super ); + 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"); - if (is_extern) then - output_h (" virtual Void __construct(" ^ constructor_type_args ^ ")=0;\n") - else - output_h (" Void __construct(" ^ constructor_type_args ^ ");\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"); @@ -2725,6 +3288,7 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla 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 " ^ @@ -2732,12 +3296,15 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla ) implemented; if ( (List.length implemented) > 0 ) then - output_h " hx::Object *__ToInterface(const type_info &inType);\n"; + 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; + end else begin + output_h (" HX_DO_INTERFACE_RTTI;\n"); + output_h (" static void __boot();\n"); + end; (match class_def.cl_array_access with @@ -2746,23 +3313,25 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla let interface = class_def.cl_interface in - List.iter (gen_member_def ctx class_def false is_extern interface) class_def.cl_ordered_fields; - List.iter (gen_member_def ctx class_def true is_extern interface) class_def.cl_ordered_statics; + 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_def.cl_path "_" ) ^ " \\\n"); + output_h ("#define DELEGATE_" ^ (join_class_path class_path "_" ) ^ " \\\n"); List.iter (fun field -> - match follow field.cf_type with - | TFun (args,return_type) -> + 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 (String.concat "," (List.map (fun (name,opt,typ) -> - (type_string typ) ^ " " ^ name ^ (if opt then "=null()" else "")) args)); + output_h (gen_tfun_interface_arg_list args); output_h (") { return mDelegate->" ^ remap_name^ "("); - output_h (String.concat "," (List.map (fun (name,opt,typ) -> name) args)); + 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"); @@ -2776,8 +3345,9 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla 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"); + 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; @@ -2789,32 +3359,8 @@ let generate_class_files common_ctx member_types super_deps constructor_deps cla end_header_file output_h def_string; h_file#close; - all_referenced;; - - -let gen_deps deps = - let project_deps = List.filter (fun path -> not (is_internal_class path) ) deps in - String.concat " " (List.map (fun class_path -> - "include/" ^ (join_class_path class_path "/") ^ ".h") project_deps );; - -let add_class_to_makefile makefile add_obj class_def = - let class_path = fst class_def in - let deps = snd class_def in - let obj_file = "obj/" ^ (join_class_path class_path "-") ^ "$(OBJ)" in - let cpp = (join_class_path class_path "/") ^ ".cpp" in - output_string makefile ( obj_file ^ " : src/" ^ cpp ^ " " ^ (gen_deps deps) ^ "\n"); - output_string makefile ("\t$(COMPILE) src/" ^ cpp ^ " $(OUT_FLAGS)$@\n\n"); - output_string makefile (add_obj ^ " " ^ obj_file ^ "\n\n" );; - - -let kind_string = function - | KNormal -> "KNormal" - | KTypeParameter -> "KTypeParameter" - | KExtension _ -> "KExtension" - | KConstant _ -> "KConstant" - | KGeneric -> "KGeneric" - | KGenericInstance _ -> "KGenericInstance";; - + 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 @@ -2849,57 +3395,63 @@ let write_resources common_ctx = resource_file#close;; -let add_class_to_buildfile 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 (" \n") ) project_deps; - - output_string buildfile ( " \n" );; - -let write_build_data filename classes main_deps exe_name = +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 buildfile) classes; - add_class_to_buildfile buildfile ( ( [] , "__boot__") , [] ); - add_class_to_buildfile buildfile ( ( [] , "__resources__") , [] ); + 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 buildfile ( ( [] , "__lib__") , main_deps ); + add_class_to_buildfile ( ( [] , "__lib__") , main_deps ); output_string buildfile "\n"; output_string buildfile "\n"; output_string buildfile "\n"; - add_class_to_buildfile buildfile ( ( [] , "__main__") , main_deps ); + 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 options = +let write_build_options filename defines = let writer = cached_source_writer filename in - PMap.iter ( fun name _ -> if (name <> "debug") then writer#write ( name ^ "\n") ) options; + 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 create_member_types common_ctx = let result = Hashtbl.create 0 in let add_member class_name interface member = - match follow member.cf_type with - | TFun (_,ret) -> + 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 -> + | _,_ when not interface -> Hashtbl.add result (class_name ^ "." ^ member.cf_name) (type_string member.cf_type) | _ -> () in @@ -2918,28 +3470,29 @@ let create_member_types common_ctx = result;; (* Builds inheritance tree, so header files can include parents defs. *) -let create_super_dependencies common_ctx = +let create_super_dependencies common_ctx = let result = Hashtbl.create 0 in List.iter (fun object_def -> (match object_def with - | TClassDecl class_def -> + | TClassDecl class_def when not class_def.cl_extern -> let deps = ref [] in (match class_def.cl_super with Some super -> - deps := ((fst super).cl_path) :: !deps + 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 -> + | 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 create_constructor_dependencies common_ctx = let result = Hashtbl.create 0 in List.iter (fun object_def -> (match object_def with - | TClassDecl class_def -> + | 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 | _ -> () ) @@ -2947,6 +3500,147 @@ let create_constructor_dependencies common_ctx = ) 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; @@ -2955,29 +3649,43 @@ let generate common_ctx = 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 - if (is_internal) then + 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 - if (not class_def.cl_interface) then - boot_classes := class_def.cl_path :: !boot_classes; + 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 in + 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 )) @@ -2986,20 +3694,26 @@ let generate common_ctx = 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 in + 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 _ -> (* already done *) () + | TTypeDecl _ | TAbstractDecl _ -> (* already done *) () ); ) common_ctx.types; + (match common_ctx.main with - | None -> () + | None -> generate_dummy_main common_ctx | Some e -> - let main_field = { cf_name = "__main__"; cf_type = t_dynamic; cf_expr = Some e; cf_public = true; cf_meta = []; cf_doc = None; cf_kind = Var { v_read = AccNormal; v_write = AccNormal; }; cf_params = [] } in + 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; - generate_main common_ctx member_types super_deps class_def !boot_classes !init_classes); + 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; @@ -3008,16 +3722,20 @@ let generate common_ctx = | Some path -> (snd path) | _ -> "output" in - write_build_data (common_ctx.file ^ "/Build.xml") !exe_classes !main_deps output_name; - write_build_options (common_ctx.file ^ "/Options.txt") common_ctx.defines; - if ( not (Common.defined common_ctx "no-compilation") ) then begin + 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"; - PMap.iter ( fun name _ -> cmd := !cmd ^ " -D" ^ name ^ "" ) common_ctx.defines; - print_endline !cmd; - if Sys.command !cmd <> 0 then failwith "Build failed"; + cmd := !cmd ^ !cmd_defines; + print_endline !cmd; + if common_ctx.run_command !cmd <> 0 then failwith "Build failed"; Sys.chdir old_dir; end ;; diff --git a/gencs.ml b/gencs.ml new file mode 100644 index 0000000000000000000000000000000000000000..6f239446b0145c828c3ea545cff7736a1a693e0c --- /dev/null +++ b/gencs.ml @@ -0,0 +1,2349 @@ +(* + * 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 Gencommon.ReflectionCFs +open Ast +open Common +open Gencommon +open Gencommon.SourceWriter +open Type +open Printf +open Option + +let is_cs_basic_type t = + match follow t with + | TInst( { cl_path = (["haxe"], "Int32") }, [] ) + | TInst( { cl_path = (["haxe"], "Int64") }, [] ) + | 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 + | TAbstract _ when like_float t -> + true + | TEnum(e, _) when not (Meta.has Meta.Class e.e_meta) -> true + | TInst(cl, _) when Meta.has Meta.Struct cl.cl_meta -> true + | _ -> false + +(* see http://msdn.microsoft.com/en-us/library/2sk3x8a7(v=vs.71).aspx *) +let cs_binops = + [Ast.OpAdd, "op_Addition"; + Ast.OpSub, "op_Subtraction"; + Ast.OpMult, "op_Multiply"; + Ast.OpDiv, "op_Division"; + Ast.OpMod, "op_Modulus"; + Ast.OpXor, "op_ExclusiveOr"; + Ast.OpOr, "op_BitwiseOr"; + Ast.OpAnd, "op_BitwiseAnd"; + Ast.OpBoolAnd, "op_LogicalAnd"; + Ast.OpBoolOr, "op_LogicalOr"; + Ast.OpAssign, "op_Assign"; + Ast.OpShl, "op_LeftShift"; + Ast.OpShr, "op_RightShift"; + Ast.OpShr, "op_SignedRightShift"; + Ast.OpUShr, "op_UnsignedRightShift"; + Ast.OpEq, "op_Equality"; + Ast.OpGt, "op_GreaterThan"; + Ast.OpLt, "op_LessThan"; + Ast.OpNotEq, "op_Inequality"; + Ast.OpGte, "op_GreaterThanOrEqual"; + Ast.OpLte, "op_LessThanOrEqual"; + Ast.OpAssignOp Ast.OpMult, "op_MultiplicationAssignment"; + Ast.OpAssignOp Ast.OpSub, "op_SubtractionAssignment"; + Ast.OpAssignOp Ast.OpXor, "op_ExclusiveOrAssignment"; + Ast.OpAssignOp Ast.OpShl, "op_LeftShiftAssignment"; + Ast.OpAssignOp Ast.OpMod, "op_ModulusAssignment"; + Ast.OpAssignOp Ast.OpAdd, "op_AdditionAssignment"; + Ast.OpAssignOp Ast.OpAnd, "op_BitwiseAndAssignment"; + Ast.OpAssignOp Ast.OpOr, "op_BitwiseOrAssignment"; + (* op_Comma *) + Ast.OpAssignOp Ast.OpDiv, "op_DivisionAssignment";] + +let cs_unops = + [Ast.Decrement, "op_Decrement"; + Ast.Increment, "op_Increment"; + Ast.Not, "op_UnaryNegation"; + Ast.Neg, "op_UnaryMinus"; + Ast.NegBits, "op_OnesComplement"] + +let binops_names = List.fold_left (fun acc (op,n) -> PMap.add n op acc) PMap.empty cs_binops +let unops_names = List.fold_left (fun acc (op,n) -> PMap.add n op acc) PMap.empty cs_unops + +let get_item = "get_Item" +let set_item = "set_Item" + +let is_tparam t = + match follow t with + | TInst( { cl_kind = KTypeParameter _ }, [] ) -> true + | _ -> false + +let rec is_int_float t = + match follow t with + | TInst( { cl_path = (["haxe"], "Int32") }, [] ) + | TInst( { cl_path = (["haxe"], "Int64") }, [] ) + | TInst( { cl_path = ([], "Int") }, [] ) + | TAbstract ({ a_path = ([], "Int") },[]) + | TInst( { cl_path = ([], "Float") }, [] ) + | TAbstract ({ a_path = ([], "Float") },[]) -> + true + | TAbstract _ when like_float t -> + true + | TInst( { cl_path = (["haxe"; "lang"], "Null") }, [t] ) -> is_int_float t + | _ -> false + +let rec is_null t = + match t with + | TInst( { cl_path = (["haxe"; "lang"], "Null") }, _ ) + | TType( { t_path = ([], "Null") }, _ ) -> true + | TType( t, tl ) -> is_null (apply_params t.t_types tl t.t_type) + | TMono r -> + (match !r with + | Some t -> is_null t + | _ -> false) + | TLazy f -> + is_null (!f()) + | _ -> 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 + +(* ******************************************* *) +(* CSharpSpecificESynf *) +(* ******************************************* *) + +(* + + Some CSharp-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 + +*) +module CSharpSpecificESynf = +struct + + let name = "csharp_specific_e" + + let priority = solve_deps name [DBefore ExpressionUnwrap.priority; DBefore ClassInstance.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 uint = match get_type gen ([], "UInt") with | TTypeDecl t -> TType(t, []) | TAbstractDecl a -> TAbstract(a, []) | _ -> assert false in + + let is_var = alloc_var "__is__" t_dynamic in + + let rec run e = + match e.eexpr with + (* Std.is() *) + | TCall( + { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "is" })) }, + [ obj; { eexpr = TTypeExpr(TClassDecl { cl_path = [], "Dynamic" } | TAbstractDecl { a_path = [], "Dynamic" }) }] + ) -> + Type.map_expr run e + | TCall( + { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "is"}) ) }, + [ obj; { eexpr = TTypeExpr(md) }] + ) -> + let mk_is obj md = + { e with eexpr = TCall( { eexpr = TLocal is_var; etype = t_dynamic; epos = e.epos }, [ + obj; + { eexpr = TTypeExpr md; etype = t_dynamic (* this is after all a syntax filter *); epos = e.epos } + ] ) } + in + let obj = run obj in + (match follow_module follow md with + | TClassDecl{ cl_path = ([], "Float") } -> + (* on the special case of seeing if it is a Float, we need to test if both it is a float and if it is an Int *) + let mk_is local = + mk_paren { + eexpr = TBinop(Ast.OpBoolOr, mk_is local md, mk_is local (TClassDecl (get_cl_from_t basic.tint))); + etype = basic.tbool; + epos = e.epos + } + in + + let ret = match obj.eexpr with + | TLocal(v) -> mk_is obj + | _ -> + let var = mk_temp gen "is" obj.etype in + let added = { obj with eexpr = TVars([var, Some(obj)]); etype = basic.tvoid } in + let local = mk_local var obj.epos in + { + eexpr = TBlock([ added; mk_is local ]); + etype = basic.tbool; + epos = e.epos + } + in + ret + | TClassDecl{ cl_path = ([], "Int") } -> + { + eexpr = TCall( + mk_static_field_access_infer runtime_cl "isInt" e.epos [], + [ obj ] + ); + etype = basic.tbool; + epos = e.epos + } + | _ -> + mk_is obj md + ) + (* end Std.is() *) + + | TBinop( Ast.OpUShr, e1, e2 ) -> + mk_cast e.etype { e with eexpr = TBinop( Ast.OpShr, mk_cast uint (run e1), run e2 ) } + + | TBinop( Ast.OpAssignOp Ast.OpUShr, e1, e2 ) -> + let mk_ushr local = + { e with eexpr = TBinop(Ast.OpAssign, local, run { e with eexpr = TBinop(Ast.OpUShr, local, run e2) }) } + in + + let mk_local obj = + let var = mk_temp gen "opUshr" obj.etype in + let added = { obj with eexpr = TVars([var, Some(obj)]); etype = basic.tvoid } in + let local = mk_local var obj.epos in + local, added + in + + let e1 = run e1 in + + let ret = match e1.eexpr with + | TField({ eexpr = TLocal _ }, _) + | TField({ eexpr = TTypeExpr _ }, _) + | TArray({ eexpr = TLocal _ }, _) + | TLocal(_) -> + mk_ushr e1 + | TField(fexpr, field) -> + let local, added = mk_local fexpr in + { e with eexpr = TBlock([ added; mk_ushr { e1 with eexpr = TField(local, field) } ]); } + | TArray(ea1, ea2) -> + let local, added = mk_local ea1 in + { e with eexpr = TBlock([ added; mk_ushr { e1 with eexpr = TArray(local, ea2) } ]); } + | _ -> (* invalid left-side expression *) + assert false + in + + ret + + | _ -> 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;; + +(* ******************************************* *) +(* CSharpSpecificSynf *) +(* ******************************************* *) + +(* + + Some CSharp-specific syntax filters that can run after ExprUnwrap + + dependencies: + Runs after ExprUnwrap + +*) + +module CSharpSpecificSynf = +struct + + let name = "csharp_specific" + + let priority = solve_deps name [ DAfter ExpressionUnwrap.priority; DAfter ObjectDeclMap.priority; DAfter ArrayDeclSynf.priority; DAfter HardNullableSynf.priority ] + + let get_cl_from_t t = + match follow t with + | TInst(cl,_) -> cl + | _ -> assert false + + let is_tparam t = + match follow t with + | TInst( { cl_kind = KTypeParameter _ }, _ ) -> true + | _ -> false + + let traverse gen runtime_cl = + let basic = gen.gcon.basic in + let tchar = match ( get_type gen (["cs"], "Char16") ) with | TTypeDecl t -> t | _ -> assert false in + let tchar = TType(tchar,[]) 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 clstring = match basic.tstring with | TInst(cl,_) -> cl | _ -> assert false in + + let is_struct t = (* not basic type *) + match follow t with + | TInst(cl, _) when Meta.has Meta.Struct cl.cl_meta -> true + | _ -> false + in + + let is_cl t = match gen.greal_type t with | TInst ( { cl_path = (["System"], "Type") }, [] ) -> true | _ -> false in + + let rec run e = + match e.eexpr with + + (* Std.int() *) + | TCall( + { eexpr = TField( _, FStatic({ cl_path = ([], "Std") }, { cf_name = "int" }) ) }, + [obj] + ) -> + run (mk_cast basic.tint obj) + (* end Std.int() *) + + (* TODO: change cf_name *) + | TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = "length" })) -> + { e with eexpr = TField(run ef, FDynamic "Length") } + | TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = "toLowerCase" })) -> + { e with eexpr = TField(run ef, FDynamic "ToLower") } + | TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = "toUpperCase" })) -> + { e with eexpr = TField(run ef, FDynamic "ToUpper") } + + | TCall( { eexpr = TField(_, FStatic({ cl_path = [], "String" }, { cf_name = "fromCharCode" })) }, [cc] ) -> + { e with eexpr = TNew(get_cl_from_t basic.tstring, [], [mk_cast tchar (run cc); mk_int gen 1 cc.epos]) } + | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("charAt" as field) })) }, args ) + | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("charCodeAt" as field) })) }, args ) + | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("indexOf" as field) })) }, args ) + | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("lastIndexOf" as field) })) }, args ) + | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("split" as field) })) }, args ) + | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("substring" as field) })) }, args ) + | TCall( { eexpr = TField(ef, FInstance({ cl_path = [], "String" }, { cf_name = ("substr" as field) })) }, args ) -> + { e with eexpr = TCall(mk_static_field_access_infer string_ext field e.epos [], [run ef] @ (List.map run args)) } + | TNew( { cl_path = ([], "String") }, [], [p] ) -> run p (* new String(myString) -> myString *) + + | TCast(expr, _) when is_int_float e.etype && not (is_int_float expr.etype) && not (is_null e.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 = basic.tint; + epos = expr.epos + } in + + if needs_cast then mk_cast e.etype ret else ret + | TCast(expr, _) when is_string e.etype -> + { e with eexpr = TCall( mk_static_field_access_infer runtime_cl "toString" expr.epos [], [run expr] ) } + | TBinop( (Ast.OpNotEq as op), e1, e2) + | TBinop( (Ast.OpEq as op), e1, e2) when is_string e1.etype || is_string e2.etype -> + let mk_ret e = match op with | Ast.OpNotEq -> { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) } | _ -> e in + mk_ret { e with + eexpr = TCall({ + eexpr = TField(mk_classtype_access clstring e.epos, FDynamic "Equals"); + etype = TFun(["obj1",false,basic.tstring; "obj2",false,basic.tstring], basic.tbool); + epos = e1.epos + }, [ run e1; run e2 ]) + } + + | TCast(expr, _) when is_tparam e.etype -> + let static = mk_static_field_access_infer (runtime_cl) "genericCast" e.epos [e.etype] in + { e with eexpr = TCall(static, [mk_local (alloc_var "$type_param" e.etype) expr.epos; run expr]); } + + | TBinop( (Ast.OpNotEq as op), e1, e2) + | TBinop( (Ast.OpEq as op), e1, e2) when is_struct e1.etype || is_struct e2.etype -> + let mk_ret e = match op with | Ast.OpNotEq -> { e with eexpr = TUnop(Ast.Not, Ast.Prefix, e) } | _ -> e in + mk_ret { e with + eexpr = TCall({ + eexpr = TField(run e1, FDynamic "Equals"); + etype = TFun(["obj1",false,t_dynamic;], basic.tbool); + epos = e1.epos + }, [ run e2 ]) + } + + | TBinop ( (Ast.OpEq as op), e1, e2 ) + | TBinop ( (Ast.OpNotEq as op), e1, e2 ) when is_cl e1.etype -> + let static = mk_static_field_access_infer (runtime_cl) "typeEq" e.epos [] in + let ret = { e with eexpr = TCall(static, [run e1; run e2]); } in + if op = Ast.OpNotEq then + { ret with eexpr = TUnop(Ast.Not, Ast.Prefix, ret) } + else + ret + + | _ -> 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;; + +(* Type Parameters Handling *) +let handle_type_params gen ifaces base_generic = + let basic = gen.gcon.basic in + (* + starting to set gtparam_cast. + *) + + (* NativeArray: the most important. *) + + (* + var new_arr = new NativeArray(old_arr.Length); + var i = -1; + while( i < old_arr.Length ) + { + new_arr[i] = (TO_T) old_arr[i]; + } + *) + + let native_arr_cl = get_cl ( get_type gen (["cs"], "NativeArray") ) in + + let get_narr_param t = match follow t with + | TInst({ cl_path = (["cs"], "NativeArray") }, [param]) -> param + | _ -> assert false + in + + let gtparam_cast_native_array e to_t = + let old_param = get_narr_param e.etype in + let new_param = get_narr_param to_t in + + let new_v = mk_temp gen "new_arr" to_t in + let i = mk_temp gen "i" basic.tint in + let old_len = mk_field_access gen e "Length" e.epos in + let obj_v = mk_temp gen "obj" t_dynamic in + let block = [ + { + eexpr = TVars( + [ + new_v, Some( { + eexpr = TNew(native_arr_cl, [new_param], [old_len] ); + etype = to_t; + epos = e.epos + } ); + i, Some( mk_int gen (-1) e.epos ) + ]); + etype = basic.tvoid; + epos = e.epos }; + { + eexpr = TWhile( + { + eexpr = TBinop( + Ast.OpLt, + { eexpr = TUnop(Ast.Increment, Ast.Prefix, mk_local i e.epos); etype = basic.tint; epos = e.epos }, + old_len + ); + etype = basic.tbool; + epos = e.epos + }, + { eexpr = TBlock [ + { + eexpr = TVars([obj_v, Some (mk_cast t_dynamic { eexpr = TArray(e, mk_local i e.epos); etype = old_param; epos = e.epos })]); + etype = basic.tvoid; + epos = e.epos + }; + { + eexpr = TIf({ + eexpr = TBinop(Ast.OpNotEq, mk_local obj_v e.epos, null e.etype e.epos); + etype = basic.tbool; + epos = e.epos + }, + { + eexpr = TBinop( + Ast.OpAssign, + { eexpr = TArray(mk_local new_v e.epos, mk_local i e.epos); etype = new_param; epos = e.epos }, + mk_cast new_param (mk_local obj_v e.epos) + ); + etype = new_param; + epos = e.epos + }, + None); + etype = basic.tvoid; + epos = e.epos + } + ]; etype = basic.tvoid; epos = e.epos }, + Ast.NormalWhile + ); + etype = basic.tvoid; + epos = e.epos; + }; + mk_local new_v e.epos + ] in + { eexpr = TBlock(block); etype = to_t; epos = e.epos } + in + + Hashtbl.add gen.gtparam_cast (["cs"], "NativeArray") gtparam_cast_native_array; + (* end set gtparam_cast *) + + TypeParams.RealTypeParams.default_config gen (fun e t -> gen.gcon.warning ("Cannot cast to " ^ (debug_type t)) e.epos; mk_cast t e) ifaces base_generic + +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 = "cs" (* 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"; "as"; "base"; "bool"; "break"; "byte"; "case"; "catch"; "char"; "checked"; "class"; + "const"; "continue"; "decimal"; "default"; "delegate"; "do"; "double"; "else"; "enum"; "event"; "explicit"; + "extern"; "false"; "finally"; "fixed"; "float"; "for"; "foreach"; "goto"; "if"; "implicit"; "in"; "int"; + "interface"; "internal"; "is"; "lock"; "long"; "namespace"; "new"; "null"; "object"; "operator"; "out"; "override"; + "params"; "private"; "protected"; "public"; "readonly"; "ref"; "return"; "sbyte"; "sealed"; "short"; "sizeof"; + "stackalloc"; "static"; "string"; "struct"; "switch"; "this"; "throw"; "true"; "try"; "typeof"; "uint"; "ulong"; + "unchecked"; "unsafe"; "ushort"; "using"; "virtual"; "volatile"; "void"; "while"; "add"; "ascending"; "by"; "descending"; + "dynamic"; "equals"; "from"; "get"; "global"; "group"; "into"; "join"; "let"; "on"; "orderby"; "partial"; + "remove"; "select"; "set"; "value"; "var"; "where"; "yield"]; + 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 "internal" cl_modifiers + (* no abstract for now | (":abstract",[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("abstract" :: cl_modifiers) + | (":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 ("sealed" :: cl_modifiers) + | (Meta.Unsafe,[],_) :: meta -> get_class_modifiers meta cl_type cl_access ("unsafe" :: 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 "internal" 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 -> 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 null_t = (get_cl (get_type gen (["haxe";"lang"],"Null")) ) in + + let runtime_cl = get_cl (get_type gen (["haxe";"lang"],"Runtime")) in + + let no_root = Common.defined gen.gcon Define.NoRoot in + + let change_clname n = n in + + let change_id name = try Hashtbl.find reserved name with | Not_found -> name in + + let change_ns md = if no_root then + function + | [] when is_hxgen md -> ["haxe";"root"] + | ns -> List.map change_id ns + else List.map change_id 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") },[]) + | TType ({ t_path = [],"UInt" },[]) + | TAbstract ({ a_path = [],"UInt" },[]) + | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[]) + | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) + | TType ({ t_path = ["haxe";"_Int64"], "NativeUInt64" },[]) + | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeUInt64" },[]) + | TType ({ t_path = ["cs"],"UInt64" },[]) + | TAbstract ({ a_path = ["cs"],"UInt64" },[]) + | TType ({ t_path = ["cs"],"UInt8" },[]) + | TAbstract ({ a_path = ["cs"],"UInt8" },[]) + | TType ({ t_path = ["cs"],"Int8" },[]) + | TAbstract ({ a_path = ["cs"],"Int8" },[]) + | TType ({ t_path = ["cs"],"Int16" },[]) + | TAbstract ({ a_path = ["cs"],"Int16" },[]) + | TType ({ t_path = ["cs"],"UInt16" },[]) + | TAbstract ({ a_path = ["cs"],"UInt16" },[]) + | TType ({ t_path = ["cs"],"Char16" },[]) + | TAbstract ({ a_path = ["cs"],"Char16" },[]) + | TType ({ t_path = ["cs"],"Ref" },_) + | TAbstract ({ a_path = ["cs"],"Ref" },_) + | TType ({ t_path = ["cs"],"Out" },_) + | TAbstract ({ a_path = ["cs"],"Out" },_) + | TType ({ t_path = [],"Single" },[]) + | TAbstract ({ a_path = [],"Single" },[]) -> Some t + | 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 module_s md = + let path = (t_infos md).mt_path in + match path with + | ([], "String") -> "string" + | ([], "Null") -> path_s (change_ns md ["haxe"; "lang"], change_clname "Null") + | (ns,clname) -> path_s (change_ns md ns, change_clname clname) + in + + let ifaces = Hashtbl.create 1 in + + let ti64 = match ( get_type gen (["haxe";"_Int64"], "NativeInt64") ) with | TTypeDecl t -> TType(t,[]) | TAbstractDecl a -> TAbstract(a,[]) | _ -> assert false in + + let ttype = get_cl ( get_type gen (["System"], "Type") ) in + + let has_tdyn tl = + List.exists (fun t -> match follow t with + | TDynamic _ | TMono _ -> true + | _ -> false + ) tl + in + + let rec real_type t = + let t = gen.gfollow#run_f t in + let ret = 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" }, _ ) + | TAbstract( { a_path = [],"Enum" }, _ ) + | TInst( { cl_path = ([], "Class") }, _ ) + | TInst( { cl_path = ([], "Enum") }, _ ) -> TInst(ttype,[]) + | TEnum(_, []) + | TInst(_, []) -> t + | TInst(cl, params) when + has_tdyn params && + Hashtbl.mem ifaces cl.cl_path -> + TInst(Hashtbl.find ifaces cl.cl_path, []) + | TEnum(e, params) -> + TEnum(e, List.map (fun _ -> t_dynamic) params) + | TInst(cl, params) when Meta.has Meta.Enum cl.cl_meta -> + TInst(cl, List.map (fun _ -> t_dynamic) params) + | TInst(cl, params) -> TInst(cl, change_param_type (TClassDecl cl) params) + | TType({ t_path = ([], "Null") }, [t]) -> + (* + Null<> handling is a little tricky. + It will only change to haxe.lang.Null<> when the actual type is non-nullable or a type parameter + It works on cases such as Hash returning Null since cast_detect will invoke real_type at the original type, + Null, which will then return the type haxe.lang.Null<> + *) + (match real_type t with + | TInst( { cl_kind = KTypeParameter _ }, _ ) -> TInst(null_t, [t]) + | _ when is_cs_basic_type t -> TInst(null_t, [t]) + | _ -> real_type t) + | TAbstract _ + | TType _ -> t + | TAnon (anon) when (match !(anon.a_status) with | Statics _ | EnumStatics _ | AbstractStatics _ -> true | _ -> false) -> t + | TFun _ -> TInst(fn_cl,[]) + | _ -> t_dynamic + in + ret + and + + (* + On hxcs, the only type parameters allowed to be declared are the basic c# types. + That's made like this to avoid casting problems when type parameters in this case + add nothing to performance, since the memory layout is always the same. + + To avoid confusion between Generic (which has a different meaning in hxcs AST), + all those references are using dynamic_anon, which means Generic<{}> + *) + change_param_type md tl = + let is_hxgeneric = (TypeParams.RealTypeParams.is_hxgeneric md) in + let ret t = match is_hxgeneric, real_type t with + | false, _ -> t + (* + Because Null<> types need a special compiler treatment for many operations (e.g. boxing/unboxing), + Null<> type parameters will be transformed into Dynamic. + *) + | true, TInst ( { cl_path = (["haxe";"lang"], "Null") }, _ ) -> dynamic_anon + | true, TInst ( { cl_kind = KTypeParameter _ }, _ ) -> t + | true, TInst _ + | true, TEnum _ + | true, TAbstract _ when is_cs_basic_type t -> t + | true, TDynamic _ -> t + | true, _ -> dynamic_anon + in + if is_hxgeneric && List.exists (fun t -> match follow t with | TDynamic _ -> true | _ -> false) tl then + List.map (fun _ -> t_dynamic) tl + else + List.map ret tl + in + + let is_dynamic t = match real_type t with + | TMono _ | TDynamic _ -> true + | TAnon anon -> + (match !(anon.a_status) with + | EnumStatics _ | Statics _ -> false + | _ -> true + ) + | _ -> false + in + + let rec t_s t = + match real_type t with + (* basic types *) + | TEnum ({ e_path = ([], "Bool") }, []) + | TAbstract ({ a_path = ([], "Bool") },[]) -> "bool" + | TEnum ({ e_path = ([], "Void") }, []) + | TAbstract ({ a_path = ([], "Void") },[]) -> "object" + | TInst ({ cl_path = ([],"Float") },[]) + | TAbstract ({ a_path = ([],"Float") },[]) -> "double" + | TInst ({ cl_path = ([],"Int") },[]) + | TAbstract ({ a_path = ([],"Int") },[]) -> "int" + | TType ({ t_path = [],"UInt" },[]) + | TAbstract ({ a_path = [],"UInt" },[]) -> "uint" + | TType ({ t_path = ["haxe";"_Int64"], "NativeInt64" },[]) + | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeInt64" },[]) -> "long" + | TType ({ t_path = ["haxe";"_Int64"], "NativeUInt64" },[]) + | TAbstract ({ a_path = ["haxe";"_Int64"], "NativeUInt64" },[]) -> "ulong" + | TType ({ t_path = ["cs"],"UInt64" },[]) + | TAbstract ({ a_path = ["cs"],"UInt64" },[]) -> "ulong" + | TType ({ t_path = ["cs"],"UInt8" },[]) + | TAbstract ({ a_path = ["cs"],"UInt8" },[]) -> "byte" + | TType ({ t_path = ["cs"],"Int8" },[]) + | TAbstract ({ a_path = ["cs"],"Int8" },[]) -> "sbyte" + | TType ({ t_path = ["cs"],"Int16" },[]) + | TAbstract ({ a_path = ["cs"],"Int16" },[]) -> "short" + | TType ({ t_path = ["cs"],"UInt16" },[]) + | TAbstract ({ a_path = ["cs"],"UInt16" },[]) -> "ushort" + | TType ({ t_path = ["cs"],"Char16" },[]) + | TAbstract ({ a_path = ["cs"],"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 = ([], "Dynamic") },_) + | TAbstract ({ a_path = ([], "Dynamic") },_) -> "object" + | TType ({ t_path = ["cs"],"Out" },[t]) + | TAbstract ({ a_path = ["cs"],"Out" },[t]) + | TType ({ t_path = ["cs"],"Ref" },[t]) + | TAbstract ({ a_path = ["cs"],"Ref" },[t]) -> t_s t + | TInst({ cl_path = (["cs"], "NativeArray") }, [param]) -> + let rec check_t_s t = + match real_type t with + | TInst({ cl_path = (["cs"], "NativeArray") }, [param]) -> + (check_t_s param) ^ "[]" + | _ -> t_s (run_follow gen t) + in + (check_t_s param) ^ "[]" + | TInst({ cl_path = (["cs"], "Pointer") },[t]) + | TAbstract({ a_path = (["cs"], "Pointer") },[t])-> + t_s t ^ "*" + (* end of basic types *) + | TInst ({ cl_kind = KTypeParameter _; cl_path=p }, []) -> snd p + | TMono r -> (match !r with | None -> "object" | Some t -> t_s (run_follow gen t)) + | TInst ({ cl_path = [], "String" }, []) -> "string" + | TEnum (e, params) -> ("global::" ^ (module_s (TEnumDecl e))) + | TInst (cl, _ :: _) when Meta.has Meta.Enum cl.cl_meta -> + "global::" ^ module_s (TClassDecl cl) + | TInst (({ cl_path = p } as cl), params) -> (path_param_s (TClassDecl cl) p params) + | TType (({ t_path = p } as t), params) -> (path_param_s (TTypeDecl t) p params) + | TAnon (anon) -> + (match !(anon.a_status) with + | Statics _ | EnumStatics _ -> "System.Type" + | _ -> "object") + | TDynamic _ -> "object" + | TAbstract(a,pl) when a.a_impl <> None -> + t_s (Codegen.Abstract.get_underlying_type a pl) + (* 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 path_param_s md path params = + match params with + | [] -> "global::" ^ module_s md + | _ -> sprintf "%s<%s>" ("global::" ^ module_s md) (String.concat ", " (List.map (fun t -> t_s t) (change_param_type md params))) + in + + let rett_s t = + match t with + | TEnum ({e_path = ([], "Void")}, []) + | TAbstract ({ a_path = ([], "Void") },[]) -> "void" + | _ -> t_s t + in + + let argt_s t = + match t with + | TType ({ t_path = (["cs"], "Ref") }, [t]) + | TAbstract ({ a_path = (["cs"], "Ref") },[t]) -> "ref " ^ t_s t + | TType ({ t_path = (["cs"], "Out") }, [t]) + | TAbstract ({ a_path = (["cs"], "Out") },[t]) -> "out " ^ t_s t + | _ -> t_s 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 + | 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 md = + let md = follow_module (gen.gfollow#run_f) md in + match md with + | TClassDecl ({ cl_types = [] } as cl) -> + t_s (TInst(cl,[])) + | TClassDecl (cl) when not (is_hxgen md) -> + t_s (TInst(cl,List.map (fun t -> t_dynamic) cl.cl_types)) + | TEnumDecl ({ e_types = [] } as e) -> + t_s (TEnum(e,[])) + | TEnumDecl (e) when not (is_hxgen md) -> + t_s (TEnum(e,List.map (fun t -> t_dynamic) e.e_types)) + | TClassDecl cl -> + t_s (TInst(cl,[])) + | TEnumDecl e -> + t_s (TEnum(e,[])) + | TTypeDecl t -> + t_s (TType(t, List.map (fun t -> t_dynamic) t.t_types)) + | TAbstractDecl a -> + t_s (TAbstract(a, List.map(fun t -> t_dynamic) a.a_types)) + in + + let rec ensure_local e explain = + match e.eexpr with + | TLocal _ -> e + | TCast(e,_) + | TParenthesis e -> ensure_local e explain + | _ -> gen.gcon.error ("This function argument " ^ explain ^ " must be a local variable.") e.epos; e + in + + let is_pointer t = match follow t with + | TInst({ cl_path = (["cs"], "Pointer") }, _) + | TAbstract ({ a_path = (["cs"], "Pointer") },_) -> + true + | _ -> + false in + + let last_line = ref (-1) in + let line_directive = + if Common.defined gen.gcon Define.RealPosition then + fun w p -> () + else fun w 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 Common.get_full_path 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 + + 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 expr_s w e = + last_line := -1; + 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 -> + write w (Int32.to_string i32); + (*match real_type e.etype with + | TType( { t_path = (["haxe";"_Int64"], "NativeInt64") }, [] ) -> write w "L"; + | _ -> () + *) + | TFloat s -> + write w s; + (if String.get s (String.length s - 1) = '.' then write w "0"); + (*match real_type e.etype with + | TType( { t_path = ([], "Single") }, [] ) -> write w "f" + | _ -> () + *) + | TString s -> + write w "\""; + write w (escape s); + write w "\"" + | TBool b -> write w (if b then "true" else "false") + | TNull -> + write w "default("; + write w (t_s e.etype); + write w ")" + | TThis -> write w "this" + | TSuper -> write w "base") + | TLocal { v_name = "__sbreak__" } -> write w "break" + | TLocal { v_name = "__undefined__" } -> + write w (t_s (TInst(runtime_cl, List.map (fun _ -> t_dynamic) runtime_cl.cl_types))); + write w ".undefined"; + | TLocal { v_name = "__typeof__" } -> write w "typeof" + | TLocal { v_name = "__sizeof__" } -> write w "sizeof" + | TLocal var -> + write_id w var.v_name + | TField (_, FEnum(e, ef)) -> + let s = ef.ef_name in + print w "%s." ("global::" ^ module_s (TEnumDecl e)); 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 ({ eexpr = TTypeExpr mt }, s) -> + (match mt with + | TClassDecl { cl_path = (["haxe"], "Int64") } -> write w ("global::" ^ module_s mt) + | TClassDecl { cl_path = (["haxe"], "Int32") } -> write w ("global::" ^ module_s mt) + | TClassDecl { cl_interface = true } -> + write w ("global::" ^ module_s mt); + write w "__Statics_"; + | TClassDecl cl -> write w (t_s (TInst(cl, List.map (fun _ -> t_empty) cl.cl_types))) + | TEnumDecl en -> write w (t_s (TEnum(en, List.map (fun _ -> t_empty) en.e_types))) + | TTypeDecl td -> write w (t_s (gen.gfollow#run_f (TType(td, List.map (fun _ -> t_empty) td.t_types)))) + | TAbstractDecl a -> write w (t_s (TAbstract(a, List.map (fun _ -> t_empty) a.a_types))) + ); + write w "."; + write_field w (field_name s) + | TField (e, s) -> + expr_s w e; write w "."; write_field w (field_name s) + | TTypeExpr mt -> + (match mt with + | TClassDecl { cl_path = (["haxe"], "Int64") } -> write w ("global::" ^ module_s mt) + | TClassDecl { cl_path = (["haxe"], "Int32") } -> write w ("global::" ^ module_s mt) + | TClassDecl cl -> write w (t_s (TInst(cl, List.map (fun _ -> t_dynamic) cl.cl_types))) + | TEnumDecl en -> write w (t_s (TEnum(en, List.map (fun _ -> t_dynamic) en.e_types))) + | TTypeDecl td -> write w (t_s (gen.gfollow#run_f (TType(td, List.map (fun _ -> t_dynamic) td.t_types)))) + | TAbstractDecl a -> write w (t_s (TAbstract(a, List.map (fun _ -> t_dynamic) a.a_types))) + ) + | TParenthesis e -> + write w "("; expr_s w e; write w ")" + | TArrayDecl el -> + print w "new %s" (t_s 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 "}" + | TCall ({ eexpr = TLocal( { v_name = "__is__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) -> + write w "( "; + expr_s w expr; + write w " is "; + write w (md_s md); + write w " )" + | TCall ({ eexpr = TLocal( { v_name = "__as__" } ) }, [ expr; { eexpr = TTypeExpr(md) } ] ) -> + write w "( "; + expr_s w expr; + write w " as "; + write w (md_s md); + write w " )" + | TCall ({ eexpr = TLocal( { v_name = "__as__" } ) }, [ expr ] ) -> + write w "( "; + expr_s w expr; + write w " as "; + write w (t_s e.etype); + write w " )"; + | TCall ({ eexpr = TLocal( { v_name = "__cs__" } ) }, [ { eexpr = TConst(TString(s)) } ] ) -> + write w s + | TCall ({ eexpr = TLocal( { v_name = "__unsafe__" } ) }, [ e ] ) -> + write w "unsafe"; + expr_s w (mk_block e) + | TCall ({ eexpr = TLocal( { v_name = "__checked__" } ) }, [ e ] ) -> + write w "checked"; + expr_s w (mk_block e) + | TCall ({ eexpr = TLocal( { v_name = "__lock__" } ) }, [ eobj; eblock ] ) -> + write w "lock("; + expr_s w eobj; + write w ")"; + expr_s w (mk_block eblock) + | TCall ({ eexpr = TLocal( { v_name = "__fixed__" } ) }, [ e ] ) -> + let first = ref true in + let rec loop = function + | ({ eexpr = TVars([v, Some({ eexpr = TCast( { eexpr = TCast(e, _) }, _) }) ]) } as expr) :: tl when is_pointer v.v_type -> + (if !first then first := false); + write w "fixed("; + let vf = mk_temp gen "fixed" v.v_type in + expr_s w { expr with eexpr = TVars([vf, Some e]) }; + write w ")"; + begin_block w; + expr_s w { expr with eexpr = TVars([v, Some (mk_local vf expr.epos)]) }; + write w ";"; + loop tl; + end_block w + | el when not !first -> + expr_s w { e with eexpr = TBlock el } + | _ -> + trace (debug_expr e); + gen.gcon.error "Invalid 'fixed' keyword format" e.epos + in + (match e.eexpr with + | TBlock bl -> loop bl + | _ -> + trace "not block"; + trace (debug_expr e); + gen.gcon.error "Invalid 'fixed' keyword format" e.epos + ) + | TCall ({ eexpr = TLocal( { v_name = "__addressOf__" } ) }, [ e ] ) -> + let e = ensure_local e "for addressOf" in + write w "&"; + expr_s w e + | TCall ({ eexpr = TLocal( { v_name = "__valueOf__" } ) }, [ e ] ) -> + write w "*("; + expr_s w e; + write w ")" + | TCall ({ eexpr = TLocal( { v_name = "__goto__" } ) }, [ { eexpr = TConst(TInt v) } ] ) -> + print w "goto label%ld" v + | TCall ({ eexpr = TLocal( { v_name = "__label__" } ) }, [ { eexpr = TConst(TInt v) } ] ) -> + print w "label%ld: {}" v + | TCall ({ eexpr = TLocal( { v_name = "__rethrow__" } ) }, _) -> + write w "throw" + (* operator overloading handling *) + | TCall({ eexpr = TField(ef, FInstance(cl,{ cf_name = "__get" })) }, [idx]) when not (is_hxgen (TClassDecl cl)) -> + expr_s w { e with eexpr = TArray(ef, idx) } + | TCall({ eexpr = TField(ef, FInstance(cl,{ cf_name = "__set" })) }, [idx; v]) when not (is_hxgen (TClassDecl cl)) -> + expr_s w { e with eexpr = TBinop(Ast.OpAssign, { e with eexpr = TArray(ef, idx) }, v) } + | TCall({ eexpr = TField(ef, FStatic(_,cf)) }, el) when PMap.mem cf.cf_name binops_names -> + let _, elr = extract_tparams [] el in + (match elr with + | [e1;e2] -> + expr_s w { e with eexpr = TBinop(PMap.find cf.cf_name binops_names, e1, e2) } + | _ -> do_call w e el) + | TCall({ eexpr = TField(ef, FStatic(_,cf)) }, el) when PMap.mem cf.cf_name unops_names -> + (match extract_tparams [] el with + | _, [e1] -> + expr_s w { e with eexpr = TUnop(PMap.find cf.cf_name unops_names, Ast.Prefix,e1) } + | _ -> do_call w e el) + | TCall (e, el) -> + do_call w e el + | TNew (({ cl_path = (["cs"], "NativeArray") } as cl), params, [ size ]) -> + let rec check_t_s t times = + match real_type t with + | TInst({ cl_path = (["cs"], "NativeArray") }, [param]) -> + (check_t_s param (times+1)) + | _ -> + print w "new %s[" (t_s (run_follow gen 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 (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 (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 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; + List.iter (fun e -> + line_directive w e.epos; + in_value := false; + 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); + List.iter (fun (var, e) -> + print w "catch (%s %s)" (t_s 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.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 + ) + and do_call w e el = + let params, el = extract_tparams [] el in + let params = List.rev params 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 (t_s t); + acc + 1 + ) 0 (change_param_type md params)); + write w ">" + ); + + let rec loop acc elist tlist = + match elist, tlist with + | e :: etl, (_,_,t) :: ttl -> + (if acc <> 0 then write w ", "); + (match real_type t with + | TType({ t_path = (["cs"], "Ref") }, _) + | TAbstract ({ a_path = (["cs"], "Ref") },_) -> + let e = ensure_local e "of type cs.Ref" in + write w "ref "; + expr_s w e + | TType({ t_path = (["cs"], "Out") }, _) + | TAbstract ({ a_path = (["cs"], "Out") },_) -> + let e = ensure_local e "of type cs.Out" in + write w "out "; + expr_s w e + | _ -> + expr_s w e + ); + loop (acc + 1) etl ttl + | e :: etl, [] -> + (if acc <> 0 then write w ", "); + expr_s w e; + loop (acc + 1) etl [] + | _ -> () + in + write w "("; + let ft = match follow e.etype with + | TFun(args,_) -> args + | _ -> [] + in + + loop 0 el ft; + + write w ")" + 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 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 -> try + let binop = PMap.find name binops_names in + "operator " ^ s_binop binop, false, false + with | Not_found -> try + let unop = PMap.find name unops_names in + "operator " ^ s_unop unop, false, false + with | Not_found -> + name, false, false + in + let rec loop_static cl = + match is_static, cl.cl_super with + | false, _ -> [] + | true, None -> [] + | true, Some(cl,_) -> + (try + let cf2 = PMap.find cf.cf_name cl.cl_statics in + Gencommon.CastDetect.type_eq gen EqStrict cf.cf_type cf2.cf_type; + ["new"] + with + | Not_found | Unify_error _ -> + loop_static cl + ) + in + let modf = loop_static cl 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 + let modifiers = modifiers @ modf in + (match cf.cf_expr with + | Some e -> + print w "%s %s%s %s %s = " access (if is_static then "static " else "") (String.concat " " modifiers) (t_s (run_follow gen cf.cf_type)) (change_field name); + expr_s w e; + write w ";" + | None -> + print w "%s %s%s %s %s;" access (if is_static then "static " else "") (String.concat " " modifiers) (t_s (run_follow gen cf.cf_type)) (change_field name) + ) + 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 = not is_final && match mkind with | MethInline -> false | _ when not is_new -> true | _ -> false in + let is_virtual = if not is_virtual || Meta.has Meta.Final cf.cf_meta then false else is_virtual in + let is_override = List.memq cf cl.cl_overrides in + let is_override = is_override || match cf.cf_name, follow cf.cf_type with + | "Equals", TFun([_,_,targ], tret) -> + (match follow targ, follow tret with + | TDynamic _, TEnum({ e_path = ([], "Bool") }, []) + | TDynamic _, TAbstract({ a_path = ([], "Bool") }, []) -> true + | _ -> false) + | "GetHashCode", TFun([],_) -> true + | _ -> false + in + + let is_virtual = is_virtual && not (Meta.has Meta.Final cl.cl_meta) && not (is_interface) in + let visibility = if is_interface then "" else "public" in + + let visibility, modifiers = get_fun_modifiers cf.cf_meta visibility [] in + let modifiers = modifiers @ modf 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 "override " else if is_virtual then "virtual " 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 ret_type, args = match follow cf_type with | TFun (strbtl, t) -> (t, strbtl) | _ -> assert false in + + (* public static void funcName *) + print w "%s %s %s %s %s" (visibility) v_n (String.concat " " modifiers) (if is_new then "" else rett_s (run_follow gen ret_type)) (change_field name); + let params, params_ext = get_string_params cf.cf_params in + (* (string arg1, object arg2) with T : object *) + (match cf.cf_expr with + | Some { eexpr = TFunction tf } -> + print w "%s(%s)%s" (params) (String.concat ", " (List.map2 (fun (var, _) (_,_,t) -> sprintf "%s %s" (argt_s (run_follow gen t)) (change_id var.v_name)) tf.tf_args args)) (params_ext) + | _ -> + print w "%s(%s)%s" (params) (String.concat ", " (List.map (fun (name, _, t) -> sprintf "%s %s" (argt_s (run_follow gen t)) (change_id name)) args)) (params_ext) + ); + 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 + match expr.eexpr with + | TBlock(bl) -> + let super_call, rest = get_super_call bl in + (match super_call with + | None -> () + | Some sc -> + write w " : "; + let t = Common.timer "expression to string" in + expr_s w sc; + t() + ); + begin_block w; + write w "unchecked "; + let t = Common.timer "expression to string" in + expr_s w { expr with eexpr = TBlock(rest) }; + t(); + write w "#line default"; + end_block w; + | _ -> assert false + end else begin + begin_block w; + write w "unchecked "; + let t = Common.timer "expression to string" in + expr_s w expr; + t(); + write w "#line default"; + end_block w; + end) + | (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 check_special_behaviors w cl = match cl.cl_kind with + | KAbstractImpl _ -> () + | _ -> + (* get/set pairs *) + let pairs = ref PMap.empty in + (try + let get = PMap.find "__get" cl.cl_fields in + List.iter (fun cf -> + let args,ret = get_fun cf.cf_type in + match args with + | [_,_,idx] -> pairs := PMap.add (t_s idx) ( t_s ret, Some cf, None ) !pairs + | _ -> gen.gcon.warning "The __get function must have exactly one argument (the index)" cf.cf_pos + ) (get :: get.cf_overloads) + with | Not_found -> ()); + (try + let set = PMap.find "__set" cl.cl_fields in + List.iter (fun cf -> + let args, ret = get_fun cf.cf_type in + match args with + | [_,_,idx; _,_,v] -> (try + let vt, g, _ = PMap.find (t_s idx) !pairs in + let tvt = t_s v in + if vt <> tvt then gen.gcon.warning "The __get function of same index has a different type from this __set function" cf.cf_pos; + pairs := PMap.add (t_s idx) (vt, g, Some cf) !pairs + with | Not_found -> + pairs := PMap.add (t_s idx) (t_s v, None, Some cf) !pairs) + | _ -> + gen.gcon.warning "The __set function must have exactly two arguments (index, value)" cf.cf_pos + ) (set :: set.cf_overloads) + with | Not_found -> ()); + PMap.iter (fun idx (v, get, set) -> + print w "public %s this[%s index]" v idx; + begin_block w; + (match get with + | None -> () + | Some _ -> + write w "get"; + begin_block w; + write w "return this.__get(index);"; + end_block w); + (match set with + | None -> () + | Some _ -> + write w "set"; + begin_block w; + write w "this.__set(index,value);"; + end_block w); + end_block w) !pairs; + (if not (PMap.is_empty !pairs) then try + let get = PMap.find "__get" cl.cl_fields in + let idx_t, v_t = match follow get.cf_type with + | TFun([_,_,arg_t],ret_t) -> + t_s (run_follow gen arg_t), t_s (run_follow gen ret_t) + | _ -> gen.gcon.error "The __get function must be a function with one argument. " get.cf_pos; assert false + in + List.iter (fun (cl,args) -> + match cl.cl_array_access with + | None -> () + | Some t -> + let changed_t = apply_params cl.cl_types (List.map (fun _ -> t_dynamic) cl.cl_types) t in + let t_as_s = t_s (run_follow gen changed_t) in + print w "%s %s.this[int key]" t_as_s (t_s (TInst(cl, args))); + begin_block w; + write w "get"; + begin_block w; + print w "return ((%s) this.__get(key));" t_as_s; + end_block w; + write w "set"; + begin_block w; + print w "this.__set(key, (%s) value);" v_t; + end_block w; + end_block w; + newline w; + newline w + ) cl.cl_implements + with | Not_found -> ()); + if cl.cl_interface && is_hxgen (TClassDecl cl) && is_some cl.cl_array_access then begin + let changed_t = apply_params cl.cl_types (List.map (fun _ -> t_dynamic) cl.cl_types) (get cl.cl_array_access) in + print w "%s this[int key]" (t_s (run_follow gen changed_t)); + begin_block w; + write w "get;"; + newline w; + write w "set;"; + newline w; + end_block w; + newline w; + newline w + end; + (try + if cl.cl_interface then raise Not_found; + let cf = PMap.find "toString" cl.cl_fields in + (if List.exists (fun c -> c.cf_name = "toString") cl.cl_overrides then raise Not_found); + (match cf.cf_type with + | TFun([], ret) -> + (match real_type ret with + | TInst( { cl_path = ([], "String") }, []) -> + write w "public override string ToString()"; + begin_block w; + write w "return this.toString();"; + end_block w; + newline w; + newline w + | _ -> + gen.gcon.error "A toString() function should return a String!" cf.cf_pos + ) + | _ -> () + ) + with | Not_found -> ()); + (* properties * + let handle_prop static f = + match f.cf_kind with + | Method _ -> () + | Var v when not (Type.is_extern_field f) -> () + | Var v -> + let prop acc = match acc with + | AccNo | AccNever | AccCall -> true + | _ -> false + in + if prop v.v_read && prop v.v_write && (v.v_read = AccCall || v.v_write = AccCall) then begin + let this = if static then + mk_classtype_access cl f.cf_pos + else + { eexpr = TConst TThis; etype = TInst(cl,List.map snd cl.cl_types); epos = f.cf_pos } + in + print w "public %s%s %s" (if static then "static " else "") (t_s f.cf_type) f.cf_name; + begin_block w; + (match v.v_read with + | AccCall -> + write w "get"; + begin_block w; + write w "return "; + expr_s w this; + print w ".get_%s();" f.cf_name; + end_block w + | _ -> ()); + (match v.v_write with + | AccCall -> + write w "set"; + begin_block w; + expr_s w this; + print w ".set_%s(value);" f.cf_name; + end_block w + | _ -> ()); + end_block w; + end + in + List.iter (handle_prop true) cl.cl_ordered_statics; + List.iter (handle_prop false) cl.cl_ordered_fields *) + in + + let gen_class w cl = + write w "#pragma warning disable 109, 114, 219, 429, 168, 162"; + newline w; + let should_close = match change_ns (TClassDecl cl) (fst (cl.cl_path)) with + | [] -> false + | ns -> + print w "namespace %s" (String.concat "." ns); + begin_block w; + true + in + + let is_main = + match gen.gcon.main_class with + | Some ( (_,"Main") as path) when path = cl.cl_path && not cl.cl_interface -> + (* + for cases where the main class is called Main, there will be a problem with creating the entry point there. + In this special case, a special entry point class will be created + *) + write w "public class EntryPoint__Main"; + begin_block w; + write w "public static void Main()"; + begin_block w; + (if Hashtbl.mem gen.gtypes (["cs"], "Boot") then write w "cs.Boot.init();"; newline w); + expr_s w { eexpr = TTypeExpr(TClassDecl cl); etype = t_dynamic; epos = Ast.null_pos }; + write w ".main();"; + end_block w; + end_block w; + false + | Some path when path = cl.cl_path && not cl.cl_interface -> true + | _ -> false + in + + let clt, access, modifiers = get_class_modifiers cl.cl_meta (if cl.cl_interface then "interface" else "class") "public" [] in + let is_final = clt = "struct" || 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, params_ext = get_string_params cl.cl_types in + let extends_implements = (match cl.cl_super with | None -> [] | Some (cl,p) -> [path_param_s (TClassDecl cl) cl.cl_path p]) @ (List.map (fun (cl,p) -> path_param_s (TClassDecl cl) cl.cl_path p) cl.cl_implements) in + (match extends_implements with + | [] -> print w "%s %s" params params_ext + | _ -> print w "%s : %s %s" params (String.concat ", " extends_implements) params_ext); + (* 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 meta = + match meta with + | [] -> () + | (Meta.ClassCode, [Ast.EConst (Ast.String contents),_],_) :: tl -> + write w contents + | _ :: tl -> loop tl + in + loop cl.cl_meta; + + if is_main then begin + write w "public static void Main()"; + begin_block w; + (if Hashtbl.mem gen.gtypes (["cs"], "Boot") then write w "cs.Boot.init();"; newline w); + write w "main();"; + end_block w + end; + + (match cl.cl_init with + | None -> () + | Some init -> + print w "static %s() " (snd cl.cl_path); + 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; + check_special_behaviors w cl; + end_block w; + if cl.cl_interface && cl.cl_ordered_statics <> [] then begin + print w "public class %s__Statics_" (snd cl.cl_path); + begin_block w; + List.iter (gen_class_field w true { cl with cl_interface = false } is_final) cl.cl_ordered_statics; + end_block w + end; + if should_close then end_block w + in + + + let gen_enum w e = + let should_close = match change_ns (TEnumDecl e) (fst e.e_path) with + | [] -> false + | ns -> + print w "namespace %s" (String.concat "." ns); + begin_block w; + true + 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 + (if no_root && len w = 0 then write w "using haxe.root;"; newline w;); + gen_class w cl; + newline w; + newline w + end; + (not cl.cl_extern) + | TEnumDecl e -> + if not e.e_extern then begin + (if no_root && len w = 0 then write w "using haxe.root;"; newline w;); + gen_enum w e; + newline w; + newline w + end; + (not e.e_extern) + | TAbstractDecl _ + | TTypeDecl _ -> + false + in + + let module_gen w md_def = + List.fold_left (fun should md -> module_type_gen w md or should) false md_def.m_types + in + + (* generate source code *) + init_ctx gen; + + Hashtbl.add gen.gspecial_vars "__rethrow__" true; + Hashtbl.add gen.gspecial_vars "__typeof__" true; + 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 "__as__" true; + Hashtbl.add gen.gspecial_vars "__cs__" true; + + Hashtbl.add gen.gspecial_vars "__checked__" true; + Hashtbl.add gen.gspecial_vars "__lock__" true; + Hashtbl.add gen.gspecial_vars "__fixed__" true; + Hashtbl.add gen.gspecial_vars "__unsafe__" true; + Hashtbl.add gen.gspecial_vars "__addressOf__" true; + Hashtbl.add gen.gspecial_vars "__valueOf__" true; + Hashtbl.add gen.gspecial_vars "__sizeof__" true; + + Hashtbl.add gen.gsupported_conversions (["haxe"; "lang"], "Null") (fun t1 t2 -> true); + let last_needs_box = gen.gneeds_box in + gen.gneeds_box <- (fun t -> match t with | TInst( { cl_path = (["haxe"; "lang"], "Null") }, _ ) -> true | _ -> last_needs_box t); + + 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));*) + + let tp_v = alloc_var "$type_param" t_dynamic in + let mk_tp t pos = { eexpr = TLocal(tp_v); etype = t; epos = pos } in + TypeParams.configure gen (fun ecall efield params elist -> + match efield.eexpr with + | TField(_, FEnum _) -> + { ecall with eexpr = TCall(efield, elist) } + | _ -> + { ecall with eexpr = TCall(efield, (List.map (fun t -> mk_tp t ecall.epos ) params) @ elist) } + ); + + HardNullableSynf.configure gen (HardNullableSynf.traverse gen + (fun e -> + match real_type e.etype with + | TInst({ cl_path = (["haxe";"lang"], "Null") }, [t]) -> + { (mk_field_access gen e "value" e.epos) with etype = t } + | _ -> + trace (debug_type e.etype); gen.gcon.error "This expression is not a Nullable expression" e.epos; assert false + ) + (fun v t has_value -> + match has_value, real_type v.etype with + | true, TDynamic _ | true, TAnon _ | true, TMono _ -> + { + eexpr = TCall(mk_static_field_access_infer null_t "ofDynamic" v.epos [t], [mk_tp t v.epos; v]); + etype = TInst(null_t, [t]); + epos = v.epos + } + | _ -> + { eexpr = TNew(null_t, [t], [gen.ghandle_cast t v.etype v; { eexpr = TConst(TBool has_value); etype = gen.gcon.basic.tbool; epos = v.epos } ]); etype = TInst(null_t, [t]); epos = v.epos } + ) + (fun e -> + { + eexpr = TCall( + { (mk_field_access gen { (mk_paren e) with etype = real_type e.etype } "toDynamic" e.epos) with etype = TFun([], t_dynamic) }, + []); + etype = t_dynamic; + epos = e.epos + } + ) + (fun e -> + mk_field_access gen { e with etype = real_type e.etype } "hasValue" e.epos + ) + (fun e1 e2 -> + { + eexpr = TCall( + mk_field_access gen e1 "Equals" e1.epos, + [e2]); + etype = basic.tbool; + epos = e1.epos; + } + ) + true + false + ); + + + let explicit_fn_name c tl fname = + path_param_s (TClassDecl c) c.cl_path tl ^ "." ^ fname + in + FixOverrides.configure ~explicit_fn_name:explicit_fn_name gen; + NormalizeType.configure gen; + + AbstractImplementationFix.configure gen; + + IteratorsInterface.configure gen (fun e -> e); + + OverrideFix.configure gen; + + ClosuresToClass.configure gen (ClosuresToClass.default_implementation closure_t (get_cl (get_type gen (["haxe";"lang"],"Function")) )); + + EnumToClass.configure gen (Some (fun e -> mk_cast gen.gcon.basic.tint e)) false true (get_cl (get_type gen (["haxe";"lang"],"Enum")) ) true 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 = like_float in + + let rcf_on_getset_field main_expr field_expr field may_hash may_set is_unsafe = + let is_float = can_be_float (real_type main_expr.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) } + in + + handle_type_params gen ifaces (get_cl (get_type gen (["haxe";"lang"], "IGenericObject"))); + + let rcf_ctx = ReflectionCFs.new_ctx gen closure_t object_iface true 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 with eexpr = TCall(rcf_static_lookup, [hash]); etype = gen.gcon.basic.tstring } ) 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 varargs_cl = get_cl (get_type gen (["haxe";"lang"],"VarArgsFunction")) in + let dynamic_name = gen.gmk_internal_name "hx" "invokeDynamic" in + + List.iter (fun cl -> + List.iter (fun cf -> + if cf.cf_name = dynamic_name then cl.cl_overrides <- cf :: cl.cl_overrides + ) cl.cl_ordered_fields + ) [closure_cl; varargs_cl]; + + 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 follow e1.etype with + | TDynamic _ | TAnon _ | TMono _ -> true + | TInst({ cl_kind = KTypeParameter _ }, _) -> true + | _ -> false ) + | _ -> assert false + ) "__get" "__set" ); + + let field_is_dynamic t field = + match field_access gen (gen.greal_type t) field with + | FEnumField _ + | FClassField _ -> 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 + | TAbstract _ when like_float t -> 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 + + let is_null t = match real_type t with + | TInst( { cl_path = (["haxe";"lang"], "Null") }, _ ) -> true + | _ -> false + in + + let is_null_expr e = is_null e.etype || match e.eexpr with + | TField(tf, f) -> (match field_access gen (real_type tf.etype) (field_name f) with + | FClassField(_,_,_,_,_,actual_t,_) -> is_null actual_t + | _ -> false) + | _ -> false + in + + let should_handle_opeq t = + match real_type t with + | TDynamic _ | TAnon _ | TMono _ + | TInst( { cl_kind = KTypeParameter _ }, _ ) + | TInst( { cl_path = (["haxe";"lang"], "Null") }, _ ) -> true + | _ -> false + in + + let string_cl = match gen.gcon.basic.tstring with + | TInst(c,[]) -> c + | _ -> assert false + in + + DynamicOperators.configure gen + (DynamicOperators.abstract_implementation gen (fun e -> match e.eexpr with + | TBinop (Ast.OpEq, e1, e2) + | TBinop (Ast.OpNotEq, e1, e2) -> should_handle_opeq e1.etype or should_handle_opeq e2.etype + | TBinop (Ast.OpAssignOp Ast.OpAdd, e1, e2) -> + is_dynamic_expr e1 || is_null_expr e1 || is_string e.etype + | TBinop (Ast.OpAdd, e1, e2) -> is_dynamic e1.etype or is_dynamic e2.etype or is_type_param e1.etype or is_type_param e2.etype or is_string e1.etype or is_string e2.etype or is_string e.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 || is_null_expr e1 (* we will see if the expression is Null also, as the unwrap from Unop will be the same *) + | _ -> false) + (fun e1 e2 -> + let is_basic = is_cs_basic_type (follow e1.etype) || is_cs_basic_type (follow e2.etype) in + let is_ref = if is_basic then false else match follow e1.etype, follow e2.etype with + | TDynamic _, _ + | _, TDynamic _ + | TInst( { cl_path = ([], "String") }, [] ), _ + | _, TInst( { cl_path = ([], "String") }, [] ) + | 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 } + ) + (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 } + | _ when is_string e.etype || is_string e1.etype || is_string e2.etype -> + { + eexpr = TCall( + mk_static_field_access_infer runtime_cl "concat" e.epos [], + [ e1; e2 ] + ); + etype = basic.tstring; + epos = e.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_static_field_access_infer string_cl "Compare" e1.epos [], [ e1; 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) ~handle_strings:false); + + FilterClosures.configure gen (FilterClosures.traverse gen (fun e1 s -> true) closure_func); + + let base_exception = get_cl (get_type gen (["System"], "Exception")) 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 -> + { rethrow with eexpr = TCall(mk_local (alloc_var "__rethrow__" t_dynamic) rethrow.epos, [rethrow]); etype = gen.gcon.basic.tvoid } + ) + (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 + )); + + CastDetect.configure gen (CastDetect.default_implementation gen (Some (TEnum(empty_e, []))) true ~native_string_cast:false ~overloads_cast_to_base:true); + + (*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 = ([], "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 ) ; + + 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 false); + + let native_arr_cl = get_cl ( get_type gen (["cs"], "NativeArray") ) in + 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 -> + api ({ eexpr = TCall( mk_local label_special e_loop.epos, [ mk_int gen n e_loop.epos ] ); etype = t_dynamic; epos = e_loop.epos }) false; + 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); + + CSharpSpecificSynf.configure gen (CSharpSpecificSynf.traverse gen runtime_cl); + CSharpSpecificESynf.configure gen (CSharpSpecificESynf.traverse gen runtime_cl); + + 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 + mkdir (gen.gcon.file ^ "/src/Resources"); + 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/Resources/" ^ 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; + (* after the filters have been run, add all hashed fields to FieldLookup *) + + let normalize_i i = + let i = Int32.of_int (i) in + if i < Int32.zero then + Int32.logor (Int32.logand i (Int32.of_int 0x3FFFFFFF)) (Int32.shift_left Int32.one 30) + else i + in + + let hashes = Hashtbl.fold (fun i s acc -> (normalize_i i,s) :: acc) rcf_ctx.rcf_hash_fields [] in + let hashes = List.sort (fun (i,s) (i2,s2) -> compare i i2) hashes in + + let flookup_cl = get_cl (get_type gen (["haxe";"lang"], "FieldLookup")) in + (try + let basic = gen.gcon.basic in + let change_array = ArrayDeclSynf.default_implementation gen native_arr_cl in + let cl = flookup_cl in + let field_ids = PMap.find "fieldIds" cl.cl_statics in + let fields = PMap.find "fields" cl.cl_statics in + + field_ids.cf_expr <- Some (change_array { + eexpr = TArrayDecl(List.map (fun (i,s) -> { eexpr = TConst(TInt (i)); etype = basic.tint; epos = field_ids.cf_pos }) hashes); + etype = basic.tarray basic.tint; + epos = field_ids.cf_pos + }); + + fields.cf_expr <- Some (change_array { + eexpr = TArrayDecl(List.map (fun (i,s) -> { eexpr = TConst(TString s); etype = basic.tstring; epos = fields.cf_pos }) hashes); + etype = basic.tarray basic.tstring; + epos = fields.cf_pos + }) + + with | Not_found -> + gen.gcon.error "Fields 'fieldIds' and 'fields' were not found in class haxe.lang.FieldLookup" flookup_cl.cl_pos + ); + + TypeParams.RenameTypeParameters.run gen; + + let t = Common.timer "code generation" in + + generate_modules gen "cs" "src" module_gen; + + dump_descriptor gen ("hxcs_build.txt") path_s module_s; + 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 hxcs hxcs_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 generate con = + (try + let gen = new_ctx con in + let basic = con.basic in + + (* make the basic functions in C# *) + let type_cl = get_cl ( get_type gen (["System"], "Type")) in + 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 "GetHashCode" (TFun([], basic.tint)) true Ast.null_pos (Method MethNormal) []; + mk_class_field "GetType" (TFun([], TInst(type_cl, []))) 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; + 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 + diff --git a/genjava.ml b/genjava.ml new file mode 100644 index 0000000000000000000000000000000000000000..bf9b614dda76082017ce0b194aea0d5019f11fc5 --- /dev/null +++ b/genjava.ml @@ -0,0 +1,3098 @@ +(* + * 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 diff --git a/genjs.ml b/genjs.ml new file mode 100644 index 0000000000000000000000000000000000000000..734eb65c9f362cf1ea7ac111f598365528aec1d4 --- /dev/null +++ b/genjs.ml @@ -0,0 +1,1216 @@ +(* + * 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 + +type pos = Ast.pos + +type sourcemap = { + sources : (string) DynArray.t; + sources_hash : (string, int) Hashtbl.t; + mappings : Buffer.t; + + mutable source_last_line : int; + mutable source_last_col : int; + mutable source_last_file : int; + mutable print_comma : bool; + mutable output_last_col : int; + mutable output_current_col : int; +} + +type ctx = { + com : Common.context; + buf : Buffer.t; + packages : (string list,unit) Hashtbl.t; + smap : sourcemap; + js_modern : bool; + mutable current : tclass; + mutable statics : (tclass * string * texpr) list; + mutable inits : texpr list; + mutable tabs : string; + mutable in_value : tvar option; + mutable in_loop : bool; + mutable handle_break : bool; + mutable id_counter : int; + mutable type_accessor : module_type -> string; + mutable separator : bool; + mutable found_expose : bool; +} + +let s_path ctx = Ast.s_type_path + +let kwds = + let h = Hashtbl.create 0 in + List.iter (fun s -> Hashtbl.add h s ()) [ + "abstract"; "as"; "boolean"; "break"; "byte"; "case"; "catch"; "char"; "class"; "continue"; "const"; + "debugger"; "default"; "delete"; "do"; "double"; "else"; "enum"; "export"; "extends"; "false"; "final"; + "finally"; "float"; "for"; "function"; "goto"; "if"; "implements"; "import"; "in"; "instanceof"; "int"; + "interface"; "is"; "long"; "namespace"; "native"; "new"; "null"; "package"; "private"; "protected"; + "public"; "return"; "short"; "static"; "super"; "switch"; "synchronized"; "this"; "throw"; "throws"; + "transient"; "true"; "try"; "typeof"; "use"; "var"; "void"; "volatile"; "while"; "with" + ]; + h + +let valid_js_ident s = + try + for i = 0 to String.length s - 1 do + match String.unsafe_get s i with + | 'a'..'z' | 'A'..'Z' | '$' | '_' -> () + | '0'..'9' when i > 0 -> () + | _ -> raise Exit + done; + true + with Exit -> + false + +let field s = if Hashtbl.mem kwds s then "[\"" ^ s ^ "\"]" else "." ^ s +let ident s = if Hashtbl.mem kwds s then "$" ^ s else s +let anon_field s = if Hashtbl.mem kwds s || not (valid_js_ident s) then "'" ^ s ^ "'" else s +let static_field s = + match s with + | "length" | "name" -> ".$" ^ s + | s -> field s + +let has_feature ctx = Common.has_feature ctx.com +let add_feature ctx = Common.add_feature ctx.com + +let handle_newlines ctx str = + if ctx.com.debug then + let rec loop from = + try begin + let next = String.index_from str from '\n' + 1 in + Buffer.add_char ctx.smap.mappings ';'; + ctx.smap.output_last_col <- 0; + ctx.smap.print_comma <- false; + loop next + end with Not_found -> + ctx.smap.output_current_col <- String.length str - from + in + loop 0 + else () + +let spr ctx s = + ctx.separator <- false; + handle_newlines ctx s; + Buffer.add_string ctx.buf s + +let print ctx = + ctx.separator <- false; + Printf.kprintf (fun s -> begin + handle_newlines ctx s; + Buffer.add_string ctx.buf s + end) + +let unsupported p = error "This expression cannot be compiled to Javascript" p + +let add_mapping ctx e = + if not ctx.com.debug || e.epos.pmin < 0 then () else + let pos = e.epos in + let smap = ctx.smap in + let file = try + Hashtbl.find smap.sources_hash pos.pfile + with Not_found -> + let length = DynArray.length smap.sources in + Hashtbl.replace smap.sources_hash pos.pfile length; + DynArray.add smap.sources pos.pfile; + length + in + let line, col = Lexer.find_pos pos in + let line = line - 1 in + let col = col - 1 in + if smap.source_last_file != file || smap.source_last_line != line || smap.source_last_col != col then begin + if smap.print_comma then + Buffer.add_char smap.mappings ',' + else + smap.print_comma <- true; + + let base64_vlq number = + let encode_digit digit = + 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';'+';'/' + |] in + Array.unsafe_get chars digit + in + let to_vlq number = + if number < 0 then + ((-number) lsl 1) + 1 + else + number lsl 1 + in + let rec loop vlq = + let shift = 5 in + let base = 1 lsl shift in + let mask = base - 1 in + let continuation_bit = base in + let digit = vlq land mask in + let next = vlq asr shift in + Buffer.add_char smap.mappings (encode_digit ( + if next > 0 then digit lor continuation_bit else digit)); + if next > 0 then loop next else () + in + loop (to_vlq number) + in + + base64_vlq (smap.output_current_col - smap.output_last_col); + base64_vlq (file - smap.source_last_file); + base64_vlq (line - smap.source_last_line); + base64_vlq (col - smap.source_last_col); + + smap.source_last_file <- file; + smap.source_last_line <- line; + smap.source_last_col <- col; + smap.output_last_col <- smap.output_current_col + end + +let basename path = + try + let idx = String.rindex path '/' in + String.sub path (idx + 1) (String.length path - idx - 1) + with Not_found -> path + +let write_mappings ctx = + let basefile = basename ctx.com.file in + print ctx "\n//@ sourceMappingURL=%s.map" basefile; + let channel = open_out_bin (ctx.com.file ^ ".map") in + let sources = DynArray.to_list ctx.smap.sources in + let to_url file = + ExtString.String.map (fun c -> if c == '\\' then '/' else c) (Common.get_full_path file) + in + output_string channel "{\n"; + output_string channel "\"version\":3,\n"; + output_string channel ("\"file\":\"" ^ basefile ^ "\",\n"); + output_string channel ("\"sourceRoot\":\"file://\",\n"); + output_string channel ("\"sources\":[" ^ + (String.concat "," (List.map (fun s -> "\"" ^ to_url s ^ "\"") sources)) ^ + "],\n"); + output_string channel "\"names\":[],\n"; + output_string channel "\"mappings\":\""; + Buffer.output_buffer channel ctx.smap.mappings; + output_string channel "\"\n"; + output_string channel "}"; + close_out channel + +let newline ctx = + match Buffer.nth ctx.buf (Buffer.length ctx.buf - 1) with + | '}' | '{' | ':' when not ctx.separator -> print ctx "\n%s" ctx.tabs + | _ -> print ctx ";\n%s" ctx.tabs + +let newprop ctx = + match Buffer.nth ctx.buf (Buffer.length ctx.buf - 1) with + | '{' -> print ctx "\n%s" ctx.tabs + | _ -> print ctx "\n%s," ctx.tabs + +let semicolon ctx = + match Buffer.nth ctx.buf (Buffer.length ctx.buf - 1) with + | '}' when not ctx.separator -> () + | _ -> spr ctx ";" + +let rec concat ctx s f = function + | [] -> () + | [x] -> f x + | x :: l -> + f x; + spr ctx s; + concat ctx s f l + +let fun_block ctx f p = + let e = List.fold_left (fun e (a,c) -> + match c with + | None | Some TNull -> e + | Some c -> Codegen.concat (Codegen.set_default ctx.com a c p) e + ) f.tf_expr f.tf_args in + e + +let open_block ctx = + let oldt = ctx.tabs in + ctx.tabs <- "\t" ^ ctx.tabs; + (fun() -> ctx.tabs <- oldt) + +let rec has_return e = + match e.eexpr with + | TBlock [] -> false + | TBlock el -> has_return (List.hd (List.rev el)) + | TReturn _ -> true + | _ -> false + +let rec iter_switch_break in_switch e = + match e.eexpr with + | TFunction _ | TWhile _ | TFor _ -> () + | TSwitch _ | TMatch _ when not in_switch -> iter_switch_break true e + | TBreak when in_switch -> raise Exit + | _ -> iter (iter_switch_break in_switch) e + +let handle_break ctx e = + let old = ctx.in_loop, ctx.handle_break in + ctx.in_loop <- true; + try + iter_switch_break false e; + ctx.handle_break <- false; + (fun() -> + ctx.in_loop <- fst old; + ctx.handle_break <- snd old; + ) + with + Exit -> + spr ctx "try {"; + let b = open_block ctx in + newline ctx; + ctx.handle_break <- true; + (fun() -> + b(); + ctx.in_loop <- fst old; + ctx.handle_break <- snd old; + newline ctx; + spr ctx "} catch( e ) { if( e != \"__break__\" ) throw e; }"; + ) + +let handle_expose ctx path meta = + let rec loop = function + | (Meta.Expose, args, pos) :: l when ctx.js_modern -> + ctx.found_expose <- true; + let exposed_path = (match args with + | [EConst (String s), _] -> s + | [] -> path + | _ -> error "Invalid @:expose parameters" pos + ) in + print ctx "$hxExpose(%s, \"%s\")" path exposed_path; + newline ctx + | _ :: l -> loop l + | [] -> () + in + loop meta + +let this ctx = match ctx.in_value with None -> "this" | Some _ -> "$this" + +let is_dynamic_iterator ctx e = + let check x = + has_feature ctx "HxOverrides.iter" && (match follow x.etype with TInst ({ cl_path = [],"Array" },_) | TAnon _ | TDynamic _ | TMono _ -> true | _ -> false) + in + match e.eexpr with + | TField (x,f) when field_name f = "iterator" -> check x + | _ -> + false + +let gen_constant ctx p = function + | TInt i -> print ctx "%ld" i + | TFloat s -> spr ctx s + | TString s -> + if String.contains s '\000' then error "A String cannot contain \\0 characters" p; + print ctx "\"%s\"" (Ast.s_escape s) + | TBool b -> spr ctx (if b then "true" else "false") + | TNull -> spr ctx "null" + | TThis -> spr ctx (this ctx) + | TSuper -> assert false + +let rec gen_call ctx e el in_value = + match e.eexpr , el with + | TConst TSuper , params -> + (match ctx.current.cl_super with + | None -> error "Missing api.setCurrentClass" e.epos + | Some (c,_) -> + print ctx "%s.call(%s" (ctx.type_accessor (TClassDecl c)) (this ctx); + List.iter (fun p -> print ctx ","; gen_value ctx p) params; + spr ctx ")"; + ); + | TField ({ eexpr = TConst TSuper },f) , params -> + (match ctx.current.cl_super with + | None -> error "Missing api.setCurrentClass" e.epos + | Some (c,_) -> + let name = field_name f in + print ctx "%s.prototype%s.call(%s" (ctx.type_accessor (TClassDecl c)) (field name) (this ctx); + List.iter (fun p -> print ctx ","; gen_value ctx p) params; + spr ctx ")"; + ); + | TCall (x,_) , el when (match x.eexpr with TLocal { v_name = "__js__" } -> false | _ -> true) -> + spr ctx "("; + gen_value ctx e; + spr ctx ")"; + spr ctx "("; + concat ctx "," (gen_value ctx) el; + spr ctx ")"; + | TLocal { v_name = "__new__" }, { eexpr = TConst (TString cl) } :: params -> + print ctx "new %s(" cl; + concat ctx "," (gen_value ctx) params; + spr ctx ")"; + | TLocal { v_name = "__new__" }, e :: params -> + spr ctx "new "; + gen_value ctx e; + spr ctx "("; + concat ctx "," (gen_value ctx) params; + spr ctx ")"; + | TLocal { v_name = "__js__" }, [{ eexpr = TConst (TString code) }] -> + spr ctx (String.concat "\n" (ExtString.String.nsplit code "\r\n")) + | TLocal { v_name = "__instanceof__" }, [o;t] -> + spr ctx "("; + gen_value ctx o; + print ctx " instanceof "; + gen_value ctx t; + spr ctx ")"; + | TLocal ({v_name = "__define_feature__"}), [_;e] -> + gen_expr ctx e + | TLocal { v_name = "__feature__" }, { eexpr = TConst (TString f) } :: eif :: eelse -> + (if has_feature ctx f then + gen_value ctx eif + else match eelse with + | [] -> () + | e :: _ -> gen_value ctx e) + | TLocal { v_name = "__resources__" }, [] -> + spr ctx "["; + concat ctx "," (fun (name,data) -> + spr ctx "{ "; + spr ctx "name : "; + gen_constant ctx e.epos (TString name); + spr ctx ", data : "; + gen_constant ctx e.epos (TString (Codegen.bytes_serialize data)); + spr ctx "}" + ) (Hashtbl.fold (fun name data acc -> (name,data) :: acc) ctx.com.resources []); + spr ctx "]"; + | TLocal { v_name = "`trace" }, [e;infos] -> + if has_feature ctx "haxe.Log.trace" then begin + let t = (try List.find (fun t -> t_path t = (["haxe"],"Log")) ctx.com.types with _ -> assert false) in + spr ctx (ctx.type_accessor t); + spr ctx ".trace("; + gen_value ctx e; + spr ctx ","; + gen_value ctx infos; + spr ctx ")"; + end else begin + spr ctx "console.log("; + gen_value ctx e; + spr ctx ")"; + end + | _ -> + gen_value ctx e; + spr ctx "("; + concat ctx "," (gen_value ctx) el; + spr ctx ")" + +and gen_expr ctx e = + add_mapping ctx e; + match e.eexpr with + | TConst c -> gen_constant ctx e.epos c + | TLocal v -> spr ctx (ident v.v_name) + | TArray (e1,{ eexpr = TConst (TString s) }) when valid_js_ident s -> + gen_value ctx e1; + spr ctx (field s) + | TArray (e1,e2) -> + gen_value ctx e1; + spr ctx "["; + gen_value ctx e2; + spr ctx "]"; + | TBinop (op,{ eexpr = TField (x,f) },e2) when field_name f = "iterator" -> + gen_value ctx x; + spr ctx (field "iterator"); + print ctx " %s " (Ast.s_binop op); + gen_value ctx e2; + | TBinop (op,e1,e2) -> + gen_value ctx e1; + print ctx " %s " (Ast.s_binop op); + gen_value ctx e2; + | TField (x,f) when field_name f = "iterator" && is_dynamic_iterator ctx e -> + add_feature ctx "use.$iterator"; + print ctx "$iterator("; + gen_value ctx x; + print ctx ")"; + | TField (x,FClosure (_,f)) -> + add_feature ctx "use.$bind"; + (match x.eexpr with + | TConst _ | TLocal _ -> + print ctx "$bind("; + gen_value ctx x; + print ctx ","; + gen_value ctx x; + print ctx "%s)" (field f.cf_name) + | _ -> + print ctx "($_="; + gen_value ctx x; + print ctx ",$bind($_,$_%s))" (field f.cf_name)) + | TField (x,f) -> + gen_value ctx x; + let name = field_name f in + spr ctx (match f with FStatic _ | FEnum _ -> static_field name | FInstance _ | FAnon _ | FDynamic _ | FClosure _ -> field name) + | TTypeExpr t -> + spr ctx (ctx.type_accessor t) + | TParenthesis e -> + spr ctx "("; + gen_value ctx e; + spr ctx ")"; + | TReturn eo -> + if ctx.in_value <> None then unsupported e.epos; + (match eo with + | None -> + spr ctx "return" + | Some e -> + spr ctx "return "; + gen_value ctx e); + | TBreak -> + if not ctx.in_loop then unsupported e.epos; + if ctx.handle_break then spr ctx "throw \"__break__\"" else spr ctx "break" + | TContinue -> + if not ctx.in_loop then unsupported e.epos; + spr ctx "continue" + | TBlock el -> + print ctx "{"; + let bend = open_block ctx in + List.iter (gen_block ctx) el; + bend(); + newline ctx; + print ctx "}"; + | TFunction f -> + let old = ctx.in_value, ctx.in_loop in + ctx.in_value <- None; + ctx.in_loop <- false; + print ctx "function(%s) " (String.concat "," (List.map ident (List.map arg_name f.tf_args))); + gen_expr ctx (fun_block ctx f e.epos); + ctx.in_value <- fst old; + ctx.in_loop <- snd old; + ctx.separator <- true + | TCall (e,el) -> + gen_call ctx e el false + | TArrayDecl el -> + spr ctx "["; + concat ctx "," (gen_value ctx) el; + spr ctx "]" + | TThrow e -> + spr ctx "throw "; + gen_value ctx e; + | TVars [] -> + () + | TVars vl -> + spr ctx "var "; + concat ctx ", " (fun (v,e) -> + spr ctx (ident v.v_name); + match e with + | None -> () + | Some e -> + spr ctx " = "; + gen_value ctx e + ) vl; + | TNew (c,_,el) -> + print ctx "new %s(" (ctx.type_accessor (TClassDecl c)); + concat ctx "," (gen_value ctx) el; + spr ctx ")" + | TIf (cond,e,eelse) -> + spr ctx "if"; + gen_value ctx cond; + spr ctx " "; + gen_expr ctx e; + (match eelse with + | None -> () + | Some e2 -> + (match e.eexpr with + | TObjectDecl _ -> ctx.separator <- false + | _ -> ()); + semicolon ctx; + spr ctx " else "; + gen_expr ctx e2); + | TUnop (op,Ast.Prefix,e) -> + spr ctx (Ast.s_unop op); + gen_value ctx e + | TUnop (op,Ast.Postfix,e) -> + gen_value ctx e; + spr ctx (Ast.s_unop op) + | TWhile (cond,e,Ast.NormalWhile) -> + let handle_break = handle_break ctx e in + spr ctx "while"; + gen_value ctx cond; + spr ctx " "; + gen_expr ctx e; + handle_break(); + | TWhile (cond,e,Ast.DoWhile) -> + let handle_break = handle_break ctx e in + spr ctx "do "; + gen_expr ctx e; + semicolon ctx; + spr ctx " while"; + gen_value ctx cond; + handle_break(); + | TObjectDecl fields -> + spr ctx "{ "; + concat ctx ", " (fun (f,e) -> print ctx "%s : " (anon_field f); gen_value ctx e) fields; + spr ctx "}"; + ctx.separator <- true + | TFor (v,it,e) -> + let handle_break = handle_break ctx e in + let it = ident (match it.eexpr with + | TLocal v -> v.v_name + | _ -> + let id = ctx.id_counter in + ctx.id_counter <- ctx.id_counter + 1; + let name = "$it" ^ string_of_int id in + print ctx "var %s = " name; + gen_value ctx it; + newline ctx; + name + ) in + print ctx "while( %s.hasNext() ) {" it; + let bend = open_block ctx in + newline ctx; + print ctx "var %s = %s.next()" (ident v.v_name) it; + gen_block ctx e; + bend(); + newline ctx; + spr ctx "}"; + handle_break(); + | TTry (e,catchs) -> + spr ctx "try "; + gen_expr ctx e; + let vname = (match catchs with [(v,_)] -> v.v_name | _ -> + let id = ctx.id_counter in + ctx.id_counter <- ctx.id_counter + 1; + "$e" ^ string_of_int id + ) in + print ctx " catch( %s ) {" vname; + let bend = open_block ctx in + let last = ref false in + let else_block = ref false in + List.iter (fun (v,e) -> + if !last then () else + let t = (match follow v.v_type with + | TEnum (e,_) -> Some (TEnumDecl e) + | TInst (c,_) -> Some (TClassDecl c) + | TAbstract (a,_) -> Some (TAbstractDecl a) + | TFun _ + | TLazy _ + | TType _ + | TAnon _ -> + assert false + | TMono _ + | TDynamic _ -> + None + ) in + match t with + | None -> + last := true; + if !else_block then print ctx "{"; + if vname <> v.v_name then begin + newline ctx; + print ctx "var %s = %s" v.v_name vname; + end; + gen_block ctx e; + if !else_block then begin + newline ctx; + print ctx "}"; + end + | Some t -> + if not !else_block then newline ctx; + print ctx "if( %s.__instanceof(%s," (ctx.type_accessor (TClassDecl { null_class with cl_path = ["js"],"Boot" })) vname; + gen_value ctx (mk (TTypeExpr t) (mk_mono()) e.epos); + spr ctx ") ) {"; + let bend = open_block ctx in + if vname <> v.v_name then begin + newline ctx; + print ctx "var %s = %s" v.v_name vname; + end; + gen_block ctx e; + bend(); + newline ctx; + spr ctx "} else "; + else_block := true + ) catchs; + if not !last then print ctx "throw(%s)" vname; + bend(); + newline ctx; + spr ctx "}"; + | TMatch (e,(estruct,_),cases,def) -> + let evar = (if List.for_all (fun (_,pl,_) -> pl = None) cases then begin + spr ctx "switch( "; + gen_value ctx (if Optimizer.need_parent e then Codegen.mk_parent e else e); + spr ctx "[1] ) {"; + "???" + end else begin + let v = (match e.eexpr with + | TLocal v -> v.v_name + | _ -> + spr ctx "var $e = "; + gen_value ctx e; + newline ctx; + "$e" + ) in + print ctx "switch( %s[1] ) {" v; + v + end) in + List.iter (fun (cl,params,e) -> + List.iter (fun c -> + newline ctx; + print ctx "case %d:" c; + ) cl; + let bend = open_block ctx in + (match params with + | None -> () + | Some l -> + let n = ref 1 in + let l = List.fold_left (fun acc v -> incr n; match v with None -> acc | Some v -> (v.v_name,!n) :: acc) [] l in + newline ctx; + spr ctx "var "; + concat ctx ", " (fun (v,n) -> + print ctx "%s = %s[%d]" (ident v) evar n; + ) l); + gen_block ctx e; + if not (has_return e) then begin + newline ctx; + print ctx "break"; + end; + bend(); + ) cases; + (match def with + | None -> () + | Some e -> + newline ctx; + spr ctx "default:"; + let bend = open_block ctx in + gen_block ctx e; + bend(); + ); + newline ctx; + spr ctx "}" + | TSwitch (e,cases,def) -> + spr ctx "switch"; + gen_value ctx e; + spr ctx " {"; + newline ctx; + List.iter (fun (el,e2) -> + List.iter (fun e -> + match e.eexpr with + | TConst(c) when c = TNull -> + spr ctx "case null: case undefined:"; + | _ -> + spr ctx "case "; + gen_value ctx e; + spr ctx ":" + ) el; + let bend = open_block ctx in + gen_block ctx e2; + if not (has_return e2) then begin + newline ctx; + print ctx "break"; + end; + bend(); + newline ctx; + ) cases; + (match def with + | None -> () + | Some e -> + spr ctx "default:"; + let bend = open_block ctx in + gen_block ctx e; + bend(); + newline ctx; + ); + spr ctx "}" + | TCast (e,None) -> + gen_expr ctx e + | TCast (e1,Some t) -> + spr ctx "js.Boot.__cast("; + gen_expr ctx e1; + spr ctx " , "; + spr ctx (ctx.type_accessor t); + spr ctx ")" + + +and gen_block ?(after=false) ctx e = + match e.eexpr with + | TBlock el -> + List.iter (gen_block ~after ctx) el + | TCall ({ eexpr = TLocal { v_name = "__feature__" } }, { eexpr = TConst (TString f) } :: eif :: eelse) -> + if has_feature ctx f then + gen_block ~after ctx eif + else (match eelse with + | [] -> () + | [e] -> gen_block ~after ctx e + | _ -> assert false) + | _ -> + if not after then newline ctx; + gen_expr ctx e; + if after then newline ctx + +and gen_value ctx e = + add_mapping ctx e; + let assign e = + mk (TBinop (Ast.OpAssign, + mk (TLocal (match ctx.in_value with None -> assert false | Some v -> v)) t_dynamic e.epos, + e + )) e.etype e.epos + in + let value() = + let old = ctx.in_value, ctx.in_loop in + let r = alloc_var "$r" t_dynamic in + ctx.in_value <- Some r; + ctx.in_loop <- false; + spr ctx "(function($this) "; + spr ctx "{"; + let b = open_block ctx in + newline ctx; + spr ctx "var $r"; + newline ctx; + (fun() -> + newline ctx; + spr ctx "return $r"; + b(); + newline ctx; + spr ctx "}"; + ctx.in_value <- fst old; + ctx.in_loop <- snd old; + print ctx "(%s))" (this ctx) + ) + in + match e.eexpr with + | TConst _ + | TLocal _ + | TArray _ + | TBinop _ + | TField _ + | TTypeExpr _ + | TParenthesis _ + | TObjectDecl _ + | TArrayDecl _ + | TNew _ + | TUnop _ + | TFunction _ -> + gen_expr ctx e + | TCall (e,el) -> + gen_call ctx e el true + | TReturn _ + | TBreak + | TContinue -> + unsupported e.epos + | TCast (e1, None) -> + gen_value ctx e1 + | TCast (e1, Some t) -> + spr ctx "js.Boot.__cast("; + gen_value ctx e1; + spr ctx " , "; + spr ctx (ctx.type_accessor t); + spr ctx ")" + | TVars _ + | TFor _ + | TWhile _ + | TThrow _ -> + (* value is discarded anyway *) + let v = value() in + gen_expr ctx e; + v() + | TBlock [e] -> + gen_value ctx e + | TBlock el -> + let v = value() in + let rec loop = function + | [] -> + spr ctx "return null"; + | [e] -> + gen_expr ctx (assign e); + | e :: l -> + gen_expr ctx e; + newline ctx; + loop l + in + loop el; + v(); + | TIf (cond,e,eo) -> + (* remove parenthesis unless it's an operation with higher precedence than ?: *) + let cond = (match cond.eexpr with + | TParenthesis { eexpr = TBinop ((Ast.OpAssign | Ast.OpAssignOp _),_,_) } -> cond + | TParenthesis e -> e + | _ -> cond + ) in + gen_value ctx cond; + spr ctx "?"; + gen_value ctx e; + spr ctx ":"; + (match eo with + | None -> spr ctx "null" + | Some e -> gen_value ctx e); + | TSwitch (cond,cases,def) -> + let v = value() in + gen_expr ctx (mk (TSwitch (cond, + List.map (fun (e1,e2) -> (e1,assign e2)) cases, + match def with None -> None | Some e -> Some (assign e) + )) e.etype e.epos); + v() + | TMatch (cond,enum,cases,def) -> + let v = value() in + gen_expr ctx (mk (TMatch (cond,enum, + List.map (fun (constr,params,e) -> (constr,params,assign e)) cases, + match def with None -> None | Some e -> Some (assign e) + )) e.etype e.epos); + v() + | TTry (b,catchs) -> + let v = value() in + let block e = mk (TBlock [e]) e.etype e.epos in + gen_expr ctx (mk (TTry (block (assign b), + List.map (fun (v,e) -> v, block (assign e)) catchs + )) e.etype e.epos); + v() + +let generate_package_create ctx (p,_) = + let rec loop acc = function + | [] -> () + | p :: l when Hashtbl.mem ctx.packages (p :: acc) -> loop (p :: acc) l + | p :: l -> + Hashtbl.add ctx.packages (p :: acc) (); + (match acc with + | [] -> + if ctx.js_modern then + print ctx "var %s = {}" p + else + print ctx "var %s = %s || {}" p p + | _ -> + let p = String.concat "." (List.rev acc) ^ (field p) in + if ctx.js_modern then + print ctx "%s = {}" p + else + print ctx "if(!%s) %s = {}" p p + ); + newline ctx; + loop (p :: acc) l + in + match p with + | [] -> print ctx "var " + | _ -> loop [] p + +let check_field_name c f = + match f.cf_name with + | "prototype" | "__proto__" | "constructor" -> + error ("The field name '" ^ f.cf_name ^ "' is not allowed in JS") (match f.cf_expr with None -> c.cl_pos | Some e -> e.epos); + | _ -> () + +let gen_class_static_field ctx c f = + match f.cf_expr with + | None | Some { eexpr = TConst TNull } when not (has_feature ctx "Type.getClassFields") -> + () + | None when is_extern_field f -> + () + | None -> + print ctx "%s%s = null" (s_path ctx c.cl_path) (static_field f.cf_name); + newline ctx + | Some e -> + match e.eexpr with + | TFunction _ -> + let path = (s_path ctx c.cl_path) ^ (static_field f.cf_name) in + ctx.id_counter <- 0; + print ctx "%s = " path; + gen_value ctx e; + ctx.separator <- false; + newline ctx; + handle_expose ctx path f.cf_meta + | _ -> + ctx.statics <- (c,f.cf_name,e) :: ctx.statics + +let can_gen_class_field ctx = function + | { cf_expr = (None | Some { eexpr = TConst TNull }) } when not (has_feature ctx "Type.getInstanceFields") -> + false + | f -> + not (is_extern_field f) + +let gen_class_field ctx c f = + check_field_name c f; + match f.cf_expr with + | None -> + newprop ctx; + print ctx "%s: " (anon_field f.cf_name); + print ctx "null"; + | Some e -> + newprop ctx; + print ctx "%s: " (anon_field f.cf_name); + ctx.id_counter <- 0; + gen_value ctx e; + ctx.separator <- false + +let generate_class ctx c = + ctx.current <- c; + ctx.id_counter <- 0; + (match c.cl_path with + | [],"Function" -> error "This class redefine a native one" c.cl_pos + | _ -> ()); + let p = s_path ctx c.cl_path in + generate_package_create ctx c.cl_path; + let hxClasses = has_feature ctx "Type.resolveClass" in + if ctx.js_modern || not hxClasses then + print ctx "%s = " p + else + print ctx "%s = $hxClasses[\"%s\"] = " p p; + (match c.cl_constructor with + | Some { cf_expr = Some e } -> gen_expr ctx e + | _ -> print ctx "function() { }"); + newline ctx; + if ctx.js_modern && hxClasses then begin + print ctx "$hxClasses[\"%s\"] = %s" p p; + newline ctx; + end; + handle_expose ctx p c.cl_meta; + if has_feature ctx "js.Boot.isClass" then begin + print ctx "%s.__name__ = " p; + if has_feature ctx "Type.getClassName" then + print ctx "[%s]" (String.concat "," (List.map (fun s -> Printf.sprintf "\"%s\"" (Ast.s_escape s)) (fst c.cl_path @ [snd c.cl_path]))) + else + print ctx "true"; + newline ctx; + end; + (match c.cl_implements with + | [] -> () + | l -> + print ctx "%s.__interfaces__ = [%s]" p (String.concat "," (List.map (fun (i,_) -> s_path ctx i.cl_path) l)); + newline ctx; + ); + + let gen_props props = + String.concat "," (List.map (fun (p,v) -> p ^":\""^v^"\"") props) in + let has_property_reflection = + (has_feature ctx "Reflect.getProperty") || (has_feature ctx "Reflect.setProperty") in + + if has_property_reflection then begin + (match Codegen.get_properties c.cl_ordered_statics with + | [] -> () + | props -> + print ctx "%s.__properties__ = {%s}" p (gen_props props); + newline ctx); + end; + + List.iter (gen_class_static_field ctx c) c.cl_ordered_statics; + + let has_class = has_feature ctx "js.Boot.getClass" && (c.cl_super <> None || c.cl_ordered_fields <> [] || c.cl_constructor <> None) in + let has_prototype = c.cl_super <> None || has_class || List.exists (can_gen_class_field ctx) c.cl_ordered_fields in + if has_prototype then begin + (match c.cl_super with + | None -> print ctx "%s.prototype = {" p; + | Some (csup,_) -> + let psup = s_path ctx csup.cl_path in + print ctx "%s.__super__ = %s" p psup; + newline ctx; + print ctx "%s.prototype = $extend(%s.prototype,{" p psup; + ); + + let bend = open_block ctx in + List.iter (fun f -> if can_gen_class_field ctx f then gen_class_field ctx c f) c.cl_ordered_fields; + if has_class then begin + newprop ctx; + print ctx "__class__: %s" p; + end; + + if has_property_reflection then begin + let props = Codegen.get_properties c.cl_ordered_fields in + (match c.cl_super with + | _ when props = [] -> () + | Some (csup,_) when Codegen.has_properties csup -> + newprop ctx; + let psup = s_path ctx csup.cl_path in + print ctx "__properties__: $extend(%s.prototype.__properties__,{%s})" psup (gen_props props) + | _ -> + newprop ctx; + print ctx "__properties__: {%s}" (gen_props props)); + end; + + bend(); + print ctx "\n}"; + (match c.cl_super with None -> () | _ -> print ctx ")"); + newline ctx + end + +let generate_enum ctx e = + let p = s_path ctx e.e_path in + generate_package_create ctx e.e_path; + let ename = List.map (fun s -> Printf.sprintf "\"%s\"" (Ast.s_escape s)) (fst e.e_path @ [snd e.e_path]) in + print ctx "%s = " p; + if has_feature ctx "Type.resolveEnum" then print ctx "$hxClasses[\"%s\"] = " p; + print ctx "{"; + if has_feature ctx "js.Boot.isEnum" then print ctx " __ename__ : %s," (if has_feature ctx "Type.getEnumName" then "[" ^ String.concat "," ename ^ "]" else "true"); + print ctx " __constructs__ : [%s] }" (String.concat "," (List.map (fun s -> Printf.sprintf "\"%s\"" s) e.e_names)); + newline ctx; + List.iter (fun n -> + let f = PMap.find n e.e_constrs in + print ctx "%s%s = " p (field f.ef_name); + (match f.ef_type with + | TFun (args,_) -> + let sargs = String.concat "," (List.map (fun (n,_,_) -> ident n) args) in + print ctx "function(%s) { var $x = [\"%s\",%d,%s]; $x.__enum__ = %s; $x.toString = $estr; return $x; }" sargs f.ef_name f.ef_index sargs p; + | _ -> + print ctx "[\"%s\",%d]" f.ef_name f.ef_index; + newline ctx; + print ctx "%s%s.toString = $estr" p (field f.ef_name); + newline ctx; + print ctx "%s%s.__enum__ = %s" p (field f.ef_name) p; + ); + newline ctx + ) e.e_names; + match Codegen.build_metadata ctx.com (TEnumDecl e) with + | None -> () + | Some e -> + print ctx "%s.__meta__ = " p; + gen_expr ctx e; + newline ctx + +let generate_static ctx (c,f,e) = + print ctx "%s%s = " (s_path ctx c.cl_path) (static_field f); + gen_value ctx e; + newline ctx + +let generate_type ctx = function + | TClassDecl c -> + (match c.cl_init with + | None -> () + | Some e -> + ctx.inits <- e :: ctx.inits); + if not c.cl_extern then generate_class ctx c else if Meta.has Meta.InitPackage c.cl_meta then generate_package_create ctx c.cl_path + | TEnumDecl e when e.e_extern -> + () + | TEnumDecl e -> generate_enum ctx e + | TTypeDecl _ | TAbstractDecl _ -> () + +let set_current_class ctx c = + ctx.current <- c + +let alloc_ctx com = + let ctx = { + com = com; + buf = Buffer.create 16000; + packages = Hashtbl.create 0; + smap = { + source_last_line = 0; + source_last_col = 0; + source_last_file = 0; + print_comma = false; + output_last_col = 0; + output_current_col = 0; + sources = DynArray.create(); + sources_hash = Hashtbl.create 0; + mappings = Buffer.create 16; + }; + js_modern = not (Common.defined com Define.JsClassic); + statics = []; + inits = []; + current = null_class; + tabs = ""; + in_value = None; + in_loop = false; + handle_break = false; + id_counter = 0; + type_accessor = (fun _ -> assert false); + separator = false; + found_expose = false; + } in + ctx.type_accessor <- (fun t -> s_path ctx (t_path t)); + ctx + +let gen_single_expr ctx e expr = + if expr then gen_expr ctx e else gen_value ctx e; + let str = Buffer.contents ctx.buf in + Buffer.reset ctx.buf; + ctx.id_counter <- 0; + str + +let generate com = + let t = Common.timer "generate js" in + (match com.js_gen with + | Some g -> g() + | None -> + let ctx = alloc_ctx com in + + if has_feature ctx "Class" || has_feature ctx "Type.getClassName" then add_feature ctx "js.Boot.isClass"; + if has_feature ctx "Enum" || has_feature ctx "Type.getEnumName" then add_feature ctx "js.Boot.isEnum"; + + if ctx.js_modern then begin + (* Additional ES5 strict mode keywords. *) + List.iter (fun s -> Hashtbl.replace kwds s ()) [ "arguments"; "eval" ]; + + (* Wrap output in a closure. *) + print ctx "(function () { \"use strict\""; + newline ctx; + end; + + let vars = [] in + let vars = (if has_feature ctx "Type.resolveClass" || has_feature ctx "Type.resolveEnum" then ("$hxClasses = " ^ (if ctx.js_modern then "{}" else "$hxClasses || {}")) :: vars else vars) in + let vars = (if List.exists (function TEnumDecl { e_extern = false } -> true | _ -> false) com.types then "$estr = function() { return js.Boot.__string_rec(this,''); }" :: vars else vars) in + (match List.rev vars with + | [] -> () + | vl -> + print ctx "var %s" (String.concat "," vl); + ctx.separator <- true; + newline ctx + ); + if List.exists (function TClassDecl { cl_extern = false; cl_super = Some _ } -> true | _ -> false) com.types then begin + print ctx "function $extend(from, fields) { + function inherit() {}; inherit.prototype = from; var proto = new inherit(); + for (var name in fields) proto[name] = fields[name]; + if( fields.toString !== Object.prototype.toString ) proto.toString = fields.toString; + return proto; +} +"; + end; + List.iter (generate_type ctx) com.types; + let rec chk_features e = + if is_dynamic_iterator ctx e then add_feature ctx "use.$iterator"; + match e.eexpr with + | TField (_,FClosure _) -> + add_feature ctx "use.$bind" + | _ -> + Type.iter chk_features e + in + List.iter chk_features ctx.inits; + List.iter (fun (_,_,e) -> chk_features e) ctx.statics; + if has_feature ctx "use.$iterator" then begin + add_feature ctx "use.$bind"; + print ctx "function $iterator(o) { if( o instanceof Array ) return function() { return HxOverrides.iter(o); }; return typeof(o.iterator) == 'function' ? $bind(o,o.iterator) : o.iterator; }"; + ctx.separator <- true; + newline ctx; + end; + if has_feature ctx "use.$bind" then begin + print ctx "var $_, $fid = 0"; + newline ctx; + print ctx "function $bind(o,m) { if( m == null ) return null; if( m.__id__ == null ) m.__id__ = $fid++; var f; if( o.hx__closures__ == null ) o.hx__closures__ = {}; else f = o.hx__closures__[m.__id__]; if( f == null ) { f = function(){ return f.method.apply(f.scope, arguments); }; f.scope = o; f.method = m; o.hx__closures__[m.__id__] = f; } return f; }"; + ctx.separator <- true; + newline ctx; + end; + List.iter (gen_block ~after:true ctx) (List.rev ctx.inits); + List.iter (generate_static ctx) (List.rev ctx.statics); + (match com.main with + | None -> () + | Some e -> gen_expr ctx e; newline ctx); + if ctx.found_expose then begin + (* TODO(bruno): Remove runtime branching when standard node haxelib is available *) + print ctx +"function $hxExpose(src, path) { + var o = typeof window != \"undefined\" ? window : exports; + var parts = path.split(\".\"); + for(var ii = 0; ii < parts.length-1; ++ii) { + var p = parts[ii]; + if(typeof o[p] == \"undefined\") o[p] = {}; + o = o[p]; + } + o[parts[parts.length-1]] = src; +}"; + newline ctx; + end; + if ctx.js_modern then begin + print ctx "})()"; + newline ctx; + end; + if com.debug then write_mappings ctx else (try Sys.remove (com.file ^ ".map") with _ -> ()); + let ch = open_out_bin com.file in + output_string ch (Buffer.contents ctx.buf); + close_out ch); + t() + diff --git a/haxe/genneko.ml b/genneko.ml similarity index 70% rename from haxe/genneko.ml rename to genneko.ml index b72f8c1dbe66558dcffef8339c1b05b9940b6823..e1f6b51ce9a27a2e0d4ffba73f3ed69b7eb312b6 100644 --- a/haxe/genneko.ml +++ b/genneko.ml @@ -1,28 +1,32 @@ (* - * Haxe Compiler - * Copyright (c)2005 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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 Nast -open Nxml open Common type context = { + version : int; com : Common.context; packages : (string list, unit) Hashtbl.t; globals : (string list * string, string) Hashtbl.t; @@ -30,8 +34,6 @@ type context = { mutable macros : bool; mutable curclass : string; mutable curmethod : string; - mutable locals : (string , bool) PMap.t; - mutable curblock : texpr list; mutable inits : (tclass * texpr) list; } @@ -41,7 +43,7 @@ let pos ctx p = if ctx.macros then { psource = p.pfile; - pline = p.pmin lor (p.pmax lsl 16); + pline = p.pmin lor ((p.pmax - p.pmin) lsl 20); } else let file = (match ctx.com.debug with | true -> ctx.curclass ^ "::" ^ ctx.curmethod @@ -80,57 +82,6 @@ let gen_global_name ctx path = Hashtbl.add ctx.globals path name; name -let add_local ctx v p = - let rec loop flag e = - match e.eexpr with - | TLocal a -> - if flag && a = v then raise Exit - | TFunction f -> - if not (List.exists (fun (a,_,_) -> a = v) f.tf_args) then loop true f.tf_expr - | TVars l -> - if List.exists (fun (a,_,_) -> a = v) l then raise Not_found; - Type.iter (loop flag) e - | TFor (a,_,e1,e2) -> - loop flag e1; - if a <> v then loop flag e2 - | TMatch (e,_,cases,eo) -> - loop flag e; - (match eo with None -> () | Some e -> loop flag e); - List.iter (fun (_,params,e) -> - match params with - | Some l when List.exists (fun (a,_) -> a = Some v) l -> () - | _ -> loop flag e - ) cases - | TBlock l -> - (try - List.iter (loop flag) l - with - Not_found -> ()) - | TTry (e,catchs) -> - loop flag e; - List.iter (fun (a,_,e) -> if a <> v then loop flag e) catchs - | _ -> - Type.iter (loop flag) e - in - let isref = (try - List.iter (loop false) ctx.curblock; - false - with - | Not_found -> false - | Exit -> true - ) in - ctx.locals <- PMap.add v isref ctx.locals; - isref - -let block ctx curblock = - let l = ctx.locals in - let b = ctx.curblock in - ctx.curblock <- curblock; - (fun() -> - ctx.locals <- l; - ctx.curblock <- b; - ) - let null p = (EConst Null,p) @@ -209,7 +160,14 @@ let rec gen_big_string ctx p s = let gen_constant ctx pe c = let p = pos ctx pe in match c with - | TInt i -> (try int p (Int32.to_int i) with _ -> error "This integer is too big to be compiled to a Neko 31-bit integer. Please use a Float instead" pe) + | TInt i -> + (try + let h = Int32.to_int (Int32.shift_right_logical i 24) in + if (h land 128 = 0) <> (h land 64 = 0) then raise Exit; + int p (Int32.to_int i) + with _ -> + if ctx.version < 2 then error "This integer is too big to be compiled to a Neko 31-bit integer. Please use a Float instead" pe; + (EConst (Int32 i),p)) | TFloat f -> (EConst (Float f),p) | TString s -> call p (field p (ident p "String") "new") [gen_big_string ctx p s] | TBool b -> (EConst (if b then True else False),p) @@ -226,7 +184,7 @@ and gen_unop ctx p op flag e = | Decrement -> (EBinop ((if flag = Prefix then "-=" else "--="), gen_expr ctx e , int p 1),p) | Not -> call p (builtin p "not") [gen_expr ctx e] | Neg -> (EBinop ("-",int p 0, gen_expr ctx e),p) - | NegBits -> error "Operation not available" e.epos + | NegBits -> (EBinop ("-",int p (-1), gen_expr ctx e),p) and gen_call ctx p e el = match e.eexpr , el with @@ -237,14 +195,14 @@ and gen_call ctx p e el = this p; array p (List.map (gen_expr ctx) el) ] - | TLocal "__resources__", [] -> + | TLocal { v_name = "__resources__" }, [] -> call p (builtin p "array") (Hashtbl.fold (fun name data acc -> (EObject [("name",gen_constant ctx e.epos (TString name));("data",gen_big_string ctx p data)],p) :: acc ) ctx.com.resources []) | TField ({ eexpr = TConst TSuper; etype = t },f) , _ -> let c = (match follow t with TInst (c,_) -> c | _ -> assert false) in call p (builtin p "call") [ - field p (gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path)) f; + field p (gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path)) (field_name f); this p; array p (List.map (gen_expr ctx) el) ] @@ -257,42 +215,43 @@ and gen_expr ctx e = match e.eexpr with | TConst c -> gen_constant ctx e.epos c - | TLocal s -> - let isref = try PMap.find s ctx.locals with Not_found -> false in - if isref then - (EArray (ident p s,int p 0),p) + | TLocal v when v.v_name.[0] = '$' -> + (EConst (Builtin (String.sub v.v_name 1 (String.length v.v_name - 1))),p) + | TLocal v -> + if v.v_capture then + (EArray (ident p v.v_name,int p 0),p) else - ident p s - | TEnumField (e,f) -> - field p (gen_type_path p e.e_path) f + ident p v.v_name | TArray (e1,e2) -> (EArray (gen_expr ctx e1,gen_expr ctx e2),p) | TBinop (OpAssign,{ eexpr = TField (e1,f) },e2) -> - (EBinop ("=",field p (gen_expr ctx e1) f,gen_expr ctx e2),p) + (EBinop ("=",field p (gen_expr ctx e1) (field_name f),gen_expr ctx e2),p) | TBinop (op,e1,e2) -> gen_binop ctx p op e1 e2 - | TField (e,f) -> - field p (gen_expr ctx e) f - | TClosure (e2,f) -> + | TField (e2,FClosure (_,f)) -> (match follow e.etype with | TFun (args,_) -> let n = List.length args in if n > 5 then error "Cannot create closure with more than 5 arguments" e.epos; let tmp = ident p "@tmp" in EBlock [ - (EVars ["@tmp", Some (gen_expr ctx e2); "@fun", Some (field p tmp f)] , p); + (EVars ["@tmp", Some (gen_expr ctx e2); "@fun", Some (field p tmp f.cf_name)] , p); if ctx.macros then call p (builtin p "closure") [ident p "@fun";tmp] else call p (ident p ("@closure" ^ string_of_int n)) [tmp;ident p "@fun"] ] , p | _ -> assert false) + | TField (e,f) -> + field p (gen_expr ctx e) (field_name f) | TTypeExpr t -> gen_type_path p (t_path t) | TParenthesis e -> (EParenthesis (gen_expr ctx e),p) | TObjectDecl fl -> - (EObject (List.map (fun (f,e) -> f , gen_expr ctx e) fl),p) + let hasToString = ref false in + let fl = List.map (fun (f,e) -> if f = "toString" then hasToString := (match follow e.etype with TFun ([],_) -> true | _ -> false); f , gen_expr ctx e) fl in + (EObject (if !hasToString then ("__string",ident p "@default__string") :: fl else fl),p) | TArrayDecl el -> call p (field p (ident p "Array") "new1") [array p (List.map (gen_expr ctx) el); int p (List.length el)] | TCall (e,el) -> @@ -302,79 +261,65 @@ and gen_expr ctx e = | TUnop (op,flag,e) -> gen_unop ctx p op flag e | TVars vl -> - (EVars (List.map (fun (v,_,e) -> - let isref = add_local ctx v p in + (EVars (List.map (fun (v,e) -> let e = (match e with | None -> - if isref then + if v.v_capture then Some (call p (builtin p "array") [null p]) else None | Some e -> let e = gen_expr ctx e in - if isref then + if v.v_capture then Some (call p (builtin p "array") [e]) else Some e ) in - v , e + v.v_name , e ) vl),p) | TFunction f -> - let b = block ctx [f.tf_expr] in - let inits = List.fold_left (fun acc (a,c,t) -> - let acc = (match c with - | None | Some TNull -> acc - | Some c -> gen_expr ctx (Codegen.set_default ctx.com a c t e.epos) :: acc - ) in - if add_local ctx a p then - (EBinop ("=",ident p a,call p (builtin p "array") [ident p a]),p) :: acc + let inits = List.fold_left (fun acc (a,c) -> + let acc = if a.v_capture then + (EBinop ("=",ident p a.v_name,call p (builtin p "array") [ident p a.v_name]),p) :: acc else acc + in + match c with + | None | Some TNull -> acc + | Some c -> gen_expr ctx (Codegen.set_default ctx.com a c e.epos) :: acc ) [] f.tf_args in let e = gen_expr ctx f.tf_expr in let e = (match inits with [] -> e | _ -> EBlock (List.rev (e :: inits)),p) in - let e = (EFunction (List.map arg_name f.tf_args, with_return e),p) in - b(); - e + (EFunction (List.map arg_name f.tf_args, with_return e),p) | TBlock el -> - let b = block ctx el in - let rec loop = function - | [] -> [] - | e :: l -> - ctx.curblock <- l; - let e = gen_expr ctx e in - e :: loop l - in - let e = (EBlock (loop el), p) in - b(); - e - | TFor (v, _, it, e) -> + (EBlock (List.map (gen_expr ctx) el), p) + | TFor (v, it, e) -> let it = gen_expr ctx it in - let b = block ctx [e] in - let isref = add_local ctx v p in let e = gen_expr ctx e in - b(); let next = call p (field p (ident p "@tmp") "next") [] in - let next = (if isref then call p (builtin p "array") [next] else next) in + let next = (if v.v_capture then call p (builtin p "array") [next] else next) in (EBlock [(EVars ["@tmp", Some it],p); (EWhile (call p (field p (ident p "@tmp") "hasNext") [], (EBlock [ - (EVars [v, Some next],p); + (EVars [v.v_name, Some next],p); e ],p) ,NormalWhile),p)] ,p) | TIf (cond,e1,e2) -> + (* if(e)-1 is parsed as if( e - 1 ) *) + let parent e = mk (TParenthesis e) e.etype e.epos in + let e1 = (match e1.eexpr with TConst (TInt n) when n < 0l -> parent e1 | TConst (TFloat f) when f.[0] = '-' -> parent e1 | _ -> e1) in (EIf (gen_expr ctx cond,gen_expr ctx e1,(match e2 with None -> None | Some e -> Some (gen_expr ctx e))),p) | TWhile (econd,e,flag) -> (EWhile (gen_expr ctx econd, gen_expr ctx e, match flag with Ast.NormalWhile -> NormalWhile | Ast.DoWhile -> DoWhile),p) | TTry (e,catchs) -> let rec loop = function | [] -> call p (builtin p "rethrow") [ident p "@tmp"] - | (v,t,e) :: l -> + | (v,e) :: l -> let e2 = loop l in - let path = (match follow t with + let path = (match follow v.v_type with | TInst (c,_) -> Some c.cl_path | TEnum (e,_) -> Some e.e_path | TDynamic _ -> None @@ -384,14 +329,11 @@ and gen_expr ctx e = | None -> (EConst True,p) | Some path -> call p (field p (gen_type_path p (["neko"],"Boot")) "__instanceof") [ident p "@tmp"; gen_type_path p path] ) in - let b = block ctx [e] in - let isref = add_local ctx v p in let id = ident p "@tmp" in - let id = (if isref then call p (builtin p "array") [id] else id) in + let id = (if v.v_capture then call p (builtin p "array") [id] else id) in let e = gen_expr ctx e in - b(); (EIf (cond,(EBlock [ - EVars [v,Some id],p; + EVars [v.v_name,Some id],p; e; ],p),Some e2),p) in @@ -416,8 +358,9 @@ and gen_expr ctx e = | TCast (e,None) -> gen_expr ctx e | TCast (e1,Some t) -> - gen_expr ctx (Codegen.default_cast ctx.com e1 t e.etype e.epos) + gen_expr ctx (Codegen.default_cast ~vtmp:"@tmp" ctx.com e1 t e.etype e.epos) | TMatch (e,_,cases,eo) -> + let p = pos ctx e.epos in let etmp = (EVars ["@tmp",Some (gen_expr ctx e)],p) in let eindex = field p (ident p "@tmp") "index" in let gen_params params e = @@ -425,21 +368,18 @@ and gen_expr ctx e = | None -> gen_expr ctx e | Some el -> - let b = block ctx [e] in let count = ref (-1) in - let vars = List.fold_left (fun acc (v,_) -> + let vars = List.fold_left (fun acc v -> incr count; match v with | None -> acc | Some v -> - let isref = add_local ctx v p in let e = (EArray (ident p "@tmp",int p (!count)),p) in - let e = (if isref then call p (builtin p "array") [e] else e) in - (v , Some e) :: acc + let e = (if v.v_capture then call p (builtin p "array") [e] else e) in + (v.v_name , Some e) :: acc ) [] el in let e = gen_expr ctx e in - b(); (EBlock [ (EVars ["@tmp",Some (field p (ident p "@tmp") "args")],p); (match vars with [] -> null p | _ -> EVars vars,p); @@ -508,14 +448,13 @@ and gen_expr ctx e = let gen_method ctx p c acc = ctx.curmethod <- c.cf_name; + if is_extern_field c then acc else match c.cf_expr with | None -> - (match c.cf_kind with - | Var { v_read = AccResolve } -> acc - | _ -> (c.cf_name, null p) :: acc) + ((c.cf_name, null p) :: acc) | Some e -> match e.eexpr with - | TCall ({ eexpr = TField ({ eexpr = TTypeExpr (TClassDecl { cl_path = (["neko"],"Lib") }) }, load)},[{ eexpr = TConst (TString m) };{ eexpr = TConst (TString f) };{ eexpr = TConst (TInt n) }]) when load = "load" || load = "loadLazy" -> + | TCall ({ eexpr = TField (_,FStatic ({cl_path=["neko"],"Lib"},{cf_name="load" | "loadLazy" as load})) },[{ eexpr = TConst (TString m) };{ eexpr = TConst (TString f) };{ eexpr = TConst (TInt n) }]) -> let p = pos ctx e.epos in let e = call p (EField (builtin p "loader","loadprim"),p) [(EBinop ("+",(EBinop ("+",str p m,str p "@"),p),str p f),p); (EConst (Int (Int32.to_int n)),p)] in let e = (if load = "load" then e else (ETry (e,"@e",call p (ident p "@lazy_error") [ident p "@e"]),p)) in @@ -533,7 +472,7 @@ let gen_class ctx c = | Some f -> (match follow f.cf_type with | TFun (args,_) -> - let params = List.map arg_name args in + let params = List.map (fun (n,_,_) -> n) args in gen_method ctx p f ["new",(EFunction (params,(EBlock [ (EVars ["@o",Some (call p (builtin p "new") [null p])],p); (call p (builtin p "objsetproto") [ident p "@o"; clpath]); @@ -547,12 +486,7 @@ let gen_class ctx c = let fstring = (try let f = PMap.find "toString" c.cl_fields in match follow f.cf_type with - | TFun ([],_) -> - ["__string",(EFunction ([],(EBlock [ - EVars ["@s",Some (call p (field p (this p) "toString") [])] ,p; - EIf ((EBinop ("!=",call p (builtin p "typeof") [ident p "@s"],builtin p "tobject"),p),(EReturn (Some (null p)),p),None),p; - EReturn (Some (field p (ident p "@s") "__s")),p; - ],p)),p)] + | TFun ([],_) -> ["__string",ident p "@default__string"] | _ -> [] with Not_found -> [] @@ -568,9 +502,14 @@ let gen_class ctx c = let build (f,e) = (EBinop ("=",field p (ident p "@tmp") f,e),p) in let tmp = (EVars ["@tmp",Some (call p (builtin p "new") [null p])],p) in let estat = (EBinop ("=", stpath, ident p "@tmp"),p) in + let gen_props props = (EObject (List.map (fun (n,s) -> n,str p s) props),p) in + let sprops = (match Codegen.get_properties c.cl_ordered_statics with + | [] -> [] + | l -> ["__properties__",gen_props l] + ) in let sfields = List.map build ( - ("prototype",clpath) :: + ("prototype",clpath) :: sprops @ PMap.fold (gen_method ctx p) c.cl_statics (fnew @ others) ) in @@ -578,11 +517,31 @@ let gen_class ctx c = let mfields = List.map build (PMap.fold (gen_method ctx p) c.cl_fields (fserialize :: fstring)) in + let props = Codegen.get_properties c.cl_ordered_fields in let emeta = (EBinop ("=",field p clpath "__class__",stpath),p) :: - match c.cl_path with + (match props with + | [] -> [] + | _ -> + let props = gen_props props in + let props = (match c.cl_super with + | Some (csup,_) when Codegen.has_properties csup -> + (EBlock [ + (EVars ["@tmp",Some props],p); + call p (builtin p "objsetproto") [ident p "@tmp";field p (field p (gen_type_path p csup.cl_path) "prototype") "__properties__"]; + ident p "@tmp" + ],p) + | _ -> props + ) in + [EBinop ("=",field p clpath "__properties__",props),p]) + @ match c.cl_path with | [] , name -> [(EBinop ("=",field p (ident p "@classes") name,ident p name),p)] | _ -> [] in + let emeta = if ctx.macros then + (EBinop ("=",field p stpath "__ct__",call p (builtin p "typewrap") [Obj.magic (TClassDecl c)]),p) :: emeta + else + emeta + in let eextends = (match c.cl_super with | None -> [] | Some (c,_) -> @@ -596,7 +555,7 @@ let gen_enum_constr ctx path c = let p = pos ctx c.ef_pos in (EBinop ("=",field p path c.ef_name, match follow c.ef_type with | TFun (params,_) -> - let params = List.map arg_name params in + let params = List.map (fun (n,_,_) -> n) params in (EFunction (params, (EBlock [ (EVars ["@tmp",Some (EObject [ @@ -651,12 +610,12 @@ let gen_type ctx t acc = acc else gen_enum ctx e :: acc - | TTypeDecl t -> + | TTypeDecl _ | TAbstractDecl _ -> acc let gen_static_vars ctx t = match t with - | TEnumDecl _ | TTypeDecl _ -> [] + | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ -> [] | TClassDecl c -> if c.cl_extern then [] @@ -684,7 +643,7 @@ let gen_package ctx t = | x :: l -> let path = acc @ [x] in if not (Hashtbl.mem ctx.packages path) then begin - let p = pos ctx (match t with TClassDecl c -> c.cl_pos | TEnumDecl e -> e.e_pos | TTypeDecl t -> t.t_pos) in + let p = pos ctx (t_infos t).mt_pos in let e = (EBinop ("=",gen_type_path p (acc,x),call p (builtin p "new") [null p]),p) in Hashtbl.add ctx.packages path (); (match acc with @@ -720,6 +679,11 @@ let gen_name ctx acc t = | None -> [] | Some e -> [EBinop ("=",field p path "__meta__", gen_expr ctx e),p] ) in + let meta = if ctx.macros then + (EBinop ("=",field p path "__et__",call p (builtin p "typewrap") [Obj.magic t]),p) :: meta + else + meta + in setname :: setconstrs :: meta @ acc | TClassDecl c -> if c.cl_extern then @@ -734,28 +698,63 @@ let gen_name ctx acc t = | l -> let interf = field p (gen_type_path p c.cl_path) "__interfaces__" in (EBinop ("=",interf, call p (field p (ident p "Array") "new1") [interf; int p (List.length l)]),p) :: acc) - | TTypeDecl _ -> + | TTypeDecl _ | TAbstractDecl _ -> acc let generate_libs_init = function - | [] -> "" + | [] -> [] | libs -> - let boot = - "var @s = $loader.loadprim(\"std@sys_string\",0)();" ^ - "var @env = $loader.loadprim(\"std@get_env\",1);" ^ - "var @b = if( @s == \"Windows\" ) " ^ - "@env(\"HAXEPATH\") + \"lib\\\\\"" ^ - "else try $loader.loadprim(\"std@file_contents\",1)(@env(\"HOME\")+\"/.haxelib\") + \"/\"" ^ - "catch e if( @s == \"Linux\" ) \"/usr/lib/haxe/lib/\" else \"/usr/local/lib/haxe/lib/\";" ^ - "@s = @s + \"/\";" + (* + var @s = $loader.loadprim("std@sys_string",0)(); + var @env = $loader.loadprim("std@get_env",1); + var @b = if( @s == "Windows" ) + @env("HAXEPATH") + "\\lib\\" + else try $loader.loadprim("std@file_contents",1)(@env("HOME")+"/.haxelib") + "/" + catch e if( @s == "Linux" ) "/usr/lib/haxe/lib/" else "/usr/local/lib/haxe/lib/"; + if( $loader.loadprim("std@sys_is64",0)() ) @s = @s + 64; + @s = @s + "/" + *) + let p = null_pos in + let es = ident p "@s" in + let loadp n nargs = + call p (field p (builtin p "loader") "loadprim") [str p ("std@" ^ n); int p nargs] in - List.fold_left (fun acc l -> - let full_path = l.[0] = '/' || l.[1] = ':' in - acc ^ "$loader.path = $array(" ^ (if full_path then "" else "@b + ") ^ "\"" ^ Nast.escape l ^ "\" + @s,$loader.path);" - ) boot libs - -let new_context com macros = + let op o e1 e2 = + (EBinop (o,e1,e2),p) + in + let boot = [ + (EVars [ + "@s",Some (call p (loadp "sys_string" 0) []); + "@env",Some (loadp "get_env" 1); + "@b", Some (EIf (op "==" es (str p "Windows"), + op "+" (call p (ident p "@env") [str p "HAXEPATH"]) (str p "\\lib\\"), + Some (ETry ( + op "+" (call p (loadp "file_contents" 1) [op "+" (call p (ident p "@env") [str p "HOME"]) (str p "./haxelib")]) (str p "/"), + "e", + (EIf (op "==" es (str p "Linux"), + str p "/usr/lib/haxe/lib/", + Some (str p "/usr/local/lib/haxe/lib/") + ),p) + ),p) + ),p); + ],p); + (EIf (call p (loadp "sys_is64" 0) [],op "=" es (op "+" es (int p 64)),None),p); + op "=" es (op "+" es (str p "/")); + ] in + let lpath = field p (builtin p "loader") "path" in + boot @ List.map (fun dir -> + let full_path = dir.[0] = '/' || dir.[1] = ':' in + let dstr = str p dir in + (* + // for each lib dir + $loader.path = $array($loader.path,dir+@s); + *) + op "=" lpath (call p (builtin p "array") [op "+" (if full_path then dstr else op "+" (ident p "@b") dstr) (ident p "@s"); lpath]) + ) libs + +let new_context com ver macros = { + version = ver; com = com; globals = Hashtbl.create 0; curglobal = 0; @@ -764,8 +763,6 @@ let new_context com macros = curclass = "$boot"; curmethod = "$init"; inits = []; - curblock = []; - locals = PMap.empty; } let header() = @@ -787,6 +784,11 @@ let header() = "@serialize",func [] (call p (fields ["neko";"Boot";"__serialize"]) [this p]); "@tag_serialize",func [] (call p (fields ["neko";"Boot";"__tagserialize"]) [this p]); "@lazy_error",func ["e"] (call p (builtin p "varargs") [func ["_"] (call p (builtin p "throw") [ident p "e"])]); + "@default__string",func [] (EBlock [ + EVars ["@s",Some (call p (field p (this p) "toString") [])] ,p; + EIf ((EBinop ("!=",call p (builtin p "typeof") [ident p "@s"],builtin p "tobject"),p),(EReturn (Some (null p)),p),None),p; + EReturn (Some (field p (ident p "@s") "__s")),p; + ],p) ] in let inits = inits @ List.map (fun nargs -> let args = Array.to_list (Array.init nargs (fun i -> Printf.sprintf "%c" (char_of_int (int_of_char 'a' + i)))) in @@ -814,31 +816,41 @@ let build ctx types = let vars = List.concat (List.map (gen_static_vars ctx) types) in packs @ methods @ boot :: names @ inits @ vars -let generate com libs = - let ctx = new_context com false in +let generate com = + let ctx = new_context com (if Common.defined com Define.NekoV1 then 1 else 2) false in let t = Common.timer "neko generation" in - let libs = (ENeko (generate_libs_init libs) , { psource = "
"; pline = 1; }) in + let libs = (EBlock (generate_libs_init com.neko_libs) , { psource = "
"; pline = 1; }) in let el = build ctx com.types in let emain = (match com.main with None -> [] | Some e -> [gen_expr ctx e]) in let e = (EBlock ((header()) @ libs :: el @ emain), null_pos) in + let source = Common.defined com Define.NekoSource in + let use_nekoc = Common.defined com Define.UseNekoc in + if not use_nekoc then begin + try + let ch = IO.output_channel (open_out_bin com.file) in + Nbytecode.write ch (Ncompile.compile ctx.version e); + IO.close_out ch; + with Ncompile.Error (msg,pos) -> + let rec loop p = + let pp = { pfile = pos.psource; pmin = p; pmax = p; } in + if Lexer.get_error_line pp >= pos.pline then + pp + else + loop (p + 1) + in + error msg (loop 0) + end; + let command cmd = try com.run_command cmd with _ -> -1 in let neko_file = (try Filename.chop_extension com.file with _ -> com.file) ^ ".neko" in - let ch = IO.output_channel (open_out_bin neko_file) in - let source = Common.defined com "neko_source" in - if source then Nxml.write ch (Nxml.to_xml e) else Binast.write ch e; - IO.close_out ch; - t(); - let command cmd = try Sys.command cmd with _ -> -1 in + if source || use_nekoc then begin + let ch = IO.output_channel (open_out_bin neko_file) in + Binast.write ch e; + IO.close_out ch; + end; + if use_nekoc && command ("nekoc" ^ (if ctx.version > 1 then " -version " ^ string_of_int ctx.version else "") ^ " \"" ^ neko_file ^ "\"") <> 0 then failwith "Neko compilation failure"; if source then begin if command ("nekoc -p \"" ^ neko_file ^ "\"") <> 0 then failwith "Failed to print neko code"; Sys.remove neko_file; Sys.rename ((try Filename.chop_extension com.file with _ -> com.file) ^ "2.neko") neko_file; end; - let c = Common.timer "neko compilation" in - if command ("nekoc \"" ^ neko_file ^ "\"") <> 0 then failwith "Neko compilation failure"; - c(); - let output = Filename.chop_extension neko_file ^ ".n" in - if output <> com.file then begin - (try Sys.remove com.file with _ -> ()); - Sys.rename output com.file; - end; - if not source then Sys.remove neko_file + t() diff --git a/haxe/genphp.ml b/genphp.ml similarity index 73% rename from haxe/genphp.ml rename to genphp.ml index 9e67e0c5b060c37b4f8d9abb4db51a2d3be28036..367e2fb1e395b9a1561e34c2e58a74ee97bbd010 100644 --- a/haxe/genphp.ml +++ b/genphp.ml @@ -1,22 +1,25 @@ (* - * haXe/PHP Compiler - * Copyright (c)2008 Franco Ponticelli - * based on and including code by (c)2005-2008 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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 @@ -86,7 +89,7 @@ let rec class_string klass suffix params = (* Array class *) | ([],"Array") -> (snd klass.cl_path) ^ suffix ^ "<" ^ (String.concat "," (List.map type_string params) ) ^ " >" - | _ when klass.cl_kind=KTypeParameter -> "Dynamic" + | _ when (match klass.cl_kind with KTypeParameter _ -> true | _ -> false) -> "Dynamic" | ([],"#Int") -> "/* # */int" | (["haxe";"io"],"Unsigned_char__") -> "unsigned char" | ([],"Class") -> "Class" @@ -97,19 +100,24 @@ let rec class_string klass suffix params = | TInst ({ cl_path = [],"Float" },_) | TEnum ({ e_path = [],"Bool" },_) -> "Dynamic" | _ -> "/*NULL*/" ^ (type_string t) ) - | _ -> assert false); + | _ -> assert false); (* Normal class *) | _ -> (join_class_path klass.cl_path "::") ^ suffix ) and type_string_suff suffix haxe_type = (match haxe_type with | TMono r -> (match !r with None -> "Dynamic" | Some t -> type_string_suff suffix t) + | TAbstract ({ a_path = [],"Int" },[]) -> "int" + | TAbstract ({ a_path = [],"Float" },[]) -> "double" + | TAbstract ({ a_path = [],"Bool" },[]) -> "bool" + | TAbstract ({ a_path = [],"Void" },[]) -> "Void" | TEnum ({ e_path = ([],"Void") },[]) -> "Void" | TEnum ({ e_path = ([],"Bool") },[]) -> "bool" | TInst ({ cl_path = ([],"Float") },[]) -> "double" | TInst ({ cl_path = ([],"Int") },[]) -> "int" | TEnum (enum,params) -> (join_class_path enum.e_path "::") ^ suffix | TInst (klass,params) -> (class_string klass suffix params) + | TAbstract (abs,params) -> (join_class_path abs.a_path "::") ^ suffix | TType (type_def,params) -> (match type_def.t_path with | [] , "Null" -> @@ -132,24 +140,30 @@ and type_string_suff suffix haxe_type = | TDynamic haxe_type -> "Dynamic" | TLazy func -> type_string_suff suffix ((!func)()) ) -and type_string haxe_type = +and type_string haxe_type = type_string_suff "" haxe_type;; let debug_expression expression type_too = - "/* " ^ Type.s_expr_kind expression ^ (if (type_too) then " = " ^ (type_string expression.etype) else "") ^ " */";; + "/* " ^ Type.s_expr_kind expression ^ (if (type_too) then " = " ^ (type_string (follow expression.etype)) else "") ^ " */";; -let rec register_extern_required_path ctx path = +let rec register_extern_required_path ctx path = if (List.exists(fun p -> p = path) ctx.extern_classes_with_init) && not (List.exists(fun p -> p = path) ctx.extern_required_paths) then ctx.extern_required_paths <- path :: ctx.extern_required_paths - + let s_expr_expr = Type.s_expr_kind let s_expr_name e = - s_type (print_context()) e.etype + s_type (print_context()) (follow e.etype) let s_type_name t = s_type (print_context()) t - + + + +and start_with s test = + let len = String.length test in + (String.length s > len && String.sub s 0 len = test) + let rec is_uncertain_type t = match follow t with | TInst (c, _) -> c.cl_interface @@ -194,21 +208,64 @@ let rec is_string_type t = (match !(a.a_status) with | Statics ({cl_path = ([], "String")}) -> true | _ -> false) + | TAbstract (a,pl) -> is_string_type (Codegen.Abstract.get_underlying_type a pl) | _ -> false let is_string_expr e = is_string_type e.etype +let to_string ctx e = + let v = alloc_var "__call__" t_dynamic in + let f = mk (TLocal v) t_dynamic e.epos in + mk (TCall (f, [ Codegen.string ctx.com "_hx_string_rec" e.epos; e; Codegen.string ctx.com "" e.epos])) ctx.com.basic.tstring e.epos + +let as_string_expr ctx e = + match e.eexpr with + | TConst (TNull) -> + to_string ctx e + | _ when not (is_string_expr e) -> + to_string ctx e + | _ -> e +(* for known String type that could have null value *) +let to_string_null ctx e = + let v = alloc_var "__call__" t_dynamic in + let f = mk (TLocal v) t_dynamic e.epos in + mk (TCall (f, [ Codegen.string ctx.com "_hx_string_or_null" e.epos; e])) ctx.com.basic.tstring e.epos + + +let as_string_expr ctx e = match e.eexpr with + | TConst (TNull) -> to_string ctx e + | TConst (TString s) -> e + | TBinop (op,_,_) when (is_string_expr e)-> e + | TCall ({eexpr = TField({eexpr = TTypeExpr(TClassDecl {cl_path = ([],"Std")})},FStatic(c,f) )}, [_]) when (f.cf_name="string") -> e + | TCall ({eexpr = TLocal _}, [{eexpr = TConst (TString ("_hx_string_rec" | "_hx_str_or_null"))}]) -> e + | _ when not (is_string_expr e) -> to_string ctx e + | _ -> to_string_null ctx e + let spr ctx s = Buffer.add_string ctx.buf s let print ctx = Printf.kprintf (fun s -> Buffer.add_string ctx.buf s) +(*--php-prefix - added by skial bainn*) +let prefix_class com name = + match com.php_prefix with + | Some prefix_class (* when not (String.length name <= 2 || String.sub name 0 2 = "__") *) -> + prefix_class ^ name + | _ -> + name + +let prefix_init_replace com code = + let r = Str.regexp "php_Boot" in + Str.global_replace r ("php_" ^ (prefix_class com "Boot")) code + let s_path ctx path isextern p = if isextern then begin register_extern_required_path ctx path; snd path end else begin (match path with - | ([],"List") -> "HList" - | ([],name) -> name + (*--php-prefix*) + | ([],"List") -> (prefix_class ctx.com "HList") + (*--php-prefix*) + | ([],name) -> (prefix_class ctx.com name) | (pack,name) -> (try (match Hashtbl.find ctx.imports name with @@ -218,7 +275,8 @@ let s_path ctx path isextern p = if not (List.mem pack packs) then Hashtbl.replace ctx.imports name (pack :: packs)) with Not_found -> Hashtbl.add ctx.imports name [pack]); - String.concat "_" pack ^ "_" ^ name); + (*--php-prefix*) + String.concat "_" pack ^ "_" ^ (prefix_class ctx.com name)) end let s_path_haxe path = @@ -226,35 +284,55 @@ let s_path_haxe path = | [], s -> s | el, s -> String.concat "." el ^ "." ^ s -let s_ident n = - let suf = "h" in +let escape_bin s = + let b = Buffer.create 0 in + for i = 0 to String.length s - 1 do + match Char.code (String.unsafe_get s i) with + | c when c = Char.code('\\') or c = Char.code('"') or c = Char.code('$') -> + Buffer.add_string b "\\"; + Buffer.add_char b (Char.chr c) + | c when c < 32 -> + Buffer.add_string b (Printf.sprintf "\\x%.2X" c) + | c -> + Buffer.add_char b (Char.chr c) + done; + Buffer.contents b + (* haxe reserved words that match php ones: break, case, class, continue, default, do, else, extends, for, function, if, new, return, static, switch, var, while, interface, implements, public, private, try, catch, throw *) (* PHP only (for future use): cfunction, old_function *) +let is_keyword n = match String.lowercase n with | "and" | "or" | "xor" | "__file__" | "exception" | "__line__" | "array" | "as" | "const" | "declare" | "die" | "echo"| "elseif" | "empty" | "enddeclare" | "endfor" | "endforeach" | "endif" | "endswitch" | "endwhile" | "eval" | "exit" | "foreach"| "global" | "include" - | "include_once" | "isset" | "list" | "print" | "require" | "require_once" - | "unset" | "use" | "__function__" | "__class__" | "__method__" | "final" + | "include_once" | "isset" | "list" | "namespace" | "print" | "require" | "require_once" + | "unset" | "use" | "__function__" | "__class__" | "__method__" | "final" | "php_user_filter" | "protected" | "abstract" | "__set" | "__get" | "__call" - | "clone" -> suf ^ n - | _ -> n - + | "clone" | "instanceof" | "break" | "case" | "class" | "continue" | "default" | "do" | "else" | "extends" | "for" | "function" | "if" | "new" | "return" | "static" | "switch" | "var" | "while" | "interface" | "implements" | "public" | "private" | "try" | "catch" | "throw" -> true + | _ -> false + +let s_ident n = + let suf = "h" in + if (is_keyword n) then (suf ^ n) else n + +let s_ident_field n = + if (is_keyword n) then ("{\"" ^ (escape_bin n) ^ "\"}") else n + let s_ident_local n = let suf = "h" in match String.lowercase n with - | "globals" | "_server" | "_get" | "_post" | "_cookie" | "_files" + | "globals" | "_server" | "_get" | "_post" | "_cookie" | "_files" | "_env" | "_request" | "_session" -> suf ^ n | _ -> n - + let create_directory com ldir = let atm_path = ref (String.create 0) in atm_path := com.file; if not (Sys.file_exists com.file) then (Unix.mkdir com.file 0o755); - (List.iter (fun p -> atm_path := !atm_path ^ "/" ^ p; if not (Sys.file_exists !atm_path) then (Unix.mkdir !atm_path 0o755);) ldir) + (List.iter (fun p -> atm_path := !atm_path ^ "/" ^ p; if not (Sys.file_exists !atm_path) then (Unix.mkdir !atm_path 0o755);) ldir) let write_resource dir name data = let i = ref 0 in @@ -268,9 +346,9 @@ let write_resource dir name data = let ch = open_out_bin (rdir ^ "/" ^ name) in output_string ch data; close_out ch - + let stack_init com use_add = - Codegen.stack_context_init com "GLOBALS['%s']" "GLOBALS['%e']" "»spos" "»tmp" use_add null_pos + Codegen.stack_context_init com "GLOBALS['%s']" "GLOBALS['%e']" "__hx__spos" "tmp" use_add null_pos let init com cwd path def_type = let rec create acc = function @@ -283,9 +361,10 @@ let init com cwd path def_type = let dir = if cwd <> "" then com.file :: (cwd :: fst path) else com.file :: fst path; in create [] dir; let filename path = - (match path with + prefix_class com (match path with | [], "List" -> "HList"; | _, s -> s) in + (*--php-prefix*) let ch = open_out (String.concat "/" dir ^ "/" ^ (filename path) ^ (if def_type = 0 then ".class" else if def_type = 1 then ".enum" else if def_type = 2 then ".interface" else ".extern") ^ ".php") in let imports = Hashtbl.create 0 in Hashtbl.add imports (snd path) [fst path]; @@ -323,8 +402,11 @@ let unsupported msg p = error ("This expression cannot be generated to PHP: " ^ let newline ctx = match Buffer.nth ctx.buf (Buffer.length ctx.buf - 1) with - | '}' | '{' | ':' | ' ' -> print ctx "\n%s" ctx.tabs - | _ -> print ctx ";\n%s" ctx.tabs + | '{' | ':' | ' ' + | '}' when Buffer.nth ctx.buf (Buffer.length ctx.buf - 2) != '"' -> + print ctx "\n%s" ctx.tabs + | _ -> + print ctx ";\n%s" ctx.tabs let rec concat ctx s f = function | [] -> () @@ -351,14 +433,14 @@ let inc_extern_path ctx path = let pre = if ctx.cwd = "" then ctx.lib_path ^ "/" else "" in match path with | ([],name) -> - pre ^ (slashes (List.length (fst ctx.path))) ^ name ^ ".extern.php" + pre ^ (slashes (List.length (fst ctx.path))) ^ (prefix_class ctx.com name) ^ ".extern.php" | (pack,name) -> - pre ^ (slashes (List.length (fst ctx.path))) ^ String.concat "/" pack ^ "/" ^ name ^ ".extern.php" - + pre ^ (slashes (List.length (fst ctx.path))) ^ String.concat "/" pack ^ "/" ^ (prefix_class ctx.com name) ^ ".extern.php" + let close ctx = output_string ctx.ch " - if path <> ctx.path then output_string ctx.ch ("require_once dirname(__FILE__).'/" ^ inc_extern_path ctx path ^ "';\n"); + if path <> ctx.path then output_string ctx.ch ("require_once dirname(__FILE__).'/" ^ (inc_extern_path ctx path) ^ "';\n"); ) (List.rev ctx.extern_required_paths); output_string ctx.ch "\n"; output_string ctx.ch (Buffer.contents ctx.buf); @@ -383,21 +465,7 @@ let define_local ctx l = loop 1 let this ctx = - if ctx.in_value <> None then "$»this" else "$this" - -let escape_bin s = - let b = Buffer.create 0 in - for i = 0 to String.length s - 1 do - match Char.code (String.unsafe_get s i) with - | c when c = Char.code('\\') or c = Char.code('"') or c = Char.code('$') -> - Buffer.add_string b "\\"; - Buffer.add_char b (Char.chr c) - | c when c < 32 -> - Buffer.add_string b (Printf.sprintf "\\x%.2X" c) - | c -> - Buffer.add_char b (Char.chr c) - done; - Buffer.contents b + if ctx.in_value <> None then "$__hx__this" else "$this" let gen_constant ctx p = function | TInt i -> print ctx "%ld" i @@ -409,10 +477,20 @@ let gen_constant ctx p = function | TThis -> spr ctx (this ctx) | TSuper -> spr ctx "ERROR /* unexpected call to super in gen_constant */" -let s_funarg ctx arg t p c = - let byref = if (String.length arg > 7 && String.sub arg 0 7 = "byref__") then "&" else "" in - print ctx "%s$%s" byref (s_ident_local arg) +let arg_is_opt c = + match c with + | Some _ -> true + | None -> false +let s_funarg ctx arg t p o = + let byref = if (String.length arg > 7 && String.sub arg 0 7 = "byref__") then "&" else "" in + print ctx "%s$%s" byref (s_ident_local arg); + if o then spr ctx " = null" +(* + match c with + | _, Some _ -> spr ctx " = null" + | _, None -> () +*) let is_in_dynamic_methods ctx e s = List.exists (fun dm -> (* TODO: I agree, this is a mess ... but after hours of trials and errors I gave up; maybe in a calmer day *) @@ -424,17 +502,17 @@ let is_dynamic_method f = | Var _ -> true | Method MethDynamic -> true | _ -> false) - + let fun_block ctx f p = let e = (match f.tf_expr with { eexpr = TBlock [{ eexpr = TBlock _ } as e] } -> e | e -> e) in - let e = List.fold_left (fun e (a,c,t) -> + let e = List.fold_left (fun e (v,c) -> match c with | None | Some TNull -> e - | Some c -> Codegen.concat (Codegen.set_default ctx.com a c t p) e + | Some c -> Codegen.concat (Codegen.set_default ctx.com v c p) e ) e f.tf_args in if ctx.com.debug then begin Codegen.stack_block ctx.stack ctx.curclass ctx.curmethod e - end else + end else mk_block e let rec gen_array_args ctx lst = @@ -443,9 +521,9 @@ let rec gen_array_args ctx lst = | h :: t -> spr ctx "["; gen_value ctx h; - spr ctx "]"; + spr ctx "]"; gen_array_args ctx t - + and gen_call ctx e el = let rec genargs lst = (match lst with @@ -468,56 +546,65 @@ and gen_call ctx e el = concat ctx "," (gen_value ctx) params; spr ctx ")"; ); - | TField ({ eexpr = TConst TSuper },name) , params -> + | TField ({ eexpr = TConst TSuper },f) , params -> (match ctx.curclass.cl_super with | None -> assert false | Some (c,_) -> - print ctx "parent::%s(" (s_ident name); + print ctx "parent::%s(" (s_ident (field_name f)); concat ctx "," (gen_value ctx) params; spr ctx ")"; ); - | TLocal "__set__" , { eexpr = TConst (TString code) } :: el -> + | TLocal { v_name = "__set__" }, { eexpr = TConst (TString code) } :: el -> print ctx "$%s" code; genargs el; - | TLocal "__set__" , e :: el -> + | TLocal { v_name = "__set__" }, e :: el -> gen_value ctx e; genargs el; - | TLocal "__setfield__" , e :: (f :: el) -> + | TLocal { v_name = "__setfield__" }, e :: (f :: el) -> gen_value ctx e; spr ctx "->{"; gen_value ctx f; spr ctx "}"; genargs el; - | TLocal "__field__" , e :: ({ eexpr = TConst (TString code) } :: el) -> + | TLocal { v_name = "__field__" }, e :: ({ eexpr = TConst (TString code) } :: el) -> gen_value ctx e; spr ctx "->"; spr ctx code; gen_array_args ctx el; - | TLocal "__field__" , e :: (f :: el) -> + | TLocal { v_name = "__field__" }, e :: (f :: el) -> gen_value ctx e; spr ctx "->"; gen_value ctx f; gen_array_args ctx el; - | TLocal "__var__" , { eexpr = TConst (TString code) } :: el -> + | TLocal { v_name = "__prefix__" }, [] -> + (match ctx.com.php_prefix with + | Some prefix -> + print ctx "\"%s\"" prefix + | None -> + spr ctx "null") + | TLocal { v_name = "__var__" }, { eexpr = TConst (TString code) } :: el -> print ctx "$%s" code; gen_array_args ctx el; - | TLocal "__var__" , e :: el -> + | TLocal { v_name = "__var__" }, e :: el -> gen_value ctx e; gen_array_args ctx el; - | TLocal "__call__" , { eexpr = TConst (TString code) } :: el -> + | TLocal { v_name = "__call__" }, { eexpr = TConst (TString code) } :: el -> spr ctx code; spr ctx "("; concat ctx ", " (gen_value ctx) el; spr ctx ")"; - | TLocal "__php__", [{ eexpr = TConst (TString code) }] -> - spr ctx code - | TLocal "__instanceof__" , [e1;{ eexpr = TConst (TString t) }] -> + | TLocal { v_name = "__php__" }, [{ eexpr = TConst (TString code) }] -> + (*--php-prefix*) + spr ctx (prefix_init_replace ctx.com code) + | TLocal { v_name = "__instanceof__" }, [e1;{ eexpr = TConst (TString t) }] -> gen_value ctx e1; print ctx " instanceof %s" t; - | TLocal "__physeq__" , [e1;e2] -> + | TLocal { v_name = "__physeq__" }, [e1;e2] -> + spr ctx "("; gen_value ctx e1; spr ctx " === "; - gen_value ctx e2 + gen_value ctx e2; + spr ctx ")" | TLocal _, [] | TFunction _, [] | TCall _, [] @@ -588,7 +675,7 @@ and gen_string_static_call ctx s e el = | _ -> unsupported "gen_string_static_call " e.epos; and could_be_string_call s = - s = "substr" || s = "charAt" || s = "charCodeAt" || s = "indexOf" || + s = "substr" || s = "substring" || s = "charAt" || s = "charCodeAt" || s = "indexOf" || s = "lastIndexOf" || s = "split" || s = "toLowerCase" || s = "toString" || s = "toUpperCase" and gen_string_call ctx s e el = @@ -599,6 +686,12 @@ and gen_string_call ctx s e el = spr ctx ", "; concat ctx ", " (gen_value ctx) el; spr ctx ")" + | "substring" -> + spr ctx "_hx_substring("; + gen_value ctx e; + spr ctx ", "; + concat ctx ", " (gen_value ctx) el; + spr ctx ")" | "charAt" -> spr ctx "_hx_char_at("; gen_value ctx e; @@ -660,7 +753,7 @@ and gen_field_op ctx e = | TField (f,s) -> (match follow e.etype with | TFun _ -> - gen_field_access ctx true f s + gen_field_access ctx true f (field_name s) | _ -> gen_value_op ctx e) | _ -> @@ -684,10 +777,12 @@ and gen_member_access ctx isvar e s = match follow e.etype with | TAnon a -> (match !(a.a_status) with - | EnumStatics _ - | Statics _ -> print ctx "::%s%s" (if isvar then "$" else "") (s_ident s) - | _ -> print ctx "->%s" (s_ident s)) - | _ -> print ctx "->%s" (s_ident s) + | EnumStatics _ -> + print ctx "::%s%s" (if isvar then "$" else "") (s_ident s) + | Statics _ -> + print ctx "::%s%s" (if isvar then "$" else "") (s_ident s) + | _ -> print ctx "->%s" (if isvar then s_ident_field s else s_ident s)) + | _ -> print ctx "->%s" (if isvar then s_ident_field s else s_ident s) and gen_field_access ctx isvar e s = match e.eexpr with @@ -696,7 +791,7 @@ and gen_field_access ctx isvar e s = gen_member_access ctx isvar e s | TLocal _ -> gen_expr ctx e; - print ctx "->%s" (s_ident s) + print ctx "->%s" (if isvar then s_ident_field s else s_ident s) | TArray (e1,e2) -> spr ctx "_hx_array_get("; gen_value ctx e1; @@ -710,9 +805,15 @@ and gen_field_access ctx isvar e s = | TArrayDecl _ | TNew _ -> spr ctx "_hx_deref("; - ctx.is_call <- false; + ctx.is_call <- false; gen_value ctx e; - spr ctx ")"; + spr ctx ")"; + gen_member_access ctx isvar e s + | TCast (ec, _) when (match ec.eexpr with | TNew _ | TArrayDecl _ -> true | _ -> false) -> + spr ctx "_hx_deref("; + ctx.is_call <- false; + gen_value ctx e; + spr ctx ")"; gen_member_access ctx isvar e s | _ -> gen_expr ctx e; @@ -727,10 +828,10 @@ and gen_dynamic_function ctx isstatic name f params p = ctx.local_types <- List.map snd params @ ctx.local_types; let byref = if (String.length name > 9 && String.sub name 0 9 = "__byref__") then "&" else "" in print ctx "function %s%s(" byref name; - concat ctx ", " (fun (arg,o,t) -> - let arg = define_local ctx arg in - s_funarg ctx arg t p o; - ) f.tf_args; + concat ctx ", " (fun (v,c) -> + let arg = define_local ctx v.v_name in + s_funarg ctx arg v.v_type p (arg_is_opt c); + ) f.tf_args; spr ctx ") {"; if (List.length f.tf_args) > 0 then begin @@ -738,8 +839,8 @@ and gen_dynamic_function ctx isstatic name f params p = print ctx " return call_user_func_array(self::$%s, array(" name else print ctx " return call_user_func_array($this->%s, array(" name; - concat ctx ", " (fun (arg,o,t) -> - spr ctx ("$" ^ arg) + concat ctx ", " (fun (v,_) -> + spr ctx ("$" ^ v.v_name) ) f.tf_args; print ctx ")); }"; end else if isstatic then @@ -766,9 +867,9 @@ and gen_function ctx name f params p = ctx.local_types <- List.map snd params @ ctx.local_types; let byref = if (String.length name > 9 && String.sub name 0 9 = "__byref__") then "&" else "" in print ctx "function %s%s(" byref name; - concat ctx ", " (fun (arg,o,t) -> - let arg = define_local ctx arg in - s_funarg ctx arg t p o; + concat ctx ", " (fun (v,o) -> + let arg = define_local ctx v.v_name in + s_funarg ctx arg v.v_type p (arg_is_opt o); ) f.tf_args; print ctx ") "; gen_expr ctx (fun_block ctx f p); @@ -777,7 +878,7 @@ and gen_function ctx name f params p = ctx.inv_locals <- old_li; ctx.local_types <- old_t - + and gen_inline_function ctx f hasthis p = ctx.nested_loops <- ctx.nested_loops - 1; let old = ctx.in_value in @@ -786,13 +887,13 @@ and gen_inline_function ctx f hasthis p = let old_t = ctx.local_types in ctx.in_value <- Some "closure"; - let args a = List.map (fun (n,_,_) -> n) a in + let args a = List.map (fun (v,_) -> v.v_name) a in let arguments = ref [] in - + if hasthis then begin arguments := "this" :: !arguments end; - + PMap.iter (fun n _ -> arguments := !arguments @ [n]) old_li; - + spr ctx "array(new _hx_lambda(array("; let c = ref 0 in @@ -804,16 +905,16 @@ and gen_inline_function ctx f hasthis p = ) (remove_internals !arguments); spr ctx "), \""; - - spr ctx (inline_function ctx (args f.tf_args) hasthis (fun_block ctx f p)); + + spr ctx (inline_function ctx (args f.tf_args) hasthis (fun_block ctx f p)); print ctx "\"), 'execute')"; - + ctx.in_value <- old; ctx.locals <- old_l; ctx.inv_locals <- old_li; ctx.local_types <- old_t; ctx.nested_loops <- ctx.nested_loops + 1; - + and unset_locals ctx old_l = let lst = ref [] in PMap.iter (fun n _ -> @@ -826,7 +927,7 @@ and unset_locals ctx old_l = concat ctx "," (fun (s) -> spr ctx s; ) !lst; spr ctx ")" end - + and gen_while_expr ctx e = let old_loop = ctx.in_loop in ctx.in_loop <- true; @@ -845,30 +946,73 @@ and gen_while_expr ctx e = ctx.nested_loops <- old_nested_loops; ctx.in_loop <- old_loop +and gen_tfield ctx e e1 s = + match follow e.etype with + | TFun (args, _) -> + (if ctx.is_call then begin + gen_field_access ctx false e1 s + end else if is_in_dynamic_methods ctx e1 s then begin + gen_field_access ctx true e1 s; + end else begin + let ob ex = + (match ex with + | TTypeExpr t -> + print ctx "\""; + spr ctx (s_path ctx (t_path t) false e1.epos); + print ctx "\"" + | _ -> + gen_expr ctx e1) in + + spr ctx "(isset("; + gen_field_access ctx true e1 s; + spr ctx ") ? "; + gen_field_access ctx true e1 s; + spr ctx ": array("; + ob e1.eexpr; + print ctx ", \"%s\"))" (s_ident s); + + end) + | TMono _ -> + if ctx.is_call then + gen_field_access ctx false e1 s + else + gen_uncertain_string_var ctx s e1 + | _ -> + if is_string_expr e1 then + gen_string_var ctx s e1 + else if is_uncertain_expr e1 then + gen_uncertain_string_var ctx s e1 + else + gen_field_access ctx true e1 s + and gen_expr ctx e = let in_block = ctx.in_block in ctx.in_block <- false; - let restore_in_block ctx inb = - if inb then ctx.in_block <- true + let restore_in_block ctx inb = + if inb then ctx.in_block <- true in match e.eexpr with | TConst c -> gen_constant ctx e.epos c - | TLocal s -> - spr ctx ("$" ^ (try PMap.find s ctx.locals with Not_found -> (s_ident_local s))) - | TEnumField (en,s) -> - (match (try PMap.find s en.e_constrs with Not_found -> error ("Unknown local " ^ s) e.epos).ef_type with - | TFun (args,_) -> print ctx "%s::%s" (s_path ctx en.e_path en.e_extern e.epos) (s_ident s) - | _ -> print ctx "%s::$%s" (s_path ctx en.e_path en.e_extern e.epos) (s_ident s)) + | TLocal v -> + spr ctx ("$" ^ (try PMap.find v.v_name ctx.locals with Not_found -> (s_ident_local v.v_name))) | TArray (e1,e2) -> (match e1.eexpr with | TCall _ + | TBlock _ + | TParenthesis _ | TArrayDecl _ -> spr ctx "_hx_array_get("; gen_value ctx e1; spr ctx ", "; gen_value ctx e2; spr ctx ")"; + | TCast (ec, _) when (match ec.eexpr with | TArrayDecl _ | TBlock _ -> true | _ -> false) -> + spr ctx "_hx_array_get("; + gen_value ctx e1; + spr ctx ", "; + gen_value ctx e2; + spr ctx ")"; | _ -> gen_value ctx e1; spr ctx "["; @@ -879,7 +1023,7 @@ and gen_expr ctx e = let non_assoc = function | (Ast.OpEq | Ast.OpNotEq | Ast.OpGt | Ast.OpGte | Ast.OpLt | Ast.OpLte) -> true | _ -> false - in + in (match e1.eexpr with | TBinop (op2,_,_) when non_assoc op && non_assoc op2 -> gen_expr ctx { e with eexpr = TBinop (op,mk (TParenthesis e1) e1.etype e1.epos,e2) } @@ -888,7 +1032,7 @@ and gen_expr ctx e = (match e.eexpr with | TArray(te1, te2) -> gen_value ctx te1; - spr ctx "->»a["; + spr ctx "->a["; gen_value ctx te2; spr ctx "]"; | _ -> @@ -897,24 +1041,30 @@ and gen_expr ctx e = (match e.eexpr with | TArray(te1, te2) -> gen_value ctx te1; - spr ctx "->»a["; + spr ctx "->a["; gen_value ctx te2; spr ctx "]"; | TField (e1,s) -> - gen_field_access ctx true e1 s + gen_field_access ctx true e1 (field_name s) | _ -> gen_field_op ctx e1;) in let leftsidef e = (match e.eexpr with | TField (e1,s) -> - gen_field_access ctx true e1 s; + gen_field_access ctx true e1 (field_name s) | _ -> gen_field_op ctx e1; ) in (match op with + | Ast.OpMod -> + spr ctx "_hx_mod("; + gen_value_op ctx e1; + spr ctx ", "; + gen_value_op ctx e2; + spr ctx ")"; | Ast.OpAssign -> (match e1.eexpr with - | TArray(te1, te2) when (match te1.eexpr with TCall _ -> true | _ -> false) -> + | TArray(te1, te2) when (match te1.eexpr with | TCall _ | TParenthesis _ -> true | _ -> false) -> spr ctx "_hx_array_assign("; gen_value ctx te1; spr ctx ", "; @@ -928,17 +1078,31 @@ and gen_expr ctx e = gen_value_op ctx e2; ) | Ast.OpAssignOp(Ast.OpAdd) when (is_uncertain_expr e1 && is_uncertain_expr e2) -> - leftside e1; - spr ctx " = "; - spr ctx "_hx_add("; - gen_value_op ctx e1; - spr ctx ", "; - gen_value_op ctx e2; - spr ctx ")"; + (match e1.eexpr with + | TArray(te1, te2) -> + let t1 = define_local ctx "__hx__t1" in + let t2 = define_local ctx "__hx__t2" in + + print ctx "_hx_array_assign($%s = " t1; + gen_value ctx te1; + print ctx ", $%s = " t2; + gen_value ctx te2; + print ctx ", $%s->a[$%s] + " t1 t2; + gen_value_op ctx e2; + spr ctx ")"; + | _ -> + leftside e1; + spr ctx " = "; + spr ctx "_hx_add("; + gen_value_op ctx e1; + spr ctx ", "; + gen_value_op ctx e2; + spr ctx ")"; + ) | Ast.OpAssignOp(Ast.OpAdd) when (is_string_expr e1 || is_string_expr e2) -> leftside e1; spr ctx " .= "; - gen_value_op ctx e2; + gen_value_op ctx (as_string_expr ctx e2); | Ast.OpAssignOp(Ast.OpShl) -> leftside e1; spr ctx " <<= "; @@ -951,6 +1115,14 @@ and gen_expr ctx e = spr ctx ", "; gen_value_op ctx e2; spr ctx ")"; + | Ast.OpAssignOp(Ast.OpMod) -> + leftside e1; + spr ctx " = "; + spr ctx "_hx_mod("; + gen_value_op ctx e1; + spr ctx ", "; + gen_value_op ctx e2; + spr ctx ")"; | Ast.OpAssignOp(_) -> leftsidec e1; print ctx " %s " (Ast.s_binop op); @@ -962,9 +1134,9 @@ and gen_expr ctx e = gen_value_op ctx e2; spr ctx ")"; | Ast.OpAdd when (is_string_expr e1 || is_string_expr e2) -> - gen_value_op ctx e1; + gen_value_op ctx (as_string_expr ctx e1); spr ctx " . "; - gen_value_op ctx e2; + gen_value_op ctx (as_string_expr ctx e2); | Ast.OpShl -> gen_value_op ctx e1; spr ctx " << "; @@ -989,17 +1161,17 @@ and gen_expr ctx e = | TField (f, s) when is_anonym_expr e1 || is_unknown_expr e1 -> spr ctx "_hx_field("; gen_value ctx f; - print ctx ", \"%s\")" s; + print ctx ", \"%s\")" (field_name s); | _ -> - gen_field_op ctx e1); - + gen_field_op ctx e1; + ); spr ctx s_phop; (match e2.eexpr with | TField (f, s) when is_anonym_expr e2 || is_unknown_expr e2 -> spr ctx "_hx_field("; gen_value ctx f; - print ctx ", \"%s\")" s; + print ctx ", \"%s\")" (field_name s); | _ -> gen_field_op ctx e2); end else if @@ -1011,7 +1183,7 @@ and gen_expr ctx e = gen_field_op ctx e2; end else if ((se1 = "Int" || se1 = "Float" || se1 = "Null" || se1 = "Null") - && (se1 = "Int" || se1 = "Float" || se1 = "Null" || se1 = "Null")) + && (se1 = "Int" || se1 = "Float" || se1 = "Null" || se1 = "Null")) || (is_unknown_expr e1 && is_unknown_expr e2) || is_anonym_expr e1 || is_anonym_expr e2 @@ -1023,15 +1195,19 @@ and gen_expr ctx e = gen_field_op ctx e2; spr ctx ")"; end else if - se1 == se2 - || (match e1.eexpr with | TConst _ | TLocal _ | TArray _ | TNew _ -> true | _ -> false) - || (match e2.eexpr with | TConst _ | TLocal _ | TArray _ | TNew _ -> true | _ -> false) - || is_string_expr e1 - || is_string_expr e2 - || is_anonym_expr e1 - || is_anonym_expr e2 - || is_unknown_expr e1 - || is_unknown_expr e2 + ( + se1 == se2 + || (match e1.eexpr with | TConst _ | TLocal _ | TArray _ | TNew _ -> true | _ -> false) + || (match e2.eexpr with | TConst _ | TLocal _ | TArray _ | TNew _ -> true | _ -> false) + || is_string_expr e1 + || is_string_expr e2 + || is_anonym_expr e1 + || is_anonym_expr e2 + || is_unknown_expr e1 + || is_unknown_expr e2 + ) + && (type_string (follow e1.etype)) <> "Dynamic" + && (type_string (follow e2.etype)) <> "Dynamic" then begin gen_field_op ctx e1; spr ctx s_phop; @@ -1046,52 +1222,13 @@ and gen_expr ctx e = print ctx " %s " (Ast.s_binop op); gen_value_op ctx e2; )); - | TField (e1,s) - | TClosure (e1,s) -> - (match follow e.etype with - | TFun (args, _) -> - (if ctx.is_call then begin - gen_field_access ctx false e1 s - end else if is_in_dynamic_methods ctx e1 s then begin - gen_field_access ctx true e1 s; - end else begin - let ob ex = - (match ex with - | TTypeExpr t -> - print ctx "\""; - spr ctx (s_path ctx (t_path t) false e1.epos); - print ctx "\"" - | _ -> - gen_expr ctx e1) in - - spr ctx "(isset("; - gen_field_access ctx true e1 s; - spr ctx ") ? "; - gen_field_access ctx true e1 s; - spr ctx ": array("; - ob e1.eexpr; - print ctx ", \"%s\"))" (s_ident s); - - end) - | TMono _ -> - if ctx.is_call then - gen_field_access ctx false e1 s - else - gen_uncertain_string_var ctx s e1 - | _ -> - if is_string_expr e1 then - gen_string_var ctx s e1 - else if is_uncertain_expr e1 then - gen_uncertain_string_var ctx s e1 - else - gen_field_access ctx true e1 s - ) - + | TField (e1,s) -> + gen_tfield ctx e e1 (field_name s) | TTypeExpr t -> print ctx "_hx_qtype(\"%s\")" (s_path_haxe (t_path t)) | TParenthesis e -> (match e.eexpr with - | TParenthesis _ + | TParenthesis _ | TReturn _ -> gen_value ctx e; | _ -> @@ -1103,7 +1240,7 @@ and gen_expr ctx e = (match eo with | None -> spr ctx "return" - | Some e when (match follow e.etype with TEnum({ e_path = [],"Void" },[]) -> true | _ -> false) -> + | Some e when (match follow e.etype with TEnum({ e_path = [],"Void" },[]) | TAbstract ({ a_path = [],"Void" },[]) -> true | _ -> false) -> gen_value ctx e; newline ctx; spr ctx "return" @@ -1147,17 +1284,17 @@ and gen_expr ctx e = end) in let remaining = ref (List.length el) in let build e = - (match e.eexpr with + (match e.eexpr with | TBlock [] -> () | _ -> newline ctx); if (in_block && !remaining = 1) then begin (match e.eexpr with | TIf _ | TSwitch _ - | TThrow _ + | TThrow _ | TWhile _ | TFor _ - | TMatch _ + | TMatch _ | TTry _ | TBreak | TBlock _ -> @@ -1168,17 +1305,17 @@ and gen_expr ctx e = (match e1.eexpr with | TIf _ | TSwitch _ - | TThrow _ + | TThrow _ | TWhile _ | TFor _ - | TMatch _ + | TMatch _ | TTry _ | TBlock _ -> () | _ -> spr ctx "return " ); gen_expr ctx e1; - | _ -> + | _ -> spr ctx "return "; gen_value ctx e; ) @@ -1194,7 +1331,7 @@ and gen_expr ctx e = end; bend(); newline ctx; - + cb(); print ctx "}"; b(); @@ -1217,11 +1354,11 @@ and gen_expr ctx e = concat ctx ", " (gen_value ctx) el; spr ctx "))"; | TField (ef,s) when is_static ef.etype && is_string_expr ef -> - gen_string_static_call ctx s ef el + gen_string_static_call ctx (field_name s) ef el | TField (ef,s) when is_string_expr ef -> - gen_string_call ctx s ef el - | TField (ef,s) when is_anonym_expr ef && could_be_string_call s -> - gen_uncertain_string_call ctx s ef el + gen_string_call ctx (field_name s) ef el + | TField (ef,s) when is_anonym_expr ef && could_be_string_call (field_name s) -> + gen_uncertain_string_call ctx (field_name s) ef el | _ -> gen_call ctx ec el); | TArrayDecl el -> @@ -1236,13 +1373,13 @@ and gen_expr ctx e = () | TVars vl -> spr ctx "$"; - concat ctx ("; $") (fun (n,t,v) -> + concat ctx ("; $") (fun (v,e) -> let restore = save_locals ctx in - let n = define_local ctx n in + let n = define_local ctx v.v_name in let restore2 = save_locals ctx in restore(); - (match v with - | None -> + (match e with + | None -> print ctx "%s = null" (s_ident_local n) | Some e -> print ctx "%s = " (s_ident_local n); @@ -1282,26 +1419,43 @@ and gen_expr ctx e = restore_in_block ctx in_block; gen_expr ctx (mk_block e)); | TUnop (op,Ast.Prefix,e) -> - spr ctx (Ast.s_unop op); (match e.eexpr with | TArray(te1, te2) -> - gen_value ctx te1; - spr ctx "->»a["; - gen_value ctx te2; - spr ctx "]"; + (match op with + | Increment -> + spr ctx "_hx_array_increment("; + gen_value ctx te1; + spr ctx ","; + gen_value ctx te2; + spr ctx ")"; + | Decrement -> + spr ctx "_hx_array_decrement("; + gen_value ctx te1; + spr ctx ","; + gen_value ctx te2; + spr ctx ")"; + | _ -> + spr ctx (Ast.s_unop op); + gen_value ctx te1; + spr ctx "["; + gen_value ctx te2; + spr ctx "]"; + ); | TField (e1,s) -> - gen_field_access ctx true e1 s + spr ctx (Ast.s_unop op); + gen_field_access ctx true e1 (field_name s) | _ -> + spr ctx (Ast.s_unop op); gen_value ctx e) | TUnop (op,Ast.Postfix,e) -> (match e.eexpr with | TArray(te1, te2) -> gen_value ctx te1; - spr ctx "->»a["; + spr ctx "->a["; gen_value ctx te2; spr ctx "]"; | TField (e1,s) -> - gen_field_access ctx true e1 s + gen_field_access ctx true e1 (field_name s) | _ -> gen_value ctx e); spr ctx (Ast.s_unop op) @@ -1328,12 +1482,12 @@ and gen_expr ctx e = old() | TObjectDecl fields -> spr ctx "_hx_anonymous(array("; - concat ctx ", " (fun (f,e) -> print ctx "\"%s\" => " f; gen_value ctx e) fields; + concat ctx ", " (fun (f,e) -> print ctx "\"%s\" => " (escape_bin f); gen_value ctx e) fields; spr ctx "))" - | TFor (v,t,it,e) -> + | TFor (v,it,e) -> let b = save_locals ctx in - let tmp = define_local ctx "»it" in - let v = define_local ctx v in + let tmp = define_local ctx "__hx__it" in + let v = define_local ctx v.v_name in (match it.eexpr with | TCall (e,_) -> (match e.eexpr with @@ -1363,7 +1517,7 @@ and gen_expr ctx e = restore_in_block ctx in_block; gen_expr ctx (mk_block e); let old = save_locals ctx in - let ex = define_local ctx "»e" in + let ex = define_local ctx "__hx__e" in print ctx "catch(Exception $%s) {" ex; let bend = open_block ctx in let first = ref true in @@ -1372,27 +1526,33 @@ and gen_expr ctx e = newline ctx; print ctx "$%s = ($%s instanceof HException) ? $%s->e : $%s" evar ex ex ex; old(); - List.iter (fun (v,t,e) -> - let ev = define_local ctx v in + List.iter (fun (v,e) -> + let ev = define_local ctx v.v_name in newline ctx; let b = save_locals ctx in if not !first then spr ctx "else "; - (match follow t with - | TEnum (te,_) -> (match snd te.e_path with - | "Bool" -> print ctx "if(is_bool($%s = $%s))" ev evar + (match follow v.v_type with + | TEnum (te,_) -> (match te.e_path with + | [], "Bool" -> print ctx "if(is_bool($%s = $%s))" ev evar | _ -> print ctx "if(($%s = $%s) instanceof %s)" ev evar (s_path ctx te.e_path te.e_extern e.epos)); restore_in_block ctx in_block; gen_expr ctx (mk_block e); - | TInst (tc,_) -> (match snd tc.cl_path with - | "Int" -> print ctx "if(is_int($%s = $%s))" ev evar - | "Float" -> print ctx "if(is_numeric($%s = $%s))" ev evar - | "String" -> print ctx "if(is_string($%s = $%s))" ev evar - | "Array" -> print ctx "if(($%s = $%s) instanceof _hx_array)" ev evar + | TInst (tc,_) -> (match tc.cl_path with + | [], "Int" -> print ctx "if(is_int($%s = $%s))" ev evar + | [], "Float" -> print ctx "if(is_numeric($%s = $%s))" ev evar + | [], "String" -> print ctx "if(is_string($%s = $%s))" ev evar + | [], "Array" -> print ctx "if(($%s = $%s) instanceof _hx_array)" ev evar | _ -> print ctx "if(($%s = $%s) instanceof %s)" ev evar (s_path ctx tc.cl_path tc.cl_extern e.epos)); restore_in_block ctx in_block; gen_expr ctx (mk_block e); - + | TAbstract (ta,_) -> (match ta.a_path with + | [], "Int" -> print ctx "if(is_int($%s = $%s))" ev evar + | [], "Float" -> print ctx "if(is_numeric($%s = $%s))" ev evar + | [], "Bool" -> print ctx "if(is_bool($%s = $%s))" ev evar + | _ -> print ctx "if(($%s = $%s) instanceof %s)" ev evar (s_path ctx ta.a_path false e.epos)); + restore_in_block ctx in_block; + gen_expr ctx (mk_block e); | TFun _ | TLazy _ | TType _ @@ -1418,7 +1578,7 @@ and gen_expr ctx e = spr ctx "}" | TMatch (e,_,cases,def) -> let b = save_locals ctx in - let tmp = define_local ctx "»t" in + let tmp = define_local ctx "__hx__t" in print ctx "$%s = " tmp; gen_value ctx e; newline ctx; @@ -1437,7 +1597,7 @@ and gen_expr ctx e = | None | Some [] -> () | Some l -> let n = ref (-1) in - let l = List.fold_left (fun acc (v,t) -> incr n; match v with None -> acc | Some v -> (v,t,!n) :: acc) [] l in + let l = List.fold_left (fun acc v -> incr n; match v with None -> acc | Some v -> (v.v_name,v.v_type,!n) :: acc) [] l in match l with | [] -> () | l -> @@ -1451,7 +1611,7 @@ and gen_expr ctx e = print ctx "break"; newline ctx; b() - ) cases; + ) cases; (match def with | None -> () | Some e -> @@ -1504,6 +1664,7 @@ and gen_expr ctx e = let mk_texpr = function | TClassDecl c -> TAnon { a_fields = PMap.empty; a_status = ref (Statics c) } | TEnumDecl e -> TAnon { a_fields = PMap.empty; a_status = ref (EnumStatics e) } + | TAbstractDecl a -> TAnon { a_fields = PMap.empty; a_status = ref (AbstractStatics a) } | TTypeDecl _ -> assert false in spr ctx "_hx_cast("; @@ -1511,25 +1672,25 @@ and gen_expr ctx e = spr ctx ", "; gen_expr ctx (mk (TTypeExpr t) (mk_texpr t) e1.epos); spr ctx ")" - + and argument_list_from_locals include_this in_var l = let lst = ref [] in - if (include_this && in_var) then lst := "»this" :: !lst + if (include_this && in_var) then lst := "__hx__this" :: !lst else if include_this then lst := "this" :: !lst; PMap.iter (fun n _ -> lst := !lst @ [n]; ) l; !lst - + and remove_internals args = - List.filter (fun a -> a = "»this" or '»' <> String.get a 0) args; - + List.filter (fun a -> a = "__hx__this" || not (start_with a "__hx__")) args; + and inline_block ctx e = let index = ctx.inline_index in ctx.inline_index <- ctx.inline_index + 1; - let block = { + let block = { iname = (s_path ctx ctx.curclass.cl_path ctx.curclass.cl_extern ctx.curclass.cl_pos) ^ "_" ^ string_of_int index; - iindex = index; + iindex = index; ihasthis = ctx.in_instance_method; (* param this *) iarguments = []; iexpr = e; @@ -1537,7 +1698,7 @@ and inline_block ctx e = iin_block = true; iinv_locals = ctx.inv_locals; } in - + print ctx "%s(" block.iname; let in_value = (match ctx.in_value with Some _ -> true | _ -> false) in (match remove_internals (argument_list_from_locals ctx.in_instance_method in_value ctx.locals) with @@ -1545,15 +1706,15 @@ and inline_block ctx e = | l -> print ctx "$%s" (String.concat ", $" l) ); spr ctx ")"; - + ctx.inline_methods <- ctx.inline_methods @ [block] - + and inline_function ctx args hasthis e = let index = ctx.inline_index in ctx.inline_index <- ctx.inline_index + 1; - let block = { + let block = { iname = (s_path ctx ctx.curclass.cl_path ctx.curclass.cl_extern ctx.curclass.cl_pos) ^ "_" ^ string_of_int index; - iindex = index; + iindex = index; ihasthis = hasthis; (* param this *) iarguments = args; iexpr = e; @@ -1561,19 +1722,45 @@ and inline_function ctx args hasthis e = iin_block = false; iinv_locals = ctx.inv_locals; } in - + ctx.inline_methods <- ctx.inline_methods @ [block]; block.iname + +and canbe_ternary_param e = + match e.eexpr with + | TTypeExpr _ + | TConst _ + | TLocal _ + | TField (_,FEnum _) + | TParenthesis _ + | TObjectDecl _ + | TArrayDecl _ + | TCall _ + | TUnop _ + | TNew _ + | TCast (_, _) + | TBlock [_] -> + true + | TIf (_,e,eelse) -> + cangen_ternary e eelse + | _ -> + false + +and cangen_ternary e eelse = + match eelse with + | Some other -> + (canbe_ternary_param e) && (canbe_ternary_param other) + | _ -> + false + and gen_value ctx e = match e.eexpr with | TTypeExpr _ | TConst _ | TLocal _ - | TEnumField _ | TArray _ | TBinop _ | TField _ - | TClosure _ | TParenthesis _ | TObjectDecl _ | TArrayDecl _ @@ -1587,6 +1774,34 @@ and gen_value ctx e = | TCast (e, _) | TBlock [e] -> gen_value ctx e + | TIf (cond,e,eelse) when (cangen_ternary e eelse) -> + spr ctx "("; + gen_value ctx cond; + spr ctx " ? "; + gen_value ctx e; + + (match eelse with + | Some e -> + spr ctx " : "; + gen_value ctx e + | _ ->()); + spr ctx ")"; + +(* + | TIf (cond,e,eelse) -> + spr ctx "if"; + gen_value ctx (parent cond); + spr ctx " "; + restore_in_block ctx in_block; + gen_expr ctx (mk_block e); + (match eelse with + | None -> () + | Some e when e.eexpr = TConst(TNull) -> () + | Some e -> + spr ctx " else "; + restore_in_block ctx in_block; + gen_expr ctx (mk_block e)); +*) | TBlock _ | TBreak | TContinue @@ -1596,16 +1811,26 @@ and gen_value ctx e = | TThrow _ | TSwitch _ | TFor _ - | TMatch _ + | TMatch _ | TIf _ | TTry _ -> inline_block ctx e +let rec is_instance_method_defined cls m = + if PMap.exists m cls.cl_fields then + true + else + match cls.cl_super with + | Some (scls, _) -> + is_instance_method_defined scls m + | None -> + false + let is_method_defined ctx m static = if static then PMap.exists m ctx.curclass.cl_statics else - PMap.exists m ctx.curclass.cl_fields + is_instance_method_defined ctx.curclass m let generate_self_method ctx rights m static setter = if setter then ( @@ -1620,9 +1845,17 @@ let generate_self_method ctx rights m static setter = print ctx "%s function %s() { return call_user_func($this->%s); }" rights (s_ident m) (s_ident m) ); newline ctx - + +let gen_assigned_value ctx eo = match eo with + | Some ({eexpr = TConst _} as e) -> + print ctx " = "; + gen_value ctx e + | _ -> + () + let generate_field ctx static f = - newline ctx; + if not (is_extern_field f) then + newline ctx; ctx.locals <- PMap.empty; ctx.inv_locals <- PMap.empty; ctx.in_instance_method <- not static; @@ -1638,11 +1871,13 @@ let generate_field ctx static f = if is_dynamic_method f then gen_dynamic_function ctx static (s_ident f.cf_name) fd f.cf_params p else - gen_function ctx (s_ident f.cf_name) fd f.cf_params p + gen_function ctx (s_ident f.cf_name) fd f.cf_params p | _ -> - if ctx.curclass.cl_interface then - match follow f.cf_type with - | TFun (args,r) -> + if (is_extern_field f) then + () + else if ctx.curclass.cl_interface then + match follow f.cf_type, f.cf_kind with + | TFun (args,r), Method _ -> print ctx "function %s(" (s_ident f.cf_name); concat ctx ", " (fun (arg,o,t) -> s_funarg ctx arg t p o; @@ -1653,7 +1888,9 @@ let generate_field ctx static f = (match f.cf_kind with | Var v -> (match v.v_read, v.v_write with - | AccCall m1, AccCall m2 -> + | AccCall, AccCall -> + let m1 = "get_" ^ f.cf_name in + let m2 = "set_" ^ f.cf_name in if not (is_method_defined ctx m1 static) then ( generate_self_method ctx rights m1 static false; print ctx "%s $%s" rights (s_ident m1); @@ -1664,27 +1901,31 @@ let generate_field ctx static f = print ctx "%s $%s" rights (s_ident m2); newline ctx); false - | AccCall m, _ -> + | AccCall, _ -> + let m = "get_" ^ f.cf_name in if not (is_method_defined ctx m static) then generate_self_method ctx rights m static false; - print ctx "%s $%s" rights (s_ident f.cf_name); + print ctx "%s $%s" rights (s_ident_field f.cf_name); + gen_assigned_value ctx f.cf_expr; true - | _, AccCall m -> + | _, AccCall -> + let m = "set_" ^ f.cf_name in if not (is_method_defined ctx m static) then generate_self_method ctx rights m static true; - print ctx "%s $%s" rights (s_ident f.cf_name); + print ctx "%s $%s" rights (s_ident_field f.cf_name); + gen_assigned_value ctx f.cf_expr; true | _ -> false) | _ -> false) then () else begin - let name = s_ident f.cf_name in + let name = if static then s_ident f.cf_name else f.cf_name in if static then (match f.cf_kind with - | Var _ -> + | Var _ -> (match follow f.cf_type with | TFun _ | TDynamic _ -> - print ctx "static function %s() { $»args = func_get_args(); return call_user_func_array(self::$%s, $»args); }" name name; + print ctx "static function %s() { $args = func_get_args(); return call_user_func_array(self::$%s, $args); }" name name; newline ctx; | _ -> () @@ -1693,14 +1934,7 @@ let generate_field ctx static f = () ); print ctx "%s $%s" rights name; - match f.cf_expr with - | None -> () - | Some e -> - match e.eexpr with - | TConst _ -> - print ctx " = "; - gen_value ctx e - | _ -> () + gen_assigned_value ctx f.cf_expr end let generate_static_field_assign ctx path f = @@ -1713,13 +1947,13 @@ let generate_static_field_assign ctx path f = | TConst _ -> () | TFunction fd -> (match f.cf_kind with - | Var _ when + | Var _ when (match follow f.cf_type with | TFun _ | TDynamic _ -> true; | _ -> - false) -> + false) -> newline ctx; print ctx "%s::$%s = " (s_path ctx path false p) (s_ident f.cf_name); gen_value ctx e @@ -1728,6 +1962,8 @@ let generate_static_field_assign ctx path f = print ctx "%s::$%s = " (s_path ctx path false p) (s_ident f.cf_name); gen_value ctx e | _ -> ()) + | _ when is_extern_field f -> + () | _ -> newline ctx; print ctx "%s::$%s = " (s_path ctx path false p) (s_ident f.cf_name); @@ -1739,35 +1975,35 @@ let rec super_has_dynamic c = | Some (csup, _) -> (match csup.cl_dynamic with | Some _ -> true | _ -> super_has_dynamic csup) - + let generate_inline_method ctx c m = (match ctx.inline_methods with | [] -> () | h :: t -> ctx.inline_methods <- t ); ctx.curclass <- c; - + let old = save_locals ctx in ctx.in_value <- Some m.iname; ctx.in_block <- m.iin_block; - ctx.in_loop <- false; + ctx.in_loop <- false; ctx.locals <- m.ilocals; ctx.inv_locals <- m.iinv_locals; - - newline ctx; + + newline ctx; print ctx "function %s(" m.iname; (* arguments *) let in_value = (match ctx.in_value with Some _ -> true | _ -> false) in let arguments = remove_internals (argument_list_from_locals m.ihasthis in_value ctx.locals) in let arguments = match arguments with - | [h] when h = "this" -> ["»this"] - | h :: t when h = "this" -> "»this" :: t + | [h] when h = "this" -> ["__hx__this"] + | h :: t when h = "this" -> "__hx__this" :: t | _ -> arguments in - + let marguments = List.map (define_local ctx) m.iarguments in let arguments = (List.map (fun a -> "&$" ^ a) arguments) @ (List.map (fun a -> "$" ^ a) marguments) in - + (match arguments with | [] -> () | l -> spr ctx (String.concat ", " arguments) @@ -1776,21 +2012,14 @@ let generate_inline_method ctx c m = ctx.nested_loops <- ctx.nested_loops - 1; let block = open_block ctx in newline ctx; - - (* blocks *) - if ctx.com.debug then begin - print ctx "\t$GLOBALS['%s']->push('%s:lambda_%d')" "%s" (s_path_haxe c.cl_path) m.iindex; - newline ctx; - spr ctx "\t$»spos = $GLOBALS['%s']->length"; - newline ctx; - end; + gen_expr ctx m.iexpr; block(); old(); ctx.nested_loops <- ctx.nested_loops + 1; newline ctx; spr ctx "}" - + let generate_class ctx c = let requires_constructor = ref true in ctx.curclass <- c; @@ -1802,14 +2031,15 @@ let generate_class ctx c = | Some (csup,_) -> requires_constructor := false; print ctx "extends %s " (s_path ctx csup.cl_path csup.cl_extern c.cl_pos)); - (match c.cl_implements with + let implements = ExtList.List.unique ~cmp:(fun a b -> (fst a).cl_path = (fst b).cl_path) c.cl_implements in + (match implements with | [] -> () | l -> spr ctx (if c.cl_interface then "extends " else "implements "); concat ctx ", " (fun (i,_) -> print ctx "%s" (s_path ctx i.cl_path i.cl_extern c.cl_pos)) l); spr ctx "{"; - + let get_dynamic_methods = List.filter is_dynamic_method c.cl_ordered_fields in if not ctx.curclass.cl_interface then ctx.dynamic_methods <- get_dynamic_methods; @@ -1835,33 +2065,55 @@ let generate_class ctx c = (match c.cl_dynamic with | Some _ when not c.cl_interface && not (super_has_dynamic c) -> newline ctx; - spr ctx "public $»dynamics = array();\n\tpublic function __get($n) {\n\t\tif(isset($this->»dynamics[$n]))\n\t\t\treturn $this->»dynamics[$n];\n\t}\n\tpublic function __set($n, $v) {\n\t\t$this->»dynamics[$n] = $v;\n\t}\n\tpublic function __call($n, $a) {\n\t\tif(isset($this->»dynamics[$n]) && is_callable($this->»dynamics[$n]))\n\t\t\treturn call_user_func_array($this->»dynamics[$n], $a);\n\t\tif('toString' == $n)\n\t\t\treturn $this->__toString();\n\t\tthrow new HException(\"Unable to call «\".$n.\"»\");\n\t}" + spr ctx "public $__dynamics = array();\n\tpublic function __get($n) {\n\t\tif(isset($this->__dynamics[$n]))\n\t\t\treturn $this->__dynamics[$n];\n\t}\n\tpublic function __set($n, $v) {\n\t\t$this->__dynamics[$n] = $v;\n\t}\n\tpublic function __call($n, $a) {\n\t\tif(isset($this->__dynamics[$n]) && is_callable($this->__dynamics[$n]))\n\t\t\treturn call_user_func_array($this->__dynamics[$n], $a);\n\t\tif('toString' == $n)\n\t\t\treturn $this->__toString();\n\t\tthrow new HException(\"Unable to call <\".$n.\">\");\n\t}" | Some _ | _ -> if List.length ctx.dynamic_methods > 0 then begin newline ctx; - spr ctx "public function __call($m, $a) {\n\t\tif(isset($this->$m) && is_callable($this->$m))\n\t\t\treturn call_user_func_array($this->$m, $a);\n\t\telse if(isset($this->»dynamics[$m]) && is_callable($this->»dynamics[$m]))\n\t\t\treturn call_user_func_array($this->»dynamics[$m], $a);\n\t\telse if('toString' == $m)\n\t\t\treturn $this->__toString();\n\t\telse\n\t\t\tthrow new HException('Unable to call «'.$m.'»');\n\t}"; + spr ctx "public function __call($m, $a) {\n\t\tif(isset($this->$m) && is_callable($this->$m))\n\t\t\treturn call_user_func_array($this->$m, $a);\n\t\telse if(isset($this->__dynamics[$m]) && is_callable($this->__dynamics[$m]))\n\t\t\treturn call_user_func_array($this->__dynamics[$m], $a);\n\t\telse if('toString' == $m)\n\t\t\treturn $this->__toString();\n\t\telse\n\t\t\tthrow new HException('Unable to call <'.$m.'>');\n\t}"; end; ); List.iter (generate_field ctx true) c.cl_ordered_statics; + let gen_props props = + String.concat "," (List.map (fun (p,v) -> "\"" ^ p ^ "\" => \"" ^ v ^ "\"") props) + in + + let rec fields c = + let list = Codegen.get_properties (c.cl_ordered_statics @ c.cl_ordered_fields) in + match c.cl_super with + | Some (csup, _) -> + list @ fields csup + | None -> + list + in + + if not c.cl_interface then (match fields c with + | [] -> + () + | props -> + newline ctx; + print ctx "static $__properties__ = array(%s)" (gen_props props); + ); + + cl(); newline ctx; - + if PMap.exists "__toString" c.cl_fields then () else if PMap.exists "toString" c.cl_fields && (not c.cl_interface) && (not c.cl_extern) then begin print ctx "\tfunction __toString() { return $this->toString(); }"; newline ctx end else if (not c.cl_interface) && (not c.cl_extern) then begin - print ctx "\tfunction __toString() { return '%s'; }" ((s_path_haxe c.cl_path)) ; + print ctx "\tfunction __toString() { return '%s'; }" (s_path_haxe c.cl_path) ; newline ctx end; - + print ctx "}" - - + + let createmain com e = let filename = match com.php_front with None -> "index.php" | Some n -> n in let ctx = { @@ -1896,11 +2148,11 @@ let createmain com e = } in spr ctx "if(version_compare(PHP_VERSION, '5.1.0', '<')) { - exit('Your current PHP version is: ' . PHP_VERSION . '. haXe/PHP generates code for version 5.1.0 or later'); + exit('Your current PHP version is: ' . PHP_VERSION . '. Haxe/PHP generates code for version 5.1.0 or later'); }"; newline ctx; newline ctx; - spr ctx ("require_once dirname(__FILE__).'/" ^ ctx.lib_path ^ "/php/Boot.class.php';\n\n"); + spr ctx ("require_once dirname(__FILE__).'/" ^ ctx.lib_path ^ "/php/" ^ (prefix_class com "Boot.class.php';\n\n")); gen_value ctx e; newline ctx; spr ctx "\n?>"; @@ -1923,41 +2175,41 @@ let generate_enum ctx e = newline ctx; match c.ef_type with | TFun (args,_) -> - print ctx "public static function %s($" c.ef_name; + print ctx "public static function %s($" (s_ident c.ef_name); concat ctx ", $" (fun (a,o,t) -> spr ctx a; if o then spr ctx " = null"; ) args; spr ctx ") {"; - print ctx " return new %s(\"%s\", %d, array($" ename c.ef_name c.ef_index; + print ctx " return new %s(\"%s\", %d, array($" ename (s_ident c.ef_name) c.ef_index; concat ctx ", $" (fun (a,_,_) -> spr ctx a) args; print ctx ")); }"; | _ -> - print ctx "public static $%s" c.ef_name; + print ctx "public static $%s" (s_ident c.ef_name); ) e.e_constrs; newline ctx; - + spr ctx "public static $__constructors = array("; - + let first = ref true in PMap.iter (fun _ c -> if not !first then spr ctx ", "; - print ctx "%d => '%s'" c.ef_index c.ef_name; + print ctx "%d => '%s'" c.ef_index (s_ident c.ef_name); first := false; ) e.e_constrs; - + spr ctx ")"; - + newline ctx; - + (match Codegen.build_metadata ctx.com (TEnumDecl e) with | None -> () | Some _ -> spr ctx "public static $__meta__"; newline ctx); - + pack(); - + print ctx "}"; PMap.iter (fun _ c -> @@ -1966,11 +2218,11 @@ let generate_enum ctx e = (); | _ -> newline ctx; - print ctx "%s::$%s = new %s(\"%s\", %d)" ename c.ef_name ename c.ef_name c.ef_index; + print ctx "%s::$%s = new %s(\"%s\", %d)" ename (s_ident c.ef_name) ename c.ef_name c.ef_index; ) e.e_constrs; newline ctx; - + match Codegen.build_metadata ctx.com (TEnumDecl e) with | None -> () | Some e -> @@ -1982,22 +2234,22 @@ let generate com = let all_dynamic_methods = ref [] in let extern_classes_with_init = ref [] in let php_lib_path = (match com.php_lib with None -> "lib" | Some n -> n) in - create_directory com (Str.split (Str.regexp "/") php_lib_path); + create_directory com (Str.split (Str.regexp "/") php_lib_path); (* check for methods with the same name but different case *) let check_class_fields c = let lc_names = ref [] in let special_cases = ["toString"] in - let loop c lst static = + let loop c lst static = let in_special_cases name = - (List.exists (fun n -> String.lowercase n = name) (special_cases @ c.cl_overrides)) + (List.exists (fun n -> String.lowercase n = name) (special_cases @ List.map (fun f -> f.cf_name) c.cl_overrides)) in List.iter(fun cf -> let name = String.lowercase cf.cf_name in let prefixed_name s = (if s then "s_" else "i_") ^ name in match cf.cf_kind, cf.cf_expr with | (Method _, Some e) when not (in_special_cases name) -> - (try - let lc = List.find (fun n -> + (try + let lc = List.find (fun n -> let n = snd n in if static then (n = (prefixed_name false)) @@ -2011,7 +2263,7 @@ let generate com = () ) lst in - let rec _check_class_fields cl = + let rec _check_class_fields cl = (match cl.cl_super with | Some (s,_) -> _check_class_fields s | _ -> ()); @@ -2044,17 +2296,18 @@ let generate com = }) (List.filter is_dynamic_method lst) in all_dynamic_methods := dynamic_methods_names c.cl_ordered_fields @ !all_dynamic_methods; - + if c.cl_extern then (match c.cl_init with | Some _ -> extern_classes_with_init := c.cl_path :: !extern_classes_with_init; - | _ -> + | _ -> ()) else all_dynamic_methods := dynamic_methods_names c.cl_ordered_statics @ !all_dynamic_methods; | _ -> ()) ) com.types; + List.iter (Codegen.fix_abstract_inheritance com) com.types; List.iter (fun t -> (match t with | TClassDecl c -> @@ -2064,15 +2317,16 @@ let generate com = | Some e -> let ctx = init com php_lib_path c.cl_path 3 in gen_expr ctx e; + newline ctx; close ctx; ); end else let ctx = init com php_lib_path c.cl_path (if c.cl_interface then 2 else 0) in ctx.extern_classes_with_init <- !extern_classes_with_init; ctx.all_dynamic_methods <- !all_dynamic_methods; - + generate_class ctx c; - + (match c.cl_init with | None -> () | Some e -> @@ -2085,16 +2339,16 @@ let generate com = newline ctx; print ctx "$%s = new _hx_array(array())" ctx.stack.Codegen.stack_exc_var; end; - + let rec loop l = match l with | [] -> () - | h :: _ -> + | h :: _ -> generate_inline_method ctx c h; loop ctx.inline_methods in loop ctx.inline_methods; - newline ctx; + newline ctx; close ctx | TEnumDecl e -> if e.e_extern then @@ -2103,7 +2357,7 @@ let generate com = let ctx = init com php_lib_path e.e_path 1 in generate_enum ctx e; close ctx - | TTypeDecl t -> + | TTypeDecl _ | TAbstractDecl _ -> ()); ) com.types; (match com.main with diff --git a/haxe/genswf.ml b/genswf.ml similarity index 51% rename from haxe/genswf.ml rename to genswf.ml index bc61cb02df9df87fda871945b65d934d5d508aa8..73c4893cb5781252aa7c5a28c19bbc20f90569f3 100644 --- a/haxe/genswf.ml +++ b/genswf.ml @@ -1,21 +1,25 @@ (* - * Haxe Compiler - * Copyright (c)2005 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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 Swf open As3 open As3hl @@ -24,124 +28,6 @@ open Type open Common open Ast -(* --- MINI ZIP IMPLEMENTATION --- *) - - -type zfile = { - fname : string; - fcompressed : bool; - fclen : int; - fsize : int; - fcrc : int32; - fdate : float; -} - -type t = { - ch : unit IO.output; - mutable files : zfile list; - mutable cdr_size : int; - mutable cdr_offset : int; -} - -let zip_create o = { - ch = IO.cast_output o; - files = []; - cdr_size = 0; - cdr_offset = 0; -} - -let make_crc32 data = - let init = 0xFFFFFFFFl in - let polynom = 0xEDB88320l in - let crc = ref init in - for i = 0 to String.length data - 1 do - let b = Int32.of_int (int_of_char (String.unsafe_get data i)) in - let tmp = ref (Int32.logand (Int32.logxor (!crc) b) 0xFFl) in - for j = 0 to 7 do - tmp := if Int32.to_int (Int32.logand (!tmp) 1l) == 1 then - Int32.logxor (Int32.shift_right_logical (!tmp) 1) polynom - else - Int32.shift_right_logical (!tmp) 1; - done; - crc := Int32.logxor (Int32.shift_right_logical (!crc) 8) (!tmp); - done; - Int32.logxor (!crc) init - -let zip_write_date z d = - let t = Unix.localtime d in - let hour = t.Unix.tm_hour in - let min = t.Unix.tm_min in - let sec = t.Unix.tm_sec lsr 1 in - IO.write_ui16 z.ch ((hour lsl 11) lor (min lsl 5) lor sec); - let year = t.Unix.tm_year - 80 in - let month = t.Unix.tm_mon + 1 in - let day = t.Unix.tm_mday in - IO.write_ui16 z.ch ((year lsl 9) lor (month lsl 5) lor day) - -let zip_write_file z name data date compress = - IO.write_i32 z.ch 0x04034B50; - IO.write_ui16 z.ch 0x0014; (* version *) - IO.write_ui16 z.ch 0; - let crc32 = make_crc32 data in - let cdata = if compress then - let d = Extc.zip data in - String.sub d 2 (String.length d - 4) - else - data - in - IO.write_ui16 z.ch (if compress then 0x08 else 0x00); - zip_write_date z date; - IO.write_real_i32 z.ch crc32; - IO.write_i32 z.ch (String.length cdata); - IO.write_i32 z.ch (String.length data); - IO.write_ui16 z.ch (String.length name); - IO.write_ui16 z.ch 0; - IO.nwrite z.ch name; - IO.nwrite z.ch cdata; - z.files <- { - fname = name; - fcompressed = compress; - fclen = String.length cdata; - fsize = String.length data; - fcrc = crc32; - fdate = date; - } :: z.files - -let zip_write_cdr_file z f = - let namelen = String.length f.fname in - IO.write_i32 z.ch 0x02014B50; - IO.write_ui16 z.ch 0x0014; - IO.write_ui16 z.ch 0x0014; - IO.write_ui16 z.ch 0; - IO.write_ui16 z.ch (if f.fcompressed then 0x08 else 0); - zip_write_date z f.fdate; - IO.write_real_i32 z.ch f.fcrc; - IO.write_i32 z.ch f.fclen; - IO.write_i32 z.ch f.fsize; - IO.write_ui16 z.ch namelen; - IO.write_ui16 z.ch 0; - IO.write_ui16 z.ch 0; - IO.write_ui16 z.ch 0; - IO.write_ui16 z.ch 0; - IO.write_i32 z.ch 0; - IO.write_i32 z.ch z.cdr_offset; - IO.nwrite z.ch f.fname; - z.cdr_size <- z.cdr_size + 46 + namelen; - z.cdr_offset <- z.cdr_offset + 30 + namelen + f.fclen - -let zip_write_cdr z = - List.iter (zip_write_cdr_file z) (List.rev z.files); - IO.write_i32 z.ch 0x06054B50; - IO.write_ui16 z.ch 0; - IO.write_ui16 z.ch 0; - IO.write_ui16 z.ch (List.length z.files); - IO.write_ui16 z.ch (List.length z.files); - IO.write_i32 z.ch z.cdr_size; - IO.write_i32 z.ch z.cdr_offset; - IO.write_ui16 z.ch 0 - -(* ------------------------------- *) - let rec make_tpath = function | HMPath (pack,name) -> let pdyn = ref false in @@ -151,13 +37,15 @@ let rec make_tpath = function | [], "uint" -> [], "UInt" | [], "Number" -> [], "Float" | [], "Boolean" -> [], "Bool" - | [], "Object" | [], "Function" -> [], "Dynamic" - | [],"Class" | [],"Array" -> pdyn := true; pack, name + | [], "Object" -> ["flash";"utils"], "Object" + | [], "Function" -> ["flash";"utils"], "Function" + | [], "Class" | [],"Array" -> pdyn := true; pack, name | [], "Error" -> ["flash";"errors"], "Error" | [] , "XML" -> ["flash";"xml"], "XML" | [] , "XMLList" -> ["flash";"xml"], "XMLList" | [] , "QName" -> ["flash";"utils"], "QName" | [] , "Namespace" -> ["flash";"utils"], "Namespace" + | [] , "RegExp" -> ["flash";"utils"], "RegExp" | ["__AS3__";"vec"] , "Vector" -> ["flash"], "Vector" | _ -> pack, name in @@ -171,11 +59,24 @@ let rec make_tpath = function { tpackage = (match ns with | HNInternal (Some ns) -> ExtString.String.nsplit ns "." + | HNPrivate (Some ns) -> + (try + let file, line = ExtString.String.split ns ".as$" in + [file ^ "_" ^ line] + with _ -> + []) | _ -> []); tname = id; tparams = []; tsub = None; } + | HMNSAny (id) -> + { + tpackage = []; + tname = id; + tparams = []; + tsub = None; + } | HMMultiName _ -> assert false | HMRuntimeName _ -> @@ -201,13 +102,44 @@ let make_topt = function let make_type t = CTPath (make_topt t) +let make_dyn_type t = + match make_topt t with + | { tpackage = ["flash";"utils"]; tname = ("Object"|"Function") } -> make_type None + | o -> CTPath o + +let is_valid_path com pack name = + let rec loop = function + | [] -> + false + | load :: l -> + match load (pack,name) Ast.null_pos with + | None -> loop l + | Some (file,(_,a)) -> true + in + let file = Printf.sprintf "%s/%s.hx" (String.concat "/" pack) name in + loop com.load_extern_type || (try ignore(Common.find_file com file); true with Not_found -> false) + let build_class com c file = let path = make_tpath c.hlc_name in + let pos = { pfile = file ^ "@" ^ s_type_path (path.tpackage,path.tname); pmin = 0; pmax = 0 } in + match path with + | { tpackage = ["flash";"utils"]; tname = ("Object"|"Function") } -> + let inf = { + d_name = path.tname; + d_doc = None; + d_params = []; + d_meta = []; + d_flags = []; + d_data = CTPath { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None; }; + } in + (path.tpackage, [(ETypedef inf,pos)]) + | _ -> (* make flags *) let flags = [HExtern] in let flags = if c.hlc_interface then HInterface :: flags else flags in let flags = (match c.hlc_super with | None | Some (HMPath ([],"Object")) -> flags + | Some (HMPath ([],"Function")) -> flags (* found in AIR SDK *) | Some s -> HExtends (make_tpath s) :: flags ) in let flags = List.map (fun i -> @@ -215,20 +147,20 @@ let build_class com c file = | HMMultiName (Some id,ns) -> let rec loop = function | [] -> HMPath ([],id) - | HNPublic (Some ns) :: _ -> HMPath (ExtString.String.nsplit ns ".",id) + | HNPublic (Some ns) :: _ when is_valid_path com (ExtString.String.nsplit ns ".") id -> HMPath (ExtString.String.nsplit ns ".",id) | _ :: l -> loop l in - loop (List.rev ns) + loop ns + | HMPath _ -> i | _ -> assert false ) in - HImplements (make_tpath i) + if c.hlc_interface then HExtends (make_tpath i) else HImplements (make_tpath i) ) (Array.to_list c.hlc_implements) @ flags in - let flags = if c.hlc_sealed || Common.defined com "flash_strict" then flags else HImplements (make_tpath (HMPath ([],"Dynamic"))) :: flags in + let flags = if c.hlc_sealed || Common.defined com Define.FlashStrict then flags else HImplements (make_tpath (HMPath ([],"Dynamic"))) :: flags in (* make fields *) - let pos = { pfile = file ^ "@" ^ s_type_path (path.tpackage,path.tname); pmin = 0; pmax = 0 } in let getters = Hashtbl.create 0 in let setters = Hashtbl.create 0 in - let as3_native = Common.defined com "as3_native" in + let override = Hashtbl.create 0 in let is_xml = (match path.tpackage, path.tname with | ["flash";"xml"], ("XML" | "XMLList") -> true | _ -> false @@ -241,12 +173,12 @@ let build_class com c file = (match ns with | HNPrivate _ | HNNamespace "http://www.adobe.com/2006/flex/mx/internal" -> [] | HNNamespace ns -> - if not (c.hlc_interface || is_xml) then meta := (":ns",[String ns]) :: !meta; + if not (c.hlc_interface || is_xml) then meta := (Meta.Ns,[String ns]) :: !meta; [APublic] | HNExplicit _ | HNInternal _ | HNPublic _ -> [APublic] | HNStaticProtected _ | HNProtected _ -> - if as3_native then meta := (":protected",[]) :: !meta; + meta := (Meta.Protected,[]) :: !meta; [APrivate]) | _ -> [] ) in @@ -267,15 +199,19 @@ let build_class com c file = match f.hlf_kind with | HFVar v -> if v.hlv_const then - cf.cff_kind <- FProp ("default","never",make_type v.hlv_type) + cf.cff_kind <- FProp ("default","never",Some (make_type v.hlv_type),None) else - cf.cff_kind <- FVar (Some (make_type v.hlv_type),None); + cf.cff_kind <- FVar (Some (make_dyn_type v.hlv_type),None); cf :: acc - | HFMethod m when not m.hlm_override -> + | HFMethod m when m.hlm_override -> + Hashtbl.add override (name,stat) (); + acc + | HFMethod m -> (match m.hlm_kind with | MK3Normal -> let t = m.hlm_type in let p = ref 0 and pn = ref 0 in + let make_type = if stat || name = "new" then make_dyn_type else make_type in let args = List.map (fun at -> let aname = (match t.hlmt_pnames with | None -> incr pn; "p" ^ string_of_int !pn @@ -294,11 +230,14 @@ let build_class com c file = ) in incr p; let t = make_type at in + let is_opt = ref false in let def_val = match opt_val with | None -> None | Some v -> let v = (match v with - | HVNone | HVNull | HVNamespace _ | HVString _ -> None + | HVNone | HVNull | HVNamespace _ | HVString _ -> + is_opt := true; + None | HVBool b -> Some (Ident (if b then "true" else "false")) | HVInt i | HVUInt i -> @@ -309,21 +248,23 @@ let build_class com c file = match v with | None -> None | Some v -> - meta := (":defparam",[String aname;v]) :: !meta; + (* add for --gen-hx-classes generation *) + meta := (Meta.DefParam,[String aname;v]) :: !meta; Some (EConst v,pos) in - (aname,opt_val <> None,Some t,def_val) + (aname,!is_opt,Some t,def_val) ) t.hlmt_args in let args = if t.hlmt_var_args then args @ List.map (fun _ -> incr pn; ("p" ^ string_of_int !pn,true,Some (make_type None),None)) [1;2;3;4;5] else args in let f = { + f_params = []; f_args = args; f_type = Some (make_type t.hlmt_ret); - f_expr = (EBlock [],pos) + f_expr = None; } in cf.cff_meta <- mk_meta(); - cf.cff_kind <- FFun ([],f); + cf.cff_kind <- FFun f; cf :: acc | MK3Getter -> Hashtbl.add getters (name,stat) m.hlm_type.hlmt_ret; @@ -354,6 +295,7 @@ let build_class com c file = | None, Some t -> false, true, t | Some t1, Some t2 -> true, true, (if t1 <> t2 then None else t1) ) in + let t = if name = "endian" then Some (HMPath (["flash";"utils"],"Endian")) else t in let flags = [APublic] in let flags = if stat then AStatic :: flags else flags in { @@ -362,14 +304,15 @@ let build_class com c file = cff_doc = None; cff_access = flags; cff_meta = []; - cff_kind = if get && set then FVar (Some (make_type t), None) else FProp ((if get then "default" else "never"),(if set then "default" else "never"),make_type t); + cff_kind = if get && set then FVar (Some (make_dyn_type t), None) else FProp ((if get then "default" else "never"),(if set then "default" else "never"),Some (make_dyn_type t),None); } in let fields = Hashtbl.fold (fun (name,stat) t acc -> + if Hashtbl.mem override (name,stat) then acc else make_get_set name stat (Some t) (try Some (Hashtbl.find setters (name,stat)) with Not_found -> None) :: acc ) getters fields in let fields = Hashtbl.fold (fun (name,stat) t acc -> - if Hashtbl.mem getters (name,stat) then + if Hashtbl.mem getters (name,stat) || Hashtbl.mem override (name,stat) then acc else make_get_set name stat None (Some t) :: acc @@ -385,23 +328,27 @@ let build_class com c file = match f.cff_kind with | FVar (Some (CTPath { tpackage = []; tname = ("String" | "Int" | "UInt") as tname }),None) when List.mem AStatic f.cff_access -> if !real_type = "" then real_type := tname else if !real_type <> tname then raise Exit; - (f.cff_name,None,[],[],pos) :: loop l - | FFun (_,{ f_args = [] }) when f.cff_name = "new" -> loop l + { + ec_name = f.cff_name; + ec_pos = pos; + ec_args = []; + ec_params = []; + ec_meta = []; + ec_doc = None; + ec_type = None; + } :: loop l + | FFun { f_args = [] } when f.cff_name = "new" -> loop l | _ -> raise Exit in - (match path.tpackage, path.tname with - | ["flash";"net"], "URLRequestMethod" - | ["flash";"filters"], "BitmapFilterQuality" - | ["flash";"display"], ("BitmapDataChannel" | "GraphicsPathCommand") -> raise Exit - | _ -> ()); List.iter (function HExtends _ | HImplements _ -> raise Exit | _ -> ()) flags; let constr = loop fields in - if constr = [] then raise Exit; + let name = "fakeEnum:" ^ String.concat "." (path.tpackage @ [path.tname]) in + if not (Common.raw_defined com name) then raise Exit; let enum_data = { d_name = path.tname; d_doc = None; d_params = []; - d_meta = [(":fakeEnum",[EConst (Type !real_type),pos],pos)]; + d_meta = [(Meta.FakeEnum,[EConst (Ident !real_type),pos],pos)]; d_flags = [EExtern]; d_data = constr; } in @@ -411,39 +358,33 @@ let build_class com c file = d_name = path.tname; d_doc = None; d_params = []; - d_meta = if c.hlc_final && List.exists (fun f -> f.cff_name <> "new" && not (List.mem AStatic f.cff_access)) fields then [":final",[],pos] else []; + d_meta = if c.hlc_final && List.exists (fun f -> f.cff_name <> "new" && not (List.mem AStatic f.cff_access)) fields then [Meta.Final,[],pos] else []; d_flags = flags; d_data = fields; } in (path.tpackage, [(EClass class_data,pos)]) -let extract_data swf = - let cache = ref None in - (fun() -> - match !cache with - | Some h -> h - | None -> - let _, tags = swf() in - let t = Common.timer "read swf" in - let h = Hashtbl.create 0 in - let rec loop_field f = - match f.hlf_kind with - | HFClass c -> - let path = make_tpath f.hlf_name in - (match path with - | { tpackage = []; tname = "Float" | "Bool" | "MethodClosure" | "Int" | "UInt" | "Dynamic" } -> () - | _ -> Hashtbl.add h (path.tpackage,path.tname) c) - | _ -> () - in - List.iter (fun t -> - match t.tdata with - | TActionScript3 (_,as3) -> - List.iter (fun i -> Array.iter loop_field i.hls_fields) (As3hlparse.parse as3) - | _ -> () - ) tags; - cache := Some h; - t(); - h) +let extract_data (_,tags) = + let t = Common.timer "read swf" in + let h = Hashtbl.create 0 in + let rec loop_field f = + match f.hlf_kind with + | HFClass c -> + let path = make_tpath f.hlf_name in + (match path with + | { tpackage = []; tname = "Float" | "Bool" | "Int" | "UInt" | "Dynamic" } -> () + | { tpackage = _; tname = "MethodClosure" } -> () + | _ -> Hashtbl.add h (path.tpackage,path.tname) c) + | _ -> () + in + List.iter (fun t -> + match t.tdata with + | TActionScript3 (_,as3) -> + List.iter (fun i -> Array.iter loop_field i.hls_fields) (As3hlparse.parse as3) + | _ -> () + ) tags; + t(); + h let remove_debug_infos as3 = let hl = As3hlparse.parse as3 in @@ -477,21 +418,21 @@ let remove_debug_infos as3 = m2 and loop_function f = let cur = ref 0 in - let positions = Array.map (fun op -> + let positions = MultiArray.map (fun op -> let p = !cur in (match op with | HDebugReg _ | HDebugLine _ | HDebugFile _ | HBreakPointLine _ | HTimestamp -> () | _ -> incr cur); p ) f.hlf_code in - let positions = Array.concat [positions;[|!cur|]] in - let code = DynArray.create() in - Array.iteri (fun pos op -> + MultiArray.add positions (!cur); + let code = MultiArray.create() in + MultiArray.iteri (fun pos op -> match op with | HDebugReg _ | HDebugLine _ | HDebugFile _ | HBreakPointLine _ | HTimestamp -> () | _ -> let p delta = - positions.(pos + delta) - DynArray.length code + MultiArray.get positions (pos + delta) - MultiArray.length code in let op = (match op with | HJump (j,delta) -> HJump (j, p delta) @@ -500,15 +441,15 @@ let remove_debug_infos as3 = | HCallStatic (m,args) -> HCallStatic (loop_method m,args) | HClassDef c -> HClassDef c (* mutated *) | _ -> op) in - DynArray.add code op + MultiArray.add code op ) f.hlf_code; - f.hlf_code <- DynArray.to_array code; + f.hlf_code <- code; f.hlf_trys <- Array.map (fun t -> { t with - hltc_start = positions.(t.hltc_start); - hltc_end = positions.(t.hltc_end); - hltc_handle = positions.(t.hltc_handle); + hltc_start = MultiArray.get positions t.hltc_start; + hltc_end = MultiArray.get positions t.hltc_end; + hltc_handle = MultiArray.get positions t.hltc_handle; } ) f.hlf_trys; f @@ -516,25 +457,65 @@ let remove_debug_infos as3 = As3hlparse.flatten (List.map loop_static hl) let parse_swf com file = - let data = ref None in - (fun () -> - match !data with - | Some swf -> swf + let t = Common.timer "read swf" in + let is_swc = file_extension file = "swc" in + let file = (try Common.find_file com file with Not_found -> failwith ((if is_swc then "SWC" else "SWF") ^ " Library not found : " ^ file)) in + let ch = if is_swc then begin + let zip = Zip.open_in file in + try + let entry = Zip.find_entry zip "library.swf" in + let ch = IO.input_string (Zip.read_entry zip entry) in + Zip.close_in zip; + ch + with _ -> + Zip.close_in zip; + failwith ("The input swc " ^ file ^ " is corrupted") + end else + IO.input_channel (open_in_bin file) + in + let h, tags = try + Swf.parse ch + with Out_of_memory -> + failwith ("Out of memory while parsing " ^ file) + | _ -> + failwith ("The input swf " ^ file ^ " is corrupted") + in + IO.close_in ch; + List.iter (fun t -> + match t.tdata with + | TActionScript3 (id,as3) when not com.debug && not com.display -> + t.tdata <- TActionScript3 (id,remove_debug_infos as3) + | _ -> () + ) tags; + t(); + (h,tags) + +let add_swf_lib com file extern = + let swf_data = ref None in + let swf_classes = ref None in + let getSWF = (fun() -> + match !swf_data with + | None -> + let d = parse_swf com file in + swf_data := Some d; + d + | Some d -> d + ) in + let extract = (fun() -> + match !swf_classes with | None -> - let t = Common.timer "read swf" in - let file = (try Common.find_file com file with Not_found -> failwith ("SWF Library not found : " ^ file)) in - let ch = IO.input_channel (open_in_bin file) in - let h, tags = (try Swf.parse ch with _ -> failwith ("The input swf " ^ file ^ " is corrupted")) in - IO.close_in ch; - List.iter (fun t -> - match t.tdata with - | TActionScript3 (id,as3) when not com.debug && not com.display -> - t.tdata <- TActionScript3 (id,remove_debug_infos as3) - | _ -> () - ) tags; - t(); - data := Some (h,tags); - (h,tags)) + let d = extract_data (getSWF()) in + swf_classes := Some d; + d + | Some d -> d + ) in + let build cl p = + match (try Some (Hashtbl.find (extract()) cl) with Not_found -> None) with + | None -> None + | Some c -> Some (file, build_class com c file) + in + com.load_extern_type <- com.load_extern_type @ [build]; + if not extern then com.swf_libs <- (file,getSWF,extract) :: com.swf_libs (* ------------------------------- *) @@ -551,15 +532,28 @@ let swf_ver = function | 9. -> 9 | 10. | 10.1 -> 10 | 10.2 -> 11 - | 11. -> 12 - | _ -> assert false + | 10.3 -> 12 + | 11. -> 13 + | 11.1 -> 14 + | 11.2 -> 15 + | 11.3 -> 16 + | 11.4 -> 17 + | 11.5 -> 18 + | 11.6 -> 19 + | 11.7 -> 20 + | 11.8 -> 21 + | v -> failwith ("Invalid SWF version " ^ string_of_float v) let convert_header com (w,h,fps,bg) = - if max w h >= 1639 then failwith "-swf-header : size too large"; + let high = (max w h) * 20 in + let rec loop b = + if 1 lsl b > high then b else loop (b + 1) + in + let bits = loop 0 in { h_version = swf_ver com.flash_version; h_size = { - rect_nbits = if (max w h) >= 820 then 16 else 15; + rect_nbits = bits + 1; left = 0; top = 0; right = w * 20; @@ -567,7 +561,7 @@ let convert_header com (w,h,fps,bg) = }; h_frame_count = 1; h_fps = to_float16 (if fps > 127.0 then 127.0 else fps); - h_compressed = not (Common.defined com "no-swf-compress"); + h_compressed = not (Common.defined com Define.NoSwfCompress); } , bg let default_header com = @@ -590,7 +584,10 @@ let build_dependencies t = add_path e.e_path DKType; List.iter (add_type_rec (t::l)) pl; | TInst (c,pl) -> - add_path c.cl_path DKType; + (match c.cl_kind with KTypeParameter _ -> () | _ -> add_path c.cl_path DKType); + List.iter (add_type_rec (t::l)) pl; + | TAbstract (a,pl) -> + add_path a.a_path DKType; List.iter (add_type_rec (t::l)) pl; | TFun (pl,t2) -> List.iter (fun (_,_,t2) -> add_type_rec (t::l) t2) pl; @@ -613,22 +610,21 @@ let build_dependencies t = and add_expr e = match e.eexpr with | TTypeExpr t -> add_path (Type.t_path t) DKExpr - | TEnumField (e,_) -> add_path e.e_path DKExpr | TNew (c,pl,el) -> add_path c.cl_path DKExpr; List.iter add_type pl; List.iter add_expr el; | TFunction f -> - List.iter (fun (_,_,t) -> add_type t) f.tf_args; + List.iter (fun (v,_) -> add_type v.v_type) f.tf_args; add_type f.tf_type; add_expr f.tf_expr; - | TFor (_,t,e1,e2) -> - add_type t; + | TFor (v,e1,e2) -> + add_type v.v_type; add_expr e1; add_expr e2; | TVars vl -> - List.iter (fun (_,t,e) -> - add_type t; + List.iter (fun (v,e) -> + add_type v.v_type; match e with | None -> () | Some e -> add_expr e @@ -673,6 +669,7 @@ let build_dependencies t = | _ -> ()); h := PMap.remove (([],"Int"),DKType) (!h); h := PMap.remove (([],"Int"),DKExpr) (!h); + h := PMap.remove (([],"Void"),DKType) (!h); PMap.foldi (fun (c,k) () acc -> (c,k) :: acc) (!h) [] let build_swc_catalog com types = @@ -718,24 +715,6 @@ let build_swc_catalog com types = ] in "\n" ^ Xml.to_string_fmt x -let make_as3_public data = - (* set all protected+private fields to public - this will enable overriding/reflection in haXe classes *) - let ns = Array.mapi (fun i ns -> - match ns with - | A3NPrivate _ - | A3NInternal _ - | A3NProtected _ - | A3NPublic None - -> - A3NPublic None - | A3NPublic _ - | A3NNamespace _ - | A3NExplicit _ - | A3NStaticProtected _ -> ns - ) data.as3_namespaces in - let cl = Array.map (fun c -> { c with cl3_namespace = None }) data.as3_classes in - { data with as3_namespaces = ns; as3_classes = cl } - let remove_classes toremove lib hcl = let lib = lib() in match !toremove with @@ -799,8 +778,26 @@ let build_swf8 com codeclip exports = ) in clips @ code +type file_format = + | BJPG + | BPNG + | BGIF + | SWAV + | SMP3 + +let detect_format data p = + match (try data.[0],data.[1],data.[2] with _ -> '\x00','\x00','\x00') with + | '\xFF', '\xD8', _ -> BJPG + | '\x89', 'P', 'N' -> BPNG + | 'R', 'I', 'F' -> SWAV + | 'I', 'D', '3' -> SMP3 + | '\xFF', i, _ when (int_of_char i) land 0xE2 = 0xE2 -> SMP3 + | 'G', 'I', 'F' -> BGIF + | _ -> + error "Unknown file format" p + let build_swf9 com file swc = - let boot_name = if swc <> None || Common.defined com "haxe-boot" then "haxe" else "boot_" ^ (String.sub (Digest.to_hex (Digest.string file)) 0 4) in + let boot_name = if swc <> None || Common.defined com Define.HaxeBoot then "haxe" else "boot_" ^ (String.sub (Digest.to_hex (Digest.string (Filename.basename file))) 0 4) in let code = Genswf9.generate com boot_name in let code = (match swc with | Some cat -> @@ -825,16 +822,219 @@ let build_swf9 com file swc = ) code in [tag (TActionScript3 (None,As3hlparse.flatten inits))] ) in - let clips = [tag (TF9Classes [{ f9_cid = None; f9_classname = boot_name }])] in - code @ clips + let cid = ref 0 in + let classes = ref [{ f9_cid = None; f9_classname = boot_name }] in + let res = Hashtbl.fold (fun name data acc -> + incr cid; + classes := { f9_cid = Some !cid; f9_classname = s_type_path (Genswf9.resource_path name) } :: !classes; + tag (TBinaryData (!cid,data)) :: acc + ) com.resources [] in + let load_file_data file p = + let file = try Common.find_file com file with Not_found -> file in + if String.length file > 5 && String.sub file 0 5 = "data:" then + String.sub file 5 (String.length file - 5) + else + (try Std.input_file ~bin:true file with Invalid_argument("String.create") -> error "File is too big (max 16MB allowed)" p | _ -> error "File not found" p) + in + let bmp = List.fold_left (fun acc t -> + match t with + | TClassDecl c -> + let rec loop = function + | [] -> acc + | (Meta.Font,(EConst (String file),p) :: args,_) :: l -> + let file = try Common.find_file com file with Not_found -> file in + let ch = try open_in_bin file with _ -> error "File not found" p in + let ttf = TTFParser.parse ch in + close_in ch; + let range_str = match args with + | [EConst (String str),_] -> str + | _ -> "" + in + let ttf_swf = TTFSwfWriter.to_swf ttf range_str in + let ch = IO.output_string () in + let b = IO.output_bits ch in + TTFSwfWriter.write_font2 ch b ttf_swf; + let data = IO.close_out ch in + incr cid; + classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes; + tag (TFont3 { + cd_id = !cid; + cd_data = data; + }) :: loop l + | (Meta.Bitmap,[EConst (String file),p],_) :: l -> + let data = load_file_data file p in + incr cid; + classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes; + let raw() = + tag (TBitsJPEG2 { bd_id = !cid; bd_data = data; bd_table = None; bd_alpha = None; bd_deblock = Some 0 }) + in + let t = (match detect_format data p with + | BPNG -> + (* + There is a bug in Flash PNG decoder for 24-bits PNGs : Color such has 0xFF00FF is decoded as 0xFE00FE. + In that particular case, we will then embed the decoded PNG bytes instead. + *) + (try + let png = Png.parse (IO.input_string data) in + let h = Png.header png in + (match h.Png.png_color with + | Png.ClTrueColor (Png.TBits8,Png.NoAlpha) -> + if h.Png.png_width * h.Png.png_height * 4 > Sys.max_string_length then begin + com.warning "Flash will loose some color information for this file, add alpha channel to preserve it" p; + raise Exit; + end; + let data = Extc.unzip (Png.data png) in + let raw_data = Png.filter png data in + let cmp_data = Extc.zip raw_data in + tag ~ext:true (TBitsLossless2 { bll_id = !cid; bll_format = 5; bll_width = h.Png.png_width; bll_height = h.Png.png_height; bll_data = cmp_data }) + | _ -> raw()) + with Exit -> + raw() + | _ -> + com.error ("Failed to decode this PNG " ^ file) p; + raw(); + ) + | _ -> raw() + ) in + t :: loop l + | (Meta.Bitmap,[EConst (String dfile),p1;EConst (String afile),p2],_) :: l -> + let ddata = load_file_data dfile p1 in + let adata = load_file_data afile p2 in + (match detect_format ddata p1 with + | BJPG -> () + | _ -> error "RGB channel must be a JPG file" p1); + (match detect_format adata p2 with + | BPNG -> () + | _ -> error "Alpha channel must be a PNG file" p2); + let png = Png.parse (IO.input_string adata) in + let h = Png.header png in + let amask = (match h.Png.png_color with + | Png.ClTrueColor (Png.TBits8,Png.HaveAlpha) -> + let data = Extc.unzip (Png.data png) in + let raw_data = Png.filter png data in + let alpha = String.make (h.Png.png_width * h.Png.png_height) '\000' in + for i = 0 to String.length alpha do + String.unsafe_set alpha i (String.unsafe_get raw_data (i lsl 2)); + done; + Extc.zip alpha + | _ -> error "PNG file must contain 8 bit alpha channel" p2 + ) in + incr cid; + classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes; + tag (TBitsJPEG3 { bd_id = !cid; bd_data = ddata; bd_table = None; bd_alpha = Some amask; bd_deblock = Some 0 }) :: loop l + | (Meta.File,[EConst (String file),p],_) :: l -> + let data = load_file_data file p in + incr cid; + classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes; + tag (TBinaryData (!cid,data)) :: loop l + | (Meta.Sound,[EConst (String file),p],_) :: l -> + let data = load_file_data file p in + let make_flags fmt mono freq bits = + let fbits = (match freq with 5512 when fmt <> 2 -> 0 | 11025 -> 1 | 22050 -> 2 | 44100 -> 3 | _ -> failwith ("Unsupported frequency " ^ string_of_int freq)) in + let bbits = (match bits with 8 -> 0 | 16 -> 1 | _ -> failwith ("Unsupported bits " ^ string_of_int bits)) in + (fmt lsl 4) lor (fbits lsl 2) lor (bbits lsl 1) lor (if mono then 0 else 1) + in + let flags, samples, data = (match detect_format data p with + | SWAV -> + (try + let i = IO.input_string data in + if IO.nread i 4 <> "RIFF" then raise Exit; + ignore(IO.nread i 4); (* size *) + if IO.nread i 4 <> "WAVE" || IO.nread i 4 <> "fmt " then raise Exit; + let chunk_size = IO.read_i32 i in + if not (chunk_size = 0x10 || chunk_size = 0x12 || chunk_size = 0x40) then failwith ("Unsupported chunk size " ^ string_of_int chunk_size); + if IO.read_ui16 i <> 1 then failwith "Not a PCM file"; + let chan = IO.read_ui16 i in + if chan > 2 then failwith "Too many channels"; + let freq = IO.read_i32 i in + ignore(IO.read_i32 i); + ignore(IO.read_i16 i); + let bits = IO.read_ui16 i in + if chunk_size <> 0x10 then ignore(IO.nread i (chunk_size - 0x10)); + if IO.nread i 4 <> "data" then raise Exit; + let data_size = IO.read_i32 i in + let data = IO.nread i data_size in + make_flags 0 (chan = 1) freq bits, (data_size * 8 / (chan * bits)), data + with Exit | IO.No_more_input | IO.Overflow _ -> + error "Invalid WAV file" p + | Failure msg -> + error ("Invalid WAV file (" ^ msg ^ ")") p + ) + | SMP3 -> + (try + let sampling = ref 0 in + let mono = ref false in + let samples = ref 0 in + let i = IO.input_string data in + let rec read_frame() = + match (try IO.read_byte i with IO.No_more_input -> -1) with + | -1 -> + () + | 0x49 -> + (* ID3 *) + if IO.nread i 2 <> "D3" then raise Exit; + ignore(IO.read_ui16 i); (* version *) + ignore(IO.read_byte i); (* flags *) + let size = IO.read_byte i land 0x7F in + let size = size lsl 7 lor (IO.read_byte i land 0x7F) in + let size = size lsl 7 lor (IO.read_byte i land 0x7F) in + let size = size lsl 7 lor (IO.read_byte i land 0x7F) in + ignore(IO.nread i size); (* id3 data *) + read_frame() + | 0x54 -> + (* TAG and TAG+ *) + if IO.nread i 3 = "AG+" then ignore(IO.nread i 223) else ignore(IO.nread i 124); + read_frame() + | 0xFF -> + let infos = IO.read_byte i in + let ver = (infos lsr 3) land 3 in + sampling := [|11025;0;22050;44100|].(ver); + let layer = (infos lsr 1) land 3 in + let bits = IO.read_byte i in + let bitrate = (if ver = 3 then [|0;32;40;48;56;64;80;96;112;128;160;192;224;256;320;-1|] else [|0;8;16;24;32;40;48;56;64;80;96;112;128;144;160;-1|]).(bits lsr 4) in + let srate = [| + [|11025;12000;8000;-1|]; + [|-1;-1;-1;-1|]; + [|22050;24000;16000;-1|]; + [|44100;48000;32000;-1|]; + |].(ver).((bits lsr 2) land 3) in + let pad = (bits lsr 1) land 1 in + mono := (IO.read_byte i) lsr 6 = 3; + let bpp = (if ver = 3 then 144 else 72) in + let size = ((bpp * bitrate * 1000) / srate) + pad - 4 in + ignore(IO.nread i size); + samples := !samples + (if layer = 3 then 384 else 1152); + read_frame() + | _ -> + raise Exit + in + read_frame(); + make_flags 2 !mono !sampling 16, (!samples), ("\x00\x00" ^ data) + with Exit | IO.No_more_input | IO.Overflow _ -> + error "Invalid MP3 file" p + | Failure msg -> + error ("Invalid MP3 file (" ^ msg ^ ")") p + ) + | _ -> + error "Sound extension not supported (only WAV or MP3)" p + ) in + incr cid; + classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes; + tag (TSound { so_id = !cid; so_flags = flags; so_samples = samples; so_data = data }) :: loop l + | _ :: l -> loop l + in + loop c.cl_meta + | _ -> acc + ) [] com.types in + let clips = [tag (TF9Classes (List.rev !classes))] in + res @ bmp @ code @ clips let merge com file priority (h1,tags1) (h2,tags2) = (* prioritize header+bgcolor for first swf *) let header = if priority then { h2 with h_version = max h2.h_version (swf_ver com.flash_version) } else h1 in let tags1 = if priority then List.filter (function { tdata = TSetBgColor _ } -> false | _ -> true) tags1 else tags1 in (* remove unused tags *) - let use_stage = priority && Common.defined com "flash_use_stage" in - let as3_native = Common.defined com "as3_native" in + let use_stage = priority && Common.defined com Define.FlashUseStage in let classes = ref [] in let nframe = ref 0 in let tags2 = List.filter (fun t -> @@ -844,16 +1044,15 @@ let merge com file priority (h1,tags1) (h2,tags2) = | TRemoveObject2 _ | TRemoveObject _ -> use_stage | TShowFrame -> incr nframe; use_stage - (* patch : this class has a public method which redefines a private one ! *) - | TActionScript3 (Some (_,"org/papervision3d/render/QuadrantRenderEngine"),_) when not as3_native -> false | TFilesAttributes _ | TEnableDebugger2 _ | TScenes _ -> false + | TMetaData _ -> not (Common.defined com Define.SwfMetadata) | TSetBgColor _ -> priority | TExport el when !nframe = 0 && com.flash_version >= 9. -> let el = List.filter (fun e -> let path = parse_path e.exp_name in let b = List.exists (fun t -> t_path t = path) com.types in if not b && fst path = [] then List.iter (fun t -> - if snd (t_path t) = snd path then error ("Linkage name '" ^ snd path ^ "' in '" ^ file ^ "' should be '" ^ s_type_path (t_path t) ^"'") (t_pos t); + if snd (t_path t) = snd path then error ("Linkage name '" ^ snd path ^ "' in '" ^ file ^ "' should be '" ^ s_type_path (t_path t) ^"'") (t_infos t).mt_pos; ) com.types; b ) el in @@ -877,12 +1076,6 @@ let merge com file priority (h1,tags1) (h2,tags2) = in List.iter loop tags2; let classes = List.map (fun e -> match e.f9_cid with None -> e | Some id -> { e with f9_cid = Some (id + !max_id) }) !classes in - (* do additional transforms *) - let tags2 = List.map (fun t -> - match t.tdata with - | TActionScript3 (id,data) when not as3_native -> { t with tdata = TActionScript3 (id,make_as3_public data) } - | _ -> t - ) tags2 in (* merge timelines *) let rec loop l1 l2 = match l1, l2 with @@ -913,7 +1106,7 @@ let merge com file priority (h1,tags1) (h2,tags2) = let generate com swf_header = let t = Common.timer "generate swf" in let isf9 = com.flash_version >= 9. in - let swc = if Common.defined com "swc" then Some (ref "") else None in + let swc = if Common.defined com Define.Swc then Some (ref "") else None in if swc <> None && not isf9 then failwith "SWC support is only available for Flash9+"; let file , codeclip = (try let f , c = ExtString.String.split com.file "@" in f, Some c with _ -> com.file , None) in (* list exports *) @@ -930,17 +1123,18 @@ let generate com swf_header = let extern = (match t with | TClassDecl c -> c.cl_extern | TEnumDecl e -> e.e_extern + | TAbstractDecl a -> false | TTypeDecl t -> false ) in if not extern && s_type_path (t_path t) = e.f9_classname then match t with | TClassDecl c -> - if has_meta ":bind" c.cl_meta then + if Meta.has Meta.Bind c.cl_meta then toremove := (t_path t) :: !toremove else - error ("Class already exists in '" ^ file ^ "', use @:bind to redefine it") (t_pos t) + error ("Class already exists in '" ^ file ^ "', use @:bind to redefine it") (t_infos t).mt_pos | _ -> - error ("Invalid redefinition of class defined in '" ^ file ^ "'") (t_pos t) + error ("Invalid redefinition of class defined in '" ^ file ^ "'") (t_infos t).mt_pos ) com.types; ) el | _ -> () @@ -950,17 +1144,44 @@ let generate com swf_header = let tags = if isf9 then build_swf9 com file swc else build_swf8 com codeclip exports in let header, bg = (match swf_header with None -> default_header com | Some h -> convert_header com h) in let bg = tag (TSetBgColor { cr = bg lsr 16; cg = (bg lsr 8) land 0xFF; cb = bg land 0xFF }) in - let debug = (if isf9 && Common.defined com "fdb" then [tag (TEnableDebugger2 (0,""))] else []) in + let swf_debug_password = try + Digest.to_hex(Digest.string (Common.defined_value com Define.SwfDebugPassword)) + with Not_found -> + "" + in + let debug = (if isf9 && Common.defined com Define.Fdb then [tag (TEnableDebugger2 (0, swf_debug_password))] else []) in + let meta_data = + try + let file = Common.defined_value com Define.SwfMetadata in + let file = try Common.find_file com file with Not_found -> file in + let data = try Std.input_file ~bin:true file with Sys_error _ -> failwith ("Metadata resource file not found : " ^ file) in + [tag(TMetaData (data))] + with Not_found -> + [] + in let fattr = (if com.flash_version < 8. then [] else [tag (TFilesAttributes { - fa_network = Common.defined com "network-sandbox"; + fa_network = Common.defined com Define.NetworkSandbox; fa_as3 = isf9; - fa_metadata = false; - fa_gpu = false; - fa_direct_blt = false; + fa_metadata = meta_data <> []; + fa_gpu = com.flash_version > 9. && Common.defined com Define.SwfGpu; + fa_direct_blt = com.flash_version > 9. && Common.defined com Define.SwfDirectBlit; })] ) in - let swf = header, fattr @ bg :: debug @ tags @ [tag TShowFrame] in + let fattr = if Common.defined com Define.AdvancedTelemetry then fattr @ [tag (TUnknown (0x5D,"\x00\x00"))] else fattr in + let preframe, header = + if Common.defined com Define.SwfPreloaderFrame then + [tag TShowFrame], {h_version=header.h_version; h_size=header.h_size; h_frame_count=header.h_frame_count+1; h_fps=header.h_fps; h_compressed=header.h_compressed; } + else + [], header in + let swf_script_limits = try + let s = Common.defined_value com Define.SwfScriptTimeout in + let i = try int_of_string s with _ -> error "Argument to swf_script_timeout must be an integer" Ast.null_pos in + [tag(TScriptLimits (256, if i < 0 then 0 else if i > 65535 then 65535 else i))] + with Not_found -> + [] + in + let swf = header, fattr @ meta_data @ bg :: debug @ swf_script_limits @ preframe @ tags @ [tag TShowFrame] in (* merge swf libraries *) let priority = ref (swf_header = None) in let swf = List.fold_left (fun swf (file,lib,cl) -> @@ -971,17 +1192,17 @@ let generate com swf_header = t(); (* write swf/swc *) let t = Common.timer "write swf" in + let level = (try int_of_string (Common.defined_value com Define.SwfCompressLevel) with Not_found -> 9) in + SwfParser.init Extc.input_zip (Extc.output_zip ~level); (match swc with | Some cat -> let ch = IO.output_strings() in Swf.write ch swf; let swf = IO.close_out ch in - let ch = IO.output_channel (open_out_bin file) in - let z = zip_create ch in - zip_write_file z "catalog.xml" (!cat) (Unix.time()) true; - zip_write_file z "library.swf" (match swf with [s] -> s | _ -> failwith "SWF too big for SWC") (Unix.time()) false; - zip_write_cdr z; - IO.close_out ch; + let z = Zip.open_out file in + Zip.add_entry (!cat) z "catalog.xml"; + Zip.add_entry (match swf with [s] -> s | _ -> failwith "SWF too big for SWC") z ~level:0 "library.swf"; + Zip.close_out z | None -> let ch = IO.output_channel (open_out_bin file) in Swf.write ch swf; diff --git a/haxe/genswf8.ml b/genswf8.ml similarity index 89% rename from haxe/genswf8.ml rename to genswf8.ml index 4841f3d91db20c921149b74cc62ed0cda5517b42..a345e54d55fed57486370b056872d7917b074522 100644 --- a/haxe/genswf8.ml +++ b/genswf8.ml @@ -1,21 +1,25 @@ (* - * Haxe Compiler - * Copyright (c)2005 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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 Swf open Ast open Type @@ -56,9 +60,9 @@ type context = { mutable curmethod : (string * bool); mutable fun_pargs : (int * bool list) list; mutable static_init : bool; + mutable extern_boot : bool; (* loops *) - mutable cur_block : texpr list; mutable breaks : (unit -> unit) list; mutable continues : (int -> unit) list; mutable loop_stack : int; @@ -68,8 +72,6 @@ type context = { let invalid_expr p = error "Invalid expression" p let stack_error p = error "Stack error" p let protect_all = ref true -let extern_boot = ref false -let debug_pass = ref "" (* -------------------------------------------------------------- *) (* Bytecode Helpers *) @@ -401,11 +403,9 @@ let begin_func ctx need_super need_args args = let open_block ctx = let old_regs = ctx.regs in let old_rcount = ctx.reg_count in - let old_block = ctx.cur_block in (fun() -> ctx.regs <- old_regs; ctx.reg_count <- old_rcount; - ctx.cur_block <- old_block; ) let begin_loop ctx = @@ -447,10 +447,10 @@ let segment ctx = (* -------------------------------------------------------------- *) (* Generation Helpers *) -let define_var ctx v ef exprs = - if ctx.flash6 || List.exists (Codegen.local_find false v) exprs || ctx.static_init then begin - push ctx [VStr (v,false)]; - ctx.regs <- PMap.add v NoReg ctx.regs; +let define_var ctx v ef = + if ctx.flash6 || v.v_capture || ctx.static_init then begin + push ctx [VStr (v.v_name,false)]; + ctx.regs <- PMap.add v.v_name NoReg ctx.regs; match ef with | None -> write ctx ALocalVar @@ -459,7 +459,7 @@ let define_var ctx v ef exprs = write ctx ALocalAssign end else begin let r = alloc_reg ctx in - ctx.regs <- PMap.add v (Reg r) ctx.regs; + ctx.regs <- PMap.add v.v_name (Reg r) ctx.regs; match ef with | None -> () | Some f -> @@ -471,7 +471,7 @@ let alloc_tmp ctx = let r = alloc_reg ctx in if ctx.flash6 then let name = "$" ^ string_of_int r in - define_var ctx name None []; + define_var ctx (alloc_var name t_dynamic) None; TmpVar (name,r); else TmpReg r @@ -578,14 +578,20 @@ let rec gen_access ?(read_write=false) ctx forcall e = VarStr end else VarReg 1 - | TLocal "__arguments__" -> + | TLocal { v_name = "__arguments__" } -> push ctx [VStr ("arguments",true)]; VarStr - | TLocal s -> - access_local ctx s + | TLocal v -> + access_local ctx v.v_name + | TField (e,FClosure (_,{ cf_name = f })) -> + gen_expr ctx true e; + if read_write then assert false; + push ctx [VStr (f,is_protected ctx e.etype f)]; + VarClosure | TField (e2,f) -> gen_expr ctx true e2; if read_write then write ctx ADup; + let f = field_name f in let p = VStr (f,is_protected ctx e2.etype f) in push ctx [p]; if read_write then begin @@ -596,15 +602,10 @@ let rec gen_access ?(read_write=false) ctx forcall e = VarVolatile else VarObj - | TClosure (e,f) -> - gen_expr ctx true e; - if read_write then assert false; - push ctx [VStr (f,is_protected ctx e.etype f)]; - VarClosure | TArray (ea,eb) -> - if read_write then - try - let r = (match ea.eexpr with TLocal l -> (match PMap.find l ctx.regs with Reg r -> r | _ -> raise Not_found) | _ -> raise Not_found) in + if read_write then + try + let r = (match ea.eexpr with TLocal l -> (match PMap.find l.v_name ctx.regs with Reg r -> r | _ -> raise Not_found) | _ -> raise Not_found) in push ctx [VReg r]; gen_expr ctx true eb; write ctx ADup; @@ -623,16 +624,11 @@ let rec gen_access ?(read_write=false) ctx forcall e = gen_expr ctx true eb; end; VarObj - | TEnumField (en,f) -> - getvar ctx (gen_path ctx en.e_path false); - push ctx [VStr (f,false)]; - (match follow e.etype with - | TFun _ -> VarClosure - | _ -> VarObj) | TTypeExpr t -> (match t with | TClassDecl c -> gen_path ctx c.cl_path c.cl_extern | TEnumDecl e -> gen_path ctx e.e_path false + | TAbstractDecl a -> gen_path ctx a.a_path false | TTypeDecl _ -> assert false) | _ -> if not forcall then invalid_expr e.epos; @@ -644,7 +640,7 @@ and gen_access_rw ctx e = match e.eexpr with | TField ({ eexpr = TLocal _ },_) | TArray ({ eexpr = TLocal _ },{ eexpr = TConst _ }) | TArray ({ eexpr = TLocal _ },{ eexpr = TLocal _ }) -> ignore(gen_access ctx false e); - gen_access ctx false e + gen_access ctx false e | TField _ | TArray _ -> gen_access ~read_write:true ctx false e | _ -> @@ -656,12 +652,13 @@ and gen_try_catch ctx retval e catchs = gen_expr ctx retval e; let end_try = start_try() in let end_throw = ref true in - let jumps = List.map (fun (name,t,e) -> + let jumps = List.map (fun (v,e) -> if not !end_throw then (fun () -> ()) - else let t = (match follow t with + else let t = (match follow v.v_type with | TEnum (e,_) -> Some (TEnumDecl e) | TInst (c,_) -> Some (TClassDecl c) + | TAbstract (a,_) -> Some (TAbstractDecl a) | TFun _ | TLazy _ | TType _ @@ -683,7 +680,7 @@ and gen_try_catch ctx retval e catchs = cjmp ctx ) in let block = open_block ctx in - define_var ctx name (Some (fun() -> push ctx [VReg 0])) [e]; + define_var ctx v (Some (fun() -> push ctx [VReg 0])); gen_expr ctx retval e; block(); if retval then ctx.stack_size <- ctx.stack_size - 1; @@ -754,16 +751,16 @@ and gen_match ctx retval e cases def = let nregs = ctx.reg_count in List.iter (fun j -> j()) jl; let n = ref 1 in - List.iter (fun (a,t) -> + List.iter (fun v -> incr n; - match a with + match v with | None -> () - | Some a -> - define_var ctx a (Some (fun() -> + | Some v -> + define_var ctx v (Some (fun() -> get_tmp ctx renum; push ctx [VInt !n]; write ctx AObjGet - )) [e] + )) ) (match args with None -> [] | Some l -> l); gen_expr ctx retval e; if retval then ctx.stack_size <- ctx.stack_size - 1; @@ -836,7 +833,7 @@ and gen_binop ctx retval op e1 e2 = write ctx APop; gen_expr ctx true e2; jump_end() - | OpInterval -> + | OpInterval | OpArrow -> (* handled by typer *) assert false @@ -858,49 +855,50 @@ and gen_unop ctx retval op flag e = let k = gen_access_rw ctx e in getvar ctx k; (* store preincr value for later access *) - if retval && flag = Postfix then write ctx (ASetReg 0); + if retval && flag = Postfix then write ctx (ASetReg 0); write ctx (match op with Increment -> AIncrement | Decrement -> ADecrement | _ -> assert false); setvar ~retval:(retval && flag = Prefix) ctx k; if retval && flag = Postfix then push ctx [VReg 0] and gen_call ctx e el = - match e.eexpr, el with - | TLocal "__instanceof__" , [e1;e2] -> + let loc = match e.eexpr with TLocal v -> v.v_name | _ -> "" in + match loc, el with + | "__instanceof__" , [e1;e2] -> gen_expr ctx true e1; gen_expr ctx true e2; write ctx AInstanceOf - | TLocal "__typeof__" , [e] -> + | "__typeof__" , [e] -> gen_expr ctx true e; write ctx ATypeOf - | TLocal "__delete__" , [e1; e2] -> + | "__delete__" , [e1; e2] -> gen_expr ctx true e1; gen_expr ctx true e2; write ctx ADeleteObj - | TLocal "__random__" , [e] -> + | "__random__" , [e] -> gen_expr ctx true e; write ctx ARandom - | TLocal "__trace__" , [e] -> + | "__trace__" , [e] -> gen_expr ctx true e; write ctx ATrace - | TLocal "__eval__" , [e] -> + | "__eval__" , [e] -> gen_expr ctx true e; write ctx AEval - | TLocal "__gettimer__", [] -> + | "__gettimer__", [] -> write ctx AGetTimer - | TLocal "__undefined__", [] -> - push ctx [VUndefined] - | TLocal "__geturl__" , url :: target :: post -> + | "__undefined__", [] -> + push ctx [VUndefined] + | "__geturl__" , url :: target :: post -> gen_expr ctx true url; gen_expr ctx true target; write ctx (AGetURL2 (match post with [] -> 0 | [{ eexpr = TConst (TString "GET") }] -> 1 | _ -> 2)) - | TLocal "__new__", e :: el -> + | "__new__", e :: el -> let nargs = List.length el in List.iter (gen_expr ctx true) (List.rev el); push ctx [VInt nargs]; let k = gen_access ctx true e in new_call ctx k nargs - | TLocal "__keys__", [e2] - | TLocal "__hkeys__", [e2] -> + | "__keys__", [e2] + | "__hkeys__", [e2] -> let r = alloc_tmp ctx in push ctx [VInt 0; VStr ("Array",true)]; new_call ctx VarStr 0; @@ -914,7 +912,7 @@ and gen_call ctx e el = push ctx [VNull]; write ctx AEqual; let jump_end = cjmp ctx in - if e.eexpr = TLocal "__hkeys__" then begin + if loc = "__hkeys__" then begin push ctx [VInt 1; VInt 1; VReg 0; VStr ("substr",true)]; call ctx VarObj 1; end else begin @@ -929,19 +927,19 @@ and gen_call ctx e el = jump_end(); get_tmp ctx r; free_tmp ctx r e2.epos; - | TLocal "__physeq__" , [e1;e2] -> + | "__physeq__" , [e1;e2] -> gen_expr ctx true e1; gen_expr ctx true e2; write ctx APhysEqual; - | TLocal "__unprotect__", [{ eexpr = TConst (TString s) }] -> + | "__unprotect__", [{ eexpr = TConst (TString s) }] -> push ctx [VStr (s,false)] - | TLocal "__resources__", [] -> + | "__resources__", [] -> let count = ref 0 in Hashtbl.iter (fun name data -> incr count; push ctx [VStr ("name",false);VStr (name,true)]; (* if the data contains \0 or is not UTF8 valid, encode into bytes *) - (try + (try (try ignore(String.index data '\000'); raise Exit; with Not_found -> ()); UTF8.validate data; push ctx [VStr ("str",false)]; @@ -954,7 +952,7 @@ and gen_call ctx e el = ctx.stack_size <- ctx.stack_size - 4; ) ctx.com.resources; init_array ctx !count - | TLocal "__FSCommand2__", l -> + | "__FSCommand2__", l -> let nargs = List.length l in List.iter (gen_expr ctx true) (List.rev l); push ctx [VInt nargs]; @@ -973,11 +971,9 @@ and gen_expr_2 ctx retval e = | TConst TSuper | TConst TThis | TField _ - | TClosure _ | TArray _ | TLocal _ - | TTypeExpr _ - | TEnumField _ -> + | TTypeExpr _ -> getvar ctx (gen_access ctx false e) | TConst c -> gen_constant ctx c e.epos @@ -988,10 +984,8 @@ and gen_expr_2 ctx retval e = | [] -> if retval then push ctx [VNull] | [e] -> - ctx.cur_block <- []; gen_expr ctx retval e | e :: l -> - ctx.cur_block <- l; gen_expr ctx false e; loop l in @@ -999,8 +993,8 @@ and gen_expr_2 ctx retval e = loop el; b() | TVars vl -> - List.iter (fun (v,t,e) -> - define_var ctx v (match e with None -> None | Some e -> Some (fun() -> gen_expr ctx true e)) ctx.cur_block + List.iter (fun (v,e) -> + define_var ctx v (match e with None -> None | Some e -> Some (fun() -> gen_expr ctx true e)) ) vl; if retval then push ctx [VNull] | TArrayDecl el -> @@ -1019,7 +1013,18 @@ and gen_expr_2 ctx retval e = let block = open_block ctx in let old_in_loop = ctx.in_loop in let old_meth = ctx.curmethod in - let reg_super = Codegen.local_find true "super" f.tf_expr in + let rec loop e = + match e.eexpr with + | TConst TSuper -> raise Exit + | _ -> Type.iter loop e + in + let reg_super = try loop f.tf_expr; false with Exit -> true in + let rec loop e = + match e.eexpr with + | TLocal { v_name = "__arguments__" } -> raise Exit + | _ -> Type.iter loop e + in + let reg_args = try loop f.tf_expr; false with Exit -> true in if snd ctx.curmethod then ctx.curmethod <- (fst ctx.curmethod ^ "@" ^ string_of_int (Lexer.get_error_line e.epos), true) else @@ -1033,25 +1038,25 @@ and gen_expr_2 ctx retval e = ctx.reg_count <- (if reg_super then 2 else 1); ctx.in_loop <- false; let pargs = ref [] in - let rargs = List.map (fun (a,_,t) -> - let no_reg = ctx.flash6 || Codegen.local_find false a f.tf_expr in + let rargs = List.map (fun (v,_) -> + let no_reg = ctx.flash6 || v.v_capture in if no_reg then begin - ctx.regs <- PMap.add a NoReg ctx.regs; - pargs := unprotect a :: !pargs; - 0 , a + ctx.regs <- PMap.add v.v_name NoReg ctx.regs; + pargs := unprotect v.v_name :: !pargs; + 0 , v.v_name end else begin let r = alloc_reg ctx in - ctx.regs <- PMap.add a (Reg r) ctx.regs; + ctx.regs <- PMap.add v.v_name (Reg r) ctx.regs; pargs := false :: !pargs; r , "" end ) f.tf_args in - let tf = begin_func ctx reg_super (Codegen.local_find true "__arguments__" f.tf_expr) rargs in + let tf = begin_func ctx reg_super reg_args rargs in ctx.fun_pargs <- (ctx.code_pos, List.rev !pargs) :: ctx.fun_pargs; - List.iter (fun (a,c,t) -> + List.iter (fun (v,c) -> match c with | None | Some TNull -> () - | Some c -> gen_expr ctx false (Codegen.set_default ctx.com a c t e.epos) + | Some c -> gen_expr ctx false (Codegen.set_default ctx.com v c e.epos) ) f.tf_args; if ctx.com.debug then begin gen_expr ctx false (ctx.stack.Codegen.stack_push ctx.curclass (fst ctx.curmethod)); @@ -1068,7 +1073,7 @@ and gen_expr_2 ctx retval e = let j = cjmp ctx in push ctx [VReg 0]; push ctx [VInt 1]; - getvar ctx (gen_path ctx (["flash"],"Boot") (!extern_boot)); + getvar ctx (gen_path ctx (["flash"],"Boot") ctx.extern_boot); push ctx [VStr ("__exc",false)]; call ctx VarObj 1; write ctx AReturn; @@ -1161,7 +1166,7 @@ and gen_expr_2 ctx retval e = gen_expr ctx retval (Codegen.default_cast ctx.com e1 t e.etype e.epos) | TMatch (e,_,cases,def) -> gen_match ctx retval e cases def - | TFor (v,_,it,e) -> + | TFor (v,it,e) -> gen_expr ctx true it; let r = alloc_tmp ctx in set_tmp ctx r; @@ -1181,12 +1186,12 @@ and gen_expr_2 ctx retval e = get_tmp ctx r; push ctx [VStr ("next",false)]; call ctx VarObj 0; - )) [e]; + )); gen_expr ctx false e; j_begin false; j_end(); loop_end cont_pos; - if retval then getvar ctx (access_local ctx v); + if retval then getvar ctx (access_local ctx v.v_name); b(); free_tmp ctx r null_pos @@ -1331,7 +1336,7 @@ let gen_type_def ctx t = () else let have_constr = ref false in - if c.cl_path = (["flash"] , "Boot") then extern_boot := false; + if c.cl_path = (["flash"] , "Boot") then ctx.extern_boot <- false; let acc = gen_path ctx c.cl_path false in let rec loop s = match s.cl_super with @@ -1405,9 +1410,11 @@ let gen_type_def ctx t = setvar ctx VarObj; (* true if implements mt.Protect *) let flag = is_protected ctx ~stat:true (TInst (c,[])) "" in - List.iter (gen_class_static_field ctx c flag) c.cl_ordered_statics; + if (Common.has_feature ctx.com "Reflect.getProperty") || (Common.has_feature ctx.com "Reflect.setProperty") then + Codegen.add_property_field ctx.com c; + List.iter (fun f -> if not (is_extern_field f) then gen_class_static_field ctx c flag f) c.cl_ordered_statics; let flag = is_protected ctx (TInst (c,[])) "" in - PMap.iter (fun _ f -> match f.cf_kind with Var { v_read = AccResolve } -> () | _ -> gen_class_field ctx flag f) c.cl_fields; + PMap.iter (fun _ f -> if not (is_extern_field f) then gen_class_field ctx flag f) c.cl_fields; | TEnumDecl e when e.e_extern -> () | TEnumDecl e -> @@ -1430,12 +1437,12 @@ let gen_type_def ctx t = write ctx AObjSet; ); PMap.iter (fun _ f -> gen_enum_field ctx e f) e.e_constrs - | TTypeDecl _ -> + | TTypeDecl _ | TAbstractDecl _ -> () let gen_boot ctx = (* r0 = Boot *) - getvar ctx (gen_path ctx (["flash"],"Boot") (!extern_boot)); + getvar ctx (gen_path ctx (["flash"],"Boot") ctx.extern_boot); write ctx (ASetReg 0); write ctx APop; (* r0.__init(eval("this")) *) @@ -1484,7 +1491,7 @@ let convert_header ctx ver (w,h,fps,bg) = }; h_frame_count = 1; h_fps = to_float16 (if fps > 127.0 then 127.0 else fps); - h_compressed = not (Common.defined ctx "no-swf-compress"); + h_compressed = not (Common.defined ctx Define.NoSwfCompress); } , bg let default_header ctx ver = @@ -1507,7 +1514,6 @@ let generate com = regs = PMap.empty; reg_count = 0; reg_max = 0; - cur_block = []; breaks = []; continues = []; loop_stack = 0; @@ -1520,10 +1526,10 @@ let generate com = fun_pargs = []; in_loop = false; static_init = false; + extern_boot = true; } in write ctx (AStringPool []); - protect_all := not (Common.defined com "swf-mark"); - extern_boot := true; + protect_all := not (Common.defined com Define.SwfMark); if com.debug then begin push ctx [VStr (ctx.stack.Codegen.stack_var,false); VInt 0]; write ctx AInitArray; @@ -1559,14 +1565,14 @@ let generate com = let end_try = global_try() in (* flash.Boot.__trace(exc) *) push ctx [VReg 0; VInt 1]; - getvar ctx (gen_path ctx (["flash"],"Boot") (!extern_boot)); + getvar ctx (gen_path ctx (["flash"],"Boot") ctx.extern_boot); push ctx [VStr ("__exc",false)]; call ctx VarObj 1; write ctx APop; end_try(); let segs = List.rev ((ctx.opcodes,ctx.idents) :: ctx.segs) in let tags = List.map build_tag segs in - if Common.defined com "swf-mark" then begin + if Common.defined com Define.SwfMark then begin if List.length segs > 1 then assert false; let pidents = snd (List.hd tags) in let ch = IO.output_channel (open_out_bin (Filename.chop_extension com.file ^ ".mark")) in diff --git a/haxe/genswf9.ml b/genswf9.ml similarity index 75% rename from haxe/genswf9.ml rename to genswf9.ml index d2207df1d6d4c8a08e63fb387dd58d02b48403b7..1df47b7535f39bea3b70a6ec64060763abbccba2 100644 --- a/haxe/genswf9.ml +++ b/genswf9.ml @@ -1,21 +1,25 @@ (* - * Haxe Compiler - * Copyright (c)2006 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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 As3 @@ -50,6 +54,7 @@ type 'a access = | VArray | VScope of hl_slot | VVolatile of hl_name * tkind option + | VSuper of hl_name type local = | LReg of register @@ -80,19 +85,21 @@ type context = { debugger : bool; swc : bool; boot : path; + swf_protected : bool; + need_ctor_skip : bool; + mutable cur_class : tclass; + mutable debug : bool; mutable last_line : int; mutable last_file : string; (* per-function *) - mutable locals : (string,local) PMap.t; + mutable locals : (int,tvar * local) PMap.t; mutable code : hl_opcode DynArray.t; mutable infos : code_infos; mutable trys : try_infos list; mutable breaks : (unit -> unit) list; mutable continues : (int -> unit) list; mutable in_static : bool; - mutable curblock : texpr list; mutable block_vars : (hl_slot * string * hl_name option) list; - mutable used_vars : (string , pos) PMap.t; mutable try_scope_reg : register option; mutable for_call : bool; } @@ -107,6 +114,14 @@ let tid (x : 'a index) : int = Obj.magic x let ethis = mk (TConst TThis) (mk_mono()) null_pos let dynamic_prop = HMMultiNameLate [HNPublic (Some "")] +let is_special_compare e1 e2 = + match e1.eexpr, e2.eexpr with + | TConst TNull, _ | _ , TConst TNull -> None + | _ -> + match follow e1.etype, follow e2.etype with + | TInst ({ cl_path = [],"Xml" } as c,_) , _ | _ , TInst ({ cl_path = [],"Xml" } as c,_) -> Some c + | _ -> None + let write ctx op = DynArray.add ctx.code op; ctx.infos.ipos <- ctx.infos.ipos + 1; @@ -146,10 +161,13 @@ let real_path = function | [] , "Float" -> [] , "Number" | [] , "Bool" -> [] , "Boolean" | [] , "Enum" -> [] , "Class" + | [] , "EnumValue" -> [] , "Object" | ["flash";"xml"], "XML" -> [], "XML" | ["flash";"xml"], "XMLList" -> [], "XMLList" | ["flash";"utils"], "QName" -> [] , "QName" | ["flash";"utils"], "Namespace" -> [] , "Namespace" + | ["flash";"utils"], "Object" -> [] , "Object" + | ["flash";"utils"], "Function" -> [] , "Function" | ["flash"] , "FlashXml__" -> [] , "Xml" | ["flash";"errors"] , "Error" -> [], "Error" | ["flash"] , "Vector" -> ["__AS3__";"vec"], "Vector" @@ -171,16 +189,24 @@ let rec follow_basic t = (match follow_basic tp with | TMono _ | TFun _ + | TAbstract ({ a_path = ([],"Int") },[]) + | TAbstract ({ a_path = ([],"Float") },[]) + | TAbstract ({ a_path = [],"UInt" },[]) + | TAbstract ({ a_path = ([],"Bool") },[]) | TInst ({ cl_path = (["haxe"],"Int32") },[]) | TInst ({ cl_path = ([],"Int") },[]) | TInst ({ cl_path = ([],"Float") },[]) | TType ({ t_path = [],"UInt" },[]) | TEnum ({ e_path = ([],"Bool") },[]) -> t | t -> t) + | TType ({ t_path = ["flash";"utils"],"Object" },[]) + | TType ({ t_path = ["flash";"utils"],"Function" },[]) | TType ({ t_path = [],"UInt" },[]) -> t | TType (t,tl) -> follow_basic (apply_params t.t_types tl t.t_type) + | TAbstract (a,pl) when a.a_impl <> None -> + follow_basic (apply_params a.a_types pl a.a_this) | _ -> t let rec type_id ctx t = @@ -188,18 +214,22 @@ let rec type_id ctx t = | TInst ({ cl_path = ["haxe"],"Int32" },_) -> type_path ctx ([],"Int") | TInst ({ cl_path = ["flash"],"Vector" } as c,pl) -> - HMParams (type_path ctx c.cl_path,List.map (type_id ctx) pl) + (match pl with + | [TInst({cl_kind = KTypeParameter _},_)] -> type_path ctx ([],"Object") + | _ -> HMParams (type_path ctx c.cl_path,List.map (type_id ctx) pl)) | TInst (c,_) -> (match c.cl_kind with - | KTypeParameter -> - (match c.cl_implements with - | [csup,_] -> type_path ctx csup.cl_path + | KTypeParameter l -> + (match l with + | [t] -> type_id ctx t | _ -> type_path ctx ([],"Object")) | KExtension (c,params) -> type_id ctx (TInst (c,params)) | _ -> type_path ctx c.cl_path) - | TFun _ -> + | TAbstract (a,_) -> + type_path ctx a.a_path + | TFun _ | TType ({ t_path = ["flash";"utils"],"Function" },[]) -> type_path ctx ([],"Function") | TType ({ t_path = ([],"UInt") as path },_) -> type_path ctx path @@ -208,7 +238,7 @@ let rec type_id ctx t = | TEnum (e,_) -> let rec loop = function | [] -> type_path ctx e.e_path - | (":fakeEnum",[Ast.EConst (Ast.Type n),_],_) :: _ -> type_path ctx ([],n) + | (Meta.FakeEnum,[Ast.EConst (Ast.Ident n),_],_) :: _ -> type_path ctx ([],n) | _ :: l -> loop l in loop e.e_meta @@ -216,29 +246,31 @@ let rec type_id ctx t = HMPath ([],"Object") let type_opt ctx t = - match follow t with + match follow_basic t with | TDynamic _ | TMono _ -> None | _ -> Some (type_id ctx t) let type_void ctx t = match follow t with - | TEnum ({ e_path = [],"Void" },_) -> Some (HMPath ([],"void")) + | TEnum ({ e_path = [],"Void" },_) | TAbstract ({ a_path = [],"Void" },_) -> Some (HMPath ([],"void")) | _ -> type_opt ctx t let classify ctx t = match follow_basic t with - | TInst ({ cl_path = [],"Int" },_) | TInst ({ cl_path = ["haxe"],"Int32" },_) -> + | TAbstract ({ a_path = [],"Int" },_) | TInst ({ cl_path = [],"Int" },_) | TInst ({ cl_path = ["haxe"],"Int32" },_) -> KInt - | TInst ({ cl_path = [],"Float" },_) -> + | TAbstract ({ a_path = [],"Float" },_) | TInst ({ cl_path = [],"Float" },_) -> KFloat - | TEnum ({ e_path = [],"Bool" },_) -> + | TAbstract ({ a_path = [],"Bool" },_) | TEnum ({ e_path = [],"Bool" },_) -> KBool + | TAbstract ({ a_path = [],"Void" },_) | TEnum ({ e_path = [],"Void" },_) -> + KDynamic | TEnum ({ e_path = [],"XmlType"; e_extern = true },_) -> KType (HMPath ([],"String")) | TEnum (e,_) -> let rec loop = function | [] -> KType (type_id ctx t) - | (":fakeEnum",[Ast.EConst (Type n),_],_) :: _ -> + | (Meta.FakeEnum,[Ast.EConst (Ident n),_],_) :: _ -> (match n with | "Int" -> KInt | "UInt" -> KUInt @@ -247,16 +279,18 @@ let classify ctx t = | _ :: l -> loop l in loop e.e_meta - | TInst _ -> - KType (type_id ctx t) - | TType ({ t_path = [],"UInt" },_) -> + | TAbstract ({ a_path = [],"UInt" },_) | TType ({ t_path = [],"UInt" },_) -> KUInt - | TFun _ -> + | TFun _ | TType ({ t_path = ["flash";"utils"],"Function" },[]) -> KType (HMPath ([],"Function")) | TAnon a -> (match !(a.a_status) with | Statics _ -> KNone | _ -> KDynamic) + | TType ({ t_path = ["flash";"utils"],"Object" },[]) -> + KType (HMPath ([],"Object")) + | TInst _ | TAbstract _ -> + KType (type_id ctx t) | TMono _ | TType _ | TDynamic _ -> @@ -264,11 +298,14 @@ let classify ctx t = | TLazy _ -> assert false -let ident i = - (* some field identifiers might cause issues with SWC *) +(* some field identifiers might cause issues with SWC *) +let reserved i = match i with - | "int" -> HMPath ([],"_" ^ i) - | _ -> HMPath ([],i) + | "int" -> "_" ^ i + | _ -> i + +let ident i = + HMPath ([],reserved i) let as3 p = HMName (p,HNNamespace "http://adobe.com/AS3/2006/builtin") @@ -278,17 +315,18 @@ let property ctx p t = | TInst ({ cl_path = [],"Array" },_) -> (match p with | "length" -> ident p, Some KInt, false (* UInt in the spec *) - | "copy" | "insert" | "remove" | "iterator" | "toString" -> ident p , None, true + | "copy" | "insert" | "remove" | "iterator" | "toString" | "map" | "filter" -> ident p , None, true | _ -> as3 p, None, false); | TInst ({ cl_path = ["flash"],"Vector" },_) -> (match p with - | "length" | "fixed" | "toString" -> ident p, None, false + | "length" -> ident p, Some KInt, false (* UInt in the spec *) + | "fixed" | "toString" -> ident p, None, false | "iterator" -> ident p, None, true | _ -> as3 p, None, false); | TInst ({ cl_path = [],"String" },_) -> (match p with - | "length" (* Int in AS3/haXe *) -> ident p, None, false - | "charCodeAt" (* use haXe version *) -> ident p, None, true + | "length" (* Int in AS3/Haxe *) -> ident p, None, false + | "charCodeAt" (* use Haxe version *) -> ident p, None, true | "cca" -> as3 "charCodeAt", None, false | _ -> as3 p, None, false); | TAnon a -> @@ -296,6 +334,8 @@ let property ctx p t = | Statics { cl_path = [], "Math" } -> (match p with | "POSITIVE_INFINITY" | "NEGATIVE_INFINITY" | "NaN" -> ident p, Some KFloat, false + | "floor" | "ceil" | "round" when ctx.for_call -> ident p, Some KInt, false + | "ffloor" | "fceil" | "fround" -> ident (String.sub p 1 (String.length p - 1)), None, false | _ -> ident p, None, false) | _ -> ident p, None, false) | TInst ({ cl_kind = KExtension _ } as c,params) -> @@ -305,6 +345,28 @@ let property ctx p t = ident p, Some (classify ctx (apply_params c.cl_types params f.cf_type)), false with Not_found -> ident p, None, false) + | TInst ({ cl_interface = true } as c,_) -> + (* lookup the interface in which the field was actually declared *) + let rec loop c = + try + (match PMap.find p c.cl_fields with + | { cf_kind = Var _ } -> raise Exit (* no vars in interfaces in swf9 *) + | _ -> c) + with Not_found -> + let rec loop2 = function + | [] -> raise Not_found + | (i,_) :: l -> + try loop i with Not_found -> loop2 l + in + loop2 c.cl_implements + in + (try + let c = loop c in + let ns = HMName (reserved p, HNNamespace (match c.cl_path with [],n -> n | l,n -> String.concat "." l ^ ":" ^ n)) in + ns, None, false + with Not_found | Exit -> + ident p, None, false) + | _ -> ident p, None, false @@ -388,32 +450,44 @@ let pop ctx n = loop n; ctx.infos.istack <- old -let define_local ctx ?(init=false) name t el p = - let l = (if List.exists (Codegen.local_find false name) el then begin +let is_member ctx name = + let rec loop c = + PMap.mem name c.cl_fields || (match c.cl_super with None -> false | Some (c,_) -> loop c) + in + loop ctx.cur_class + +let rename_block_var ctx v = + (* we need to rename it since slots are accessed on a by-name basis *) + let rec loop i = + let name = v.v_name ^ string_of_int i in + if List.exists (fun(_,x,_) -> name = x) ctx.block_vars || is_member ctx name then + loop (i + 1) + else + v.v_name <- name + in + loop 1 + +let define_local ctx ?(init=false) v p = + let name = v.v_name in + let t = v.v_type in + let l = (if v.v_capture then begin let topt = type_opt ctx t in - let pos = (try - let slot , _ , t = (List.find (fun (_,x,_) -> name = x) ctx.block_vars) in - if t <> topt then error ("Local variable '" ^ name ^ "' captured with same name but different types") p; - slot - with - Not_found -> - let n = List.length ctx.block_vars + 1 in - ctx.block_vars <- (n,name,topt) :: ctx.block_vars; - n - ) in + if List.exists (fun (_,x,_) -> name = x) ctx.block_vars || is_member ctx name then rename_block_var ctx v; + let pos = List.length ctx.block_vars + 1 in + ctx.block_vars <- (pos,v.v_name,topt) :: ctx.block_vars; LScope pos end else let r = alloc_reg ctx (classify ctx t) in - if ctx.com.debug then write ctx (HDebugReg (name, r.rid, ctx.last_line)); + if ctx.debug then write ctx (HDebugReg (name, r.rid, ctx.last_line)); r.rinit <- init; LReg r ) in - ctx.locals <- PMap.add name l ctx.locals + ctx.locals <- PMap.add v.v_id (v,l) ctx.locals let is_set v = (Obj.magic v) = Write -let gen_local_access ctx name p (forset : 'a) : 'a access = - match (try PMap.find name ctx.locals with Not_found -> error ("Unbound variable " ^ name) p) with +let gen_local_access ctx v p (forset : 'a) : 'a access = + match snd (try PMap.find v.v_id ctx.locals with Not_found -> error ("Unbound variable " ^ v.v_name) p) with | LReg r -> VReg r | LScope n -> @@ -423,8 +497,8 @@ let gen_local_access ctx name p (forset : 'a) : 'a access = if is_set forset then write ctx (HFindProp p); VGlobal p -let get_local_register ctx name = - match (try PMap.find name ctx.locals with Not_found -> LScope 0) with +let get_local_register ctx v = + match (try snd (PMap.find v.v_id ctx.locals) with Not_found -> LScope 0) with | LReg r -> Some r | _ -> None @@ -453,6 +527,8 @@ let rec setvar ctx (acc : write access) kret = ctx.infos.istack <- ctx.infos.istack - 1 | VScope n -> write ctx (HSetSlot n) + | VSuper id -> + write ctx (HSetSuper id) let getvar ctx (acc : read access) = match acc with @@ -482,13 +558,13 @@ let getvar ctx (acc : read access) = ctx.infos.istack <- ctx.infos.istack - 1 | VScope n -> write ctx (HGetSlot n) + | VSuper id -> + write ctx (HGetSuper id) -let open_block ctx el retval = +let open_block ctx retval = let old_stack = ctx.infos.istack in let old_regs = DynArray.map (fun r -> r.rused) ctx.infos.iregs in let old_locals = ctx.locals in - let old_block = ctx.curblock in - ctx.curblock <- el; (fun() -> if ctx.infos.istack <> old_stack + (if retval then 1 else 0) then assert false; let rcount = DynArray.length old_regs + 1 in @@ -499,7 +575,6 @@ let open_block ctx el retval = r.rused <- false ) ctx.infos.iregs; ctx.locals <- old_locals; - ctx.curblock <- old_block; ) let begin_branch ctx = @@ -531,10 +606,10 @@ let begin_switch ctx = let debug_infos ?(is_min=true) ctx p = - if ctx.com.debug then begin + if ctx.debug then begin let line = Lexer.get_error_line (if is_min then p else { p with pmin = p.pmax }) in if ctx.last_file <> p.pfile then begin - write ctx (HDebugFile (if ctx.debugger then try Common.get_full_path p.pfile with _ -> p.pfile else p.pfile)); + write ctx (HDebugFile (if ctx.debugger then Common.get_full_path p.pfile else p.pfile)); ctx.last_file <- p.pfile; ctx.last_line <- -1; end; @@ -562,10 +637,7 @@ let gen_constant ctx c t p = write ctx (if b then HTrue else HFalse); | TNull -> write ctx HNull; - (match classify ctx t with - | KInt | KBool | KUInt | KFloat -> - error ("In Flash9, null can't be used as basic type " ^ s_type (print_context()) t) p - | x -> coerce ctx x) + coerce ctx (classify ctx t) | TThis -> write ctx HThis | TSuper -> @@ -575,12 +647,12 @@ let end_fun ctx args dparams tret = { hlmt_index = 0; hlmt_ret = type_void ctx tret; - hlmt_args = List.map (fun (_,_,t) -> type_opt ctx t) args; + hlmt_args = List.map (fun (v,_) -> type_opt ctx v.v_type) args; hlmt_native = false; hlmt_var_args = false; hlmt_debug_name = None; hlmt_dparams = dparams; - hlmt_pnames = if ctx.swc || ctx.debugger then Some (List.map (fun (n,_,_) -> Some n) args) else None; + hlmt_pnames = if ctx.swc || ctx.debugger then Some (List.map (fun (v,_) -> Some v.v_name) args) else None; hlmt_new_block = false; hlmt_unused_flag = false; hlmt_arguments_defined = false; @@ -597,10 +669,8 @@ let begin_fun ctx args tret el stat p = let old_static = ctx.in_static in let last_line = ctx.last_line in let old_treg = ctx.try_scope_reg in - let old_uvars = ctx.used_vars in ctx.infos <- default_infos(); ctx.code <- DynArray.create(); - ctx.used_vars <- PMap.empty; ctx.trys <- []; ctx.block_vars <- []; ctx.in_static <- stat; @@ -614,11 +684,11 @@ let begin_fun ctx args tret el stat p = | _ -> Type.iter find_this e in let this_reg = try List.iter find_this el; false with Exit -> true in - ctx.locals <- PMap.foldi (fun name l acc -> + ctx.locals <- PMap.foldi (fun _ (v,l) acc -> match l with | LReg _ -> acc - | LScope _ -> PMap.add name (LGlobal (ident name)) acc - | LGlobal _ -> PMap.add name l acc + | LScope _ -> PMap.add v.v_id (v,LGlobal (ident v.v_name)) acc + | LGlobal _ -> PMap.add v.v_id (v,l) acc ) ctx.locals PMap.empty; let dparams = ref None in @@ -629,7 +699,7 @@ let begin_fun ctx args tret el stat p = (match c with | TInt i -> if kind = KUInt then HVUInt i else HVInt i | TFloat s -> HVFloat (float_of_string s) - | TBool b -> HVBool b + | TBool b -> HVBool b | TNull -> error ("In Flash9, null can't be used as basic type " ^ s_type (print_context()) t) p | _ -> assert false) | _, Some TNull -> HVNone @@ -645,12 +715,22 @@ let begin_fun ctx args tret el stat p = ) in match !dparams with | None -> if c <> None then dparams := Some [v] - | Some l -> dparams := Some (v :: l) + | Some l -> dparams := Some (v :: l) in - List.iter (fun (name,c,t) -> - define_local ctx name ~init:true t el p; - match gen_local_access ctx name null_pos Write with + let args, varargs = (match List.rev args with + | (({ v_name = "__arguments__"; v_type = t } as v),_) :: l -> + (match follow t with + | TInst ({ cl_path = ([],"Array") },_) -> List.rev l, Some (v,true) + | _ -> List.rev l, Some(v,false)) + | _ -> + args, None + ) in + + List.iter (fun (v,c) -> + let t = v.v_type in + define_local ctx v ~init:true p; + match gen_local_access ctx v null_pos Write with | VReg r -> make_constant_value r c t | acc -> @@ -660,11 +740,13 @@ let begin_fun ctx args tret el stat p = setvar ctx acc None ) args; + (match varargs with + | None -> () + | Some (v,_) -> + define_local ctx v ~init:true p; + ignore(alloc_reg ctx (classify ctx v.v_type))); + let dparams = (match !dparams with None -> None | Some l -> Some (List.rev l)) in - let args, varargs = (match args with - | ["__arguments__",_,_] -> [], true - | _ -> args, false - ) in let rec loop_try e = match e.eexpr with | TFunction _ -> () @@ -674,13 +756,6 @@ let begin_fun ctx args tret el stat p = ctx.try_scope_reg <- (try List.iter loop_try el; None with Exit -> Some (alloc_reg ctx KDynamic)); (fun () -> let hasblock = ctx.block_vars <> [] || ctx.trys <> [] in - List.iter (fun (_,v,_) -> - try - let p = PMap.find v ctx.used_vars in - error ("Accessing to this member variable is prevented by local '" ^ v ^ "' used in closure") p - with - Not_found -> () - ) ctx.block_vars; let code = DynArray.to_list ctx.code in let extra = ( if hasblock then begin @@ -715,7 +790,7 @@ let begin_fun ctx args tret el stat p = hlf_nregs = DynArray.length ctx.infos.iregs + 1; hlf_init_scope = 1; hlf_max_scope = ctx.infos.imaxscopes + 1 + (if hasblock then 2 else if this_reg then 1 else 0); - hlf_code = Array.of_list (extra @ code); + hlf_code = MultiArray.of_array (Array.of_list (extra @ code)); hlf_trys = Array.of_list (List.map (fun t -> { hltc_start = t.tr_pos + delta; @@ -728,7 +803,8 @@ let begin_fun ctx args tret el stat p = hlf_locals = Array.of_list (List.map (fun (id,name,t) -> ident name, t, id, false) ctx.block_vars); } in let mt = { (end_fun ctx args dparams tret) with - hlmt_var_args = varargs; + hlmt_var_args = (match varargs with Some (_,true) -> true | _ -> false); + hlmt_arguments_defined = (match varargs with Some (_,false) -> true | _ -> false); hlmt_new_block = hasblock; hlmt_function = Some f; } in @@ -740,7 +816,6 @@ let begin_fun ctx args tret el stat p = ctx.in_static <- old_static; ctx.last_line <- last_line; ctx.try_scope_reg <- old_treg; - ctx.used_vars <- old_uvars; mt ) @@ -778,19 +853,21 @@ let pop_value ctx retval = let gen_expr_ref = ref (fun _ _ _ -> assert false) let gen_expr ctx e retval = (!gen_expr_ref) ctx e retval -let use_var ctx f p = - if not (PMap.mem f ctx.used_vars) then ctx.used_vars <- PMap.add f p ctx.used_vars - -let gen_access ctx e (forset : 'a) : 'a access = +let rec gen_access ctx e (forset : 'a) : 'a access = match e.eexpr with - | TLocal i -> - gen_local_access ctx i e.epos forset - | TField (e1,f) | TClosure (e1,f) -> + | TLocal v -> + gen_local_access ctx v e.epos forset + | TField ({ eexpr = TConst TSuper } as e1,f) -> + let f = field_name f in + let id, _, _ = property ctx f e1.etype in + write ctx HThis; + VSuper id + | TField (e1,f) -> + let f = field_name f in let id, k, closure = property ctx f e1.etype in if closure && not ctx.for_call then error "In Flash9, this method cannot be accessed this way : please define a local function" e1.epos; (match e1.eexpr with - | TConst TThis when not ctx.in_static -> - use_var ctx f e.epos; + | TConst (TThis|TSuper) when not ctx.in_static -> write ctx (HFindProp id) | _ -> gen_expr ctx true e1); (match k with @@ -818,7 +895,7 @@ let gen_access ctx e (forset : 'a) : 'a access = else VCast (id,classify ctx e.etype) ) - | TArray ({ eexpr = TLocal "__global__" },{ eexpr = TConst (TString s) }) -> + | TArray ({ eexpr = TLocal { v_name = "__global__" } },{ eexpr = TConst (TString s) }) -> let path = parse_path s in let id = type_path ctx path in if is_set forset then write ctx HGetGlobalScope; @@ -836,8 +913,8 @@ let gen_access ctx e (forset : 'a) : 'a access = let gen_expr_twice ctx e = match e.eexpr with - | TLocal l -> - (match get_local_register ctx l with + | TLocal v -> + (match get_local_register ctx v with | Some r -> write ctx (HReg r.rid); write ctx (HReg r.rid); @@ -862,7 +939,7 @@ let gen_access_rw ctx e : (read access * write access) = let r = gen_access ctx e Read in r, w | TArray (e,eindex) -> - let r = (match e.eexpr with TLocal l -> get_local_register ctx l | _ -> None) in + let r = (match e.eexpr with TLocal v -> get_local_register ctx v | _ -> None) in (match r with | None -> let r = alloc_reg ctx (classify ctx e.etype) in @@ -914,10 +991,6 @@ let rec gen_expr_content ctx retval e = no_value ctx retval; | TParenthesis e -> gen_expr ctx retval e - | TEnumField (e,s) -> - let id = type_path ctx e.e_path in - write ctx (HGetLex id); - write ctx (HGetProp (ident s)); | TObjectDecl fl -> List.iter (fun (name,e) -> write ctx (HString name); @@ -932,19 +1005,17 @@ let rec gen_expr_content ctx retval e = | [] -> if retval then write ctx HNull | [e] -> - ctx.curblock <- []; gen_expr ctx retval e | e :: l -> - ctx.curblock <- l; gen_expr ctx false e; loop l in - let b = open_block ctx [] retval in + let b = open_block ctx retval in loop el; b(); | TVars vl -> - List.iter (fun (v,t,ei) -> - define_local ctx v t ctx.curblock e.epos; + List.iter (fun (v,ei) -> + define_local ctx v e.epos; (match ei with | None -> () | Some e -> @@ -962,7 +1033,6 @@ let rec gen_expr_content ctx retval e = ctx.infos.icond <- true; no_value ctx retval | TField _ - | TClosure _ | TLocal _ | TTypeExpr _ -> getvar ctx (gen_access ctx e Read) @@ -970,7 +1040,7 @@ let rec gen_expr_content ctx retval e = getvar ctx (gen_access ctx e Read); coerce ctx (classify ctx e.etype) | TBinop (op,e1,e2) -> - gen_binop ctx retval op e1 e2 e.etype + gen_binop ctx retval op e1 e2 e.etype e.epos | TCall (f,el) -> gen_call ctx retval f el e.etype | TNew ({ cl_path = [],"Array" },_,[]) -> @@ -1031,8 +1101,9 @@ let rec gen_expr_content ctx retval e = let jend = jump ctx J3Always in let rec loop ncases = function | [] -> [] - | (ename,t,e) :: l -> - let b = open_block ctx [e] retval in + | (v,e) :: l -> + let b = open_block ctx retval in + let t = v.v_type in ctx.trys <- { tr_pos = p; tr_end = pend; @@ -1046,15 +1117,15 @@ let rec gen_expr_content ctx retval e = write ctx (HReg (match ctx.try_scope_reg with None -> assert false | Some r -> r.rid)); write ctx HScope; (* store the exception into local var, using a tmp register if needed *) - define_local ctx ename t [e] e.epos; - let r = (match try PMap.find ename ctx.locals with Not_found -> assert false with + define_local ctx v e.epos; + let r = (match snd (try PMap.find v.v_id ctx.locals with Not_found -> assert false) with | LReg _ -> None | _ -> let r = alloc_reg ctx (classify ctx t) in set_reg ctx r; Some r ) in - let acc = gen_local_access ctx ename e.epos Write in + let acc = gen_local_access ctx v e.epos Write in (match r with None -> () | Some r -> write ctx (HReg r.rid)); setvar ctx acc None; (* ----- *) @@ -1066,11 +1137,11 @@ let rec gen_expr_content ctx retval e = in let has_call = (try call_loop e; false with Exit -> true) in if has_call then begin - getvar ctx (gen_local_access ctx ename e.epos Read); + getvar ctx (gen_local_access ctx v e.epos Read); write ctx (HAsType (type_path ctx (["flash";"errors"],"Error"))); let j = jump ctx J3False in getvar ctx (VGlobal (type_path ctx (["flash"],"Boot"))); - getvar ctx (gen_local_access ctx ename e.epos Read); + getvar ctx (gen_local_access ctx v e.epos Read); setvar ctx (VId (ident "lastError")) None; j(); end; @@ -1087,13 +1158,13 @@ let rec gen_expr_content ctx retval e = List.iter (fun j -> j()) loops; branch(); jend() - | TFor (v,t,it,e) -> + | TFor (v,it,e) -> gen_expr ctx true it; let r = alloc_reg ctx KDynamic in set_reg ctx r; let branch = begin_branch ctx in - let b = open_block ctx [e] retval in - define_local ctx v t [e] e.epos; + let b = open_block ctx retval in + define_local ctx v e.epos; let end_loop = begin_loop ctx in let continue_pos = ctx.infos.ipos in let start = jump_back ctx in @@ -1228,17 +1299,17 @@ let rec gen_expr_content ctx retval e = let j = jump ctx J3Always in List.iter case cl; pop_value ctx retval; - let b = open_block ctx [e] retval in + let b = open_block ctx retval in (match params with | None -> () | Some l -> let p = ref (-1) in - List.iter (fun (name,t) -> + List.iter (fun v -> incr p; - match name with + match v with | None -> () | Some v -> - define_local ctx v t [e] e.epos; + define_local ctx v e.epos; let acc = gen_local_access ctx v e.epos Write in write ctx (HReg rparams.rid); write ctx (HSmallInt !p); @@ -1286,23 +1357,35 @@ let rec gen_expr_content ctx retval e = and gen_call ctx retval e el r = match e.eexpr , el with - | TLocal "__is__" , [e;t] -> + | TLocal { v_name = "__is__" }, [e;t] -> gen_expr ctx true e; gen_expr ctx true t; write ctx (HOp A3OIs) - | TLocal "__as__" , [e;t] -> + | TLocal { v_name = "__as__" }, [e;t] -> gen_expr ctx true e; gen_expr ctx true t; write ctx (HOp A3OAs) - | TLocal "__int__", [e] -> + | TLocal { v_name = "__int__" }, [e] -> gen_expr ctx true e; write ctx HToInt - | TLocal "__float__", [e] -> + | TLocal { v_name = "__float__" }, [e] -> gen_expr ctx true e; write ctx HToNumber - | TLocal "__hkeys__" , [e2] - | TLocal "__foreach__", [e2] - | TLocal "__keys__" , [e2] -> + | TLocal { v_name = "__foreach__" }, [obj;counter] -> + gen_expr ctx true obj; + gen_expr ctx true counter; + write ctx HForEach + | TLocal { v_name = "__forin__" }, [obj;counter] -> + gen_expr ctx true obj; + gen_expr ctx true counter; + write ctx HForIn + | TLocal { v_name = "__has_next__" }, [obj;counter] -> + let oreg = match gen_access ctx obj Read with VReg r -> r | _ -> error "Must be a local variable" obj.epos in + let creg = match gen_access ctx counter Read with VReg r -> r | _ -> error "Must be a local variable" obj.epos in + write ctx (HNext (oreg.rid,creg.rid)) + | TLocal { v_name = "__hkeys__" }, [e2] + | TLocal { v_name = "__foreach__" }, [e2] + | TLocal { v_name = "__keys__" }, [e2] -> let racc = alloc_reg ctx (KType (type_path ctx ([],"Array"))) in let rcounter = alloc_reg ctx KInt in let rtmp = alloc_reg ctx KDynamic in @@ -1317,14 +1400,15 @@ and gen_call ctx retval e el r = write ctx (HReg racc.rid); write ctx (HReg rtmp.rid); write ctx (HReg rcounter.rid); - if e.eexpr = TLocal "__foreach__" then + (match e.eexpr with + | TLocal { v_name = "__foreach__" } -> write ctx HForEach - else + | TLocal { v_name = "__hkeys__" } -> write ctx HForIn; - if e.eexpr = TLocal "__hkeys__" then begin write ctx (HSmallInt 1); write ctx (HCallProperty (as3 "substr",1)); - end; + | _ -> + write ctx HForIn); write ctx (HCallPropVoid (as3 "push",1)); start(); write ctx (HNext (rtmp.rid,rcounter.rid)); @@ -1333,37 +1417,35 @@ and gen_call ctx retval e el r = free_reg ctx rtmp; free_reg ctx rcounter; free_reg ctx racc; - | TLocal "__new__" , e :: el -> + | TLocal { v_name = "__new__" }, e :: el -> gen_expr ctx true e; List.iter (gen_expr ctx true) el; write ctx (HConstruct (List.length el)) - | TLocal "__delete__" , [o;f] -> + | TLocal { v_name = "__delete__" }, [o;f] -> gen_expr ctx true o; gen_expr ctx true f; write ctx (HDeleteProp dynamic_prop); - | TLocal "__unprotect__" , [e] -> + | TLocal { v_name = "__unprotect__" }, [e] -> write ctx (HGetLex (type_path ctx (["flash"],"Boot"))); gen_expr ctx true e; write ctx (HCallProperty (ident "__unprotect__",1)); - | TLocal "__typeof__", [e] -> + | TLocal { v_name = "__typeof__" }, [e] -> gen_expr ctx true e; write ctx HTypeof - | TLocal "__in__", [e; f] -> + | TLocal { v_name = "__in__" }, [e; f] -> gen_expr ctx true e; gen_expr ctx true f; write ctx (HOp A3OIn) - | TLocal "__resources__", [] -> + | TLocal { v_name = "__resources__" }, [] -> let count = ref 0 in Hashtbl.iter (fun name data -> incr count; write ctx (HString "name"); write ctx (HString name); - write ctx (HString "data"); - write ctx (HString (Codegen.bytes_serialize data)); - write ctx (HObject 2); + write ctx (HObject 1); ) ctx.com.resources; write ctx (HArray !count) - | TLocal "__vmem_set__", [{ eexpr = TConst (TInt code) };e1;e2] -> + | TLocal { v_name = "__vmem_set__" }, [{ eexpr = TConst (TInt code) };e1;e2] -> gen_expr ctx true e2; gen_expr ctx true e1; write ctx (HOp (match code with @@ -1374,7 +1456,7 @@ and gen_call ctx retval e el r = | 4l -> A3OMemSetDouble | _ -> assert false )) - | TLocal "__vmem_get__", [{ eexpr = TConst (TInt code) };e] -> + | TLocal { v_name = "__vmem_get__" }, [{ eexpr = TConst (TInt code) };e] -> gen_expr ctx true e; write ctx (HOp (match code with | 0l -> A3OMemGet8 @@ -1384,7 +1466,7 @@ and gen_call ctx retval e el r = | 4l -> A3OMemGetDouble | _ -> assert false )) - | TLocal "__vmem_sign__", [{ eexpr = TConst (TInt code) };e] -> + | TLocal { v_name = "__vmem_sign__" }, [{ eexpr = TConst (TInt code) };e] -> gen_expr ctx true e; write ctx (HOp (match code with | 0l -> A3OSign1 @@ -1392,12 +1474,12 @@ and gen_call ctx retval e el r = | 2l -> A3OSign16 | _ -> assert false )) - | TLocal "__vector__", [ep] -> + | TLocal { v_name = "__vector__" }, [ep] -> gen_type ctx (type_id ctx r); write ctx HGetGlobalScope; gen_expr ctx true ep; write ctx (HCallStack 1) - | TArray ({ eexpr = TLocal "__global__" },{ eexpr = TConst (TString s) }), _ -> + | TArray ({ eexpr = TLocal { v_name = "__global__" } },{ eexpr = TConst (TString s) }), _ -> (match gen_access ctx e Read with | VGlobal id -> write ctx (HFindPropStrict id); @@ -1409,15 +1491,13 @@ and gen_call ctx retval e el r = List.iter (gen_expr ctx true) el; write ctx (HConstructSuper (List.length el)); | TField ({ eexpr = TConst TSuper },f) , _ -> - use_var ctx f e.epos; - let id = ident f in + let id = ident (field_name f) in write ctx (HFindPropStrict id); List.iter (gen_expr ctx true) el; write ctx (HCallSuper (id,List.length el)); coerce ctx (classify ctx r); | TField ({ eexpr = TConst TThis },f) , _ when not ctx.in_static -> - use_var ctx f e.epos; - let id = ident f in + let id = ident (field_name f) in write ctx (HFindProp id); List.iter (gen_expr ctx true) el; if retval then begin @@ -1429,19 +1509,14 @@ and gen_call ctx retval e el r = let old = ctx.for_call in ctx.for_call <- true; gen_expr ctx true e1; + let id , _, _ = property ctx (field_name f) e1.etype in ctx.for_call <- old; List.iter (gen_expr ctx true) el; - let id , _, _ = property ctx f e1.etype in if retval then begin write ctx (HCallProperty (id,List.length el)); coerce ctx (classify ctx r); end else write ctx (HCallPropVoid (id,List.length el)) - | TEnumField (e,f) , _ -> - let id = type_path ctx e.e_path in - write ctx (HGetLex id); - List.iter (gen_expr ctx true) el; - write ctx (HCallProperty (ident f,List.length el)); | _ -> gen_expr ctx true e; write ctx HGetGlobalScope; @@ -1464,7 +1539,7 @@ and gen_unop ctx retval op flag e = | Increment | Decrement -> let incr = (op = Increment) in - let r = (match e.eexpr with TLocal n -> get_local_register ctx n | _ -> None) in + let r = (match e.eexpr with TLocal v -> get_local_register ctx v | _ -> None) in match r with | Some r when r.rtype = KInt -> if not r.rinit then r.rcond <- true; @@ -1499,7 +1574,7 @@ and check_binop ctx e1 e2 = | _ -> false) in if invalid then error "Comparison of Int and UInt might lead to unexpected results" (punion e1.epos e2.epos); -and gen_binop ctx retval op e1 e2 t = +and gen_binop ctx retval op e1 e2 t p = let write_op op = let iop = (match op with | OpAdd -> Some A3OIAdd @@ -1541,6 +1616,14 @@ and gen_binop ctx retval op e1 e2 t = gen_expr ctx true e2; write ctx (HOp o) in + let gen_eq() = + match is_special_compare e1 e2 with + | None -> + gen_op A3OEq + | Some c -> + let f = FStatic (c,try PMap.find "compare" c.cl_statics with Not_found -> assert false) in + gen_expr ctx true (mk (TCall (mk (TField (mk (TTypeExpr (TClassDecl c)) t_dynamic p,f)) t_dynamic p,[e1;e2])) ctx.com.basic.tbool p); + in match op with | OpAssign -> let acc = gen_access ctx e1 Write in @@ -1575,9 +1658,9 @@ and gen_binop ctx retval op e1 e2 t = gen_expr ctx true e2; write_op op | OpEq -> - gen_op A3OEq + gen_eq() | OpNotEq -> - gen_op A3OEq; + gen_eq(); write ctx (HOp A3ONot) | OpGt -> gen_op A3OGt @@ -1587,7 +1670,7 @@ and gen_binop ctx retval op e1 e2 t = gen_op A3OLt | OpLte -> gen_op A3OLte - | OpInterval -> + | OpInterval | OpArrow -> assert false and gen_expr ctx retval e = @@ -1603,7 +1686,7 @@ and generate_function ctx fdata stat = let f = begin_fun ctx fdata.tf_args fdata.tf_type [fdata.tf_expr] stat fdata.tf_expr.epos in gen_expr ctx false fdata.tf_expr; (match follow fdata.tf_type with - | TEnum ({ e_path = [],"Void" },[]) -> + | TEnum ({ e_path = [],"Void" },[]) | TAbstract ({ a_path = [],"Void" },[]) -> debug_infos ctx ~is_min:false fdata.tf_expr.epos; write ctx HRetVoid | _ -> @@ -1642,8 +1725,8 @@ and jump_expr_gen ctx e jif jfun = jfun (if jif then t else f) in (match op with - | OpEq -> j J3Eq J3Neq - | OpNotEq -> j J3Neq J3Eq + | OpEq when is_special_compare e1 e2 = None -> j J3Eq J3Neq + | OpNotEq when is_special_compare e1 e2 = None -> j J3Neq J3Eq | OpGt -> j J3Gt J3NotGt | OpGte -> j J3Gte J3NotGte | OpLt -> j J3Lt J3NotLt @@ -1658,24 +1741,32 @@ and jump_expr_gen ctx e jif jfun = and jump_expr ctx e jif = jump_expr_gen ctx e jif (jump ctx) -let generate_method ctx fdata stat = - generate_function ctx fdata stat +let do_debug ctx meta = + let old = ctx.debug in + ctx.debug <- (old || Meta.has Meta.Debug meta) && not (Meta.has Meta.NoDebug meta); + (fun() -> ctx.debug <- old) + +let generate_method ctx fdata stat fmeta = + let old = do_debug ctx fmeta in + let m = generate_function ctx fdata stat in + old(); + m let generate_construct ctx fdata c = (* make all args optional to allow no-param constructor *) - let cargs = List.map (fun (a,c,t) -> + let cargs = if not ctx.need_ctor_skip then fdata.tf_args else List.map (fun (v,c) -> let c = (match c with Some _ -> c | None -> - Some (match classify ctx t with + Some (match classify ctx v.v_type with | KInt | KUInt -> TInt 0l | KFloat -> TFloat "0" | KBool -> TBool false - | KType _ | KDynamic | KNone -> TNull) + | KType _ | KDynamic | KNone -> TNull) ) in - a,c,t + v,c ) fdata.tf_args in let f = begin_fun ctx cargs fdata.tf_type [ethis;fdata.tf_expr] false fdata.tf_expr.epos in (* if skip_constructor, then returns immediatly *) - (match c.cl_kind with + if ctx.need_ctor_skip then (match c.cl_kind with | KGenericInstance _ -> () | _ when not (Codegen.constructor_side_effects fdata.tf_expr) -> () | _ -> @@ -1694,7 +1785,7 @@ let generate_construct ctx fdata c = write ctx (HGetProp id); let j = jump ctx J3True in write ctx (HFindProp id); - write ctx (HFunction (generate_method ctx fdata false)); + write ctx (HFunction (generate_method ctx fdata false [])); write ctx (HInitProp id); j(); | _ -> () @@ -1704,13 +1795,13 @@ let generate_construct ctx fdata c = write ctx HRetVoid; f() , List.length fdata.tf_args -let rec is_const e = +let rec is_const e = match e.eexpr with | TConst _ -> true | TArrayDecl el | TBlock el -> List.for_all is_const el | TObjectDecl fl -> List.for_all (fun (_,e) -> is_const e) fl | TParenthesis e -> is_const e - | TFunction _ -> true + | TFunction _ -> true | _ -> false let generate_class_statics ctx c const = @@ -1728,8 +1819,7 @@ let generate_class_statics ctx c const = let need_init ctx c = not ctx.swc && not c.cl_extern && List.exists (fun f -> match f.cf_expr with Some e -> not (is_const e) | _ -> false) c.cl_ordered_statics -let generate_inits ctx = - let finit = begin_fun ctx [] ctx.com.basic.tvoid [] true null_pos in +let generate_extern_inits ctx = List.iter (fun t -> match t with | TClassDecl c when c.cl_extern -> @@ -1737,7 +1827,11 @@ let generate_inits ctx = | None -> () | Some e -> gen_expr ctx false e); | _ -> () - ) ctx.com.types; + ) ctx.com.types + +let generate_inits ctx = + let finit = begin_fun ctx [] ctx.com.basic.tvoid [] true null_pos in + if not ctx.swc then generate_extern_inits ctx; List.iter (fun t -> match t with | TClassDecl c when need_init ctx c -> @@ -1775,12 +1869,13 @@ let generate_class_init ctx c hc = match f.cf_expr, f.cf_kind with | Some { eexpr = TFunction fdata }, Method MethDynamic -> write ctx HDup; - write ctx (HFunction (generate_method ctx fdata true)); + write ctx (HFunction (generate_method ctx fdata true f.cf_meta)); write ctx (HInitProp (ident f.cf_name)); | _ -> () ) c.cl_ordered_statics; if not c.cl_interface then write ctx HPopScope; write ctx (HInitProp (type_path ctx c.cl_path)); + if ctx.swc && c.cl_path = ctx.boot then generate_extern_inits ctx; (match c.cl_init with | None -> () | Some e -> @@ -1836,11 +1931,11 @@ let generate_enum_init ctx e hc meta = let extract_meta meta = let rec loop = function | [] -> [] - | (":meta",[ECall ((EConst (Ident n | Type n),_),args),_],_) :: l -> + | (Meta.Meta,[ECall ((EConst (Ident n),_),args),_],_) :: l -> let mk_arg (a,p) = match a with | EConst (String s) -> (None, s) - | EBinop (OpAssign,(EConst (Ident n | Type n),_),(EConst (String s),_)) -> (Some n, s) + | EBinop (OpAssign,(EConst (Ident n),_),(EConst (String s),_)) -> (Some n, s) | _ -> error "Invalid meta definition" p in { hlmeta_name = n; hlmeta_data = Array.of_list (List.map mk_arg args) } :: loop l @@ -1851,6 +1946,16 @@ let extract_meta meta = | l -> Some (Array.of_list l) let generate_field_kind ctx f c stat = + let method_kind() = + let rec loop = function + | [] -> f.cf_name, MK3Normal + | (Meta.Getter,[EConst (Ident f),_],_) :: _ -> f, MK3Getter + | (Meta.Setter,[EConst (Ident f),_],_) :: _ -> f, MK3Setter + | _ :: l -> loop l + in + loop f.cf_meta + in + if is_extern_field f then None else match f.cf_expr with | Some { eexpr = TFunction fdata } -> let rec loop c name = @@ -1860,6 +1965,8 @@ let generate_field_kind ctx f c stat = PMap.exists name c.cl_fields || loop c name in (match f.cf_kind with + | Method MethDynamic when List.memq f c.cl_overrides -> + None | Var _ | Method MethDynamic -> Some (HFVar { hlv_type = Some (type_path ctx ([],"Function")); @@ -1867,16 +1974,11 @@ let generate_field_kind ctx f c stat = hlv_const = false; }) | _ -> - let rec lookup_kind = function - | [] -> f.cf_name, MK3Normal - | (":getter",[EConst (Ident f | Type f),_],_) :: _ -> f, MK3Getter - | (":setter",[EConst (Ident f | Type f),_],_) :: _ -> f, MK3Setter - | _ :: l -> lookup_kind l - in - let name, kind = lookup_kind f.cf_meta in + let name, kind = method_kind() in + let m = generate_method ctx fdata stat f.cf_meta in Some (HFMethod { - hlm_type = generate_method ctx fdata stat; - hlm_final = stat; + hlm_type = m; + hlm_final = stat || (Meta.has Meta.Final f.cf_meta); hlm_override = not stat && loop c name; hlm_kind = kind; }) @@ -1892,15 +1994,13 @@ let generate_field_kind ctx f c stat = ) args; let dparams = (match !dparams with None -> None | Some l -> Some (List.rev l)) in Some (HFMethod { - hlm_type = end_fun ctx (List.map (fun (a,opt,t) -> a, (if opt then Some TNull else None), t) args) dparams tret; + hlm_type = end_fun ctx (List.map (fun (a,opt,t) -> alloc_var a t, (if opt then Some TNull else None)) args) dparams tret; hlm_final = false; hlm_override = false; - hlm_kind = MK3Normal; + hlm_kind = snd (method_kind()); }) | _ -> None) - | _ when (match f.cf_kind with Var { v_read = AccResolve } -> true | _ -> false) -> - None | _ -> Some (HFVar { hlv_type = if Codegen.is_volatile f.cf_type then Some (type_path ctx ([],"Array")) else type_opt ctx f.cf_type; @@ -1910,6 +2010,7 @@ let generate_field_kind ctx f c stat = let generate_class ctx c = let name = type_path ctx c.cl_path in + ctx.cur_class <- c; let cid , cnargs = (match c.cl_constructor with | None -> if c.cl_interface then @@ -1926,51 +2027,83 @@ let generate_class ctx c = } c | Some f -> match f.cf_expr with - | Some { eexpr = TFunction fdata } -> generate_construct ctx fdata c + | Some { eexpr = TFunction fdata } -> + let old = do_debug ctx f.cf_meta in + let m = generate_construct ctx fdata c in + old(); + m | _ -> assert false ) in let has_protected = ref None in + let make_name f stat = + let rec find_meta c = + try + let f = PMap.find f.cf_name (if stat then c.cl_statics else c.cl_fields) in + if List.memq f c.cl_overrides then raise Not_found; + f.cf_meta + with Not_found -> + match c.cl_super with + | None -> [] + | Some _ when stat -> [] + | Some (c,_) -> find_meta c + in + let protect() = + let p = (match c.cl_path with [], n -> n | p, n -> String.concat "." p ^ ":" ^ n) in + has_protected := Some p; + HMName (f.cf_name,HNProtected p) + in + let rec loop_meta = function + | [] -> + if not f.cf_public && ctx.swf_protected then + protect() + else + ident f.cf_name + | x :: l -> + match x with + | ((Meta.Getter | Meta.Setter),[EConst (Ident f),_],_) -> ident f + | (Meta.Ns,[EConst (String ns),_],_) -> HMName (f.cf_name,HNNamespace ns) + | (Meta.Protected,[],_) -> protect() + | _ -> loop_meta l + in + if c.cl_interface then + HMName (reserved f.cf_name, HNNamespace (match c.cl_path with [],n -> n | l,n -> String.concat "." l ^ ":" ^ n)) + else + loop_meta (find_meta c) + in + let generate_prop f acc alloc_slot = + match f.cf_kind with + | Method _ -> acc + | Var v -> + (* let p = f.cf_pos in *) + (* let ethis = mk (TConst TThis) (TInst (c,[])) p in *) + acc + in let fields = PMap.fold (fun f acc -> + let acc = generate_prop f acc (fun() -> 0) in match generate_field_kind ctx f c false with | None -> acc | Some k -> - let rec find_meta c = - try - let f = PMap.find f.cf_name c.cl_fields in - if List.mem f.cf_name c.cl_overrides then raise Not_found; - f.cf_meta - with Not_found -> - match c.cl_super with - | None -> [] - | Some (c,_) -> find_meta c - in - let rec loop_meta = function - | [] -> ident f.cf_name - | x :: l -> - match x with - | ((":getter" | ":setter"),[EConst (Ident f | Type f),_],_) -> ident f - | (":ns",[EConst (String ns),_],_) -> HMName (f.cf_name,HNNamespace ns) - | (":protected",[],_) -> - let p = (match c.cl_path with [], n -> n | p, n -> String.concat "." p ^ ":" ^ n) in - has_protected := Some p; - HMName (f.cf_name,HNProtected p) - | _ -> loop_meta l - in - let name = if c.cl_interface then - HMName (f.cf_name, HNNamespace (match c.cl_path with [],n -> n | l,n -> String.concat "." l ^ ":" ^ n)) - else - loop_meta (find_meta c) - in { - hlf_name = name; + hlf_name = make_name f false; hlf_slot = 0; hlf_kind = k; hlf_metas = extract_meta f.cf_meta; } :: acc ) c.cl_fields [] in - let fields = if c.cl_path <> ctx.boot then fields else + let fields = if c.cl_path <> ctx.boot then fields else begin { - hlf_name = ident "init"; + hlf_name = make_name { + cf_name = "init"; + cf_public = ctx.swc && ctx.swf_protected; + cf_meta = []; + cf_doc = None; + cf_pos = c.cl_pos; + cf_type = TFun ([],t_dynamic); + cf_params = []; + cf_expr = None; + cf_kind = Method MethNormal; + cf_overloads = []; + } false; hlf_slot = 0; hlf_kind = (HFMethod { hlm_type = generate_inits ctx; @@ -1980,21 +2113,24 @@ let generate_class ctx c = }); hlf_metas = None; } :: fields - in + end in let st_field_count = ref 0 in let st_meth_count = ref 0 in - let statics = List.map (fun f -> - let k = (match generate_field_kind ctx f c true with None -> assert false | Some k -> k) in - let count = (match k with HFMethod _ -> st_meth_count | HFVar _ -> st_field_count | _ -> assert false) in - incr count; - { - hlf_name = ident f.cf_name; - hlf_slot = !count; - hlf_kind = k; - hlf_metas = extract_meta f.cf_meta; - } - ) c.cl_ordered_statics in - let statics = if not (need_init ctx c) then statics else + let statics = List.rev (List.fold_left (fun acc f -> + let acc = generate_prop f acc (fun() -> incr st_meth_count; !st_meth_count) in + match generate_field_kind ctx f c true with + | None -> acc + | Some k -> + let count = (match k with HFMethod _ -> st_meth_count | HFVar _ -> st_field_count | _ -> assert false) in + incr count; + { + hlf_name = make_name f true; + hlf_slot = !count; + hlf_kind = k; + hlf_metas = extract_meta f.cf_meta; + } :: acc + ) [] c.cl_ordered_statics) in + let statics = if not (need_init ctx c) then statics else { hlf_name = ident "init__"; hlf_slot = (incr st_field_count; !st_field_count); @@ -2013,7 +2149,7 @@ let generate_class ctx c = hlc_name = name; hlc_super = (if c.cl_interface then None else Some (type_path ctx (match c.cl_super with None -> [],"Object" | Some (c,_) -> c.cl_path))); hlc_sealed = not (is_dynamic c); - hlc_final = false; + hlc_final = Meta.has Meta.Final c.cl_meta; hlc_interface = c.cl_interface; hlc_namespace = (match !has_protected with None -> None | Some p -> Some (HNProtected p)); hlc_implements = Array.of_list (List.map (fun (c,_) -> @@ -2030,7 +2166,7 @@ let generate_class ctx c = let generate_enum ctx e meta = let name_id = type_path ctx e.e_path in let api = ctx.com.basic in - let f = begin_fun ctx [("tag",None,api.tstring);("index",None,api.tint);("params",None,mk_mono())] api.tvoid [ethis] false e.e_pos in + let f = begin_fun ctx [alloc_var "tag" api.tstring, None;alloc_var "index" api.tint, None;alloc_var "params" (mk_mono()), None] api.tvoid [ethis] false e.e_pos in let tag_id = ident "tag" in let index_id = ident "index" in let params_id = ident "params" in @@ -2059,7 +2195,7 @@ let generate_enum ctx e meta = hlf_slot = !st_count; hlf_kind = (match f.ef_type with | TFun (args,_) -> - let fdata = begin_fun ctx (List.map (fun (a,opt,t) -> a, (if opt then Some TNull else None), t) args) (TEnum (e,[])) [] true f.ef_pos in + let fdata = begin_fun ctx (List.map (fun (a,opt,t) -> alloc_var a t, (if opt then Some TNull else None)) args) (TEnum (e,[])) [] true f.ef_pos in write ctx (HFindPropStrict name_id); write ctx (HString f.ef_name); write ctx (HInt f.ef_index); @@ -2133,25 +2269,27 @@ let generate_enum ctx e meta = } :: constrs); } -let generate_type ctx t = +let rec generate_type ctx t = match t with | TClassDecl c -> if c.cl_path = (["flash";"_Boot"],"RealBoot") then c.cl_path <- ctx.boot; - if c.cl_extern && c.cl_path <> ([],"Dynamic") then + if c.cl_extern && (c.cl_path <> ([],"Dynamic") || Meta.has Meta.RealPath c.cl_meta) then None else + let debug = do_debug ctx c.cl_meta in let hlc = generate_class ctx c in let init = begin_fun ctx [] ctx.com.basic.tvoid [ethis] false c.cl_pos in generate_class_init ctx c hlc; write ctx HRetVoid; + debug(); Some (init(), { hlf_name = type_path ctx c.cl_path; hlf_slot = 0; hlf_kind = HFClass hlc; - hlf_metas = None; + hlf_metas = extract_meta c.cl_meta; }) | TEnumDecl e -> - if e.e_extern && e.e_path <> ([],"Void") then + if e.e_extern then None else let meta = Codegen.build_metadata ctx.com t in @@ -2163,37 +2301,70 @@ let generate_type ctx t = hlf_name = type_path ctx e.e_path; hlf_slot = 0; hlf_kind = HFClass hlc; - hlf_metas = None; + hlf_metas = extract_meta e.e_meta; }) - | TTypeDecl _ -> + | TAbstractDecl ({ a_path = [],"Dynamic" } as a) -> + generate_type ctx (TClassDecl (mk_class a.a_module a.a_path a.a_pos)) + | TTypeDecl _ | TAbstractDecl _ -> None +let resource_path name = + (["_res"],"_" ^ String.concat "_" (ExtString.String.nsplit name ".")) + +let generate_resource ctx name = + let c = mk_class null_module (resource_path name) null_pos in + c.cl_super <- Some (mk_class null_module (["flash";"utils"],"ByteArray") null_pos,[]); + let t = TClassDecl c in + match generate_type ctx t with + | Some (m,f) -> (t,m,f) + | None -> assert false + let generate com boot_name = let ctx = { com = com; + need_ctor_skip = Common.has_feature com "Type.createEmptyInstance"; + debug = com.Common.debug; + cur_class = null_class; boot = ([],boot_name); - debugger = Common.defined com "fdb"; - swc = Common.defined com "swc"; + debugger = Common.defined com Define.Fdb; + swc = Common.defined com Define.Swc; + swf_protected = Common.defined com Define.SwfProtected; code = DynArray.create(); locals = PMap.empty; infos = default_infos(); trys = []; breaks = []; continues = []; - curblock = []; block_vars = []; - used_vars = PMap.empty; in_static = false; last_line = -1; last_file = ""; try_scope_reg = None; for_call = false; } in + let types = if ctx.swc && com.main_class = None then + (* + make sure that both Boot and RealBoot are the first two classes in the SWC + this way initializing RealBoot will also run externs __init__ blocks before + another class static is defined + *) + let hd = ref [] in + let types = List.fold_left (fun acc t -> + match t_path t with + | ["flash";"_Boot"],"RealBoot" -> hd := !hd @ [t]; acc + | ["flash"], "Boot" -> hd := t :: !hd; acc + | _ -> t :: acc + ) [] com.types in + !hd @ List.rev types + else + com.types + in + let res = Hashtbl.fold (fun name _ acc -> generate_resource ctx name :: acc) com.resources [] in let classes = List.fold_left (fun acc t -> match generate_type ctx t with | None -> acc | Some (m,f) -> (t,m,f) :: acc - ) [] com.types in + ) res types in List.rev classes ;; diff --git a/haxe/genxml.ml b/genxml.ml similarity index 67% rename from haxe/genxml.ml rename to genxml.ml index 11ed0402d6f0b04f0df3960008cc41730325e323..665052f2c18c2d4bb556aae791390312ab6ab663 100644 --- a/haxe/genxml.ml +++ b/genxml.ml @@ -1,21 +1,25 @@ (* - * Haxe Compiler - * Copyright (c)2005 Nicolas Cannasse + * Copyright (C)2005-2013 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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 @@ -37,9 +41,14 @@ let pmap f m = let gen_path (p,n) priv = ("path",String.concat "." (p @ [n])) +let gen_string s = + if String.contains s '<' || String.contains s '>' || String.contains s '&' then cdata s else pcdata s + let gen_doc s = - let f = if String.contains s '<' || String.contains s '>' || String.contains s '&' then cdata else pcdata in - node "haxe_doc" [] [f s] + (* remove trailing space and convert newlines *) + let s = ExtString.String.strip s in + let s = String.concat "\n" (ExtString.String.nsplit (String.concat "\n" (ExtString.String.nsplit s "\r\n")) "\r") in + node "haxe_doc" [] [gen_string s] let gen_doc_opt d = match d with @@ -49,13 +58,17 @@ let gen_doc_opt d = let gen_arg_name (name,opt,_) = (if opt then "?" else "") ^ name -let cpath c = +let real_path path meta = let rec loop = function - | [] -> c.cl_path - | (":real",[(Ast.EConst (Ast.String s),_)],_) :: _ -> parse_path s + | [] -> path + | (Meta.RealPath,[(Ast.EConst (Ast.String s),_)],_) :: _ -> parse_path s | _ :: l -> loop l in - loop c.cl_meta + loop meta + +let tpath t = + let i = t_infos t in + real_path i.mt_path i.mt_meta let rec follow_param t = match t with @@ -68,24 +81,47 @@ let rec follow_param t = | _ -> t +let rec sexpr (e,_) = + match e with + | EConst c -> s_constant c + | EParenthesis e -> "(" ^ (sexpr e) ^ ")" + | EArrayDecl el -> "[" ^ (String.concat "," (List.map sexpr el)) ^ "]" + | EObjectDecl fl -> "{" ^ (String.concat "," (List.map (fun (n,e) -> n ^ ":" ^ (sexpr e)) fl)) ^ "}" + | _ -> "'???'" + +let gen_meta meta = + let meta = List.filter (fun (m,_,_) -> match m with Meta.Used | Meta.MaybeUsed | Meta.RealPath -> false | _ -> true) meta in + match meta with + | [] -> [] + | _ -> + let nodes = List.map (fun (m,el,_) -> + node "m" ["n",fst (MetaInfo.to_string m)] (List.map (fun e -> node "e" [] [gen_string (sexpr e)]) el) + ) meta in + [node "meta" [] nodes] + let rec gen_type t = match t with | TMono m -> (match !m with None -> tag "unknown" | Some t -> gen_type t) - | TEnum (e,params) -> node "e" [gen_path e.e_path e.e_private] (List.map gen_type params) - | TInst (c,params) -> node "c" [gen_path (cpath c) c.cl_private] (List.map gen_type params) - | TType (t,params) -> node "t" [gen_path t.t_path t.t_private] (List.map gen_type params) + | TEnum (e,params) -> gen_type_decl "e" (TEnumDecl e) params + | TInst (c,params) -> gen_type_decl "c" (TClassDecl c) params + | TAbstract (a,params) -> gen_type_decl "x" (TAbstractDecl a) params + | TType (t,params) -> gen_type_decl "t" (TTypeDecl t) params | TFun (args,r) -> node "f" ["a",String.concat ":" (List.map gen_arg_name args)] (List.map gen_type (List.map (fun (_,opt,t) -> if opt then follow_param t else t) args @ [r])) | TAnon a -> node "a" [] (pmap (fun f -> gen_field [] { f with cf_public = false }) a.a_fields) | TDynamic t2 -> node "d" [] (if t == t2 then [] else [gen_type t2]) | TLazy f -> gen_type (!f()) +and gen_type_decl n t pl = + let i = t_infos t in + node n [gen_path (tpath t) i.mt_private] (List.map gen_type pl) + and gen_field att f = let add_get_set acc name att = match acc with | AccNormal | AccResolve | AccRequire _ -> att | AccNo | AccNever -> (name, "null") :: att - | AccCall m -> (name,m) :: att - | AccInline -> (name,"inline") :: att + | AccCall -> (name,"accessor") :: att + | AccInline -> (name,"inline") :: att in let att = (match f.cf_expr with None -> att | Some e -> ("line",string_of_int (Lexer.get_error_line e.epos)) :: att) in let att = (match f.cf_kind with @@ -97,7 +133,7 @@ and gen_field att f = | MethInline -> ("get", "inline") :: ("set","null") :: att) ) in let att = (match f.cf_params with [] -> att | l -> ("params", String.concat ":" (List.map (fun (n,_) -> n) l)) :: att) in - node f.cf_name (if f.cf_public then ("public","1") :: att else att) (gen_type f.cf_type :: gen_doc_opt f.cf_doc) + node f.cf_name (if f.cf_public then ("public","1") :: att else att) (gen_type f.cf_type :: gen_meta f.cf_meta @ gen_doc_opt f.cf_doc) let gen_constr e = let doc = gen_doc_opt e.ef_doc in @@ -112,12 +148,12 @@ let gen_constr e = let gen_type_params ipos priv path params pos m = let mpriv = (if priv then [("private","1")] else []) in - let mpath = (if m.mpath <> path then [("module",snd (gen_path m.mpath false))] else []) in + let mpath = (if m.m_path <> path then [("module",snd (gen_path m.m_path false))] else []) in let file = (if ipos && pos <> null_pos then [("file",pos.pfile)] else []) in gen_path path priv :: ("params", String.concat ":" (List.map fst params)) :: (file @ mpriv @ mpath) let gen_class_path name (c,pl) = - node name [("path",s_type_path (cpath c))] (List.map gen_type pl) + node name [("path",s_type_path (tpath (TClassDecl c)))] (List.map gen_type pl) let rec exists f c = PMap.exists f.cf_name c.cl_fields || @@ -126,37 +162,45 @@ let rec exists f c = | Some (csup,_) -> exists f csup let gen_type_decl com pos t = - let path = t_path t in - let m = (try List.find (fun m -> List.exists (fun t2 -> t_path t2 = path) m.mtypes) com.modules with Not_found -> { mpath = t_path t; mtypes = [t] }) in + let m = (t_infos t).mt_module in match t with | TClassDecl c -> - let stats = List.map (gen_field ["static","1"]) c.cl_ordered_statics in + let stats = List.map (gen_field ["static","1"]) (List.filter (fun cf -> cf.cf_name <> "__meta__") c.cl_ordered_statics) in let fields = (match c.cl_super with | None -> List.map (fun f -> f,[]) c.cl_ordered_fields | Some (csup,_) -> List.map (fun f -> if exists f csup then (f,["override","1"]) else (f,[])) c.cl_ordered_fields ) in let fields = List.map (fun (f,att) -> gen_field att f) fields in let constr = (match c.cl_constructor with None -> [] | Some f -> [gen_field [] f]) in - let impl = List.map (gen_class_path "implements") c.cl_implements in + let impl = List.map (gen_class_path (if c.cl_interface then "extends" else "implements")) c.cl_implements in let tree = (match c.cl_super with | None -> impl | Some x -> gen_class_path "extends" x :: impl ) in let doc = gen_doc_opt c.cl_doc in + let meta = gen_meta c.cl_meta in let ext = (if c.cl_extern then [("extern","1")] else []) in let interf = (if c.cl_interface then [("interface","1")] else []) in let dynamic = (match c.cl_dynamic with | None -> [] | Some t -> [node "haxe_dynamic" [] [gen_type t]] ) in - node "class" (gen_type_params pos c.cl_private (cpath c) c.cl_types c.cl_pos m @ ext @ interf) (tree @ stats @ fields @ constr @ doc @ dynamic) + node "class" (gen_type_params pos c.cl_private (tpath t) c.cl_types c.cl_pos m @ ext @ interf) (tree @ stats @ fields @ constr @ doc @ meta @ dynamic) | TEnumDecl e -> let doc = gen_doc_opt e.e_doc in - node "enum" (gen_type_params pos e.e_private e.e_path e.e_types e.e_pos m) (pmap gen_constr e.e_constrs @ doc) + let meta = gen_meta e.e_meta in + node "enum" (gen_type_params pos e.e_private (tpath t) e.e_types e.e_pos m) (pmap gen_constr e.e_constrs @ doc @ meta) | TTypeDecl t -> let doc = gen_doc_opt t.t_doc in + let meta = gen_meta t.t_meta in let tt = gen_type t.t_type in - node "typedef" (gen_type_params pos t.t_private t.t_path t.t_types t.t_pos m) (tt :: doc) + node "typedef" (gen_type_params pos t.t_private t.t_path t.t_types t.t_pos m) (tt :: doc @ meta) + | TAbstractDecl a -> + let doc = gen_doc_opt a.a_doc in + let meta = gen_meta a.a_meta in + let sub = (match a.a_from with [] -> [] | l -> [node "from" [] (List.map (fun (t,_) -> gen_type t) l)]) in + let super = (match a.a_to with [] -> [] | l -> [node "to" [] (List.map (fun (t,_) -> gen_type t) l)]) in + node "abstract" (gen_type_params pos a.a_private (tpath t) a.a_types a.a_pos m) (sub @ super @ doc @ meta) let att_str att = String.concat "" (List.map (fun (a,v) -> Printf.sprintf " %s=\"%s\"" a v) att) @@ -183,7 +227,7 @@ let rec write_xml ch tabs x = let generate com file = let t = Common.timer "construct xml" in - let x = node "haxe" [] (List.map (gen_type_decl com true) com.types) in + let x = node "haxe" [] (List.map (gen_type_decl com true) (List.filter (fun t -> not (Meta.has Meta.NoDoc (t_infos t).mt_meta)) com.types)) in t(); let t = Common.timer "write xml" in let ch = IO.output_channel (open_out_bin file) in @@ -248,7 +292,7 @@ let generate_type com t = (match !r with | None -> "Unknown" | Some t -> stype t) - | TInst ({ cl_kind = KTypeParameter } as c,tl) -> + | TInst ({ cl_kind = KTypeParameter _ } as c,tl) -> path ([],snd c.cl_path) tl | TInst (c,tl) -> path c.cl_path tl @@ -256,6 +300,8 @@ let generate_type com t = path e.e_path tl | TType (t,tl) -> path t.t_path tl + | TAbstract (a,tl) -> + path a.a_path tl | TAnon a -> let fields = PMap.fold (fun f acc -> (f.cf_name ^ " : " ^ stype f.cf_type) :: acc) a.a_fields [] in "{" ^ String.concat ", " fields ^ "}" @@ -280,11 +326,6 @@ let generate_type com t = | _ -> stype t in - let sexpr (e,_) = - match e with - | EConst c -> s_constant c - | _ -> "'???'" - in let sparam (n,v,t) = match v with | None -> @@ -292,16 +333,16 @@ let generate_type com t = | Some (Ident "null") -> "?" ^ n ^ " : " ^ stype (notnull t) | Some v -> - n ^ " : " ^ stype t ^ " = " ^ (s_constant v) + n ^ " : " ^ stype t ^ " = " ^ (match s_constant v with "nan" -> "0./*NaN*/" | v -> v) in let print_meta ml = List.iter (fun (m,pl,_) -> match m with - | ":defparam" | ":core_api" -> () + | Meta.DefParam | Meta.CoreApi | Meta.Used | Meta.MaybeUsed -> () | _ -> match pl with - | [] -> p "@%s " m - | l -> p "@%s(%s) " m (String.concat "," (List.map sexpr pl)) + | [] -> p "@%s " (fst (MetaInfo.to_string m)) + | l -> p "@%s(%s) " (fst (MetaInfo.to_string m)) (String.concat "," (List.map sexpr pl)) ) ml in let access a = @@ -324,7 +365,7 @@ let generate_type com t = List.map (fun (a,o,t) -> let rec loop = function | [] -> Ident "null" - | (":defparam",[(EConst (String p),_);(EConst v,_)],_) :: _ when p = a -> + | (Meta.DefParam,[(EConst (String p),_);(EConst v,_)],_) :: _ when p = a -> (match v with | Float "1.#QNAN" -> Float "0./*NaN*/" | Float "4294967295." -> Int "0xFFFFFFFF" @@ -357,12 +398,13 @@ let generate_type com t = | None -> [] | Some (c,pl) -> [" extends " ^ stype (TInst (c,pl))] ) in - let ext = List.fold_left (fun acc (i,pl) -> (" implements " ^ stype (TInst (i,pl))) :: acc) ext c.cl_implements in + let ext = List.fold_left (fun acc (i,pl) -> ((if c.cl_interface then " extends " else " implements ") ^ stype (TInst (i,pl))) :: acc) ext c.cl_implements in let ext = (match c.cl_dynamic with | None -> ext | Some t -> (match c.cl_path with | ["flash";"errors"], _ -> ext + | _ when t == t_dynamic -> " implements Dynamic" :: ext | _ -> (" implements Dynamic<" ^ stype t ^ ">") :: ext) ) in let ext = (match c.cl_path with @@ -370,14 +412,14 @@ let generate_type com t = | ["flash";"utils"], "Dictionnary" -> [" implements ArrayAccess"] | ["flash";"xml"], "XML" -> [" implements Dynamic"] | ["flash";"xml"], "XMLList" -> [" implements ArrayAccess"] - | ["flash";"display"],"MovieClip" -> [" extends Sprite #if !flash_strict, implements Dynamic #end"] + | ["flash";"display"],"MovieClip" -> [" extends Sprite #if !flash_strict implements Dynamic #end"] | ["flash";"errors"], "Error" -> [" #if !flash_strict implements Dynamic #end"] | _ -> ext ) in - p "%s" (String.concat "," (List.rev ext)); + p "%s" (String.concat "" (List.rev ext)); p " {\n"; let sort l = - let a = Array.of_list (List.filter (fun f -> f.cf_public && not (List.mem f.cf_name c.cl_overrides)) l) in + let a = Array.of_list (List.filter (fun f -> f.cf_public && not (List.memq f c.cl_overrides)) l) in let name = function "new" -> "" | n -> n in Array.sort (fun f1 f2 -> match f1.cf_kind, f2.cf_kind with @@ -405,13 +447,16 @@ let generate_type com t = | TFun (args,_) -> p "(%s)" (String.concat ", " (List.map sparam (List.map (fun (a,o,t) -> a,(if o then Some (Ident "null") else None),t) args))) | _ -> ()); p ";\n"; - ) (sort e.e_names); + ) (if Meta.has Meta.FakeEnum e.e_meta then sort e.e_names else e.e_names); p "}\n" | TTypeDecl t -> print_meta t.t_meta; - p "extern typedef %s = " (stype (TType (t,List.map snd t.t_types))); + p "typedef %s = " (stype (TType (t,List.map snd t.t_types))); p "%s" (stype t.t_type); p "\n"; + | TAbstractDecl a -> + print_meta a.a_meta; + p "abstract %s {}" (stype (TAbstract (a,List.map snd a.a_types))); ); IO.close_out ch diff --git a/haxe.hxproj b/haxe.hxproj new file mode 100644 index 0000000000000000000000000000000000000000..804af128ba59f95ab3362aa3b82962ce85477463 --- /dev/null +++ b/haxe.hxproj @@ -0,0 +1,143 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + make -j4 MSVC=1 FD_OUTPUT=1 -f Makefile.win kill haxe + + + + + + + + \ No newline at end of file diff --git a/haxe/Makefile b/haxe/Makefile deleted file mode 100644 index dcf9c1673e02370649a9fa3142e31a8d78506f6c..0000000000000000000000000000000000000000 --- a/haxe/Makefile +++ /dev/null @@ -1,50 +0,0 @@ -EXTLIB=../../mtcvs/extlib-dev -SWFLIB=../../mtcvs/swflib -EXTC=../../mtcvs/extc -NEKO=../neko -XML=../../mtcvs/xml-light -LIBS_SRC=$(EXTLIB)/*.ml* -n $(EXTLIB)/install.ml $(SWFLIB)/*.ml* $(EXTC)/extc.ml* -SRC=$(NEKO)/libs/include/ocaml/*.ml* *.ml* -LIBS=unix.cmxa str.cmxa $(XML)/xml-light.cmxa -FLAGS=-o haxe -pp camlp4o -P $(XML)/dtd.mli -lp "-cclib extc_stubs.o -cclib -lz" -LFLAGS= -EXPORT=../../../projects/motionTools/haxe - -ifeq ($(PPC),1) -LFLAGS=-ccopt '-arch ppc' -endif - -all: xml - ocamlopt $(LFLAGS) -c $(EXTC)/extc_stubs.c - ocamake -lp "$(LFLAGS)" $(FLAGS) $(LIBS_SRC) $(SRC) $(LIBS) - -xml: - (cd ${XML} && make clean xml-light.cmxa) - -mode_ppc: - sudo ln -sfh /usr/local/bin/ocamlopt.ppc /usr/local/bin/ocamlopt - sudo ln -sfh /usr/local/lib/ocaml_ppc /usr/local/lib/ocaml - -mode_intel: - sudo ln -sfh /usr/local/bin/ocamlopt.intel /usr/local/bin/ocamlopt - sudo ln -sfh /usr/local/lib/ocaml_intel /usr/local/lib/ocaml - -universal: - make PPC=1 clean mode_ppc all - mv haxe haxe.ppc - make clean mode_intel all - mv haxe haxe.intel - lipo -create -arch i386 haxe.intel -arch ppc haxe.ppc -output haxe - chmod +x haxe - -tools: - (cd std/tools/haxedoc && haxe haxedoc.hxml && cp haxedoc ../../..) - (cd std/tools/haxelib && haxe haxelib.hxml && cp haxelib ../../..) - -clean: - ocamake $(FLAGS) -clean $(LIBS_SRC) $(SRC) $(LIBS) - rm -rf extc_stubs.o - -export: - cp haxe*.exe $(EXPORT) - rsync -a --exclude .svn --exclude *.n --exclude std/mt --delete std $(EXPORT) diff --git a/haxe/codegen.ml b/haxe/codegen.ml deleted file mode 100644 index be10bfda72569a040f46d7f0a21be176eae00e96..0000000000000000000000000000000000000000 --- a/haxe/codegen.ml +++ /dev/null @@ -1,1177 +0,0 @@ -(* - * Haxe Compiler - * Copyright (c)2005-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 Ast -open Type -open Common -open Typecore - -(* -------------------------------------------------------------------------- *) -(* TOOLS *) - -let field e name t p = - mk (TField (e,name)) 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 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 | Type t -> error ("Invalid constant : " ^ t) p - | Regexp _ -> error "Invalid constant" p - -(* -------------------------------------------------------------------------- *) -(* 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 *) - if ctx.com.verbose then print_endline ("Building proxy for " ^ s_type_path path); - let decls = (try Typeload.parse_module ctx path p with 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 = (EBinop (OpAssign,(EConst (Ident "__cnx"),p),(EConst (Ident "c"),p)),p) }) }; - ] 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 (pl,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_args = fargs; - f_type = if async then None else ftype; - f_expr = (EBlock [expr],p); - } in - { cff_name = f.cff_name; cff_pos = p; cff_doc = None; cff_meta = []; cff_access = [APublic]; cff_kind = FFun (pl,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) decls p in - try - List.find (fun tdecl -> snd (t_path tdecl) = new_name) m.mtypes - 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 = [] -> c.cl_super <- Some (c2,[]); - | _ -> error "Remoting proxy must be a class without parameters" p - -(* -------------------------------------------------------------------------- *) -(* HAXE.RTTI.GENERIC *) - -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 (c,tl) -> - if c.cl_kind = KTypeParameter then recurse := true; - List.iter check_recursive tl; - | _ -> - () - in - let name = String.concat "_" (snd c.cl_path :: (List.map (fun t -> - check_recursive t; - let path = (match follow t with - | TInst (c,_) -> c.cl_path - | TEnum (e,_) -> e.e_path - | TMono _ -> error "Type parameter must be explicit when creating a haxe.rtti.Generic instance" p - | _ -> error "Type parameter must be a class or enum instance" p - ) in - match path with - | [] , name -> name - | l , name -> String.concat "_" l ^ "_" ^ name - ) tl)) in - if !recurse then - TInst (c,tl) (* build a normal instance *) - 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 local_types = m.mtypes @ ctx.local_types } in - let cg = mk_class (pack,name) c.cl_pos in - let mg = { - mpath = cg.cl_path; - mtypes = [TClassDecl cg]; - } in - Hashtbl.add ctx.g.modules mg.mpath mg; - 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 subst = loop c.cl_types tl in - let rec build_type t = - match t with - | TInst ({ cl_kind = KGeneric } as c2,tl2) -> - (* maybe loop, or generate cascading generics *) - let _, _, f = ctx.g.do_build_instance ctx (TClassDecl c2) p in - f (List.map build_type tl2) - | _ -> - try List.assq t subst with Not_found -> Type.map build_type t - in - let rec build_expr e = map_expr_type build_expr build_type e in - let build_field f = - let t = build_type f.cf_type in - { f with cf_type = t; cf_expr = (match f.cf_expr with None -> None | Some e -> Some (build_expr e)) } - 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 with None -> None | Some c -> Some (build_field c)); - cg.cl_implements <- List.map (fun (i,tl) -> - (match follow (build_type (TInst (i, List.map build_type 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; - 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 - 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 "check-xml-proxy" 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_doc = None; - cf_meta = no_meta; - cf_kind = Var { v_read = AccResolve; v_write = AccNo }; - cf_params = []; - cf_expr = None; - } 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 [] | _ -> []),[]) - ) in - let filter l = - let l = List.map (fun (n,ml) -> n, List.filter (fun (m,_,_) -> m.[0] <> ':') ml) l in - List.filter (fun (_,ml) -> ml <> []) l - in - let meta, fields, statics = filter meta, filter fields, filter statics in - let rec loop (e,p) = - match e with - | EConst c -> - type_constant com c p - | EParenthesis e -> - loop e - | EObjectDecl el -> - mk (TObjectDecl (List.map (fun (n,e) -> n, loop e) el)) (TAnon { a_fields = PMap.empty; a_status = ref Closed }) p - | EArrayDecl el -> - mk (TArrayDecl (List.map loop el)) (com.basic.tarray t_dynamic) p - | _ -> - error "Metadata should be constant" p - 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 loop 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) - -(* -------------------------------------------------------------------------- *) -(* API EVENTS *) - -let build_instance ctx mtype p = - match mtype with - | TClassDecl c -> - let ft = (fun pl -> - match c.cl_kind with - | KGeneric -> - let r = exc_protect (fun r -> - let t = mk_mono() in - r := (fun() -> t); - unify_raise ctx (build_generic ctx c p pl) t p; - t - ) in - delay ctx (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)) - -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 - | HImplements { tpackage = ["haxe";"rtti"]; tname = "Generic"; tparams = [] } -> - c.cl_kind <- KGeneric; - false - | HExtends { tpackage = ["haxe";"xml"]; tname = "Proxy"; tparams = [TPConst(String file);TPType t] } -> - extend_xml_proxy ctx c t file p; - true - | _ -> - true - -let rec has_rtti c = - List.exists (function (t,pl) -> - match t, pl with - | { cl_path = ["haxe";"rtti"],"Infos" },[] -> true - | _ -> false - ) c.cl_implements || (match c.cl_super with None -> false | Some (c,_) -> has_rtti c) - -let on_generate ctx t = - match t with - | TClassDecl c -> - List.iter (fun m -> - match m with - | ":native",[Ast.EConst (Ast.String name),p],mp -> - c.cl_meta <- (":real",[Ast.EConst (Ast.String (s_type_path c.cl_path)),p],mp) :: c.cl_meta; - c.cl_path <- parse_path name; - | _ -> () - ) c.cl_meta; - if has_rtti c && not (PMap.mem "__rtti" c.cl_statics) then begin - let f = mk_field "__rtti" ctx.t.tstring in - let str = Genxml.gen_type_string ctx.com t in - f.cf_expr <- Some (mk (TConst (TString str)) f.cf_type c.cl_pos); - c.cl_ordered_statics <- f :: c.cl_ordered_statics; - c.cl_statics <- PMap.add f.cf_name f c.cl_statics; - end; - if not ctx.in_macro then List.iter (fun f -> - match f.cf_kind with - | Method MethMacro -> - c.cl_statics <- PMap.remove f.cf_name c.cl_statics; - c.cl_ordered_statics <- List.filter (fun f2 -> f != f2) c.cl_ordered_statics; - | _ -> () - ) c.cl_ordered_statics; - (match build_metadata ctx.com t with - | None -> () - | Some e -> - let f = mk_field "__meta__" t_dynamic 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); - | _ -> - () - -(* -------------------------------------------------------------------------- *) -(* LOCAL VARIABLES USAGE *) - -type usage = - | Block of ((usage -> unit) -> unit) - | Loop of ((usage -> unit) -> unit) - | Function of ((usage -> unit) -> unit) - | Declare of string * t - | Use of string - -let rec local_usage f e = - match e.eexpr with - | TLocal v -> - f (Use v) - | TVars l -> - List.iter (fun (v,t,e) -> - (match e with None -> () | Some e -> local_usage f e); - f (Declare (v,t)); - ) l - | TFunction tf -> - let cc f = - List.iter (fun (n,_,t) -> f (Declare (n,t))) 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,t,it,e) -> - local_usage f it; - f (Loop (fun f -> - f (Declare (v,t)); - 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,t,e) -> - f (Block (fun f -> - f (Declare (v,t)); - 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 (fun (vo,t) -> match vo with None -> () | Some v -> f (Declare (v,t))) 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 - -(* -------------------------------------------------------------------------- *) -(* PER-BLOCK VARIABLES *) - -(* - This algorithm ensure that variables used in loop sub-functions are captured - by value. 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)); - } - - This way, each value is captured independantly. -*) - -let block_vars com e = - - let uid = ref 0 in - let gen_unique() = - incr uid; - "$t" ^ string_of_int !uid; - in - - let t = com.basic in - - let rec mk_init v vt vtmp pos = - let at = t.tarray vt in - mk (TVars [v,at,Some (mk (TArrayDecl [mk (TLocal vtmp) vt pos]) at pos)]) t.tvoid pos - - and wrap used e = - match e.eexpr with - | TVars vl -> - let vl = List.map (fun (v,vt,ve) -> - if PMap.mem v used then begin - let vt = t.tarray vt in - v, vt, Some (mk (TArrayDecl (match ve with None -> [] | Some e -> [wrap used e])) vt e.epos) - end else - v, vt, (match ve with None -> None | Some e -> Some (wrap used e)) - ) vl in - { e with eexpr = TVars vl } - | TLocal v when PMap.mem v used -> - mk (TArray ({ e with etype = t.tarray e.etype },mk (TConst (TInt 0l)) t.tint e.epos)) e.etype e.epos - | TFor (v,vt,it,expr) when PMap.mem v used -> - let vtmp = gen_unique() in - let it = wrap used it in - let expr = wrap used expr in - mk (TFor (vtmp,vt,it,concat (mk_init v vt vtmp e.epos) expr)) e.etype e.epos - | TTry (expr,catchs) -> - let catchs = List.map (fun (v,t,e) -> - let e = wrap used e in - if PMap.mem v used then - let vtmp = gen_unique() in - vtmp, t, concat (mk_init v t vtmp e.epos) e - else - v, t, 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 (vo,vt) -> - match vo with - | Some v when PMap.mem v used -> - let vtmp = gen_unique() in - e := concat (mk_init v vt vtmp pos) !e; - Some vtmp, vt - | _ -> vo, vt - ) 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 (PMap.foldi PMap.add used PMap.empty) in - let rec browse = function - | Block f | Loop f | Function f -> f browse - | Use v -> - (try - fused := PMap.add v (PMap.find v !tmp_used) !fused; - with Not_found -> - ()) - | Declare (v,_) -> - tmp_used := PMap.remove v !tmp_used - in - local_usage browse e; - let vars = PMap.foldi (fun v vt acc -> (v,t.tarray vt) :: 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,vt) -> - if PMap.mem v used then - let vtmp = gen_unique() in - fexpr := concat (mk_init v vt vtmp e.epos) !fexpr; - vtmp, o, vt - else - v, o, vt - ) f.tf_args in - let e = { e with eexpr = TFunction { f with tf_args = fargs; tf_expr = !fexpr } } in - (match com.platform with - | Cpp -> e - | _ -> - let args = List.map (fun (v,t) -> v, None, t) vars in - mk (TCall ( - (mk (TFunction { - tf_args = args; - tf_type = e.etype; - tf_expr = mk (TReturn (Some e)) e.etype e.epos; - }) (TFun (fun_args args,e.etype)) e.epos), - List.map (fun (v,t) -> mk (TLocal v) t e.epos) vars) - ) e.etype e.epos) - | _ -> - map_expr (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,t) -> - if in_loop then vars := PMap.add v (!depth,t) !vars; - | Use v -> - try - let d, t = PMap.find v (!vars) in - if d <> !depth then used := PMap.add v t !used; - with Not_found -> - () - in - local_usage (collect_vars false) e; - if PMap.is_empty !used then e else 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,t) -> - vars := PMap.add v (!depth,t) !vars; - | Use v -> - try - let d, t = PMap.find v (!vars) in - if d <> !depth then used := PMap.add v t !used; - with Not_found -> () - in - local_usage collect_vars e; - if PMap.is_empty !used then e else wrap !used e - in - match com.platform with - | Neko | Php | Cross -> e - | Cpp -> all_vars e - | _ -> out_loop 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 name -> - let init = (try PMap.find name !vars with Not_found -> true) in - if not init then error ("Local variable " ^ name ^ " used without being initialized") e.epos; - | TVars vl -> - List.iter (fun (v,_,eo) -> - let init = (match eo with None -> false | Some e -> loop vars e; true) in - declared := v :: !declared; - vars := PMap.add v init !vars - ) 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 name },e) -> - loop vars e; - vars := PMap.add name 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) - | TFor (v,_,it,e) -> - loop vars it; - let old = !vars in - vars := PMap.add v true !vars; - loop vars e; - vars := old; - | TFunction f -> - let old = !vars in - vars := List.fold_left (fun acc (v,_,_) -> PMap.add v true acc) !vars f.tf_args; - loop vars f.tf_expr; - vars := old; - | 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; - let tvars = (match vl with - | None -> [] - | Some vl -> List.map (fun (v,_) -> match v with None -> "" | Some v -> vars := PMap.add v true !vars; v) vl - ) in - loop vars e; - restore vars old tvars; - !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 - -(* -------------------------------------------------------------------------- *) -(* POST PROCESS *) - -let post_process ctx filters = - List.iter (fun t -> - match t with - | TClassDecl c -> - let process_field f = - match f.cf_expr with - | None -> () - | Some e -> - f.cf_expr <- Some (List.fold_left (fun e f -> f e) e filters) - 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 _ -> () - ) ctx.types - -(* -------------------------------------------------------------------------- *) -(* 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_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 = - mk (TBlock [ - mk (TVars [tmp_var, e.etype, Some e]) t.tvoid e.epos; - stack_pop; - mk (TReturn (Some (mk (TLocal tmp_var) e.etype e.epos))) e.etype e.epos - ]) e.etype e.epos - in - { - stack_var = stack_var; - stack_exc_var = exc_var; - stack_pos_var = pos_var; - stack_pos = p; - stack_expr = stack_e; - stack_pop = stack_pop; - stack_save_pos = mk (TVars [pos_var, t.tint, 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 ( - 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 (n,t,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 - n , t , 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 fix_override com c f fd = - c.cl_fields <- PMap.remove f.cf_name c.cl_fields; - let rec find_field c interf = - try - (match c.cl_super with - | None -> - raise Not_found - | Some (c,_) -> - find_field c false) - with Not_found -> try - let rec loop = function - | [] -> - raise Not_found - | (c,_) :: l -> - try - find_field c true - with - Not_found -> loop l - in - loop c.cl_implements - with Not_found -> - interf, PMap.find f.cf_name c.cl_fields - in - let f2 = (try Some (find_field c true) with Not_found -> None) in - let f = (match f2 with - | Some (interf,f2) -> - 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 ((n,c,t) as cur) (_,_,t2) -> - try - type_eq EqStrict t t2; - cur - with Unify_error _ -> - changed_args := (n,t,t2) :: !changed_args; - (prefix ^ n,c,t2) - ) 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 (n,t,t2) -> - (n,t,Some (mk (TCast (mk (TLocal (prefix ^ n)) t2 p,None)) t p)) - ) args)) com.basic.tvoid p in - { e with eexpr = TBlock (v :: el) } - ); - } in - let fde = (match f.cf_expr with None -> assert false | Some e -> e) in - { f with cf_expr = Some { fde with eexpr = TFunction fd2 }; cf_type = TFun(targs,tret) } - | _ -> f - ) in - c.cl_fields <- PMap.add f.cf_name f c.cl_fields; - f - -let fix_overrides com t = - match t with - | TClassDecl c -> - c.cl_ordered_fields <- List.map (fun f -> - match f.cf_expr, f.cf_kind with - | Some { eexpr = TFunction fd }, Method (MethNormal | MethInline) -> - fix_override com c f fd - | _ -> - f - ) c.cl_ordered_fields - | _ -> - () - -(* -------------------------------------------------------------------------- *) -(* MISC FEATURES *) - -(* - Tells if we can find a local var in an expression or inside a sub closure -*) -let local_find flag vname e = - let rec loop2 e = - match e.eexpr with - | TFunction f -> - if not flag && not (List.exists (fun (a,_,_) -> a = vname) f.tf_args) then loop2 f.tf_expr - | TBlock _ -> - (try - Type.iter loop2 e; - with - Not_found -> ()) - | TVars vl -> - List.iter (fun (v,t,e) -> - (match e with - | None -> () - | Some e -> loop2 e); - if v = vname then raise Not_found; - ) vl - | TConst TSuper -> - if vname = "super" then raise Exit - | TLocal v -> - if v = vname then raise Exit - | _ -> - iter loop2 e - in - let rec loop e = - match e.eexpr with - | TFunction f -> - if not (List.exists (fun (a,_,_) -> a = vname) f.tf_args) then loop2 f.tf_expr - | TBlock _ -> - (try - iter loop e; - with - Not_found -> ()) - | TVars vl -> - List.iter (fun (v,t,e) -> - (match e with - | None -> () - | Some e -> loop e); - if v = vname then raise Not_found; - ) vl - | _ -> - iter loop e - in - try - (if flag then loop2 else loop) e; - false - with - Exit -> - true - -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 t p = - let ve = mk (TLocal a) t p in - let cond = TBinop (OpEq,ve,mk (TConst TNull) t p) in - mk (TIf (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 - | TUnop _ | TArray _ | TField _ | TCall _ | TNew _ | TFor _ | TWhile _ | TSwitch _ | TMatch _ | TReturn _ | TThrow _ | TClosure _ -> - true - | TBinop _ | TTry _ | TIf _ | TBlock _ | TVars _ - | TFunction _ | TArrayDecl _ | TObjectDecl _ - | TParenthesis _ | TTypeExpr _ | TEnumField _ | 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 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 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 - List.iter (fun mt -> - let path = Type.t_path mt in - let dir = "dump" :: fst path in - create [] dir; - let ch = open_out (String.concat "/" dir ^ "/" ^ snd path ^ ".dump") in - let buf = Buffer.create 0 in - let print fmt = Printf.kprintf (fun s -> Buffer.add_string buf s) fmt in - (match mt with - | Type.TClassDecl c -> - let 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" (Type.s_expr s_type e)); - print ";\n\n"; - 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); - ); - output_string ch (Buffer.contents buf); - close_out ch - ) com.types - -(* - 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) } - | TTypeDecl _ -> assert false - in - let var = mk (TVars [(vtmp,e.etype,Some e)]) api.tvoid p in - let vexpr = mk (TLocal vtmp) e.etype p in - let texpr = mk (TTypeExpr texpr) (mk_texpr texpr) p in - let std = (try List.find (fun t -> t_path t = ([],"Std")) com.types with Not_found -> assert false) in - let std = mk (TTypeExpr std) (mk_texpr std) p in - let is = mk (TField (std,"is")) (tfun [t_dynamic;t_dynamic] api.tbool) p in - let is = mk (TCall (is,[vexpr;texpr])) api.tbool p in - let exc = mk (TThrow (mk (TConst (TString "Class cast error")) api.tstring p)) t p in - let check = mk (TIf (is,mk (TCast (vexpr,None)) t p,Some exc)) t p in - mk (TBlock [var;check;vexpr]) t p diff --git a/haxe/common.ml b/haxe/common.ml deleted file mode 100644 index 5a20d9bac02dd0bc40c2f1784c3f4b484de3f650..0000000000000000000000000000000000000000 --- a/haxe/common.ml +++ /dev/null @@ -1,220 +0,0 @@ -(* - * Haxe Compiler - * Copyright (c)2005-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 Type - -type package_rule = - | Forbidden - | Directory of string - | Remap of string - -type platform = - | Cross - | Flash - | Js - | Neko - | Flash9 - | Php - | Cpp - -type pos = Ast.pos - -type basic_types = { - mutable tvoid : t; - mutable tint : t; - mutable tfloat : t; - mutable tbool : t; - mutable tnull : t -> t; - mutable tstring : t; - mutable tarray : t -> t; -} - -type context = { - (* config *) - version : int; - mutable display : bool; - mutable debug : bool; - mutable verbose : bool; - mutable foptimize : bool; - mutable dead_code_elimination : bool; - mutable platform : platform; - mutable std_path : string list; - mutable class_path : string list; - mutable main_class : Type.path option; - mutable defines : (string,unit) PMap.t; - mutable package_rules : (string,package_rule) PMap.t; - mutable error : string -> pos -> unit; - mutable warning : string -> pos -> unit; - mutable js_namespace : string option; - mutable load_extern_type : (path -> pos -> Ast.package option) list; (* allow finding types which are not in sources *) - mutable filters : (unit -> unit) list; - (* output *) - mutable file : string; - mutable flash_version : float; - mutable modules : Type.module_def list; - mutable main : Type.texpr option; - mutable types : Type.module_type list; - mutable resources : (string,string) Hashtbl.t; - mutable php_front : string option; - mutable php_lib : string option; - mutable swf_libs : (string * (unit -> Swf.swf) * (unit -> ((string list * string),As3hl.hl_class) Hashtbl.t)) list; - mutable js_gen : (unit -> unit) option; - (* typing *) - mutable basic : basic_types; -} - -exception Abort of string * Ast.pos - -let display_default = ref false - -let create v = - let m = Type.mk_mono() in - { - version = v; - debug = false; - display = !display_default; - verbose = false; - foptimize = true; - dead_code_elimination = false; - platform = Cross; - std_path = []; - class_path = []; - main_class = None; - defines = PMap.add "true" () PMap.empty; - package_rules = PMap.empty; - file = ""; - types = []; - filters = []; - modules = []; - main = None; - flash_version = 10.; - resources = Hashtbl.create 0; - php_front = None; - php_lib = None; - swf_libs = []; - js_namespace = None; - js_gen = None; - load_extern_type = []; - warning = (fun _ _ -> assert false); - error = (fun _ _ -> assert false); - basic = { - tvoid = m; - tint = m; - tfloat = m; - tbool = m; - tnull = (fun _ -> assert false); - tstring = m; - tarray = (fun _ -> assert false); - }; - } - -let clone com = - let t = com.basic in - { com with basic = { t with tvoid = t.tvoid } } - -let platforms = [ - Flash; - Js; - Neko; - Flash9; - Php; - Cpp -] - -let platform_name = function - | Cross -> "cross" - | Flash -> "flash" - | Js -> "js" - | Neko -> "neko" - | Flash9 -> "flash9" - | Php -> "php" - | Cpp -> "cpp" - -let defined ctx v = PMap.mem v ctx.defines - -let define ctx v = - ctx.defines <- PMap.add v () ctx.defines; - let v = String.concat "_" (ExtString.String.nsplit v "-") in - ctx.defines <- PMap.add v () ctx.defines - -let init_platform com pf = - com.platform <- pf; - let name = platform_name pf in - let forbid acc p = if p = name || PMap.mem p acc then acc else PMap.add p Forbidden acc in - com.package_rules <- List.fold_left forbid com.package_rules (List.map platform_name platforms); - define com name - -let error msg p = raise (Abort (msg,p)) - -let platform ctx p = ctx.platform = p - -let add_filter ctx f = - ctx.filters <- f :: ctx.filters - -let find_file ctx f = - let rec loop = function - | [] -> raise Not_found - | p :: l -> - let file = p ^ f in - if Sys.file_exists file then - file - else - loop l - in - loop ctx.class_path - -let get_full_path = Extc.get_full_path - -(* ------------------------- TIMERS ----------------------------- *) - -type timer_infos = { - name : string; - mutable start : float; - mutable total : float; -} - -let get_time = Unix.gettimeofday -let htimers = Hashtbl.create 0 - -let new_timer name = - try - let t = Hashtbl.find htimers name in - t.start <- get_time(); - t - with Not_found -> - let t = { name = name; start = get_time(); total = 0.; } in - Hashtbl.add htimers name t; - t - -let curtime = ref [] - -let close t = - let dt = get_time() -. t.start in - t.total <- t.total +. dt; - curtime := List.tl !curtime; - List.iter (fun ct -> ct.start <- ct.start +. dt) !curtime - -let timer name = - let t = new_timer name in - curtime := t :: !curtime; - (function() -> close t) - -let rec close_time() = - match !curtime with - | [] -> () - | t :: _ -> close t diff --git a/haxe/doc/extract.hxml b/haxe/doc/extract.hxml deleted file mode 100644 index ed079059f747c89b6583fba2693cf36f324b626d..0000000000000000000000000000000000000000 --- a/haxe/doc/extract.hxml +++ /dev/null @@ -1,6 +0,0 @@ --debug --swf-lib library102.swf --swf9 test.swf --swf-version 10.2 ---macro patchTypes("../doc/extract.patch") ---gen-hx-classes \ No newline at end of file diff --git a/haxe/genjs.ml b/haxe/genjs.ml deleted file mode 100644 index 5ba817ee38871b0f02d949f83f2c81dedfdfc8c6..0000000000000000000000000000000000000000 --- a/haxe/genjs.ml +++ /dev/null @@ -1,799 +0,0 @@ -(* - * Haxe Compiler - * 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 Type -open Common - -type ctx = { - com : Common.context; - buf : Buffer.t; - packages : (string list,unit) Hashtbl.t; - stack : Codegen.stack_context; - namespace : string option; - mutable current : tclass; - mutable statics : (tclass * string * texpr) list; - mutable inits : texpr list; - mutable tabs : string; - mutable in_value : bool; - mutable in_loop : bool; - mutable handle_break : bool; - mutable id_counter : int; - mutable curmethod : (string * bool); - mutable type_accessor : module_type -> string; - mutable separator : bool; -} - -let s_path ctx = function - | ([],p) -> - (match ctx.namespace with - | None -> p - | Some ns -> ns ^ "." ^ p) - | p -> Ast.s_type_path p - -let kwds = - let h = Hashtbl.create 0 in - List.iter (fun s -> Hashtbl.add h s ()) [ - "abstract"; "as"; "boolean"; "break"; "byte"; "case"; "catch"; "char"; "class"; "continue"; "const"; - "debugger"; "default"; "delete"; "do"; "double"; "else"; "enum"; "export"; "extends"; "false"; "final"; - "finally"; "float"; "for"; "function"; "goto"; "if"; "implements"; "import"; "in"; "instanceof"; "int"; - "interface"; "is"; "long"; "namespace"; "native"; "new"; "null"; "package"; "private"; "protected"; - "public"; "return"; "short"; "static"; "super"; "switch"; "synchronized"; "this"; "throw"; "throws"; - "transient"; "true"; "try"; "typeof"; "use"; "var"; "void"; "volatile"; "while"; "with" - ]; - h - -let field s = if Hashtbl.mem kwds s then "[\"" ^ s ^ "\"]" else "." ^ s -let ident s = if Hashtbl.mem kwds s then "$" ^ s else s -let anon_field s = if Hashtbl.mem kwds s then "'" ^ s ^ "'" else s - -let spr ctx s = ctx.separator <- false; Buffer.add_string ctx.buf s -let print ctx = ctx.separator <- false; Printf.kprintf (fun s -> Buffer.add_string ctx.buf s) - -let unsupported p = error "This expression cannot be compiled to Javascript" p - -let newline ctx = - match Buffer.nth ctx.buf (Buffer.length ctx.buf - 1) with - | '}' | '{' | ':' when not ctx.separator -> print ctx "\n%s" ctx.tabs - | _ -> print ctx ";\n%s" ctx.tabs - -let rec concat ctx s f = function - | [] -> () - | [x] -> f x - | x :: l -> - f x; - spr ctx s; - concat ctx s f l - -let fun_block ctx f p = - let e = (match f.tf_expr with { eexpr = TBlock [{ eexpr = TBlock _ } as e] } -> e | e -> e) in - let e = List.fold_left (fun e (a,c,t) -> - match c with - | None | Some TNull -> e - | Some c -> Codegen.concat (Codegen.set_default ctx.com a c t p) e - ) e f.tf_args in - if ctx.com.debug then - Codegen.stack_block ctx.stack ctx.current (fst ctx.curmethod) e - else - mk_block e - -let parent e = - match e.eexpr with - | TParenthesis _ -> e - | _ -> mk (TParenthesis e) e.etype e.epos - -let open_block ctx = - let oldt = ctx.tabs in - ctx.tabs <- "\t" ^ ctx.tabs; - (fun() -> ctx.tabs <- oldt) - -let rec iter_switch_break in_switch e = - match e.eexpr with - | TFunction _ | TWhile _ | TFor _ -> () - | TSwitch _ | TMatch _ when not in_switch -> iter_switch_break true e - | TBreak when in_switch -> raise Exit - | _ -> iter (iter_switch_break in_switch) e - -let handle_break ctx e = - let old = ctx.in_loop, ctx.handle_break in - ctx.in_loop <- true; - try - iter_switch_break false e; - ctx.handle_break <- false; - (fun() -> - ctx.in_loop <- fst old; - ctx.handle_break <- snd old; - ) - with - Exit -> - spr ctx "try {"; - let b = open_block ctx in - newline ctx; - ctx.handle_break <- true; - (fun() -> - b(); - ctx.in_loop <- fst old; - ctx.handle_break <- snd old; - newline ctx; - spr ctx "} catch( e ) { if( e != \"__break__\" ) throw e; }"; - ) - -let this ctx = if ctx.in_value then "$this" else "this" - -let gen_constant ctx p = function - | TInt i -> print ctx "%ld" i - | TFloat s -> spr ctx s - | TString s -> - if String.contains s '\000' then error "A String cannot contain \\0 characters" p; - print ctx "\"%s\"" (Ast.s_escape s) - | TBool b -> spr ctx (if b then "true" else "false") - | TNull -> spr ctx "null" - | TThis -> spr ctx (this ctx) - | TSuper -> assert false - -let rec gen_call ctx e el = - match e.eexpr , el with - | TConst TSuper , params -> - (match ctx.current.cl_super with - | None -> error "Missing setDebugInfos current class" e.epos - | Some (c,_) -> - print ctx "%s.call(%s" (ctx.type_accessor (TClassDecl c)) (this ctx); - List.iter (fun p -> print ctx ","; gen_value ctx p) params; - spr ctx ")"; - ); - | TField ({ eexpr = TConst TSuper },name) , params -> - (match ctx.current.cl_super with - | None -> error "Missing setDebugInfos current class" e.epos - | Some (c,_) -> - print ctx "%s.prototype%s.call(%s" (ctx.type_accessor (TClassDecl c)) (field name) (this ctx); - List.iter (fun p -> print ctx ","; gen_value ctx p) params; - spr ctx ")"; - ); - | TCall (x,_) , el when x.eexpr <> TLocal "__js__" -> - spr ctx "("; - gen_value ctx e; - spr ctx ")"; - spr ctx "("; - concat ctx "," (gen_value ctx) el; - spr ctx ")"; - | TLocal "__new__" , { eexpr = TConst (TString cl) } :: params -> - print ctx "new %s(" cl; - concat ctx "," (gen_value ctx) params; - spr ctx ")"; - | TLocal "__new__" , e :: params -> - spr ctx "new "; - gen_value ctx e; - spr ctx "("; - concat ctx "," (gen_value ctx) params; - spr ctx ")"; - | TLocal "__js__", [{ eexpr = TConst (TString code) }] -> - spr ctx (String.concat "\n" (ExtString.String.nsplit code "\r\n")) - | TLocal "__resources__", [] -> - spr ctx "["; - concat ctx "," (fun (name,data) -> - spr ctx "{ "; - spr ctx "name : "; - gen_constant ctx e.epos (TString name); - spr ctx ", data : "; - gen_constant ctx e.epos (TString (Codegen.bytes_serialize data)); - spr ctx "}" - ) (Hashtbl.fold (fun name data acc -> (name,data) :: acc) ctx.com.resources []); - spr ctx "]"; - | _ -> - gen_value ctx e; - spr ctx "("; - concat ctx "," (gen_value ctx) el; - spr ctx ")" - -and gen_expr ctx e = - match e.eexpr with - | TConst c -> gen_constant ctx e.epos c - | TLocal s -> spr ctx (ident s) - | TEnumField (e,s) -> - print ctx "%s%s" (ctx.type_accessor (TEnumDecl e)) (field s) - | TArray (e1,e2) -> - gen_value ctx e1; - spr ctx "["; - gen_value ctx e2; - spr ctx "]"; - | TBinop (op,e1,e2) -> - gen_value ctx e1; - print ctx " %s " (Ast.s_binop op); - gen_value ctx e2; - | TField (x,s) -> - gen_value ctx x; - spr ctx (field s) - | TClosure (x,s) -> - spr ctx "$closure("; - gen_value ctx x; - spr ctx ","; - gen_constant ctx e.epos (TString s); - spr ctx ")"; - | TTypeExpr t -> - spr ctx (ctx.type_accessor t) - | TParenthesis e -> - spr ctx "("; - gen_value ctx e; - spr ctx ")"; - | TReturn eo -> - if ctx.in_value then unsupported e.epos; - (match eo with - | None -> - spr ctx "return" - | Some e -> - spr ctx "return "; - gen_value ctx e); - | TBreak -> - if not ctx.in_loop then unsupported e.epos; - if ctx.handle_break then spr ctx "throw \"__break__\"" else spr ctx "break" - | TContinue -> - if not ctx.in_loop then unsupported e.epos; - spr ctx "continue" - | TBlock [] -> - spr ctx "null" - | TBlock el -> - print ctx "{"; - let bend = open_block ctx in - List.iter (fun e -> newline ctx; gen_expr ctx e) el; - bend(); - newline ctx; - print ctx "}"; - | TFunction f -> - let old = ctx.in_value, ctx.in_loop in - let old_meth = ctx.curmethod in - ctx.in_value <- false; - ctx.in_loop <- false; - if snd ctx.curmethod then - ctx.curmethod <- (fst ctx.curmethod ^ "@" ^ string_of_int (Lexer.get_error_line e.epos), true) - else - ctx.curmethod <- (fst ctx.curmethod, true); - print ctx "function(%s) " (String.concat "," (List.map ident (List.map arg_name f.tf_args))); - gen_expr ctx (fun_block ctx f e.epos); - ctx.curmethod <- old_meth; - ctx.in_value <- fst old; - ctx.in_loop <- snd old; - | TCall (e,el) -> - gen_call ctx e el - | TArrayDecl el -> - spr ctx "["; - concat ctx "," (gen_value ctx) el; - spr ctx "]" - | TThrow e -> - spr ctx "throw "; - gen_value ctx e; - | TVars [] -> - () - | TVars vl -> - spr ctx "var "; - concat ctx ", " (fun (n,_,e) -> - spr ctx (ident n); - match e with - | None -> () - | Some e -> - spr ctx " = "; - gen_value ctx e - ) vl; - | TNew (c,_,el) -> - print ctx "new %s(" (ctx.type_accessor (TClassDecl c)); - concat ctx "," (gen_value ctx) el; - spr ctx ")" - | TIf (cond,e,eelse) -> - spr ctx "if"; - gen_value ctx (parent cond); - spr ctx " "; - gen_expr ctx e; - (match eelse with - | None -> () - | Some e -> - newline ctx; - spr ctx "else "; - gen_expr ctx e); - | TUnop (op,Ast.Prefix,e) -> - spr ctx (Ast.s_unop op); - gen_value ctx e - | TUnop (op,Ast.Postfix,e) -> - gen_value ctx e; - spr ctx (Ast.s_unop op) - | TWhile (cond,e,Ast.NormalWhile) -> - let handle_break = handle_break ctx e in - spr ctx "while"; - gen_value ctx (parent cond); - spr ctx " "; - gen_expr ctx e; - handle_break(); - | TWhile (cond,e,Ast.DoWhile) -> - let handle_break = handle_break ctx e in - spr ctx "do "; - gen_expr ctx e; - spr ctx " while"; - gen_value ctx (parent cond); - handle_break(); - | TObjectDecl fields -> - spr ctx "{ "; - concat ctx ", " (fun (f,e) -> print ctx "%s : " (anon_field f); gen_value ctx e) fields; - spr ctx "}"; - ctx.separator <- true - | TFor (v,_,it,e) -> - let handle_break = handle_break ctx e in - let id = ctx.id_counter in - ctx.id_counter <- ctx.id_counter + 1; - print ctx "{ var $it%d = " id; - gen_value ctx it; - newline ctx; - print ctx "while( $it%d.hasNext() ) { var %s = $it%d.next()" id (ident v) id; - newline ctx; - gen_expr ctx e; - newline ctx; - spr ctx "}}"; - handle_break(); - | TTry (e,catchs) -> - spr ctx "try "; - gen_expr ctx (mk_block e); - newline ctx; - let id = ctx.id_counter in - ctx.id_counter <- ctx.id_counter + 1; - print ctx "catch( $e%d ) {" id; - let bend = open_block ctx in - newline ctx; - let last = ref false in - List.iter (fun (v,t,e) -> - if !last then () else - let t = (match follow t with - | TEnum (e,_) -> Some (TEnumDecl e) - | TInst (c,_) -> Some (TClassDecl c) - | TFun _ - | TLazy _ - | TType _ - | TAnon _ -> - assert false - | TMono _ - | TDynamic _ -> - None - ) in - match t with - | None -> - last := true; - spr ctx "{"; - let bend = open_block ctx in - newline ctx; - print ctx "var %s = $e%d" v id; - newline ctx; - gen_expr ctx e; - bend(); - newline ctx; - spr ctx "}" - | Some t -> - print ctx "if( %s.__instanceof($e%d," (ctx.type_accessor (TClassDecl { null_class with cl_path = ["js"],"Boot" })) id; - gen_value ctx (mk (TTypeExpr t) (mk_mono()) e.epos); - spr ctx ") ) {"; - let bend = open_block ctx in - newline ctx; - print ctx "var %s = $e%d" v id; - newline ctx; - gen_expr ctx e; - bend(); - newline ctx; - spr ctx "} else " - ) catchs; - if not !last then print ctx "throw($e%d)" id; - bend(); - newline ctx; - spr ctx "}"; - | TMatch (e,(estruct,_),cases,def) -> - spr ctx "var $e = "; - gen_value ctx e; - newline ctx; - spr ctx "switch( $e[1] ) {"; - newline ctx; - List.iter (fun (cl,params,e) -> - List.iter (fun c -> - print ctx "case %d:" c; - newline ctx; - ) cl; - (match params with - | None | Some [] -> () - | Some l -> - let n = ref 1 in - let l = List.fold_left (fun acc (v,_) -> incr n; match v with None -> acc | Some v -> (v,!n) :: acc) [] l in - match l with - | [] -> () - | l -> - spr ctx "var "; - concat ctx ", " (fun (v,n) -> - print ctx "%s = $e[%d]" v n; - ) l; - newline ctx); - gen_expr ctx (mk_block e); - print ctx "break"; - newline ctx - ) cases; - (match def with - | None -> () - | Some e -> - spr ctx "default:"; - gen_expr ctx (mk_block e); - print ctx "break"; - newline ctx; - ); - spr ctx "}" - | TSwitch (e,cases,def) -> - spr ctx "switch"; - gen_value ctx (parent e); - spr ctx " {"; - newline ctx; - List.iter (fun (el,e2) -> - List.iter (fun e -> - match e.eexpr with - | TConst(c) when c = TNull -> - spr ctx "case null: case undefined:"; - | _ -> - spr ctx "case "; - gen_value ctx e; - spr ctx ":" - ) el; - gen_expr ctx (mk_block e2); - print ctx "break"; - newline ctx; - ) cases; - (match def with - | None -> () - | Some e -> - spr ctx "default:"; - gen_expr ctx (mk_block e); - print ctx "break"; - newline ctx; - ); - spr ctx "}" - | TCast (e,None) -> - gen_expr ctx e - | TCast (e1,Some t) -> - gen_expr ctx (Codegen.default_cast ctx.com e1 t e.etype e.epos) - -and gen_value ctx e = - let assign e = - mk (TBinop (Ast.OpAssign, - mk (TLocal "$r") t_dynamic e.epos, - e - )) e.etype e.epos - in - let value block = - let old = ctx.in_value, ctx.in_loop in - ctx.in_value <- true; - ctx.in_loop <- false; - spr ctx "(function($this) "; - let b = if block then begin - spr ctx "{"; - let b = open_block ctx in - newline ctx; - spr ctx "var $r"; - newline ctx; - b - end else - (fun() -> ()) - in - (fun() -> - if block then begin - newline ctx; - spr ctx "return $r"; - b(); - newline ctx; - spr ctx "}"; - end; - ctx.in_value <- fst old; - ctx.in_loop <- snd old; - print ctx "(%s))" (this ctx) - ) - in - match e.eexpr with - | TConst _ - | TLocal _ - | TEnumField _ - | TArray _ - | TBinop _ - | TField _ - | TClosure _ - | TTypeExpr _ - | TParenthesis _ - | TObjectDecl _ - | TArrayDecl _ - | TCall _ - | TNew _ - | TUnop _ - | TFunction _ -> - gen_expr ctx e - | TReturn _ - | TBreak - | TContinue -> - unsupported e.epos - | TCast (e1,t) -> - gen_value ctx (match t with None -> e1 | Some t -> Codegen.default_cast ctx.com e1 t e.etype e.epos) - | TVars _ - | TFor _ - | TWhile _ - | TThrow _ -> - (* value is discarded anyway *) - let v = value true in - gen_expr ctx e; - v() - | TBlock [e] -> - gen_value ctx e - | TBlock el -> - let v = value true in - let rec loop = function - | [] -> - spr ctx "return null"; - | [e] -> - gen_expr ctx (assign e); - | e :: l -> - gen_expr ctx e; - newline ctx; - loop l - in - loop el; - v(); - | TIf (cond,e,eo) -> - (* remove parenthesis unless it's an operation with higher precedence than ?: *) - let cond = (match cond.eexpr with - | TParenthesis { eexpr = TBinop ((Ast.OpAssign | Ast.OpAssignOp _),_,_) } -> cond - | TParenthesis e -> e - | _ -> cond - ) in - gen_value ctx cond; - spr ctx "?"; - gen_value ctx e; - spr ctx ":"; - (match eo with - | None -> spr ctx "null" - | Some e -> gen_value ctx e); - | TSwitch (cond,cases,def) -> - let v = value true in - gen_expr ctx (mk (TSwitch (cond, - List.map (fun (e1,e2) -> (e1,assign e2)) cases, - match def with None -> None | Some e -> Some (assign e) - )) e.etype e.epos); - v() - | TMatch (cond,enum,cases,def) -> - let v = value true in - gen_expr ctx (mk (TMatch (cond,enum, - List.map (fun (constr,params,e) -> (constr,params,assign e)) cases, - match def with None -> None | Some e -> Some (assign e) - )) e.etype e.epos); - v() - | TTry (b,catchs) -> - let v = value true in - gen_expr ctx (mk (TTry (assign b, - List.map (fun (v,t,e) -> v, t , assign e) catchs - )) e.etype e.epos); - v() - -let generate_package_create ctx (p,_) = - let rec loop acc = function - | [] -> () - | p :: l when Hashtbl.mem ctx.packages (p :: acc) -> loop (p :: acc) l - | p :: l -> - Hashtbl.add ctx.packages (p :: acc) (); - (match acc with - | [] -> - print ctx "if(typeof %s=='undefined') %s = {}" p p; - | _ -> - let p = String.concat "." (List.rev acc) ^ (field p) in - print ctx "if(!%s) %s = {}" p p); - newline ctx; - loop (p :: acc) l - in - loop [] p - -let check_field_name c f = - match f.cf_name with - | "prototype" | "__proto__" | "constructor" -> - error ("The field name '" ^ f.cf_name ^ "' is not allowed in JS") (match f.cf_expr with None -> c.cl_pos | Some e -> e.epos); - | _ -> () - -let gen_class_static_field ctx c f = - check_field_name c f; - match f.cf_expr with - | None -> - print ctx "%s%s = null" (s_path ctx c.cl_path) (field f.cf_name); - newline ctx - | Some e -> - match e.eexpr with - | TFunction _ -> - ctx.curmethod <- (f.cf_name,false); - ctx.id_counter <- 0; - print ctx "%s%s = " (s_path ctx c.cl_path) (field f.cf_name); - gen_value ctx e; - newline ctx - | _ -> - ctx.statics <- (c,f.cf_name,e) :: ctx.statics - -let gen_class_field ctx c f = - check_field_name c f; - print ctx "%s.prototype%s = " (s_path ctx c.cl_path) (field f.cf_name); - match f.cf_expr with - | None -> - print ctx "null"; - newline ctx - | Some e -> - ctx.curmethod <- (f.cf_name,false); - ctx.id_counter <- 0; - gen_value ctx e; - newline ctx - -let gen_constructor ctx e = - match e.eexpr with - | TFunction f -> - let args = List.map arg_name f.tf_args in - let a, args = (match args with [] -> "p" , ["p"] | x :: _ -> x, args) in - print ctx "function(%s) { if( %s === $_ ) return; " (String.concat "," (List.map ident args)) a; - gen_expr ctx (fun_block ctx f e.epos); - print ctx "}"; - | _ -> assert false - -let generate_class ctx c = - ctx.current <- c; - ctx.curmethod <- ("new",true); - ctx.id_counter <- 0; - let p = s_path ctx c.cl_path in - generate_package_create ctx c.cl_path; - print ctx "%s = " p; - (match c.cl_constructor with - | Some { cf_expr = Some e } -> gen_constructor ctx e - | _ -> print ctx "function() { }"); - newline ctx; - print ctx "%s.__name__ = [%s]" p (String.concat "," (List.map (fun s -> Printf.sprintf "\"%s\"" (Ast.s_escape s)) (fst c.cl_path @ [snd c.cl_path]))); - newline ctx; - (match c.cl_super with - | None -> () - | Some (csup,_) -> - let psup = s_path ctx csup.cl_path in - print ctx "%s.__super__ = %s" p psup; - newline ctx; - print ctx "for(var k in %s.prototype ) %s.prototype[k] = %s.prototype[k]" psup p psup; - newline ctx; - ); - List.iter (gen_class_static_field ctx c) c.cl_ordered_statics; - List.iter (fun f -> match f.cf_kind with Var { v_read = AccResolve } -> () | _ -> gen_class_field ctx c f) c.cl_ordered_fields; - print ctx "%s.prototype.__class__ = %s" p p; - newline ctx; - match c.cl_implements with - | [] -> () - | l -> - print ctx "%s.__interfaces__ = [%s]" p (String.concat "," (List.map (fun (i,_) -> s_path ctx i.cl_path) l)); - newline ctx - -let generate_enum ctx e = - let p = s_path ctx e.e_path in - generate_package_create ctx e.e_path; - let ename = List.map (fun s -> Printf.sprintf "\"%s\"" (Ast.s_escape s)) (fst e.e_path @ [snd e.e_path]) in - print ctx "%s = { __ename__ : [%s], __constructs__ : [%s] }" p (String.concat "," ename) (String.concat "," (List.map (fun s -> Printf.sprintf "\"%s\"" s) e.e_names)); - newline ctx; - List.iter (fun n -> - let f = PMap.find n e.e_constrs in - print ctx "%s%s = " p (field f.ef_name); - (match f.ef_type with - | TFun (args,_) -> - let sargs = String.concat "," (List.map arg_name args) in - print ctx "function(%s) { var $x = [\"%s\",%d,%s]; $x.__enum__ = %s; $x.toString = $estr; return $x; }" sargs f.ef_name f.ef_index sargs p; - | _ -> - print ctx "[\"%s\",%d]" f.ef_name f.ef_index; - newline ctx; - print ctx "%s%s.toString = $estr" p (field f.ef_name); - newline ctx; - print ctx "%s%s.__enum__ = %s" p (field f.ef_name) p; - ); - newline ctx - ) e.e_names; - match Codegen.build_metadata ctx.com (TEnumDecl e) with - | None -> () - | Some e -> - print ctx "%s.__meta__ = " p; - gen_expr ctx e; - newline ctx - -let generate_static ctx (c,f,e) = - print ctx "%s%s = " (s_path ctx c.cl_path) (field f); - gen_value ctx e; - newline ctx - -let generate_type ctx = function - | TClassDecl c -> - (match c.cl_init with - | None -> () - | Some e -> ctx.inits <- e :: ctx.inits); - if not c.cl_extern then generate_class ctx c - | TEnumDecl e when e.e_extern -> - () - | TEnumDecl e -> generate_enum ctx e - | TTypeDecl _ -> () - -let alloc_ctx com = - let ctx = { - com = com; - stack = Codegen.stack_init com false; - buf = Buffer.create 16000; - packages = Hashtbl.create 0; - namespace = com.js_namespace; - statics = []; - inits = []; - current = null_class; - tabs = ""; - in_value = false; - in_loop = false; - handle_break = false; - id_counter = 0; - curmethod = ("",false); - type_accessor = (fun _ -> assert false); - separator = false; - } in - ctx.type_accessor <- (fun t -> s_path ctx (t_path t)); - ctx - -let gen_single_expr ctx e constr = - if constr then gen_constructor ctx e else gen_value ctx e; - let str = Buffer.contents ctx.buf in - Buffer.reset ctx.buf; - ctx.id_counter <- 0; - str - -let set_debug_infos ctx c m s = - ctx.current <- c; - ctx.curmethod <- (m,s) - -let generate com = - let t = Common.timer "generate js" in - (match com.js_gen with - | Some g -> g() - | None -> - let ctx = alloc_ctx com in - print ctx "$estr = function() { return js.Boot.__string_rec(this,''); }"; - newline ctx; - (match ctx.namespace with - | None -> () - | Some ns -> - print ctx "if(typeof %s=='undefined') %s = {}" ns ns; - newline ctx); - List.iter (generate_type ctx) com.types; - print ctx "$_ = {}"; - newline ctx; - print ctx "js.Boot.__res = {}"; - newline ctx; - (match ctx.namespace with - | None -> () - | Some ns -> - print ctx "js.Boot.__ns = '%s'" ns; - newline ctx); - if com.debug then begin - print ctx "%s = []" ctx.stack.Codegen.stack_var; - newline ctx; - print ctx "%s = []" ctx.stack.Codegen.stack_exc_var; - newline ctx; - end; - print ctx "js.Boot.__init()"; - newline ctx; - List.iter (fun e -> - gen_expr ctx e; - newline ctx; - ) (List.rev ctx.inits); - List.iter (generate_static ctx) (List.rev ctx.statics); - (match com.main with - | None -> () - | Some e -> gen_expr ctx e); - let ch = open_out_bin com.file in - output_string ch (Buffer.contents ctx.buf); - close_out ch); - t() - diff --git a/haxe/interp.ml b/haxe/interp.ml deleted file mode 100644 index ec54eade03cd842908c87b079db4fba96a48eaf0..0000000000000000000000000000000000000000 --- a/haxe/interp.ml +++ /dev/null @@ -1,3079 +0,0 @@ -(* - * Haxe Compiler - * Copyright (c)2005-2010 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 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) - -and vobject = { - ofields : (string,value) Hashtbl.t; - mutable oproto : vobject option; -} - -and vabstract = - | AKind of vabstract - | AInt32 of int32 - | 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 - -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 locals = (string, value ref) PMap.t - -type extern_api = { - pos : Ast.pos; - defined : string -> bool; - get_type : string -> Type.t option; - get_module : string -> Type.t list; - on_generate : (Type.t list -> unit) -> unit; - print : string -> unit; - parse_string : string -> Ast.pos -> Ast.expr; - typeof : Ast.expr -> Type.t; - type_patch : string -> string -> bool -> string option -> unit; - meta_patch : string -> string -> string option -> bool -> unit; - set_js_generator : (value -> unit) -> unit; - get_cur_class : unit -> tclass option; -} - -type context = { - com : Common.context; - gen : Genneko.context; - types : (Type.path,bool) Hashtbl.t; - globals : (string, value) Hashtbl.t; - prototypes : (string list, vobject) Hashtbl.t; - mutable error : bool; - 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 locals : locals; - mutable stack : (pos * value * locals) list; - mutable exc : pos list; - mutable vthis : value; - (* context *) - mutable curapi : extern_api; - mutable delayed : (unit -> value) DynArray.t; -} - -type access = - | AccField of value * string - | AccArray of value * value - | AccVar of string - -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 - -(* ---------------------------------------------------------------------- *) -(* UTILS *) - -let get_ctx_ref = ref (fun() -> assert false) -let encode_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 enc_array_ref = ref (fun l -> assert false) -let get_ctx() = (!get_ctx_ref)() -let enc_array (l:value list) : value = (!enc_array_ref) l -let encode_type (t:Type.t) : value = (!encode_type_ref) t -let encode_expr (e:Ast.expr) : value = (!encode_expr_ref) e -let decode_expr (e:value) : Ast.expr = (!decode_expr_ref) e - -let to_int f = int_of_float (mod_float f 2147483648.0) - -let make_pos p = - { - Ast.pfile = p.psource; - Ast.pmin = if p.pline < 0 then 0 else p.pline land 0xFFFF; - Ast.pmax = if p.pline < 0 then 0 else p.pline lsr 16; - } - -let warn ctx msg p = - ctx.com.Common.warning msg (make_pos p) - -let catch_errors ctx ?(final=(fun() -> ())) f = - try - let v = f() in - final(); - Some v - with Runtime v -> - final(); - raise (Error (ctx.do_string v,List.map (fun (p,_,_) -> make_pos p) ctx.stack)) - | Abort -> - final(); - None - -let obj fields = - let h = Hashtbl.create 0 in - List.iter (fun (k,v) -> Hashtbl.replace h k v) fields; - { - ofields = h; - oproto = None; - } - -let exc v = - raise (Runtime v) - -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' when i = 1 && String.get s 0 = '0' -> loop_hex (i + 1) - | _ -> String.sub s sp (i - sp) - in - int_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 fname = - try - Hashtbl.find o.ofields fname - with Not_found -> - match o.oproto with - | None -> VNull - | Some p -> get_field p fname - -let rec get_field_opt o fname = - try - Some (Hashtbl.find o.ofields fname) - with Not_found -> - match o.oproto with - | None -> None - | Some p -> get_field_opt p fname - -let make_library fl = - let h = Hashtbl.create 0 in - List.iter (fun (n,f) -> Hashtbl.add h n f) fl; - h - -(* ---------------------------------------------------------------------- *) -(* 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 (obj []) - | VObject o -> VObject { ofields = Hashtbl.copy o.ofields; oproto = o.oproto } - | _ -> error() - ); - "objget", Fun2 (fun o f -> - match o with - | VObject o -> get_field o (vstring f) - | _ -> VNull - ); - "objset", Fun3 (fun o f v -> - match o with - | VObject o -> Hashtbl.replace o.ofields (vstring f) v; v - | _ -> VNull - ); - "objcall", Fun3 (fun o f pl -> - match o with - | VObject oo -> - (get_ctx()).do_call o (get_field oo (vstring f)) (Array.to_list (varray pl)) p - | _ -> VNull - ); - "objfield", Fun2 (fun o f -> - match o with - | VObject o -> VBool (Hashtbl.mem o.ofields (vstring f)) - | _ -> VBool false - ); - "objremove", Fun2 (fun o f -> - let o = vobj o in - let f = vstring f in - if Hashtbl.mem o.ofields f then begin - Hashtbl.remove o.ofields f; - VBool true - end else - VBool false - ); - "objfields", Fun1 (fun o -> - let fl = Hashtbl.fold (fun f _ acc -> VString f :: acc) (vobj o).ofields [] in - VArray (Array.of_list fl) - ); - "hash", Fun1 (fun v -> VString (String.copy (vstring v))); - "field", Fun1 (fun v -> VString (vstring v)); - "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 i -> v - | VFloat f -> VInt (to_int f) - | VString s -> (try VInt (parse_int s) with _ -> VNull) - | _ -> VNull - ); - "float", Fun1 (fun v -> - match v with - | VInt i -> VFloat (float_of_int 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) - | _ -> 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)) - | _ -> 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 - ctx.curapi.print (ctx.do_string v) - ) vl; VNull); - "throw", Fun1 (fun v -> exc v); - "rethrow", Fun1 (fun v -> - let ctx = get_ctx() in - ctx.stack <- List.rev (List.map (fun p -> p,VNull,PMap.empty) ctx.exc) @ ctx.stack; - exc v - ); - "istrue", Fun1 (fun v -> - match v with - | VNull | VInt 0 | VBool false -> VBool false - | _ -> VBool true - ); - "not", Fun1 (fun v -> - match v with - | VNull | VInt 0 | VBool false -> VBool true - | _ -> VBool false - ); - "typeof", Fun1 (fun v -> - VInt (match v with - | VNull -> 0 - | VInt _ -> 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 (p,_,_) -> p) (get_ctx()).stack) - ); - "version", Fun0 (fun() -> - VInt 0 - ); - (* extra *) - "delay_call",Fun1 (fun i -> - let ctx = get_ctx() in - match i with - | VInt i when i >= 0 && i < DynArray.length ctx.delayed -> (DynArray.get ctx.delayed i)() - | _ -> error() - ); - ] 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; - let loader = obj [ - "args",VArray [||]; - "loadprim",VFunction (Fun2 (fun a b -> (get_ctx()).do_loadprim a b)); - "loadmodule",VFunction (Fun2 (fun a b -> assert false)); - ] in - Hashtbl.add h "loader" (VObject loader); - Hashtbl.add h "exports" (VObject { ofields = Hashtbl.create 0; oproto = None }); - 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 - | VFloat f -> f - | _ -> error() - in - let make_date f = - VAbstract (AInt32 (Int32.of_float f)) - in - let date = function - | VAbstract (AInt32 i) -> Int32.to_float i - | VInt i -> float_of_int i - | _ -> error() - in - let make_i32 i = - VAbstract (AInt32 i) - in - let int32 = function - | VInt i -> Int32.of_int i - | VAbstract (AInt32 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) - | VFloat f -> VFloat (abs_float f) - | _ -> error() - ); - "math_ceil", Fun1 (fun v -> VInt (to_int (ceil (num v)))); - "math_floor", Fun1 (fun v -> VInt (to_int (floor (num v)))); - "math_round", Fun1 (fun v -> VInt (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 (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 n -> v - | VFloat f -> VInt (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 _ -> - 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 [ - "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 [ - "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 - | VAbstract (AInt32 i) -> 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 -> - match f, big with - | VFloat f, 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 -> - match f, big with - | VFloat f, 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 - | _ -> 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 - VAbstract (AInt32 (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 - | VAbstract (AInt32 h) -> VString (Unix.string_of_inet_addr (int32_addr h)); - | _ -> error() - ); - "host_reverse", Fun1 (fun h -> - match h with - | VAbstract (AInt32 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), VAbstract (AInt32 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 -> Unix.sleep (int_of_float (ceil f)); VNull - | _ -> error() - ); - "set_time_locale", Fun1 (fun l -> - match l with - | VString s -> VBool false (* always fail *) - | _ -> error() - ); - "get_cwd", Fun0 (fun() -> - VString (Unix.getcwd()) - ); - "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 (Sys.command (vstring cmd)) - ); - "sys_exit", Fun1 (fun code -> - 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 [ - "gid", VInt s.st_gid; - "uid", VInt s.st_uid; - "atime", VAbstract (AInt32 (Int32.of_float s.st_atime)); - "mtime", VAbstract (AInt32 (Int32.of_float s.st_mtime)); - "ctime", VAbstract (AInt32 (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 = Array.length d then - acc - else - loop (VArray [|VString d.(i);acc|]) (i + 1) - in - loop VNull 0 - ); - "file_full_path", Fun1 (fun file -> - VString (Extc.get_full_path (vstring file)) - ); - "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 = Array.length env then - acc - else - let e, v = ExtString.String.split "=" env.(i) in - loop (VArray [|VString e;VString v;acc|]) (i + 1) - in - loop VNull 0 - ); - "sys_getch", Fun1 (fun echo -> - match echo with - | VBool _ -> VInt (int_of_char (input_char Pervasives.stdin)) - | _ -> 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", 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 "xml" in - let don = get_field events "done" in - let pcdata = get_field events "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 "cdata" in - let comment = get_field events "comment" in - *) - let rec loop = function - | Xml.Element (node, attribs, children) -> - ignore(ctx.do_call o xml [VString node;VObject (obj (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() - ); - (* process *) - (* TODO *) - (* memory, module, thread : not planned *) - ] - -(* ---------------------------------------------------------------------- *) -(* REGEXP LIBRARY *) - -let reg_lib = - let error() = - raise Builtin_error - in - make_library [ - (* regexp_new : deprecated *) - "regexp_new_options", Fun2 (fun str opt -> - match str, opt with - | VString str, VString opt -> - List.iter (function - | 'm' -> () (* always ON ? *) - | 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' - | '\\' -> 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 = Str.regexp 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 ["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 *) - ] - -(* ---------------------------------------------------------------------- *) -(* 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 [ - "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 (AZipI 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 [ - "done", VBool r.Extc.z_finish; - "read", VInt r.Extc.z_read; - "write", VInt r.Extc.z_wrote; - ]) - | _ -> error() - ); - ] - -(* ---------------------------------------------------------------------- *) -(* MACRO LIBRARY *) - -let macro_lib = - let error() = - raise Builtin_error - 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) -> (get_ctx()).com.Common.error s p; raise Abort - | _ -> error() - ); - "warning", Fun2 (fun msg p -> - match msg, p with - | VString s, VAbstract (APos p) -> (get_ctx()).com.Common.warning s p; VNull; - | _ -> error() - ); - "class_path", Fun0 (fun() -> - let cp = (get_ctx()).com.Common.class_path in - VArray (Array.of_list (List.map (fun s -> VString s) cp)); - ); - "resolve", Fun1 (fun file -> - match file with - | VString s -> VString (try Common.find_file (get_ctx()).com s with Not_found -> failwith ("File not found '" ^ s ^ "'")) - | _ -> error(); - ); - "defined", Fun1 (fun s -> - match s with - | VString s -> VBool ((get_ctx()).curapi.defined s) - | _ -> 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() - ); - "parse", Fun2 (fun s p -> - match s, p with - | VString s, VAbstract (APos p) -> encode_expr ((get_ctx()).curapi.parse_string s p) - | _ -> error() - ); - "signature", Fun1 (fun v -> - let cache = ref [] in - let rec loop v = - match v with - | VNull | VBool _ | VInt _ | VFloat _ | VString _ -> v - | VAbstract (AInt32 _ | APos _) -> v - | _ -> - try - List.assq v !cache - with Not_found -> - match v with - | VObject o -> - let o2 = { ofields = Hashtbl.create 0; oproto = None } in - let v2 = VObject o2 in - cache := (v,v2) :: !cache; - Hashtbl.iter (fun k v -> - if k <> "__class__" then Hashtbl.add o2.ofields k (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 - cache := (v,v2) :: !cache; - for i = 0 to Array.length a - 1 do - a2.(i) <- loop a.(i); - done; - v2 - | VFunction f -> - let v2 = VFunction (Obj.magic (List.length !cache)) in - cache := (v,v2) :: !cache; - v2 - | VClosure (vl,f) -> - let v2 = VClosure ([], Obj.magic (List.length !cache)) in - cache := (v,v2) :: !cache; - v2 - | VAbstract (AHash h) -> - let h2 = Hashtbl.create 0 in - let v2 = VAbstract (AHash h2) in - cache := (v, v2) :: !cache; - Hashtbl.iter (fun k v -> Hashtbl.add h2 k (loop v)) h2; - v2 - | VAbstract _ -> - let v2 = VAbstract (Obj.magic (List.length !cache)) in - cache := (v, v2) :: !cache; - v2 - | _ -> assert false - in - let v = loop v in - VString (Digest.to_hex (Digest.string (Marshal.to_string v [Marshal.Closures]))) - ); - "typeof", Fun1 (fun v -> - encode_type ((get_ctx()).curapi.typeof (decode_expr v)) - ); - "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 ["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 (get_ctx()).com.Common.resources name data; VNull - | _ -> error() - ); - "curclass", Fun0 (fun() -> - match (get_ctx()).curapi.get_cur_class() with - | None -> VNull - | Some c -> encode_type (TInst (c,[])) - ); - ] - -(* ---------------------------------------------------------------------- *) -(* EVAL *) - -let throw ctx p msg = - ctx.stack <- (p,ctx.vthis,ctx.locals) :: ctx.stack; - exc (VString msg) - -let local ctx var value = - ctx.locals <- PMap.add var (ref value) ctx.locals - -let get_ident ctx s = - try - !(PMap.find s ctx.locals) - with Not_found -> try - Hashtbl.find ctx.globals s - with Not_found -> - VNull - -let rec eval ctx (e,p) = - match e with - | EConst c -> - (match c with - | True -> VBool true - | False -> VBool false - | Null -> VNull - | This -> ctx.vthis - | Int i -> VInt i - | Float f -> VFloat (float_of_string f) - | String s -> VString s - | Builtin s -> (try Hashtbl.find builtins s with Not_found -> throw ctx p ("Builtin not found '" ^ s ^ "'")) - | Ident s -> get_ident ctx s) - | EBlock el -> - let rec loop = function - | [] -> VNull - | [e] -> eval ctx e - | e :: l -> - ignore(eval ctx e); - loop l - in - let old = ctx.locals in - let v = loop el in - ctx.locals <- old; - v - | EParenthesis e -> - eval ctx e - | EField (e,f) -> - (match eval ctx e with - | VObject o -> get_field o f - | _ -> throw ctx p ("Invalid field access : " ^ f)) - | ECall (e,el) -> - let pl = List.map (eval ctx) el in - (match fst e with - | EField (e,f) -> - let o = eval ctx e in - let f = (match o with - | VObject o -> get_field o f - | _ -> throw ctx p ("Invalid field access : " ^ f) - ) in - call ctx o f pl p - | _ -> - call ctx ctx.vthis (eval ctx e) pl p) - | EArray (e1,e2) -> - let index = eval ctx e2 in - acc_get ctx p (AccArray (eval ctx e1,index)); - | EVars vl -> - List.iter (fun (v,eo) -> - let value = (match eo with None -> VNull | Some e -> eval ctx e) in - local ctx v value - ) vl; - VNull - | EWhile (econd,e,NormalWhile) -> - let rec loop() = - match eval ctx econd with - | VBool true -> - let v = (try - ignore(eval ctx e); None - with - | Continue -> None - | Break v -> Some v - ) in - (match v with - | None -> loop() - | Some v -> v) - | _ -> - VNull - in - (try loop() with Sys.Break -> throw ctx p "Ctrl+C") - | EWhile (econd,e,DoWhile) -> - let rec loop() = - let v = (try - ignore(eval ctx e); None - with - | Continue -> None - | Break v -> Some v - ) in - match v with - | Some v -> v - | None -> - match eval ctx econd with - | VBool true -> loop() - | _ -> VNull - in - loop() - | EIf (econd,eif,eelse) -> - (match eval ctx econd with - | VBool true -> eval ctx eif - | _ -> match eelse with - | None -> VNull - | Some e -> eval ctx e) - | ETry (e,exc,ecatch) -> - let locals = ctx.locals in - let vthis = ctx.vthis in - let stack = ctx.stack in - (try - eval ctx e - with Runtime v -> - let rec loop n l = - if n = 0 then List.map (fun (p,_,_) -> p) l else - match l with - | [] -> [] - | _ :: l -> loop (n - 1) l - in - ctx.exc <- loop (List.length stack) (List.rev ctx.stack); - ctx.stack <- stack; - ctx.locals <- locals; - ctx.vthis <- vthis; - local ctx exc v; - eval ctx ecatch); - | EFunction (pl,e) -> - let locals = ctx.locals in - VFunction (match pl with - | [] -> - Fun0 (fun() -> - ctx.locals <- locals; - eval ctx e - ) - | [a] -> - Fun1 (fun v -> - ctx.locals <- locals; - local ctx a v; - eval ctx e - ) - | [a;b] -> - Fun2 (fun va vb -> - ctx.locals <- locals; - local ctx a va; - local ctx b vb; - eval ctx e - ) - | [a;b;c] -> - Fun3 (fun va vb vc -> - ctx.locals <- locals; - local ctx a va; - local ctx b vb; - local ctx c vc; - eval ctx e - ) - | [a;b;c;d] -> - Fun4 (fun va vb vc vd -> - ctx.locals <- locals; - local ctx a va; - local ctx b vb; - local ctx c vc; - local ctx d vd; - eval ctx e - ) - | [a;b;c;d;pe] -> - Fun5 (fun va vb vc vd ve -> - ctx.locals <- locals; - local ctx a va; - local ctx b vb; - local ctx c vc; - local ctx d vd; - local ctx pe ve; - eval ctx e - ) - | pl -> - FunVar (fun vl -> - if List.length vl != List.length pl then exc (VString "Invalid call"); - ctx.locals <- locals; - List.iter2 (local ctx) pl vl; - eval ctx e - ) - ) - | EBinop (op,e1,e2) -> - eval_op ctx op e1 e2 p - | EReturn None -> - raise (Return VNull) - | EReturn (Some e) -> - raise (Return (eval ctx e)) - | EBreak None -> - raise (Break VNull) - | EBreak (Some e) -> - raise (Break (eval ctx e)) - | EContinue -> - raise Continue - | ENext (e1,e2) -> - ignore(eval ctx e1); - eval ctx e2 - | EObject fl -> - let o = { - ofields = Hashtbl.create 0; - oproto = None; - } in - List.iter (fun (f,e) -> - Hashtbl.add o.ofields f (eval ctx e) - ) fl; - VObject o - | ELabel l -> - assert false - | ESwitch (e,el,eo) -> - let v = eval ctx e in - let rec loop = function - | [] -> - (match eo with - | None -> VNull - | Some e -> eval ctx e) - | (c,e) :: l -> - if ctx.do_compare v (eval ctx c) = CEq then eval ctx e else loop l - in - loop el - | 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 idx = eval ctx eindex in - let v = eval ctx e in - AccArray (v,idx) - | EConst (Ident s) -> - AccVar s - | _ -> - throw ctx p "Invalid assign" - -and acc_get ctx p = function - | AccField (v,f) -> - (match v with - | VObject o -> get_field o f - | _ -> throw ctx p ("Invalid field access : " ^ f)) - | AccArray (e,index) -> - (match index, e with - | VInt i, VArray a -> (try Array.get a i with _ -> VNull) - | _, VObject o -> - (match eval_oop ctx p o "__get" [index] with - | None -> throw ctx p "Invalid array access" - | Some v -> v) - | _ -> throw ctx p "Invalid array access") - | AccVar s -> - get_ident ctx s - -and acc_set ctx p acc value = - match acc with - | AccField (v,f) -> - (match v with - | VObject o -> Hashtbl.replace o.ofields f value; value - | _ -> throw ctx p ("Invalid field access : " ^ f)) - | AccArray (e,index) -> - (match index, e with - | VInt i, VArray a -> (try Array.set a i value; value with _ -> throw ctx p "Invalid array access") - | _, VObject o -> - (match eval_oop ctx p o "__set" [index;value] with - | None -> throw ctx p "Invalid array access" - | Some _ -> value); - | _ -> throw ctx p "Invalid array access") - | AccVar s -> - (try - let v = PMap.find s ctx.locals in - v := value; - with Not_found -> - Hashtbl.replace ctx.globals s value); - value - -and number_op ctx p sop iop fop oop rop v1 v2 = - match v1, v2 with - | VInt a, VInt b -> VInt (iop a b) - | VFloat a, VInt b -> VFloat (fop a (float_of_int b)) - | VInt a, VFloat b -> VFloat (fop (float_of_int a) b) - | VFloat a, VFloat b -> VFloat (fop 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 = - match v1, v2 with - | VInt a, VInt b -> VInt (iop a b) - | _ -> throw ctx p op - -and base_op ctx op v1 v2 p = - match op with - | "+" -> - (match v1, v2 with - | VInt _, VInt _ | VInt _ , VFloat _ | VFloat _ , VInt _ | VFloat _ , VFloat _ | VObject _ , _ | _ , VObject _ -> number_op ctx p op (+) (+.) "__add" "__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 (-) (-.) "__sub" "__rsub" v1 v2 - | "*" -> - number_op ctx p op ( * ) ( *. ) "__mult" "__rmul" v1 v2 - | "/" -> - (match v1, v2 with - | VInt i, VInt j -> VFloat ((float_of_int i) /. (float_of_int j)) - | _ -> number_op ctx p op (/) (/.) "__div" "__rdiv" v1 v2) - | "%" -> - number_op ctx p op (fun x y -> x mod y) mod_float "__mod" "__rmod" v1 v2 - | "&" -> - int_op ctx p op (fun x y -> x land y) v1 v2 - | "|" -> - int_op ctx p op (fun x y -> x lor y) v1 v2 - | "^" -> - int_op ctx p op (fun x y -> x lxor y) v1 v2 - | "<<" -> - int_op ctx p op (fun x y -> x lsl y) v1 v2 - | ">>" -> - int_op ctx p op (fun x y -> x asr y) v1 v2 - | ">>>" -> - int_op ctx p op (fun x y -> - if x >= 0 then x lsr y else Int32.to_int (Int32.shift_right_logical (Int32.of_int x) 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 - (match ctx.do_compare v1 v2 with - | CEq -> VBool true - | _ -> VBool false) - | "!=" -> - let v1 = eval ctx e1 in - let v2 = eval ctx e2 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 - (match ctx.do_compare v1 v2 with - | CSup -> VBool true - | _ -> VBool false) - | ">=" -> - let v1 = eval ctx e1 in - let v2 = eval ctx e2 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 - (match ctx.do_compare v1 v2 with - | CInf -> VBool true - | _ -> VBool false) - | "<=" -> - let v1 = eval ctx e1 in - let v2 = eval ctx e2 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 acc = eval_access ctx e1 in - let v1 = acc_get ctx p acc 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 acc v - | "&&" -> - (match eval ctx e1 with - | VBool false as v -> v - | _ -> eval ctx e2) - | "||" -> - (match eval ctx e1 with - | VBool true as v -> v - | _ -> eval ctx e2) - | "++=" | "--=" -> - let acc = eval_access ctx e1 in - let v1 = acc_get ctx p acc in - let v2 = eval ctx e2 in - let v = base_op ctx (String.sub op 0 1) v1 v2 p in - ignore(acc_set ctx p acc v); - v1 - | _ -> - throw ctx p ("Unsupported " ^ op) - -and call ctx vthis vfun pl p = - let oldthis = ctx.vthis in - let locals = ctx.locals in - let oldstack = ctx.stack in - ctx.locals <- PMap.empty; - ctx.vthis <- vthis; - ctx.stack <- (p,oldthis,locals) :: ctx.stack; - 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)))) - | _ -> - exc (VString ("Invalid call " ^ ctx.do_string vfun))) - with Return v -> v - | Sys_error msg | Failure msg -> exc (VString msg) - | Unix.Unix_error (_,cmd,msg) -> exc (VString ("Error " ^ cmd ^ " " ^ msg)) - | Builtin_error | Invalid_argument _ -> exc (VString "Invalid call")) in - ctx.locals <- locals; - ctx.vthis <- oldthis; - ctx.stack <- oldstack; - 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 - | VFloat f -> string_of_float f - | 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 ^ ")" - | AInt32 i -> Int32.to_string i - | _ -> "#abstract") - | VFunction f -> "#function:" ^ string_of_int (nargs f) - | VClosure _ -> "#function:-1" - | VObject o -> - match eval_oop ctx null_pos o "__string" [] with - | Some (VString s) -> s - | _ -> - let b = Buffer.create 0 in - let first = ref true in - Buffer.add_char b '{'; - Hashtbl.iter (fun f v -> - if !first then begin - Buffer.add_char b ' '; - first := false; - end else - Buffer.add_string b ", "; - Buffer.add_string b 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 - match a, b with - | VNull, VNull -> CEq - | VInt a, VInt b -> if a = b then CEq else if a < b then CInf else CSup - | VFloat a, VFloat b -> fcmp a b - | VFloat a, VInt b -> fcmp a (float_of_int b) - | VInt a, VFloat b -> fcmp (float_of_int 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 - | VFloat _ , VString s - | VBool _ , VString s -> scmp (to_string ctx 0 a) s - | VString s, VInt _ - | 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 "__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 alloc_delayed ctx f = - let pos = DynArray.length ctx.delayed in - DynArray.add ctx.delayed f; - pos - -let create com api = - let ctx = { - com = com; - gen = Genneko.new_context com true; - types = Hashtbl.create 0; - error = false; - prototypes = Hashtbl.create 0; - globals = Hashtbl.create 0; - enums = [||]; - locals = PMap.empty; - stack = []; - exc = []; - vthis = VNull; - (* api *) - do_call = Obj.magic(); - do_string = Obj.magic(); - do_loadprim = Obj.magic(); - do_compare = Obj.magic(); - (* context *) - curapi = api; - delayed = DynArray.create(); - } 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 add_types ctx types = - 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 true; - true; - end - ) types in - 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 f in - call ctx (VObject o) f vl p - | _ -> assert false - ) - -let unwind_stack ctx = - match ctx.stack with - | [] -> () - | (p,vthis,locals) :: l -> - ctx.stack <- l; - ctx.vthis <- vthis; - ctx.locals <- locals - -(* ---------------------------------------------------------------------- *) -(* EXPR ENCODING *) - -type enum_index = - | IExpr - | IBinop - | IUnop - | IConst - | ITParam - | ICType - | IField - | IType - | IFieldKind - | IMethodKind - | IVarAccess - -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" - -let init ctx = - let enums = [IExpr;IBinop;IUnop;IConst;ITParam;ICType;IField;IType;IFieldKind;IMethodKind;IVarAccess] in - let get_enum_proto e = - match get_path ctx ["haxe";"macro";enum_name e] null_pos with - | VObject e -> - (match get_field e "__constructs__" with - | VObject cst -> - (match get_field cst "__a" with - | VArray a -> - Array.map (fun s -> - match s with - | VObject s -> (match get_field s "__s" with VString s -> get_field e 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) - -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 h = Hashtbl.create 0 in - List.iter (fun (f,v) -> Hashtbl.add h f v) 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 -> o - | _ -> raise (Runtime VNull)) - with Runtime _ -> - failwith ("Prototype not found " ^ String.concat "." path) - ) in - VObject { - ofields = h; - oproto = Some p; - } - -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 ["Hash"] [ - "h", VAbstract (AHash h); - ] - -let enc_obj l = VObject (obj 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 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] - | Type s -> 4, [enc_string s] - | Regexp (s,opt) -> 5, [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, [] - 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 = - enc_obj [ - "pack", enc_array (List.map enc_string t.tpackage); - "name", enc_string t.tname; - "params", enc_array (List.map encode_tparam t.tparams); - "sub", null enc_string t.tsub; - ] - -and encode_tparam = function - | TPType t -> enc_enum ITParam 0 [encode_type t] - | TPConst c -> enc_enum ITParam 1 [encode_const c] - -and encode_field (f,pub,field,pos) = - let tag, pl = match field with - | AFVar t -> 0, [encode_type t] - | AFProp (t,get,set) -> 1, [encode_type t; enc_string get; enc_string set] - | AFFun (pl,t) -> 2, [enc_array (List.map (fun (n,opt,t) -> - enc_obj [ - "name", enc_string n; - "opt", VBool opt; - "type", encode_type t - ] - ) pl); encode_type t] - in - enc_obj [ - "name",enc_string f; - "isPublic",null (fun b -> VBool b) pub; - "type", enc_enum IField tag pl; - "pos", encode_pos pos; - ] - -and encode_type t = - let tag, pl = match t with - | CTPath p -> - 0, [encode_path p] - | CTFunction (pl,r) -> - 1, [enc_array (List.map encode_type pl);encode_type r] - | CTAnonymous fl -> - 2, [enc_array (List.map encode_field fl)] - | CTParent t -> - 3, [encode_type t] - | CTExtend (t,fields) -> - 4, [encode_path t; enc_array (List.map encode_field fields)] - in - enc_enum ICType tag pl - -let 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] - | EType (e,f) -> - 4, [loop e;enc_string f] - | EParenthesis e -> - 5, [loop e] - | EObjectDecl fl -> - 6, [enc_array (List.map (fun (f,e) -> enc_obj [ - "field",enc_string f; - "expr",loop e; - ]) fl)] - | EArrayDecl el -> - 7, [enc_array (List.map loop el)] - | ECall (e,el) -> - 8, [loop e;enc_array (List.map loop el)] - | ENew (p,el) -> - 9, [encode_path p; enc_array (List.map loop el)] - | EUnop (op,flag,e) -> - 10, [encode_unop op; VBool (match flag with Prefix -> false | Postfix -> true); loop e] - | EVars vl -> - 11, [enc_array (List.map (fun (v,t,eo) -> - enc_obj [ - "name",enc_string v; - "type",null encode_type t; - "expr",null loop eo; - ] - ) vl)] - | EFunction (name,f) -> - 12, [enc_obj [ - "name", null enc_string name; - "args", enc_array (List.map (fun (n,opt,t,e) -> - enc_obj [ - "name", enc_string n; - "opt", VBool opt; - "type", null encode_type t; - "value", null loop e; - ] - ) f.f_args); - "ret", null encode_type f.f_type; - "expr", loop f.f_expr - ]] - | EBlock el -> - 13, [enc_array (List.map loop el)] - | EFor (v,e,eloop) -> - 14, [enc_string v;loop e;loop eloop] - | 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,e) -> - enc_obj [ - "values",enc_array (List.map loop ecl); - "expr",loop e - ] - ) cases);null loop eopt] - | ETry (e,catches) -> - 18, [loop e;enc_array (List.map (fun (v,t,e) -> - enc_obj [ - "name",enc_string v; - "type",encode_type 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_type 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] - in - enc_obj [ - "pos", encode_pos p; - "expr", enc_enum IExpr tag pl; - ] - in - loop e - -(* ---------------------------------------------------------------------- *) -(* EXPR DECODING *) - -exception Invalid_expr - -let opt f v = - match v with - | VNull -> None - | _ -> Some (f v) - -let decode_pos = function - | VAbstract (APos p) -> p - | _ -> raise Invalid_expr - -let field v f = - match v with - | VObject o -> (try Hashtbl.find o.ofields f with Not_found -> VNull) - | _ -> 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] -> Type (dec_string s) - | 5, [s;opt] -> Regexp (dec_string s, dec_string opt) - | _ -> 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 - | _ -> 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_type t) - | 1,[c] -> TPConst (decode_const c) - | _ -> raise Invalid_expr - -and decode_field v = - let ftype = match decode_enum (field v "type") with - | 0, [t] -> - AFVar (decode_type t) - | 1, [t;get;set] -> - AFProp (decode_type t, dec_string get, dec_string set) - | 2, [pl;t] -> - let pl = List.map (fun p -> - (dec_string (field p "name"),dec_bool (field p "opt"),decode_type (field p "type")) - ) (dec_array pl) in - AFFun (pl, decode_type t) - | _ -> - raise Invalid_expr - in - ( - dec_string (field v "name"), - opt dec_bool (field v "isPublic"), - ftype, - decode_pos (field v "pos") - ) - -and decode_type t = - match decode_enum t with - | 0, [p] -> - CTPath (decode_path p) - | 1, [a;r] -> - CTFunction (List.map decode_type (dec_array a), decode_type r) - | 2, [fl] -> - CTAnonymous (List.map decode_field (dec_array fl)) - | 3, [t] -> - CTParent (decode_type t) - | 4, [t;fl] -> - CTExtend (decode_path t, List.map decode_field (dec_array fl)) - | _ -> - raise Invalid_expr - -let 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;f] -> - EType (loop e, dec_string f) - | 5, [e] -> - EParenthesis (loop e) - | 6, [a] -> - EObjectDecl (List.map (fun o -> - (dec_string (field o "field"), loop (field o "expr")) - ) (dec_array a)) - | 7, [a] -> - EArrayDecl (List.map loop (dec_array a)) - | 8, [e;el] -> - ECall (loop e,List.map loop (dec_array el)) - | 9, [t;el] -> - ENew (decode_path t,List.map loop (dec_array el)) - | 10, [op;VBool f;e] -> - EUnop (decode_unop op,(if f then Postfix else Prefix),loop e) - | 11, [vl] -> - EVars (List.map (fun v -> - (dec_string (field v "name"),opt decode_type (field v "type"),opt loop (field v "expr")) - ) (dec_array vl)) - | 12, [f] -> - let ft = { - f_args = List.map (fun o -> - (dec_string (field o "name"),dec_bool (field o "opt"),opt decode_type (field o "type"),opt loop (field o "value")) - ) (dec_array (field f "args")); - f_type = opt decode_type (field f "ret"); - f_expr = loop (field f "expr"); - } in - EFunction (opt dec_string (field f "name"),ft) - | 13, [el] -> - EBlock (List.map loop (dec_array el)) - | 14, [v;e1;e2] -> - EFor (dec_string v, 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")),loop (field c "expr")) - ) (dec_array cases) in - ESwitch (loop e,cases,opt loop eo) - | 18, [e;catches] -> - let catches = List.map (fun c -> - (dec_string (field c "name"),decode_type (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_type 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) - | _ -> - raise Invalid_expr - in - loop 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()))); - ] - -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() -> - enc_array (List.map (fun (m,ml,p) -> - enc_obj [ - "name", enc_string m; - "params", enc_array (List.map encode_expr ml); - "pos", encode_pos p; - ] - ) (!meta)) - )); - "add", VFunction (Fun3 (fun k vl p -> - (try - let el = List.map decode_expr (dec_array vl) in - meta := (dec_string k, el, decode_pos p) :: !meta; - set (!meta) - with Invalid_expr -> - failwith "Invalid expression"); - VNull - )); - "remove", VFunction (Fun1 (fun k -> - let k = (try dec_string k with Invalid_expr -> raise Builtin_error) in - meta := List.filter (fun (m,_,_) -> m <> k) (!meta); - set (!meta); - VNull - )); - ] - -let rec encode_tenum e = - enc_obj [ - "__t", encode_tdecl (TEnumDecl e); - "pack", enc_array (List.map enc_string (fst e.e_path)); - "name", enc_string (snd e.e_path); - "pos", encode_pos e.e_pos; - "isPrivate", VBool e.e_private; - "isExtern", VBool e.e_extern; - "exclude", VFunction (Fun0 (fun() -> e.e_extern <- true; VNull)); - "params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) e.e_types); - "contructs", encode_pmap encode_efield e.e_constrs; - "names", enc_array (List.map enc_string e.e_names); - "meta", encode_meta e.e_meta (fun m -> e.e_meta <- m); - ] - -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); - ] - -and encode_cfield f = - enc_obj [ - "name", enc_string f.cf_name; - "type", encode_type f.cf_type; - "isPublic", VBool f.cf_public; - "params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) f.cf_params); - "meta", encode_meta f.cf_meta (fun m -> f.cf_meta <- m); - "expr", (match f.cf_expr with None -> VNull | Some e -> encode_texpr e); - "kind", encode_field_kind f.cf_kind; - ] - -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 s -> 4, [enc_string s] - | AccInline -> 5, [] - | AccRequire s -> 6, [enc_string s] - ) 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_tclass c = - enc_obj [ - "__t", encode_tdecl (TClassDecl c); - "pack", enc_array (List.map enc_string (fst c.cl_path)); - "name", enc_string (snd c.cl_path); - "pos", encode_pos c.cl_pos; - "isPrivate", VBool c.cl_private; - "isExtern", VBool c.cl_extern; - "exclude", VFunction (Fun0 (fun() -> c.cl_extern <- true; c.cl_init <- None; VNull)); - "params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) c.cl_types); - "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")); - "meta", encode_meta c.cl_meta (fun m -> c.cl_meta <- m); - "init", (match c.cl_init with None -> VNull | Some e -> encode_texpr e); - ] - -and encode_ttype t = - enc_obj [ - "__t", encode_tdecl (TTypeDecl t); - "pack", enc_array (List.map enc_string (fst t.t_path)); - "name", enc_string (snd t.t_path); - "pos", encode_pos t.t_pos; - "isPrivate", VBool t.t_private; - "isExtern", VBool false; - "exclude", VFunction (Fun0 (fun() -> VNull)); - "params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) t.t_types); - "type", encode_type t.t_type; - "meta", encode_meta t.t_meta (fun m -> t.t_meta <- m); - ] - -and encode_tdecl t = - VAbstract (ATDecl t) - -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, [] - | 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)()) - in - let tag, pl = loop t in - enc_enum IType tag pl - -and encode_texpr e = - VAbstract (ATExpr e) - -let decode_tdecl v = - match v with - | VObject o -> - (match get_field o "__t" with - | VAbstract (ATDecl t) -> t - | _ -> raise Invalid_expr) - | _ -> raise Invalid_expr - -(* ---------------------------------------------------------------------- *) -(* VALUE-TO-CONSTANT *) - -let rec make_const e = - match e.eexpr with - | TConst c -> - (match c with - | TInt i -> (try VInt (Int32.to_int i) with _ -> raise Exit) - | 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 (List.map (fun (f,e) -> f, make_const e) el)) - | TArrayDecl al -> - enc_array (List.map make_const al) - | _ -> - raise Exit - -;; -enc_array_ref := enc_array; -encode_type_ref := encode_type; -encode_expr_ref := encode_expr; -decode_expr_ref := decode_expr \ No newline at end of file diff --git a/haxe/main.ml b/haxe/main.ml deleted file mode 100755 index 14d595b7ebeb94a23d03329dd1348e3bacaa9c9b..0000000000000000000000000000000000000000 --- a/haxe/main.ml +++ /dev/null @@ -1,719 +0,0 @@ -(* - * Haxe Compiler - * Copyright (c)2005-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 Printf -open Genswf -open Common - -let version = 207 - -let prompt = ref false -let measure_times = ref false -let start = get_time() - -let executable_path() = - Extc.executable_path() - -let normalize_path p = - let l = String.length p in - if l = 0 then - "./" - else match p.[l-1] with - | '\\' | '/' -> p - | _ -> p ^ "/" - -let format msg p = - if p = Ast.null_pos then - msg - else begin - let error_printer file line = sprintf "%s:%d:" file line in - let epos = Lexer.get_error_pos error_printer p in - let msg = String.concat ("\n" ^ epos ^ " : ") (ExtString.String.nsplit msg "\n") in - sprintf "%s : %s" epos msg - end - -let message msg p = - prerr_endline (format msg p) - -let messages = ref [] - -let store_message msg p = - messages := format msg p :: !messages - -let do_exit() = - List.iter prerr_endline (List.rev (!messages)); - if !prompt then begin - print_endline "Press enter to exit..."; - ignore(read_line()); - end; - exit 1 - -let report msg p = - messages := format msg p :: !messages; - do_exit() - -let htmlescape s = - let s = String.concat "<" (ExtString.String.nsplit s "<") in - let s = String.concat ">" (ExtString.String.nsplit s ">") in - s - -let report_list l = - prerr_endline ""; - List.iter (fun (n,t,d) -> - prerr_endline (Printf.sprintf "%s%s" n (htmlescape t) (htmlescape d)); - ) (List.sort (fun (a,_,_) (b,_,_) -> compare a b) l); - prerr_endline "" - -let file_extension f = - let cl = ExtString.String.nsplit f "." in - match List.rev cl with - | [] -> "" - | x :: _ -> x - -let make_path f = - let f = String.concat "/" (ExtString.String.nsplit f "\\") in - let cl = ExtString.String.nsplit f "." in - let cl = (match List.rev cl with - | ["hx";path] -> ExtString.String.nsplit path "/" - | _ -> cl - ) in - let error() = failwith ("Invalid class name " ^ f) in - let invalid_char x = - for i = 1 to String.length x - 1 do - match x.[i] with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> () - | _ -> error() - done; - false - in - let rec loop = function - | [] -> error() - | [x] -> if String.length x = 0 || not (x.[0] = '_' || (x.[0] >= 'A' && x.[0] <= 'Z')) || invalid_char x then error() else [] , x - | x :: l -> - if String.length x = 0 || x.[0] < 'a' || x.[0] > 'z' || invalid_char x then error() else - let path , name = loop l in - x :: path , name - in - loop cl - -let unique l = - let rec _unique = function - | [] -> [] - | x1 :: x2 :: l when x1 = x2 -> _unique (x2 :: l) - | x :: l -> x :: _unique l - in - _unique (List.sort compare l) - -let rec read_type_path com p = - let classes = ref [] in - let packages = ref [] in - let p = (match p with - | x :: l -> - (try - match PMap.find x com.package_rules with - | Directory d -> d :: l - | Remap s -> s :: l - | _ -> p - with - Not_found -> p) - | _ -> p - ) in - List.iter (fun path -> - let dir = path ^ String.concat "/" p in - let r = (try Sys.readdir dir with _ -> [||]) in - Array.iter (fun f -> - if (try (Unix.stat (dir ^ "/" ^ f)).Unix.st_kind = Unix.S_DIR with _ -> false) then begin - if f.[0] >= 'a' && f.[0] <= 'z' then begin - if p = ["."] then - match read_type_path com [f] with - | [] , [] -> () - | _ -> - try - match PMap.find f com.package_rules with - | Forbidden -> () - | Remap f -> packages := f :: !packages - | Directory _ -> raise Not_found - with Not_found -> - packages := f :: !packages - else - packages := f :: !packages - end; - end else if file_extension f = "hx" then begin - let c = Filename.chop_extension f in - if String.length c < 2 || String.sub c (String.length c - 2) 2 <> "__" then classes := c :: !classes; - end; - ) r; - ) com.class_path; - List.iter (fun (_,_,extract) -> - Hashtbl.iter (fun (path,name) _ -> - if path = p then classes := name :: !classes else - let rec loop p1 p2 = - match p1, p2 with - | [], _ -> () - | x :: _, [] -> packages := x :: !packages - | a :: p1, b :: p2 -> if a = b then loop p1 p2 - in - loop path p - ) (extract()); - ) com.swf_libs; - unique !packages, unique !classes - -let delete_file f = try Sys.remove f with _ -> () - -let expand_env path = - let r = Str.regexp "%\\([^%]+\\)%" in - Str.global_substitute r (fun s -> try Sys.getenv (Str.matched_group 1 s) with Not_found -> "") path - -let parse_hxml file = - let ch = IO.input_channel (try open_in_bin file with _ -> failwith ("File not found " ^ file)) in - let lines = Str.split (Str.regexp "[\r\n]+") (IO.read_all ch) in - IO.close_in ch; - List.concat (List.map (fun l -> - let l = ExtString.String.strip l in - let renv = Str.regexp "%\\([A-Za-z0-9_]+\\)%" in - let l = Str.global_substitute renv (fun _ -> - let e = Str.matched_group 1 l in - try Sys.getenv e with Not_found -> "%" ^ e ^ "%" - ) l in - if l = "" || l.[0] = '#' then - [] - else if l.[0] = '-' then - try - let a, b = ExtString.String.split l " " in - [a; b] - with - _ -> [l] - else - [l] - ) lines) - -let lookup_classes com fpath = - let spath = String.lowercase fpath in - let rec loop = function - | [] -> [] - | cp :: l -> - let cp = (if cp = "" then "./" else cp) in - let c = normalize_path (try Common.get_full_path cp with _ -> cp) in - let clen = String.length c in - if clen < String.length fpath && String.sub spath 0 clen = String.lowercase c then begin - let path = String.sub fpath clen (String.length fpath - clen) in - (try [make_path path] with _ -> loop l) - end else - loop l - in - loop com.class_path - -exception Hxml_found - -let rec process_params acc = function - | [] -> - init (List.rev acc) false - | "--next" :: l -> - init (List.rev acc) true; - process_params [] l - | x :: l -> - process_params (x :: acc) l - -and init params has_next = - let usage = Printf.sprintf - "haXe Compiler %d.%.2d - (c)2005-2011 Motion-Twin\n Usage : haxe%s -main [-swf|-js|-neko|-php|-cpp|-as3] [options]\n Options :" - (version / 100) (version mod 100) (if Sys.os_type = "Win32" then ".exe" else "") - in - let classes = ref [([],"Std")] in - let com = Common.create version in -try - let xml_out = ref None in - let swf_header = ref None in - let cmds = ref [] in - let config_macros = ref [] in - let libs = ref [] in - let has_error = ref false in - let gen_as3 = ref false in - let no_output = ref false in - let did_something = ref false in - let force_typing = ref false in - let pre_compilation = ref [] in - let interp = ref false in - Common.define com ("haxe_" ^ string_of_int version); - com.warning <- (fun msg p -> - message ("Warning : " ^ msg) p - ); - com.error <- (fun msg p -> - message msg p; - has_error := true; - ); - Parser.display_error := (fun e p -> - com.error (Parser.error_msg e) p; - ); - Parser.use_doc := false; - (try - let p = Sys.getenv "HAXE_LIBRARY_PATH" in - let rec loop = function - | drive :: path :: l -> - if String.length drive = 1 && ((drive.[0] >= 'a' && drive.[0] <= 'z') || (drive.[0] >= 'A' && drive.[0] <= 'Z')) then - (drive ^ ":" ^ path) :: loop l - else - drive :: loop (path :: l) - | l -> - l - in - let parts = "" :: Str.split_delim (Str.regexp "[;:]") p in - com.class_path <- List.map normalize_path (loop parts) - with - Not_found -> - if Sys.os_type = "Unix" then - com.class_path <- ["/usr/lib/haxe/std/";"/usr/local/lib/haxe/std/";"";"/"] - else - let base_path = normalize_path (try executable_path() with _ -> "./") in - com.class_path <- [base_path ^ "std/";""]); - com.std_path <- List.filter (fun p -> ExtString.String.ends_with p "std/" || ExtString.String.ends_with p "std\\") com.class_path; - let set_platform pf file = - if com.platform <> Cross then failwith "Multiple targets"; - Common.init_platform com pf; - com.file <- file; - Unix.putenv "__file__" file; - Unix.putenv "__platform__" file; - if (pf = Flash || pf = Flash9) && file_extension file = "swc" then Common.define com "swc"; - in - let define f = Arg.Unit (fun () -> Common.define com f) in - let basic_args_spec = [ - ("-cp",Arg.String (fun path -> - com.class_path <- normalize_path path :: com.class_path - )," : add a directory to find source files"); - ("-js",Arg.String (set_platform Js)," : compile code to JavaScript file"); - ("-swf",Arg.String (set_platform Flash)," : compile code to Flash SWF file"); - ("-as3",Arg.String (fun dir -> - set_platform Flash dir; - if com.flash_version < 9. then com.flash_version <- 9.; - gen_as3 := true; - Common.define com "as3"; - Common.define com "no_inline"; - )," : generate AS3 code into target directory"); - ("-neko",Arg.String (set_platform Neko)," : compile code to Neko Binary"); - ("-php",Arg.String (fun dir -> - classes := (["php"],"Boot") :: !classes; - set_platform Php dir; - )," : generate PHP code into target directory"); - ("-cpp",Arg.String (fun dir -> - set_platform Cpp dir; - )," : generate C++ code into target directory"); - ("-xml",Arg.String (fun file -> - Parser.use_doc := true; - xml_out := Some file - )," : generate XML types description"); - ("-main",Arg.String (fun cl -> - if com.main_class <> None then raise (Arg.Bad "Multiple -main"); - let cpath = make_path cl in - com.main_class <- Some cpath; - classes := cpath :: !classes - )," : select startup class"); - ("-lib",Arg.String (fun l -> - libs := l :: !libs; - Common.define com l; - )," : use a haxelib library"); - ("-D",Arg.String (fun var -> - (match var with - | "use_rtti_doc" -> Parser.use_doc := true - | "no_opt" -> com.foptimize <- false - | _ -> ()); - Common.define com var - )," : define a conditional compilation flag"); - ("-v",Arg.Unit (fun () -> - com.verbose <- true - ),": turn on verbose mode"); - ("-debug", Arg.Unit (fun() -> - Common.define com "debug"; com.debug <- true - ), ": add debug informations to the compiled code"); - ] in - let adv_args_spec = [ - ("-swf-version",Arg.Float (fun v -> - com.flash_version <- v; - )," : change the SWF version (6 to 10)"); - ("-swf-header",Arg.String (fun h -> - try - swf_header := Some (match ExtString.String.nsplit h ":" with - | [width; height; fps] -> - (int_of_string width,int_of_string height,float_of_string fps,0xFFFFFF) - | [width; height; fps; color] -> - (int_of_string width, int_of_string height, float_of_string fps, int_of_string ("0x" ^ color)) - | _ -> raise Exit) - with - _ -> raise (Arg.Bad "Invalid SWF header format") - ),"
: define SWF header (width:height:fps:color)"); - ("-swf-lib",Arg.String (fun file -> - let getSWF = Genswf.parse_swf com file in - let extract = Genswf.extract_data getSWF in - let build cl p = - match (try Some (Hashtbl.find (extract()) cl) with Not_found -> None) with - | None -> None - | Some c -> Some (Genswf.build_class com c file) - in - com.load_extern_type <- com.load_extern_type @ [build]; - com.swf_libs <- (file,getSWF,extract) :: com.swf_libs - )," : add the SWF library to the compiled SWF"); - ("-x", Arg.String (fun file -> - let neko_file = file ^ ".n" in - set_platform Neko neko_file; - if com.main_class = None then begin - let cpath = make_path file in - com.main_class <- Some cpath; - classes := cpath :: !classes - end; - cmds := ("neko " ^ neko_file) :: !cmds; - )," : shortcut for compiling and executing a neko file"); - ("-resource",Arg.String (fun res -> - let file, name = (match ExtString.String.nsplit res "@" with - | [file; name] -> file, name - | [file] -> file, file - | _ -> raise (Arg.Bad "Invalid Resource format : should be file@name") - ) in - let file = (try Common.find_file com file with Not_found -> file) in - let data = (try - let s = Std.input_file ~bin:true file in - if String.length s > 12000000 then raise Exit; - s; - with - | Sys_error _ -> failwith ("Resource file not found : " ^ file) - | _ -> failwith ("Resource '" ^ file ^ "' excess the maximum size of 12MB") - ) in - if Hashtbl.mem com.resources name then failwith ("Duplicate resource name " ^ name); - Hashtbl.add com.resources name data - ),"[@name] : add a named resource file"); - ("-prompt", Arg.Unit (fun() -> prompt := true),": prompt on error"); - ("-cmd", Arg.String (fun cmd -> - let len = String.length cmd in - let cmd = (if len > 0 && cmd.[0] = '"' && cmd.[len - 1] = '"' then String.sub cmd 1 (len - 2) else cmd) in - cmds := expand_env cmd :: !cmds - ),": run the specified command after successful compilation"); - ("--flash-strict", define "flash_strict", ": more type strict flash API"); - ("--no-traces", define "no_traces", ": don't compile trace calls in the program"); - ("--flash-use-stage", define "flash_use_stage", ": place objects found on the stage of the SWF lib"); - ("--neko-source", define "neko_source", ": keep generated neko source"); - ("--gen-hx-classes", Arg.Unit (fun() -> - force_typing := true; - pre_compilation := (fun() -> - List.iter (fun (_,_,extract) -> - Hashtbl.iter (fun n _ -> classes := n :: !classes) (extract()) - ) com.swf_libs; - ) :: !pre_compilation; - xml_out := Some "hx" - )," : generate hx headers from SWF9 file"); - ("--next", Arg.Unit (fun() -> assert false), ": separate several haxe compilations"); - ("--display", Arg.String (fun file_pos -> - match file_pos with - | "classes" -> - pre_compilation := (fun() -> raise (Parser.TypePath (["."],None))) :: !pre_compilation; - | "keywords" -> - report_list (Hashtbl.fold (fun k _ acc -> (k,"","") :: acc) Lexer.keywords []); - exit 0; - | _ -> - let file, pos = try ExtString.String.split file_pos "@" with _ -> failwith ("Invalid format : " ^ file_pos) in - let pos = try int_of_string pos with _ -> failwith ("Invalid format : " ^ pos) in - com.display <- true; - Common.display_default := true; - Common.define com "display"; - Parser.resume_display := { - Ast.pfile = Common.get_full_path file; - Ast.pmin = pos; - Ast.pmax = pos; - }; - ),": display code tips"); - ("--no-output", Arg.Unit (fun() -> no_output := true),": compiles but does not generate any file"); - ("--times", Arg.Unit (fun() -> measure_times := true),": measure compilation times"); - ("--no-inline", define "no_inline", ": disable inlining"); - ("--no-opt", Arg.Unit (fun() -> - com.foptimize <- false; - Common.define com "no_opt"; - ), ": disable code optimizations"); - ("--php-front",Arg.String (fun f -> - if com.php_front <> None then raise (Arg.Bad "Multiple --php-front"); - com.php_front <- Some f; - )," : select the name for the php front file"); - ("--php-lib",Arg.String (fun f -> - if com.php_lib <> None then raise (Arg.Bad "Multiple --php-lib"); - com.php_lib <- Some f; - )," : select the name for the php lib folder"); - ("--js-namespace",Arg.String (fun f -> - if com.js_namespace <> None then raise (Arg.Bad "Multiple --js-namespace"); - com.js_namespace <- Some f; - Common.define com "js_namespace"; - )," : create a namespace where root types are defined"); - ("--remap", Arg.String (fun s -> - let pack, target = (try ExtString.String.split s ":" with _ -> raise (Arg.Bad "Invalid format")) in - com.package_rules <- PMap.add pack (Remap target) com.package_rules; - )," : remap a package to another one"); - ("--interp", Arg.Unit (fun() -> - Common.define com "macro"; - set_platform Neko ""; - no_output := true; - interp := true; - ),": interpret the program using internal macro system"); - ("--macro", Arg.String (fun e -> - force_typing := true; - config_macros := e :: !config_macros - )," : call the given macro before typing anything else"); - ("--dead-code-elimination", Arg.Unit (fun () -> - com.dead_code_elimination <- true; - Common.add_filter com (fun() -> Optimizer.filter_dead_code com); - )," : remove unused methods"); - ("-swf9",Arg.String (fun file -> - set_platform Flash file; - if com.flash_version < 9. then com.flash_version <- 9.; - )," : [deprecated] compile code to Flash9 SWF file"); - ] in - let current = ref 0 in - let args = Array.of_list ("" :: params) in - let rec args_callback cl = - match List.rev (ExtString.String.nsplit cl ".") with - | x :: _ when String.lowercase x = "hxml" -> - let hxml_args = parse_hxml cl in - let p1 = Array.to_list (Array.sub args 1 (!current - 1)) in - let p2 = Array.to_list (Array.sub args (!current + 1) (Array.length args - !current - 1)) in - if com.verbose then print_endline ("Processing HXML : " ^ cl); - process_params [] (p1 @ hxml_args @ p2); - raise Hxml_found - | _ -> - classes := make_path cl :: !classes - in - Arg.parse_argv ~current args (basic_args_spec @ adv_args_spec) args_callback usage; - (match !libs with - | [] -> () - | l -> - libs := []; - let cmd = "haxelib path " ^ String.concat " " l in - let p = Unix.open_process_in cmd in - let lines = Std.input_list p in - let ret = Unix.close_process_in p in - let lines = List.fold_left (fun acc l -> - let p = String.length l - 1 in - let l = (if l.[p] = '\r' then String.sub l 0 p else l) in - match (if p > 3 then String.sub l 0 3 else "") with - | "-D " -> - Common.define com (String.sub l 3 (String.length l - 3)); - acc - | "-L " -> - libs := String.sub l 3 (String.length l - 3) :: !libs; - acc - | _ -> - l :: acc - ) [] lines in - if ret <> Unix.WEXITED 0 then failwith (String.concat "\n" lines); - com.class_path <- lines @ com.class_path; - ); - if com.display then begin - xml_out := None; - no_output := true; - com.warning <- store_message; - com.main_class <- None; - com.error <- (fun msg p -> - store_message msg p; - has_error := true; - ); - classes := lookup_classes com (!Parser.resume_display).Ast.pfile; - end; - let add_std dir = - com.class_path <- List.filter (fun s -> not (List.mem s com.std_path)) com.class_path @ List.map (fun p -> p ^ dir ^ "/_std/") com.std_path @ com.std_path - in - let ext = (match com.platform with - | Cross -> - (* no platform selected *) - set_platform Cross ""; - "?" - | Flash | Flash9 -> - if com.flash_version >= 9. then begin - let rec loop = function - | [] -> () - | v :: _ when v > com.flash_version -> () - | v :: l -> - let maj = int_of_float v in - let min = int_of_float (mod_float (v *. 10.) 10.) in - let def = "flash" ^ string_of_int maj ^ (if min = 0 then "" else "_" ^ string_of_int min) in - Common.define com def; - loop l - in - loop [9.;10.;10.1;10.2;11.]; - com.package_rules <- PMap.add "flash" (Directory "flash9") com.package_rules; - com.package_rules <- PMap.add "flash9" Forbidden com.package_rules; - com.platform <- Flash9; - add_std "flash9"; - end else begin - Common.define com ("flash" ^ string_of_int (int_of_float com.flash_version)); - add_std "flash"; - end; - "swf" - | Neko -> add_std "neko"; "n" - | Js -> add_std "js"; "js" - | Php -> add_std "php"; "php" - | Cpp -> add_std "cpp"; "cpp" - ) in - (* if we are at the last compilation step, allow all packages accesses - in case of macros or opening another project file *) - if com.display && not has_next then com.package_rules <- PMap.foldi (fun p r acc -> match r with Forbidden -> acc | _ -> PMap.add p r acc) com.package_rules PMap.empty; - - (* check file extension. In case of wrong commandline, we don't want - to accidentaly delete a source file. *) - if not !no_output && file_extension com.file = ext then delete_file com.file; - List.iter (fun f -> f()) (List.rev (!pre_compilation)); - if !classes = [([],"Std")] && not !force_typing then begin - if !cmds = [] && not !did_something then Arg.usage basic_args_spec usage; - end else begin - if com.verbose then print_endline ("Classpath : " ^ (String.concat ";" com.class_path)); - let t = Common.timer "typing" in - Typecore.type_expr_ref := (fun ctx e need_val -> Typer.type_expr ~need_val ctx e); - let ctx = Typer.create com in - List.iter (Typer.call_init_macro ctx) (List.rev !config_macros); - List.iter (fun cpath -> ignore(ctx.Typecore.g.Typecore.do_load_module ctx cpath Ast.null_pos)) (List.rev !classes); - Typer.finalize ctx; - t(); - if !has_error then do_exit(); - let main, types, modules = Typer.generate ctx com.main_class in - com.main <- main; - com.types <- types; - com.modules <- modules; - let filters = [ - if com.foptimize then Optimizer.reduce_expression ctx else Optimizer.sanitize ctx; - Codegen.check_local_vars_init; - Codegen.block_vars com; - ] in - Codegen.post_process com filters; - Common.add_filter com (fun() -> List.iter (Codegen.on_generate ctx) com.types); - List.iter (fun f -> f()) (List.rev com.filters); - (match !xml_out with - | None -> () - | Some "hx" -> - Genxml.generate_hx com - | Some file -> - if com.verbose then print_endline ("Generating xml : " ^ com.file); - Genxml.generate com file); - if com.platform = Flash9 || com.platform = Cpp then List.iter (Codegen.fix_overrides com) com.types; - if Common.defined com "dump" then Codegen.dump_types com; - (match com.platform with - | _ when !no_output -> - if !interp then begin - let ctx = Interp.create com (Typer.make_macro_api ctx Ast.null_pos) in - Interp.add_types ctx com.types; - (match com.main with - | None -> () - | Some e -> ignore(Interp.eval_expr ctx e)); - end; - | Cross -> - () - | Flash | Flash9 when !gen_as3 -> - if com.verbose then print_endline ("Generating AS3 in : " ^ com.file); - Genas3.generate com; - | Flash | Flash9 -> - if com.verbose then print_endline ("Generating swf : " ^ com.file); - Genswf.generate com !swf_header; - | Neko -> - if com.verbose then print_endline ("Generating neko : " ^ com.file); - Genneko.generate com !libs; - | Js -> - if com.verbose then print_endline ("Generating js : " ^ com.file); - Genjs.generate com - | Php -> - if com.verbose then print_endline ("Generating PHP in : " ^ com.file); - Genphp.generate com; - | Cpp -> - if com.verbose then print_endline ("Generating Cpp in : " ^ com.file); - Gencpp.generate com; - ); - end; - if not !no_output then List.iter (fun cmd -> - let t = Common.timer "command" in - let len = String.length cmd in - if len > 3 && String.sub cmd 0 3 = "cd " then - Sys.chdir (String.sub cmd 3 (len - 3)) - else - if Sys.command cmd <> 0 then failwith "Command failed"; - t(); - ) (List.rev !cmds) -with - | Common.Abort (m,p) -> report m p - | Lexer.Error (m,p) -> report (Lexer.error_msg m) p - | Parser.Error (m,p) -> report (Parser.error_msg m) p - | Typecore.Error (Typecore.Forbid_package _,_) when !Common.display_default && has_next -> () - | Typecore.Error (m,p) -> report (Typecore.error_msg m) p - | Interp.Error (msg,p :: l) -> - store_message msg p; - List.iter (store_message "Called from") l; - report "Aborted" Ast.null_pos; - | Failure msg | Arg.Bad msg -> report ("Error : " ^ msg) Ast.null_pos - | Arg.Help msg -> print_string msg - | Hxml_found -> () - | Typer.Display t -> - (* - documentation is currently not output even when activated - because the parse 'eats' it when used in "resume" mode - *) - let ctx = Type.print_context() in - (match Type.follow t with - | Type.TAnon a -> - let fields = PMap.fold (fun f acc -> - if not f.Type.cf_public then - acc - else - (f.Type.cf_name,Type.s_type ctx f.Type.cf_type,match f.Type.cf_doc with None -> "" | Some d -> d) :: acc - ) a.Type.a_fields [] in - let fields = if !measure_times then begin - close_time(); - let tot = ref 0. in - Hashtbl.iter (fun _ t -> tot := !tot +. t.total) Common.htimers; - let fields = ("@TOTAL", Printf.sprintf "%.3fs" (get_time() -. start), "") :: fields in - Hashtbl.fold (fun _ t acc -> - ("@TIME " ^ t.name, Printf.sprintf "%.3fs (%.0f%%)" t.total (t.total *. 100. /. !tot), "") :: acc - ) Common.htimers fields; - end else - fields - in - report_list fields; - | _ -> - prerr_endline ""; - prerr_endline (htmlescape (Type.s_type ctx t)); - prerr_endline ""); - exit 0; - | Parser.TypePath (p,c) -> - (match c with - | None -> - let packs, classes = read_type_path com p in - if packs = [] && classes = [] then report ("No classes found in " ^ String.concat "." p) Ast.null_pos; - report_list (List.map (fun f -> f,"","") (packs @ classes)) - | Some c -> - try - let ctx = Typer.create com in - let m = Typeload.load_module ctx (p,c) Ast.null_pos in - report_list (List.map (fun t -> snd (Type.t_path t),"","") (List.filter (fun t -> not (Type.t_private t)) m.Type.mtypes)) - with _ -> - report ("Could not load module " ^ (Ast.s_type_path (p,c))) Ast.null_pos - ); - exit 0; - | e when (try Sys.getenv "OCAMLRUNPARAM" <> "b" with _ -> true) -> - report (Printexc.to_string e) Ast.null_pos - -;; -let all = Common.timer "other" in -Sys.catch_break true; -process_params [] (List.tl (Array.to_list Sys.argv)); -all(); -if !measure_times then begin - let tot = ref 0. in - Hashtbl.iter (fun _ t -> tot := !tot +. t.total) Common.htimers; - Printf.eprintf "Total time : %.3fs\n" !tot; - Printf.eprintf "------------------------------------\n"; - Hashtbl.iter (fun _ t -> - Printf.eprintf " %s : %.3fs, %.0f%%\n" t.name t.total (t.total *. 100. /. !tot); - ) Common.htimers; -end; diff --git a/haxe/optimizer.ml b/haxe/optimizer.ml deleted file mode 100644 index 05f8853b303906d7431619d9efdf3b9db1649174..0000000000000000000000000000000000000000 --- a/haxe/optimizer.ml +++ /dev/null @@ -1,628 +0,0 @@ -(* - * Haxe Compiler - * Copyright (c)2005-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 Ast -open Type -open Common -open Typecore - -(* ---------------------------------------------------------------------- *) -(* INLINING *) - -let type_inline ctx cf f ethis params tret p = - let locals = save_locals ctx in - let hcount = Hashtbl.create 0 in - let lsets = Hashtbl.create 0 in - let pnames = List.map (fun (name,_,t) -> - let name = add_local ctx name t in - Hashtbl.add hcount name (ref 0); - (name,t) - ) f.tf_args in - (* type substitution on both class and function type parameters *) - let has_params, map_type = - let rec get_params c pl = - match c.cl_super with - | None -> c.cl_types, pl - | Some (csup,spl) -> - let spl = (match apply_params c.cl_types pl (TInst (csup,spl)) with - | TInst (_,pl) -> pl - | _ -> assert false - ) in - let ct, cpl = get_params csup spl in - c.cl_types @ ct, pl @ cpl - in - let tparams = (match follow ethis.etype with TInst (c,pl) -> get_params c pl | _ -> ([],[])) in - let pmonos = List.map (fun _ -> mk_mono()) cf.cf_params in - let tmonos = snd tparams @ pmonos in - let tparams = fst tparams @ cf.cf_params in - tparams <> [], apply_params tparams tmonos - in - (* use default values for null/unset arguments *) - let rec loop pl al = - match pl, al with - | [], [] -> [] - | e :: pl, (name, opt, t) :: al -> - if is_nullable t && is_null e.etype then Hashtbl.add lsets name (); (* force coerce *) - (match e.eexpr, opt with - | TConst TNull , Some c -> mk (TConst c) (map_type t) e.epos - | _ -> e) :: loop pl al - | [], (_,opt,t) :: al -> - (match opt with - | None -> assert false - | Some c -> mk (TConst c) (map_type t) p) :: loop [] al - | _ :: _, [] -> - assert false - in - let params = loop params f.tf_args in - let ethis = (match ethis.eexpr with TConst TSuper -> { ethis with eexpr = TConst TThis } | _ -> ethis) in - let vthis = gen_local ctx ethis.etype in - let this_count = ref 0 in - let local i = - let i = (try PMap.find i ctx.locals_map with Not_found -> i) in - (try incr (Hashtbl.find hcount i) with Not_found -> ()); - i - in - let opt f = function - | None -> None - | Some e -> Some (f e) - in - let has_vars = ref false in - (* - here, we try to eliminate final returns from the expression tree. - However, this is not entirely correct since we don't yet correctly propagate - the type of returned expressions upwards ("return" expr itself being Dynamic) - *) - let rec map term e = - let e = { e with epos = p } in - match e.eexpr with - | TLocal s -> - { e with eexpr = TLocal (local s) } - | TConst TThis -> - incr this_count; - { e with eexpr = TLocal vthis } - | TVars vl -> - has_vars := true; - let vl = List.map (fun (v,t,e) -> - let e = opt (map false) e in - add_local ctx v t,t,e - ) vl in - { e with eexpr = TVars vl } - | TReturn eo -> - if not term then error "Cannot inline a not final return" e.epos; - (match eo with - | None -> mk (TConst TNull) (mk_mono()) p - | Some e -> map term e) - | TFor (v,t,e1,e2) -> - let e1 = map false e1 in - let old = save_locals ctx in - let v = add_local ctx v t in - let e2 = map false e2 in - old(); - { e with eexpr = TFor (v,t,e1,e2) } - | TMatch (e,en,cases,def) -> - let term, t = (match def with Some d when term -> true, ref d.etype | _ -> false, ref e.etype) in - let cases = List.map (fun (i,vl,e) -> - let old = save_locals ctx in - let vl = opt (List.map (fun (n,t) -> opt (fun n -> add_local ctx n t) n, t)) vl in - let e = map term e in - if is_null e.etype then t := e.etype; - old(); - i, vl, e - ) cases in - { e with eexpr = TMatch (map false e,en,cases,opt (map term) def); etype = !t } - | TTry (e1,catches) -> - { e with eexpr = TTry (map term e1,List.map (fun (v,t,e) -> - let old = save_locals ctx in - let v = add_local ctx v t in - let e = map term e in - old(); - v,t,e - ) catches) } - | TBlock l -> - let old = save_locals ctx in - let t = ref e.etype in - let rec loop = function - | [] when term -> - t := mk_mono(); - [mk (TConst TNull) (!t) p] - | [] -> [] - | [e] -> - let e = map term e in - if term then t := e.etype; - [e] - | e :: l -> - let e = map false e in - e :: loop l - in - let l = loop l in - old(); - { e with eexpr = TBlock l; etype = !t } - | TIf (econd,eif,Some eelse) when term -> - let econd = map false econd in - let eif = map term eif in - let eelse = map term eelse in - { e with eexpr = TIf(econd,eif,Some eelse); etype = if is_null eif.etype then eif.etype else eelse.etype } - | TParenthesis _ | TIf (_,_,Some _) | TSwitch (_,_,Some _) -> - Type.map_expr (map term) e - | TUnop (op,pref,({ eexpr = TLocal s } as e1)) -> - (match op with - | Increment | Decrement -> Hashtbl.add lsets (local s) () - | _ -> ()); - { e with eexpr = TUnop (op,pref,map false e1) } - | TBinop (op,({ eexpr = TLocal s } as e1),e2) -> - (match op with - | OpAssign | OpAssignOp _ -> Hashtbl.add lsets (local s) () - | _ -> ()); - { e with eexpr = TBinop (op,map false e1,map false e2) } - | TConst TSuper -> - error "Cannot inline function containing super" e.epos - | TFunction _ -> - error "Cannot inline functions containing closures" p - | _ -> - Type.map_expr (map false) e - in - let e = map true f.tf_expr in - locals(); - let subst = ref PMap.empty in - Hashtbl.add hcount vthis this_count; - let vars = List.map2 (fun (n,t) e -> - let flag = not (Hashtbl.mem lsets n) && (match e.eexpr with - | TLocal _ | TConst _ | TFunction _ -> true - | _ -> - let used = !(Hashtbl.find hcount n) in - used <= 1 - ) in - (n,t,e,flag) - ) ((vthis,ethis.etype) :: pnames) (ethis :: params) in - let vars = List.fold_left (fun acc (n,t,e,flag) -> - if flag then begin - subst := PMap.add n e !subst; - acc - end else - (n,t,Some e) :: acc - ) [] vars in - let subst = !subst in - let rec inline_params e = - match e.eexpr with - | TLocal s -> (try PMap.find s subst with Not_found -> e) - | _ -> Type.map_expr inline_params e - in - let e = (if PMap.is_empty subst then e else inline_params e) in - let init = (match vars with [] -> None | l -> Some (mk (TVars (List.rev l)) ctx.t.tvoid p)) in - if Common.defined ctx.com "js" && (init <> None || !has_vars) then - None - else - let wrap e = - (* we can't mute the type of the expression because it is not correct to do so *) - if e.etype == tret then - e - else - mk (TParenthesis e) tret e.epos - in - let e = (match e.eexpr, init with - | TBlock [e] , None -> wrap e - | _ , None -> wrap e - | TBlock l, Some init -> mk (TBlock (init :: l)) tret e.epos - | _, Some init -> mk (TBlock [init;e]) tret e.epos - ) in - (* we need to replace type-parameters that were used in the expression *) - if not has_params then - Some e - else - let mt = map_type cf.cf_type in - unify_raise ctx mt (TFun (List.map (fun e -> "",false,e.etype) params,tret)) p; - (* - this is very expensive since we are building the substitution list for - every expression, but hopefully in such cases the expression size is small - *) - let rec map_expr_type e = Type.map_expr_type map_expr_type map_type e in - Some (map_expr_type e) - -(* ---------------------------------------------------------------------- *) -(* LOOPS *) - -let optimize_for_loop ctx i e1 e2 p = - let t_void = ctx.t.tvoid in - let t_int = ctx.t.tint in - let lblock el = Some (mk (TBlock el) t_void p) in - match e1.eexpr, follow e1.etype with - | TNew ({ cl_path = ([],"IntIter") },[],[i1;i2]) , _ -> - let max = (match i1.eexpr , i2.eexpr with - | TConst (TInt a), TConst (TInt b) when Int32.compare b a < 0 -> error "Range operate can't iterate backwards" p - | _, TConst _ | _ , TLocal _ -> None - | _ -> Some (gen_local ctx t_int) - ) in - let tmp = gen_local ctx t_int in - let i = add_local ctx i t_int in - let rec check e = - match e.eexpr with - | TBinop (OpAssign,{ eexpr = TLocal l },_) - | TBinop (OpAssignOp _,{ eexpr = TLocal l },_) - | TUnop (Increment,_,{ eexpr = TLocal l }) - | TUnop (Decrement,_,{ eexpr = TLocal l }) when l = i -> - error "Loop variable cannot be modified" e.epos - | TFunction f when List.exists (fun (l,_,_) -> l = i) f.tf_args -> - e - | TFor (k,_,_,_) when k = i -> - e - | _ -> - Type.map_expr check e - in - let e2 = check (type_expr ctx e2 false) in - let etmp = mk (TLocal tmp) t_int p in - let incr = mk (TUnop (Increment,Postfix,etmp)) t_int p in - let init = mk (TVars [i,t_int,Some incr]) t_void p in - let block = match e2.eexpr with - | TBlock el -> mk (TBlock (init :: el)) t_void e2.epos - | _ -> mk (TBlock [init;e2]) t_void p - in - (* - force locals to be of Int type (to prevent Int/UInt issues) - *) - (match max with - | None -> - lblock [ - mk (TVars [tmp,t_int,Some i1]) t_void p; - mk (TWhile ( - mk (TBinop (OpLt, etmp, { i2 with etype = t_int })) ctx.t.tbool p, - block, - NormalWhile - )) t_void p; - ] - | Some max -> - lblock [ - mk (TVars [tmp,t_int,Some i1;max,t_int,Some i2]) t_void p; - mk (TWhile ( - mk (TBinop (OpLt, etmp, mk (TLocal max) t_int p)) ctx.t.tbool p, - block, - NormalWhile - )) t_void p; - ]) - | _ , TInst({ cl_path = [],"Array" },[pt]) - | _ , TInst({ cl_path = ["flash"],"Vector" },[pt]) -> - let i = add_local ctx i pt in - let index = gen_local ctx t_int in - let arr, avars = (match e1.eexpr with - | TLocal _ -> e1, [] - | _ -> - let atmp = gen_local ctx e1.etype in - mk (TLocal atmp) e1.etype e1.epos, [atmp,e1.etype,Some e1] - ) in - let iexpr = mk (TLocal index) t_int p in - let e2 = type_expr ctx e2 false in - let aget = mk (TVars [i,pt,Some (mk (TArray (arr,iexpr)) pt p)]) t_void p in - let incr = mk (TUnop (Increment,Prefix,iexpr)) t_int p in - let block = match e2.eexpr with - | TBlock el -> mk (TBlock (aget :: incr :: el)) t_void e2.epos - | _ -> mk (TBlock [aget;incr;e2]) t_void p - in - let ivar = index, t_int, Some (mk (TConst (TInt 0l)) t_int p) in - lblock [ - mk (TVars (ivar :: avars)) t_void p; - mk (TWhile ( - mk (TBinop (OpLt, iexpr, mk (TField (arr,"length")) t_int p)) ctx.t.tbool p, - block, - NormalWhile - )) t_void p; - ] - | _ , TInst ({ cl_kind = KGenericInstance ({ cl_path = ["haxe"],"FastList" },[t]) } as c,[]) -> - let tcell = (try (PMap.find "head" c.cl_fields).cf_type with Not_found -> assert false) in - let i = add_local ctx i t in - let cell = gen_local ctx tcell in - let cexpr = mk (TLocal cell) tcell p in - let e2 = type_expr ctx e2 false in - let evar = mk (TVars [i,t,Some (mk (TField (cexpr,"elt")) t p)]) t_void p in - let enext = mk (TBinop (OpAssign,cexpr,mk (TField (cexpr,"next")) tcell p)) tcell p in - let block = match e2.eexpr with - | TBlock el -> mk (TBlock (evar :: enext :: el)) t_void e2.epos - | _ -> mk (TBlock [evar;enext;e2]) t_void p - in - lblock [ - mk (TVars [cell,tcell,Some (mk (TField (e1,"head")) tcell p)]) t_void p; - mk (TWhile ( - mk (TBinop (OpNotEq, cexpr, mk (TConst TNull) tcell p)) ctx.t.tbool p, - block, - NormalWhile - )) t_void p - ] - | _ -> - None - -(* ---------------------------------------------------------------------- *) -(* SANITIZE *) - -(* - makes sure that when an AST get generated to source code, it will not - generate expressions that evaluate differently. It is then necessary to - add parenthesises around some binary expressions when the AST does not - correspond to the natural operand priority order for the platform -*) - -(* - this is the standard C++ operator precedence, which is also used by both JS and PHP -*) -let standard_precedence op = - let left = true and right = false in - match op with - | OpMult | OpDiv | OpMod -> 5, left - | OpAdd | OpSub -> 6, left - | OpShl | OpShr | OpUShr -> 7, left - | OpLt | OpLte | OpGt | OpGte -> 8, left - | OpEq | OpNotEq -> 9, left - | OpAnd -> 10, left - | OpXor -> 11, left - | OpOr -> 12, left - | OpInterval -> 13, right (* haxe specific *) - | OpBoolAnd -> 14, left - | OpBoolOr -> 15, left - | OpAssignOp OpAssign -> 16, right (* mimics ?: *) - | OpAssign | OpAssignOp _ -> 17, right - -let sanitize_expr e = - let parent e = - mk (TParenthesis e) e.etype e.epos - in - let block e = - mk (TBlock [e]) e.etype e.epos - in - let need_parent e = - match e.eexpr with - | TConst _ | TLocal _ | TEnumField _ | TArray _ | TField _ | TParenthesis _ | TCall _ | TClosure _ | TNew _ | TTypeExpr _ | TObjectDecl _ | TArrayDecl _ -> false - | TCast _ | TThrow _ | TReturn _ | TTry _ | TMatch _ | TSwitch _ | TFor _ | TIf _ | TWhile _ | TBinop _ | TContinue | TBreak - | TBlock _ | TVars _ | TFunction _ | TUnop _ -> true - in - match e.eexpr with - | TBinop (op,e1,e2) -> - let swap op1 op2 = - let p1, left1 = standard_precedence op1 in - let p2, _ = standard_precedence op2 in - left1 && p1 <= p2 - in - let rec loop ee left = - match ee.eexpr with - | TBinop (op2,_,_) -> if left then not (swap op2 op) else swap op op2 - | TIf _ -> if left then not (swap (OpAssignOp OpAssign) op) else swap op (OpAssignOp OpAssign) - | TCast (e,None) -> loop e left - | _ -> false - in - let e1 = if loop e1 true then parent e1 else e1 in - let e2 = if loop e2 false then parent e2 else e2 in - { e with eexpr = TBinop (op,e1,e2) } - | TUnop (op,mode,e2) -> - let rec loop ee = - match ee.eexpr with - | TBinop _ -> parent e2 - | TCast (e,None) -> loop e - | _ -> e2 - in - { e with eexpr = TUnop (op,mode,loop e2) } - | TIf (e1,e2,eelse) -> - let e1 = (match e1.eexpr with - | TParenthesis _ -> e1 - | _ -> parent e1 - ) in - let e2 = (match e2.eexpr, eelse with - | TIf (_,_,Some _) , _ | TIf (_,_,None), Some _ -> block e2 - | _ -> e2 - ) in - { e with eexpr = TIf (e1,e2,eelse) } - | TFunction f -> - (match f.tf_expr.eexpr with - | TBlock _ -> e - | _ -> { e with eexpr = TFunction { f with tf_expr = block f.tf_expr } }) - | TCall (e2,args) -> - if need_parent e2 then { e with eexpr = TCall(parent e2,args) } else e - | TField (e2,f) -> - if need_parent e2 then { e with eexpr = TField(parent e2,f) } else e - | TArray (e1,e2) -> - if need_parent e1 then { e with eexpr = TArray(parent e1,e2) } else e - | _ -> - e - -let reduce_expr ctx e = - match e.eexpr with - | TSwitch (_,cases,_) -> - List.iter (fun (cl,_) -> - List.iter (fun e -> - match e.eexpr with - | TCall ({ eexpr = TEnumField _ },_) -> error "Not-constant enum in switch cannot be matched" e.epos - | _ -> () - ) cl - ) cases; - e - | TBlock [{ eexpr = TConst _ } as ec] -> - { ec with epos = e.epos } - | TParenthesis ec -> - { ec with epos = e.epos } - | _ -> - e - -let rec sanitize ctx e = - sanitize_expr (reduce_expr ctx (Type.map_expr (sanitize ctx) e)) - -(* ---------------------------------------------------------------------- *) -(* REDUCE *) - -let rec reduce_loop ctx e = - let is_float t = - match follow t with - | TInst ({ cl_path = ([],"Float") },_) -> true - | _ -> false - in - let e = Type.map_expr (reduce_loop ctx) e in - sanitize_expr (match e.eexpr with - | TIf ({ eexpr = TConst (TBool t) },e1,e2) -> - (if t then e1 else match e2 with None -> { e with eexpr = TBlock [] } | Some e -> e) - | TWhile ({ eexpr = TConst (TBool false) },sub,flag) -> - (match flag with - | NormalWhile -> { e with eexpr = TBlock [] } (* erase sub *) - | DoWhile -> e) (* we cant remove while since sub can contain continue/break *) - | TBinop (op,e1,e2) -> - (match e1.eexpr, e2.eexpr with - | TConst (TInt 0l) , _ when op = OpAdd -> e2 - | TConst (TInt 1l) , _ when op = OpMult -> e2 - | TConst (TFloat v) , _ when op = OpAdd && float_of_string v = 0. && is_float e2.etype -> e2 - | TConst (TFloat v) , _ when op = OpMult && float_of_string v = 1. && is_float e2.etype -> e2 - | _ , TConst (TInt 0l) when (match op with OpAdd | OpSub | OpShr | OpShl -> true | _ -> false) -> e1 (* bits operations might cause overflow *) - | _ , TConst (TInt 1l) when op = OpMult -> e1 - | _ , TConst (TFloat v) when (match op with OpAdd | OpSub -> float_of_string v = 0. && is_float e1.etype | _ -> false) -> e1 (* bits operations might cause overflow *) - | _ , TConst (TFloat v) when op = OpMult && float_of_string v = 1. && is_float e1.etype -> e1 - | TConst TNull, TConst TNull -> - (match op with - | OpEq -> { e with eexpr = TConst (TBool true) } - | OpNotEq -> { e with eexpr = TConst (TBool false) } - | _ -> e) - | TConst (TInt a), TConst (TInt b) -> - let opt f = try { e with eexpr = TConst (TInt (f a b)) } with Exit -> e in - let check_overflow f = - opt (fun a b -> - let v = f (Int64.of_int32 a) (Int64.of_int32 b) in - let iv = Int64.to_int32 v in - if Int64.compare (Int64.of_int32 iv) v <> 0 then raise Exit; - iv - ) - in - let ebool t = - { e with eexpr = TConst (TBool (t (Int32.compare b a))) } - in - (match op with - | OpAdd -> check_overflow Int64.add - | OpSub -> check_overflow Int64.sub - | OpMult -> check_overflow Int64.mul - | OpAnd -> opt Int32.logand - | OpOr -> opt Int32.logor - | OpXor -> opt Int32.logxor - | OpShl -> opt (fun a b -> Int32.shift_left a (Int32.to_int b)) - | OpShr -> opt (fun a b -> Int32.shift_right a (Int32.to_int b)) - | OpUShr -> opt (fun a b -> Int32.shift_right_logical a (Int32.to_int b)) - | OpEq -> ebool ((=) 0) - | OpNotEq -> ebool ((<>) 0) - | OpGt -> ebool ((>) 0) - | OpGte -> ebool ((>=) 0) - | OpLt -> ebool ((<) 0) - | OpLte -> ebool ((<=) 0) - | _ -> e) - | TConst (TFloat a), TConst (TFloat b) -> - let fop f = - let v = f (float_of_string a) (float_of_string b) in - let vstr = string_of_float v in - if v = float_of_string vstr then - { e with eexpr = TConst (TFloat vstr) } - else - e - in - let ebool t = - { e with eexpr = TConst (TBool (t (compare b a))) } - in - (match op with - | OpAdd -> fop (+.) - | OpSub -> fop (-.) - | OpMult -> fop ( *. ) - | OpEq -> ebool ((=) 0) - | OpNotEq -> ebool ((<>) 0) - | OpGt -> ebool ((>) 0) - | OpGte -> ebool ((>=) 0) - | OpLt -> ebool ((<) 0) - | OpLte -> ebool ((<=) 0) - | _ -> e) - | TConst (TBool a), TConst (TBool b) -> - let ebool f = - { e with eexpr = TConst (TBool (f a b)) } - in - (match op with - | OpEq -> ebool (=) - | OpNotEq -> ebool (<>) - | OpBoolAnd -> ebool (&&) - | OpBoolOr -> ebool (||) - | _ -> e) - | TConst (TBool a), _ -> - (match op with - | OpBoolAnd -> if a then e2 else { e with eexpr = TConst (TBool false) } - | OpBoolOr -> if a then { e with eexpr = TConst (TBool true) } else e2 - | _ -> e) - | _ , TConst (TBool a) -> - (match op with - | OpBoolAnd when a -> e1 - | OpBoolOr when not a -> e1 - | _ -> e) - | TEnumField (e1,f1), TEnumField (e2,f2) when e1 == e2 -> - (match op with - | OpEq -> { e with eexpr = TConst (TBool (f1 = f2)) } - | OpNotEq -> { e with eexpr = TConst (TBool (f1 <> f2)) } - | _ -> e) - | _, TCall ({ eexpr = TEnumField _ },_) | TCall ({ eexpr = TEnumField _ },_), _ -> - (match op with - | OpAssign -> e - | _ -> - error "You cannot directly compare enums with arguments. Use either 'switch' or 'Type.enumEq'" e.epos) - | _ -> - e) - | TUnop (op,flag,esub) -> - (match op, esub.eexpr with - | Not, TConst (TBool f) -> { e with eexpr = TConst (TBool (not f)) } - | Neg, TConst (TInt i) -> { e with eexpr = TConst (TInt (Int32.neg i)) } - | NegBits, TConst (TInt i) -> { e with eexpr = TConst (TInt (Int32.lognot i)) } - | Neg, TConst (TFloat f) -> - let v = 0. -. float_of_string f in - let vstr = string_of_float v in - if float_of_string vstr = v then - { e with eexpr = TConst (TFloat vstr) } - else - e - | _ -> e - ) - | TCall ({ eexpr = TFunction func } as ef,el) -> - (match follow ef.etype with - | TFun (_,rt) -> - let cf = { cf_name = ""; cf_params = []; cf_type = ef.etype; cf_public = true; cf_doc = None; cf_meta = no_meta; cf_kind = Var { v_read = AccNormal; v_write = AccNo }; cf_expr = None } in - let inl = (try type_inline ctx cf func (mk (TConst TNull) (mk_mono()) e.epos) el rt e.epos with Error (Custom _,_) -> None) in - (match inl with - | None -> e - | Some e -> e) - | _ -> - e) - | _ -> - reduce_expr ctx e) - -let reduce_expression ctx e = - if ctx.com.foptimize then reduce_loop ctx e else e - -(* ---------------------------------------------------------------------- *) -(* ELIMINATE DEAD CODE *) - -(* - if dead code elimination is on, any class without fields is eliminated from the output. -*) - -let filter_dead_code com = - let s_class c = s_type_path c.cl_path in - com.types <- List.filter (fun t -> - match t with - | TClassDecl c -> - if (c.cl_extern or has_meta ":keep" c.cl_meta) then - true - else ( - match (c.cl_ordered_statics, c.cl_ordered_fields, c.cl_constructor) with - | ([], [], None) -> - if com.verbose then print_endline ("Remove class " ^ s_class c); - false - | _ -> - true) - | _ -> - true - ) com.types diff --git a/haxe/parser.ml b/haxe/parser.ml deleted file mode 100755 index 1aab1d446105aae5a4f8ddd51f3d273a62fda9cd..0000000000000000000000000000000000000000 --- a/haxe/parser.ml +++ /dev/null @@ -1,833 +0,0 @@ -(* - * Haxe Compiler - * 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 Ast - -type error_msg = - | Unexpected of token - | Duplicate_default - | Missing_semicolon - | Unclosed_macro - | Unimplemented - | Missing_type - | Custom of string - -exception Error of error_msg * pos -exception TypePath of string list * string option -exception Display of expr - -let error_msg = function - | Unexpected t -> "Unexpected "^(s_token t) - | Duplicate_default -> "Duplicate default" - | Missing_semicolon -> "Missing ;" - | Unclosed_macro -> "Unclosed macro" - | Unimplemented -> "Not implemented for current platform" - | Missing_type -> "Missing type declaration" - | Custom s -> s - -let error m p = raise (Error (m,p)) -let display_error : (error_msg -> pos -> unit) ref = ref (fun _ _ -> assert false) - -let cache = ref (DynArray.create()) -let doc = ref None -let use_doc = ref false -let resume_display = ref null_pos - -let last_token s = - let n = Stream.count s in - DynArray.get (!cache) (if n = 0 then 0 else n - 1) - -let serror() = raise (Stream.Error "") - -let do_resume() = !resume_display <> null_pos - -let display e = raise (Display e) - -let is_resuming p = - let p2 = !resume_display in - p.pmax = p2.pmin && String.lowercase (Common.get_full_path p.pfile) = String.lowercase p2.pfile - -let precedence op = - let left = true and right = false in - match op with - | OpMod -> 0, left - | OpMult | OpDiv -> 1, left - | OpAdd | OpSub -> 2, left - | OpShl | OpShr | OpUShr -> 3, left - | OpOr | OpAnd | OpXor -> 4, left - | OpEq | OpNotEq | OpGt | OpLt | OpGte | OpLte -> 5, left - | OpInterval -> 6, left - | OpBoolAnd -> 7, left - | OpBoolOr -> 8, left - | OpAssign | OpAssignOp _ -> 9, right - -let is_not_assign = function - | OpAssign | OpAssignOp _ -> false - | _ -> true - -let swap op1 op2 = - let p1, left1 = precedence op1 in - let p2, _ = precedence op2 in - left1 && p1 <= p2 - -let rec make_binop op e ((v,p2) as e2) = - match v with - | EBinop (_op,_e,_e2) when swap op _op -> - let _e = make_binop op e _e in - EBinop (_op,_e,_e2) , punion (pos _e) (pos _e2) - | ETernary (e1,e2,e3) when is_not_assign op -> - let e = make_binop op e e1 in - ETernary (e,e2,e3) , punion (pos e) (pos e3) - | _ -> - EBinop (op,e,e2) , punion (pos e) (pos e2) - -let rec make_unop op ((v,p2) as e) p1 = - match v with - | EBinop (bop,e,e2) -> EBinop (bop, make_unop op e p1 , e2) , (punion p1 p2) - | ETernary (e1,e2,e3) -> ETernary (make_unop op e1 p1 , e2, e3), punion p1 p2 - | _ -> - EUnop (op,Prefix,e), punion p1 p2 - -let popt f = parser - | [< v = f >] -> Some v - | [< >] -> None - -let rec plist f = parser - | [< v = f; l = plist f >] -> v :: l - | [< >] -> [] - -let rec psep sep f = parser - | [< v = f; s >] -> - let rec loop = parser - | [< '(sep2,_) when sep2 = sep; v = f; l = loop >] -> v :: l - | [< >] -> [] - in - v :: loop s - | [< >] -> [] - -let ident = parser - | [< '(Const (Ident i),_) >] -> i - -let any_ident = parser - | [< '(Const (Ident i),_) >] -> i - | [< '(Const (Type t),_) >] -> t - -let property_ident = parser - | [< i = any_ident >] -> i - | [< '(Kwd Dynamic,_) >] -> "dynamic" - | [< '(Kwd Default,_) >] -> "default" - -let log m s = - prerr_endline m - -let get_doc s = - let d = !doc in - doc := None; - d - -let comma = parser - | [< '(Comma,_) >] -> () - -let semicolon s = - if fst (last_token s) = BrClose then - match s with parser - | [< '(Semicolon,p) >] -> p - | [< >] -> snd (last_token s) - else - match s with parser - | [< '(Semicolon,p) >] -> p - | [< s >] -> - let pos = snd (last_token s) in - if do_resume() then pos else error Missing_semicolon pos - -let rec parse_file s = - doc := None; - match s with parser - | [< '(Kwd Package,_); p = parse_package; _ = semicolon; l = plist parse_type_decl; '(Eof,_) >] -> p , l - | [< l = plist parse_type_decl; '(Eof,_) >] -> [] , l - -and parse_type_decl s = - match s with parser - | [< '(Kwd Import,p1); t = parse_type_path; p2 = semicolon >] -> EImport t, punion p1 p2 - | [< '(Kwd Using,p1); t = parse_type_path; p2 = semicolon >] -> EUsing t, punion p1 p2 - | [< meta = parse_meta; c = parse_common_flags; s >] -> - match s with parser - | [< n , p1 = parse_enum_flags; doc = get_doc; '(Const (Type name),_); tl = parse_constraint_params; '(BrOpen,_); l = plist parse_enum; '(BrClose,p2) >] -> - (EEnum { - d_name = name; - d_doc = doc; - d_meta = meta; - d_params = tl; - d_flags = List.map snd c @ n; - d_data = l - }, punion p1 p2) - | [< n , p1 = parse_class_flags; doc = get_doc; '(Const (Type name),_); tl = parse_constraint_params; hl = psep Comma parse_class_herit; '(BrOpen,_); fl = parse_class_field_resume; s >] -> - let p2 = (match s with parser - | [< '(BrClose,p2) >] -> p2 - | [< >] -> if do_resume() then p1 else serror() - ) in - (EClass { - d_name = name; - d_doc = doc; - d_meta = meta; - d_params = tl; - d_flags = List.map fst c @ n @ hl; - d_data = fl; - }, punion p1 p2) - | [< '(Kwd Typedef,p1); doc = get_doc; '(Const (Type name),p2); tl = parse_constraint_params; '(Binop OpAssign,_); t = parse_complex_type; s >] -> - (match s with parser - | [< '(Semicolon,_) >] -> () - | [< >] -> ()); - (ETypedef { - d_name = name; - d_doc = doc; - d_meta = meta; - d_params = tl; - d_flags = List.map snd c; - d_data = t; - }, punion p1 p2) - -and parse_package s = psep Dot ident s - -and parse_class_field_resume s = - if not (do_resume()) then - plist parse_class_field s - else try - let c = parse_class_field s in - c :: parse_class_field_resume s - with Stream.Error _ | Stream.Failure -> try - (* junk all tokens until we reach next variable/function or next type declaration *) - let rec loop() = - (match List.map fst (Stream.npeek 2 s) with - | At :: _ | Kwd Public :: _ | Kwd Static :: _ | Kwd Var :: _ | Kwd Override :: _ | Kwd Dynamic :: _ | Kwd Inline :: _ -> - raise Exit - | [] | Eof :: _ | Kwd Import :: _ | Kwd Using :: _ | Kwd Extern :: _ | Kwd Class :: _ | Kwd Interface :: _ | Kwd Enum :: _ | Kwd Typedef :: _ -> - raise Not_found - | [Kwd Private; Kwd Class] - | [Kwd Private; Kwd Interface] - | [Kwd Private; Kwd Enum] - | [Kwd Private; Kwd Typedef] -> - raise Not_found - | Kwd Private :: _ -> - raise Exit - | [Kwd Function; Const _] - | [Kwd Function; Kwd New] -> - raise Exit - | [BrClose; At] -> - raise Not_found - | _ -> ()); - Stream.junk s; - loop(); - in - loop() - with - | Not_found -> [] (* we have reached the next type declaration *) - | Exit -> parse_class_field_resume s - -and parse_common_flags = parser - | [< '(Kwd Private,_); l = parse_common_flags >] -> (HPrivate, EPrivate) :: l - | [< '(Kwd Extern,_); l = parse_common_flags >] -> (HExtern, EExtern) :: l - | [< >] -> [] - -and parse_meta = parser - | [< '(At,_); name,p = meta_name; s >] -> - (match s with parser - | [< '(POpen,_); params = psep Comma expr; '(PClose,_); s >] -> (name,params,p) :: parse_meta s - | [< >] -> (name,[],p) :: parse_meta s) - | [< >] -> [] - -and meta_name = parser - | [< '(Const (Ident i),p) >] -> i, p - | [< '(Const (Type t),p) >] -> t, p - | [< '(Kwd k,p) >] -> s_keyword k,p - | [< '(DblDot,_); s >] -> let n, p = meta_name s in ":" ^ n, p - -and parse_enum_flags = parser - | [< '(Kwd Enum,p) >] -> [] , p - -and parse_class_flags = parser - | [< '(Kwd Class,p) >] -> [] , p - | [< '(Kwd Interface,p) >] -> [HInterface] , p - -and parse_type_opt = parser - | [< '(DblDot,_); t = parse_complex_type >] -> Some t - | [< >] -> None - -and parse_complex_type = parser - | [< '(POpen,_); t = parse_complex_type; '(PClose,_); s >] -> parse_complex_type_next (CTParent t) s - | [< '(BrOpen,_); s >] -> - let t = (match s with parser - | [< name = any_ident >] -> CTAnonymous (parse_type_anonymous_resume name s) - | [< '(Binop OpGt,_); t = parse_type_path; '(Comma,_); s >] -> - (match s with parser - | [< name = any_ident; l = parse_type_anonymous_resume name >] -> CTExtend (t,l) - | [< l = plist (parse_signature_field None); '(BrClose,_) >] -> CTExtend (t,l) - | [< >] -> serror()) - | [< l = plist (parse_signature_field None); '(BrClose,_) >] -> CTAnonymous l - | [< >] -> serror() - ) in - parse_complex_type_next t s - | [< t = parse_type_path; s >] -> parse_complex_type_next (CTPath t) s - -and parse_type_path s = parse_type_path1 [] s - -and parse_type_path1 pack = parser - | [< '(Const (Ident name),_); '(Dot,p); s >] -> - if is_resuming p then - raise (TypePath (List.rev (name :: pack),None)) - else - parse_type_path1 (name :: pack) s - | [< '(Const (Type name),_); s >] -> - let sub = (match s with parser - | [< '(Dot,p); s >] -> - (if is_resuming p then - raise (TypePath (List.rev pack,Some name)) - else match s with parser - | [< '(Const (Type name),_) >] -> Some name - | [< >] -> serror()) - | [< >] -> None - ) in - let params = (match s with parser - | [< '(Binop OpLt,_); l = psep Comma parse_type_path_or_const; '(Binop OpGt,_) >] -> l - | [< >] -> [] - ) in - { - tpackage = List.rev pack; - tname = name; - tparams = params; - tsub = sub; - } - -and parse_type_path_or_const = parser - | [< '(Const (String s),_) >] -> TPConst (String s) - | [< '(Const (Int i),_) >] -> TPConst (Int i) - | [< '(Const (Float f),_) >] -> TPConst (Float f) - | [< t = parse_complex_type >] -> TPType t - -and parse_complex_type_next t = parser - | [< '(Arrow,_); t2 = parse_complex_type >] -> - (match t2 with - | CTFunction (args,r) -> - CTFunction (t :: args,r) - | _ -> - CTFunction ([t] , t2)) - | [< >] -> t - -and parse_type_anonymous_resume name = parser - | [< '(DblDot,p); t = parse_complex_type; s >] -> - (name, None, AFVar t, p) :: - match s with parser - | [< '(BrClose,_) >] -> [] - | [< '(Comma,_) >] -> - (match s with parser - | [< '(BrClose,_) >] -> [] - | [< name = any_ident; s >] -> parse_type_anonymous_resume name s - | [< >] -> serror()); - | [< >] -> serror() - -and parse_enum s = - doc := None; - let meta = parse_meta s in - match s with parser - | [< name = any_ident; doc = get_doc; s >] -> - match s with parser - | [< '(POpen,_); l = psep Comma parse_enum_param; '(PClose,_); p = semicolon; >] -> (name,doc,meta,l,p) - | [< '(Semicolon,p) >] -> (name,doc,meta,[],p) - | [< >] -> serror() - -and parse_enum_param = parser - | [< '(Question,_); name = any_ident; '(DblDot,_); t = parse_complex_type >] -> (name,true,t) - | [< name = any_ident; '(DblDot,_); t = parse_complex_type >] -> (name,false,t) - -and parse_class_field s = - doc := None; - match s with parser - | [< meta = parse_meta; al = parse_cf_rights true []; doc = get_doc; s >] -> - let name, pos, k = (match s with parser - | [< '(Kwd Var,p1); name = any_ident; s >] -> - (match s with parser - | [< '(POpen,_); i1 = property_ident; '(Comma,_); i2 = property_ident; '(PClose,_); '(DblDot,_); t = parse_complex_type; p2 = semicolon >] -> - name, punion p1 p2, FProp (i1,i2,t) - | [< t = parse_type_opt; s >] -> - let e , p2 = (match s with parser - | [< '(Binop OpAssign,_) when List.mem AStatic al; e = toplevel_expr; p2 = semicolon >] -> Some e , p2 - | [< '(Semicolon,p2) >] -> None , p2 - | [< >] -> serror() - ) in - name, punion p1 p2, FVar (t,e)) - | [< '(Kwd Function,p1); name = parse_fun_name; pl = parse_constraint_params; '(POpen,_); al = psep Comma parse_fun_param; '(PClose,_); t = parse_type_opt; s >] -> - let e = (match s with parser - | [< e = toplevel_expr >] -> e - | [< '(Semicolon,p) >] -> (EBlock [],p) - | [< >] -> serror() - ) in - let f = { - f_args = al; - f_type = t; - f_expr = e; - } in - name, punion p1 (pos e), FFun (pl,f) - | [< >] -> - if al = [] then raise Stream.Failure else serror() - ) in - { - cff_name = name; - cff_doc = doc; - cff_meta = meta; - cff_access = al; - cff_pos = pos; - cff_kind = k; - } - -and parse_signature_field flag = parser - | [< '(Kwd Var,p1); name = any_ident; s >] -> - (match s with parser - | [< '(DblDot,_); t = parse_complex_type; p2 = semicolon >] -> (name,flag,AFVar t,punion p1 p2) - | [< '(POpen,_); i1 = property_ident; '(Comma,_); i2 = property_ident; '(PClose,_); '(DblDot,_); t = parse_complex_type; p2 = semicolon >] -> (name,flag,AFProp (t,i1,i2),punion p1 p2) - | [< >] -> serror()) - | [< '(Kwd Function,p1); name = any_ident; '(POpen,_); al = psep Comma parse_fun_param_type; '(PClose,_); '(DblDot,_); t = parse_complex_type; p2 = semicolon >] -> - (name,flag,AFFun (al,t),punion p1 p2) - | [< '(Kwd Private,_) when flag = None; s >] -> parse_signature_field (Some false) s - | [< '(Kwd Public,_) when flag = None; s >] -> parse_signature_field (Some true) s - -and parse_cf_rights allow_static l = parser - | [< '(Kwd Static,_) when allow_static; l = parse_cf_rights false (AStatic :: l) >] -> l - | [< '(Kwd Public,_) when not(List.mem APublic l || List.mem APrivate l); l = parse_cf_rights allow_static (APublic :: l) >] -> l - | [< '(Kwd Private,_) when not(List.mem APublic l || List.mem APrivate l); l = parse_cf_rights allow_static (APrivate :: l) >] -> l - | [< '(Kwd Override,_) when not (List.mem AOverride l); l = parse_cf_rights false (AOverride :: l) >] -> l - | [< '(Kwd Dynamic,_) when not (List.mem ADynamic l); l = parse_cf_rights allow_static (ADynamic :: l) >] -> l - | [< '(Kwd Inline,_); l = parse_cf_rights allow_static (AInline :: l) >] -> l - | [< >] -> l - -and parse_fun_name = parser - | [< '(Const (Ident name),_) >] -> name - | [< '(Const (Type name),_) >] -> name - | [< '(Kwd New,_) >] -> "new" - -and parse_fun_param = parser - | [< '(Question,_); name = any_ident; t = parse_type_opt; c = parse_fun_param_value >] -> (name,true,t,c) - | [< name = any_ident; t = parse_type_opt; c = parse_fun_param_value >] -> (name,false,t,c) - -and parse_fun_param_value = parser - | [< '(Binop OpAssign,_); e = expr >] -> Some e - | [< >] -> None - -and parse_fun_param_type = parser - | [< '(Question,_); name = any_ident; '(DblDot,_); t = parse_complex_type >] -> (name,true,t) - | [< name = any_ident; '(DblDot,_); t = parse_complex_type >] -> (name,false,t) - -and parse_constraint_params = parser - | [< '(Binop OpLt,_); l = psep Comma parse_constraint_param; '(Binop OpGt,_) >] -> l - | [< >] -> [] - -and parse_constraint_param = parser - | [< '(Const (Type name),_); s >] -> - match s with parser - | [< '(DblDot,_); s >] -> - (match s with parser - | [< '(POpen,_); l = psep Comma parse_type_path; '(PClose,_) >] -> (name,l) - | [< t = parse_type_path >] -> (name,[t]) - | [< >] -> serror()) - | [< >] -> (name,[]) - -and parse_class_herit = parser - | [< '(Kwd Extends,_); t = parse_type_path >] -> HExtends t - | [< '(Kwd Implements,_); t = parse_type_path >] -> HImplements t - -and block1 = parser - | [< '(Const (Ident name),p); s >] -> block2 name true p s - | [< '(Const (Type name),p); s >] -> block2 name false p s - | [< b = block [] >] -> EBlock b - -and block2 name ident p = parser - | [< '(DblDot,_); e = expr; l = parse_obj_decl >] -> EObjectDecl ((name,e) :: l) - | [< e = expr_next (EConst (if ident then Ident name else Type name),p); s >] -> - try - let _ = semicolon s in - let b = block [e] s in - EBlock b - with - | Error (err,p) -> - (!display_error) err p; - EBlock (block [e] s) - -and block acc s = - try - (* because of inner recursion, we can't put Display handling in errors below *) - let e = try parse_block_elt s with Display e -> display (EBlock (List.rev (e :: acc)),snd e) in - block (e :: acc) s - with - | Stream.Failure -> - List.rev acc - | Stream.Error _ -> - let tk , pos = (match Stream.peek s with None -> last_token s | Some t -> t) in - (!display_error) (Unexpected tk) pos; - block acc s - | Error (e,p) -> - (!display_error) e p; - block acc s - -and parse_block_elt = parser - | [< '(Kwd Var,p1); vl = psep Comma parse_var_decl; p2 = semicolon >] -> (EVars vl,punion p1 p2) - | [< e = expr; _ = semicolon >] -> e - -and parse_obj_decl = parser - | [< '(Comma,_); s >] -> - (match s with parser - | [< name = any_ident; '(DblDot,_); e = expr; l = parse_obj_decl >] -> (name,e) :: l - | [< >] -> []) - | [< >] -> [] - -and parse_array_decl = parser - | [< e = expr; s >] -> - (match s with parser - | [< '(Comma,_); l = parse_array_decl >] -> e :: l - | [< >] -> [e]) - | [< >] -> - [] - -and parse_var_decl = parser - | [< name = any_ident; t = parse_type_opt; s >] -> - match s with parser - | [< '(Binop OpAssign,_); e = expr >] -> (name,t,Some e) - | [< >] -> (name,t,None) - -and expr = parser - | [< '(BrOpen,p1); b = block1; '(BrClose,p2); s >] -> - let e = (b,punion p1 p2) in - (match b with - | EObjectDecl _ -> expr_next e s - | _ -> e) - | [< '(Const c,p); s >] -> expr_next (EConst c,p) s - | [< '(Kwd This,p); s >] -> expr_next (EConst (Ident "this"),p) s - | [< '(Kwd Callback,p); s >] -> expr_next (EConst (Ident "callback"),p) s - | [< '(Kwd Cast,p1); s >] -> - (match s with parser - | [< '(POpen,_); e = expr; s >] -> - (match s with parser - | [< '(Comma,_); t = parse_complex_type; '(PClose,p2); s >] -> expr_next (ECast (e,Some t),punion p1 p2) s - | [< '(PClose,p2); s >] -> expr_next (ECast (e,None),punion p1 (pos e)) s - | [< >] -> serror()) - | [< e = expr; s >] -> expr_next (ECast (e,None),punion p1 (pos e)) s - | [< >] -> serror()) - | [< '(Kwd Throw,p); e = expr >] -> (EThrow e,p) - | [< '(Kwd New,p1); t = parse_type_path; '(POpen,p); s >] -> - if is_resuming p then display (EDisplayNew t,punion p1 p); - (match s with parser - | [< al = psep Comma expr; '(PClose,p2); s >] -> expr_next (ENew (t,al),punion p1 p2) s - | [< >] -> serror()) - | [< '(POpen,p1); e = expr; '(PClose,p2); s >] -> expr_next (EParenthesis e, punion p1 p2) s - | [< '(BkOpen,p1); l = parse_array_decl; '(BkClose,p2); s >] -> expr_next (EArrayDecl l, punion p1 p2) s - | [< '(Kwd Function,p1); name = popt any_ident; '(POpen,_); al = psep Comma parse_fun_param; '(PClose,_); t = parse_type_opt; s >] -> - let make e = - let f = { - f_type = t; - f_args = al; - f_expr = e; - } in - EFunction (name,f), punion p1 (pos e) - in - (try - expr_next (make (expr s)) s - with - Display e -> display (make e)) - | [< '(Unop op,p1) when is_prefix op; e = expr >] -> make_unop op e p1 - | [< '(Binop OpSub,p1); e = expr >] -> - let neg s = - if s.[0] = '-' then String.sub s 1 (String.length s - 1) else "-" ^ s - in - (match make_unop Neg e p1 with - | EUnop (Neg,Prefix,(EConst (Int i),pc)),p -> EConst (Int (neg i)),p - | EUnop (Neg,Prefix,(EConst (Float j),pc)),p -> EConst (Float (neg j)),p - | e -> e) - (*/* removed unary + : this cause too much syntax errors go unnoticed, such as "a + + 1" (missing 'b') - without adding anything to the language - | [< '(Binop OpAdd,p1); s >] -> - (match s with parser - | [< '(Const (Int i),p); e = expr_next (EConst (Int i),p) >] -> e - | [< '(Const (Float f),p); e = expr_next (EConst (Float f),p) >] -> e - | [< >] -> serror()) */*) - | [< '(Kwd For,p); '(POpen,_); name = any_ident; '(Kwd In,_); it = expr; '(PClose,_); s >] -> - (try - let e = expr s in - (EFor (name,it,e),punion p (pos e)) - with - Display e -> display (EFor (name,it,e),punion p (pos e))) - | [< '(Kwd If,p); '(POpen,_); cond = expr; '(PClose,_); e1 = expr; s >] -> - let e2 , s = (match s with parser - | [< '(Kwd Else,_); e2 = expr; s >] -> Some e2 , s - | [< >] -> - (* - we can't directly npeek 2 elements because this might - remove some documentation tag. - *) - match Stream.npeek 1 s with - | [(Semicolon,_)] -> - (match Stream.npeek 2 s with - | [(Semicolon,_); (Kwd Else,_)] -> - Stream.junk s; - Stream.junk s; - (match s with parser - | [< e2 = expr; s >] -> Some e2, s - | [< >] -> serror()) - | _ -> None , s) - | _ -> - None , s - ) in - (EIf (cond,e1,e2), punion p (match e2 with None -> pos e1 | Some e -> pos e)) - | [< '(Kwd Return,p); e = popt expr >] -> (EReturn e, match e with None -> p | Some e -> punion p (pos e)) - | [< '(Kwd Break,p) >] -> (EBreak,p) - | [< '(Kwd Continue,p) >] -> (EContinue,p) - | [< '(Kwd While,p1); '(POpen,_); cond = expr; '(PClose,_); s >] -> - (try - let e = expr s in - (EWhile (cond,e,NormalWhile),punion p1 (pos e)) - with - Display e -> display (EWhile (cond,e,NormalWhile),punion p1 (pos e))) - | [< '(Kwd Do,p1); e = expr; '(Kwd While,_); '(POpen,_); cond = expr; '(PClose,_); s >] -> (EWhile (cond,e,DoWhile),punion p1 (pos e)) - | [< '(Kwd Switch,p1); e = expr; '(BrOpen,_); cases , def = parse_switch_cases e []; '(BrClose,p2); s >] -> (ESwitch (e,cases,def),punion p1 p2) - | [< '(Kwd Try,p1); e = expr; cl = plist (parse_catch e); s >] -> (ETry (e,cl),p1) - | [< '(IntInterval i,p1); e2 = expr >] -> make_binop OpInterval (EConst (Int i),p1) e2 - | [< '(Kwd Untyped,p1); e = expr >] -> (EUntyped e,punion p1 (pos e)) - -and expr_next e1 = parser - | [< '(Dot,p); s >] -> - if is_resuming p then display (EDisplay (e1,false),p); - (match s with parser - | [< '(Const (Ident f),p2) when p.pmax = p2.pmin; s >] -> expr_next (EField (e1,f) , punion (pos e1) p2) s - | [< '(Const (Type t),p2) when p.pmax = p2.pmin; s >] -> expr_next (EType (e1,t) , punion (pos e1) p2) s - | [< '(Binop OpOr,p2) when do_resume() >] -> display (EDisplay (e1,false),p) (* help for debug display mode *) - | [< >] -> - (* turn an integer followed by a dot into a float *) - match e1 with - | (EConst (Int v),p2) when p2.pmax = p.pmin -> expr_next (EConst (Float (v ^ ".")),punion p p2) s - | _ -> serror()) - | [< '(POpen,p1); s >] -> - if is_resuming p1 then display (EDisplay (e1,true),p1); - (match s with parser - | [< params = parse_call_params e1; '(PClose,p2); s >] -> expr_next (ECall (e1,params) , punion (pos e1) p2) s - | [< >] -> serror()) - | [< '(BkOpen,_); e2 = expr; '(BkClose,p2); s >] -> - expr_next (EArray (e1,e2), punion (pos e1) p2) s - | [< '(Binop OpGt,_); s >] -> - (match s with parser - | [< '(Binop OpGt,_); s >] -> - (match s with parser - | [< '(Binop OpGt,_) >] -> - (match s with parser - | [< '(Binop OpAssign,_); e2 = expr >] -> make_binop (OpAssignOp OpUShr) e1 e2 - | [< e2 = expr >] -> make_binop OpUShr e1 e2 - | [< >] -> serror()) - | [< '(Binop OpAssign,_); e2 = expr >] -> make_binop (OpAssignOp OpShr) e1 e2 - | [< e2 = expr >] -> make_binop OpShr e1 e2 - | [< >] -> serror()) - | [< '(Binop OpAssign,_); s >] -> - (match s with parser - | [< e2 = expr >] -> make_binop OpGte e1 e2 - | [< >] -> serror()) - | [< e2 = expr >] -> - make_binop OpGt e1 e2 - | [< >] -> serror()) - | [< '(Binop op,_); e2 = expr >] -> - make_binop op e1 e2 - | [< '(Unop op,p) when is_postfix e1 op; s >] -> - expr_next (EUnop (op,Postfix,e1), punion (pos e1) p) s - | [< '(Question,_); e2 = expr; '(DblDot,_); e3 = expr >] -> - (ETernary (e1,e2,e3),punion (pos e1) (pos e3)) - | [< >] -> e1 - -and parse_switch_cases eswitch cases = parser - | [< '(Kwd Default,p1); '(DblDot,_); s >] -> - let b = EBlock (try block [] s with Display e -> display (ESwitch (eswitch,cases,Some e),punion (pos eswitch) (pos e))) in - let l , def = parse_switch_cases eswitch cases s in - (match def with None -> () | Some (e,p) -> error Duplicate_default p); - l , Some (b,p1) - | [< '(Kwd Case,p1); el = psep Comma expr; '(DblDot,_); s >] -> - let b = EBlock (try block [] s with Display e -> display (ESwitch (eswitch,List.rev ((el,e) :: cases),None),punion (pos eswitch) (pos e))) in - parse_switch_cases eswitch ((el,(b,p1)) :: cases) s - | [< >] -> - List.rev cases , None - -and parse_catch etry = parser - | [< '(Kwd Catch,p); '(POpen,_); name = any_ident; s >] -> - match s with parser - | [< '(DblDot,_); t = parse_complex_type; '(PClose,_); s >] -> - (try - match s with parser - | [< e = expr >] -> (name,t,e) - | [< >] -> serror() - with - Display e -> display (ETry (etry,[name,t,e]),punion (pos etry) (pos e))) - | [< '(_,p) >] -> error Missing_type p - -and parse_call_params ec s = - let e = (try - match s with parser - | [< e = expr >] -> Some e - | [< >] -> None - with Display e -> - display (ECall (ec,[e]),punion (pos ec) (pos e)) - ) in - let rec loop acc = - try - match s with parser - | [< '(Comma,_); e = expr >] -> loop (e::acc) - | [< >] -> List.rev acc - with Display e -> - display (ECall (ec,List.rev (e::acc)),punion (pos ec) (pos e)) - in - match e with - | None -> [] - | Some e -> loop [e] - -and parse_macro_cond allow_op s = - match s with parser - | [< '(Const (Ident t | Type t),p) >] -> - let e = (EConst (Ident t),p) in - if not allow_op then - None, e - else (match Stream.peek s with - | Some (Binop op,_) -> - Stream.junk s; - let tk, e2 = (try parse_macro_cond true s with Stream.Failure -> serror()) in - tk, make_binop op e e2 - | tk -> - tk, e); - | [< '(POpen, p1); _,e = parse_macro_cond true; '(PClose, p2) >] -> - None, (EParenthesis e,punion p1 p2) - | [< '(Unop op,p); tk, e = parse_macro_cond allow_op >] -> - tk, make_unop op e p - -and toplevel_expr s = - try - expr s - with - Display e -> e - -let parse ctx code = - let old = Lexer.save() in - let old_cache = !cache in - let mstack = ref [] in - cache := DynArray.create(); - doc := None; - Lexer.skip_header code; - let sraw = Stream.from (fun _ -> Some (Lexer.token code)) in - let rec next_token() = process_token (Lexer.token code) - - and process_token tk = - match fst tk with - | Comment s -> - if !use_doc then begin - let l = String.length s in - if l > 0 && s.[0] = '*' then doc := Some (String.sub s 1 (l - (if l > 1 && s.[l-1] = '*' then 2 else 1))); - end; - next_token() - | CommentLine s -> - next_token() - | Macro "end" -> - (match !mstack with - | [] -> raise Exit - | _ :: l -> - mstack := l; - next_token()) - | Macro "else" | Macro "elseif" -> - (match !mstack with - | [] -> raise Exit - | _ :: l -> - mstack := l; - process_token (skip_tokens (snd tk) false)) - | Macro "if" -> - process_token (enter_macro (snd tk)) - | Macro "error" -> - (match Lexer.token code with - | (Const (String s),p) -> error (Custom s) p - | _ -> error Unimplemented (snd tk)) - | Macro "line" -> - let line = (match next_token() with - | (Const (Int s),_) -> int_of_string s - | (t,p) -> error (Unexpected t) p - ) in - !(Lexer.cur).Lexer.lline <- line - 1; - next_token(); - | _ -> - tk - - and enter_macro p = - let rec loop (e,p) = - match e with - | EConst (Ident i) -> Common.defined ctx i - | EBinop (OpBoolAnd, e1, e2) -> loop e1 && loop e2 - | EBinop (OpBoolOr, e1, e2) -> loop e1 || loop e2 - | EUnop (Not, _, e) -> not (loop e) - | EParenthesis e -> loop e - | _ -> error Unclosed_macro p - in - let tk, e = parse_macro_cond false sraw in - let tk = (match tk with None -> Lexer.token code | Some tk -> tk) in - if loop e then begin - mstack := p :: !mstack; - tk - end else - skip_tokens_loop p true tk - - and skip_tokens_loop p test tk = - match fst tk with - | Macro "end" -> - Lexer.token code - | Macro "elseif" | Macro "else" when not test -> - skip_tokens p test - | Macro "else" -> - mstack := snd tk :: !mstack; - Lexer.token code - | Macro "elseif" -> - enter_macro (snd tk) - | Macro "if" -> - skip_tokens_loop p test (skip_tokens p false) - | Eof -> - error Unclosed_macro p - | _ -> - skip_tokens p test - - and skip_tokens p test = skip_tokens_loop p test (Lexer.token code) - - in - let s = Stream.from (fun _ -> - try - let t = next_token() in - DynArray.add (!cache) t; - Some t - with - Exit -> None - ) in - try - let l = parse_file s in - (match !mstack with [] -> () | p :: _ -> error Unclosed_macro p); - cache := old_cache; - Lexer.restore old; - l - with - | Stream.Error _ - | Stream.Failure -> - let last = (match Stream.peek s with None -> last_token s | Some t -> t) in - Lexer.restore old; - cache := old_cache; - error (Unexpected (fst last)) (pos last) - | e -> - Lexer.restore old; - cache := old_cache; - raise e diff --git a/haxe/std/Array.hx b/haxe/std/Array.hx deleted file mode 100644 index 5d551053361d58ae87adc737924ca213c7c8d7de..0000000000000000000000000000000000000000 --- a/haxe/std/Array.hx +++ /dev/null @@ -1,127 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - An Array is a storage for values. You can access it using indexes or - with its API. On the server side, it's often better to use a [List] which - is less memory and CPU consuming, unless you really need indexed access. -**/ -extern class Array { - - /** - The length of the Array - **/ - var length(default,null) : Int; - - /** - Creates a new Array. - **/ - function new() : Void; - - /** - Returns a new Array by appending [a] to [this]. - **/ - function concat( a : Array ) : Array; - - /** - Returns a representation of an array with [sep] for separating each element. - **/ - function join( sep : String ) : String; - - /** - Removes the last element of the array and returns it. - **/ - function pop() : Null; - - /** - Adds the element [x] at the end of the array. - **/ - function push(x : T) : Int; - - /** - Reverse the order of elements of the Array. - **/ - function reverse() : Void; - - /** - Removes the first element and returns it. - **/ - function shift() : Null; - - /** - Copies the range of the array starting at [pos] up to, - but not including, [end]. Both [pos] and [end] can be - negative to count from the end: -1 is the last item in - the array. - **/ - function slice( pos : Int, ?end : Int ) : Array; - - /** - Sort the Array according to the comparison function [f]. - [f(x,y)] should return [0] if [x == y], [>0] if [x > y] - and [<0] if [x < y]. - **/ - function sort( f : T -> T -> Int ) : Void; - - /** - Removes [len] elements starting from [pos] an returns them. - **/ - function splice( pos : Int, len : Int ) : Array; - - /** - Returns a displayable representation of the Array content. - **/ - function toString() : String; - - /** - Adds the element [x] at the start of the array. - **/ - function unshift( x : T ) : Void; - - /** - Inserts the element [x] at the position [pos]. - All elements after [pos] are moved one index ahead. - **/ - function insert( pos : Int, x : T ) : Void; - - /** - Removes the first occurence of [x]. - Returns false if [x] was not present. - Elements are compared by using standard equality. - **/ - function remove( x : T ) : Bool; - - /** - Returns a copy of the Array. The values are not - copied, only the Array structure. - **/ - function copy() : Array; - - /** - Returns an iterator of the Array values. - **/ - function iterator() : Iterator>; - -} diff --git a/haxe/std/Class.hx b/haxe/std/Class.hx deleted file mode 100644 index dcc20ac594925698c42ca4096b1e9f9c73b667e6..0000000000000000000000000000000000000000 --- a/haxe/std/Class.hx +++ /dev/null @@ -1,31 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - An abstract type that represents a Class. - See [Type] for the haXe Reflection API. -**/ -extern class Class { -} diff --git a/haxe/std/Date.hx b/haxe/std/Date.hx deleted file mode 100644 index a2f886c471e63ffcde1374397c67d416940b7504..0000000000000000000000000000000000000000 --- a/haxe/std/Date.hx +++ /dev/null @@ -1,175 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - The Date class is used for date manipulation. There is some extra functions - available in the [DateTools] class. -**/ - -extern class Date -{ - /** - Creates a new date object. - **/ - function new(year : Int, month : Int, day : Int, hour : Int, min : Int, sec : Int ) : Void; - - /** - Returns the timestamp of the date. It's the number of milliseconds - elapsed since 1st January 1970. It might only have a per-second precision - depending on the platforms. - **/ - function getTime() : Float; - - /** - Returns the hours value of the date (0-23 range). - **/ - function getHours() : Int; - - /** - Returns the minutes value of the date (0-59 range). - **/ - function getMinutes() : Int; - - /** - Returns the seconds of the date (0-59 range). - **/ - function getSeconds() : Int; - - /** - Returns the full year of the date. - **/ - function getFullYear() : Int; - - /** - Returns the month of the date (0-11 range). - **/ - function getMonth() : Int; - - /** - Returns the day of the date (1-31 range). - **/ - function getDate() : Int; - - /** - Returns the week day of the date (0-6 range). - **/ - function getDay() : Int; - - /** - Returns a string representation for the Date, by using the - standard format [YYYY-MM-DD HH:MM:SS]. See [DateTools.format] for - other formating rules. - **/ - function toString():String; - - /** - Returns a Date representing the current local time. - **/ - static function now() : Date; - - /** - Returns a Date from a timestamp [t] which is the number of - milliseconds elapsed since 1st January 1970. - **/ - static function fromTime( t : Float ) : Date; - - /** - Returns a Date from a formated string of one of the following formats : - [YYYY-MM-DD hh:mm:ss] or [YYYY-MM-DD] or [hh:mm:ss]. The first two formats - are expressed in local time, the third in UTC Epoch. - **/ - static function fromString( s : String ) : Date; - - -#if (js || flash) - private static function __init__() : Void untyped { - var d #if !swf_mark : Dynamic #end = Date; - d.now = function() { - return __new__(Date); - }; - d.fromTime = function(t){ - var d : Date = __new__(Date); - #if flash9 - d.setTime(t); - #else - d["setTime"]( t ); - #end - return d; - }; - d.fromString = function(s : String) { - switch( s.length ) { - case 8: // hh:mm:ss - var k = s.split(":"); - var d : Date = __new__(Date); - #if flash9 - d.setTime(0); - d.setUTCHours(k[0]); - d.setUTCMinutes(k[1]); - d.setUTCSeconds(k[2]); - #else - d["setTime"](0); - d["setUTCHours"](k[0]); - d["setUTCMinutes"](k[1]); - d["setUTCSeconds"](k[2]); - #end - return d; - case 10: // YYYY-MM-DD - var k = s.split("-"); - return new Date(cast k[0],cast k[1] - 1,cast k[2],0,0,0); - case 19: // YYYY-MM-DD hh:mm:ss - var k = s.split(" "); - var y = k[0].split("-"); - var t = k[1].split(":"); - return new Date(cast y[0],cast y[1] - 1,cast y[2],cast t[0],cast t[1],cast t[2]); - default: - throw "Invalid date format : " + s; - } - }; - d.prototype[#if as3 "toStringHX" #else "toString" #end] = function() { - var date : Date = this; - var m = date.getMonth() + 1; - var d = date.getDate(); - var h = date.getHours(); - var mi = date.getMinutes(); - var s = date.getSeconds(); - return date.getFullYear() - +"-"+(if( m < 10 ) "0"+m else ""+m) - +"-"+(if( d < 10 ) "0"+d else ""+d) - +" "+(if( h < 10 ) "0"+h else ""+h) - +":"+(if( mi < 10 ) "0"+mi else ""+mi) - +":"+(if( s < 10 ) "0"+s else ""+s); - }; - #if flash9 - #elseif flash - d.prototype[__unprotect__("__class__")] = d; - d[__unprotect__("__name__")] = ["Date"]; - #else - d.prototype.__class__ = d; - d.__name__ = ["Date"]; - #end - } -#end -} - diff --git a/haxe/std/EReg.hx b/haxe/std/EReg.hx deleted file mode 100644 index 9f1626872b4fa1c9d25a97e249beee2ed39bc832..0000000000000000000000000000000000000000 --- a/haxe/std/EReg.hx +++ /dev/null @@ -1,117 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - Regular expressions are a way to find regular patterns into - Strings. Have a look at the tutorial on haXe website to learn - how to use them. -**/ -class EReg { - - /** - Creates a new regular expression with pattern [r] and - options [opt]. - **/ - public function new( r : String, opt : String ) { - throw "Regular expressions are not implemented for this platform"; - } - - /** - Tells if the regular expression matches the String. - Updates the internal state accordingly. - **/ - public function match( s : String ) : Bool { - return false; - } - - /** - Returns a matched group or throw an expection if there - is no such group. If [n = 0], the whole matched substring - is returned. - **/ - public function matched( n : Int ) : String { - return null; - } - - /** - Returns the part of the string that was as the left of - of the matched substring. - **/ - public function matchedLeft() : String { - return null; - } - - /** - Returns the part of the string that was at the right of - of the matched substring. - **/ - public function matchedRight() : String { - return null; - } - - /** - Returns the position of the matched substring within the - original matched string. - **/ - public function matchedPos() : { pos : Int, len : Int } { - return null; - } - - /** - Split a string by using the regular expression to match - the separators. - **/ - public function split( s : String ) : Array { - return null; - } - - /** - Replaces a pattern by another string. The [by] format can - contains [$1] to [$9] that will correspond to groups matched - while replacing. [$$] means the [$] character. - **/ - public function replace( s : String, by : String ) : String { - return null; - } - - /** - For each occurence of the pattern in the string [s], the function [f] is called and - can return the string that needs to be replaced. All occurences are matched anyway, - and setting the [g] flag might cause some incorrect behavior on some platforms. - **/ - public function customReplace( s : String, f : EReg -> String ) : String { - var buf = new StringBuf(); - while( true ) { - if( !match(s) ) - break; - buf.add(matchedLeft()); - buf.add(f(this)); - s = matchedRight(); - } - buf.add(s); - return buf.toString(); - } - -} diff --git a/haxe/std/Enum.hx b/haxe/std/Enum.hx deleted file mode 100644 index 85d7588906aaaef23d5ed8973ddae86a1d1ad168..0000000000000000000000000000000000000000 --- a/haxe/std/Enum.hx +++ /dev/null @@ -1,7 +0,0 @@ - -/** - An abstract type that represents an Enum. - See [Type] for the haXe Reflection API. -**/ -extern class Enum { -} diff --git a/haxe/std/Hash.hx b/haxe/std/Hash.hx deleted file mode 100644 index 8539fa1fcdfb7bd341558c61c11d76532ccf542f..0000000000000000000000000000000000000000 --- a/haxe/std/Hash.hx +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - Hashtable over a set of elements, using [String] as keys. - Other kind of keys are not possible on all platforms since they - can't always be implemented efficiently. -**/ -extern class Hash { - - /** - Creates a new empty hashtable. - **/ - public function new() : Void; - - /** - Set a value for the given key. - **/ - public function set( key : String, value : T ) : Void; - - /** - Get a value for the given key. - **/ - public function get( key : String ) : Null; - - /** - Tells if a value exists for the given key. - In particular, it's useful to tells if a key has - a [null] value versus no value. - **/ - public function exists( key : String ) : Bool; - - /** - Removes a hashtable entry. Returns [true] if - there was such entry. - **/ - public function remove( key : String ) : Bool; - - - /** - Returns an iterator of all keys in the hashtable. - **/ - public function keys() : Iterator; - - /** - Returns an iterator of all values in the hashtable. - **/ - public function iterator() : Iterator; - - /** - Returns an displayable representation of the hashtable content. - **/ - public function toString() : String; - -} diff --git a/haxe/std/IntHash.hx b/haxe/std/IntHash.hx deleted file mode 100644 index 9907d74b529187e119cfaaf8b087bb28e6526a86..0000000000000000000000000000000000000000 --- a/haxe/std/IntHash.hx +++ /dev/null @@ -1,74 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - Hashtable over a set of elements, using [Int] as keys. - On Flash and Javascript, the underlying structure is an Object. -**/ -extern class IntHash { - - /** - Creates a new empty hashtable. - **/ - public function new() : Void; - - /** - Set a value for the given key. - **/ - public function set( key : Int, value : T ) : Void; - /** - Get a value for the given key. - **/ - public function get( key : Int ) : Null; - - /** - Tells if a value exists for the given key. - In particular, it's useful to tells if a key has - a [null] value versus no value. - **/ - public function exists( key : Int ) : Bool; - - /** - Removes a hashtable entry. Returns [true] if - there was such entry. - **/ - public function remove( key : Int ) : Bool; - - /** - Returns an iterator of all keys in the hashtable. - **/ - public function keys() : Iterator; - - /** - Returns an iterator of all values in the hashtable. - **/ - public function iterator() : Iterator; - - /** - Returns an displayable representation of the hashtable content. - **/ - public function toString() : String; - -} diff --git a/haxe/std/IntIter.hx b/haxe/std/IntIter.hx deleted file mode 100644 index 0fd247eec30ab7353eeb508bd8b67740a5109b42..0000000000000000000000000000000000000000 --- a/haxe/std/IntIter.hx +++ /dev/null @@ -1,57 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - Integer iterator. Used for interval implementation. -**/ -class IntIter { - - var min : Int; - var max : Int; - - /** - Iterate from [min] (inclusive) to [max] (exclusive). - If [max <= min], the iterator will not act as a countdown. - **/ - public function new( min : Int, max : Int ) { - this.min = min; - this.max = max; - } - - /** - Returns true if the iterator has other items, false otherwise. - **/ - public function hasNext() { - return min < max; - } - - /** - Moves to the next item of the iterator. - **/ - public function next() { - return min++; - } - -} diff --git a/haxe/std/Lambda.hx b/haxe/std/Lambda.hx deleted file mode 100644 index 90a1278541854e0f3c107926032d6e074b044b8e..0000000000000000000000000000000000000000 --- a/haxe/std/Lambda.hx +++ /dev/null @@ -1,190 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - The [Lambda] class is a collection of functional methods in order to - use functional-style programming with haXe. -**/ -class Lambda { - - /** - Creates an [Array] from an [Iterable] - **/ - public static function array( it : Iterable ) : Array { - var a = new Array(); - for(i in it) - a.push(i); - return a; - } - - /** - Creates a [List] from an [Iterable] - **/ - public static function list( it : Iterable ) : List { - var l = new List(); - for(i in it) - l.add(i); - return l; - } - - /** - Creates a new [Iterable] by appling the function 'f' to all - elements of the iterator 'it'. - **/ - public static function map( it : Iterable, f : A -> B ) : List { - var l = new List(); - for( x in it ) - l.add(f(x)); - return l; - } - - /** - Similar to [map], but also pass an index for each item iterated. - **/ - public static function mapi( it : Iterable, f : Int -> A -> B ) : List { - var l = new List(); - var i = 0; - for( x in it ) - l.add(f(i++,x)); - return l; - } - - /** - Tells if the element is part of an iterable. The comparison - is made using the [==] operator. Optionally you can pass as - a third parameter a function that performs the comparison. - That function must take as arguments the two items to - compare and returns a boolean value. - **/ - public static function has( it : Iterable, elt : A, ?cmp : A -> A -> Bool ) : Bool { - if( cmp == null ) { - for( x in it ) - if( x == elt ) - return true; - } else { - for( x in it ) - if( cmp(x,elt) ) - return true; - } - return false; - } - - /** - Tells if at least one element of the iterable is found by using the specific function. - **/ - public static function exists( it : Iterable, f : A -> Bool ) { - for( x in it ) - if( f(x) ) - return true; - return false; - } - - /** - Tells if all elements of the iterable have the specified property defined by [f]. - **/ - public static function foreach( it : Iterable, f : A -> Bool ) { - for( x in it ) - if( !f(x) ) - return false; - return true; - } - - /** - Call the function 'f' on all elements of the [Iterable] 'it'. - **/ - public static function iter( it : Iterable, f : A -> Void ) { - for( x in it ) - f(x); - } - - /** - Return the list of elements matching the function 'f' - **/ - public static function filter( it : Iterable, f : A -> Bool ) { - var l = new List(); - for( x in it ) - if( f(x) ) - l.add(x); - return l; - } - - /** - Functional 'fold' using an [Iterable] - **/ - public static function fold( it : Iterable, f : A -> B -> B, first : B ) : B { - for( x in it ) - first = f(x,first); - return first; - } - - /** - Count the number of elements in an [Iterable] having [pred] returning true. - **/ - public static function count( it : Iterable, ?pred : A -> Bool ) { - var n = 0; - if( pred == null ) - for( _ in it ) - n++; - else - for( x in it ) - if( pred(x) ) - n++; - return n; - } - - /** - Tells if an iterable does not contain any element. - **/ - public static function empty( it : Iterable ) : Bool { - return !it.iterator().hasNext(); - } - - /** - Returns the index of the item in the given Iterable, depending on the order of the Iterator. - Returns -1 if the item was not found. - **/ - public static function indexOf( it : Iterable, v : T ) : Int { - var i = 0; - for( v2 in it ) { - if( v == v2 ) - return i; - i++; - } - return -1; - } - - /** - Returns a list containing all items of 'a' followed by all items of 'b' - **/ - public static function concat( a : Iterable, b : Iterable ) : List { - var l = new List(); - for( x in a ) - l.add(x); - for( x in b ) - l.add(x); - return l; - } - -} diff --git a/haxe/std/List.hx b/haxe/std/List.hx deleted file mode 100644 index 54e91f6708cb79511f5d2109bf25ec63af74876e..0000000000000000000000000000000000000000 --- a/haxe/std/List.hx +++ /dev/null @@ -1,239 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - A linked-list of elements. The list is composed of two-elements arrays - that are chained together. It's optimized so that adding or removing an - element doesn't imply to copy the whole array content everytime. -**/ -class List { - - private var h : Array; - private var q : Array; - - /** - The number of elements in this list. - **/ - public var length(default,null) : Int; - - /** - Creates a new empty list. - **/ - public function new() { - length = 0; - } - - /** - Add an element at the end of the list. - **/ - public function add( item : T ) { - var x = #if neko untyped __dollar__array(item,null) #else [item] #end; - if( h == null ) - h = x; - else - q[1] = x; - q = x; - length++; - } - - /** - Push an element at the beginning of the list. - **/ - public function push( item : T ) { - var x = #if neko - untyped __dollar__array(item,h) - #else - [item,h] - #end; - h = x; - if( q == null ) - q = x; - length++; - } - - /** - Returns the first element of the list, or null - if the list is empty. - **/ - public function first() : T { - return if( h == null ) null else h[0]; - } - - /** - Returns the last element of the list, or null - if the list is empty. - **/ - public function last() : T { - return if( q == null ) null else q[0]; - } - - - /** - Removes the first element of the list and - returns it or simply returns null if the - list is empty. - **/ - public function pop() : T { - if( h == null ) - return null; - var x = h[0]; - h = h[1]; - if( h == null ) - q = null; - length--; - return x; - } - - /** - Tells if a list is empty. - **/ - public function isEmpty() : Bool { - return (h == null); - } - - /** - Makes the list empty. - **/ - public function clear() : Void { - h = null; - q = null; - length = 0; - } - - /** - Remove the first element that is [== v] from the list. - Returns [true] if an element was removed, [false] otherwise. - **/ - public function remove( v : T ) : Bool { - var prev = null; - var l = h; - while( l != null ) { - if( l[0] == v ) { - if( prev == null ) - h = l[1]; - else - prev[1] = l[1]; - if( q == l ) - q = prev; - length--; - return true; - } - prev = l; - l = l[1]; - } - return false; - } - - /** - Returns an iterator on the elements of the list. - **/ - public function iterator() : Iterator { - return cast { - h : h, - hasNext : function() { - return untyped (this.h != null); - }, - next : function() { - untyped { - if( this.h == null ) - return null; - var x = this.h[0]; - this.h = this.h[1]; - return x; - } - } - } - } - - /** - Returns a displayable representation of the String. - **/ - public function toString() { - var s = new StringBuf(); - var first = true; - var l = h; - s.add("{"); - while( l != null ) { - if( first ) - first = false; - else - s.add(", "); - s.add(Std.string(l[0])); - l = l[1]; - } - s.add("}"); - return s.toString(); - } - - /** - Join the element of the list by using the separator [sep]. - **/ - public function join(sep : String) { - var s = new StringBuf(); - var first = true; - var l = h; - while( l != null ) { - if( first ) - first = false; - else - s.add(sep); - s.add(l[0]); - l = l[1]; - } - return s.toString(); - } - - /** - Returns a list filtered with [f]. The returned list - will contain all elements [x] for which [f(x) = true]. - **/ - public function filter( f : T -> Bool ) { - var l2 = new List(); - var l = h; - while( l != null ) { - var v = l[0]; - l = l[1]; - if( f(v) ) - l2.add(v); - } - return l2; - } - - /** - Returns a new list where all elements have been converted - by the function [f]. - **/ - public function map(f : T -> X) : List { - var b = new List(); - var l = h; - while( l != null ) { - var v = l[0]; - l = l[1]; - b.add(f(v)); - } - return b; - } - -} diff --git a/haxe/std/Math.hx b/haxe/std/Math.hx deleted file mode 100644 index 724ed342b1e033a637d4671deb3c0bef2d3d2458..0000000000000000000000000000000000000000 --- a/haxe/std/Math.hx +++ /dev/null @@ -1,97 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - This class defines mathematical functions and constants. -**/ -extern class Math -{ - static var PI(default,null) : Float; - static var NaN(default,null) : Float; - static var NEGATIVE_INFINITY(default,null) : Float; - static var POSITIVE_INFINITY(default,null) : Float; - - static function abs(v:Float):Float; - static function min(a:Float,b:Float):Float; - static function max(a:Float,b:Float):Float; - static function sin(v:Float):Float; - static function cos(v:Float):Float; - static function atan2(y:Float,x:Float):Float; - static function tan(v:Float):Float; - static function exp(v:Float):Float; - static function log(v:Float):Float; - static function sqrt(v:Float):Float; - static function round(v:Float):Int; - static function floor(v:Float):Int; - static function ceil(v:Float):Int; - static function atan(v:Float):Float; - static function asin(v:Float):Float; - static function acos(v:Float):Float; - static function pow(v:Float,exp:Float):Float; - static function random() : Float; - - static function isFinite( f : Float ) : Bool; - static function isNaN( f : Float ) : Bool; - - private static function __init__() : Void untyped { - #if flash9 - NaN = __global__["Number"].NaN; - NEGATIVE_INFINITY = __global__["Number"].NEGATIVE_INFINITY; - POSITIVE_INFINITY = __global__["Number"].POSITIVE_INFINITY; - #else - Math.__name__ = ["Math"]; - Math.NaN = Number["NaN"]; - Math.NEGATIVE_INFINITY = Number["NEGATIVE_INFINITY"]; - Math.POSITIVE_INFINITY = Number["POSITIVE_INFINITY"]; - #end - Math.isFinite = function(i) { - return - #if flash9 - __global__["isFinite"](i); - #elseif flash - _global["isFinite"](i); - #elseif js - __js__("isFinite")(i); - #else - false; - #end - }; - Math.isNaN = function(i) { - return - #if flash9 - __global__["isNaN"](i); - #elseif flash - _global["isNaN"](i); - #elseif js - __js__("isNaN")(i); - #else - false; - #end - }; - } - -} - - diff --git a/haxe/std/Reflect.hx b/haxe/std/Reflect.hx deleted file mode 100644 index 48211e3b884e0cdf32655275624dc7ffe2180390..0000000000000000000000000000000000000000 --- a/haxe/std/Reflect.hx +++ /dev/null @@ -1,96 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - The Reflect API is a way to manipulate values dynamicly through an - abstract interface in an untyped manner. Use with care. -**/ -extern class Reflect { - - /** - Tells if an object has a field set. This doesn't take into account the object prototype (class methods). - **/ - public static function hasField( o : Dynamic, field : String ) : Bool; - - /** - Returns the field of an object, or null if [o] is not an object or doesn't have this field. - **/ - public static function field( o : Dynamic, field : String ) : Dynamic; - - - /** - Set an object field value. - **/ - public inline static function setField( o : Dynamic, field : String, value : Dynamic ) : Void; - - /** - Call a method with the given object and arguments. - **/ - public static function callMethod( o : Dynamic, func : Dynamic, args : Array ) : Dynamic; - - /** - Returns the list of fields of an object, excluding its prototype (class methods). - **/ - public static function fields( o : Dynamic ) : Array; - - /** - Tells if a value is a function or not. - **/ - public static function isFunction( f : Dynamic ) : Bool; - - /** - Generic comparison function, does not work for methods, see [compareMethods] - **/ - public static function compare( a : T, b : T ) : Int; - - /** - Compare two methods closures. Returns true if it's the same method of the same instance. - Does not work on Neko platform. - **/ - public static function compareMethods( f1 : Dynamic, f2 : Dynamic ) : Bool; - - /** - Tells if a value is an object or not. - - **/ - public static function isObject( v : Dynamic ) : Bool; - - /** - Delete an object field. - **/ - public static function deleteField( o : Dynamic, f : String ) : Bool; - - /** - Make a copy of the fields of an object. - **/ - public static function copy( o : T ) : T; - - /** - Transform a function taking an array of arguments into a function that can - be called with any number of arguments. - **/ - public static function makeVarArgs( f : Array -> Dynamic ) : Dynamic; - -} diff --git a/haxe/std/Std.hx b/haxe/std/Std.hx deleted file mode 100644 index a73310440acad4c44422c135e8d6928dfa074f62..0000000000000000000000000000000000000000 --- a/haxe/std/Std.hx +++ /dev/null @@ -1,65 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -#if !(core_api || cross) -#error "Please don't add haxe/std to your classpath, instead set HAXE_LIBRARY_PATH env var" -#end - -/** - The Std class provides standard methods for manipulating basic types. -**/ -extern class Std { - - /** - Tells if a value v is of the type t. - **/ - public static function is( v : Dynamic, t : Dynamic ) : Bool; - - /** - Convert any value to a String - **/ - public static function string( s : Dynamic ) : String; - - /** - Convert a Float to an Int, rounded down. - **/ - public static function int( x : Float ) : Int; - - /** - Convert a String to an Int, parsing different possible representations. Returns [null] if could not be parsed. - **/ - public static function parseInt( x : String ) : Null; - - /** - Convert a String to a Float, parsing different possible reprensations. - **/ - public static function parseFloat( x : String ) : Float; - - /** - Return a random integer between 0 included and x excluded. - **/ - public static function random( x : Int ) : Int; - -} diff --git a/haxe/std/StdTypes.hx b/haxe/std/StdTypes.hx deleted file mode 100644 index 95c7662ff4d109aec2dcf171aaefb775e9b5886a..0000000000000000000000000000000000000000 --- a/haxe/std/StdTypes.hx +++ /dev/null @@ -1,96 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -// standard haXe types - -/** - The standard Void type. Only [null] values can be of the type [Void]. -**/ -extern enum Void { } - -/** - The standard Float type, this is a double-precision IEEE 64bit float. -**/ -extern class Float { } - -/** - The standard Int type. Its precision depends on the platform. -**/ -extern class Int extends Float { } - -#if (flash9 || flash9doc) -/** - The unsigned Int type is only defined for Flash9. It's currently - handled the same as a normal Int. -**/ -typedef UInt = Int -#end - -/** - [Null] can be useful in two cases. In order to document some methods - that accepts or can return a [null] value, or for the Flash9 compiler and AS3 - generator to distinguish between base values that can be null and others that - can't. -**/ -typedef Null = T - -/** - The standard Boolean type is represented as an enum with two choices. -**/ -extern enum Bool { - true; - false; -} - -/** - Dynamic is an internal compiler type which has special behavior. - See the haXe language reference for more informations. -**/ -extern class Dynamic { -} - -/** - An Iterator is a structure that permits to list a given container - values. It can be used by your own data structures. See the haXe - documentation for more informations. -**/ -typedef Iterator = { - function hasNext() : Bool; - function next() : T; -} - -/** - An Iterable is a data structure which has an iterator() method. - See [Lambda] for generic functions on iterable structures. -**/ -typedef Iterable = { - function iterator() : Iterator; -} - -/** - ArrayAccess is used to indicate a class that can be accessed using brackets. - The type parameter represent the type of the elements stored. -**/ -extern interface ArrayAccess { } diff --git a/haxe/std/String.hx b/haxe/std/String.hx deleted file mode 100644 index bccf9e0d5aa188089bc1d136558de9bd699e7787..0000000000000000000000000000000000000000 --- a/haxe/std/String.hx +++ /dev/null @@ -1,94 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - The basic String class. -**/ -extern class String { - - /** - The number of characters in the String. - **/ - var length(default,null) : Int; - - /** - Creates a copy from a given String. - **/ - function new(string:String) : Void; - - /** - Returns an String where all characters have been uppercased. - **/ - function toUpperCase() : String; - - /** - Returns an String where all characters have been lowercased. - **/ - function toLowerCase() : String; - - /** - Returns the character at the given position. - Returns the empty String if outside of String bounds. - **/ - function charAt( index : Int) : String; - - /** - Returns the character code at the given position. - Returns [null] if outside of String bounds. - **/ - function charCodeAt( index : Int) : Null; - - /** - Returns the index of first occurence of [value] - Returns [1-1] if [value] is not found. - The optional [startIndex] parameter allows you to specify at which character to start searching. - The position returned is still relative to the beginning of the string. - **/ - function indexOf( str : String, ?startIndex : Int ) : Int; - - /** - Similar to [indexOf] but returns the latest index. - **/ - function lastIndexOf( str : String, ?startIndex : Int ) : Int; - - /** - Split the string using the specified delimiter. - **/ - function split( delimiter : String ) : Array; - - /** - Returns a part of the String, taking [len] characters starting from [pos]. - If [len] is not specified, it takes all the remaining characters. - **/ - function substr( pos : Int, ?len : Int ) : String; - - /** - Returns the String itself. - **/ - function toString() : String; - - static function fromCharCode( code : Int ) : String; - -} diff --git a/haxe/std/StringBuf.hx b/haxe/std/StringBuf.hx deleted file mode 100644 index 05bb59b1628f19f110d4b05d38e3b8320e9d04cc..0000000000000000000000000000000000000000 --- a/haxe/std/StringBuf.hx +++ /dev/null @@ -1,102 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - A String buffer is an efficient way to build a big string by - appending small elements together. -**/ -class StringBuf { - - /** - Creates a new string buffer. - **/ - public function new() { - #if (js || cpp) - b = new Array(); - #else - b = ""; - #end - } - - /** - Adds the representation of any value to the string buffer. - **/ - public inline function add( ?x : Dynamic ) { - #if (js || cpp) - b[b.length] = x; - #else - b += x; - #end - } - - /** - Adds a part of a string to the string buffer. - **/ - public inline function addSub( s : String, pos : Int, ?len : Int ) { - #if flash9 - if( len == null ) - b += s.substr(pos); - else - b += s.substr(pos,len); - #elseif (js || cpp) - b[b.length] = s.substr(pos,len); - #else - b += s.substr(pos,len); - #end - } - - /** - Adds a character to the string buffer. - **/ - public inline function addChar( c : Int ) untyped { - #if (js || cpp) - b[b.length] = String.fromCharCode(c); - #elseif (flash && !flash9) - b += String["fromCharCode"](c); - #else - b += String.fromCharCode(c); - #end - } - - /** - Returns the content of the string buffer. - The buffer is not emptied by this operation. - **/ - public inline function toString() : String { - #if (js || cpp) - return b.join(""); - #else - return b; - #end - } - - private var b : - #if (js || cpp) - Array - #else - String - #end; - -} diff --git a/haxe/std/StringTools.hx b/haxe/std/StringTools.hx deleted file mode 100644 index 3bdb59f31702d51bea472200e2328e5f2c40e335..0000000000000000000000000000000000000000 --- a/haxe/std/StringTools.hx +++ /dev/null @@ -1,289 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - - -/** - The StringTools class contains some extra functionalities for [String] - manipulation. It's stored in a different class in order to prevent - the standard [String] of being bloated and thus increasing the size of - each application using it. -**/ -class StringTools { - - /** - Encode an URL by using the standard format. - **/ - public #if php inline #end static function urlEncode( s : String ) : String untyped { - #if flash9 - return __global__["encodeURIComponent"](s); - #elseif flash - return _global["escape"](s); - #elseif neko - return new String(_urlEncode(s.__s)); - #elseif js - return encodeURIComponent(s); - #elseif php - return __call__("rawurlencode", s); - #elseif cpp - return s.__URLEncode(); - #else - return null; - #end - } - - /** - Decode an URL using the standard format. - **/ - public #if php inline #end static function urlDecode( s : String ) : String untyped { - #if flash9 - return __global__["decodeURIComponent"](s.split("+").join(" ")); - #elseif flash - return _global["unescape"](s); - #elseif neko - return new String(_urlDecode(s.__s)); - #elseif js - return decodeURIComponent(s.split("+").join(" ")); - #elseif php - return __call__("urldecode", s); - #elseif cpp - return s.__URLDecode(); - #else - return null; - #end - } - - /** - Escape HTML special characters of the string. - **/ - public static function htmlEscape( s : String ) : String { - return s.split("&").join("&").split("<").join("<").split(">").join(">"); - } - - /** - Unescape HTML special characters of the string. - **/ - public #if php inline #end static function htmlUnescape( s : String ) : String { - #if php - return untyped __call__("htmlspecialchars_decode", s); - #else - return s.split(">").join(">").split("<").join("<").split("&").join("&"); - #end - } - - /** - Tells if the string [s] starts with the string [start]. - **/ - public static function startsWith( s : String, start : String ) { - return( s.length >= start.length && s.substr(0,start.length) == start ); - } - - /** - Tells if the string [s] ends with the string [end]. - **/ - public static function endsWith( s : String, end : String ) { - var elen = end.length; - var slen = s.length; - return( slen >= elen && s.substr(slen-elen,elen) == end ); - } - - /** - Tells if the character in the string [s] at position [pos] is a space. - **/ - public static function isSpace( s : String, pos : Int ) : Bool { - var c = s.charCodeAt( pos ); - return (c >= 9 && c <= 13) || c == 32; - } - - /** - Removes spaces at the left of the String [s]. - **/ - public #if php inline #end static function ltrim( s : String ) : String { - #if php - return untyped __call__("ltrim", s); - #else - var l = s.length; - var r = 0; - while( r < l && isSpace(s,r) ){ - r++; - } - if( r > 0 ) - return s.substr(r, l-r); - else - return s; - #end - } - - /** - Removes spaces at the right of the String [s]. - **/ - public #if php inline #end static function rtrim( s : String ) : String { - #if php - return untyped __call__("rtrim", s); - #else - var l = s.length; - var r = 0; - while( r < l && isSpace(s,l-r-1) ){ - r++; - } - if( r > 0 ){ - return s.substr(0, l-r); - }else{ - return s; - } - #end - } - - /** - Removes spaces at the beginning and the end of the String [s]. - **/ - public #if php inline #end static function trim( s : String ) : String { - #if php - return untyped __call__("trim", s); - #else - return ltrim(rtrim(s)); - #end - } - - /** - Pad the string [s] by appending [c] at its right until it reach [l] characters. - **/ - public #if php inline #end static function rpad( s : String, c : String, l : Int ) : String { - #if php - return untyped __call__("str_pad", s, l, c, __php__("STR_PAD_RIGHT")); - #else - var sl = s.length; - var cl = c.length; - while( sl < l ){ - if( l - sl < cl ){ - s += c.substr(0,l-sl); - sl = l; - }else{ - s += c; - sl += cl; - } - } - return s; - #end - } - - /** - Pad the string [s] by appending [c] at its left until it reach [l] characters. - **/ - public #if php inline #end static function lpad( s : String, c : String, l : Int ) : String { - #if php - return untyped __call__("str_pad", s, l, c, __php__("STR_PAD_LEFT")); - #else - var ns = ""; - var sl = s.length; - if( sl >= l ) return s; - - var cl = c.length; - while( sl < l ){ - if( l - sl < cl ){ - ns += c.substr(0,l-sl); - sl = l; - }else{ - ns += c; - sl += cl; - } - } - return ns+s; - #end - } - - /** - Replace all occurences of the string [sub] in the string [s] by the string [by]. - **/ - public #if php inline #end static function replace( s : String, sub : String, by : String ) : String { - #if php - return untyped __call__("str_replace", sub, by, s); - #else - return s.split(sub).join(by); - #end - } - - /** - Encode a number into a hexadecimal representation, with an optional number of zeros for left padding. - **/ - public static function hex( n : Int, ?digits : Int ) { - #if flash9 - var n : UInt = n; - var s : String = untyped n.toString(16); - s = s.toUpperCase(); - #else - var s = ""; - var hexChars = "0123456789ABCDEF"; - do { - s = hexChars.charAt(n&15) + s; - n >>>= 4; - } while( n > 0 ); - #end - if( digits != null ) - while( s.length < digits ) - s = "0"+s; - return s; - } - - /** - Provides a fast native string charCodeAt access. Since the EOF value might vary depending on the platforms, always test with StringTools.isEOF. - Only guaranteed to work if index in [0,s.length] range. Might not work with strings containing \0 char. - **/ - public static inline function fastCodeAt( s : String, index : Int ) : Int untyped { - #if neko - return untyped __dollar__sget(s.__s, index); - #elseif cpp - return (s == null) ? 0 : s.cca(index); - #elseif flash9 - return s.cca(index); - #elseif flash - return s["cca"](index); - #else - return s.cca(index); - #end - } - - /* - Only to use together with fastCodeAt. - */ - public static inline function isEOF( c : Int ) : Bool { - #if (flash9 || cpp) - return c == 0; - #elseif flash8 - return c <= 0; // fast NaN - #elseif js - return c != c; // fast NaN - #elseif neko - return c == null; - #else - return false; - #end - } - - #if neko - private static var _urlEncode = neko.Lib.load("std","url_encode",1); - private static var _urlDecode = neko.Lib.load("std","url_decode",1); - #end - -} diff --git a/haxe/std/Type.hx b/haxe/std/Type.hx deleted file mode 100644 index ada5aa673f5ea59c943c7c48af53eec998970aba..0000000000000000000000000000000000000000 --- a/haxe/std/Type.hx +++ /dev/null @@ -1,422 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -/** - The diffent possible runtime types of a value. - See [Type] for the haXe Reflection API. -**/ -enum ValueType { - TNull; - TInt; - TFloat; - TBool; - TObject; - TFunction; - TClass( c : Class ); - TEnum( e : Enum ); - TUnknown; -} - -/** - The haXe Reflection API enables you to retreive informations about any value, - Classes and Enums at runtime. -**/ -extern class Type { - - /** - Returns the class of a value or [null] if this value is not a Class instance. - **/ - public static function getClass( o : T ) : Class; - - /** - Returns the enum of a value or [null] if this value is not an Enum instance. - **/ - public static function getEnum( o : Dynamic ) : Enum; - - - /** - Returns the super-class of a class, or null if no super class. - **/ - public static function getSuperClass( c : Class ) : Class; - - - /** - Returns the complete name of a class. - **/ - public static function getClassName( c : Class ) : String; - - /** - Returns the complete name of an enum. - **/ - public static function getEnumName( e : Enum ) : String; - - /** - Evaluates a class from a name. The class must have been compiled - to be accessible. - **/ - public static function resolveClass( name : String ) : Class; - - - /** - Evaluates an enum from a name. The enum must have been compiled - to be accessible. - **/ - public static function resolveEnum( name : String ) : Enum; - - /** - Creates an instance of the given class with the list of constructor arguments. - **/ - public static function createInstance( cl : Class, args : Array ) : T; - /** - Similar to [Reflect.createInstance] excepts that the constructor is not called. - This enables you to create an instance without any side-effect. - **/ - public static function createEmptyInstance( cl : Class ) : T; - - /** - Create an instance of an enum by using a constructor name and parameters. - **/ - public static function createEnum( e : Enum, constr : String, ?params : Array ) : T; - - /** - Create an instance of an enum by using a constructor index and parameters. - **/ - public static function createEnumIndex( e : Enum, index : Int, ?params : Array ) : T; - - /** - Returns the list of instance fields. - **/ - public static function getInstanceFields( c : Class ) : Array; - - /** - Returns the list of a class static fields. - **/ - public static function getClassFields( c : Class ) : Array { - #if flash9 - var a = describe(c,false); - a.remove("__construct__"); - a.remove("prototype"); - return a; - #elseif php - if(untyped c.__qname__ == 'String') return ['fromCharCode']; - if(untyped c.__qname__ == 'Array') return []; - untyped __php__(" - $rfl = $c->__rfl__(); - if($rfl === null) return new _hx_array(array()); - $ms = $rfl->getMethods(); - $r = array(); - while(list(, $m) = each($ms)) - if($m->isStatic()) $r[] = $m->getName(); - $ps = $rfl->getProperties(); - while(list(, $p) = each($ps)) - if($p->isStatic()) $r[] = $p->getName(); - "); - return untyped __php__("new _hx_array(array_unique($r))"); - #elseif cpp - return untyped c.GetClassFields(); - #else - var a = Reflect.fields(c); - a.remove(__unprotect__("__name__")); - a.remove(__unprotect__("__interfaces__")); - a.remove(__unprotect__("__super__")); - #if js - a.remove("prototype"); - #end - #if neko - a.remove("__string"); - a.remove("__construct__"); - a.remove("prototype"); - a.remove("new"); - #end - return a; - #end - } - - /** - Returns all the available constructor names for an enum. - **/ - public static function getEnumConstructs( e : Enum ) : Array untyped { - #if php - if (__php__("$e->__tname__ == 'Bool'")) return ['true', 'false']; - if (__php__("$e->__tname__ == 'Void'")) return []; - return __call__("new _hx_array", e.__constructors); - #elseif cpp - return untyped e.GetClassFields(); - #else - return untyped e.__constructs__; - #end - } - - /** - Returns the runtime type of a value. - **/ - public static function typeof( v : Dynamic ) : ValueType untyped { - #if neko - return switch( __dollar__typeof(v) ) { - case __dollar__tnull: TNull; - case __dollar__tint: TInt; - case __dollar__tfloat: TFloat; - case __dollar__tbool: TBool; - case __dollar__tfunction: TFunction; - case __dollar__tobject: - var c = v.__class__; - if( c != null ) - TClass(c); - else { - var e = v.__enum__; - if( e != null ) - TEnum(e); - else - TObject; - } - default: TUnknown; - } - #elseif flash9 - var cname = __global__["flash.utils.getQualifiedClassName"](v); - switch(cname) { - case "null": return TNull; - case "void": return TNull; // undefined - case "int": return TInt; - case "Number": - // integers >28 bits are stored as Numbers in avm2 - if( (v < -0x10000000 || v >= 0x10000000) && Std.int(v) == v ) - return TInt; - return TFloat; - case "Boolean": return TBool; - case "Object": return TObject; - case "Function": return TFunction; - default: - var c : Dynamic = null; - try { - c = __global__["flash.utils.getDefinitionByName"](cname); - if( v.hasOwnProperty("prototype") ) - return TObject; - if( c.__isenum ) - return TEnum(c); - return TClass(c); - } catch( e : Dynamic ) { - if( cname == "builtin.as$0::MethodClosure" || cname.indexOf("-") != -1 ) - return TFunction; - return if( c == null ) TFunction else TClass(c); - } - } - return null; - #elseif (flash || js) - switch( #if flash __typeof__ #else __js__("typeof") #end(v) ) { - #if flash - case "null": return TNull; - #end - case "boolean": return TBool; - case "string": return TClass(String); - case "number": - // this should handle all cases : NaN, +/-Inf and Floats outside range - if( Math.ceil(v) == v%2147483648.0 ) - return TInt; - return TFloat; - case "object": - #if js - if( v == null ) - return TNull; - #end - var e = v.__enum__; - if( e != null ) - return TEnum(e); - var c = v.__class__; - if( c != null ) - return TClass(c); - return TObject; - case "function": - if( v.__name__ != null ) - return TObject; - return TFunction; - case "undefined": - return TNull; - default: - return TUnknown; - } - #elseif php - if(v == null) return TNull; - if(__call__("is_array", v)) { - if(__call__("is_callable", v)) return TFunction; - return TClass(Array); - } - if(__call__("is_string", v)) { - if(__call__("_hx_is_lambda", v)) return TFunction; - return TClass(String); - } - if(__call__("is_bool", v)) return TBool; - if(__call__("is_int", v)) return TInt; - if(__call__("is_float", v)) return TFloat; - if(__php__("$v instanceof _hx_anonymous")) return TObject; - if(__php__("$v instanceof _hx_enum")) return TObject; - if(__php__("$v instanceof _hx_class")) return TObject; - - var c = __php__("_hx_ttype(get_class($v))"); - - if(__php__("$c instanceof _hx_enum")) return TEnum(cast c); - if(__php__("$c instanceof _hx_class")) return TClass(cast c); - return TUnknown; - #elseif cpp - if (v==null) return TNull; - var t:Int = untyped v.__GetType(); - switch(t) - { - case untyped __global__.vtBool : return TBool; - case untyped __global__.vtInt : return TInt; - case untyped __global__.vtFloat : return TFloat; - case untyped __global__.vtFunction : return TFunction; - case untyped __global__.vtObject : return TObject; - case untyped __global__.vtEnum : return TEnum(v.__GetClass()); - default: - return untyped TClass(v.__GetClass()); - } - #else - return TUnknown; - #end - } - - /** - Recursively compare two enums constructors and parameters. - **/ - public static function enumEq( a : T, b : T ) : Bool untyped { - if( a == b ) - return true; - #if neko - try { - if( a.__enum__ == null || a.index != b.index ) - return false; - } catch( e : Dynamic ) { - return false; - } - for( i in 0...__dollar__asize(a.args) ) - if( !enumEq(a.args[i],b.args[i]) ) - return false; - #elseif flash9 - try { - if( a.index != b.index ) - return false; - var ap : Array = a.params; - var bp : Array = b.params; - for( i in 0...ap.length ) - if( !enumEq(ap[i],bp[i]) ) - return false; - } catch( e : Dynamic ) { - return false; - } - #elseif php - try { - if( a.index != b.index ) - return false; - for( i in 0...__call__("count", a.params)) - if(getEnum(untyped __php__("$a->params[$i]")) != null) { - if(!untyped enumEq(__php__("$a->params[$i]"),__php__("$b->params[$i]"))) - return false; - } else { - if(!untyped __call__("_hx_equal", __php__("$a->params[$i]"),__php__("$b->params[$i]"))) - return false; - } - } catch( e : Dynamic ) { - return false; - } - #elseif cpp - return a==b; - #elseif flash - // no try-catch since no exception possible - if( a[0] != b[0] ) - return false; - for( i in 2...a.length ) - if( !enumEq(a[i],b[i]) ) - return false; - var e = a.__enum__; - if( e != b.__enum__ || e == null ) - return false; - #else - try { - if( a[0] != b[0] ) - return false; - for( i in 2...a.length ) - if( !enumEq(a[i],b[i]) ) - return false; - var e = a.__enum__; - if( e != b.__enum__ || e == null ) - return false; - } catch( e : Dynamic ) { - return false; - } - #end - return true; - } - - /** - Returns the constructor of an enum - **/ - public static function enumConstructor( e : Dynamic ) : String { - #if neko - return new String(e.tag); - #elseif (flash9 || php) - return e.tag; - #elseif cpp - return e.__Tag(); - #else - return e[0]; - #end - } - - /** - Returns the parameters of an enum - **/ - public static function enumParameters( e : Dynamic ) : Array { - #if neko - return if( e.args == null ) [] else untyped Array.new1(e.args,__dollar__asize(e.args)); - #elseif flash9 - return if( e.params == null ) [] else e.params; - #elseif cpp - var result : Array = untyped e.__EnumParams(); - return result==null ? [] : result; - #elseif php - if(e.params == null) - return []; - else - return untyped __php__("new _hx_array($e->params)"); - #else - return e.slice(2); - #end - } - - /** - Returns the index of the constructor of an enum - **/ - public inline static function enumIndex( e : Dynamic ) : Int { - #if (neko || flash9 || php) - return e.index; - #elseif cpp - return e.__Index(); - #else - return e[1]; - #end - } - -} - diff --git a/haxe/std/cpp/CppInt32__.hx b/haxe/std/cpp/CppInt32__.hx deleted file mode 100644 index d15792475e48b03e4be029ea773208c60a69b151..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/CppInt32__.hx +++ /dev/null @@ -1,48 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp; - -typedef Int32 = CppInt32__; - -extern class CppInt32__ { - public static function make( a : Int, b : Int ) : Int32; - public static function ofInt( x : Int ) : Int32; - public static function toInt( x : Int32 ) : Int; - public static function add( a : Int32, b : Int32 ) : Int32; - public static function sub( a : Int32, b : Int32 ) : Int32; - public static function mul( a : Int32, b : Int32 ) : Int32; - public static function div( a : Int32, b : Int32 ) : Int32; - public static function mod( a : Int32, b : Int32 ) : Int32; - public static function shl( a : Int32, b : Int ) : Int32; - public static function shr( a : Int32, b : Int ) : Int32; - public static function ushr( a : Int32, b : Int ) : Int32; - public static function and( a : Int32, b : Int32 ) : Int32; - public static function or( a : Int32, b : Int32 ) : Int32; - public static function xor( a : Int32, b : Int32 ) : Int32; - public static function neg( a : Int32 ) : Int32; - public static function complement( a : Int32 ) : Int32; - public static function compare( a : Int32, b : Int32 ) : Int; -} - diff --git a/haxe/std/cpp/FastIterator.hx b/haxe/std/cpp/FastIterator.hx deleted file mode 100644 index 45997ba35bab057c29db7a41092ca15bf1ad281f..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/FastIterator.hx +++ /dev/null @@ -1,8 +0,0 @@ -package cpp; - -extern class FastIterator implements haxe.rtti.Generic -{ - public function hasNext():Bool; - public function next():T; -} - diff --git a/haxe/std/cpp/FileSystem.hx b/haxe/std/cpp/FileSystem.hx deleted file mode 100644 index 65a9d3a93066a4c15cb41e0f740242ad372f752a..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/FileSystem.hx +++ /dev/null @@ -1,114 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp; - -typedef FileStat = { - var gid : Int; - var uid : Int; - var atime : Date; - var mtime : Date; - var ctime : Date; - var dev : Int; - var ino : Int; - var nlink : Int; - var rdev : Int; - var size : Int; - var mode : Int; -} - -enum FileKind { - kdir; - kfile; - kother( k : String ); -} - -class FileSystem { - - public static function exists( path : String ) : Bool { - return sys_exists(path); - } - - public static function rename( path : String, newpath : String ) { - if (sys_rename(path,newpath)==null) - throw "Could not rename:" + path + " to " + newpath; - } - - public static function stat( path : String ) : FileStat { - var s : FileStat = sys_stat(path); - if (s==null) - return { gid:0, uid:0, atime:Date.fromTime(0), mtime:Date.fromTime(0), ctime:Date.fromTime(0), dev:0, ino:0, nlink:0, rdev:0, size:0, mode:0 }; - s.atime = Date.fromTime(1000.0*(untyped s.atime)); - s.mtime = Date.fromTime(1000.0*(untyped s.mtime)); - s.ctime = Date.fromTime(1000.0*(untyped s.ctime)); - return s; - } - - public static function fullPath( relpath : String ) : String { - return new String(file_full_path(relpath)); - } - - public static function kind( path : String ) : FileKind { - var k:String = sys_file_type(path); - return switch(k) { - case "file": kfile; - case "dir": kdir; - default: kother(k); - } - } - - public static function isDirectory( path : String ) : Bool { - return kind(path) == kdir; - } - - public static function createDirectory( path : String ) { - if (sys_create_dir( path, 493 )==null) - throw "Could not create directory:" + path; - } - - public static function deleteFile( path : String ) { - if (file_delete(path)==null) - throw "Could not delete file:" + path; - } - - public static function deleteDirectory( path : String ) { - if (sys_remove_dir(path)==null) - throw "Could not delete directory:" + path; - } - - public static function readDirectory( path : String ) : Array { - return sys_read_dir(path); - } - - private static var sys_exists = Lib.load("std","sys_exists",1); - private static var file_delete = Lib.load("std","file_delete",1); - private static var sys_rename = Lib.load("std","sys_rename",2); - private static var sys_stat = Lib.load("std","sys_stat",1); - private static var sys_file_type = Lib.load("std","sys_file_type",1); - private static var sys_create_dir = Lib.load("std","sys_create_dir",2); - private static var sys_remove_dir = Lib.load("std","sys_remove_dir",1); - private static var sys_read_dir = Lib.load("std","sys_read_dir",1); - private static var file_full_path = Lib.load("std","file_full_path",1); - -} diff --git a/haxe/std/cpp/Random.hx b/haxe/std/cpp/Random.hx deleted file mode 100644 index 8595b6eb5472736ce4cdddf0b33021c286290c44..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/Random.hx +++ /dev/null @@ -1,52 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp; - -class Random { - - var r : Dynamic; - - public function new() { - r = random_new(); - } - - public function setSeed( s : Int ) { - random_set_seed(r,s); - } - - public function int( max : Int ) : Int { - return random_int(r,max); - } - - public function float() : Float { - return random_float(r); - } - - static var random_new = Lib.load("std","random_new",0); - static var random_set_seed = Lib.load("std","random_set_seed",2); - static var random_int = Lib.load("std","random_int",2); - static var random_float = Lib.load("std","random_float",1); - -} diff --git a/haxe/std/cpp/Sys.hx b/haxe/std/cpp/Sys.hx deleted file mode 100644 index 5dc248143ed42d286f5970c5dd33818221190d9f..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/Sys.hx +++ /dev/null @@ -1,105 +0,0 @@ -package cpp; - -class Sys { - - public static function args() : Array untyped { - return __global__.__get_args(); - } - - public static function getEnv( s : String ):String { - var v = get_env(s); - if( v == null ) - return null; - return v; - } - - public static function putEnv( s : String, v : String ) { - put_env(s,v); - } - - public static function sleep( seconds : Float ) { - _sleep(seconds); - } - - public static function setTimeLocale( loc : String ) : Bool { - return set_time_locale(loc); - } - - public static function getCwd() : String { - return new String(get_cwd()); - } - - public static function setCwd( s : String ) { - set_cwd(s); - } - - public static function systemName() : String { - return sys_string(); - } - - public static function escapeArgument( arg : String ) : String { - var ok = true; - for( i in 0...arg.length ) - switch( arg.charCodeAt(i) ) { - case 32, 34: // [space] " - ok = false; - case 0, 13, 10: // [eof] [cr] [lf] - arg = arg.substr(0,i); - } - if( ok ) - return arg; - return '"'+arg.split('"').join('\\"')+'"'; - } - - public static function command( cmd : String, ?args : Array ) : Int { - if( args != null ) { - cmd = escapeArgument(cmd); - for( a in args ) - cmd += " "+escapeArgument(a); - } - return sys_command(cmd); - } - - public static function exit( code : Int ) { - sys_exit(code); - } - - public static function time() : Float { - return sys_time(); - } - - public static function cpuTime() : Float { - return sys_cpu_time(); - } - - public static function executablePath() : String { - return new String(sys_exe_path()); - } - - public static function environment() : Hash { - var vars:Array = sys_env(); - var result = new Hash(); - var i = 0; - while(i { - private var __Internal : Dynamic; - - public function new() : Void { - __Internal = {}; - } - - public function set( key : String, value : T ) : Void { - untyped __Internal.__SetField(key,value); - } - - public function get( key : String ) : Null { - return untyped __Internal.__Field(key); - } - - public function exists( key : String ) : Bool { - return untyped __Internal.__HasField(key); - } - - public function remove( key : String ) : Bool { - return untyped __global__.__hxcpp_anon_remove(__Internal,key); - } - - /** - Returns an iterator of all keys in the hashtable. - **/ - public function keys() : Iterator { - var a:Array = []; - untyped __Internal.__GetFields(a); - return a.iterator(); - } - - /** - Returns an iterator of all values in the hashtable. - **/ - public function iterator() : Iterator { - var a:Array = []; - untyped __Internal.__GetFields(a); - var it = a.iterator(); - return untyped { - hasNext : function() { return it.hasNext(); }, - next : function() { return untyped __Internal.__Field(it.next()); } - }; - } - - /** - Returns an displayable representation of the hashtable content. - **/ - - public function toString() : String { - var s = new StringBuf(); - s.add("{"); - var it = keys(); - for( i in it ) { - s.add(i); - s.add(" => "); - s.add(Std.string(get(i))); - if( it.hasNext() ) - s.add(", "); - } - s.add("}"); - return s.toString(); - } -} diff --git a/haxe/std/cpp/_std/IntHash.hx b/haxe/std/cpp/_std/IntHash.hx deleted file mode 100644 index ac2e71dd5cdb9dcd5984840ebd84f289521a1dd2..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/_std/IntHash.hx +++ /dev/null @@ -1,75 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class IntHash { - - private var h : Dynamic; - - public function new() : Void { - h = untyped __global__.__int_hash_create(); - } - - public function set( key : Int, value : T ) : Void { - untyped __global__.__int_hash_set(h,key,value); - } - - public function get( key : Int ) : Null { - return untyped __global__.__int_hash_get(h,key); - } - - public function exists( key : Int ) : Bool { - return untyped __global__.__int_hash_exists(h,key); - } - - public function remove( key : Int ) : Bool { - return untyped __global__.__int_hash_remove(h,key); - } - - public function keys() : Iterator { - var a:Array = untyped __global__.__int_hash_keys(h); - return a.iterator(); - } - - public function iterator() : Iterator { - var a:Array = untyped __global__.__int_hash_values(h); - return a.iterator(); - } - - public function toString() : String { - var s = new StringBuf(); - s.add("{"); - var it = keys(); - for( i in it ) { - s.add(i); - s.add(" => "); - s.add(Std.string(get(i))); - if( it.hasNext() ) - s.add(", "); - } - s.add("}"); - return s.toString(); - } - -} diff --git a/haxe/std/cpp/_std/Std.hx b/haxe/std/cpp/_std/Std.hx deleted file mode 100644 index 1e6708e1ded1d5770085d08807b297a9cf3a6631..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/_std/Std.hx +++ /dev/null @@ -1,51 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Std { - public static function is( v : Dynamic, t : Dynamic ) : Bool { - return untyped __global__.__instanceof(v,t); - } - - public static function string( s : Dynamic ) : String { - return untyped s==null ? "null" : s.toString(); - } - - public static function int( x : Float ) : Int { - return untyped __global__.__int__(x); - } - - public static function parseInt( x : String ) : Null { - return untyped __global__.__hxcpp_parse_int(x); - } - - public static function parseFloat( x : String ) : Float { - return untyped __global__.__hxcpp_parse_float(x); - } - - public static function random( x : Int ) : Int { - return untyped __global__.rand() % x; - } - -} diff --git a/haxe/std/cpp/io/File.hx b/haxe/std/cpp/io/File.hx deleted file mode 100644 index 1abe9f507732980424a48e624ce1bc45447c7bbf..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/io/File.hx +++ /dev/null @@ -1,95 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.io; - -typedef FileHandle = Dynamic; - -enum FileSeek { - SeekBegin; - SeekCur; - SeekEnd; -} - -/** - API for reading and writing to files. -**/ -class File { - - public static function getContent( path : String ) { - var b = getBytes(path); - return b.toString(); - } - - public static function getBytes( path : String ) : haxe.io.Bytes { - var data:haxe.io.BytesData = file_contents(path); - return haxe.io.Bytes.ofData(data); - } - - public static function read( path : String, binary : Bool ) { - return new FileInput(file_open(path,(if( binary ) "rb" else "r"))); - } - - public static function write( path : String, binary : Bool ) { - return new FileOutput(file_open(path,(if( binary ) "wb" else "w"))); - } - - public static function append( path : String, binary : Bool ) { - return new FileOutput(file_open(path,(if( binary ) "ab" else "a"))); - } - - public static function copy( src : String, dst : String ) { - var s = read(src,true); - var d = write(dst,true); - d.writeInput(s); - s.close(); - d.close(); - } - - public static function stdin() { - return new FileInput(file_stdin()); - } - - public static function stdout() { - return new FileOutput(file_stdout()); - } - - public static function stderr() { - return new FileOutput(file_stderr()); - } - - public static function getChar( echo : Bool ) : Int { - return getch(echo); - } - - private static var file_stdin = cpp.Lib.load("std","file_stdin",0); - private static var file_stdout = cpp.Lib.load("std","file_stdout",0); - private static var file_stderr = cpp.Lib.load("std","file_stderr",0); - - private static var file_contents = cpp.Lib.load("std","file_contents",1); - private static var file_open = cpp.Lib.load("std","file_open",2); - - private static var getch = cpp.Lib.load("std","sys_getch",1); - -} diff --git a/haxe/std/cpp/io/FileInput.hx b/haxe/std/cpp/io/FileInput.hx deleted file mode 100644 index b3215bc4c3c507f843dff143a8577ab6accc3cee..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/io/FileInput.hx +++ /dev/null @@ -1,88 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.io; -import cpp.io.File; - -/** - Use [cpp.io.File.read] to create a [FileInput] -**/ -class FileInput extends haxe.io.Input { - - private var __f : FileHandle; - - public function new(f) { - __f = f; - } - - public override function readByte() : Int { - return try { - file_read_char(__f); - } catch( e : Dynamic ) { - if( untyped e.__IsArray() ) - throw new haxe.io.Eof(); - else - throw haxe.io.Error.Custom(e); - } - } - - public override function readBytes( s : haxe.io.Bytes, p : Int, l : Int ) : Int { - return try { - file_read(__f,s.getData(),p,l); - } catch( e : Dynamic ) { - if( untyped e.__IsArray() ) - throw new haxe.io.Eof(); - else - throw haxe.io.Error.Custom(e); - } - } - - public override function close() { - super.close(); - file_close(__f); - } - - public function seek( p : Int, pos : FileSeek ) { - file_seek(__f,p,switch( pos ) { case SeekBegin: 0; case SeekCur: 1; case SeekEnd: 2; }); - } - - public function tell() : Int { - return file_tell(__f); - } - - - public function eof() : Bool { - return file_eof(__f); - } - - private static var file_eof = cpp.Lib.load("std","file_eof",1); - - private static var file_read = cpp.Lib.load("std","file_read",4); - private static var file_read_char = cpp.Lib.load("std","file_read_char",1); - - private static var file_close = cpp.Lib.load("std","file_close",1); - private static var file_seek = cpp.Lib.load("std","file_seek",3); - private static var file_tell = cpp.Lib.load("std","file_tell",1); - -} diff --git a/haxe/std/cpp/io/FileOutput.hx b/haxe/std/cpp/io/FileOutput.hx deleted file mode 100644 index 0638ad164bcb7d9a9e44d38b5fb713d98d0595e1..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/io/FileOutput.hx +++ /dev/null @@ -1,72 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.io; -import cpp.io.File; - -/** - Use [cpp.io.File.write] to create a [FileOutput] -**/ -class FileOutput extends haxe.io.Output { - - private var __f : FileHandle; - - public function new(f) { - __f = f; - } - - public override function writeByte( c : Int ) { - try file_write_char(__f,c) catch( e : Dynamic ) throw haxe.io.Error.Custom(e); - } - - public override function writeBytes( s : haxe.io.Bytes, p : Int, l : Int ) : Int { - return try file_write(__f,s.getData(),p,l) catch( e : Dynamic ) throw haxe.io.Error.Custom(e); - } - - public override function flush() { - file_flush(__f); - } - - public override function close() { - super.close(); - file_close(__f); - } - - public function seek( p : Int, pos : FileSeek ) { - file_seek(__f,p,switch( pos ) { case SeekBegin: 0; case SeekCur: 1; case SeekEnd: 2; }); - } - - public function tell() : Int { - return file_tell(__f); - } - - private static var file_close = cpp.Lib.load("std","file_close",1); - private static var file_seek = cpp.Lib.load("std","file_seek",3); - private static var file_tell = cpp.Lib.load("std","file_tell",1); - - private static var file_flush = cpp.Lib.load("std","file_flush",1); - private static var file_write = cpp.Lib.load("std","file_write",4); - private static var file_write_char = cpp.Lib.load("std","file_write_char",2); - -} diff --git a/haxe/std/cpp/io/Path.hx b/haxe/std/cpp/io/Path.hx deleted file mode 100644 index f9c6e3f4f3e0050e8466f376ba1a575870cd18fc..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/io/Path.hx +++ /dev/null @@ -1,92 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.io; - -class Path { - - public var ext : String; - public var dir : String; - public var file : String; - public var backslash : Bool; - - public function new( path : String ) { - var c1 = path.lastIndexOf("/"); - var c2 = path.lastIndexOf("\\"); - if( c1 < c2 ) { - dir = path.substr(0,c2); - path = path.substr(c2+1); - backslash = true; - } else if( c2 < c1 ) { - dir = path.substr(0,c1); - path = path.substr(c1+1); - } else - dir = null; - var cp = path.lastIndexOf("."); - if( cp != -1 ) { - ext = path.substr(cp+1); - file = path.substr(0,cp); - } else { - ext = null; - file = path; - } - } - - public function toString() { - return (if( dir == null ) "" else dir + if( backslash ) "\\" else "/") + file + (if( ext == null ) "" else "." + ext); - } - - public static function withoutExtension( path : String ) { - var s = new Path(path); - s.ext = null; - return s.toString(); - } - - public static function withoutDirectory( path ) { - var s = new Path(path); - s.dir = null; - return s.toString(); - } - - public static function directory( path ) { - var s = new Path(path); - if( s.dir == null ) - return ""; - return s.dir; - } - - public static function extension( path ) { - var s = new Path(path); - if( s.ext == null ) - return ""; - return s.ext; - } - - public static function withExtension( path, ext ) { - var s = new Path(path); - s.ext = ext; - return s.toString(); - } - -} diff --git a/haxe/std/cpp/net/Host.hx b/haxe/std/cpp/net/Host.hx deleted file mode 100644 index bf60d4ce27dfc650d6b2c35b0f4682177c8a26c7..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/net/Host.hx +++ /dev/null @@ -1,58 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - * - */ -package cpp.net; - - -class Host { - - public var ip(default,null) : haxe.Int32; - - public function new( name : String ) { - ip = host_resolve(name); - } - - public function toString() : String { - return new String(host_to_string(ip)); - } - - public function reverse() { - return new String(host_reverse(ip)); - } - - public static function localhost() : String { - return new String(host_local()); - } - - static function __init__() { - cpp.Lib.load("std","socket_init",0)(); - } - - private static var host_resolve = cpp.Lib.load("std","host_resolve",1); - private static var host_reverse = cpp.Lib.load("std","host_reverse",1); - private static var host_to_string = cpp.Lib.load("std","host_to_string",1); - private static var host_local = cpp.Lib.load("std","host_local",0); - -} diff --git a/haxe/std/cpp/net/Socket.hx b/haxe/std/cpp/net/Socket.hx deleted file mode 100644 index 1b548584af4005880240b5fa64f96fb1a3128c14..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/net/Socket.hx +++ /dev/null @@ -1,148 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - * - * Contributor: Lee McColl Sylvester - */ -package cpp.net; - -typedef SocketHandle = Dynamic; - -class Socket { - - private var __s : SocketHandle; - public var input(default,null) : SocketInput; - public var output(default,null) : SocketOutput; - public var custom : Dynamic; - - public function new( ?s ) { - __s = if( s == null ) socket_new(false) else s; - input = new SocketInput(__s); - output = new SocketOutput(__s); - } - - public function close() : Void { - socket_close(__s); - untyped { - input.__s = null; - output.__s = null; - } - input.close(); - output.close(); - } - - public function read() : String { - var bytes:haxe.io.BytesData = socket_read(__s); - if (bytes==null) return ""; - return bytes.toString(); - } - - public function write( content : String ) { - socket_write(__s, haxe.io.Bytes.ofString(content).getData() ); - } - - public function connect(host : Host, port : Int) { - try { - socket_connect(__s, host.ip, port); - } catch( s : String ) { - if( s == "std@socket_connect" ) - throw "Failed to connect on "+(try host.reverse() catch( e : Dynamic ) host.toString())+":"+port; - else - cpp.Lib.rethrow(s); - } - } - - public function listen(connections : Int) { - socket_listen(__s, connections); - } - - public function shutdown( read : Bool, write : Bool ){ - socket_shutdown(__s,read,write); - } - - public function bind(host : Host, port : Int) { - socket_bind(__s, host.ip, port); - } - - public function accept() : Socket { - return new Socket(socket_accept(__s)); - } - - public function peer() : { host : Host, port : Int } { - var a : Dynamic = socket_peer(__s); - var h = new Host("127.0.0.1"); - untyped h.ip = a[0]; - return { host : h, port : a[1] }; - } - - public function host() : { host : Host, port : Int } { - var a : Dynamic = socket_host(__s); - var h = new Host("127.0.0.1"); - untyped h.ip = a[0]; - return { host : h, port : a[1] }; - } - - public function setTimeout( timeout : Float ) { - socket_set_timeout(__s, timeout); - } - - public function waitForRead() { - select([this],null,null,null); - } - - public function setBlocking( b : Bool ) { - socket_set_blocking(__s,b); - } - - public static function newUdpSocket() { - return new Socket(socket_new(true)); - } - - // STATICS - public static function select(read : Array, write : Array, others : Array, timeout : Null) : {read: Array,write: Array,others: Array} { - var neko_array = socket_select(read,write,others, timeout); - if (neko_array==null) - throw "Select error"; - return { - read: neko_array[0], - write: neko_array[1], - others: neko_array[2] - }; - } - - private static var socket_new = cpp.Lib.load("std","socket_new",1); - private static var socket_close = cpp.Lib.load("std","socket_close",1); - private static var socket_write = cpp.Lib.load("std","socket_write",2); - private static var socket_read = cpp.Lib.load("std","socket_read",1); - private static var socket_connect = cpp.Lib.load("std","socket_connect",3); - private static var socket_listen = cpp.Lib.load("std","socket_listen",2); - private static var socket_select = cpp.Lib.load("std","socket_select",4); - private static var socket_bind = cpp.Lib.load("std","socket_bind",3); - private static var socket_accept = cpp.Lib.load("std","socket_accept",1); - private static var socket_peer = cpp.Lib.load("std","socket_peer",1); - private static var socket_host = cpp.Lib.load("std","socket_host",1); - private static var socket_set_timeout = cpp.Lib.load("std","socket_set_timeout",2); - private static var socket_shutdown = cpp.Lib.load("std","socket_shutdown",3); - private static var socket_set_blocking = cpp.Lib.load("std","socket_set_blocking",2); - -} diff --git a/haxe/std/cpp/net/SocketInput.hx b/haxe/std/cpp/net/SocketInput.hx deleted file mode 100644 index 64c084e83db4ad112d8437ef9af4e60e06d5fc1d..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/net/SocketInput.hx +++ /dev/null @@ -1,76 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.net; -import cpp.net.Socket; -import haxe.io.Error; - -class SocketInput extends haxe.io.Input { - - var __s : SocketHandle; - - public function new(s) { - __s = s; - } - - public override function readByte() { - return try { - socket_recv_char(__s); - } catch( e : Dynamic ) { - if( e == "Blocking" ) - throw Blocked; - else if( __s == null ) - throw Custom(e); - else - throw new haxe.io.Eof(); - } - } - - public override function readBytes( buf : haxe.io.Bytes, pos : Int, len : Int ) : Int { - var r; - if (__s==null) - throw "Invalid handle"; - try { - r = socket_recv(__s,buf.getData(),pos,len); - } catch( e : Dynamic ) { - if( e == "Blocking" ) - throw Blocked; - else - throw Custom(e); - } - if( r == 0 ) - throw new haxe.io.Eof(); - return r; - } - - public override function close() { - super.close(); - if( __s != null ) socket_close(__s); - } - - private static var socket_recv = cpp.Lib.load("std","socket_recv",4); - private static var socket_recv_char = cpp.Lib.load("std","socket_recv_char",1); - private static var socket_close = cpp.Lib.load("std","socket_close",1); - -} diff --git a/haxe/std/cpp/net/SocketOutput.hx b/haxe/std/cpp/net/SocketOutput.hx deleted file mode 100644 index 46e3158b60b88ead20584184e440655dd5809b49..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/net/SocketOutput.hx +++ /dev/null @@ -1,70 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.net; -import cpp.net.Socket; -import haxe.io.Error; - -class SocketOutput extends haxe.io.Output { - - var __s : SocketHandle; - - public function new(s) { - __s = s; - } - - public override function writeByte( c : Int ) { - if (__s==null) - throw "Invalid handle"; - try { - socket_send_char(__s, c); - } catch( e : Dynamic ) { - if( e == "Blocking" ) - throw Blocked; - else - throw Custom(e); - } - } - - public override function writeBytes( buf : haxe.io.Bytes, pos : Int, len : Int) : Int { - return try { - socket_send(__s, buf.getData(), pos, len); - } catch( e : Dynamic ) { - if( e == "Blocking" ) - throw Blocked; - else - throw Custom(e); - } - } - - public override function close() { - super.close(); - if( __s != null ) socket_close(__s); - } - - private static var socket_close = cpp.Lib.load("std","socket_close",1); - private static var socket_send_char = cpp.Lib.load("std","socket_send_char",2); - private static var socket_send = cpp.Lib.load("std","socket_send",4); - -} diff --git a/haxe/std/cpp/rtti/FieldIntegerLookup.hx b/haxe/std/cpp/rtti/FieldIntegerLookup.hx deleted file mode 100644 index 98ca06e462f57e4b199756654ee9e47f4b8fe374..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/rtti/FieldIntegerLookup.hx +++ /dev/null @@ -1,8 +0,0 @@ -package cpp.rtti; - -/** - If you implement this interface, then the backend will generate code that - allows fast dynamic access to fields by integer id. This should speed up the CFFI. -**/ -interface FieldIntegerLookup { -} diff --git a/haxe/std/cpp/rtti/FieldNumericIntegerLookup.hx b/haxe/std/cpp/rtti/FieldNumericIntegerLookup.hx deleted file mode 100644 index 2bb9c6a59ee67c28d68707808020b21e8d0854b1..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/rtti/FieldNumericIntegerLookup.hx +++ /dev/null @@ -1,8 +0,0 @@ -package cpp.rtti; - -/** - If you implement this interface, then the backend will generate code that - allows fast numeric access to fields by integer id. This should speed up the CFFI. -**/ -interface FieldNumericIntegerLookup { -} diff --git a/haxe/std/cpp/vm/Deque.hx b/haxe/std/cpp/vm/Deque.hx deleted file mode 100644 index 31f085b905a27333bf2d06d1ac345d78e5c58c3e..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/vm/Deque.hx +++ /dev/null @@ -1,47 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.vm; - -#if HXCPP_MULTI_THREADED - -class Deque { - var q : Dynamic; - public function new() { - q = untyped __global__.__hxcpp_deque_create(); - } - public function add( i : T ) { - untyped __global__.__hxcpp_deque_add(q,i); - } - public function push( i : T ) { - untyped __global__.__hxcpp_deque_push(q,i); - } - public function pop( block : Bool ) : T { - return untyped __global__.__hxcpp_deque_pop(q,block); - } -} - -#else -You_need_to_define_HXCPP_MULTI_THREADED_to_use_the_Deque_class -#end diff --git a/haxe/std/cpp/vm/Gc.hx b/haxe/std/cpp/vm/Gc.hx deleted file mode 100644 index 9d5d4137c1ba6594969fc697f13596fa6711bb24..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/vm/Gc.hx +++ /dev/null @@ -1,20 +0,0 @@ -package cpp.vm; - -class Gc -{ - static public function enable(inEnable:Bool) : Void - { - untyped __global__.__hxcpp_enable(inEnable); - } - - static public function run(major:Bool) : Void - { - untyped __global__.__hxcpp_collect(); - } - - static public function trace(sought:Class,printInstances:Bool=true) : Int - { - return untyped __global__.__hxcpp_gc_trace(sought,printInstances); - } - -} diff --git a/haxe/std/cpp/vm/Lock.hx b/haxe/std/cpp/vm/Lock.hx deleted file mode 100644 index b2c3b78b0bcf29d7181c79718fab2aac87e03ab4..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/vm/Lock.hx +++ /dev/null @@ -1,44 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.vm; - -#if HXCPP_MULTI_THREADED - -class Lock { - var l : Dynamic; - public function new() { - l = untyped __global__.__hxcpp_lock_create(); - } - public function wait( ?timeout : Float = -1) : Bool { - return untyped __global__.__hxcpp_lock_wait(l,timeout); - } - public function release() { - untyped __global__.__hxcpp_lock_release(l); - } -} - -#else -You_need_to_define_HXCPP_MULTI_THREADED_to_use_the_Lock_class -#end diff --git a/haxe/std/cpp/vm/Mutex.hx b/haxe/std/cpp/vm/Mutex.hx deleted file mode 100644 index 905e5fd8072f09a7a746249c6e22a65a8ea625e0..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/vm/Mutex.hx +++ /dev/null @@ -1,48 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.vm; - -#if HXCPP_MULTI_THREADED - -class Mutex { - var m : Dynamic; - - public function new() { - m = untyped __global__.__hxcpp_mutex_create(); - } - public function acquire() { - untyped __global__.__hxcpp_mutex_acquire(m); - } - public function tryAcquire() : Bool { - return untyped __global__.__hxcpp_mutex_try(m); - } - public function release() { - untyped __global__.__hxcpp_mutex_release(m); - } -} - -#else -You_need_to_define_HXCPP_MULTI_THREADED_to_use_the_Mutex_class -#end diff --git a/haxe/std/cpp/vm/Thread.hx b/haxe/std/cpp/vm/Thread.hx deleted file mode 100644 index b97b6e73ece598660ad7e217be45d7bde72f5e53..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/vm/Thread.hx +++ /dev/null @@ -1,76 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.vm; - -typedef ThreadHandle = Dynamic; - -#if HXCPP_MULTI_THREADED -class Thread { - - var handle : ThreadHandle; - - function new(h) { - handle = h; - } - - /** - Send a message to the thread queue. This message can be readed by using [readMessage]. - **/ - public function sendMessage( msg : Dynamic ) { - untyped __global__.__hxcpp_thread_send(handle,msg); - } - - - /** - Returns the current thread. - **/ - public static function current() { - return new Thread(untyped __global__.__hxcpp_thread_current()); - } - - /** - Creates a new thread that will execute the [callb] function, then exit. - **/ - public static function create( callb : Void -> Void ) { - return new Thread(untyped __global__.__hxcpp_thread_create(callb)); - } - - /** - Reads a message from the thread queue. If [block] is true, the function - blocks until a message is available. If [block] is false, the function - returns [null] if no message is available. - **/ - public static function readMessage( block : Bool ) : Dynamic { - return untyped __global__.__hxcpp_thread_read_message(block); - } - - function __compare(t) { - return untyped handle == t.handle; - } - -} -#else -You_need_to_define_HXCPP_MULTI_THREADED_to_use_the_Thread_class -#end diff --git a/haxe/std/cpp/vm/Tls.hx b/haxe/std/cpp/vm/Tls.hx deleted file mode 100644 index ef2fd86d1d0a827208d8e40fa9c7efee743ea165..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/vm/Tls.hx +++ /dev/null @@ -1,52 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.vm; - -#if HXCPP_MULTI_THREADED - -class Tls { - - static var sFreeSlot = 0; - var mTLSID : Int; - public var value(getValue,setValue) : T; - - public function new() { - mTLSID = sFreeSlot++; - } - - function getValue() : T { - return untyped __global__.__hxcpp_tls_get(mTLSID); - } - - function setValue( v : T ) { - untyped __global__.__hxcpp_tls_set(mTLSID,v); - return v; - } - -} - -#else -You_need_to_define_HXCPP_MULTI_THREADED_to_use_the_Tls_class -#end diff --git a/haxe/std/cpp/zip/Compress.hx b/haxe/std/cpp/zip/Compress.hx deleted file mode 100644 index ca9402d2e75437f88259061976541762e2a5297c..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/zip/Compress.hx +++ /dev/null @@ -1,64 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.zip; - -class Compress { - - var s : Dynamic; - - public function new( level : Int ) { - s = _deflate_init(level); - } - - public function execute( src : haxe.io.Bytes, srcPos : Int, dst : haxe.io.Bytes, dstPos : Int ) : { done : Bool, read : Int, write : Int } { - return _deflate_buffer(s,src.getData(),srcPos,dst.getData(),dstPos); - } - - public function setFlushMode( f : Flush ) { - _set_flush_mode(s,Std.string(f)); - } - - public function close() { - _deflate_end(s); - } - - public static function run( s : haxe.io.Bytes, level : Int ) : haxe.io.Bytes { - var c = new Compress(level); - c.setFlushMode(Flush.FINISH); - var out = haxe.io.Bytes.alloc(_deflate_bound(c.s,s.length)); - var r = c.execute(s,0,out,0); - c.close(); - if( !r.done || r.read != s.length ) - throw "Compression failed"; - return out.sub(0,r.write); - } - - static var _deflate_init = cpp.Lib.load("zlib","deflate_init",1); - static var _deflate_bound = cpp.Lib.load("zlib","deflate_bound",2); - static var _deflate_buffer = cpp.Lib.load("zlib","deflate_buffer",5); - static var _deflate_end = cpp.Lib.load("zlib","deflate_end",1); - static var _set_flush_mode = cpp.Lib.load("zlib","set_flush_mode",2); - -} diff --git a/haxe/std/cpp/zip/Flush.hx b/haxe/std/cpp/zip/Flush.hx deleted file mode 100644 index c337aacaf4745229402963cfb9a994ef846faa96..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/zip/Flush.hx +++ /dev/null @@ -1,33 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.zip; - -enum Flush { - NO; - SYNC; - FULL; - FINISH; - BLOCK; -} diff --git a/haxe/std/cpp/zip/Uncompress.hx b/haxe/std/cpp/zip/Uncompress.hx deleted file mode 100644 index 116d9d92accbe7c0316a2b5efee538fd2f8e3fd6..0000000000000000000000000000000000000000 --- a/haxe/std/cpp/zip/Uncompress.hx +++ /dev/null @@ -1,69 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package cpp.zip; - -class Uncompress { - var s : Dynamic; - - public function new( windowBits : Null ) { - s = _inflate_init(windowBits); - } - - public function this_run( src : haxe.io.Bytes, srcPos : Int, dst : haxe.io.Bytes, dstPos : Int ) : { done : Bool, read : Int, write : Int } { - return _inflate_buffer(s,src.getData(),srcPos,dst.getData(),dstPos); - } - - public function setFlushMode( f : Flush ) { - _set_flush_mode(s,untyped f.__Tag()); - } - - public function close() { - _inflate_end(s); - } - - public static function run( src : haxe.io.Bytes, ?bufsize ) : haxe.io.Bytes { - var u = new Uncompress(null); - if( bufsize == null ) bufsize = 1 << 16; // 64K - var tmp = haxe.io.Bytes.alloc(bufsize); - var b = new haxe.io.BytesBuffer(); - var pos = 0; - u.setFlushMode(Flush.SYNC); - while( true ) { - var r = u.this_run(src,pos,tmp,0); - b.addBytes(tmp,0,r.write); - pos += r.read; - if( r.done ) - break; - } - u.close(); - return b.getBytes(); - } - - static var _inflate_init = cpp.Lib.load("zlib","inflate_init",1); - static var _inflate_buffer = cpp.Lib.load("zlib","inflate_buffer",5); - static var _inflate_end = cpp.Lib.load("zlib","inflate_end",1); - static var _set_flush_mode = cpp.Lib.load("zlib","set_flush_mode",2); - -} diff --git a/haxe/std/flash/Lib.hx b/haxe/std/flash/Lib.hx deleted file mode 100644 index 0c8c4799a8b8126987c8aa3c327c04b98dcfa059..0000000000000000000000000000000000000000 --- a/haxe/std/flash/Lib.hx +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package flash; - -class Lib { - - public static var _global : Dynamic; - public static var _root : MovieClip; - public static var current : MovieClip; - static var onerror : String -> Array -> Void; - - public static function trace( str : String ) { - untyped __trace__(str); - } - - public static function eval( str : String ) : Dynamic { - return untyped __eval__(str); - } - - public static function getURL( url : String, ?target : String ) { - untyped __geturl__(url,if( target == null ) "_self" else target); - } - - public static function fscommand( cmd : String, ?param : Dynamic ) { - untyped __geturl__("FSCommand:"+cmd,if( param == null ) "" else param); - } - - public static function print( cmd : String, ?kind : String ) { - kind = if (kind == "bframe" || kind == "bmax") "print:#"+kind else "print:"; - untyped __geturl__(kind,cmd); - } - - public inline static function getTimer() : Int { - return untyped __gettimer__(); - } - - public static function getVersion() : String { - return untyped _root["$version"]; - } - - public static function registerClass( name : String, cl : {} ) { - untyped _global["Object"]["registerClass"](name,cl); - } - - public static function keys( v : Dynamic ) : Array { - return untyped __keys__(v); - } - - public static function setErrorHandler(f) { - onerror = f; - } - -} - - diff --git a/haxe/std/flash/_std/Hash.hx b/haxe/std/flash/_std/Hash.hx deleted file mode 100644 index 351f1faead441097005267e727eac3e586d9700b..0000000000000000000000000000000000000000 --- a/haxe/std/flash/_std/Hash.hx +++ /dev/null @@ -1,81 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Hash { - - private var h : Dynamic; - - public function new() : Void { - h = untyped __new__(_global["Object"]); - } - - public function set( key : String, value : T ) : Void { - untyped h["$"+key] = value; - } - - public function get( key : String ) : Null { - return untyped h["$"+key]; - } - - public function exists( key : String ) : Bool { - return untyped h["hasOwnProperty"]("$"+key); - } - - public function remove( key : String ) : Bool { - key = "$"+key; - if( untyped !h["hasOwnProperty"](key) ) return false; - untyped __delete__(h,key); - return true; - } - - public function keys() : Iterator { - return untyped (__hkeys__(h))["iterator"](); - } - - public function iterator() : Iterator { - return untyped { - ref : h, - it : __keys__(h)["iterator"](), - hasNext : function() { return this.it[__unprotect__("hasNext")](); }, - next : function() { var i = this.it[__unprotect__("next")](); return this.ref[i]; } - }; - } - - public function toString() : String { - var s = new StringBuf(); - s.add("{"); - var it = keys(); - for( i in it ) { - s.add(i); - s.add(" => "); - s.add(Std.string(get(i))); - if( it.hasNext() ) - s.add(", "); - } - s.add("}"); - return s.toString(); - } - -} diff --git a/haxe/std/flash/_std/IntHash.hx b/haxe/std/flash/_std/IntHash.hx deleted file mode 100644 index e9984391924d14f9d9578722770ade8c3250b6e4..0000000000000000000000000000000000000000 --- a/haxe/std/flash/_std/IntHash.hx +++ /dev/null @@ -1,83 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class IntHash { - - private var h : Dynamic; - - public function new() : Void { - h = untyped __new__(_global["Object"]); - } - - public function set( key : Int, value : T ) : Void { - h[key] = value; - } - - public function get( key : Int ) : Null { - return h[key]; - } - - public function exists( key : Int ) : Bool { - return untyped h["hasOwnProperty"](key); - } - - public function remove( key : Int ) : Bool { - if( untyped !h["hasOwnProperty"](key) ) return false; - untyped __delete__(h,key); - return true; - } - - public function keys() : Iterator { - var l : Array = untyped __keys__(h); - for( x in 0...l.length ) - l[x] = Std.int(l[x]); - return l.iterator(); - } - - public function iterator() : Iterator { - return untyped { - ref : h, - it : keys(), - hasNext : function() { return this.it[__unprotect__("hasNext")](); }, - next : function() { var i = this.it[__unprotect__("next")](); return this.ref[i]; } - }; - } - - public function toString() : String { - var s = new StringBuf(); - s.add("{"); - var it = keys(); - for( i in it ) { - s.add(i); - s.add(" => "); - s.add(Std.string(get(i))); - if( it.hasNext() ) - s.add(", "); - } - s.add("}"); - return s.toString(); - } - -} diff --git a/haxe/std/flash/_std/Reflect.hx b/haxe/std/flash/_std/Reflect.hx deleted file mode 100644 index 3cfe5a62134c3b651b08323ab4bea41169d83f1a..0000000000000000000000000000000000000000 --- a/haxe/std/flash/_std/Reflect.hx +++ /dev/null @@ -1,91 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Reflect { - - public inline static function hasField( o : Dynamic, field : String ) : Bool untyped { - return this["hasOwnProperty"]["call"](o,field); - } - - public inline static function field( o : Dynamic, field : String ) : Dynamic untyped { - return o[field]; - } - - public inline static function setField( o : Dynamic, field : String, value : Dynamic ) : Void untyped { - o[field] = value; - } - - public inline static function callMethod( o : Dynamic, func : Dynamic, args : Array ) : Dynamic untyped { - return func["apply"](o,args); - } - - public static function fields( o : Dynamic ) : Array untyped { - if( o == null ) return new Array(); - var a : Array = __keys__(o); - var i = 0; - while( i < a.length ) { - if( !a["hasOwnProperty"]["call"](o,a[i]) ) - a.splice(i,1); - else - ++i; - } - return a; - } - - public static function isFunction( f : Dynamic ) : Bool untyped { - return __typeof__(f) == "function" && f.__name__ == null; - } - - public static function compare( a : T, b : T ) : Int { - return ( a == b ) ? 0 : (((cast a) > (cast b)) ? 1 : -1); - } - - public static function compareMethods( f1 : Dynamic, f2 : Dynamic ) : Bool { - return untyped f1["f"] == f2["f"] && f1["o"] == f2["o"] && f1["f"] != null; - } - - public static function isObject( v : Dynamic ) : Bool untyped { - var t = __typeof__(v); - return (t == "string" || (t == "object" && !v.__enum__) || (t == "function" && v.__name__ != null)); - } - - public static function deleteField( o : Dynamic, f : String ) : Bool untyped { - if( this["hasOwnProperty"]["call"](o,f) != true ) return false; - __delete__(o,f); - return true; - } - - public static function copy( o : T ) : T { - var o2 : Dynamic = {}; - for( f in Reflect.fields(o) ) - Reflect.setField(o2,f,Reflect.field(o,f)); - return o2; - } - - public static function makeVarArgs( f : Array -> Dynamic ) : Dynamic { - return function() { return f(untyped __arguments__); }; - } - -} diff --git a/haxe/std/flash/_std/Std.hx b/haxe/std/flash/_std/Std.hx deleted file mode 100644 index 920862bd224ce4e7be31d56c5b6da9cade9c5ad2..0000000000000000000000000000000000000000 --- a/haxe/std/flash/_std/Std.hx +++ /dev/null @@ -1,78 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Std { - - public static function is( v : Dynamic, t : Dynamic ) : Bool { - return untyped flash.Boot.__instanceof(v,t); - } - - public static function string( s : Dynamic ) : String { - return untyped flash.Boot.__string_rec(s,""); - } - - public static function int( x : Float ) : Int { - if( x < 0 ) return Math.ceil(x); - return Math.floor(x); - } - - public static function parseInt( x : String ) : Null untyped { - var v = _global["parseInt"](x, 10); - if( _global["isNaN"](v) ) { - if( x.charCodeAt(1) == 'x'.code ) { - v = _global["parseInt"](x); - if( !_global["isNaN"](v) ) return v; // fast isNaN - } - return null; - } - return v; - } - - public static function parseFloat( x : String ) : Float { - return untyped _global["parseFloat"](x); - } - - public static function random( x : Int ) : Int { - return untyped __random__(x); - } - - static function __init__() : Void untyped { - var g : Dynamic = _global; - g["Int"] = { __name__ : ["Int"] }; - g["Bool"] = { __ename__ : ["Bool"] }; - g.Dynamic = { __name__ : [__unprotect__("Dynamic")] }; - g.Class = { __name__ : [__unprotect__("Class")] }; - g.Enum = {}; - g.Void = { __ename__ : [__unprotect__("Void")] }; - g["Float"] = _global["Number"]; - g["Float"][__unprotect__("__name__")] = ["Float"]; - Array.prototype[__unprotect__("__class__")] = Array; - Array[__unprotect__("__name__")] = ["Array"]; - String.prototype[__unprotect__("__class__")] = String; - String[__unprotect__("__name__")] = ["String"]; - g["ASSetPropFlags"](Array.prototype,null,7); - } - -} diff --git a/haxe/std/flash9/Lib.hx b/haxe/std/flash9/Lib.hx deleted file mode 100644 index e25146c67f24f92dfaff6e6b5be9c03016390a72..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/Lib.hx +++ /dev/null @@ -1,82 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package flash; - -class Lib { - - public static var current : flash.display.MovieClip; - - public inline static function getTimer() : Int { - return untyped __global__["flash.utils.getTimer"](); - } - - public static function eval( path : String ) : Dynamic { - var p = path.split("."); - var fields = new Array(); - var o : Dynamic = null; - while( p.length > 0 ) { - try { - o = untyped __global__["flash.utils.getDefinitionByName"](p.join(".")); - } catch( e : Dynamic ) { - fields.unshift(p.pop()); - } - if( o != null ) - break; - } - for( f in fields ) { - if( o == null ) return null; - o = untyped o[f]; - } - return o; - } - - public static function getURL( url : flash.net.URLRequest, ?target : String ) { - var f = untyped __global__["flash.net.navigateToURL"]; - if( target == null ) - f(url); - else - (cast f)(url,target); - } - - public static function fscommand( cmd : String, ?param : String ) { - untyped __global__["flash.system.fscommand"](cmd,if( param == null ) "" else param); - } - - public static function trace( arg : Dynamic ) { - untyped __global__["trace"](arg); - } - - public static function attach( name : String ) : flash.display.MovieClip { - var cl = untyped __as__(__global__["flash.utils.getDefinitionByName"](name),Class); - return untyped __new__(cl); - } - - public inline static function as( v : Dynamic, c : Class ) : Null { - return untyped __as__(v,c); - } - -} - - diff --git a/haxe/std/flash9/Vector.hx b/haxe/std/flash9/Vector.hx deleted file mode 100644 index c80590973a7eaaa6449712fba4fdb2475f14d776..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/Vector.hx +++ /dev/null @@ -1,34 +0,0 @@ -package flash; - -/** - The Vector class is very similar to Array but is only supported by the Flash Player 10+ -**/ -@:require(flash10) extern class Vector implements ArrayAccess { - - var length : UInt; - var fixed : Bool; - - function new( ?length : UInt, ?fixed : Bool ) : Void; - function concat( ?a : Vector ) : Vector; - function join( sep : String ) : String; - function pop() : Null; - function push(x : T) : Int; - function reverse() : Void; - function shift() : Null; - function unshift( x : T ) : Void; - function slice( pos : Int, ?end : Int ) : Vector; - function sort( f : T -> T -> Int ) : Void; - function splice( pos : Int, len : Int ) : Vector; - function toString() : String; - function indexOf( x : T, ?from : Int ) : Int; - function lastIndexOf( x : T, ?from : Int ) : Int; - - public inline static function ofArray( v : Array ) : Vector { - return untyped __vector__(v); - } - - public inline static function convert( v : Vector ) : Vector { - return untyped __vector__(v); - } - -} diff --git a/haxe/std/flash9/_std/EReg.hx b/haxe/std/flash9/_std/EReg.hx deleted file mode 100644 index f706f6fabce0bf8f88f535249297b77b26b144de..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/_std/EReg.hx +++ /dev/null @@ -1,85 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class EReg { - - var r : Dynamic; - var result : {> Array, index : Int, input : String }; - - public function new( r : String, opt : String ) : Void { - this.r = untyped __new__(__global__["RegExp"],r,opt); - } - - public function match( s : String ) : Bool { - result = untyped r.exec(s); - return (result != null); - } - - public function matched( n : Int ) : String { - return untyped if( result != null && n >= 0 && n < result.length ) result[n] else throw "EReg::matched"; - } - - public function matchedLeft() : String { - if( result == null ) throw "No string matched"; - var s = result.input; - return s.substr(0,result.index); - } - - public function matchedRight() : String { - if( result == null ) throw "No string matched"; - var rl = result.index + result[0].length; - var s = result.input; - return s.substr(rl,s.length - rl); - } - - public function matchedPos() : { pos : Int, len : Int } { - if( result == null ) throw "No string matched"; - return { pos : result.index, len : result[0].length }; - } - - public function split( s : String ) : Array { - // we can't use directly s.split because it's ignoring the 'g' flag - var d = "#__delim__#"; - return untyped s.replace(r,d).split(d); - } - - public function replace( s : String, by : String ) : String { - return untyped s.replace(r,by); - } - - public function customReplace( s : String, f : EReg -> String ) : String { - var buf = new StringBuf(); - while( true ) { - if( !match(s) ) - break; - buf.add(matchedLeft()); - buf.add(f(this)); - s = matchedRight(); - } - buf.add(s); - return buf.toString(); - } - -} diff --git a/haxe/std/flash9/_std/Hash.hx b/haxe/std/flash9/_std/Hash.hx deleted file mode 100644 index b58d01a2a2885b84784219e885a662dd251c89c2..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/_std/Hash.hx +++ /dev/null @@ -1,81 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Hash { - - private var h :flash.utils.Dictionary; - - public function new() : Void { - h = new flash.utils.Dictionary(); - } - - public function set( key : String, value : T ) : Void { - untyped h["$"+key] = value; - } - - public function get( key : String ) : Null { - return untyped h["$"+key]; - } - - public function exists( key : String ) : Bool { - return untyped h.hasOwnProperty("$"+key); - } - - public function remove( key : String ) : Bool { - key = "$"+key; - if( untyped !h.hasOwnProperty(key) ) return false; - untyped __delete__(h,key); - return true; - } - - public function keys() : Iterator { - return untyped (__hkeys__(h)).iterator(); - } - - public function iterator() : Iterator { - return untyped { - ref : h, - it : __keys__(h).iterator(), - hasNext : function() { return this.it.hasNext(); }, - next : function() { var i : Dynamic = this.it.next(); return this.ref[i]; } - }; - } - - public function toString() : String { - var s = new StringBuf(); - s.add("{"); - var it = keys(); - for( i in it ) { - s.add(i); - s.add(" => "); - s.add(Std.string(get(i))); - if( it.hasNext() ) - s.add(", "); - } - s.add("}"); - return s.toString(); - } - -} diff --git a/haxe/std/flash9/_std/IntHash.hx b/haxe/std/flash9/_std/IntHash.hx deleted file mode 100644 index b1401c4f7f3bda15a9391a99d43c0e9d1bd7055d..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/_std/IntHash.hx +++ /dev/null @@ -1,80 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class IntHash { - - private var h : flash.utils.Dictionary; - - public function new() : Void { - h = new flash.utils.Dictionary(); - } - - public function set( key : Int, value : T ) : Void { - untyped h[key] = value; - } - - public function get( key : Int ) : Null { - return untyped h[key]; - } - - public function exists( key : Int ) : Bool { - return untyped h.hasOwnProperty(key); - } - - public function remove( key : Int ) : Bool { - if( untyped !h.hasOwnProperty(key) ) return false; - untyped __delete__(h,key); - return true; - } - - public function keys() : Iterator { - return untyped (__keys__(h)).iterator(); - } - - public function iterator() : Iterator { - return untyped { - ref : h, - it : keys(), - hasNext : function() { return this.it.hasNext(); }, - next : function() { var i = this.it.next(); return this.ref[i]; } - }; - } - - public function toString() : String { - var s = new StringBuf(); - s.add("{"); - var it = keys(); - for( i in it ) { - s.add(i); - s.add(" => "); - s.add(Std.string(get(i))); - if( it.hasNext() ) - s.add(", "); - } - s.add("}"); - return s.toString(); - } - -} diff --git a/haxe/std/flash9/_std/Reflect.hx b/haxe/std/flash9/_std/Reflect.hx deleted file mode 100644 index 06ae8f68596ecf0b170a84316220bf605cfbea0b..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/_std/Reflect.hx +++ /dev/null @@ -1,103 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Reflect { - - public static function hasField( o : Dynamic, field : String ) : Bool untyped { - return o.hasOwnProperty( field ); - } - - public inline static function field( o : Dynamic, field : String ) : Dynamic untyped { - return (o == null) ? null : o[field]; - } - - public inline static function setField( o : Dynamic, field : String, value : Dynamic ) : Void untyped { - o[field] = value; - } - - public inline static function callMethod( o : Dynamic, func : Dynamic, args : Array ) : Dynamic untyped { - return func.apply(o,args); - } - - public static function fields( o : Dynamic ) : Array untyped { - if( o == null ) return new Array(); - var a : Array = __keys__(o); - var i = 0; - while( i < a.length ){ - if( !o.hasOwnProperty(a[i]) ) - a.splice(i,1); - else - ++i; - } - return a; - } - - public static function isFunction( f : Dynamic ) : Bool untyped { - return __typeof__(f) == "function"; - } - - public static function compare( a : T, b : T ) : Int { - var a : Dynamic = a; - var b : Dynamic = b; - return ( a == b ) ? 0 : ((a > b) ? 1 : -1); - } - - public static function compareMethods( f1 : Dynamic, f2 : Dynamic ) : Bool { - return f1 == f2; // VM-level closures - } - - public static function isObject( v : Dynamic ) : Bool untyped { - if( v == null ) - return false; - var t = __typeof__(v); - if( t == "object" ) { - try { - if( v.__enum__ == true ) - return false; - } catch( e : Dynamic ) { - } - return true; - } - return (t == "string"); - } - - public static function deleteField( o : Dynamic, f : String ) : Bool untyped { - if( o.hasOwnProperty(f) != true ) return false; - __delete__(o,f); - return true; - } - - public static function copy( o : T ) : T { - var o2 : Dynamic = {}; - for( f in Reflect.fields(o) ) - Reflect.setField(o2,f,Reflect.field(o,f)); - return o2; - } - - public static function makeVarArgs( f : Array -> Dynamic ) : Dynamic { - return function(__arguments__) { return f(__arguments__); }; - } - -} diff --git a/haxe/std/flash9/_std/Std.hx b/haxe/std/flash9/_std/Std.hx deleted file mode 100644 index 71a99013519aa58cb4fc3b89986b940f5791112a..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/_std/Std.hx +++ /dev/null @@ -1,55 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Std { - - public static function is( v : Dynamic, t : Dynamic ) : Bool { - return untyped flash.Boot.__instanceof(v,t); - } - - public static function string( s : Dynamic ) : String { - return untyped flash.Boot.__string_rec(s,""); - } - - public inline static function int( x : Float ) : Int { - return untyped __int__(x); - } - - public static function parseInt( x : String ) : Null untyped { - var v = __global__["parseInt"](x); - if( __global__["isNaN"](v) ) - return null; - return v; - } - - public static function parseFloat( x : String ) : Float { - return untyped __global__["parseFloat"](x); - } - - public static function random( x : Int ) : Int { - return untyped Math.floor(Math.random()*x); - } - -} diff --git a/haxe/std/flash9/display/ColorCorrection.hx b/haxe/std/flash9/display/ColorCorrection.hx deleted file mode 100644 index 8e34ca6054bccb6621f2ee17beae88a78d5cd00f..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/display/ColorCorrection.hx +++ /dev/null @@ -1,7 +0,0 @@ -package flash.display; - -@:fakeEnum(String) extern enum ColorCorrection { - DEFAULT; - OFF; - ON; -} diff --git a/haxe/std/flash9/display/ColorCorrectionSupport.hx b/haxe/std/flash9/display/ColorCorrectionSupport.hx deleted file mode 100644 index 14ca7828e18df6856a40ca19f23954c84e973f7f..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/display/ColorCorrectionSupport.hx +++ /dev/null @@ -1,7 +0,0 @@ -package flash.display; - -@:fakeEnum(String) extern enum ColorCorrectionSupport { - DEFAULT_OFF; - DEFAULT_ON; - UNSUPPORTED; -} diff --git a/haxe/std/flash9/display/FocusDirection.hx b/haxe/std/flash9/display/FocusDirection.hx deleted file mode 100644 index 1190ef1b5d2b4cbc978f494e1eeeb8b3cf38d3b5..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/display/FocusDirection.hx +++ /dev/null @@ -1,7 +0,0 @@ -package flash.display; - -@:fakeEnum(String) extern enum FocusDirection { - BOTTOM; - NONE; - TOP; -} diff --git a/haxe/std/flash9/display/GraphicsEndFill.hx b/haxe/std/flash9/display/GraphicsEndFill.hx deleted file mode 100644 index c2632d94b451d587405b5145477b7c9864b50b69..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/display/GraphicsEndFill.hx +++ /dev/null @@ -1,5 +0,0 @@ -package flash.display; - -extern class GraphicsEndFill implements IGraphicsData, implements IGraphicsFill { - function new() : Void; -} diff --git a/haxe/std/flash9/display/SWFVersion.hx b/haxe/std/flash9/display/SWFVersion.hx deleted file mode 100644 index 2e3dbd140063695128b4dd43d03bc656a9f45a4b..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/display/SWFVersion.hx +++ /dev/null @@ -1,14 +0,0 @@ -package flash.display; - -@:fakeEnum(UInt) extern enum SWFVersion { - FLASH1; - FLASH10; - FLASH2; - FLASH3; - FLASH4; - FLASH5; - FLASH6; - FLASH7; - FLASH8; - FLASH9; -} diff --git a/haxe/std/flash9/errors/ArgumentsError.hx b/haxe/std/flash9/errors/ArgumentsError.hx deleted file mode 100644 index a4401d49df9c7a6a11a4e4fcd7ffb9829b60bcd8..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/errors/ArgumentsError.hx +++ /dev/null @@ -1,4 +0,0 @@ -package flash.errors; - -@:native("ArgumentsError") extern class ArgumentsError extends Error { -} diff --git a/haxe/std/flash9/events/FullScreenEvent.hx b/haxe/std/flash9/events/FullScreenEvent.hx deleted file mode 100644 index 70853753354fde5cb5f4da5f1f657e5caea8e06c..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/events/FullScreenEvent.hx +++ /dev/null @@ -1,7 +0,0 @@ -package flash.events; - -extern class FullScreenEvent extends ActivityEvent { - var fullScreen(default,null) : Bool; - function new(type : String, bubbles : Bool = false, cancelable : Bool = false, fullScreen : Bool = false) : Void; - static var FULL_SCREEN : String; -} diff --git a/haxe/std/flash9/events/GesturePhase.hx b/haxe/std/flash9/events/GesturePhase.hx deleted file mode 100644 index ce744993d823af92e601b16adc16d33d276cdb61..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/events/GesturePhase.hx +++ /dev/null @@ -1,8 +0,0 @@ -package flash.events; - -@:fakeEnum(String) extern enum GesturePhase { - ALL; - BEGIN; - END; - UPDATE; -} diff --git a/haxe/std/flash9/net/IDynamicPropertyWriter.hx b/haxe/std/flash9/net/IDynamicPropertyWriter.hx deleted file mode 100644 index 76826634184e7989b37841e2912d035c4cb1c133..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/IDynamicPropertyWriter.hx +++ /dev/null @@ -1,5 +0,0 @@ -package flash.net; - -extern interface IDynamicPropertyWriter { - function writeDynamicProperties(obj : Dynamic, output : IDynamicPropertyOutput) : Void; -} diff --git a/haxe/std/flash9/net/NetGroupReceiveMode.hx b/haxe/std/flash9/net/NetGroupReceiveMode.hx deleted file mode 100644 index 246b9c5f3f4e679242efd0fbe4888c50ad900b0a..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/NetGroupReceiveMode.hx +++ /dev/null @@ -1,6 +0,0 @@ -package flash.net; - -@:fakeEnum(String) extern enum NetGroupReceiveMode { - EXACT; - NEAREST; -} diff --git a/haxe/std/flash9/net/NetGroupReplicationStrategy.hx b/haxe/std/flash9/net/NetGroupReplicationStrategy.hx deleted file mode 100644 index 8e5ae301103be8dc25e46c699051eb3fab9ec12a..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/NetGroupReplicationStrategy.hx +++ /dev/null @@ -1,6 +0,0 @@ -package flash.net; - -@:fakeEnum(String) extern enum NetGroupReplicationStrategy { - LOWEST_FIRST; - RAREST_FIRST; -} diff --git a/haxe/std/flash9/net/NetGroupSendMode.hx b/haxe/std/flash9/net/NetGroupSendMode.hx deleted file mode 100644 index 4a6102b7e0aab9fd7c32a7db98aa4989dbf8e18d..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/NetGroupSendMode.hx +++ /dev/null @@ -1,6 +0,0 @@ -package flash.net; - -@:fakeEnum(String) extern enum NetGroupSendMode { - NEXT_DECREASING; - NEXT_INCREASING; -} diff --git a/haxe/std/flash9/net/NetGroupSendResult.hx b/haxe/std/flash9/net/NetGroupSendResult.hx deleted file mode 100644 index da766586414e4bf656eef98dd6d9ecbbfae4d115..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/NetGroupSendResult.hx +++ /dev/null @@ -1,7 +0,0 @@ -package flash.net; - -@:fakeEnum(String) extern enum NetGroupSendResult { - ERROR; - NO_ROUTE; - SENT; -} diff --git a/haxe/std/flash9/net/NetStreamAppendBytesAction.hx b/haxe/std/flash9/net/NetStreamAppendBytesAction.hx deleted file mode 100644 index f09f4e7accd58217e011e191ee9e3f85580a0720..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/NetStreamAppendBytesAction.hx +++ /dev/null @@ -1,7 +0,0 @@ -package flash.net; - -@:fakeEnum(String) extern enum NetStreamAppendBytesAction { - END_SEQUENCE; - RESET_BEGIN; - RESET_SEEK; -} diff --git a/haxe/std/flash9/net/SharedObjectFlushStatus.hx b/haxe/std/flash9/net/SharedObjectFlushStatus.hx deleted file mode 100644 index 6d18827fa02332ded526c6fb8817834e964dda17..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/SharedObjectFlushStatus.hx +++ /dev/null @@ -1,6 +0,0 @@ -package flash.net; - -@:fakeEnum(String) extern enum SharedObjectFlushStatus { - FLUSHED; - PENDING; -} diff --git a/haxe/std/flash9/net/drm/AuthenticationMethod.hx b/haxe/std/flash9/net/drm/AuthenticationMethod.hx deleted file mode 100644 index 56c049e1d9113ccffc02590757d08e2f3f7a32e0..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/drm/AuthenticationMethod.hx +++ /dev/null @@ -1,6 +0,0 @@ -package flash.net.drm; - -@:fakeEnum(String) extern enum AuthenticationMethod { - ANONYMOUS; - USERNAME_AND_PASSWORD; -} diff --git a/haxe/std/flash9/net/drm/DRMURLDownloadContext.hx b/haxe/std/flash9/net/drm/DRMURLDownloadContext.hx deleted file mode 100644 index 51f1cbe2b5426bf7ec53fc932a9832adefc9c5da..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/drm/DRMURLDownloadContext.hx +++ /dev/null @@ -1,5 +0,0 @@ -package flash.net.drm; - -extern class DRMURLDownloadContext extends flash.events.EventDispatcher { - function new() : Void; -} diff --git a/haxe/std/flash9/net/drm/LoadVoucherSetting.hx b/haxe/std/flash9/net/drm/LoadVoucherSetting.hx deleted file mode 100644 index 44b9ce9838638fe3ebadc3fd50ba13ae7a2501ba..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/net/drm/LoadVoucherSetting.hx +++ /dev/null @@ -1,7 +0,0 @@ -package flash.net.drm; - -@:fakeEnum(String) extern enum LoadVoucherSetting { - ALLOW_SERVER; - FORCE_REFRESH; - LOCAL_ONLY; -} diff --git a/haxe/std/flash9/sampler/Api.hx b/haxe/std/flash9/sampler/Api.hx deleted file mode 100644 index 553464a5df07b45f3d89a21b33be49dacebfdf4d..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/sampler/Api.hx +++ /dev/null @@ -1,53 +0,0 @@ -package flash.sampler; - -class Api { - - public static function clearSamples() { - untyped __global__["flash.sampler.clearSamples"](); - } - - public static function getGetterInvocationCount( obj : Dynamic, qname : flash.utils.QName ) : Float { - return untyped __global__["flash.sampler.getGetterInvocationCount"](obj,qname); - } - - public static function getSetterInvocationCount( obj : Dynamic, qname : flash.utils.QName ) : Float { - return untyped __global__["flash.sampler.getSetterInvocationCount"](obj,qname); - } - - public static function getInvocationCount( obj : Dynamic, qname : flash.utils.QName ) : Float { - return untyped __global__["flash.sampler.getInvocationCount"](obj,qname); - } - - public static function getMemberNames( obj : Dynamic, ?instanceNames : Bool ) : Dynamic { - return untyped __global__["flash.sampler.getMemberNames"](obj,instanceNames); - } - - public static function getSampleCount() : Float { - return untyped __global__["flash.sampler.getSampleCount"](); - } - - public static function getSamples() : Array { - return untyped __foreach__(__global__["flash.sampler.getSamples"]()); - } - - public static function getSize( obj : Dynamic ) : Float { - return untyped __global__["flash.sampler.getSize"](obj); - } - - public static function isGetterSetter( obj : Dynamic, qname : flash.utils.QName ) : Bool { - return untyped __global__["flash.sampler.isGetterSetter"](obj,qname); - } - - public static function pauseSampling() { - untyped __global__["flash.sampler.pauseSampling"](); - } - - public static function startSampling() { - untyped __global__["flash.sampler.startSampling"](); - } - - public static function stopSampling() { - untyped __global__["flash.sampler.stopSampling"](); - } - -} \ No newline at end of file diff --git a/haxe/std/flash9/text/StyleSheet.hx b/haxe/std/flash9/text/StyleSheet.hx deleted file mode 100644 index 549554f3770949d88e62f8e12c00da677e09d859..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/text/StyleSheet.hx +++ /dev/null @@ -1,11 +0,0 @@ -package flash.text; - -extern class StyleSheet extends flash.events.EventDispatcher, implements Dynamic { - var styleNames(default,null) : Array; - function new() : Void; - function clear() : Void; - function getStyle(styleName : String) : Dynamic; - function parseCSS(CSSText : String) : Void; - function setStyle(styleName : String, styleObject : Dynamic) : Void; - function transform(formatObject : Dynamic) : TextFormat; -} diff --git a/haxe/std/flash9/ui/Mouse.hx b/haxe/std/flash9/ui/Mouse.hx deleted file mode 100644 index 8e520b3c5fc6993888b3504538ecde2cd01b10aa..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/ui/Mouse.hx +++ /dev/null @@ -1,9 +0,0 @@ -package flash.ui; - -extern class Mouse { - @:require(flash10) static var cursor : MouseCursor; - @:require(flash10_1) static var supportsCursor(default,null) : Bool; - static function hide() : Void; - @:require(flash10_2) static function registerCursor(cursor : flash.display.MouseCursorData) : Void; - static function show() : Void; -} diff --git a/haxe/std/flash9/ui/MouseCursor.hx b/haxe/std/flash9/ui/MouseCursor.hx deleted file mode 100644 index bcb2ad47696a3d1f40df07e746147b38064b65ab..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/ui/MouseCursor.hx +++ /dev/null @@ -1,9 +0,0 @@ -package flash.ui; - -@:fakeEnum(String) extern enum MouseCursor { - ARROW; - AUTO; - BUTTON; - HAND; - IBEAM; -} diff --git a/haxe/std/flash9/ui/MultitouchInputMode.hx b/haxe/std/flash9/ui/MultitouchInputMode.hx deleted file mode 100644 index 8a0b7d36f37e0eea50442009d736ea9f55a7c5ac..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/ui/MultitouchInputMode.hx +++ /dev/null @@ -1,7 +0,0 @@ -package flash.ui; - -@:fakeEnum(String) extern enum MultitouchInputMode { - GESTURE; - NONE; - TOUCH_POINT; -} diff --git a/haxe/std/flash9/utils/TypedDictionary.hx b/haxe/std/flash9/utils/TypedDictionary.hx deleted file mode 100644 index ac11760a0a699b149662a971bdcdfb5d166d5d5f..0000000000000000000000000000000000000000 --- a/haxe/std/flash9/utils/TypedDictionary.hx +++ /dev/null @@ -1,56 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package flash.utils; - -/** - This is a typed version of the Flash9 Dictionary class. -**/ -class TypedDictionary extends Dictionary { - - public inline function get( k : K ) : Null { - return untyped this[k]; - } - - public inline function set( k : K, v : T ) { - untyped this[k] = v; - } - - public inline function exists( k : K ) { - return untyped this[k] != null; - } - - public inline function delete( k : K ) { - untyped __delete__(this,k); - } - - public inline function keys() : Array { - return untyped __keys__(this); - } - - public function iterator() : Iterator { - return keys().iterator(); - } - -} \ No newline at end of file diff --git a/haxe/std/haxe/Firebug.hx b/haxe/std/haxe/Firebug.hx deleted file mode 100644 index 4df3b014865e374c581b7ba1cd1968b2ba46f9aa..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/Firebug.hx +++ /dev/null @@ -1,98 +0,0 @@ -/* - * Copyright (c) 2007, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; - -class Firebug { - - public static function detect() : Bool { - #if js - try { - return untyped console != null && console.error != null; - } catch( e : Dynamic ) { - return false; - } - #elseif flash - if( !flash.external.ExternalInterface.available ) - return false; - return flash.external.ExternalInterface.call("console.error.toString") != null; - #else - return true; - #end - } - - public static function redirectTraces() { - haxe.Log.trace = trace; - #if flash9 - #elseif flash - flash.Lib.setErrorHandler(onError); - #elseif js - js.Lib.setErrorHandler(onError); - #end - } - - public static function onError( err : String, stack : Array ) { - var buf = err+"\n"; - for( s in stack ) - buf += "Called from "+s+"\n"; - haxe.Firebug.trace(buf,null); - #if js - return true; - #end - } - - public static function trace(v : Dynamic, ?inf : haxe.PosInfos ) { - var type = if( inf != null && inf.customParams != null ) inf.customParams[0] else null; - if( type != "warn" && type != "info" && type != "debug" && type != "error" ) - type = if( inf == null ) "error" else "log"; - #if flash - var str = if( inf == null ) "" else inf.fileName + ":" + inf.lineNumber + " : "; - try str += Std.string(v) catch( e : Dynamic ) str += "????"; - #if flash9 - // in Flash9, it is needed to use _self with getURL and - // only the latest call per frame is processed, so it's - // needed to use ExternalInterface (URLLoader displays - // security errors for remote files) - str = str.split("\\").join("\\\\"); - flash.external.ExternalInterface.call("console."+type,str); - #else - str = str.split("\\").join("\\\\").split("'").join("\\'").split("\n").join("\\n").split("\r").join("\\r"); - str = StringTools.urlEncode(str); - var out = "javascript:console."+ type +"('"+str+"');"; - flash.Lib.getURL(out); - #end // flash9 - #elseif js - untyped console[type]( (if( inf == null ) "" else inf.fileName+":"+inf.lineNumber+" : ") + Std.string(v) ); - #elseif (neko || php) - var str = inf.fileName + ":" + inf.lineNumber + " : "; - try str += Std.string(v) catch( e : Dynamic ) str += "???"; - #if neko - neko.Lib.print(''); - #else - php.Lib.print(''); - #end - #end - } - -} diff --git a/haxe/std/haxe/Int32.hx b/haxe/std/haxe/Int32.hx deleted file mode 100644 index 152aa4de4e1c26360d3d9ec055c5385fbcc52a41..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/Int32.hx +++ /dev/null @@ -1,205 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; - -#if (cpp && !xmldoc) -typedef Int32 = cpp.CppInt32__; -#else - -class Int32 { - - public static inline function make( a : Int, b : Int ) : Int32 { - #if neko - return add(shl(cast a,16),cast b); - #else - return cast ((a << 16) | b); - #end - } - - public static inline function ofInt( x : Int ) : Int32 { - #if neko - return untyped __i32__new(x); - #else - return cast x; - #end - } - - public static inline function toInt( x : Int32 ) : Int { - #if !neko - if( (((cast x) >> 30) & 1) != ((cast x) >>> 31) ) throw "Overflow "+x; - #end - #if neko - return try untyped __i32__to_int(x) catch( e : Dynamic ) throw "Overflow"+x; - #elseif flash9 - return cast x; - #else - return (cast x) & 0xFFFFFFFF; - #end - } - - public static inline function toNativeInt( x : Int32 ) : Int { - #if neko - return untyped (__i32__ushr(x,8) << 8) | __i32__and(x,0xFF); - #else - return cast x; - #end - } - - public static inline function add( a : Int32, b : Int32 ) : Int32 { - #if neko - return untyped __i32__add(a,b); - #else - return cast ((cast a) + (cast b)); - #end - } - - public static inline function sub( a : Int32, b : Int32 ) : Int32 { - #if neko - return untyped __i32__sub(a,b); - #else - return cast ((cast a) - (cast b)); - #end - } - - public static inline function mul( a : Int32, b : Int32 ) : Int32 { - #if neko - return untyped __i32__mul(a,b); - #else - return cast ((cast a) * (cast b)); - #end - } - - public static inline function div( a : Int32, b : Int32 ) : Int32 { - #if neko - return untyped __i32__div(a,b); - #else - return cast Std.int((cast a) / (cast b)); - #end - } - - public static inline function mod( a : Int32, b : Int32 ) : Int32 { - #if neko - return untyped __i32__mod(a,b); - #else - return cast ((cast a) % (cast b)); - #end - } - - public static inline function shl( a : Int32, b : Int ) : Int32 { - #if neko - return untyped __i32__shl(a,b); - #else - return cast ((cast a) << b); - #end - } - - public static inline function shr( a : Int32, b : Int ) : Int32 { - #if neko - return untyped __i32__shr(a,b); - #else - return cast ((cast a) >> b); - #end - } - - public static inline function ushr( a : Int32, b : Int ) : Int32 { - #if neko - return untyped __i32__ushr(a,b); - #else - return cast ((cast a) >>> b); - #end - } - - public static inline function and( a : Int32, b : Int32 ) : Int32 { - #if neko - return untyped __i32__and(a,b); - #else - return cast ((cast a) & (cast b)); - #end - } - - public static inline function or( a : Int32, b : Int32 ) : Int32 { - #if neko - return untyped __i32__or(a,b); - #else - return cast ((cast a) | (cast b)); - #end - } - - public static inline function xor( a : Int32, b : Int32 ) : Int32 { - #if neko - return untyped __i32__xor(a,b); - #else - return cast ((cast a) ^ (cast b)); - #end - } - - public static inline function neg( a : Int32 ) : Int32 { - #if neko - return untyped __i32__neg(a); - #else - return cast -(cast a); - #end - } - - public static inline function complement( a : Int32 ) : Int32 { - #if neko - return untyped __i32__complement(a); - #else - return cast ~(cast a); - #end - } - - public static inline function compare( a : Int32, b : Int32 ) : Int { - #if neko - return untyped __i32__compare(a,b); - #else - return untyped a - b; - #end - } - - #if neko - static function __init__() untyped { - __i32__new = neko.Lib.load("std","int32_new",1); - __i32__to_int = neko.Lib.load("std","int32_to_int",1); - __i32__add = neko.Lib.load("std","int32_add",2); - __i32__sub = neko.Lib.load("std","int32_sub",2); - __i32__mul = neko.Lib.load("std","int32_mul",2); - __i32__div = neko.Lib.load("std","int32_div",2); - __i32__mod = neko.Lib.load("std","int32_mod",2); - __i32__shl = neko.Lib.load("std","int32_shl",2); - __i32__shr = neko.Lib.load("std","int32_shr",2); - __i32__ushr = neko.Lib.load("std","int32_ushr",2); - __i32__and = neko.Lib.load("std","int32_and",2); - __i32__or = neko.Lib.load("std","int32_or",2); - __i32__xor = neko.Lib.load("std","int32_xor",2); - __i32__neg = neko.Lib.load("std","int32_neg",1); - __i32__complement = neko.Lib.load("std","int32_complement",1); - __i32__compare = neko.Lib.load("std","int32_compare",2); - } - #end - -} -#end - diff --git a/haxe/std/haxe/Log.hx b/haxe/std/haxe/Log.hx deleted file mode 100644 index bfe171849560932d45895824379e81fce725e0ff..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/Log.hx +++ /dev/null @@ -1,57 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; - -class Log { - - public static dynamic function trace( v : Dynamic, ?infos : PosInfos ) : Void { - #if flash - untyped flash.Boot.__trace(v,infos); - #elseif neko - untyped __dollar__print(infos.fileName+":"+infos.lineNumber+": ",v,"\n"); - #elseif js - untyped js.Boot.__trace(v,infos); - #elseif php - untyped __call__('_hx_trace', v,infos); - #elseif cpp - untyped __trace(v,infos); - #end - } - - public static dynamic function clear() : Void { - #if flash - untyped flash.Boot.__clear_trace(); - #elseif js - untyped js.Boot.__clear_trace(); - #end - } - - #if flash - public static dynamic function setColor( rgb : Int ) { - untyped flash.Boot.__set_trace_color(rgb); - } - #end - -} diff --git a/haxe/std/haxe/PosInfos.hx b/haxe/std/haxe/PosInfos.hx deleted file mode 100644 index 4cee2971ff02a70b826cb15960a764e501dbdbf2..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/PosInfos.hx +++ /dev/null @@ -1,33 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; - -typedef PosInfos = { - var fileName : String; - var lineNumber : Int; - var className : String; - var methodName : String; - var customParams : Array; -} diff --git a/haxe/std/haxe/Public.hx b/haxe/std/haxe/Public.hx deleted file mode 100644 index 08ee16941fe52e8e1696dd9abe6e514b1b82df0c..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/Public.hx +++ /dev/null @@ -1,32 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; - -/** - When implementing this interface, all default fields access for the class and - subclasses becomes [public] instead of [private]. -**/ -interface Public { -} diff --git a/haxe/std/haxe/Resource.hx b/haxe/std/haxe/Resource.hx deleted file mode 100644 index 61bfd607190c138959e73433f246dbc818ef180f..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/Resource.hx +++ /dev/null @@ -1,117 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; - -class Resource { -#if php - static function cleanName(name : String) : String { - return ~/[\\\/:?"*<>|]/.replace(name, '_'); - } - - static function getDir() { - return untyped __call__('dirname', __php__('__FILE__'))+"/../../res"; - } - - static function getPath(name : String) { - return getDir()+'/'+cleanName(name); - } - - public static function listNames() : Array { - var a = php.FileSystem.readDirectory(getDir()); - if(a[0] == '.') a.shift(); - if(a[0] == '..') a.shift(); - return a; - } - - public static function getString( name : String ) { - return php.io.File.getContent(getPath(name)); - } - - public static function getBytes( name : String ) { - return php.io.File.getBytes(getPath(name)); - } -#elseif cpp - public static function listNames() : Array { - return untyped __global__.__hxcpp_resource_names(); - } - public static function getString(name:String) : String { - return untyped __global__.__hxcpp_resource_string(name); - } - public static function getBytes(name:String) : haxe.io.Bytes { - var array:haxe.io.BytesData = untyped __global__.__hxcpp_resource_bytes(name); - if (array==null) return null; - return haxe.io.Bytes.ofData(array); - } -#else - static var content : Array<{ name : String, data : String, str : String }>; - - public static function listNames() : Array { - var names = new Array(); - for( x in content ) - names.push(x.name); - return names; - } - - public static function getString( name : String ) : String { - for( x in content ) - if( x.name == name ) { - #if neko - return new String(x.data); - #else - if( x.str != null ) return x.str; - var b : haxe.io.Bytes = haxe.Unserializer.run(x.data); - return b.toString(); - #end - } - return null; - } - - public static function getBytes( name : String ) : haxe.io.Bytes { - for( x in content ) - if( x.name == name ) { - #if neko - return haxe.io.Bytes.ofData(cast x.data); - #else - if( x.str != null ) return haxe.io.Bytes.ofString(x.str); - return haxe.Unserializer.run(x.data); - #end - } - return null; - } - - static function __init__() { - #if neko - var tmp = untyped __resources__(); - content = untyped Array.new1(tmp,__dollar__asize(tmp)); - #elseif php - content = null; - #elseif as3 - null; - #else - content = untyped __resources__(); - #end - } -#end -} diff --git a/haxe/std/haxe/SHA1.hx b/haxe/std/haxe/SHA1.hx deleted file mode 100644 index 53f682a77852cbddb016e94954a091f28351e7ae..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/SHA1.hx +++ /dev/null @@ -1,152 +0,0 @@ -/* - * Copyright (c) 2005-2010, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; -import haxe.Int32; - -class SHA1 { - - static var hex_chr = "0123456789abcdef"; - - inline static function newInt32( left:Int, right:Int ) : Int32 { - var result = Int32.ofInt(left); - result = Int32.shl(result, 16); - return Int32.add(result, Int32.ofInt(right)); - } - - public static function encode( s:String ) : String { - var x = str2blks_SHA1( s ); - var w = new Array(); - - var a = newInt32(0x6745, 0x2301); - var b = newInt32(0xEFCD, 0xAB89); - var c = newInt32(0x98BA, 0xDCFE); - var d = newInt32(0x1032, 0x5476); - var e = newInt32(0xC3D2, 0xE1F0); - - var i = 0; - while( i < x.length ) { - var olda = a; - var oldb = b; - var oldc = c; - var oldd = d; - var olde = e; - - var j = 0; - while( j < 80 ) { - if(j < 16) - w[j] = x[i + j]; - else - w[j] = rol(Int32.xor(Int32.xor(Int32.xor(w[j-3], w[j-8]), w[j-14]), w[j-16]), 1); - var t = add(add(rol(a, 5), ft(Int32.ofInt(j), b, c, d)), add(add(e, w[j]), kt(Int32.ofInt(j)))); - e = d; - d = c; - c = rol(b, 30); - b = a; - a = t; - - j++; - } - a = add( a, olda ); - b = add( b, oldb ); - c = add( c, oldc ); - d = add( d, oldd ); - e = add( e, olde ); - i += 16; - } - return hex(a) + hex(b) + hex(c) + hex(d) + hex(e); - } - - static function hex( num : Int32 ) : String { - var str = ""; - var j = 7; - while( j >= 0 ) { - str += hex_chr.charAt( Int32.toInt( Int32.and((Int32.shr(num, j*4)), Int32.ofInt(0x0F)) ) ); - j--; - } - return str; - } - - /** - Convert a string to a sequence of 16-word blocks, stored as an array. - Append padding bits and the length, as described in the SHA1 standard. - */ - static function str2blks_SHA1( s :String ) : Array { - var nblk = ((s.length + 8) >> 6) + 1; - var blks = new Array(); - - for (i in 0...nblk*16) - blks[i] = Int32.ofInt(0); - for (i in 0...s.length){ - var p = i >> 2; - var c = Int32.ofInt(s.charCodeAt(i)); - blks[p] = Int32.or(blks[p], Int32.shl(c, (24 - (i % 4) * 8))); - } - var i = s.length; - var p = i >> 2; - blks[p] = Int32.or(blks[p], Int32.shl(Int32.ofInt(0x80), (24 - (i % 4) * 8))); - blks[nblk * 16 - 1] = Int32.ofInt(s.length * 8); - return blks; - } - - /** - Add integers, wrapping at 2^32. - */ - static function add( x : Int32, y : Int32 ) : Int32 { - var lsw = Int32.add(Int32.and(x, Int32.ofInt(0xFFFF)), Int32.and(y, Int32.ofInt(0xFFFF))); - var msw = Int32.add(Int32.add(Int32.shr(x, 16), Int32.shr(y, 16)), Int32.shr(lsw, 16)); - return Int32.or(Int32.shl(msw, 16), Int32.and(lsw, Int32.ofInt(0xFFFF))); - } - - /** - Bitwise rotate a 32-bit number to the left - */ - static function rol( num : Int32, cnt : Int ) : Int32 { - return Int32.or(Int32.shl(num, cnt), Int32.ushr(num, (32 - cnt))); - } - - /** - Perform the appropriate triplet combination function for the current iteration - */ - static function ft( t : Int32, b : Int32, c : Int32, d : Int32 ) : Int32 { - if (Int32.compare(t, Int32.ofInt(20)) <0) return Int32.or(Int32.and(b, c), Int32.and((Int32.complement(b)), d)); - if (Int32.compare(t, Int32.ofInt(40)) <0) return Int32.xor(Int32.xor(b, c), d); - if (Int32.compare(t, Int32.ofInt(60)) <0) return Int32.or(Int32.or(Int32.and(b, c), Int32.and(b, d)), Int32.and(c, d)); - return Int32.xor(Int32.xor(b, c), d); - } - - /** - Determine the appropriate additive constant for the current iteration - */ - static function kt( t : Int32 ) : Int32 { - if (Int32.compare(t,Int32.ofInt(20)) < 0) - return newInt32(0x5A82, 0x7999); - if (Int32.compare(t,Int32.ofInt(40)) < 0) - return newInt32(0x6ed9, 0xeba1); - if (Int32.compare(t,Int32.ofInt(60)) < 0) - return newInt32(0x8f1b, 0xbcdc); - return newInt32(0xca62, 0xc1d6); - } - -} diff --git a/haxe/std/haxe/Timer.hx b/haxe/std/haxe/Timer.hx deleted file mode 100644 index 3dd62703b0efe25b043e10ac11a63c4a2ae77440..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/Timer.hx +++ /dev/null @@ -1,113 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; - -class Timer { - #if (neko || php) - #else - - private var id : Null; - - #if js - private static var arr = new Array(); - private var timerId : Int; - #end - - public function new( time_ms : Int ){ - #if flash9 - var me = this; - id = untyped __global__["flash.utils.setInterval"](function() { me.run(); },time_ms); - #elseif flash - var me = this; - id = untyped _global["setInterval"](function() { me.run(); },time_ms); - #elseif js - id = arr.length; - arr[id] = this; - timerId = untyped window.setInterval("haxe.Timer.arr["+id+"].run();",time_ms); - #end - } - - public function stop() { - if( id == null ) - return; - #if flash9 - untyped __global__["flash.utils.clearInterval"](id); - #elseif flash - untyped _global["clearInterval"](id); - #elseif js - untyped window.clearInterval(timerId); - arr[id] = null; - if( id > 100 && id == arr.length - 1 ) { - // compact array - var p = id - 1; - while( p >= 0 && arr[p] == null ) - p--; - arr = arr.slice(0,p+1); - } - #end - id = null; - } - - public dynamic function run() { - } - - public static function delay( f : Void -> Void, time_ms : Int ) { - var t = new haxe.Timer(time_ms); - t.run = function() { - t.stop(); - f(); - }; - return t; - } - - #end - - public static function measure( f : Void -> T, ?pos : PosInfos ) : T { - var t0 = stamp(); - var r = f(); - Log.trace((stamp() - t0) + "s", pos); - return r; - } - - /** - Returns a timestamp, in seconds - **/ - public static function stamp() : Float { - #if flash - return flash.Lib.getTimer() / 1000; - #elseif neko - return neko.Sys.time(); - #elseif php - return php.Sys.time(); - #elseif js - return Date.now().getTime() / 1000; - #elseif cpp - return untyped __time_stamp(); - #else - return 0; - #end - } - -} diff --git a/haxe/std/haxe/TimerQueue.hx b/haxe/std/haxe/TimerQueue.hx deleted file mode 100644 index 0991a730c4c70a86afb9adef724e2e323345e8f8..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/TimerQueue.hx +++ /dev/null @@ -1,60 +0,0 @@ -/* - * Copyright (c) 2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe; - -#if neko -#error -#end - -class TimerQueue { - - var delay : Int; - var t : haxe.Timer; - var q : ArrayVoid>; - - public function new( ?delay ) { - this.delay = delay == null ? 1 : delay; - q = new Array(); - } - - public function add(f) { - q.push(f); - if( t == null ) { - t = new haxe.Timer(delay); - t.run = process; - } - } - - function process() { - var f = q.shift(); - if( f == null ) { - t.stop(); - t = null; - return; - } - f(); - } - -} diff --git a/haxe/std/haxe/io/BytesData.hx b/haxe/std/haxe/io/BytesData.hx deleted file mode 100644 index a7182208c8db70d2b6489f20194b85b9d679e10a..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/io/BytesData.hx +++ /dev/null @@ -1,38 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.io; - -#if neko - typedef BytesData = neko.NativeString; -#elseif flash9 - typedef BytesData = flash.utils.ByteArray; -#elseif php - typedef BytesData = php.NativeString; -#elseif cpp - extern class Unsigned_char__ { } - typedef BytesData = Array; -#else - typedef BytesData = Array; -#end diff --git a/haxe/std/haxe/io/Eof.hx b/haxe/std/haxe/io/Eof.hx deleted file mode 100644 index 56c72fd44e8eda42588ba2b2262caadd7c1d2bb2..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/io/Eof.hx +++ /dev/null @@ -1,36 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.io; - -/** - This exception is raised when reading while data is no longer available in the [Input]. -**/ -class Eof { - public function new() { - } - function toString() { - return "Eof"; - } -} diff --git a/haxe/std/haxe/io/Error.hx b/haxe/std/haxe/io/Error.hx deleted file mode 100644 index 8288e3852101196ea39695e69e770934a7265502..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/io/Error.hx +++ /dev/null @@ -1,39 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.io; - -/** - The possible IO errors that can occur -**/ -enum Error { - /** The IO is set into nonblocking mode and some data cannot be read or written **/ - Blocked; - /** An integer value is outside its allowed range **/ - Overflow; - /** An operation on Bytes is outside of its valid range **/ - OutsideBounds; - /** Other errors **/ - Custom( e : Dynamic ); -} diff --git a/haxe/std/haxe/io/Input.hx b/haxe/std/haxe/io/Input.hx deleted file mode 100644 index f849b9cc9c92b1ce6cf6434c0b80a9d704cfe7a6..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/io/Input.hx +++ /dev/null @@ -1,263 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.io; - -/** - An Input is an abstract reader. See other classes in the [haxe.io] package - for several possible implementations. -**/ -class Input { - - public var bigEndian(default,setEndian) : Bool; - - public function readByte() : Int { - #if cpp - throw "Not implemented"; - return 0; - #else - return throw "Not implemented"; - #end - } - - public function readBytes( s : Bytes, pos : Int, len : Int ) : Int { - var k = len; - var b = s.getData(); - if( pos < 0 || len < 0 || pos + len > s.length ) - throw Error.OutsideBounds; - while( k > 0 ) { - #if neko - untyped __dollar__sset(b,pos,readByte()); - #elseif php - b[pos] = untyped __call__("chr", readByte()); - #elseif cpp - b[pos] = untyped readByte(); - #else - b[pos] = readByte(); - #end - pos++; - k--; - } - return len; - } - - public function close() { - } - - function setEndian(b) { - bigEndian = b; - return b; - } - - /* ------------------ API ------------------ */ - - public function readAll( ?bufsize : Int ) : Bytes { - if( bufsize == null ) - #if php - bufsize = 8192; // default value for PHP and max under certain circumstances - #else - bufsize = (1 << 14); // 16 Ko - #end - var buf = Bytes.alloc(bufsize); - var total = new haxe.io.BytesBuffer(); - try { - while( true ) { - var len = readBytes(buf,0,bufsize); - if( len == 0 ) - throw Error.Blocked; - total.addBytes(buf,0,len); - } - } catch( e : Eof ) { - } - return total.getBytes(); - } - - public function readFullBytes( s : Bytes, pos : Int, len : Int ) { - while( len > 0 ) { - var k = readBytes(s,pos,len); - pos += k; - len -= k; - } - } - - public function read( nbytes : Int ) : Bytes { - var s = Bytes.alloc(nbytes); - var p = 0; - while( nbytes > 0 ) { - var k = readBytes(s,p,nbytes); - if( k == 0 ) throw Error.Blocked; - p += k; - nbytes -= k; - } - return s; - } - - public function readUntil( end : Int ) : String { - var buf = new StringBuf(); - var last : Int; - while( (last = readByte()) != end ) - buf.addChar( last ); - return buf.toString(); - } - - public function readLine() : String { - var buf = new StringBuf(); - var last : Int; - var s; - try { - while( (last = readByte()) != 10 ) - buf.addChar( last ); - s = buf.toString(); - if( s.charCodeAt(s.length-1) == 13 ) s = s.substr(0,-1); - } catch( e : Eof ) { - s = buf.toString(); - if( s.length == 0 ) - #if neko neko.Lib.rethrow #else throw #end (e); - } - return s; - } - - public function readFloat() : Float { - #if neko - return _float_of_bytes(untyped read(4).b,bigEndian); - #elseif cpp - return _float_of_bytes(read(4).getData(),bigEndian); - #elseif php - var a = untyped __call__('unpack', 'f', readString(4)); - return a[1]; - #else - throw "Not implemented"; - return 0; - #end - } - - public function readDouble() : Float { - #if neko - return _double_of_bytes(untyped read(8).b,bigEndian); - #elseif cpp - return _double_of_bytes(read(8).getData(),bigEndian); - #elseif php - var a = untyped __call__('unpack', 'd', readString(8)); - return a[1]; - #else - throw "Not implemented"; - return 0; - #end - } - - public function readInt8() { - var n = readByte(); - if( n >= 128 ) - return n - 256; - return n; - } - - public function readInt16() { - var ch1 = readByte(); - var ch2 = readByte(); - var n = bigEndian ? ch2 | (ch1 << 8) : ch1 | (ch2 << 8); - if( n & 0x8000 != 0 ) - return n - 0x10000; - return n; - } - - public function readUInt16() { - var ch1 = readByte(); - var ch2 = readByte(); - return bigEndian ? ch2 | (ch1 << 8) : ch1 | (ch2 << 8); - } - - public function readInt24() { - var ch1 = readByte(); - var ch2 = readByte(); - var ch3 = readByte(); - var n = bigEndian ? ch3 | (ch2 << 8) | (ch1 << 16) : ch1 | (ch2 << 8) | (ch3 << 16); - if( n & 0x800000 != 0 ) - return n - 0x1000000; - return n; - } - - public function readUInt24() { - var ch1 = readByte(); - var ch2 = readByte(); - var ch3 = readByte(); - return bigEndian ? ch3 | (ch2 << 8) | (ch1 << 16) : ch1 | (ch2 << 8) | (ch3 << 16); - } - - public function readInt31() { - var ch1,ch2,ch3,ch4; - if( bigEndian ) { - ch4 = readByte(); - ch3 = readByte(); - ch2 = readByte(); - ch1 = readByte(); - } else { - ch1 = readByte(); - ch2 = readByte(); - ch3 = readByte(); - ch4 = readByte(); - } - if( ((ch4 & 128) == 0) != ((ch4 & 64) == 0) ) throw Error.Overflow; - return ch1 | (ch2 << 8) | (ch3 << 16) | (ch4 << 24); - } - - public function readUInt30() { - var ch1 = readByte(); - var ch2 = readByte(); - var ch3 = readByte(); - var ch4 = readByte(); - if( (bigEndian?ch1:ch4) >= 64 ) throw Error.Overflow; - return bigEndian ? ch4 | (ch3 << 8) | (ch2 << 16) | (ch1 << 24) : ch1 | (ch2 << 8) | (ch3 << 16) | (ch4 << 24); - } - - public function readInt32() { - var ch1 = readByte(); - var ch2 = readByte(); - var ch3 = readByte(); - var ch4 = readByte(); - return bigEndian ? haxe.Int32.make((ch1 << 8) | ch2,(ch3 << 8) | ch4) : haxe.Int32.make((ch4 << 8) | ch3,(ch2 << 8) | ch1); - } - - public function readString( len : Int ) : String { - var b = Bytes.alloc(len); - readFullBytes(b,0,len); - #if neko - return neko.Lib.stringReference(b); - #else - return b.toString(); - #end - } - -#if neko - static var _float_of_bytes = neko.Lib.load("std","float_of_bytes",2); - static var _double_of_bytes = neko.Lib.load("std","double_of_bytes",2); - static function __init__() untyped { - Input.prototype.bigEndian = false; - } -#elseif cpp - static var _float_of_bytes = cpp.Lib.load("std","float_of_bytes",2); - static var _double_of_bytes = cpp.Lib.load("std","double_of_bytes",2); -#end - -} diff --git a/haxe/std/haxe/io/Output.hx b/haxe/std/haxe/io/Output.hx deleted file mode 100644 index b7ed595d8d1cb59521737b301498f05c86df3c72..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/io/Output.hx +++ /dev/null @@ -1,257 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.io; - -/** - An Output is an abstract write. A specific output implementation will only - have to override the [writeChar] and maybe the [write], [flush] and [close] - methods. See [File.write] and [String.write] for two ways of creating an - Output. -**/ -class Output { - - public var bigEndian(default,setEndian) : Bool; - - public function writeByte( c : Int ) : Void { - throw "Not implemented"; - } - - public function writeBytes( s : Bytes, pos : Int, len : Int ) : Int { - var k = len; - var b = s.getData(); - #if !neko - if( pos < 0 || len < 0 || pos + len > s.length ) - throw Error.OutsideBounds; - #end - while( k > 0 ) { - #if neko - writeByte(untyped __dollar__sget(b,pos)); - #elseif php - writeByte(untyped __call__("ord", b[pos])); - #elseif cpp - writeByte(untyped b[pos]); - #else - writeByte(b[pos]); - #end - pos++; - k--; - } - return len; - } - - public function flush() { - } - - public function close() { - } - - function setEndian( b ) { - bigEndian = b; - return b; - } - - /* ------------------ API ------------------ */ - - public function write( s : Bytes ) : Void { - var l = s.length; - var p = 0; - while( l > 0 ) { - var k = writeBytes(s,p,l); - if( k == 0 ) throw Error.Blocked; - p += k; - l -= k; - } - } - - public function writeFullBytes( s : Bytes, pos : Int, len : Int ) { - while( len > 0 ) { - var k = writeBytes(s,pos,len); - pos += k; - len -= k; - } - } - - public function writeFloat( x : Float ) { - #if neko - write(untyped new Bytes(4,_float_bytes(x,bigEndian))); - #elseif cpp - write(Bytes.ofData(_float_bytes(x,bigEndian))); - #elseif php - write(untyped Bytes.ofString(__call__('pack', 'f', x))); - #else - throw "Not implemented"; - #end - } - - public function writeDouble( x : Float ) { - #if neko - write(untyped new Bytes(8,_double_bytes(x,bigEndian))); - #elseif cpp - write(Bytes.ofData(_double_bytes(x,bigEndian))); - #elseif php - write(untyped Bytes.ofString(__call__('pack', 'd', x))); - #else - throw "Not implemented"; - #end - } - - public function writeInt8( x : Int ) { - if( x < -0x80 || x >= 0x80 ) - throw Error.Overflow; - writeByte(x & 0xFF); - } - - public function writeInt16( x : Int ) { - if( x < -0x8000 || x >= 0x8000 ) throw Error.Overflow; - writeUInt16(x & 0xFFFF); - } - - public function writeUInt16( x : Int ) { - if( x < 0 || x >= 0x10000 ) throw Error.Overflow; - if( bigEndian ) { - writeByte(x >> 8); - writeByte(x & 0xFF); - } else { - writeByte(x & 0xFF); - writeByte(x >> 8); - } - } - - public function writeInt24( x : Int ) { - if( x < -0x800000 || x >= 0x800000 ) throw Error.Overflow; - writeUInt24(x & 0xFFFFFF); - } - - public function writeUInt24( x : Int ) { - if( x < 0 || x >= 0x1000000 ) throw Error.Overflow; - if( bigEndian ) { - writeByte(x >> 16); - writeByte((x >> 8) & 0xFF); - writeByte(x & 0xFF); - } else { - writeByte(x & 0xFF); - writeByte((x >> 8) & 0xFF); - writeByte(x >> 16); - } - } - - public function writeInt31( x : Int ) { - #if !neko - if( x < -0x40000000 || x >= 0x40000000 ) throw Error.Overflow; - #end - if( bigEndian ) { - writeByte(x >>> 24); - writeByte((x >> 16) & 0xFF); - writeByte((x >> 8) & 0xFF); - writeByte(x & 0xFF); - } else { - writeByte(x & 0xFF); - writeByte((x >> 8) & 0xFF); - writeByte((x >> 16) & 0xFF); - writeByte(x >>> 24); - } - } - - public function writeUInt30( x : Int ) { - if( x < 0 #if !neko || x >= 0x40000000 #end ) throw Error.Overflow; - if( bigEndian ) { - writeByte(x >>> 24); - writeByte((x >> 16) & 0xFF); - writeByte((x >> 8) & 0xFF); - writeByte(x & 0xFF); - } else { - writeByte(x & 0xFF); - writeByte((x >> 8) & 0xFF); - writeByte((x >> 16) & 0xFF); - writeByte(x >>> 24); - } - } - - public function writeInt32( x : haxe.Int32 ) { - if( bigEndian ) { - writeByte( haxe.Int32.toInt(haxe.Int32.ushr(x,24)) ); - writeByte( haxe.Int32.toInt(haxe.Int32.ushr(x,16)) & 0xFF ); - writeByte( haxe.Int32.toInt(haxe.Int32.ushr(x,8)) & 0xFF ); - writeByte( haxe.Int32.toInt(haxe.Int32.and(x,haxe.Int32.ofInt(0xFF))) ); - } else { - writeByte( haxe.Int32.toInt(haxe.Int32.and(x,haxe.Int32.ofInt(0xFF))) ); - writeByte( haxe.Int32.toInt(haxe.Int32.ushr(x,8)) & 0xFF ); - writeByte( haxe.Int32.toInt(haxe.Int32.ushr(x,16)) & 0xFF ); - writeByte( haxe.Int32.toInt(haxe.Int32.ushr(x,24)) ); - } - } - - /** - Inform that we are about to write at least a specified number of bytes. - The underlying implementation can allocate proper working space depending - on this information, or simply ignore it. This is not a mandatory call - but a tip and is only used in some specific cases. - **/ - public function prepare( nbytes : Int ) { - } - - public function writeInput( i : Input, ?bufsize : Int ) { - if( bufsize == null ) - bufsize = 4096; - var buf = Bytes.alloc(bufsize); - try { - while( true ) { - var len = i.readBytes(buf,0,bufsize); - if( len == 0 ) - throw Error.Blocked; - var p = 0; - while( len > 0 ) { - var k = writeBytes(buf,p,len); - if( k == 0 ) - throw Error.Blocked; - p += k; - len -= k; - } - } - } catch( e : Eof ) { - } - } - - public function writeString( s : String ) { - #if neko - var b = untyped new Bytes(s.length,s.__s); - #else - var b = Bytes.ofString(s); - #end - writeFullBytes(b,0,b.length); - } - -#if neko - static var _float_bytes = neko.Lib.load("std","float_bytes",2); - static var _double_bytes = neko.Lib.load("std","double_bytes",2); - static function __init__() untyped { - Output.prototype.bigEndian = false; - } -#elseif cpp - static var _float_bytes = cpp.Lib.load("std","float_bytes",2); - static var _double_bytes = cpp.Lib.load("std","double_bytes",2); -#end - -} diff --git a/haxe/std/haxe/io/StringInput.hx b/haxe/std/haxe/io/StringInput.hx deleted file mode 100644 index 2739a9bc0b9a1d5d3593d76b3d8686e5f196b80c..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/io/StringInput.hx +++ /dev/null @@ -1,38 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.io; - -class StringInput extends BytesInput { - - public function new( s : String ) { - #if neko - // don't copy the string - super( neko.Lib.bytesReference(s) ); - #else - super( haxe.io.Bytes.ofString(s) ); - #end - } - -} \ No newline at end of file diff --git a/haxe/std/haxe/macro/Context.hx b/haxe/std/haxe/macro/Context.hx deleted file mode 100644 index e93e0da797c26382e8ca6377633c3a07e46e3fa3..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/macro/Context.hx +++ /dev/null @@ -1,167 +0,0 @@ -/* - * Copyright (c) 2005-2010, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.macro; -import haxe.macro.Expr; - -/** - This is an API that can be used by macros implementations. -**/ -class Context { - -#if neko - /** - Display a compilation error at the given position in code - **/ - public static function error( msg : String, pos : Position ) : Dynamic { - return load("error",2)(untyped msg.__s, pos); - } - - /** - Display a compilation warning at the given position in code - **/ - public static function warning( msg : String, pos : Position ) { - load("warning",2)(untyped msg.__s, pos); - } - - /** - Resolve a filename based on current classpath. - **/ - public static function resolvePath( file : String ) { - return new String(load("resolve",1)(untyped file.__s)); - } - - /** - Return the current classpath - **/ - public static function getClassPath() : Array { - var c : neko.NativeArray = load("class_path",0)(); - var a = new Array(); - for( i in 0...neko.NativeArray.length(c) ) - a.push(Std.string(c[i])); - return a; - } - - /** - Returns the position at which the macro is called - **/ - public static function currentPos() : Position { - return load("curpos", 0)(); - } - - /** - Returns the current class in which the macro is called - **/ - public static function getLocalClass() : Null> { - var l : Type = load("curclass", 0)(); - if( l == null ) return null; - return switch( l ) { - case TInst(c,_): c; - default: null; - } - } - - /** - Tells is the given compiler directive has been defined with -D - **/ - public static function defined( s : String ) : Bool { - return load("defined", 1)(untyped s.__s); - } - - /** - Resolve a type from its name. - **/ - public static function getType( name : String ) : Type { - return load("get_type", 1)(untyped name.__s); - } - - /** - Return the list of types defined in the given compilation unit module - **/ - public static function getModule( name : String ) : Array { - return load("get_module", 1)(untyped name.__s); - } - - /** - Parse an expression. - **/ - public static function parse( expr : String, pos : Position ) : Expr { - return load("parse", 2)(untyped expr.__s, pos); - } - - /** - Quickly build an hashed MD5 signature for any given value - **/ - public static function signature( v : Dynamic ) : String { - return new String(load("signature", 1)(v)); - } - - /** - Set a callback function that will return all the types compiled before they get generated. - **/ - public static function onGenerate( callb : Array -> Void ) { - load("on_generate",1)(callb); - } - - /** - Evaluate the type a given expression would have in the context of the current macro call. - **/ - public static function typeof( e : Expr ) : Type { - return load("typeof", 1)(e); - } - - /** - Get the informations stored into a given position. - **/ - public static function getPosInfos( p : Position ) : { min : Int, max : Int, file : String } { - var i = load("get_pos_infos",1)(p); - i.file = new String(i.file); - return i; - } - - /** - Build a position with the given informations. - **/ - public static function makePosition( inf : { min : Int, max : Int, file : String } ) : Position { - return load("make_pos",3)(inf.min,inf.max,untyped inf.file.__s); - } - - /** - Add or modify a resource that will be accessible with haxe.Resource api. - **/ - public static function addResource( name : String, data : haxe.io.Bytes ) { - return load("add_resource",2)(untyped name.__s,data.getData()); - } - - static function load( f, nargs ) : Dynamic { - #if macro - return neko.Lib.load("macro", f, nargs); - #else - return Reflect.makeVarArgs(function(_) throw "Can't be called outside of macro"); - #end - } - -#end - -} \ No newline at end of file diff --git a/haxe/std/haxe/macro/DefaultJSGenerator.hx b/haxe/std/haxe/macro/DefaultJSGenerator.hx deleted file mode 100644 index 9017181962d07e9d273de77ed0aa0a1eb80d0846..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/macro/DefaultJSGenerator.hx +++ /dev/null @@ -1,314 +0,0 @@ -/* - * Copyright (c) 2005-2010, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.macro; -import haxe.macro.Type; -import haxe.macro.Expr; -using Lambda; - -class DefaultJSGenerator { - - var api : JSGenApi; - var buf : StringBuf; - var inits : List; - var statics : List<{ c : ClassType, f : ClassField }>; - var packages : Hash; - var forbidden : Hash; - - public function new(api) { - this.api = api; - buf = new StringBuf(); - inits = new List(); - statics = new List(); - packages = new Hash(); - forbidden = new Hash(); - for( x in ["prototype", "__proto__", "constructor"] ) - forbidden.set(x, true); - api.setTypeAccessor(getType); - } - - function getType( t : Type ) { - return switch(t) { - case TInst(c, _): getPath(c.get()); - case TEnum(e, _): getPath(e.get()); - default: throw "assert"; - }; - } - - inline function print(str) { - buf.add(str); - } - - inline function newline() { - buf.add(";\n"); - } - - inline function genExpr(e) { - print(api.generateExpr(e)); - } - - @:macro static function fprint( e : Expr ) { - switch( e.expr ) { - case EConst(c): - switch( c ) { - case CString(str): - var exprs = []; - var r = ~/%((\([^\)]+\))|([A-Za-z_][A-Za-z0-9_]*))/; - var pos = e.pos; - var inf = Context.getPosInfos(pos); - inf.min++; // string quote - while( r.match(str) ) { - var left = r.matchedLeft(); - if( left.length > 0 ) { - exprs.push( { expr : EConst(CString(left)), pos : pos } ); - inf.min += left.length; - } - var v = r.matched(1); - if( v.charCodeAt(0) == "(".code ) { - var pos = Context.makePosition( { min : inf.min + 2, max : inf.min + v.length, file : inf.file } ); - exprs.push(Context.parse(v.substr(1, v.length-2), pos)); - } else { - var pos = Context.makePosition( { min : inf.min + 1, max : inf.min + 1 + v.length, file : inf.file } ); - exprs.push( { expr : EConst(CIdent(v)), pos : pos } ); - } - inf.min += v.length + 1; - str = r.matchedRight(); - } - exprs.push({ expr : EConst(CString(str)), pos : pos }); - var ret = null; - for( e in exprs ) - if( ret == null ) ret = e else ret = { expr : EBinop(OpAdd, ret, e), pos : pos }; - return { expr : ECall({ expr : EConst(CIdent("print")), pos : pos },[ret]), pos : pos }; - default: - } - default: - } - Context.error("Expression should be a constant string", e.pos); - return null; - } - - function field(p) { - return api.isKeyword(p) ? '["' + p + '"]' : "." + p; - } - - function genPackage( p : Array ) { - var full = null; - for( x in p ) { - var prev = full; - if( full == null ) full = x else full += "." + x; - if( packages.exists(full) ) - continue; - packages.set(full, true); - if( prev == null ) - fprint("if(typeof %x=='undefined') %x = {}"); - else { - var p = prev + field(x); - fprint("if(!%p) %p = {}"); - } - newline(); - } - } - - function getPath( t : BaseType ) { - return (t.pack.length == 0) ? t.name : t.pack.join(".") + "." + t.name; - } - - function checkFieldName( c : ClassType, f : ClassField ) { - if( forbidden.exists(f.name) ) - Context.error("The field " + f.name + " is not allowed in JS", c.pos); - } - - function genClassField( c : ClassType, p : String, f : ClassField ) { - checkFieldName(c, f); - var field = field(f.name); - fprint("%p.prototype%field = "); - if( f.expr == null ) - print("null"); - else { - api.setDebugInfos(c, f.name, false); - print(api.generateExpr(f.expr)); - } - newline(); - } - - function genStaticField( c : ClassType, p : String, f : ClassField ) { - checkFieldName(c, f); - var field = field(f.name); - if( f.expr == null ) { - fprint("%p%field = null"); - newline(); - } else switch( f.kind ) { - case FMethod(_): - fprint("%p%field = "); - api.setDebugInfos(c, f.name, true); - genExpr(f.expr); - newline(); - default: - statics.add( { c : c, f : f } ); - } - } - - function genClass( c : ClassType ) { - genPackage(c.pack); - var p = getPath(c); - fprint("%p = "); - api.setDebugInfos(c, "new", false); - if( c.constructor != null ) - print(api.generateConstructor(c.constructor.get().expr)); - else - print("function() { }"); - newline(); - var name = p.split(".").map(api.quoteString).join(","); - fprint("%p.__name__ = [%name]"); - newline(); - if( c.superClass != null ) { - var psup = getPath(c.superClass.t.get()); - fprint("%p.__super__ = %psup"); - newline(); - fprint("for(var k in %psup.prototype ) %p.prototype[k] = %psup.prototype[k]"); - newline(); - } - for( f in c.statics.get() ) - genStaticField(c, p, f); - for( f in c.fields.get() ) { - switch( f.kind ) { - case FVar(r, _): - if( r == AccResolve ) continue; - default: - } - genClassField(c, p, f); - } - fprint("%p.prototype.__class__ = %p"); - newline(); - if( c.interfaces.length > 0 ) { - var me = this; - var inter = c.interfaces.map(function(i) return me.getPath(i.t.get())).join(","); - fprint("%p.prototype = [%inter]"); - newline(); - } - } - - function genEnum( e : EnumType ) { - genPackage(e.pack); - var p = getPath(e); - var names = p.split(".").map(api.quoteString).join(","); - var constructs = e.names.map(api.quoteString).join(","); - fprint("%p = { __ename__ : [%names], __constructs__ : [%constructs] }"); - newline(); - for( c in e.contructs.keys() ) { - var c = e.contructs.get(c); - var f = field(c.name); - fprint("%p%f = "); - switch( c.type ) { - case TFun(args, _): - var sargs = args.map(function(a) return a.name).join(","); - fprint('function(%sargs) { var $x = ["%(c.name)",%(c.index),%sargs]; $x.__enum__ = %p; $x.toString = $estr; return $x; }'); - default: - print("[" + api.quoteString(c.name) + "," + c.index + "]"); - newline(); - fprint("%p%f.toString = $estr"); - newline(); - fprint("%p%f.__enum__ = %p"); - } - newline(); - } - var meta = api.buildMetaData(e); - if( meta != null ) { - fprint("%p.__meta__ = "); - genExpr(meta); - newline(); - } - } - - - function genStaticValue( c : ClassType, cf : ClassField ) { - var p = getPath(c); - var f = field(cf.name); - fprint("%p%f = "); - genExpr(cf.expr); - newline(); - } - - function genType( t : Type ) { - switch( t ) { - case TInst(c, _): - var c = c.get(); - if( c.init != null ) - inits.add(c.init); - if( !c.isExtern ) genClass(c); - case TEnum(r, _): - var e = r.get(); - if( !e.isExtern ) genEnum(e); - default: - } - } - - public function generate() { - print("$estr = function() { return js.Boot.__string_rec(this,''); }"); - newline(); - /* - (match ctx.namespace with - | None -> () - | Some ns -> - print ctx "if(typeof %s=='undefined') %s = {}" ns ns; - newline ctx); - */ - for( t in api.types ) - genType(t); - print("$_ = {}"); - newline(); - print("js.Boot.__res = {}"); - newline(); - if( Context.defined("debug") ) { - fprint("%(api.stackVar) = []"); - newline(); - fprint("%(api.excVar) = []"); - newline(); - } - print("js.Boot.__init()"); - newline(); - for( e in inits ) { - genExpr(e); - newline(); - } - for( s in statics ) { - genStaticValue(s.c,s.f); - newline(); - } - if( api.main != null ) { - genExpr(api.main); - newline(); - } - var file = neko.io.File.write(api.outputFile, true); - file.writeString(buf.toString()); - file.close(); - } - - #if macro - public static function use() { - Compiler.setCustomJSGenerator(function(api) new DefaultJSGenerator(api).generate()); - } - #end - -} \ No newline at end of file diff --git a/haxe/std/haxe/macro/Expr.hx b/haxe/std/haxe/macro/Expr.hx deleted file mode 100644 index 747a26c25089bbe5b88a8211fcc655846dd78d0e..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/macro/Expr.hx +++ /dev/null @@ -1,155 +0,0 @@ -/* - * Copyright (c) 2005-2010, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.macro; - -extern enum Position { -} - -enum Constant { - CInt( v : String ); - CFloat( f : String ); - CString( s : String ); - CIdent( s : String ); - CType( s : String ); - CRegexp( r : String, opt : String ); -} - -enum Binop { - OpAdd; - OpMult; - OpDiv; - OpSub; - OpAssign; - OpEq; - OpNotEq; - OpGt; - OpGte; - OpLt; - OpLte; - OpAnd; - OpOr; - OpXor; - OpBoolAnd; - OpBoolOr; - OpShl; - OpShr; - OpUShr; - OpMod; - OpAssignOp( op : Binop ); - OpInterval; -} - - -enum Unop { - OpIncrement; - OpIDecrement; - OpNot; - OpNeg; - OpNegBits; -} - -typedef Expr = { - var expr : ExprDef; - var pos : Position; -} - -enum ExprDef { - EConst( c : Constant ); - EArray( e1 : Expr, e2 : Expr ); - EBinop( op : Binop, e1 : Expr, e2 : Expr ); - EField( e : Expr, field : String ); - EType( e : Expr, field : String ); - EParenthesis( e : Expr ); - EObjectDecl( fields : Array<{ field : String, expr : Expr }> ); - EArrayDecl( values : Array ); - ECall( e : Expr, params : Array ); - ENew( t : TypePath, params : Array ); - EUnop( op : Unop, postFix : Bool, e : Expr ); - EVars( vars : Array<{ name : String, type : Null, expr : Null }> ); - EFunction( f : Function ); - EBlock( exprs : Array ); - EFor( v : String, it : Expr, expr : Expr ); - EIf( econd : Expr, eif : Expr, eelse : Null ); - EWhile( econd : Expr, e : Expr, normalWhile : Bool ); - ESwitch( e : Expr, cases : Array<{ values : Array, expr : Expr }>, edef : Null ); - ETry( e : Expr, catches : Array<{ name : String, type : ComplexType, expr : Expr }> ); - EReturn( e : Null ); - EBreak; - EContinue; - EUntyped( e : Expr ); - EThrow( e : Expr ); - ECast( e : Expr, t : Null ); - EDisplay( e : Expr, isCall : Bool ); - EDisplayNew( t : TypePath ); - ETernary( econd : Expr, eif : Expr, eelse : Expr ); -} - -enum ComplexType { - TPath( p : TypePath ); - TFunction( args : Array, ret : ComplexType ); - TAnonymous( fields : Array ); - TParent( t : ComplexType ); - TExtend( p : TypePath, fields : Array ); -} - -typedef TypePath = { - var pack : Array; - var name : String; - var params : Array; - var sub : Null; -} - -enum TypeParam { - TPType( t : ComplexType ); - TPConst( c : Constant ); -} - -typedef Function = { - var name : Null; - var args : Array; - var ret : Null; - var expr : Expr; -} - -typedef FunctionArg = { - var name : String; - var opt : Bool; - var type : Null; - var value : Null; -} - -typedef Field = { - var name : String; - var isPublic : Null; - var type : FieldType; - var pos : Position; -} - -enum FieldType { - FVar( t : ComplexType ); - FProp( t : ComplexType, get : String, set : String ); - FFun( args : Array<{ name : String, opt : Bool, type : ComplexType }>, ret : ComplexType ); -} - diff --git a/haxe/std/haxe/macro/JSGenApi.hx b/haxe/std/haxe/macro/JSGenApi.hx deleted file mode 100644 index 7a758ac5b806d44176d9a5a2fbacbacab5d5938f..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/macro/JSGenApi.hx +++ /dev/null @@ -1,56 +0,0 @@ -/* - * Copyright (c) 2005-2010, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.macro; -import haxe.macro.Type; - -/** - This is the api that is passed to the custom JS generator. -**/ -typedef JSGenApi = { - /** the file in which the JS code can be generated **/ - var outputFile : String; - /** all the types that were compiled by haXe **/ - var types : Array; - /** the main call expression, if a -main class is defined **/ - var main : Null; - /** the variable used to store the temporary stack in debug mode **/ - var stackVar(default,null) : String; - /** the variable used to store the temporary exception in debug mode **/ - var excVar(default,null) : String; - /** generate the JS code for a given typed expression **/ - function generateExpr( e : TypedExpr ) : String; - /** define the JS code that gets generated when a class or enum is accessed in a typed expression **/ - function setTypeAccessor( callb : Type -> String ) : Void; - /** tells if the given identifier is a JS keyword **/ - function isKeyword( ident : String ) : Bool; - /** quote and escape the given string constant **/ - function quoteString( s : String ) : String; - /** create the metadata expression for the given type **/ - function buildMetaData( t : BaseType ) : Null; - /** set the current class/method for debug stack management **/ - function setDebugInfos( c : ClassType, meth : String, isStatic : Bool ) : Void; - /** generate the JS code for a given class constructor **/ - function generateConstructor( e : TypedExpr ) : String; -} \ No newline at end of file diff --git a/haxe/std/haxe/macro/Type.hx b/haxe/std/haxe/macro/Type.hx deleted file mode 100644 index 5d47cdfe748d3a2fd8aca0539a9de74cfbb794db..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/macro/Type.hx +++ /dev/null @@ -1,126 +0,0 @@ -/* - * Copyright (c) 2005-2010, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.macro; - -typedef Ref = { - public function get() : T; - public function toString() : String; -} - -enum Type { - TMono; - TEnum( t : Ref, params : Array ); - TInst( t : Ref, params : Array ); - TType( t : Ref, params : Array ); - TFun( args : Array<{ name : String, opt : Bool, t : Type }>, ret : Type ); - TAnonymous( a : Ref ); - TDynamic( t : Null ); -} - -typedef AnonType = { - var fields : Array; - //var status : AnonStatus; -} - -typedef BaseType = { - var pack : Array; - var name : String; - var pos : Expr.Position; - var isPrivate : Bool; - var isExtern : Bool; - var params : Array<{ name : String, t : Type }>; - var meta : Metadata; - function exclude() : Void; -} - -typedef ClassField = { - var name : String; - var type : Type; - var isPublic : Bool; - var params : Array<{ name : String, t : Type }>; - var meta : Metadata; - var kind : FieldKind; - var expr : Null; -} - -typedef ClassType = {> BaseType, - //var kind : ClassKind; - var isInterface : Bool; - var superClass : Null<{ t : Ref, params : Array }>; - var interfaces : Array<{ t : Ref, params : Array }>; - var fields : Ref>; - var statics : Ref>; - //var dynamic : Null; - //var arrayAccess : Null; - var constructor : Null>; - var init : Null; -} - -typedef EnumField = { - var name : String; - var type : Type; - var pos : Expr.Position; - var meta : Metadata; - var index : Int; -} - -typedef EnumType = {> BaseType, - var contructs : Hash; - var names : Array; -} - -typedef DefType = {> BaseType, - var type : Type; -} - -typedef Metadata = { - function get() : Array<{ name : String, params : Array, pos : Expr.Position }>; - function add( name : String, params : Array, pos : Expr.Position ) : Void; - function remove( name : String ) : Void; -} - -enum FieldKind { - FVar( read : VarAccess, write : VarAccess ); - FMethod( k : MethodKind ); -} - -enum VarAccess { - AccNormal; - AccNo; - AccNever; - AccResolve; - AccCall( m : String ); - AccInline; - AccRequire( r : String ); -} - -enum MethodKind { - MethNormal; - MethInline; - MethDynamic; - MethMacro; -} - -extern enum TypedExpr {} diff --git a/haxe/std/haxe/remoting/AsyncAdapter.hx b/haxe/std/haxe/remoting/AsyncAdapter.hx deleted file mode 100644 index 5f0db25c9b2ca9cbd3b337036beaf85eb0a1cf6e..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/AsyncAdapter.hx +++ /dev/null @@ -1,63 +0,0 @@ -/* - * Copyright (c) 2005-2007, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -/** - Build an AsyncConnection from a synchronized Connection. -**/ -class AsyncAdapter implements AsyncConnection { - - var __cnx : Connection; - var __error : { ref : Dynamic -> Void }; - - function new(cnx,error) { - __cnx = cnx; - __error = error; - } - - public function resolve( name ) : AsyncConnection { - return new AsyncAdapter(__cnx.resolve(name),__error); - } - - public function setErrorHandler(h) { - __error.ref = h; - } - - public function call( params : Array, ?onResult : Dynamic -> Void ) { - var ret; - try { - ret = __cnx.call(params); - } catch( e : Dynamic ) { - __error.ref(e); - return; - } - if( onResult != null ) onResult(ret); - } - - public static function create( cnx : Connection ) : AsyncConnection { - return new AsyncAdapter(cnx,{ ref : function(e) throw e }); - } - -} diff --git a/haxe/std/haxe/remoting/AsyncConnection.hx b/haxe/std/haxe/remoting/AsyncConnection.hx deleted file mode 100644 index e8088719c77266f998a549542ddccf6991f47773..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/AsyncConnection.hx +++ /dev/null @@ -1,33 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -interface AsyncConnection implements Dynamic { - - function resolve( name : String ) : AsyncConnection; - function call( params : Array, ?result : Dynamic -> Void ) : Void; - function setErrorHandler( error : Dynamic -> Void ) : Void; - -} diff --git a/haxe/std/haxe/remoting/AsyncProxy.hx b/haxe/std/haxe/remoting/AsyncProxy.hx deleted file mode 100644 index d5db1d3d2e0e6129e8f9fed18b6347871d737edf..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/AsyncProxy.hx +++ /dev/null @@ -1,40 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -/** - This class is magic. When you extend it with a class C, it will automaticaly - create a stub class with all public methods forwarding remoting messages over - the connection. -**/ -class AsyncProxy { - - var __cnx : AsyncConnection; - - function new( c ) { - __cnx = c; - } - -} \ No newline at end of file diff --git a/haxe/std/haxe/remoting/Connection.hx b/haxe/std/haxe/remoting/Connection.hx deleted file mode 100644 index ea85bc826f87345277886e02118010172cef52fa..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/Connection.hx +++ /dev/null @@ -1,32 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -interface Connection implements Dynamic { - - function resolve( name : String ) : Connection; - function call( params : Array ) : Dynamic; - -} diff --git a/haxe/std/haxe/remoting/Context.hx b/haxe/std/haxe/remoting/Context.hx deleted file mode 100644 index f7f8e7f0f67f68581e551fefc7e97dff779bfb58..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/Context.hx +++ /dev/null @@ -1,64 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -class Context { - - var objects : Hash<{ obj : Dynamic, rec : Bool }>; - - public function new() { - objects = new Hash(); - } - - public function addObject( name : String, obj : {}, ?recursive ) { - objects.set(name,{ obj : obj, rec : recursive }); - } - - public function call( path : Array, params : Array ) : Dynamic { - if( path.length < 2 ) throw "Invalid path '"+path.join(".")+"'"; - var inf = objects.get(path[0]); - if( inf == null ) - throw "No such object "+path[0]; - var o = inf.obj; - var m = Reflect.field(o,path[1]); - if( path.length > 2 ) { - if( !inf.rec ) throw "Can't access "+path.join("."); - for( i in 2...path.length ) { - o = m; - m = Reflect.field(o,path[i]); - } - } - if( !Reflect.isFunction(m) ) - throw "No such method "+path.join("."); - return Reflect.callMethod(o,m,params); - } - - public static function share( name : String, obj : {} ) : Context { - var ctx = new Context(); - ctx.addObject(name,obj); - return ctx; - } - -} \ No newline at end of file diff --git a/haxe/std/haxe/remoting/ContextAll.hx b/haxe/std/haxe/remoting/ContextAll.hx deleted file mode 100644 index b3c462027cb9b3f723022dd8ae7f0373957ea498..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/ContextAll.hx +++ /dev/null @@ -1,66 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -class ContextAll extends Context { - - public override function call( path : Array, params : Array ) : Dynamic { - #if neko - var o : Dynamic = null; - var m : Dynamic = neko.Lib.getClasses(); - for( p in path ) { - o = m; - m = Reflect.field(o,p); - } - #elseif js - var path2 = path.copy(); - var f = path2.pop(); - var o; - try { - o = js.Lib.eval(path2.join(".")); - } catch( e : Dynamic ) { - o = null; - } - var m = Reflect.field(o,f); - #elseif flash - var path2 = path.copy(); - var f = path2.pop(); - var o = flash.Lib.eval(path2.join(".")); - var m = Reflect.field(o,f); - #elseif php - var path2 = path.copy(); - var f = path2.pop(); - var o = Type.resolveClass(path2.join(".")); - var m = Reflect.field(o,f); - #else - var o = null; - var m = null; - #end - if( m == null ) - return super.call(path,params); - return Reflect.callMethod(o,m,params); - } - -} \ No newline at end of file diff --git a/haxe/std/haxe/remoting/DelayedConnection.hx b/haxe/std/haxe/remoting/DelayedConnection.hx deleted file mode 100644 index 6ecf996b4460af250f321046b80bb969e5da0595..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/DelayedConnection.hx +++ /dev/null @@ -1,93 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -class DelayedConnection implements AsyncConnection, implements Dynamic { - - public var connection(getConnection,setConnection) : AsyncConnection; - - var __path : Array; - var __data : { - cnx : AsyncConnection, - error : Dynamic -> Void, - cache : Array<{ - path : Array, - params : Array, - onResult : Dynamic -> Void, - onError : Dynamic -> Void - }>, - }; - - function new(data,path) { - __data = data; - __path = path; - } - - public function setErrorHandler(h) { - __data.error = h; - } - - public function resolve( name ) : AsyncConnection { - var d = new DelayedConnection(__data,__path.copy()); - d.__path.push(name); - return d; - } - - function getConnection() { - return __data.cnx; - } - - function setConnection(cnx) { - __data.cnx = cnx; - process(this); - return cnx; - } - - public function call( params : Array, ?onResult ) { - __data.cache.push({ path : __path, params : params, onResult : onResult, onError : __data.error }); - process(this); - } - - static function process( d : DelayedConnection ) { - var cnx = d.__data.cnx; - if( cnx == null ) - return; - while( true ) { - var m = d.__data.cache.shift(); - if( m == null ) - break; - var c = cnx; - for( p in m.path ) - c = c.resolve(p); - c.setErrorHandler(m.onError); - c.call(m.params,m.onResult); - } - } - - public static function create() { - return new DelayedConnection({ cnx : null, error : function(e) throw e, cache : new Array() },[]); - } - -} diff --git a/haxe/std/haxe/remoting/HttpAsyncConnection.hx b/haxe/std/haxe/remoting/HttpAsyncConnection.hx deleted file mode 100644 index bb7ff3147105c6fa63eb97dde95ca39558222446..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/HttpAsyncConnection.hx +++ /dev/null @@ -1,80 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -class HttpAsyncConnection implements AsyncConnection, implements Dynamic { - - var __data : { url : String, error : Dynamic -> Void }; - var __path : Array; - - function new(data,path) { - __data = data; - __path = path; - } - - public function resolve( name ) : AsyncConnection { - var c = new HttpAsyncConnection(__data,__path.copy()); - c.__path.push(name); - return c; - } - - public function setErrorHandler(h) { - __data.error = h; - } - - public function call( params : Array, ?onResult : Dynamic -> Void ) { - var h = new haxe.Http(__data.url); - #if (neko && no_remoting_shutdown) - h.noShutdown = true; - #end - var s = new haxe.Serializer(); - s.serialize(__path); - s.serialize(params); - h.setHeader("X-Haxe-Remoting","1"); - h.setParameter("__x",s.toString()); - var error = __data.error; - h.onData = function( response : String ) { - var ok = true; - var ret; - try { - if( response.substr(0,3) != "hxr" ) throw "Invalid response : '"+response+"'"; - var s = new haxe.Unserializer(response.substr(3)); - ret = s.unserialize(); - } catch( err : Dynamic ) { - ret = null; - ok = false; - error(err); - } - if( ok && onResult != null ) onResult(ret); - }; - h.onError = error; - h.request(true); - } - - public static function urlConnect( url : String ) { - return new HttpAsyncConnection({ url : url, error : function(e) throw e },[]); - } - -} diff --git a/haxe/std/haxe/remoting/Proxy.hx b/haxe/std/haxe/remoting/Proxy.hx deleted file mode 100644 index a22baec2e7eb15b4793c44342fedead37fa6c2d0..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/Proxy.hx +++ /dev/null @@ -1,40 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; - -/** - This class is magic. When you extend it with a class C, it will automaticaly - create a stub class with all public methods forwarding remoting messages over - the connection. -**/ -class Proxy { - - var __cnx : Connection; - - function new( c ) { - __cnx = c; - } - -} \ No newline at end of file diff --git a/haxe/std/haxe/remoting/SocketWrapper.hx b/haxe/std/haxe/remoting/SocketWrapper.hx deleted file mode 100644 index 019443b1cef70bf7ce3f549bad1573f2ad1b7cf7..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/SocketWrapper.hx +++ /dev/null @@ -1,87 +0,0 @@ -/* - * Copyright (c) 2005-2007, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; -import haxe.remoting.SocketProtocol.Socket; - -/** - See [js.XMLSocket] -**/ -class SocketWrapper { - - static var ID = 0; - - static function create( prefix : String ) : String { - var id = prefix + "WrappedSocket"+(ID++); - var s = new Socket(); - var ctx = new Context(); - var cnx = haxe.remoting.ExternalConnection.jsConnect(id,ctx); - ctx.addObject("sock",s); - var o = {}; - Reflect.setField(o,"close",cnx.close); - ctx.addObject("api",o); - #if flash9 - var connected = false; - s.addEventListener(flash.events.Event.CONNECT,function(_) { - connected = true; - cnx.api.onConnect.call([true]); - }); - s.addEventListener(flash.events.SecurityErrorEvent.SECURITY_ERROR,function(_) { - if( connected ) - cnx.api.onClose.call([]); - else - cnx.api.onConnect.call([false]); - }); - s.addEventListener(flash.events.Event.CLOSE,function(_) { - cnx.api.onClose.call([]); - }); - s.addEventListener(flash.events.DataEvent.DATA,function(e:flash.events.DataEvent) { - cnx.api.onData.call([e.data]); - }); - #elseif flash - s.onConnect = function(b) { - cnx.api.onConnect.call([b]); - }; - s.onData = function(data) { - cnx.api.onData.call([data]); - }; - s.onClose = function() { - cnx.api.onClose.call([]); - }; - #end - return id; - } - - static function init() { - if( !flash.external.ExternalInterface.available ) return; - var ctx = new Context(); - var o = {}; - Reflect.setField(o,"create",create); - ctx.addObject("api",o); - haxe.remoting.ExternalConnection.jsConnect("SocketWrapper",ctx); - } - - static var _ = init(); - -} diff --git a/haxe/std/haxe/remoting/SyncSocketConnection.hx b/haxe/std/haxe/remoting/SyncSocketConnection.hx deleted file mode 100644 index 1ec3bc528c15f7054667684c8e0ba18579aecf7d..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/remoting/SyncSocketConnection.hx +++ /dev/null @@ -1,86 +0,0 @@ -/* - * Copyright (c) 2005-2007, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.remoting; -import haxe.remoting.SocketProtocol.Socket; - -class SyncSocketConnection implements Connection, implements Dynamic { - - var __path : Array; - var __proto : SocketProtocol; - - function new(proto,path) { - __proto = proto; - __path = path; - } - - public function resolve( name ) : Connection { - var s = new SyncSocketConnection(__proto,__path.copy()); - s.__path.push(name); - return s; - } - - public function call( params : Array ) : Dynamic { - var proto = __proto; - proto.sendRequest(__path,params); - while( true ) { - var data = proto.readMessage(); - if( proto.isRequest(data) ) { - if( proto.context == null ) - throw "Request received"; - proto.processRequest(data,onRequestError); - continue; - } - return proto.processAnswer(data); - } - return null; // never reached - } - - public function processRequest() { - if( __proto.context == null ) - throw "Can't process request"; - var data = __proto.readMessage(); - __proto.processRequest(data,onRequestError); - } - - public function onRequestError( path : Array, args : Array, exc : Dynamic ) { - } - - public function setProtocol( p : SocketProtocol ) { - __proto = p; - } - - public function getProtocol() : SocketProtocol { - return __proto; - } - - public function close() { - try __proto.socket.close() catch( e : Dynamic ) { }; - } - - public static function create( s : Socket, ?ctx : Context ) { - return new SyncSocketConnection(new SocketProtocol(s,ctx),[]); - } - -} diff --git a/haxe/std/haxe/rtti/Generic.hx b/haxe/std/haxe/rtti/Generic.hx deleted file mode 100644 index 8c4fbc2b9528e7f4a3b4059f89442f80faf3e468..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/rtti/Generic.hx +++ /dev/null @@ -1,33 +0,0 @@ -/* - * Copyright (c) 2006-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.rtti; - -/** - You can implement this interface with a parametrized type. For each type - parameter used, a duplicate class with be created. This is useful on - platforms that supports runtime typing (such as flash9). -**/ -interface Generic { -} diff --git a/haxe/std/haxe/rtti/HtmlEditor.hx b/haxe/std/haxe/rtti/HtmlEditor.hx deleted file mode 100644 index 687d53ee7edd831827ee620a9484a60df19c816e..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/rtti/HtmlEditor.hx +++ /dev/null @@ -1,339 +0,0 @@ -/* - * Copyright (c) 2006-2009, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.rtti; -import haxe.rtti.CType; - -class HtmlEditor { - - static var UID = 0; - - var id : String; - var types : Hash; - var buf : StringBuf; - var nfields : Int; - - public function new() { - types = new Hash(); - } - - public function add( tl : TypeRoot ) { - for( t in tl ) - switch(t) { - case TPackage(_,_,subs): - add(subs); - case TClassdecl(c): - types.set(c.path,t); - case TEnumdecl(e): - types.set(e.path,t); - case TTypedecl(td): - types.set(td.path,t); - } - } - - public function buildHTML( id : String, v : Dynamic, t : CType ) { - this.id = id; - nfields = 0; - buf = new StringBuf(); - buildHTMLRec(v,t,false); - var str = buf.toString(); - buf = null; - return str; - } - - function open(t) { - buf.add("<"+t); - } - - function close(?t) { - buf.add(( t == null ) ? "/>" : ""); - } - - function genUID() { - return "__u"+id+"_"+(UID++); - } - - function genFieldName() { - return "__f"+id+"_"+(nfields++); - } - - function skipField() { - nfields++; - } - - function attrib(name,value) { - buf.add(" "+name+'="'+value+'"'); - } - - function followTypeDef( name, params : List ) { - var td = types.get(name); - if( td == null ) throw "Missing type "+name; - if( !params.isEmpty() ) throw "Can't apply parameters"; - return switch( td ) { - case TTypedecl(t): t.type; - default: throw "assert"; - }; - } - - function getEnum( name ) { - var td = types.get(name); - if( td == null ) throw "Missing type "+name; - return switch( td ) { case TEnumdecl(e): e; default: throw "assert"; }; - } - - function buildNullField( checked ) { - open("input"); - attrib("name",genFieldName()); - attrib("class","null"); - attrib("type","checkbox"); - if( checked ) - attrib("checked","checked"); - close(); - } - - function buildHTMLRec( v : Dynamic, t : CType, nullable ) { - switch( t ) { - case CUnknown,CDynamic(_),CFunction(_,_): - buf.add("???"); - case CTypedef(name,params): - var t = followTypeDef(name,params); - buildHTMLRec(v,t,nullable || name == "Null"); - case CAnonymous(fl): - open("table"); - attrib("class","anon"); - buf.add(">"); - for( f in fl ) { - buf.add(""); - buf.add(f.name); - buf.add(""); - buildHTMLRec(Reflect.field(v,f.name),f.t,false); - buf.add(""); - } - close("table"); - case CClass(name,params): - if( !params.isEmpty() ) throw "Can't use type parameters"; - switch( name ) { - case "Int": - open("input"); - attrib("name",genFieldName()); - attrib("class","int"); - if( v != null ) - attrib("value",v); - close(); - case "String": - if( nullable ) - buildNullField(v != null); - open("input"); - attrib("name",genFieldName()); - attrib("class","string"); - if( v != null ) - attrib("value",v); - close(); - case "Bool": - if( nullable ) - buildNullField(v != null); - open("input"); - attrib("name",genFieldName()); - attrib("type","checkbox"); - if( v ) - attrib("checked","checked"); - close(); - default: - throw "Can't edit instances of "+name; - } - case CEnum(name,params): - if( name == "Bool" ) { - buildHTMLRec(v,CClass("Bool",params),nullable); - return; - } - if( !params.isEmpty() ) throw "Can't use type parameters"; - var e = getEnum(name); - var js = genUID(); - open("select"); - attrib("name",genFieldName()); - attrib("class","enum"); - attrib("onchange",js+"(this)"); - buf.add(">"); - var current = if( v == null ) null else Type.enumConstructor(v); - if( nullable ) - buf.add(""); - var prefix = if( e.constructors.length <= 1 ) "" else e.constructors.first().name; - for( c in e.constructors ) - while( prefix.length > 0 ) - if( c.name.substr(0,prefix.length) == prefix ) - break; - else - prefix = prefix.substr(0,prefix.length-1); - for( c in e.constructors ) { - open("option"); - attrib("value",c.name); - if( current == c.name ) - attrib("selected","selected"); - buf.add(">"); - buf.add(c.name.substr(prefix.length)); - close("option"); - } - close("select"); - var ids = new Array(); - for( c in e.constructors ) { - var id = genUID(); - ids.push({ id : id, c : c }); - open("table"); - attrib("id",id); - attrib("class","construct"); - if( current != c.name ) - attrib("style","display : none"); - buf.add(">"); - if( c.args != null ) { - var args = if( current == c.name ) Type.enumParameters(v) else new Array(); - var i = 0; - for( p in c.args ) { - buf.add(""); - buf.add(p.name); - buf.add(""); - buildHTMLRec(args[i++],p.t,p.opt); - buf.add(""); - } - } - close("table"); - } - open("script"); - attrib("type","text/javascript"); - buf.add(">"); - buf.add("function "+js+"(s) {"); - for( c in ids ) - buf.add("document.getElementById('"+c.id+"').style.display = (s.value == '"+c.c.name+"')?'':'none';"); - buf.add("}"); - close("script"); - } - } - - public function buildObject( id : String, params : Hash, t : CType ) : Dynamic { - this.id = id; - nfields = 0; - return buildObjectRec(params,t,false); - } - - function buildObjectRec( params : Hash, t : CType, nullable : Bool ) : Dynamic { - return switch( t ) { - case CUnknown,CDynamic(_),CFunction(_,_): - throw Type.enumConstructor(t)+" can't be built"; - case CTypedef(name,pl): - buildObjectRec(params,followTypeDef(name,pl),nullable || name == "Null"); - case CAnonymous(fl): - var o = {}; - for( f in fl ) - Reflect.setField(o,f.name,buildObjectRec(params,f.t,false)); - o; - case CClass(name,_): - var v = params.get(genFieldName()); - var ret : Dynamic; - switch( name ) { - case "Int": - if( v == null || (v == "" && !nullable) ) - throw "Missing required value"; - if( !~/^[0-9]+$/.match(v) ) - throw "Invalid int format '"+v+"'"; - ret = ( v == "" ) ? null : Std.parseInt(v); - case "String": - if( nullable ) { - var str = params.get(genFieldName()); - ret = if( v == null && str == "" ) null else str; - } else { - if( v == null ) - throw "Missing required value"; - ret = v; - } - case "Bool": - if( nullable ) { - var b = params.exists(genFieldName()); - ret = if( v == null && !b ) null else b; - } else - ret = (v != null); - default: - throw name+" can't be built"; - } - ret; - case CEnum(name,_): - if( name == "Bool" ) - buildObjectRec(params,CClass("Bool",new List()),nullable); - else { - var e = getEnum(name); - var v = genFieldName(); - var current = params.get(v); - var value = null; - for( c in e.constructors ) { - if( c.name == current ) { - var args = null; - if( c.args != null ) { - args = new Array(); - for( a in c.args ) - args.push(buildObjectRec(params,a.t,a.opt)); - } - value = Type.createEnum(Type.resolveEnum(name),current,args); - } else if( c.args != null ) { - for( a in c.args ) - skipObjectRec(a.t,a.opt); - } - } - if( value == null && !nullable ) - throw name+" can't be null"; - value; - } - }; - } - - function skipObjectRec( t : CType, nullable ) { - switch( t ) { - case CUnknown,CDynamic(_),CFunction(_,_): - // nothing - case CTypedef(name,pl): - skipObjectRec(followTypeDef(name,pl),nullable || name == "Null"); - case CAnonymous(fl): - for( f in fl ) - skipObjectRec(f.t,false); - case CEnum(name,_): - if( name == "Bool" ) { - skipObjectRec(CClass("Bool",new List()),nullable); - return; - } - var e = getEnum(name); - skipField(); - for( c in e.constructors ) { - if( c.args == null ) continue; - for( a in c.args ) - skipObjectRec(a.t,a.opt); - } - case CClass(name,_): - switch( name ) { - case "Int": skipField(); - case "String", "Bool": - if( nullable ) skipField(); - skipField(); - default: - } - } - } - -} diff --git a/haxe/std/haxe/rtti/Infos.hx b/haxe/std/haxe/rtti/Infos.hx deleted file mode 100644 index d7e3977da736c88047c5eba5ba09be3df3de42db..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/rtti/Infos.hx +++ /dev/null @@ -1,32 +0,0 @@ -/* - * Copyright (c) 2006, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.rtti; - -/** - This is a magic interface. When a class implements [haxe.rtti.Infos], this class and all its - subclass will get an additional static field [__rtti] storing the class type informations. -**/ -interface Infos { -} diff --git a/haxe/std/haxe/rtti/Meta.hx b/haxe/std/haxe/rtti/Meta.hx deleted file mode 100644 index a4957db7c378aabbcee97745cb211b25e59b0099..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/rtti/Meta.hx +++ /dev/null @@ -1,56 +0,0 @@ -/* - * Copyright (c) 2005-2009, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.rtti; - -/** - An api to access classes and enums metadata at runtime. -**/ -class Meta { - - /** - Returns the metadata that were declared for the given type (class or enum) - **/ - public static function getType( t : Dynamic ) : Dynamic> { - var meta : Dynamic = untyped t.__meta__; - return (meta == null) ? meta : meta.obj; - } - - /** - Returns the metadata that were declared for the given class fields or enum constructors - **/ - public static function getStatics( t : Dynamic ) : Dynamic>> { - var meta : Dynamic = untyped t.__meta__; - return (meta == null) ? meta : meta.statics; - } - - /** - Returns the metadata that were declared for the given class static fields - **/ - public static function getFields( t : Dynamic ) : Dynamic>> { - var meta : Dynamic = untyped t.__meta__; - return (meta == null) ? meta : meta.fields; - } - -} \ No newline at end of file diff --git a/haxe/std/haxe/unit/TestCase.hx b/haxe/std/haxe/unit/TestCase.hx deleted file mode 100644 index 3368e5416846ffbb48c0b56b34e17f7542c2947f..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/unit/TestCase.hx +++ /dev/null @@ -1,74 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.unit; -import haxe.PosInfos; - -class TestCase #if mt_build implements mt.Protect, #end implements haxe.Public { - public var currentTest : TestStatus; - - public function new( ) { - } - - public function setup() : Void { - } - - public function tearDown() : Void { - } - - function print( v : Dynamic ) { - haxe.unit.TestRunner.print(v); - } - - function assertTrue( b:Bool, ?c : PosInfos ) : Void { - currentTest.done = true; - if (b == false){ - currentTest.success = false; - currentTest.error = "expected true but was false"; - currentTest.posInfos = c; - throw currentTest; - } - } - - function assertFalse( b:Bool, ?c : PosInfos ) : Void { - currentTest.done = true; - if (b == true){ - currentTest.success = false; - currentTest.error = "expected false but was true"; - currentTest.posInfos = c; - throw currentTest; - } - } - - function assertEquals( expected: T , actual: T, ?c : PosInfos ) : Void { - currentTest.done = true; - if (actual != expected){ - currentTest.success = false; - currentTest.error = "expected '" + expected + "' but was '" + actual + "'"; - currentTest.posInfos = c; - throw currentTest; - } - } - -} diff --git a/haxe/std/haxe/unit/TestResult.hx b/haxe/std/haxe/unit/TestResult.hx deleted file mode 100644 index 3eaebb65f3a474731f63fb50b3947b0bf3ac7ec2..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/unit/TestResult.hx +++ /dev/null @@ -1,94 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - package haxe.unit; - -class TestResult { - - var m_tests : List; - public var success(default,null) : Bool; - - public function new() { - m_tests = new List(); - success = true; - } - - public function add( t:TestStatus ) : Void { - m_tests.add(t); - if( !t.success ) - success = false; - } - - public function toString() : String { - var buf = new StringBuf(); - var failures = 0; - for ( test in m_tests ){ - if (test.success == false){ - buf.add("* "); - buf.add(test.classname); - buf.add("::"); - buf.add(test.method); - buf.add("()"); - buf.add("\n"); - - buf.add("ERR: "); - if( test.posInfos != null ){ - buf.add(test.posInfos.fileName); - buf.add(":"); - buf.add(test.posInfos.lineNumber); - buf.add("("); - buf.add(test.posInfos.className); - buf.add("."); - buf.add(test.posInfos.methodName); - buf.add(") - "); - } - buf.add(test.error); - buf.add("\n"); - - if (test.backtrace != null) { - buf.add(test.backtrace); - buf.add("\n"); - } - - buf.add("\n"); - failures++; - } - } - buf.add("\n"); - if (failures == 0) - buf.add("OK "); - else - buf.add("FAILED "); - - buf.add(m_tests.length); - buf.add(" tests, "); - buf.add(failures); - buf.add(" failed, "); - buf.add( (m_tests.length - failures) ); - buf.add(" success"); - buf.add("\n"); - return buf.toString(); - } - -} diff --git a/haxe/std/haxe/unit/TestStatus.hx b/haxe/std/haxe/unit/TestStatus.hx deleted file mode 100644 index ac75b5b00d7e518c3301ea3a4623c535cc1de30a..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/unit/TestStatus.hx +++ /dev/null @@ -1,44 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.unit; -import haxe.Stack; - -import haxe.PosInfos; - -class TestStatus { - public var done : Bool; - public var success : Bool; - public var error : String; - public var method : String; - public var classname : String; - public var posInfos : PosInfos; - public var backtrace : String; - - public function new() { - done = false; - success = false; - } - -} diff --git a/haxe/std/haxe/xml/Proxy.hx b/haxe/std/haxe/xml/Proxy.hx deleted file mode 100644 index c71615e80e9eff03e35cd48105eed91f998e53aa..0000000000000000000000000000000000000000 --- a/haxe/std/haxe/xml/Proxy.hx +++ /dev/null @@ -1,57 +0,0 @@ -/* - * Copyright (c) 2005-2007, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package haxe.xml; - -/** - This proxy can be inherited with an XML file name parameter. - It will only allow access to fields which corresponds to an "id" attribute - value in the XML file : - - [ - class MyXml extends haxe.xml.Proxy<"my.xml",MyStructure> { - } - ... - var h = new Hash(); - // ... fill h with "my.xml" content - var m = new MyXml(h.get); - trace(m.myNode.structField); - // access to "myNode" is only possible - // if you have an id="myNode" attribute - // in your XML, and completion works as well - ] -**/ -class Proxy { - - var __f : String -> T; - - public function new(f) { - this.__f = f; - } - - public function resolve(k) { - return __f(k); - } - -} diff --git a/haxe/std/js/Boot.hx b/haxe/std/js/Boot.hx deleted file mode 100644 index bdabdc3fdfcc6faf7014bc7a02e24db4420060af..0000000000000000000000000000000000000000 --- a/haxe/std/js/Boot.hx +++ /dev/null @@ -1,261 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package js; - -class Boot { - - private static function __unhtml(s : String) { - return s.split("&").join("&").split("<").join("<").split(">").join(">"); - } - - private static function __trace(v,i : haxe.PosInfos) { - untyped { - var msg = if( i != null ) i.fileName+":"+i.lineNumber+": " else ""; - #if jsfl - msg += __string_rec(v,""); - fl.trace(msg); - #else - msg += __unhtml(__string_rec(v,""))+"
"; - var d = document.getElementById("haxe:trace"); - if( d == null ) - alert("No haxe:trace element defined\n"+msg); - else - d.innerHTML += msg; - #end - } - } - - private static function __clear_trace() { - untyped { - #if jsfl - fl.outputPanel.clear(); - #else - var d = document.getElementById("haxe:trace"); - if( d != null ) - d.innerHTML = ""; - #end - } - } - - private static function __closure(o,f) { - untyped { - var m = o[f]; - if( m == null ) - return null; - var f = function() { return m.apply(o,arguments); }; - f.scope = o; - f.method = m; - return f; - } - } - - private static function __string_rec(o,s) { - untyped { - if( o == null ) - return "null"; - if( s.length >= 5 ) - return "<...>"; // too much deep recursion - var t = __js__("typeof(o)"); - if( t == "function" && (o.__name__ != null || o.__ename__ != null) ) - t = "object"; - switch( t ) { - case "object": - if( __js__("o instanceof Array") ) { - if( o.__enum__ != null ) { - if( o.length == 2 ) - return o[0]; - var str = o[0]+"("; - s += "\t"; - for( i in 2...o.length ) { - if( i != 2 ) - str += "," + __string_rec(o[i],s); - else - str += __string_rec(o[i],s); - } - return str + ")"; - } - var l = o.length; - var i; - var str = "["; - s += "\t"; - for( i in 0...l ) - str += (if (i > 0) "," else "")+__string_rec(o[i],s); - str += "]"; - return str; - } - var tostr; - try { - tostr = untyped o.toString; - } catch( e : Dynamic ) { - // strange error on IE - return "???"; - } - if( tostr != null && tostr != __js__("Object.toString") ) { - var s2 = o.toString(); - if( s2 != "[object Object]") - return s2; - } - var k : String = null; - var str = "{\n"; - s += "\t"; - var hasp = (o.hasOwnProperty != null); - __js__("for( var k in o ) { "); - if( hasp && !o.hasOwnProperty(k) ) - __js__("continue"); - if( k == "prototype" || k == "__class__" || k == "__super__" || k == "__interfaces__" ) - __js__("continue"); - if( str.length != 2 ) - str += ", \n"; - str += s + k + " : "+__string_rec(o[k],s); - __js__("}"); - s = s.substring(1); - str += "\n" + s + "}"; - return str; - case "function": - return ""; - case "string": - return o; - default: - return String(o); - } - } - } - - private static function __interfLoop(cc : Dynamic,cl : Dynamic) { - if( cc == null ) - return false; - if( cc == cl ) - return true; - var intf : Dynamic = cc.__interfaces__; - if( intf != null ) - for( i in 0...intf.length ) { - var i : Dynamic = intf[i]; - if( i == cl || __interfLoop(i,cl) ) - return true; - } - return __interfLoop(cc.__super__,cl); - } - - private static function __instanceof(o : Dynamic,cl) { - untyped { - try { - if( __js__("o instanceof cl") ) { - if( cl == Array ) - return (o.__enum__ == null); - return true; - } - if( __interfLoop(o.__class__,cl) ) - return true; - } catch( e : Dynamic ) { - if( cl == null ) - return false; - } - switch( cl ) { - case Int: - return __js__("Math.ceil(o%2147483648.0) === o"); - case Float: - return __js__("typeof(o)") == "number"; - case Bool: - return __js__("o === true || o === false"); - case String: - return __js__("typeof(o)") == "string"; - case Dynamic: - return true; - default: - if( o == null ) - return false; - return o.__enum__ == cl || ( cl == Class && o.__name__ != null ) || ( cl == Enum && o.__ename__ != null ); - } - } - } - - private static function __init() { - untyped { - Lib.isIE = (__js__("typeof document!='undefined'") && document.all != null && __js__("typeof window!='undefined'") && window.opera == null ); - Lib.isOpera = (__js__("typeof window!='undefined'") && window.opera != null ); -#if js_namespace - __js__("eval(js.Boot.__ns).Array = Array"); - __js__("eval(js.Boot.__ns).String = String"); - __js__("eval(js.Boot.__ns).Math = Math"); - __js__("eval(js.Boot.__ns).Date = Date"); -#end - Array.prototype.copy = Array.prototype.slice; - Array.prototype.insert = function(i,x) { - this.splice(i,0,x); - }; - Array.prototype.remove = if( Array.prototype.indexOf ) function(obj) { - var idx = this.indexOf(obj); - if( idx == -1 ) return false; - this.splice(idx,1); - return true; - } else function(obj) { - var i = 0; - var l = this.length; - while( i < l ) { - if( this[i] == obj ) { - this.splice(i,1); - return true; - } - i++; - } - return false; - }; - Array.prototype.iterator = function() { - return { - cur : 0, - arr : this, - hasNext : function() { - return this.cur < this.arr.length; - }, - next : function() { - return this.arr[this.cur++]; - } - } - }; - if( String.prototype.cca == null ) - String.prototype.cca = String.prototype.charCodeAt; - String.prototype.charCodeAt = function(i) { - var x = this.cca(i); - if( x != x ) // fast isNaN - return null; - return x; - }; - var oldsub = String.prototype.substr; - String.prototype.substr = function(pos,len){ - if( pos != null && pos != 0 && len != null && len < 0 ) return ""; - if( len == null ) len = this.length; - if( pos < 0 ){ - pos = this.length + pos; - if( pos < 0 ) pos = 0; - }else if( len < 0 ){ - len = this.length + len - pos; - } - return oldsub.apply(this,[pos,len]); - }; - __js__("$closure = js.Boot.__closure"); - } - } - -} diff --git a/haxe/std/js/Cookie.hx b/haxe/std/js/Cookie.hx deleted file mode 100644 index 7ffa002c02edbd81d3a31face356c6a4e4e0fd96..0000000000000000000000000000000000000000 --- a/haxe/std/js/Cookie.hx +++ /dev/null @@ -1,59 +0,0 @@ -package js; - -class Cookie { - /** - Create or update a cookie. - expireDelay (seconds), if null, the cookie expires at end of session - **/ - public static function set( name : String, value : String, ?expireDelay : Int, ?path : String, ?domain : String ){ - var s = name+"="+StringTools.urlEncode(value); - if( expireDelay != null ){ - var d = DateTools.delta(Date.now(),expireDelay*1000); - s += ";expires=" + untyped d.toGMTString(); - } - if( path != null ){ - s += ";path="+path; - } - if( domain != null ){ - s += ";domain="+domain; - } - js.Lib.document.cookie = s; - } - - /** - Returns all cookies - **/ - public static function all(){ - var h = new Hash(); - var a = js.Lib.document.cookie.split(";"); - for( e in a ){ - e = StringTools.ltrim(e); - var t = e.split("="); - if( t.length < 2 ) - continue; - h.set(t[0],StringTools.urlDecode(t[1])); - } - return h; - } - - /** - Returns value of a cookie. - **/ - public static function get( name : String ){ - return all().get(name); - } - - /** - Returns true if a cookie [name] exists - **/ - public static function exists( name : String ){ - return all().exists(name); - } - - /** - Remove a cookie - **/ - public static function remove( name : String, ?path : String, ?domain : String ){ - set(name,"",-10,path,domain); - } -} diff --git a/haxe/std/js/Dom.hx b/haxe/std/js/Dom.hx deleted file mode 100644 index 47f50333db374d2507ac3c52dd7689c0db6efcd8..0000000000000000000000000000000000000000 --- a/haxe/std/js/Dom.hx +++ /dev/null @@ -1,633 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package js; - -// allow both indexed and dot accessses -extern class HtmlCollection implements ArrayAccess, implements Dynamic { - var length(default,null) : Int; -} - -// the base typedef for every DOM element -typedef MetaDom = { - var nodeName : String; - var nodeType : Int; - var nodeValue : String; - - var parentNode : T; - var childNodes : HtmlCollection; - var firstChild : T; - var lastChild : T; - var nextSibling : T; - var previousSibling : T; - - function appendChild( child : T ) : Void; - function cloneNode( deep : Bool ) : T; - function hasChildNodes() : Bool; - function insertBefore( newChild : T, refChild : T ) : Void; - function removeChild( child : T ) : T; - function replaceChild( child : T, oldChild : T ) : Void; - function getAttribute( attr : String ) : String; - function setAttribute( attr : String, val : String ) : Void; -} - -typedef Dom = MetaDom - -typedef HtmlDom = {> MetaDom, - var id : String; - var title : String; - var lang : String; - var dir : String; - var innerHTML : String; - var className : String; - - var style : Style; - - function getElementsByTagName( tag : String ) : HtmlCollection; - - var scrollTop : Int; - var scrollLeft : Int; - var scrollHeight(default,null) : Int; - var scrollWidth(default,null) : Int; - var clientHeight(default,null) : Int; - var clientWidth(default,null) : Int; - var offsetParent : HtmlDom; - var offsetLeft : Int; - var offsetTop : Int; - var offsetWidth : Int; - var offsetHeight : Int; - - function blur() : Void; - function click() : Void; - function focus() : Void; - - var onscroll : Event -> Void; - var onblur : Event -> Void; - var onclick : Event -> Void; - var ondblclick : Event -> Void; - var onfocus : Event -> Void; - var onkeydown : Event -> Void; - var onkeypress : Event -> Void; - var onkeyup : Event -> Void; - var onmousedown : Event -> Void; - var onmousemove : Event -> Void; - var onmouseout : Event -> Void; - var onmouseover : Event -> Void; - var onmouseup : Event -> Void; - var onresize : Event -> Void; -} - -typedef FormElement = {> HtmlDom, - - var disabled : Bool; - var form : Form; - var name : String; - var type : String; - var value : String; - - function select() : Void; - var onselect : Event -> Void; - var onchange : Event -> Void; -} - -typedef Anchor = {> HtmlDom, - - var accessKey : String; - var href : String; - var name: String; - var rel : String; - var rev : String; - var tabIndex : Int; - var target : String; - -#if ie5 - var charset : String; - var coords : String; - var hreflang : String; - var shape : String; - var type : String; -#end - -} - -typedef Body = {> HtmlDom, - // IE only, NO W3C var accessKey : String; - var aLink : String; - var background : String; - var bgColor : String; - var link : String; - var text : String; - var vLink : String; -} - -typedef Button = {> FormElement, -} - -typedef Checkbox = {> FormElement, - var checked : Bool; - var defaultChecked : Bool; -} - -typedef Document = {> HtmlDom, - var anchors : HtmlCollection; - // applets : Applet is deprecated in Dom2 - var forms : HtmlCollection
; - var images : HtmlCollection; - var links : HtmlCollection; - // plugins : Not in IE, not in W3C - - /* deprecated in Dom2 , use body - var alinkColor; - var background; - var bgColor; - var fgColor; - var linkColor; - var vlinkColor; - */ - - var body : Body; - var cookie : String; - var domain : String; - var referrer : String; - - // TODO : var URL : String; - - // not W3C , need infos : var embeds : HtmlCollection; - // var lastModified : Date; // commented : does not include date by default - var styleSheets : HtmlCollection; - function getElementsByTag( tag : String ) : HtmlCollection; - - function open() : Void; - function write( str : String ) : Void; - function writeln( str : String ) : Void; - function close() : Void; - function getElementById( id : String ) : HtmlDom; - function getElementsByName( name : String ) : HtmlCollection; - function createElement( name : String ) : HtmlDom; - function createTextNode( text : String ) : HtmlDom; -} - -typedef Event = { - var target : HtmlDom; - var type : String; - - // TO COMPLETE... (need infos) - var clientX : Int; - var clientY : Int; - var screenX : Int; - var screenY : Int; - var button : Int; - var keyCode : Int; - var shiftKey : Bool; - var ctrlKey : Bool; - var altKey : Bool; - var cancelBubble : Bool; - function stopPropagation() : Void; // W3C only -} - -typedef FileUpload = {> FormElement, - var defaultValue : String; -} - -typedef Form = {> HtmlDom, - - var elements : HtmlCollection; - - var acceptCharset : String; - var action : String; - var encoding : String; - var enctype : String; - var length : Int; - var method : String; - var name : String; - var tabIndex : Int; - var target : String; - - function reset() : Void; - function submit() : Void; - - var onreset : Event -> Void; - var onsubmit : Event -> Bool; -} - -typedef Frame = {> HtmlDom, - - var contentDocument : Document; - var frameBorder : String; - // IE6 only ? var longDesc : String - var marginHeight : String; - var marginWidth : String; - var name : String; - var noResize : Bool; - var scrolling : String; - var src : String; -} - -typedef Frameset = {> HtmlDom, - var cols : Int; - var rows : Int; -} - -typedef Hidden = {> FormElement, - var defaultValue : String; -} - -typedef History = { - var length : Int; - function back() : Void; - function forward() : Void; - function go( p : Dynamic ) : Void; -} - -typedef IFrame = {> HtmlDom, - var contentWindow : Window; - var frameBorder : String; - var height : Int; - var width : Int; - // IE6 only ? var longDesc : String - var marginHeight : String; - var marginWidth : String; - var name : String; - var scrolling : String; - var src : String; -} - -typedef Image = {> HtmlDom, - var align : String; - var alt : String; - var border : String; - var height : Int; - var hspace : Int; - var isMap : Bool; - // IE only : var longDesc : String; - var name : String; - var src : String; - var useMap : String; - var vspace : Int; - var width : Int; - - var complete : Bool; - var lowsrc : String; - - var onabort : Event -> Void; - var onerror : Event -> Void; - var onload : Event -> Void; -} - -typedef Link = {> HtmlDom, - var charset : String; - var disabled : Bool; - var href : String; - var hreflang : String; - var media : String; - var rel : String; - var rev : String; - var target : String; - var type : String; - var name : String; - var onload : Event -> Void; -} - -typedef Location = { - var hash : String; - var host : String; - var hostname : String; - var href : String; - var pathname : String; - var port : Int; - var protocol : String; - var search : String; - - function assign( url : String ) : Void; - function reload( ?forceReload : Bool ) : Void; - function replace( url : String ) : Void; -} - -typedef Navigator = { - // var plugins : HtmlCollection - - var appCodeName : String; - var appName : String; - var appVersion : String; - var cookieEnabled : Bool; - var platform : String; - var userAgent : String; - - /* IE only ? - var appMinorVersion : String - var browserLanguage : String - var cpuClass : String; - var onLine : Bool; - var systemLanguage : String; - var userLanguage : String; - */ - - function javaEnabled() : Bool; - function taintEnabled() : Bool; -} - -typedef Option = {> FormElement, - var defaultSelected : Bool; - var selected : Bool; - var text : String; -} - -typedef Password = {> FormElement, - var defaultValue : String; - var maxLength : Int; - var readOnly : Bool; - var size : Int; -} - -typedef Radio = {> FormElement, - var checked : Bool; - var defaultChecked : Bool; - var size : Int; -} - -typedef Reset = {> FormElement, -} - -typedef Screen = { - var availHeight : Int; - var availWidth : Int; - var colorDepth : Int; - var height : Int; - var width : Int; - - // FF only ? var pixelDepth : Int; - - /* IE only ? - var bufferDepth : Int; - var deviceXDPI : Int; - var deviceYDPI : Int; - var logicalXDPI : Int; - var logicalYDPI : Int; - var updateInterval : Int; - */ -} - -typedef Select = {> FormElement, - var options : HtmlCollection
{ - if( vrfy == null ) - vrfy = true; - var a = new Array(); - var name = null; - var address = null; - - str = StringTools.trim(str); - var s = str; - - while( s.length > 0 ){ - s = StringTools.ltrim(s); - if( REG_QSTRING.match(s) ){ - var t = REG_QSTRING.matched(1); - t = ~/\\(.)/g.replace(t,"$1"); - if( name != null ) name += " "; - else name = ""; - name += t; - s = REG_QSTRING.matchedRight(); - }else if( REG_ADDRESS.match(s) ){ - if( address != null && vrfy ) throw Exception.ParseError(str+", near: "+s.substr(0,15)); - address = REG_ADDRESS.matched(1); - s = REG_ADDRESS.matchedRight(); - }else if( REG_ROUTE_ADDR.match(s) ){ - if( address != null ) - name = (name!=null)?name+" "+address : address; - address = REG_ROUTE_ADDR.matched(1); - s = REG_ROUTE_ADDR.matchedRight(); - }else if( REG_ATOM.match(s) ){ - if( name != null ) name += " "; - else name = ""; - name += REG_ATOM.matched(1); - s = REG_ATOM.matchedRight(); - }else if( REG_COMMENT.match(s) ){ - if( name != null ) name += " "; - else name = ""; - name += REG_COMMENT.matched(1); - s = REG_COMMENT.matchedRight(); - }else if( REG_SEPARATOR.match(s) ){ - if( address != null ){ - a.push({name: if( name != null && name.length > 0 ) name else null, address: address}); - address = null; - name = null; - } - s = REG_SEPARATOR.matchedRight(); - }else if( vrfy ){ - throw Exception.ParseError(str+", near: "+s.substr(0,15)); - }else{ - break; - } - } - if( address != null ){ - a.push({name: if( name != null && name.length > 0 ) name else null, address: address}); - } - if( a.length == 0 ){ - if( vrfy ) - throw Exception.ParseError(str+", no address found"); - else - a.push({name: null,address: null}); - } - return a; - } - - public static function formatAddress( a : Array
){ - var r = new List(); - for( c in a ){ - if( c.name == null || c.name == "" ) r.add(c.address); - else if( ~/^[A-Z0-9 ]*$/i.match(c.name) ) r.add(c.name+" <"+c.address+">"); - else{ - var quoted = c.name.split("\\").join("\\\\").split("\"").join("\\\""); - r.add("\""+quoted+"\" <"+c.address+">"); - } - } - return r.join(","); - } - -} diff --git a/haxe/std/mtwin/mail/imap/BodyStructure.hx b/haxe/std/mtwin/mail/imap/BodyStructure.hx deleted file mode 100644 index 5a70ad51e8269105d0feddf6634a335e476dfef5..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/mail/imap/BodyStructure.hx +++ /dev/null @@ -1,246 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package mtwin.mail.imap; - -class BodyStructure { - public var ctype0(default,null): String; - public var ctype1(default,null): String; - public var params(default,null) : Hash; - public var parts(default,null): List; - - // single-part specific - public var id(default,null) : String; - public var contentId(default,null): String; - public var description(default,null) : String; - public var encoding(default,null) : String; - public var size(default,null) : Int; - public var disposition(default,null) : String; - public var dispositionParams(default,null) : Hash; - - // - public var __length : Int; - - public function new(){ - parts = new List(); - params = new Hash(); - } - - public function getMainPart( ?preferHtml : Bool, ?level : Int, ?priority : Int, ?cpriority : Int ) : BodyStructure { - if( level == null ) level = 0; - if( priority == null ) priority = 0; - if( cpriority == null ) cpriority = 0; - if( preferHtml == null ) preferHtml = true; - - if( ctype0 != "multipart" || (level == 0 && parts.length == 0) ){ - if( level == 0 ) return this; - if( preferHtml ){ - if( ctype1 == "html" ) return this; - if( ctype1 == "plain" && cpriority > 0 ) return this; - }else{ - if( ctype1 == "plain" ) return this; - if( ctype1 == "html" && cpriority > 0 ) return this; - } - }else{ - if( level == 0 ){ - // multipart ! - // si c'est au premier niveau, c'est une boucle principale, avec priorité qui augmente - do { - do { - var r = null; - for( part in parts ){ - r = part.getMainPart( preferHtml, level + 1, priority, cpriority ); - if( r != null ) break; - } - if( r != null ) return r; - priority++; - }while( priority <= 1 ); - cpriority++; - }while( cpriority <= 1 ); - }else{ - // là c'est des boucles qui se déclanche si c'est ok - if( ctype1 == "alternative" || priority > 0 ){ - var r = null; - for( part in parts ){ - r = part.getMainPart( preferHtml, level + 1, priority, cpriority ); - if( r != null ) return r; - } - } - } - } - return null; - } - - public function listAttachment( ?level : Int ) : List { - if( level == null ) level = 0; - var ret = new List(); - if( ctype0 != "multipart" ){ - if( level != 0 && disposition != null ){ - ret.add( this ); - } - }else if( ctype1 != "alternative" ){ - for( part in parts ){ - for( v in part.listAttachment( level + 1 ) ){ - ret.add( v ); - } - } - } - return ret; - } - - public function hasAttachment(){ - return listAttachment().length > 0; - } - - public function findById( contentId : String ) : BodyStructure { - if( this.contentId == contentId ) return this; - for( part in parts ){ - var r = part.findById( contentId ); - if( r != null ) return r; - } - return null; - } - - public static function parse( s : String, ?id : String ) : BodyStructure{ - if( id == null ) id = ""; - var len = s.length; - var parCount = 0; - var p = 0; - var ret = new BodyStructure(); - ret.id = id; - var addPart = function( p ){ - ret.parts.add( p ); - }; - var tmp = {pName: null,argPos: 0}; - var addElement = function( e : String ){ - if( ret.ctype0 == null ){ - ret.ctype0 = e; - }else if( ret.ctype1 == null ){ - ret.ctype1 = e; - tmp.argPos = 0; - }else{ - if( e == "NIL" ) return; - if( ret.ctype0 == "multipart" ){ - switch( tmp.argPos ){ - case 1: - if( tmp.pName == null ) - tmp.pName = e; - else{ - ret.params.set(tmp.pName.toLowerCase(),e); - tmp.pName = null; - } - case 4: - case 5: - } - }else{ - switch( tmp.argPos ){ - case 1: - if( tmp.pName == null ) - tmp.pName = e; - else{ - ret.params.set(tmp.pName.toLowerCase(),e); - tmp.pName = null; - } - case 2: - ret.contentId = e; - case 3: - ret.description = e; - case 4: - ret.encoding = e; - case 5: - ret.size = Std.parseInt(e); - default: - var dispoPos = if( ret.ctype0 == "text" ) 8 else if( ret.ctype0 == "message" ) 10 else 7; - if( tmp.argPos == dispoPos ){ - if( parCount == 1 ){ - ret.disposition = e; - ret.dispositionParams = new Hash(); - }else{ - if( tmp.pName == null ) - tmp.pName = e; - else{ - ret.dispositionParams.set(tmp.pName,e); - tmp.pName = null; - } - } - } - } - } - - } - }; - while( p < len ){ - var c = s.charAt(p); - p++; - switch( c ){ - case "(": - if( ret.ctype1 == null ){ - var newPart = parse( s.substr(p,s.length-p), (if( id == "" ) "" else id + "." )+ (ret.parts.length+1) ); - addPart( newPart ); - ret.ctype0 = "multipart"; - p += newPart.__length; - }else - parCount++; - case ")": - parCount--; - if( parCount < 0 ){ - ret.__length = p; - return ret; - } - case "\"": - var b = new StringBuf(); - var prev = null; - while( p < len ){ - var c2 = s.charAt(p); - p++; - if( c2 == "\"" && prev != "\\" ) - break; - b.add( c2 ); - prev = c2; - } - addElement( b.toString().split("\\\"").join("\"").split("\\\\").join("\\") ); - case " ": - if( parCount == 0 ){ - tmp.argPos++; - } - default: - var b = new StringBuf(); - p--; - while( p < len ){ - var c2 = s.charAt(p); - p++; - if( c2 == ")" || c2 == " " ){ - p--; - break; - } - b.add( c2 ); - } - addElement( b.toString() ); - } - } - ret.__length = p; - return ret; - } - -} diff --git a/haxe/std/mtwin/mail/imap/Connection.hx b/haxe/std/mtwin/mail/imap/Connection.hx deleted file mode 100644 index add96cfd8778da113302dd310c3f7d83cbb0fca6..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/mail/imap/Connection.hx +++ /dev/null @@ -1,529 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package mtwin.mail.imap; - -import neko.net.Socket; -import mtwin.mail.Exception; -import mtwin.mail.imap.Tools; - -enum FlagMode { - Add; - Remove; - Replace; -} - -typedef FetchResponse = { - id: Int, - uid: Int, - bodyType: String, - body: String, - flags: Flags, - structure: BodyStructure, - internalDate: String, - envelope: Envelope -} - -class Connection { - public static var DEBUG = false; - public static var TIMEOUT = 25; - - var cnx : Socket; - var count : Int; - var selected : String; - var logged : Bool; - - static var REG_RESP = ~/(OK|NO|BAD) (\[([^\]]+)\] )?(([A-Z]{2,}) )? ?(.*)/; - static var REG_EXISTS = ~/^([0-9]+) EXISTS$/; - static var REG_RECENT = ~/^([0-9]+) RECENT$/; - static var REG_UNSEEN = ~/^OK \[UNSEEN ([0-9]+)\]/; - static var REG_FETCH_MAIN = ~/([0-9]+) FETCH \(/; - static var REG_FETCH_PART = ~/^(BODY\[[A-Za-z0-9.]*\]|RFC822\.?[A-Z]*) \{([0-9]+)\}/; - static var REG_FETCH_FLAGS = ~/^FLAGS \(([ \\A-Za-z0-9$]*)\) */; - static var REG_FETCH_UID = ~/^UID ([0-9]+) */; - static var REG_FETCH_BODYSTRUCTURE = ~/^BODY(STRUCTURE)? \(/; - static var REG_FETCH_ENVELOPE = ~/^ENVELOPE \(/; - static var REG_FETCH_INTERNALDATE = ~/^INTERNALDATE "([^"]+)" */; - static var REG_FETCH_END = ~/^([A0-9]{4}) (OK|BAD|NO)/; - static var REG_STATUS = ~/STATUS .*? \(([^)]+)\)/; - static var REG_STATUS_VAL = ~/^ ?([A-Z]+) (-?[0-9]+)/; - static var REG_LIST_RESP = ~/LIST \(([ \\A-Za-z0-9]*)\) [A-z0-9".]* "?([^"]+)"?/; - static var REG_CRLF = ~/\r?\n/g; - - static function rmCRLF(s){ - return REG_CRLF.replace(s, ""); - } - - static function debug(s:String){ - if( DEBUG ) neko.Lib.print(Std.string(s)+"\n"); - } - - ////// - - public function new(){ - count = 0; - logged = false; - } - - /** - Connect to Imap Server - **/ - public function connect( host : String, ?port : Int ){ - if( cnx != null ) throw AlreadyConnected; - - if( port == null ) port = 143; - cnx = new Socket(); - try{ - cnx.connect( new neko.net.Host(host), port ); - }catch( e : Dynamic ){ - cnx.close(); - throw ConnectionError(host,port); - } - debug("socket connected"); - cnx.setTimeout( TIMEOUT ); - cnx.input.readLine(); - logged = false; - } - - /** - Login to server - **/ - public function login( user : String, pass : String ){ - var r = command("LOGIN",Tools.quote(user)+" "+Tools.quote(pass)); - if( !r.success ){ - throw BadResponse(r.response); - } - logged = true; - } - - /** - Logout - **/ - function logout(){ - if( !logged ) return; - var r = command("LOGOUT"); - if( !r.success ) throw BadResponse(r.response); - logged = false; - } - - /** - Close connection to server - **/ - public function close(){ - logout(); - cnx.close(); - cnx = null; - } - - /** - List mailboxes that match pattern (all mailboxes if pattern is null) - **/ - public function mailboxes( ?pattern : String, ?flat : Bool ) : Array { - if( pattern == null ) pattern = "*"; - if( flat == null ) flat = false; - - var r = command("LIST",Tools.quote("")+" "+Tools.quote(pattern)); - if( !r.success ){ - throw BadResponse(r.response); - } - - var hash = new Hash(); - for( v in r.result ){ - if( REG_LIST_RESP.match(v) ){ - var name = REG_LIST_RESP.matched(2); - var flags = REG_LIST_RESP.matched(1).split(" "); - - var t = Mailbox.init( this, name, flags ); - hash.set(name,t); - } - } - - var ret = new Array(); - for( t in hash ){ - var a = t.name.split("."); - a.pop(); - var p = a.join("."); - if( p.length > 0 && hash.exists(p) ){ - var par = hash.get(p); - par.children.push( t ); - untyped t.parent = par; - if( flat ) ret.push( t ); - }else{ - ret.push( t ); - } - - } - - return ret; - } - - public function getMailbox( name : String ){ - var m = mailboxes(name)[0]; - if( m == null ) - throw "No such mailbox "+name; - return m; - } - - /** - Select a mailbox - **/ - public function select( mailbox : String ){ - if( selected == mailbox ) return null; - - var r = command("SELECT",Tools.quote(mailbox)); - if( !r.success ) - throw BadResponse(r.response); - - selected = mailbox; - - var ret = {recent: 0,exists: 0,firstUnseen: null}; - for( v in r.result ){ - if( REG_EXISTS.match(v) ){ - ret.exists = Std.parseInt(REG_EXISTS.matched(1)); - }else if( REG_UNSEEN.match(v) ){ - ret.firstUnseen = Std.parseInt(REG_UNSEEN.matched(1)); - }else if( REG_RECENT.match(v) ){ - ret.recent = Std.parseInt(REG_RECENT.matched(1)); - } - } - - return ret; - } - - public function status( mailbox : String ){ - var r = command("STATUS",Tools.quote(mailbox)+" (MESSAGES RECENT UNSEEN)"); - if( !r.success ) throw BadResponse( r.response ); - - var ret = new Hash(); - if( REG_STATUS.match( r.result.first() ) ){ - var t = REG_STATUS.matched(1); - while( REG_STATUS_VAL.match(t) ){ - ret.set(REG_STATUS_VAL.matched(1),Std.parseInt(REG_STATUS_VAL.matched(2))); - t = REG_STATUS_VAL.matchedRight(); - } - }else{ - throw UnknowResponse(r.result.first()); - } - return ret; - } - - /** - Search for messages. Pattern syntax described in RFC 3501, section 6.4.4 - **/ - public function search( ?pattern : String, ?useUid : Bool ) : List { - if( pattern == null ) pattern = "ALL"; - if( useUid == null ) useUid = false; - - var r = command(if( useUid) "UID SEARCH" else "SEARCH",pattern); - if( !r.success ){ - throw BadResponse(r.response); - } - - var l = new List(); - - for( v in r.result ){ - if( StringTools.startsWith(v,"SEARCH ") ){ - var t = v.substr(7,v.length-7).split(" "); - for( i in t ){ - l.add( Std.parseInt(i) ); - } - } - } - - return l; - } - - public function sort( criteria : String, ?pattern : String, ?charset : String, ?useUid : Bool ){ - if( pattern == null ) pattern = "ALL"; - if( useUid == null ) useUid = false; - if( charset == null ) charset = "US-ASCII"; - - var r = command(if( useUid) "UID SORT" else "SORT","("+criteria+") "+charset+" "+pattern); - if( !r.success ){ - throw BadResponse(r.response); - } - - var l = new List(); - - for( v in r.result ){ - if( StringTools.startsWith(v,"SORT ") ){ - var t = v.substr(5,v.length-5).split(" "); - for( i in t ){ - l.add( Std.parseInt(i) ); - } - } - } - - return l; - } - - /** - Fetch messages from the currently selected mailbox. - **/ - public function fetchRange( iRange: Collection, ?iSection : Array
, ?useUid : Bool ) : List{ - if( iRange == null ) return null; - if( iSection == null ) iSection = [Body(null)]; - if( useUid == null ) useUid = false; - - var range = Tools.collString(iRange); - var section = Tools.sectionString(iSection); - - if( useUid ) - command("UID FETCH",range+" "+section,false); - else - command("FETCH",range+" "+section,false); - - var tmp = new IntHash(); - var ret = new List(); - while( true ){ - var l = cnx.input.readLine(); - if( REG_FETCH_MAIN.match(l) ){ - var id = Std.parseInt(REG_FETCH_MAIN.matched(1)); - - var o = if( tmp.exists(id) ){ - tmp.get(id); - }else { - var o = {bodyType: null,body: null,flags: null,uid: null,structure: null,internalDate: null,envelope: null,id: id}; - tmp.set(id,o); - ret.add(o); - o; - } - - var s = REG_FETCH_MAIN.matchedRight(); - while( s.length > 0 ){ - if( REG_FETCH_FLAGS.match( s ) ){ - o.flags = REG_FETCH_FLAGS.matched(1).split(" "); - s = REG_FETCH_FLAGS.matchedRight(); - }else if( REG_FETCH_UID.match( s ) ){ - o.uid = Std.parseInt(REG_FETCH_UID.matched(1)); - s = REG_FETCH_UID.matchedRight(); - }else if( REG_FETCH_INTERNALDATE.match( s ) ){ - o.internalDate = REG_FETCH_INTERNALDATE.matched(1); - s = REG_FETCH_INTERNALDATE.matchedRight(); - }else if( REG_FETCH_ENVELOPE.match( s ) ){ - var t = REG_FETCH_ENVELOPE.matchedRight(); - t = completeString(t); - o.envelope = mtwin.mail.imap.Envelope.parse( t ); - s = StringTools.ltrim(t.substr(o.envelope.__length,t.length)); - }else if( REG_FETCH_BODYSTRUCTURE.match( s ) ){ - var t = REG_FETCH_BODYSTRUCTURE.matchedRight(); - t = completeString(t); - o.structure = mtwin.mail.imap.BodyStructure.parse( t ); - s = StringTools.ltrim(t.substr(o.structure.__length,t.length)); - }else if( REG_FETCH_PART.match( s ) ){ - var len = Std.parseInt(REG_FETCH_PART.matched(2)); - - o.body = cnx.input.readString( len ); - o.bodyType = REG_FETCH_PART.matched(1); - - cnx.input.readLine(); - break; - }else{ - break; - } - } - - }else if( REG_FETCH_END.match(l) ){ - var resp = REG_FETCH_END.matched(2); - if( resp == "OK" ){ - break; - }else{ - throw BadResponse(l); - } - }else{ - throw UnknowResponse(l); - } - } - - return ret; - } - - /** - Append content as a new message at the end of mailbox. - **/ - public function append( mailbox : String, content : String, ?flags : Flags ){ - var f = if( flags != null ) "("+flags.join(" ")+") " else ""; - command("APPEND",Tools.quote(mailbox)+" "+f+"{"+content.length+"}",false); - cnx.write( content ); - cnx.write( "\r\n" ); - var r = read( StringTools.lpad(Std.string(count),"A000",4) ); - if( !r.success ) - throw BadResponse(r.response); - } - - /** - Remove permanently all messages flagged as \Deleted in the currently selected mailbox. - **/ - public function expunge(){ - var r = command("EXPUNGE"); - if( !r.success ) - throw BadResponse(r.response); - } - - /** - Add, remove or replace flags on message(s) of the currently selected mailbox. - **/ - public function storeFlags( iRange : Collection, flags : Flags, ?mode : FlagMode, ?useUid : Bool, ?fetchResult : Bool ) : IntHash> { - if( mode == null ) mode = Add; - if( fetchResult == null ) fetchResult = false; - if( useUid == null ) useUid = false; - - var range = Tools.collString(iRange); - var elem = switch( mode ){ - case Add: "+FLAGS"; - case Remove: "-FLAGS"; - case Replace: "FLAGS"; - } - if( !fetchResult ){ - elem += ".SILENT"; - } - - var r = command( if( useUid ) "UID STORE" else "STORE", range + " " + elem + " ("+flags.join(" ")+")"); - if( !r.success ) throw BadResponse( r.response ); - if( !fetchResult ) return null; - - var ret = new IntHash(); - for( line in r.result ){ - if( REG_FETCH_MAIN.match(line) ){ - var id = Std.parseInt(REG_FETCH_MAIN.matched(1)); - if( REG_FETCH_FLAGS.match( REG_FETCH_MAIN.matchedRight() ) ){ - ret.set(id,REG_FETCH_FLAGS.matched(1).split(" ")); - } - } - } - return ret; - } - - /** - Create a new mailbox. - **/ - public function create( mailbox : String ){ - var r = command( "CREATE", Tools.quote(mailbox) ); - if( !r.success ) throw BadResponse( r.response ); - } - - /** - Delete a mailbox. - **/ - public function delete( mailbox : String ){ - var r = command( "DELETE", Tools.quote(mailbox) ); - if( !r.success ) throw BadResponse( r.response ); - } - - /** - Rename a mailbox. - **/ - public function rename( mailbox : String, newName : String ){ - var r = command( "RENAME", Tools.quote(mailbox)+" "+Tools.quote(newName) ); - if( !r.success ) throw BadResponse( r.response ); - } - - /** - Copy message(s) from the currently selected mailbox to the end of an other mailbox. - **/ - public function copy( iRange : Collection, toMailbox : String, ?useUid : Bool ){ - if( useUid == null ) useUid = false; - - var range = Tools.collString(iRange); - var r = command(if(useUid) "UID COPY" else "COPY",range+" "+Tools.quote(toMailbox)); - if( !r.success ) throw BadResponse( r.response ); - } - - - - ///// - - function completeString( s ){ - var reg = ~/(?; - public var sender(default,null) : List
; - public var replyTo(default,null) : List
; - public var to(default,null) : List
; - public var cc(default,null) : List
; - public var bcc(default,null) : List
; - public var inReplyTo(default,null) : String; - public var messageId(default,null) : String; - - function new(){ - } - - public function getDate(){ - if( date == null ) - return null; - return mtwin.DateFormat.parse(date); - } - - public static function parse( s : String ){ - var len = s.length; - var parCount = 0; - var p = 0; - var argPos = 0; - var ret = new Envelope(); - var tmp = { - alist: new List
(), - buf: new Array() - }; - - var closeParenthesis = function(){ - if( parCount == 1 ){ - tmp.alist.add({name: tmp.buf[0],address: tmp.buf[2]+"@"+tmp.buf[3]}); - tmp.buf = new Array(); - }else if( parCount == 0 ){ - switch( argPos ){ - case 2: ret.from = tmp.alist; - case 3: ret.sender = tmp.alist; - case 4: ret.replyTo = tmp.alist; - case 5: ret.to = tmp.alist; - case 6: ret.cc = tmp.alist; - case 7: ret.bcc = tmp.alist; - } - tmp.alist = new List(); - } - }; - - var addElement = function( e : String ){ - if( parCount >= 2 ){ - tmp.buf.push( e ); - }else{ - if( e != null ){ - switch( argPos ){ - case 0: ret.date = e; - case 1: ret.subject = e; - case 8: ret.inReplyTo = e; - case 9: ret.messageId = e; - } - } - } - }; - - while( p < len ){ - var c = s.charAt(p); - p++; - switch( c ){ - case "(": - parCount++; - case ")": - parCount--; - if( parCount < 0 ){ - ret.__length = p; - return ret; - } - closeParenthesis(); - case "\"": - var b = new StringBuf(); - var escape = false; - while( p < len ){ - var c2 = s.charAt(p); - p++; - if( c2 == "\"" && !escape ) - break; - escape = (c2 == "\\" && !escape ); - if( !escape ) - b.add( c2 ); - } - addElement( b.toString() ); - case " ": - if( parCount == 0 ) - argPos++; - default: - var b = new StringBuf(); - p--; - while( p < len ){ - var c2 = s.charAt(p); - p++; - if( c2 == ")" || c2 == " " ){ - p--; - break; - } - b.add( c2 ); - } - var bs = b.toString(); - if( bs == "NIL" ) - addElement( null ); - else - throw ParseError(bs); - } - } - ret.__length = p; - return ret; - } -} diff --git a/haxe/std/mtwin/mail/imap/Mailbox.hx b/haxe/std/mtwin/mail/imap/Mailbox.hx deleted file mode 100644 index 3b0740d4046ce9586ff5861e97b703ff10ab00d5..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/mail/imap/Mailbox.hx +++ /dev/null @@ -1,180 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -/* -signature ImapMailbox = { - name: String, - flags: ImapFlags, - hasChildren: Bool -} -*/ -package mtwin.mail.imap; - -import mtwin.mail.imap.Tools; -import mtwin.mail.Exception; - -class Mailbox { - static var PREFETCH_SECTION = [Section.Uid,Section.InternalDate,Section.Envelope,Section.BodyStructure,Section.Flags]; - - var cnx : Connection; - public var name(default,null) : String; - var flags : Flags; - public var children : Array; - public var parent(default,null) : Mailbox; - - public var length(default,null) : Int; - public var firstUnseen(default,null) : Int; - public var recent(default,null) : Int; - public var unseen(default,null) : Int; - - public static function init( c : Connection, n : String, f : Flags ){ - return new Mailbox( c,n,f ); - } - - function new( c, n, f ){ - cnx = c; - name = n; - flags = f; - children = new Array(); - } - - public function select(){ - if( hasFlag("\\Noselect") ) throw NoSelect; - - var r = cnx.select( name ); - if( r != null ){ - length = r.exists; - firstUnseen = r.firstUnseen; - recent = r.recent; - } - return cnx; - } - - public function hasFlag( f : String ){ - for( e in flags ){ - if( e == f ) return true; - } - return false; - } - - public function list( ?start : Int, ?end : Int, ?fPrefetch : Bool ){ - select(); - - if( start == null ) start = 1; - if( end == null ) end = length; - if( fPrefetch == null ) fPrefetch = true; - - start = Std.int(Math.max(1,Math.min(length,start))); - end = Std.int(Math.max(1,Math.min(length,end))); - - var r = cnx.fetchRange( Range(start,end), if( fPrefetch ) PREFETCH_SECTION else [Uid] ); - var ret = new List(); - for( m in r ){ - var t = Message.initUid(this,m.uid); - t.usePrefetch(m); - ret.add( t ); - } - return ret; - } - - public function syncStatus(){ - if( hasFlag("\\Noselect") ) throw NoSelect; - - var r = cnx.status( name ); - length = r.get("MESSAGES"); - unseen = r.get("UNSEEN"); - recent = r.get("RECENT"); - } - - public function get( uid : Int, ?fPrefetch : Bool ){ - select(); - - if( fPrefetch == null ) fPrefetch = true; - - var ret = Message.initUid( this, uid ); - if( fPrefetch ) prefetchOne( ret ); - return ret; - } - - public function prefetchOne( m : Message ){ - var l = new List(); - l.add( m ); - prefetch(l); - } - - public function prefetch( l : List ){ - if( l.length == 0 ) - return; - select(); - - var a = new Array(); - var h = new IntHash(); - for( m in l ){ - a.push( Single(m.uid) ); - h.set(m.uid,m); - } - var r = cnx.fetchRange( Composite(a), PREFETCH_SECTION, true ); - for( e in r ){ - h.get(e.uid).usePrefetch( e ); - } - } - - public function search( pattern : String, ?fPrefetch : Bool ){ - select(); - - if( fPrefetch == null ) fPrefetch = true; - var r = cnx.search( pattern, true ); - var ret = new List(); - for( uid in r ){ - ret.add( Message.initUid(this,uid) ); - } - if( fPrefetch ) prefetch( ret ); - return ret; - } - - public function sort( criteria : String, ?pattern : String, ?charset : String, ?fPrefetch : Bool ){ - select(); - - if( pattern == null ) pattern = "ALL"; - if( charset == null ) charset = "US-ASCII"; - if( fPrefetch == null ) fPrefetch = true; - - var r = cnx.sort( criteria, pattern, charset, true ); - var ret = new List(); - for( uid in r ){ - ret.add( Message.initUid(this,uid) ); - } - if( fPrefetch ) prefetch( ret ); - return ret; - } - - public function expunge(){ - select(); - cnx.expunge(); - } - - public function add( content : String, ?flags : Flags ){ - cnx.append( name, content, flags ); - } -} diff --git a/haxe/std/mtwin/mail/imap/Message.hx b/haxe/std/mtwin/mail/imap/Message.hx deleted file mode 100644 index 25a91a67f5c88a8f99283b1d21074316dcce61b8..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/mail/imap/Message.hx +++ /dev/null @@ -1,105 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package mtwin.mail.imap; - -import mtwin.mail.Exception; -import mtwin.mail.imap.Tools; -import mtwin.mail.imap.Connection; - -class Message { - - var mailbox : Mailbox; - var id : Int; - public var uid(default,null) : Int; - var flags : Flags; - public var structure(default,null) : BodyStructure; - public var envelope(default,null) : Envelope; - public var internalDate(default,null) : String; - - public static function initUid( mailbox : Mailbox, uid : Int ){ - var m = new Message(); - m.mailbox = mailbox; - m.uid = uid; - return m; - } - - public function new(){ - } - - function select(){ - } - - public function usePrefetch( f : FetchResponse ){ - id = f.id; - uid = f.uid; - flags = f.flags; - structure = f.structure; - envelope = f.envelope; - internalDate = f.internalDate; - } - - public function getSection( ?subId : String, ?el : BodySection , ?markAsReed : Bool ){ - var cnx = mailbox.select(); - if( markAsReed == null ) markAsReed = false; - - var r = cnx.fetchRange( Single(uid), [if( markAsReed ) Body(SubSection(subId,el)) else BodyPeek(SubSection(subId,el))], true ); - if( r.length != 1 ) - throw ImapFetchError; - return r.first().body; - } - - public function markAsDeleted(){ - addFlag("\\Deleted"); - } - - public function delete(){ - markAsDeleted(); - mailbox.expunge(); - } - - public function addFlag( flag : String ){ - var cnx = mailbox.select(); - cnx.storeFlags(Single(uid), [flag], Add, true, false ); - } - - public function removeFlag( flag : String ){ - var cnx = mailbox.select(); - cnx.storeFlags(Single(uid), [flag], Remove, true, false ); - } - - public function copyTo( mb : Mailbox ){ - var cnx = mailbox.select(); - cnx.copy( Single(uid), mb.name, true ); - } - - public function hasFlag( f : String ){ - for( e in flags ){ - if( e == f ) return true; - } - return false; - } - - -} diff --git a/haxe/std/mtwin/mail/imap/Tools.hx b/haxe/std/mtwin/mail/imap/Tools.hx deleted file mode 100644 index ec147ff310a3dd03558f11b2f78ed9b63c79e4f1..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/mail/imap/Tools.hx +++ /dev/null @@ -1,171 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package mtwin.mail.imap; - -import mtwin.mail.imap.Envelope; - -typedef Flags = Array - -enum Section { - Flags; - Uid; - BodyStructure; - Envelope; - InternalDate; - Body(ss:BodySection); - BodyPeek(ss:BodySection); -} - -enum BodySection { - Header; - Mime; - Text; - SubSection(id:String,ss:BodySection); -} - -enum Collection { - Single(i:Int); - Range(s:Int,e:Int); - Composite(l:Array); -} - -/* -enum Pattern { - All; - Answered; - Bcc(s:String); - Before(d:Date); - Body(s:String); - Cc(s:String); - Deleted; - Draft; - Flagged; - From(s:String); - Header(f:String,s:String); - Keyword(s:String); - Larger(s:Int); - New; - Not(p:Pattern); - Old; - On(d:Date); - Or(p1:Pattern,p2:Pattern); - Recent; - Seen; - SentBefore(d:Date); - SentOn(d:Date); - SentSince(d:Date); - Since(d:Date); - Smaller(s:Int); - Subject(s:String); - Text(s:String); - To(s:String); - Uid(c:Collection); - Unanswered; - Undeleted; - Undraft; - Unkeyword(s:String); - Unseen; -} -*/ - -class Tools { - public static function quote( s : String ) : String { - return "\""+s.split("\"").join("\\\"")+"\""; - } - - public static function listToColl( l : List ) : Collection { - var a = new Array(); - for( e in l ) - a.push( Single(e) ); - return Composite(a); - } - - public static function collString( r : Collection ) : String { - return switch( r ){ - case Single(i): Std.string(i); - case Range(s,e): Std.string(s)+":"+Std.string(e); - case Composite(l): - var t = new List(); - for( e in l ) - t.add(collString(e)); - t.join(","); - } - } - - public static function sectionString( a : Array
) : String{ - var r = new List(); - - if( a == null || a.length < 1 ) - return ""; - - for( s in a ){ - r.add( switch( s ){ - case Flags: "FLAGS"; - case Uid: "UID"; - case BodyStructure: "BODYSTRUCTURE"; - case Envelope: "ENVELOPE"; - case InternalDate: "INTERNALDATE"; - case Body(ss): "BODY["+bodySectionString(ss)+"]"; - case BodyPeek(ss): "BODY.PEEK["+bodySectionString(ss)+"]"; - - }); - } - return "("+r.join(" ")+")"; - } - - static function bodySectionString( ss : BodySection ){ - if( ss == null ) - return ""; - - return switch( ss ){ - case Text: "TEXT"; - case Header: "HEADER"; - case Mime: "MIME"; - case SubSection(id,nss): - var t = bodySectionString(nss); - if( id == null || id == "" ) - t; - else if( t == "" ) - id; - else - id+"."+t; - } - } - - public static function addressListToString( l : List
, ?charset : String ){ - if( charset == null ) charset = "utf-8"; - if( l == null ) return ""; - var r = new List(); - for( a in l ){ - if( a.name != null ){ - r.add("\""+mtwin.mail.Tools.headerDecode(a.name,charset).split("\"").join("\\\"")+"\" <"+a.address+">"); - }else{ - r.add(a.address); - } - } - return r.join(", "); - } - -} diff --git a/haxe/std/mtwin/net/Ftp.hx b/haxe/std/mtwin/net/Ftp.hx deleted file mode 100644 index 2b9c2e07ab7ebe88deef89c70cad339e8af183b7..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/net/Ftp.hx +++ /dev/null @@ -1,429 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package mtwin.net; - -import neko.net.Socket; -import neko.net.Host; - -/** - Handles FTP protocol. - - Example: [ - - var ftp = new Ftp("my.ftp.com", 21); - ftp.login("myuser", "mypass"); - ftp.cwd("uploads"); - neko.Lib.println(ftp.list()); - - var fp = neko.io.File.read("localFile.dat", true); - ftp.put(fp, "remoteName.dat"); - fp.close(); - - fp = neko.io.File.write("copyFile.dat", true); - ftp.get(fp, "remoteName2.dat"); - fp.close(); - - ftp.close(); - ] -**/ -class Ftp { - - static var CRLF = "\r\n"; - - public var debug : Bool; - var host : Host; - var port : Int; - var user : String; - var pass : String; - var acct : String; - var socket : Socket; - var srv : Socket; - var passiveMode : Bool; - - /** - Creates a connection to an FTP server. - **/ - public function new( host:String, ?port:Int ){ - debug = false; - passiveMode = true; - this.host = new Host(host); - this.port = if (port != null) port else 21; - socket = new Socket(); - socket.connect(this.host, this.port); - var welcome = getLines(); - } - - /** - Log into FTP server. - **/ - public function login( ?login:String, ?pass:String, ?acct:String ){ - if (login == null) login = "anonymous"; - if (pass == null) pass = ""; - if (acct == null) acct = ""; - this.user = login; - this.pass = pass; - this.acct = acct; - var res = command("USER "+login); - if (res.charAt(0) == "3") res = command("PASS "+pass); - if (res.charAt(0) == "3") res = command("ACCT "+acct); - if (res.charAt(0) != "2") - throw res; - } - - /** - Enable/Disable passive mode (default is on). - **/ - public function setPassiveMode( b:Bool ){ - passiveMode = b; - } - - /** - Returns remote current working directory. - **/ - public function pwd() : String { - var res = command("PWD"); - var re = ~/257 "(.*?)"/; - if (re.match(res)) - return re.matched(1); - throw res; - } - - /** - Change remote current working directory. - **/ - public function cwd( path:String ){ - if (path == ".."){ - voidCommand("CDUP"); - return; - } - if (path == "") - path = "."; - voidCommand("CWD "+path); - } - - /** - Create a remote directory. - **/ - public function createDirectory( path: String ){ - var res = command("MKD "+path); - var re = ~/257 "(.*?)"/; - if (re.match(res)) - return true; - throw res; - } - - /** - Delete remove directory. - **/ - public function removeDirectory( path:String ){ - voidCommand("RMD "+path); - } - - /** - Retrieve remote file size. - **/ - public function fileSize( path:String ) : Int { - voidCommand("TYPE I"); - var res = command("SIZE "+path); - voidCommand("TYPE A"); - if (res.substr(0,3) != "213") - throw res; - res = StringTools.trim(res.substr(3,res.length)); - return Std.parseInt(res); - } - - /** - Rename remote file or directory. - **/ - public function rename( from:String, to:String ) { - var res = command("RNFR "+from); - if (res.charAt(0) != "3") - throw res; - voidCommand("RNTO "+to); - } - - /** - Delete specified file from FTP server. - **/ - public function deleteFile( path:String ) { - var res = command("DELE "+path); - if (res.substr(0,3) != "200" && res.substr(0,3) != "250") - throw res; - } - - /** - Returns a quick listing of specified directory (or current directory if args omited). - **/ - public function list( ?args:String ) : Array { - var cmd = "NLST "+if (args != null) args else ""; - return retrieveLines(cmd); - } - - /** - Returns a detailed listing of specified directory (or current directory if args omited). - **/ - public function detailedList( ?args:String ) : Array { - var cmd = "LIST "+if (args != null) args else ""; - return retrieveLines(cmd); - } - - /** - Reads input and upload its content to remoteName. - **/ - public function put( input:haxe.io.Input, remoteName:String, ?bufSize:Int ){ - if (bufSize == null) - bufSize = 8192; - voidCommand("TYPE I"); - var cnx = transferConnection("STOR "+remoteName); - cnx.output.writeInput(input, bufSize); - cnx.close(); - voidResponse(); - } - - /** - Downloads remote file and write its content in output using neko.io.Output.writeBytes() - **/ - public function get( output:haxe.io.Output, remoteFileName:String, ?bufSize:Int ){ - if (bufSize == null) - bufSize = 8192; - retrieveBytes("RETR "+remoteFileName, function(s:haxe.io.Bytes, n:Int){ output.writeBytes(s,0,n); }, bufSize); - } - - /** - Close connection. - **/ - public function close(){ - command("QUIT"); - socket.close(); - if (srv != null) - srv.close(); - } - - /** - Creates a new FTP connection dedicated to write to specified file. - - Don't forget to close the neko.io.Output when done. - **/ - public function write( remoteName:String ) : haxe.io.Output { - var pwd = pwd(); - var ftp = new Ftp(host.toString(), port); - ftp.login(user, pass, acct); - ftp.cwd(pwd); - ftp.voidCommand("TYPE I"); - var cnx = ftp.transferConnection("STOR "+remoteName); - var out = cnx.output; - var old = out.close; - (cast out).close = function(){ - old(); - ftp.voidResponse(); - ftp.close(); - } - return out; - } - - /** - Creates a new FTP connection dedicated to read specified file. - - Don't forget to close the neko.io.Output when done. - **/ - public function read( remoteFileName:String ) : haxe.io.Input { - var pwd = pwd(); - var ftp = new Ftp(host.toString(), port); - ftp.login(user, pass, acct); - ftp.cwd(pwd); - ftp.voidCommand("TYPE I"); - var cnx = ftp.transferConnection("RETR "+remoteFileName); - var inp = cnx.input; - var old = inp.close; - (cast inp).close = function(){ - old(); - ftp.voidResponse(); - ftp.close(); - } - return inp; - } - - function voidResponse() : String { - var res = getLines().join("\n"); - if (debug) trace("VR< "+res); - if (res.charAt(0) != "2") - throw res; - return res; - } - - function voidCommand( command:String ) : String { - if (debug) trace("VC> "+command); - socket.write(command + CRLF); - return voidResponse(); - } - - function command( command:String ) : String { - if (debug) trace("C> "+command); - socket.write(command + CRLF); - return getLines().pop(); - //return getLine(); - } - - function getLine() : String { - var r = socket.input.readLine(); - if (debug) trace(r); - return r; - } - - function getLines() : Array { - var lines = new Array(); - var line = getLine(); - lines.push(line); - if (line.charAt(3) != '-'){ - return lines; - } - while (true){ - line = getLine(); - if (line.charAt(3) != "-"){ - var code = line.substr(0, 3); - break; - } - else { - lines.push(line); - } - } - return lines; - } - - function getPassivePort() : Int { - var res = command("PASV"); - if (res.substr(0,3) != "227") - throw "Not PASV response : "+res; - var reg = ~/(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/; - if (reg.match(res)){ - var port = (Std.parseInt(reg.matched(5)) << 8) + Std.parseInt(reg.matched(6)); - return port; - } - throw "Unable to activate PASV : "+res; - } - - function transferConnection( cmd:String, ?rest:String ) : Socket { - var cnx = null; - if (passiveMode){ - var tport = getPassivePort(); - cnx = new Socket(); - cnx.connect(host, tport); - if (rest != null) command("REST "+rest); - var res = command(cmd); - // transfer complete there means nothing do do - if (res.substr(0,3) == "226"){ - cnx.close(); - return null; - } - else if (res.charAt(0) != "1") - throw res; - } - else { - if (srv != null) - srv.close(); - srv = createTransferServer(); - if (rest != null) - command("REST "+rest); - var res = command(cmd); - if (res.charAt(0) != "1") - throw res; - cnx = srv.accept(); - } - return cnx; - } - - function retrieveLines( cmd:String, ?rest:String ) : Array { - var res = command("TYPE A"); - var cnx = transferConnection(cmd, rest); - // nothing to retrieve - if (cnx == null) - return []; - var lines = new Array(); - while (true){ - try { - var line = cnx.input.readLine(); - lines.push(line); - } - catch (eof:haxe.io.Eof){ - cnx.close(); - voidResponse(); - return lines; - } - } - cnx.close(); - throw voidResponse(); - return null; - } - - function retrieveBytes( cmd:String, cb:haxe.io.Bytes->Int->Void, ?bufSize:Int, ?rest:String ) { - if (bufSize == null) - bufSize = 8192; - var res = voidCommand("TYPE I"); - var cnx = transferConnection(cmd, rest); - var buf = haxe.io.Bytes.alloc(bufSize); - while (cnx != null){ - var rdd = try cnx.input.readBytes(buf, 0, bufSize) catch(eof:haxe.io.Eof) break; - cb(buf, rdd); - /* - var rdd = 0; - try { - var buf = neko.Lib.makeString(bufSize); - rdd = cnx.input.readBytes(buf, 0, bufSize); - cb(buf, rdd); - } - catch (eof:Eof){ - rdd = 0; - } - if (rdd < bufSize) - break; - */ - } - if (cnx != null) - cnx.close(); - voidResponse(); - } - - function createTransferServer(){ - var sock = null; - var port = 0; - while (true){ - try { - port = 1025 + Std.random(9999); - sock = new Socket(); - sock.bind(socket.host().host, port); - } - catch (e:Dynamic){ - sock.close(); - sock = null; - } - if (sock != null) - break; - } - sock.listen(1); - var hostIp = StringTools.replace(socket.host().host.toString(), ".", ","); - voidCommand("PORT "+hostIp+","+Std.int(port/256)+","+(port%256)); - return sock; - } -} diff --git a/haxe/std/mtwin/templo/Generator.hx b/haxe/std/mtwin/templo/Generator.hx deleted file mode 100644 index dfb491743ff7244a6a64710daa2e8cfad1e74999..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/templo/Generator.hx +++ /dev/null @@ -1,218 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.templo; - -/** - Generates template .neko file. -**/ -class Generator { - - var out : StringBuf; - var htmlBuf : StringBuf; - - public function new(){ - out = new StringBuf(); - htmlBuf = null; - } - - public function toString() : String { - flushHtml(); - - var result = new StringBuf(); - var headercode = ' - String = $loader.String; - Array = $loader.Array; - iter = $loader.iter; - buffer_new = $loader.loadprim("std@buffer_new", 0); - buffer_add = $loader.loadprim("std@buffer_add", 2); - buffer_string = $loader.loadprim("std@buffer_string", 1); - string_split = $loader.loadprim("std@string_split", 2); - - replace = function( h, n, r ){ - var l = string_split(h, n); - if (l[1] == null) - return h; - var res = buffer_new(); - buffer_add(res, l[0]); - l = l[1]; - while (l != null){ - buffer_add(res, r); - buffer_add(res, l[0]); - l = l[1]; - } - return buffer_string(res); - } - - html_escape = function( data ){ - var t = $typeof(data); - if (t == $tint) - return data; - if (t != $tstring) - data = $string(data); - if (data == "") - return data; - data = replace(data, "&", "&"); - data = replace(data, "<", "<"); - data = replace(data, ">", ">"); - data = replace(data, "\\\"", """); - return data; - } - - is_true = function( data ){ - if (data == "") return false; - return $istrue(data); - } - - new_repeat = function( data ){ - var result = $new(null); - result.data = data; - result.index = 0-1; - result.number = 0; - result.first = true; - result.last = false; - result.odd = true; - result.even = false; - if (data.get_length != null) result.size = data.get_length(); - else if (data.length != null) result.size = data.length; - else if (data.size != null) result.size = data.size(); - else result.size = null; - result.next = function(v){ - this.current = v; - this.index = this.index + 1; - this.first = this.index == 0; - this.number = this.number + 1; - this.last = (this.number == this.size); - this.even = (this.number % 2) == 0; - this.odd = (this.even == false); - } - return result; - } - - new_output_buffer = function( parent ){ - var result = $new(null); - result.parent = parent; - result.buf = buffer_new(); - result.add = function(str){ return buffer_add(this.buf, str); } - result.str = function(){ return buffer_string(this.buf); } - return result; - } - - new_context = function( parent, vars ){ - var result = $new(null); - result.parent = parent; - result.__isTemplateContext = true; - if (vars == null){ - result.vars = $new(null); - } - else { - result.vars = vars; - } - result.get = function( field ){ - if ($objfield(this.vars, field)) return $objget(this.vars, field); - if (this.parent == null) return null; - return this.parent.get(field); - } - result.set = function( field, v ){ - $objset(this.vars, field, v); - } - return result; - } - - template = function( macro, params ){ - var __ctx = null; - if (params.__isTemplateContext) { - __ctx = new_context(params, null); - } - else { - __ctx = new_context(null, params); - } - var __glb = __ctx; - var __out = new_output_buffer(null); - -//--- HERE COMES THE TEMPLATE CODE --- -'; - result.add(~/[\r\n]+/g.split(headercode).join("\n")); - result.add(out.toString()); - result.add('//--- END OF TEMPLATE CODE --- - return __out.str(); - } - - $exports.template = template; - '); //' - return result.toString(); - } - - public function writeHtml( str:String ){ - if (htmlBuf == null){ - htmlBuf = new StringBuf(); - } - htmlBuf.add(str); - } - - public function writeCode( str:String ){ - if (htmlBuf != null){ - flushHtml(); - } - out.add("__out.add("+str+");\n"); - } - - public function writeEscapedCode( str:String ){ - if (htmlBuf != null){ - flushHtml(); - } - out.add("__out.add(html_escape("+str+"));\n"); - } - - public function add( code:String ){ - if (htmlBuf != null){ - flushHtml(); - } - out.add(code); - } - - public static function hash( name:String ) : Int { - return untyped __dollar__hash(name.__s); - } - - public function getVar( name:String ) : String { - return "__ctx.get("+hash(name)+")"; - } - - public function setVar( name:String, exp:String ){ - add("__ctx.set("+hash(name)+", "+exp+");\n"); - } - - public function flushHtml(){ - if (htmlBuf == null) return; - var html = htmlBuf.toString(); - html = StringTools.replace(html, "\\", "\\\\"); - html = StringTools.replace(html, "\\'", "\\'"); - html = StringTools.replace(html, "\"", "\\\""); - html = StringTools.replace(html, "\n", "\\n"); - out.add("__out.add(\"" + html + "\");\n"); - htmlBuf = null; - } -} diff --git a/haxe/std/mtwin/templo/Loader.hx b/haxe/std/mtwin/templo/Loader.hx deleted file mode 100644 index 495270c12766cabd908b02600afe886ef846547a..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/templo/Loader.hx +++ /dev/null @@ -1,118 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.templo; - -import neko.Sys; -import neko.io.File; -import neko.FileSystem; - -class Loader { - - public static var BASE_DIR = ""; - public static var TMP_DIR = "/tmp/"; - public static var MACROS = "macros.mtt"; - public static var OPTIMIZED = false; - - public var execute : Dynamic -> String; - - public function new( file:String ) { - if( !OPTIMIZED ) - compileTemplate(file); - execute = loadTemplate(tmpFileId(file)); - } - - static function tmpFileId( path:String ) : String { - var rpath = path; - var temp = path; - if( temp.charAt(0) == "/" ) temp = temp.substr(1, temp.length-1); - temp = temp.split("/").join("__"); - temp = temp.split("\\").join("__"); - temp = temp.split(":").join("__"); - temp = temp.split("____").join("__"); - return TMP_DIR + temp + ".n"; - } - - static function compileTemplate( path:String ) : Void { - if( FileSystem.exists(tmpFileId(path)) ) { - var macroStamp = if( FileSystem.exists(BASE_DIR+MACROS) ) FileSystem.stat(BASE_DIR+MACROS).mtime.getTime() else null; - var sourceStamp = FileSystem.stat(BASE_DIR+path).mtime.getTime(); - var stamp = FileSystem.stat(tmpFileId(path)).mtime.getTime(); - if( stamp >= sourceStamp && (macroStamp == null || macroStamp < stamp) ) - return; - } - var result = 0; - - var macroArg = if (MACROS == null) "" else "-m \""+BASE_DIR+MACROS+"\""; - - if (BASE_DIR == "") - result = Sys.command("temploc -s "+macroArg+" -o \""+TMP_DIR+"\" \""+path+"\" 2> \""+TMP_DIR+"temploc.out\""); - else - result = Sys.command("temploc -s "+macroArg+" -o \""+TMP_DIR+"\" -r \""+BASE_DIR+"\" \""+path+"\" 2> \""+TMP_DIR+"temploc.out\""); - if( result != 0 ) - throw "temploc compilation or "+path+" failed : "+neko.io.File.getContent(Loader.TMP_DIR+"temploc.out"); - } - - static function loadTemplate( nPath:String ) : Dynamic -> String { - return untyped { - var loader = __dollar__loader; - var oldCache = loader.cache; - loader.cache = __dollar__new(oldCache); - loader.String = String; - loader.Array = Array; - loader.iter = function(loop : Dynamic, fnc){ - if (loop == null){ - throw "repeat or foreach called on null value"; - } - if (loop.iterator != null){ - var it : Iterable = loop; - for (v in it.iterator() ) fnc(v); - } - else if (loop.hasNext != null && loop.next != null){ - var it : Iterator = loop; - for (v in it) fnc(v); - } - else { - throw "repeat or foreach called on non iterable object"; - } - }; - var code = loader.loadmodule(nPath.__s, loader); - loader.cache = oldCache; - function(context){ - var wrapCache = loader.cache; - loader.cache = __dollar__new(wrapCache); - var macro = function(path){ - if (mtwin.templo.Loader.OPTIMIZED == false){ - mtwin.templo.Loader.compileTemplate(new String(path)); - } - return loader.loadmodule(mtwin.templo.Loader.tmpFileId(new String(path)).__s, loader); - } - var result = new String(code.template(macro, context)); - loader.cache = wrapCache; - return result; - } - } - } -} diff --git a/haxe/std/mtwin/templo/Macro.hx b/haxe/std/mtwin/templo/Macro.hx deleted file mode 100644 index 5a16eb4ec7132e6729dc10df176d3acf51b43f5d..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/templo/Macro.hx +++ /dev/null @@ -1,170 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.templo; - -class Macro { - - static var R_PARAMS = ~/^([a-zA-Z0-9_]+)\((.*?)\)$/g; - static var R_NOTVAR = ~/[^a-zA-Z0-9_.]/; - static var R_NUM = ~/^[0-9.]+$/; - static var R_VAR = ~/^::(.*?)::$/; - - public var name : String; - var params : Array; - var source : String; - - public function new( n:String, c:String ){ - params = new Array(); - name = n; - if (R_PARAMS.match(name)){ - name = R_PARAMS.matched(1); - if (StringTools.trim(R_PARAMS.matched(2)) != ""){ - var i = 0; - for (param in R_PARAMS.matched(2).split(",")) - params[i++] = StringTools.trim(param); - } - } - source = c; - } - - dynamic public static function debug(x:String){} - - public function expand( p:Array ) : String { - if (params.length != p.length){ - throw "macro "+name+" takes "+params.length+" arguments"+params.toString()+"\ngot: "+p.toString(); - } - - var hashReplace = new Hash(); - - var res = source; - for (i in 0...params.length){ - // Extract raw parameters ::myparam:: for later replacement, - // this is faster than trying to parse simple raw replacement like ::myparam::, - // an additional benefit is that this little replacement prevent the macro system from - // becoming mad when a call parameter references a variable with the same name as one - // of the macro arguments name (ex: macro(content) $$macro(::content::foo bar baz)) - var replace = new EReg("::\\s*?"+params[i]+"\\s*?::", "g"); - var key = "##__MP__"+i+"__##"; - hashReplace.set(key, p[i]); - res = replace.replace(res, key); - // old - // res = replace.replace(res, StringTools.replace(p[i], "$", "$$")); - - // work on complex expressions ::myparam + 10 + 'foo bar baz':: - var isNum = R_NUM.match(p[i]); - var isVar = (R_VAR.match(p[i]) && R_VAR.matched(1).indexOf("::") == -1); - var pos = res.indexOf("::", 0); - while (pos != -1){ - var end = res.indexOf("::", pos+2); - if (end == null){ - neko.Lib.print(res); - throw "Unable to find matching ::"; - } - var exp = res.substr(pos+2, end-pos-2); - var rep = replaceArgumentInExpression(exp, params[i], p[i], isVar, isNum); - res = res.substr(0, pos+2) + rep + res.substr(end, res.length - end); - pos = end - exp.length + rep.length + 2; - pos = res.indexOf("::", pos); - } - // work on mt:*="" attributes - var param = params[i]; - var paramValue = p[i]; - var reg = ~/(mt:[a-z-]+=)(["'])(.*?)(\2)/sm; - res = reg.customReplace(res, function(r){ - return r.matched(1) + r.matched(2) + replaceArgumentInExpression(r.matched(3), param, paramValue, isVar, isNum) + r.matched(4); - }); - } - - // Replace raw parameters - for (k in hashReplace.keys()) - res = StringTools.replace(res, k, hashReplace.get(k)); - return res; - } - - static function replaceArgumentInExpression( exp:String, paramName:String, value:String, isVar:Bool, isNum:Bool ) : String { - var repl = if (isNum) value - else if (isVar) "(" + value.substr(2, value.length-4) + ")" - else stringArgumentToExpressionCompound(value); - var res = exp; - var pos = res.indexOf(paramName, 0); - while (pos != -1){ - var end = pos + paramName.length; - var before = if (pos > 0) res.charAt(pos-1) else " "; - var after = if (end < res.length) res.charAt(end) else " "; - if (R_NOTVAR.match(before) && (after == "." || R_NOTVAR.match(after))){ - res = res.substr(0, pos) + repl + res.substr(end, res.length-end); - end = end - paramName.length + repl.length; - } - pos = res.indexOf(paramName, end+1); - } - return res; - } - - static function xmlToString( xml:Xml ) : String { - if (xml.nodeType != Xml.Element){ - return xml.nodeValue; - } - var res = new StringBuf(); - res.add("<"); - res.add(xml.nodeName); - for (i in xml.attributes()){ - res.add(" "); - res.add(i); - res.add("=\""); - res.add(StringTools.htmlEscape(xml.get(i))); - res.add("\""); - } - if (xml.firstChild() != null){ - res.add(">"); - for (x in xml) - res.add(xmlToString(x)); - res.add(""); - } - else { - res.add("/>"); - } - return res.toString(); - } - - static function stringArgumentToExpressionCompound( str:String ) : String { - var res = StringTools.replace(str,"'","\\'"); - var pos = res.indexOf("::",0); - while ( pos != -1 ){ - var end = res.indexOf("::", pos+2); - if (end == -1) - throw "Malformed expression '"+str+"'"; - var left = res.substr(0, pos); - var data = res.substr(pos+2, end-pos-2); - var right = res.substr(end+2, res.length-end-2); - res = left + "\'+" + data + "+\'" + right; - pos = end + 2; - pos = res.indexOf("::",pos); - } - return "(\'" + res + "\')"; - } -} diff --git a/haxe/std/mtwin/templo/Main.hx b/haxe/std/mtwin/templo/Main.hx deleted file mode 100644 index 2c56d25999bb4264f944b073e2f7c8c264ab9ae6..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/templo/Main.hx +++ /dev/null @@ -1,112 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package mtwin.templo; - -class Main { - - static var VERSION = "0.2 -- haxe flavoured"; - static var USAGE = "Usage: temploc -o -m -r \n"; - static var args : Array; - static var files : List; - static var silence : Bool = false; - - static function parseArgs(){ - files = new List(); - args = neko.Sys.args(); - var i = 0; - var macros = null; - while (i < args.length){ - var arg = args[i]; - switch (arg){ - case "-h": - throw USAGE; - - case "-s": - silence = true; - - case "-r": - var value = args[i+1]; - if (value.charAt(value.length-1) == "/"){ - value = value.substr(0, value.length-1); - } - Loader.BASE_DIR = value; - ++i; - - case "-o": - var value = args[i+1]; - if (value.charAt(value.length-1) != "/"){ - value = value + "/"; - } - Loader.TMP_DIR = value; - ++i; - - case "-m": - i++; - macros = args[i]; - mtwin.templo.Preprocessor.registerMacroFile(macros); - - default: - files.push(arg); - } - ++i; - } - if( macros != null ) - files.remove(macros); - if (args.length == 0){ - neko.Lib.print("temploc - v"+VERSION+"\n"); - neko.Lib.print(USAGE); - } - else if (files.length == 0){ - neko.Lib.print("temploc - v"+VERSION+"\n"); - neko.Lib.print(USAGE); - } - else if (Loader.BASE_DIR == null){ - var sampleFile = Lambda.array(files)[0]; - var pslah = sampleFile.lastIndexOf("/",sampleFile.length); - var aslah = sampleFile.lastIndexOf("/",sampleFile.length); - var pos = Std.int(Math.max(pslah, aslah)); - if (pos == -1){ - neko.Lib.print("missing template BASE_DIR\n"); - throw USAGE; - } - Loader.BASE_DIR = sampleFile.substr(0,pos); - } - } - - static function mtime(file:String) : Float { - return neko.FileSystem.stat(file).mtime.getTime(); - } - - static function main(){ - Loader.MACROS = null; - parseArgs(); - for (file in files){ - file = StringTools.replace(file, Loader.BASE_DIR+"/", ""); - if (!silence) neko.Lib.print("* "+file+"..."); - mtwin.templo.Template.fromFile(file); - if (!silence) neko.Lib.print(" done\n"); - } - } -} diff --git a/haxe/std/mtwin/templo/Parser.hx b/haxe/std/mtwin/templo/Parser.hx deleted file mode 100644 index b077ccf895f83ed4649f5e564bb5bde2eff00afb..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/templo/Parser.hx +++ /dev/null @@ -1,731 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.templo; - -class Parser { - - static var REGEX_EXP = ~/^([a-zA-Z][A-Za-z0-9_]{0,})[ \n\r\t]+(.*?)$/gsm; - static var REGEX_DXP = ~/::([^:].*?)::/gsm; - - static var MT = "mt"; - static var MT_IF = "mt:if"; - static var MT_ELSEIF = "mt:elseif"; - static var MT_ELSE = "mt:else"; - static var MT_CONTENT = "mt:content"; - static var MT_REPLACE = "mt:replace"; - static var MT_FOREACH = "mt:foreach"; - static var MT_ATTRIBUTES = "mt:attr"; - static var MT_SET = "mt:set"; - static var MT_FILL = "mt:fill"; - static var MT_OMIT_TAG = "mt:omit-tag"; - static var MT_MACRO = "mt:macro"; - static var MT_USE = "mt:use"; - - static var XHTML_EMPTY = ["area","base","basefont","br","col","frame","hr","img","input","isindex","link","meta","param"]; - static var XHTML_ATTRS = ["compact","nowrap","ismap","declare","noshade","checked","disabled","readonly","multiple","selected","noresize","defer"]; - - var out : mtwin.templo.Generator; - var xhtmlMode : Bool; - - public function new( ?isXhtml:Bool ){ - xhtmlMode = (isXhtml == true); - out = new mtwin.templo.Generator(); - } - - public function parse( xml:Xml ) : String { - parseNode(xml); - return out.toString(); - } - - function parseNode( xml:Xml ){ - switch (untyped xml.nodeType){ - case Xml.Document: - for (child in xml) parseNode(child); - case Xml.CData: - parseCDATA(xml); - case Xml.Comment: - parseComment(xml); - case Xml.Element: - parseElement(xml); - default: - echoString(xml.toString()); - } - } - - function parseElement( xml:Xml ){ - var mtSet = extractAttribute(xml, MT_SET); - if (mtSet != null){ - var incExp = ~/^([a-zA-Z_][a-zA-Z0-9_]*?)\s*?([\+\-\/*%])=\s*?(.*?)$/; // */ - if (incExp.match(mtSet)){ - var dest = StringTools.trim(incExp.matched(1)); - var op = incExp.matched(2); - var exp = parseExpression(StringTools.trim(incExp.matched(3))); - out.setVar(dest, out.getVar(dest)+" "+op+" ("+exp+")"); - } - else { - var parts = Lambda.array(mtSet.split("=")); - var dest = StringTools.trim(parts.shift()); - var exp = parseExpression(StringTools.trim(parts.join("="))); - out.setVar(dest, "("+exp+")"); - } - return; - } - - var mtUse = extractAttribute(xml, MT_USE); - if (mtUse != null){ - // ensure template is parsed (beware of cycle) - /* - if (!mtwin.templo.Template.compiledFiles.exists(mtUse)){ - mtwin.templo.Template.compiledFiles.set(mtUse, true); - var f = mtwin.templo.Template.fromFile(mtUse); - } - */ - out.add("tmp = "+out.getVar("__content__")+";\n"); - out.add("__out = new_output_buffer(__out);\n"); - parseNode(xml); - out.setVar("__content__", "__out.str()"); - out.add("__out = __out.parent;\n"); - - if (StringTools.endsWith(mtUse, ".mtt")) - neko.Lib.println("WARNING: templo ::use:: changed the following use may be incorrect : '"+mtUse+"'"); - //throw parseExpression(mtUse); - out.add("mcr = macro("+parseExpression(mtUse)+");\n"); - out.add("__out.add(mcr.template(macro, __ctx));\n"); - out.setVar("__content__", "tmp"); - return; - } - - var mtFill = extractAttribute(xml, MT_FILL); - if (mtFill != null){ - out.add("__out = new_output_buffer(__out);\n"); - parseNode(xml); - out.setVar(StringTools.trim(mtFill), "String.new(__out.str())"); - out.add("__out = __out.parent;\n"); - return; - } - - var mtIf = extractAttribute(xml, MT_IF); - if (mtIf != null){ - out.add("if (is_true("+parseExpression(mtIf)+")){\n"); - parseNode(xml); - out.add("}\n"); - return; - } - - var mtElseIf = extractAttribute(xml, MT_ELSEIF); - if (mtElseIf != null){ - out.add("else if (is_true("+parseExpression(mtElseIf)+")){\n"); - parseNode(xml); - out.add("}\n"); - return; - } - - var mtElse = extractAttribute(xml, MT_ELSE); - if (mtElse != null){ - out.add("else {\n"); - parseNode(xml); - out.add("}\n"); - return; - } - - var mtForeach = extractAttribute(xml, MT_FOREACH); - if (mtForeach != null){ - var o = extractExpressionTarget(mtForeach); - if (o.target == null) - throw "repeat/foreach requires two parameters (expression was '"+mtForeach+"')"; - out.add("var loop = "+parseExpression(o.exp)+";\n"); - out.add("__ctx.vars.repeat_"+o.target+" = new_repeat(loop);\n"); - out.add("iter(loop, function(__item){\n"); - out.add("__ctx.vars.repeat_"+o.target+".next(__item);\n"); - out.setVar(o.target, "__item"); - parseNode(xml); - out.add("});\n"); - return; - } - - var mtReplace = extractAttribute(xml, MT_REPLACE); - if (mtReplace != null){ - echoExpression(mtReplace); - return; - } - - var mtOmitTag = extractAttribute(xml, MT_OMIT_TAG); - if (mtOmitTag == null && xml.nodeName == MT){ - mtOmitTag = "true"; - } - - var mtAttributes = extractAttribute(xml, MT_ATTRIBUTES); - var mtContent = extractAttribute(xml, MT_CONTENT); - - var hasContent = (mtContent != null || xml.firstChild() != null); - - var xhtmlEmpty = isXHTMLEmptyTag(xml.nodeName); - if (xhtmlMode && hasContent && xhtmlEmpty){ - hasContent = false; - } - if (xhtmlMode && !hasContent && !xhtmlEmpty){ - hasContent = true; - } - - if (mtOmitTag == null){ - out.writeHtml("<"+xml.nodeName); - if (mtAttributes != null){ - doMtAttributes(mtAttributes, xml); - } - else { - echoAttributes(xml); - } - if (hasContent){ - out.writeHtml(">"); - } - else { - out.writeHtml("/>"); - return; - } - } - - if (mtContent != null){ - echoExpression(mtContent); - } - else { - for (child in xml) - parseNode(child); - } - - if (mtOmitTag == null && hasContent){ - out.writeHtml(""); - } - } - - function doMtAttributes( att:String, xml:Xml ){ - var overwritten = new Hash(); - var parts = Lambda.array(splitExpression(att)); - for (i in 0...parts.length){ - var x = StringTools.trim(parts[i]); - var o = extractExpressionTarget(x); - var exp = parseExpression(o.exp); - if (isBooleanAttribute(o.target)){ - out.add("if ("+exp+"){\n"); - out.add("__out.add(\" "+o.target+"=\\\""+o.target+"\\\"\");\n"); - out.add("}"); - } - else { - out.add("var value = "+exp+";\n"); - out.add("if (value != false && value != null){\n"); - out.add("__out.add(\" "+o.target+"=\\\"\");\n"); - out.add("__out.add(html_escape(value));\n"); - out.add("__out.add(\"\\\"\");\n"); - out.add("}"); - } - overwritten.set(o.target, true); - } - - for (field in xml.attributes()){ - var attName = field; - if (!overwritten.exists(attName)){ - var attVal = xml.get(field); - if (attVal != null){ // mt attributes - out.add("__out.add(\" "+attName+"=\\\"\");\n"); - echoString(attVal); - out.add("__out.add(\"\\\"\");\n"); - } - } - } - } - - function splitExpression( exp:String ) : List { - var result = new List(); - var start = 0; - var len = exp.length; - var i = 0; - var inString = false; - var inDString = false; - while( i < len ){ - var c = exp.charAt(i); - if (inString || inDString){ - if ( c == "\\" && ( (inString && exp.charAt(i+1) == "'") || (inDString && exp.charAt(i+1) == "\"") ) ) - i = i + 1; - else if (inString && c == "'") - inString = false; - else if (inDString && c == "\"") - inDString = false; - } - else if (c == "'") - inString = true; - else if (c == "\"") - inDString = true; - else if (c == ";"){ - result.push(exp.substr(start, i-start)); - start = i+1; - } - i++; - } - if (start < len){ - result.push(exp.substr(start, len-start)); - } - return result; - } - - function echoAttributes( xml:Xml ){ - if (xml == null) - return; - for (att in xml.attributes()){ - var value = xml.get(att); - if (value == null) - continue; - out.writeHtml(" "+att); - out.writeHtml("=\""); - echoString( StringTools.replace(value, "\"", """) ); - out.writeHtml("\""); - } - } - - function parseComment( xml:Xml ){ - out.writeHtml(""); - } - - function echoExpression( exp:String ){ - exp = StringTools.trim(exp); - if (exp.indexOf("raw ", 0) == 0){ - out.writeCode(parseExpression(exp.substr(4, exp.length-4))); - } - else { - out.writeEscapedCode(parseExpression(exp)); - } - } - - function echoString( str:String ){ - var source = str; - while (REGEX_DXP.match(source)){ - var pos = REGEX_DXP.matchedPos(); - if (pos.pos > 0){ - out.writeHtml(source.substr(0,pos.pos)); - } - echoExpression(StringTools.htmlUnescape(REGEX_DXP.matched(1))); - source = source.substr(pos.pos + pos.len, source.length - pos.pos - pos.len); - } - if (source.length > 0){ - out.writeHtml(source); - } - } - - function parseCDATA( xml:Xml ){ - out.writeHtml("" + cdataSrc + ""; - var cdataxml = null; - try { - cdataxml = Xml.parse(cdataSrc); - if (cdataxml == null) - throw "Unable to parse CDATA content"; - } - catch (e:Dynamic){ - throw { error:e, xmlsource:cdataSrc, cdatasource:xml.nodeValue }; - } - restoreCDATAHtmlEncoding(cdataxml); - parseNode(cdataxml); - out.writeHtml("]]>"); - } - - function isBooleanAttribute( attName:String ) : Bool { - if (!xhtmlMode) - return false; - for (f in XHTML_ATTRS){ - if (f == attName) return true; - } - return false; - } - - function isXHTMLEmptyTag( tag:String ) : Bool { - if (!xhtmlMode) - return false; - for (f in XHTML_EMPTY){ - if (f == tag) return true; - } - return false; - } - - static function splitArguments( str:String ) : List { - var res = new List(); - var arg = ""; - var len = str.length; - var cto = 0; - var string = false; - var dstring = false; - var i = 0; - while (i < len){ - var c = str.charAt(i); - if (c == "("){ - cto++; - } - else if (c == ")"){ - cto--; - } - - if (c == "\\"){ - arg += c; - arg += str.charAt(i+1); - i += 2; - continue; - } - - if (c == "\"" && !string) - dstring = !dstring; - - if (c == "'" && !dstring) - string = !string; - - if (c == "," && cto == 0 && !string && !dstring){ - res.add(StringTools.trim(arg)); - arg = ""; - } - else { - arg += c; - } - i++; - } - if (arg != ""){ - res.add(StringTools.trim(arg)); - } - return res; - } - - static function findEndOfArray( str:String, pos:Int ) : { end:Int, n:Int } { - var len = str.length; - var n = 0; - var ctopen = 0; - for (i in (pos+1)...(len)){ - var c = str.charAt(i); - if (c == "," && ctopen == 0){ - n++; - } - if (c == "["){ - ctopen++; - } - else if (c == "]"){ - if (ctopen == 0){ - if (StringTools.trim(str.substr(pos+1, i-pos-1)) != "") - n++; - return { end:i-1, n:n }; - } - else { - ctopen--; - } - } - } - return { end:-1, n:null }; - } - - static function findEndOfBracket( str:String, pos:Int ) : Int { - var len = str.length; - var ctopen = 0; - for (i in (pos+1)...(len)){ - var c = str.charAt(i); - if (c == "("){ - ctopen++; - } - else if (c == ")"){ - if (ctopen == 0){ - return i-1; - } - else { - ctopen--; - } - } - } - return -1; - } - - static function extractAttribute( xml:Xml, id:String ) : String { - var res = xml.get(id); - if (res == null){ - return null; - } - xml.set(id, null); - return StringTools.trim(res.split(""").join("\"").split("&").join("&")); - } - - static function restoreCDATAHtmlEncoding( xml:Xml ){ - if (xml.nodeType == Xml.Element || xml.nodeType == Xml.Document) - for (x in xml) restoreCDATAHtmlEncoding(x); - else - xml.nodeValue = StringTools.htmlUnescape(xml.nodeValue); - } - - static function extractExpressionTarget( exp:String ) : { target:String, exp:String } { - if (REGEX_EXP.match(exp)){ - return {target:REGEX_EXP.matched(1), exp:REGEX_EXP.matched(2)}; - } - return {target:null, exp:exp}; - } - - static function isExpressionKeyword( varName:String ) : Bool { - return varName == "true" || varName == "false" || varName == "null" || varName == "if" || varName == "else"; - } - - // Quick and 'dirty' expression transformer, - // This function transform a template expression into a neko compliant expression. - public static function parseExpression( exp:String ) : String { - var r_num = ~/[0-9]+/; - var r_digit = ~/[0-9.]+/; - var r_var = ~/[\$a-zA-Z0-9_]/; - var r_op = ~/[!+-\/*<>=&|%]+/; //*/ - var result = new StringBuf(); - var states = { none:0, string:1, dstring:2, variable:3, num:4, member:5, array:6 }; - var str = StringTools.trim(exp); - var state = states.none; - var mark = 0; - var getter = false; - var len = str.length; - var i = 0; - while (i < len+1){ - var skip = false; - var c = if (i == len) "\n" else str.charAt(i); - var n = if (i+1 >= len) "\n" else str.charAt(i+1); - switch (state){ - case states.none: - if (r_num.match(c)){ - state = states.num; - } - else if (c == "\""){ - result.add("String.new("); - state = states.dstring; - } - else if (c == "'"){ - result.add("String.new(\""); - state = states.string; - skip = true; - } - else if (c == "."){ - state = states.member; - if (i < len && str.charAt(i+1) == "_"){ - result.add(".get"); - getter = true; - skip = true; - } - } - else if (r_op.match(c)){ - if (c == '!' && n != "="){ - result.add("false == "); - skip = true; - } - else if (c == "&" && n != "&" && n != "=" && len-i >= 5){ - if (str.substr(i,5) == "&"){ - result.add("&"); i+=4; skip = true; - } - if (str.substr(i,4) == "<"){ - result.add("<"); i+=3; skip = true; - } - else if (str.substr(i,4) == ">"){ - result.add(">"); i+=3; skip = true; - } - } - } - else if (c == "("){ - var end = findEndOfBracket(str, i); - if (end == -1) - throw "Missing end ) in expression '"+exp+"'"; - var sub = str.substr(i+1, end-i); - result.add("("); - result.add(parseExpression(sub)); - i = end; - skip = true; - } - else if (c == "["){ - var def = findEndOfArray(str, i); - if (def.end == -1) - throw "Missing end ] in expression '"+exp+"'"; - var sub = str.substr(i+1, def.end-i); - result.add("Array.new1($array("); - result.add(parseExpression(sub)); - result.add("), "); - result.add(def.n); - i = def.end; - skip = true; - } - else if (c == "]"){ - result.add(")"); - skip = true; - } - else if (r_var.match(c)){ - state = states.variable; - mark = i; - } - - case states.string: - if (c == "\\" && n == "'"){ - result.add("'"); - skip = true; - ++i; - } - else if (c == "\\" && n == "\""){ - skip = true; - } - else if (c == "'"){ - state = states.none; - result.add("\")"); - skip = true; - } - - case states.dstring: - if (c == "\\" && n == "\""){ - result.add("\\\""); - skip = true; - ++i; - } - else if (c == "\\" && n == "'"){ - skip = true; - } - else if (c == "\""){ - state = states.none; - result.add("\")"); - skip = true; - } - - case states.variable: - if (r_var.match(c)){ - } - else if (c == "."){ - var variable = str.substr(mark, i-mark); - if (variable == "repeat"){ - result.add("__ctx.vars.repeat_"); - state = states.member; - skip = true; - } - else { - result.add("__ctx.get("); - result.add(Generator.hash(variable)); - result.add(")"); - state = states.member; - if (i < len && str.charAt(i+1) == "_"){ - result.add(".get"); - getter = true; - skip = true; - } - } - } - else { - var variable = str.substr(mark, i-mark); - if (isExpressionKeyword(variable)){ - result.add(variable); - } - else if (c == "["){ - result.add("__ctx.get("); - result.add(Generator.hash(variable)); - result.add(")"); - var def = findEndOfArray(str, i); - if (def.end == -1) - throw "Missing end ] in expression '"+exp+"'"; - var sub = str.substr(i+1, def.end-i); - result.add("["); - result.add(parseExpression(sub)); - result.add("]"); - i = def.end + 1; - skip = true; - state = states.none; - } - else { - result.add("__ctx.get("); - result.add(Generator.hash(variable)); - result.add(")"); - } - state = states.none; - } - - case states.num: - if (!r_digit.match(c)){ - state = states.none; - } - - case states.member: - if (r_var.match(c)){ - } - else if (c == "("){ - if (getter){ - result.add("()"); - getter = false; - } - var end = findEndOfBracket(str, i); - if (end == -1) - throw "Missing end bracket in expression '"+exp+"'"; - var sub = str.substr(i+1, end-i); - var argStr = Lambda.array(splitArguments(sub)); - for (j in 0...argStr.length){ - argStr[j] = parseExpression(argStr[j]); - } - result.add("("); - result.add(argStr.join(",")); - result.add(")"); - i = end+1; skip = true; - } - else if (c == "."){ - if (getter){ - result.add("()"); - getter = false; - } - if (i < len && str.charAt(i+1) == "_"){ - getter = true; - result.add(".get"); - skip = true; - } - } - else if (c == "["){ - if (getter){ - result.add("()"); - getter = false; - } - var def = findEndOfArray(str, i); - if (def.end == -1) - throw "Missing end ] in expression '"+exp+"'"; - var sub = str.substr(i+1, def.end-i); - result.add("["); - result.add(parseExpression(sub)); - result.add("]"); - i = def.end + 1; - skip = true; - state = states.none; - } - else { - if (getter){ - result.add("()"); - getter = false; - } - state = states.none; - if (i != len){ - i--; - } - skip = true; - } - } - if (!skip && i < len && state != states.variable){ - result.add(str.charAt(i)); - } - ++i; - } - return result.toString(); - } -} diff --git a/haxe/std/mtwin/templo/Preprocessor.hx b/haxe/std/mtwin/templo/Preprocessor.hx deleted file mode 100644 index 27ca15c3343c7a2b99441602e7228996cd6aa05e..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/templo/Preprocessor.hx +++ /dev/null @@ -1,260 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.templo; - -class Preprocessor { - - static var r_if = ~/::if([^_a-zA-Z0-9].*?)::/gs; - static var r_elseif = ~/::elseif([^_a-zA-Z0-9].*?)::/gs; - static var r_else = ~/::else\s*?::/; - static var r_foreach = ~/::foreach\s+(.*?)::/gs; - static var r_fill = ~/::fill\s+(.*?)::/gs; - static var r_use = ~/::use\s+(.*?)::/gs; - static var r_set = ~/::set\s+(.*?)::/gs; - - static var r_cond = ~/::cond\s+(.*?)::/gs; - static var r_repeat = ~/::repeat\s+(.*?)::/gs; - static var r_attr = ~/::attr\s+(.*?)::/gs; - - static var r_cdata = ~//g; - static var r_comment = ~//g; - static var r_macroCall = ~/\$\$([a-zA-Z0-9_]+)\(/g; - static var r_print = ~/::(.*?)::/g; - - public static var macros : Hash = new Hash(); - public static var macroFileStamp : Float; - - public static function process( str:String ) : String { - if (macroFileStamp == null && Loader.MACROS != null) - registerMacroFile(Loader.BASE_DIR+Loader.MACROS); - - var res = str; - res = escapeCdata1(res); - res = expandMacros(res); - res = res.split("::else::").join(""); - res = res.split("::end::").join(""); - while (r_if.match(res)){ - res = res.split(r_if.matched(0)).join(""); - } - while (r_elseif.match(res)){ - res = res.split(r_elseif.matched(0)).join(""); - } - while (r_foreach.match(res)){ - res = res.split(r_foreach.matched(0)).join(""); - } - while (r_fill.match(res)){ - res = res.split(r_fill.matched(0)).join(""); - } - while (r_set.match(res)){ - res = res.split(r_set.matched(0)).join(""); - } - while (r_use.match(res)){ - res = res.split(r_use.matched(0)).join(""); - } - res = escapeComments(res); - - while (r_cond.match(res)){ - res = res.split(r_cond.matched(0)).join("mt:if=\""+quote(r_cond.matched(1))+"\""); - } - while (r_repeat.match(res)){ - res = res.split(r_repeat.matched(0)).join("mt:foreach=\""+quote(r_repeat.matched(1))+"\""); - } - while (r_attr.match(res)){ - res = res.split(r_attr.matched(0)).join("mt:attr=\""+quote(r_attr.matched(1))+"\""); - } - res = unescapeCdata1(res); - res = escapePrints(res); - return trimExtraSpaces("" + res + ""); - } - - static function trimExtraSpaces( str:String ) : String { - var reg = null; - - reg = ~/^\s+()\s*?\n/gm; - while (reg.match(str)) str = StringTools.replace(str, reg.matched(0), reg.matched(1)); - - reg = ~/^\s+(<\/?mt>)\s*?\n/gm; - while (reg.match(str)) str = StringTools.replace(str, reg.matched(0), reg.matched(1)); - - reg = ~/^\s+(<mt mt:[a-z]+="[^"]+"\/?>)\s*?\n/gm; - while (reg.match(str)) str = StringTools.replace(str, reg.matched(0), reg.matched(1)); - - reg = ~/^\s+(<\/?mt>)\s*?\n/gm; - while (reg.match(str)) str = StringTools.replace(str, reg.matched(0), reg.matched(1)); - - reg = ~/\s+((<|<)mt mt:(set)="[^"]+"\/?(>|>))\s+/g; - while (reg.match(str)) str = StringTools.replace(str, reg.matched(0), reg.matched(1)); - - reg = ~/()\s+(<\/?mt)/g; - while (reg.match(str)) str = StringTools.replace(str, reg.matched(0), reg.matched(1)+reg.matched(2)); - - reg = ~/(<mt mt:[^=]+="[^"]+"\/?>)\s+(<\/?mt)/g; - while (reg.match(str)) str = StringTools.replace(str, reg.matched(0), reg.matched(1)+reg.matched(2)); - - reg = ~/(<\/mt>)\s+(<\/?mt)/g; - while (reg.match(str)) str = StringTools.replace(str, reg.matched(0), reg.matched(1)+reg.matched(2)); - - return str; - } - - public static function expandMacros( str:String ) : String { - var res = str; - while (r_macroCall.match(res)){ - var macroName = r_macroCall.matched(1); - var macroCallPos = r_macroCall.matchedPos(); - var i = macroCallPos.pos + macroCallPos.len; - var args = new Array(); - var nargs = 0; - var startArg = i; - var endArg = -1; - var oAccos = 0; - var oParas = 0; - var end = 0; - var forceArg = false; - while (i < res.length){ - var c = res.charAt(i); - if (c == "("){ - if (oAccos == 0){ - oParas++; - ++i; - continue; - } - } - if (c == ")" && oParas > 0){ - oParas--; - ++i; - continue; - } - if (c == "{"){ - if (oAccos == 0){ - startArg = i+1; - forceArg = true; - } - oAccos++; - } - if (c == "}"){ - if (oAccos > 0){ - oAccos--; - if (oAccos == 0){ endArg = i; } - } - } - if (oAccos == 0 && oParas == 0 && (c == "," || c == ")")){ - if (endArg == -1){ endArg = i; } - var p = res.substr(startArg, endArg - startArg); - p = StringTools.trim(p); - if (p.length > 0 || forceArg){ - args[ nargs ] = p; - nargs++; - } - startArg = i+1; - endArg = -1; - forceArg = false; - } - if (oAccos == 0 && (c == ")")){ - end = i+1; - break; - } - ++i; - } - var mcr = macros.get(macroName); - if (mcr == null){ - throw "Unknown macro "+macroName; - } - var src = res.substr(r_macroCall.matchedPos().pos, end - r_macroCall.matchedPos().pos); - res = res.split(src).join(mcr.expand(args)); - } - return res; - } - - public static function registerMacroFile( path:String ){ - if (!neko.FileSystem.exists(path)){ - throw "Macro file "+path+" does not exists"; - } - macroFileStamp = neko.FileSystem.stat(path).mtime.getTime(); - registerMacros(neko.io.File.getContent(path)); - } - - public static function registerMacros( src:String ){ - src = StringTools.replace(src, "\r\n", "\n"); - src = StringTools.replace(src, "\r", "\n"); - var rFind = ~/([^\0]*?)<\/macro>/g; //" - while (rFind.match(src)){ - var pos = rFind.matchedPos(); - var name = rFind.matched(1); - var content = rFind.matched(2); - var macro = new mtwin.templo.Macro(name, content); - mtwin.templo.Preprocessor.macros.set( macro.name, macro ); - var end = pos.pos + pos.len; - src = src.substr(end, src.length - end); - } - } - - static function quote( str:String ) : String { - return str.split("&").join("&").split("\"").join("""); - } - - static function escapeCdata1( str:String ) : String { - var res = str; - while (r_cdata.match(res)){ - var pos = r_cdata.matchedPos(); - var cdata = r_cdata.matched(1); - cdata = cdata.split("&").join("&").split("<").join("<").split(">").join(">"); - res = res.substr(0, pos.pos) + "" + res.substr(pos.pos+pos.len, res.length-(pos.pos+pos.len)); - } - return res; - } - - static function escapeComments( str:String ) : String { - var res = str; - while (r_comment.match(res)){ - var pos = r_comment.matchedPos(); - var comment = r_comment.matched(1); - comment = comment.split("&").join("&").split("<").join("<").split(">").join(">"); - res = res.substr(0, pos.pos) + "" + res.substr(pos.pos+pos.len, res.length-(pos.pos+pos.len)); - } - return res; - } - - static function unescapeCdata1( str:String ) : String { - var res = str.split("").join("]]>"); - res = escapeCdata1(res); - res = res.split("").join("]]>"); - res = res.split("").join("-->"); - return res; - } - - static function escapePrints( str:String ) : String { - var buf = new StringBuf(); - while (r_print.match(str)){ - var pos = r_print.matchedPos(); - buf.add(str.substr(0,pos.pos)); - buf.add(StringTools.htmlEscape(r_print.matched(0))); - str = str.substr(pos.pos+pos.len, str.length); - } - buf.add(str); - return buf.toString(); - } -} diff --git a/haxe/std/mtwin/templo/Template.hx b/haxe/std/mtwin/templo/Template.hx deleted file mode 100644 index 261b9a549704c357199ef790d929206472922efa..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/templo/Template.hx +++ /dev/null @@ -1,181 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.templo; -import haxe.Md5; - -class Template { - - static var VERSION = "0.9.0"; - - public static var compiledFiles : Hash = new Hash(); - public var execute : Dynamic -> String; - - public function new( file:String ){ - execute = if (Loader.OPTIMIZED) loadTemplate(nekoBin(file)) else fromFile(file); - } - - static function nekoId( path:String ) : String { - var rpath = path; - var temp = path; - if (temp.charAt(0) == "/") temp = temp.substr(1, temp.length-1); - temp = StringTools.replace(temp, "/", "__"); - temp = StringTools.replace(temp, "\\", "__"); - temp = StringTools.replace(temp, ":", "__"); - temp = StringTools.replace(temp, "____", "__"); - return temp; - } - - static function nekoBin( path:String ) : String { - return Loader.TMP_DIR + nekoId(path) + ".n"; - } - - static function nekoSrc( path:String ) : String { - return Loader.TMP_DIR + nekoId(path) + ".neko"; - } - - public static function fromFile( path:String ) : Dynamic -> String { - if (Loader.OPTIMIZED) - return loadTemplate(nekoBin(path)); - if (Loader.MACROS != null && mtwin.templo.Preprocessor.macroFileStamp == null) - mtwin.templo.Preprocessor.registerMacroFile(Loader.BASE_DIR+Loader.MACROS); - var binPath = nekoBin(path); - if (neko.FileSystem.exists(binPath)){ - var macroStamp = mtwin.templo.Preprocessor.macroFileStamp; - var sourceStamp = neko.FileSystem.stat(Loader.BASE_DIR+"/"+path).mtime.getTime(); - var stamp = neko.FileSystem.stat(binPath).mtime.getTime(); - if ((stamp >= sourceStamp) && (macroStamp == null || macroStamp < stamp)){ - return loadTemplate(binPath); - } - } - compiledFiles.set(path,true); - var content = neko.io.File.getContent(Loader.BASE_DIR+"/"+path); - var isXhtml = StringTools.endsWith(path, ".mtt") || StringTools.endsWith(path,".html") || StringTools.endsWith(path,".tpl"); - return fromString(content, nekoId(path), isXhtml); - } - - public static function fromString( src:String, ?id:String, ?isXhtml:Bool ) : Dynamic -> String { - if (id == null){ - id = Md5.encode(src); - } - - // remove BOM - if (StringTools.startsWith(src, "\xEF\xBB\xBF")) - src = src.substr(3); - - src = StringTools.replace(src, "\r\n", "\n"); - src = StringTools.replace(src, "\r", "\n"); - - src = mtwin.templo.Preprocessor.process(src); - - var path = nekoSrc(id); - var x = null; - try { - x = Xml.parse(src); - } - catch (e:Dynamic){ - var source : String = src; - var str = Std.string(e); - var reg = ~/Xml parse error : .* at line ([0-9]+)/gs; - if (reg.match(str)){ - var margin = 10; - var line = Std.parseInt(reg.matched(1)); - var lines = src.split("\n"); - var start = Std.int(Math.max(0,line-margin)); - var splice = lines.splice(start, line+margin); - var splice = Lambda.map(splice, function(s:String){ return (start++) + " : " + s; }); - source = splice.join("\n"); - } - throw { message:"Error in "+id+"\n"+str, source:source }; - } - - var p = new mtwin.templo.Parser(isXhtml == true); - var s = p.parse(x); - - s = "// generated from " + id + "\n// temploc v"+mtwin.templo.Template.VERSION+"\n" + s; - - var f = neko.io.File.write(path, false); - f.writeString(s); - f.close(); - - var r = null; - if ((neko.Sys.systemName()=="Windows")&&(neko.Sys.getEnv("OS")!="Windows_NT")){ - // Neither Windows 95 or Windows 98 support the 2> redirect - r = neko.Sys.command("nekoc -o \""+Loader.TMP_DIR+"\" \""+path+"\" > \""+Loader.TMP_DIR+"nekoc.out\""); - } - else { - r = neko.Sys.command("nekoc -o \""+Loader.TMP_DIR+"\" \""+path+"\" 2> \""+Loader.TMP_DIR+"nekoc.out\""); - } - if (r != 0){ - if (neko.FileSystem.exists(Loader.TMP_DIR+"nekoc.out")){ - throw "nekoc compilation of "+path+" failed ("+r+") : "+neko.io.File.getContent(Loader.TMP_DIR+"nekoc.out"); - } - else { - throw "nekoc compilation of "+path+" failed ("+r+") -- no nekoc.out available"; - } - } - - return loadTemplate(nekoBin(id)); - } - - static function loadTemplate( nPath:String ) : Dynamic -> String { - return untyped { - var loader = __dollar__loader; - var oldCache = loader.cache; - loader.cache = __dollar__new(oldCache); - loader.String = String; - loader.Array = Array; - loader.iter = function(loop : Dynamic, fnc){ - if (loop == null){ - throw "repeat or foreach called on null value"; - } - if (loop.iterator != null){ - var it : Iterable = loop; - for (v in it.iterator()) fnc(v); - } - else if (loop.hasNext != null && loop.next != null){ - var it : Iterator = loop; - for (v in it) fnc(v); - } - else { - throw "repeat or foreach called on non iterable object"; - } - }; - var code = loader.loadmodule(nPath.__s, loader); - loader.cache = oldCache; - function(context){ - var wrapCache = loader.cache; - loader.cache = __dollar__new(wrapCache); - var macro = function(path){ - mtwin.templo.Template.fromFile(new String(path)); - return loader.loadmodule(mtwin.templo.Template.nekoBin(new String(path)).__s, loader); - } - var result = new String(code.template(macro, context)); - loader.cache = wrapCache; - return result; - } - } - } -} diff --git a/haxe/std/mtwin/templo/temploc.hxml b/haxe/std/mtwin/templo/temploc.hxml deleted file mode 100644 index 9ea3006795649cc01d0106655f5bf3530305ea87..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/templo/temploc.hxml +++ /dev/null @@ -1,3 +0,0 @@ --main mtwin.templo.Main --neko temploc.n --cmd nekotools boot temploc.n diff --git a/haxe/std/mtwin/text/Diff.hx b/haxe/std/mtwin/text/Diff.hx deleted file mode 100644 index b0344e119d0782c528e2065257f43938b50774f9..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/text/Diff.hx +++ /dev/null @@ -1,417 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.text; - -typedef LcsMatrix = Array> - -/** - An haxe implementation of Diff/Patch/Unpatch. - - The diff text format is the same as the gnu diff utility format. - - Usage: [ - var myDiff = Diff.diff(sourceString, modifiedString); - var modified = Diff.patch(sourceString, myDiff); // modified == modifiedString - var origin = Diff.unpatch(modified, myDiff); // origin == sourceString - ] - -**/ -class Diff { - - static var END = 0; - static var DOWN = 1; - static var RIGHT = 2; - static var DOWN_RIGHT = 3; - static var NO_NEW_LINE = "\n\\ No newline at end of file\n"; - - /** - This class uses a longest common subsequence algorithm which computes the distance between - two array of strings and creates an optimal modification cursor. - - The cursor is stored in a int matrix and starts at index 0:0. - - The matrix is filled of [END], [DOWN], [DOWN_RIGHT], [RIGHT] movements. - - [DOWN] => the src line must be removed - [DOWN_RIGHT] => lines are equals, no operation required - [RIGHT] => the dst line must be inserted - [END] => end of files reached, if END is reached before [m,n], some lines must be removed or inserted - **/ - static function longestCommonSubsequence( src:Array, dst:Array ) : LcsMatrix { - var m = src.length; - var n = dst.length; - var cursor = new Array(); - var c = new Array(); - for (i in 0...m+1) { - cursor[i] = new Array(); - cursor[i][n] = 0; - c[i] = new Array(); - c[i][n] = 0; - } - for (j in 0...n+1) { - cursor[m][j] = 0; - c[m][j] = 0; - } - var i = m-1; - while (i >= 0){ - var j = n-1; - while (j >= 0){ - if (src[i] == dst[j]){ - c[i][j] = c[i+1][j+1]+1; - cursor[i][j] = DOWN_RIGHT; - } - else if (c[i+1][j] >= c[i][j+1]){ - c[i][j] = c[i+1][j]; - cursor[i][j] = DOWN; - } - else { - c[i][j] = c[i][j+1]; - cursor[i][j] = RIGHT; - } - j--; - } - i--; - } - return cursor; - } - - /** - Returns an optimized cursor. - - Compacts the cursor and transform it from a sequential operation cursor into a vector of operations. - **/ - static function lcsToStack( c:LcsMatrix ) : List> { - var stack = new List(); - var i = 0; - var w = c.length-1; - var j = 0; - var h = c[0].length-1; - var prev = -1; - while (true){ - // direction changes, store this position - if (c[i][j] != prev) - stack.add([i,j]); - prev = c[i][j]; - switch (c[i][j]){ - case DOWN: i++; - case RIGHT: j++; - case DOWN_RIGHT: i++; j++; - case END: break; - default: throw "Unknown "+c[i][j]+" at "+i+":"+j; i=0; j=0; - } - } - return stack; - } - - static function split( txt:String ){ - var res = new Array(); - var old = 0; - var pos = txt.indexOf("\n", 0); - while (pos != -1){ - res.push(txt.substr(old, pos+1-old)); - old = pos+1; - pos = txt.indexOf("\n", old); - } - res.push(txt.substr(old, txt.length)); - return res; - } - - /** - Returns the difference between two strings. - - The returned string may be used by the gnu diff/patch utilities. - **/ - public static function diff( source:String, dest:String ) : String { - var srcNoNewLine = false; - var dstNoNewLine = false; - - var sourceLines = split(source); // source.split("\n"); - if (sourceLines[sourceLines.length-1].length > 0){ - // no newline at end of file - sourceLines.push(""); - srcNoNewLine = true; - } - - var destLines = split(dest); // dest.split("\n"); - if (destLines[destLines.length-1].length > 0){ - // no newline at end of file - destLines.push(""); - dstNoNewLine = true; - } - - var m = sourceLines.length; - var n = destLines.length; - - var lcs = longestCommonSubsequence(sourceLines, destLines); - var stack = lcsToStack(lcs); - - var cursorKind = function(p){ - return lcs[p[0]][p[1]]; - } - - var operationAdd = function(after:Int, from:Int, to:Int){ - var op = new StringBuf(); - op.add(after); - op.add("a"); - if (from == to) op.add(from) else { op.add(from); op.add(","); op.add(to); } - op.add("\n"); - for (i in (from-1)...to){ - op.add("> "); - op.add(destLines[i]); - if (dstNoNewLine && i == (destLines.length-2)){ - op.add(NO_NEW_LINE); - break; - } - } - return op.toString(); - } - - var operationDel = function(from:Int, to:Int, dest:Int){ - var op = new StringBuf(); - if (from == to) op.add(from) else { op.add(from); op.add(","); op.add(to); } - op.add("d"); op.add(dest); op.add("\n"); - for (i in (from-1)...to){ - op.add("< "); - op.add(sourceLines[i]); - if (srcNoNewLine && i == sourceLines.length-2){ - op.add(NO_NEW_LINE); - break; - } - } - return op.toString(); - } - - var operationUpd = function(from:Int, to:Int, byFrom:Int, byTo:Int){ - var op = new StringBuf(); - if (from == to) op.add(from) else { op.add(from); op.add(","); op.add(to); } - op.add("c"); - if (byFrom == byTo) op.add(byFrom) else { op.add(byFrom); op.add(","); op.add(byTo); } - op.add("\n"); - for (i in (from-1)...to){ - op.add("< "); - op.add(sourceLines[i]); - if (srcNoNewLine && i == sourceLines.length-2){ - op.add(NO_NEW_LINE); - break; - } - } - op.add("---\n"); - for (i in (byFrom-1)...byTo){ - op.add("> "); - op.add(destLines[i]); - if (dstNoNewLine && i == destLines.length-2){ - op.add(NO_NEW_LINE); - break; - } - } - return op.toString(); - } - - var result = new StringBuf(); - while (stack.length > 0){ - var pos = stack.pop(); - switch (cursorKind(pos)){ - case DOWN_RIGHT: - - case DOWN: - var end = stack.pop(); - if (cursorKind(end) == RIGHT){ - var del = stack.pop(); stack.push(del); - result.add(operationUpd(pos[0]+1, end[0], pos[1]+1, del[1])); - } - else { - stack.push(end); - result.add(operationDel(pos[0]+1, end[0], end[1])); - } - - case RIGHT: - var end = stack.pop(); stack.push(end); - //result.add(operationAdd(pos[0], end[1], pos[1]+1)); - result.add(operationAdd(pos[0], pos[1]+1, end[1])); - - case END: - if (pos[0] < m){ - result.add(operationDel(pos[0], m-1, n-1)); - } - if (pos[1] < n){ - result.add(operationAdd(m-1, pos[1], n-1)); - } - } - } - return result.toString(); - } - - /** - Creates a patch operation structure. - **/ - static function parsePatchOp( left:String, op:String, right:String ): {op:String, left:Array, right:Array, data:Array}{ - var l = Lambda.array(Lambda.map(left.split(","), function(v){ return Std.parseInt(v); })); - if (l.length == 1) l.push(l[0]); - var r = Lambda.array(Lambda.map(right.split(","), function(v){ return Std.parseInt(v); })); - if (r.length == 1) r.push(r[0]); - return { op:op, left:l, right:r, data:[] }; - } - - /** - Returns the patched string resulting of the application of the patch data on src. - **/ - public static function patch( src:String, patch:String ) : String { - var opRegexp = ~/^([0-9,]+)([adc])([0-9,]+)$/; - var lines = src.split("\n"); - var counter = 0; - var result = new StringBuf(); - var patchLines = patch.split("\n"); - while (patchLines.length > 0){ - var patchLine = patchLines.shift(); - if (opRegexp.match(patchLine)){ - var op = parsePatchOp(opRegexp.matched(1), opRegexp.matched(2), opRegexp.matched(3)); - var tmp = patchLines.shift(); - while (tmp != "" && tmp != null && !opRegexp.match(tmp)){ - op.data.push(tmp); - tmp = patchLines.shift(); - } - if (tmp != null){ - patchLines.unshift(tmp); - } - switch (op.op){ - case "a": - while (counter < op.left[0]){ - result.add(lines[counter]); result.add("\n"); - counter++; - } - for (i in 0...op.data.length){ - var line = op.data[i]; - if (line.substr(0,2) == "> "){ - result.add(line.substr(2, line.length)); - if (i == op.data.length-1 || op.data[i+1].substr(0,2) != "\\ ") result.add("\n"); - } - } - - case "d": - while (counter < op.left[0]-1){ - result.add(lines[counter]); result.add("\n"); - counter++; - } - counter = op.left[1]; - - case "c": - while (counter < op.left[0]-1){ - result.add(lines[counter]); result.add("\n"); - counter++; - } - for (i in 0...op.data.length){ - var line = op.data[i]; - if (line.substr(0,2) == "> "){ - result.add(line.substr(2, line.length)); - if (i == op.data.length-1 || op.data[i+1].substr(0,2) != "\\ ") result.add("\n"); - } - } - counter = op.left[1]; - } - } - } - for (i in counter...lines.length-1){ - result.add(lines[i]); result.add("\n"); - } - return result.toString(); - } - - /** - Returns the unpatched string resulting of the cancelation of the patch applied to src. - **/ - public static function unpatch( src:String, patch:String ){ - var opRegexp = ~/^([0-9,]+)([adc])([0-9,]+)$/; - var lines = src.split("\n"); - var counter = 0; - var result = new StringBuf(); - var patchLines = patch.split("\n"); - while (patchLines.length > 0){ - var patchLine = patchLines.shift(); - if (opRegexp.match(patchLine)){ - var op = parsePatchOp(opRegexp.matched(1), opRegexp.matched(2), opRegexp.matched(3)); - var tmp = patchLines.shift(); - while (tmp != "" && tmp != null && !opRegexp.match(tmp)){ - op.data.push(tmp); - tmp = patchLines.shift(); - } - if (tmp != null){ - patchLines.unshift(tmp); - } - switch (op.op){ - case "a": // unpatch => delete - while (counter < op.right[0]-1){ - result.add(lines[counter]); result.add("\n"); - counter++; - } - counter = op.right[1]; - - case "d": // unpatch => add - while (counter < op.right[0]){ - result.add(lines[counter]); result.add("\n"); - counter++; - } - for (i in 0...op.data.length){ - var line = op.data[i]; - if (line.substr(0,2) == "< "){ - result.add(line.substr(2, line.length)); - if (i == op.data.length-1 || op.data[i+1].substr(0,2) != "\\ ") result.add("\n"); - } - } - - case "c": // unpatch => change reverse - while (counter < op.right[0]-1){ - result.add(lines[counter]); result.add("\n"); - counter++; - } - for (i in 0...op.data.length){ - var line = op.data[i]; - if (line.substr(0,2) == "< "){ - result.add(line.substr(2, line.length)); - if (i == op.data.length-1 || op.data[i+1].substr(0,2) != "\\ ") result.add("\n"); - } - } - counter = op.right[1]; - } - } - } - for (i in counter...lines.length-1){ - result.add(lines[i]); result.add("\n"); - } - return result.toString(); - } - - public static function main(){ - var src = neko.io.File.getContent("src.txt"); - var dst = neko.io.File.getContent("dst.txt"); - var diff = diff(src,dst); - neko.Lib.print(diff); - var patched = patch(src, diff); - if (patched != dst) throw "Patch failed"; - var unpatched = unpatch(patched, diff); - if (unpatched != src) throw "Unpatch failed"; - neko.Lib.print("diff/patch/unpatch success"); - } -} diff --git a/haxe/std/mtwin/text/Text2Xhtml.hx b/haxe/std/mtwin/text/Text2Xhtml.hx deleted file mode 100644 index c79f2d8e21416f5a21ff0f8289c6398a3871360c..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/text/Text2Xhtml.hx +++ /dev/null @@ -1,406 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.text; -import haxe.Md5; - -/** - Transform a plain text document into an XHTML document. - - [h1 : at least 4 * after the title] - [****] - - or - - [*** h1 : line starts with 3 *] - - [h2 : at least 4 = after the title] - [====] - - or - - [=== h2 : line starts with 3 =] - - [h3 : at least 4 - after the title] - [----] - - or - - [--- h3 : line starts with 3 -] - - - You may specify titles' ids using #myid# before your title text : - - --- #anchorhere# my title - - #anchorhere# my title - ---- - - [ - - list item 1 - - list item 2 - - no sub level at this time - ] - - [ - * * ordered item 1 - * * ordered item 2 - * * no sub level at this time - ] - - [[pre]some preformatted code[/pre]] - - [Will generate a link : http://www.google.com.] - - [Will generate an internal link [link some name : /foo/bar/baz] with a name.] - - Will generate a link with a name [link some name : http://example.com/foo/bar/baz] too. - - Please notice that spaces around central ":" are required ! - - Some [//emphased text//] and some [**strong text**]. - - An [abbr title : Abbreviation]. - - Now insert an image : [@img http://www.foo.com/foo.jpg@] - - Inserting a Swf is easy : [@swf WxHxV http://path/to/my/swf.swf@] where W means width, H means Height and V means flash Version, - this feature uses the SWFObject javascript class to display the specified swf. - - [[html] -

This is some raw html you may like to insert manually to add some specific data like - javascript or other stuff.

-

Raw html may produce parse exceptions thrown by the Text2Xhtml.transform(src) method.

-[/html]] - - You can also insert [[cite]some citations[/cite]] ! - - That's almost everything for now :) - - Ah i almost forgot the haxe colorizer : - - [[haxe] -class Foo { - // some comment - public function new(){ - } - - // ... - - public static function foo(){ - } -} -[/haxe]] - -**/ -class Text2Xhtml { - - static var rh1 = ~/^\*\*\*\s+(.*?)$/gm; - static var rh1e = ~/^(.*?)\n\*{4,}\s*?\n/gm; - static var rh2 = ~/^===\s+(.*?)$/gm; - static var rh2e = ~/^(.*?)\n={4,}\s*?\n/gm; - static var rh3 = ~/^\-\-\-\s+(.*?)$/gm; - static var rh3e = ~/^(.*?)\n-{4,}\s*?\n/gm; - static var pre = ~/^\[pre\](.*?)\[\/pre\]/gsm; - static var em = ~/(?$1"); - var extractedHtml = if (htmlEnabled) helper.extract("html", html, "$1") else new List(); - extractedHtml = extractedHtml.map(function(data:String){ return StringTools.htmlUnescape(data); }); - var extractedHaxe = if (codeEnabled) helper.extract("haxe", haxe, "$1") else new List(); - extractedHaxe = extractedHaxe.map(function(data:String){ return "
" + HaxeColorizer.colorize(data) + "
"; }); - var swfs = if (swfEnabled) helper.extract("swf", swf, "$1@$2@$3@$4") else new List(); - swfs = swfs.map(swfProcess); - - str = helper.str; - str = rh1.replace(str, "

$1

"); - str = rh1e.replace(str, "

$1

\n"); - str = rh2.replace(str, "

$1

"); - str = rh2e.replace(str, "

$1

\n"); - str = rh3.replace(str, "

$1

"); - str = rh3e.replace(str, "

$1

\n"); - - if (titleIdsEnabled){ - str = (~/

#(.*?)# (.*?)<\/h1>/g).replace(str, "

$2

\n"); - str = (~/

#(.*?)# (.*?)<\/h2>/g).replace(str, "

$2

\n"); - str = (~/

#(.*?)# (.*?)<\/h3>/g).replace(str, "

$2

\n"); - } - - while (olli.match(str)){ - var list = olli.matched(0); - var result = new StringBuf(); - result.add("\n
    \n"); - var items = list.split("\n* "); - for (i in 1...items.length){ - var content = StringTools.trim(items[i]); - if (brEnabled) - content = StringTools.replace(content, "\n", "
    "); - result.add("
  1. "+content+"
    2. \n"); - } - result.add("
\n"); - str = StringTools.replace(str, list, result.toString()); - } - - while (li.match(str)){ - var list = li.matched(0); - var result = new StringBuf(); - result.add("\n
    \n"); - var items = list.split("\n- "); - for (i in 1...items.length){ - var content = StringTools.trim(items[i]); - if (brEnabled) - content = StringTools.replace(content, "\n", "
    "); - result.add("
  • "+content+"
    • \n"); - } - result.add("
\n"); - str = StringTools.replace(str, list, result.toString()); - } - - var xml = Xml.parse(str); - transformXml(xml); - str = xml.toString(); - - str = StringTools.replace(str, "\n\n", "\n"); - str = StringTools.replace(str, "\n\n", "\n"); - - helper = new StringHelper(str); - helper.restore("pre", extractedPre); - helper.restore("html", extractedHtml); - helper.restore("haxe", extractedHaxe); - helper.restore("swf", swfs); - str = helper.str; - - // cleanup - str = StringTools.replace(str, "


", "

"); - str = StringTools.replace(str, "

", "

"); - str = StringTools.replace(str, "

", ""); - str = StringTools.replace(str, ">

", ">\n

"); - - // XML validation - try { - xml = Xml.parse(str); - } - catch (e:Dynamic){ - throw {error:Std.string(e), xml:str}; - } - - return str; - } - - public static function transform( str:String ) : String { - var transformer = new Text2Xhtml(); - return transformer.doTransform(str); - } - - static function swfProcess(data:String){ - var s = Lambda.array(data.split("@")); - var id = Md5.encode(s[3]); // url - var str = "

- -"; - str = StringTools.replace(str, "@id", id); - str = StringTools.replace(str, "@url", s[3]); - str = StringTools.replace(str, "@v", s[2]); - str = StringTools.replace(str, "@w", s[0]); - str = StringTools.replace(str, "@h", s[1]); - return str; - } - - function transformXml( xml:Xml, ?noParagraph:Bool ) { - if (xml.nodeType != Xml.Element && xml.nodeType != Xml.Document){ - var str = xml.nodeValue; - if (noParagraph == null || noParagraph == false){ - var paragraphs = str.split(paragraphSeparator); - var me = this; - var paragraphs = Lambda.map(paragraphs, function(p){ - if (me.brEnabled) - p = StringTools.replace(p, "\n", "
"); - return "

"+me.transformContent(StringTools.trim(p))+"

\n"; - }); - str = paragraphs.join("\n"); - } - else { - str = transformContent(str); - } - xml.nodeValue = str; - return; - } - if (xml.nodeType == Xml.Element && (xml.nodeName == "pre" || xml.nodeName == "t2x")) - return; - for (child in xml){ - transformXml(child, (xml.nodeType == Xml.Element && contains(SELF_CONTAINING_ELEMENTS.iterator(), xml.nodeName))); - } - } - - function transformContent( str:String ) : String { - var helper = new StringHelper(str); - var abbrs = helper.extract("abbr", abbr, "$1"); - var links = helper.extract("link", link, "$1"); - var images = if (imgEnabled) helper.extract("img", img, "\"Image\"/") else null; - var https = helper.extract("http", http, "$1://$2$3"); - str = helper.str; - - str = StringTools.replace(str, " !", " !"); - str = StringTools.replace(str, " :", " :"); - str = StringTools.replace(str, " ?", " ?"); - - var pos = 0; - var token = findFirst(str, [em, strong, cite]); - while (token != null){ - var repl = switch (token.reg){ - case strong: "" + transformContent(token.reg.matched(1)) + ""; - case em: "" + transformContent(token.reg.matched(1)) + ""; - case cite: "" + transformContent(token.reg.matched(1)) + ""; - } - var end = pos + token.pos.pos + token.pos.len; - str = str.substr(0, pos+token.pos.pos) + repl + str.substr(end, str.length-end); - pos = pos + repl.length; - token = findFirst(str.substr(pos, str.length-pos), [em,strong]); - } - - helper = new StringHelper(str); - helper.restore("abbr", abbrs); - helper.restore("link", links); - if (imgEnabled) - helper.restore("img", images); - helper.restore("http", https); - return helper.str; - } - - static function findFirst( str:String, regs:Array ) : {reg:EReg, pos:{pos:Int, len:Int}} { - var min : {reg:EReg, pos:{pos:Int, len:Int}} = {reg:null, pos:null}; - for (reg in regs){ - if (reg.match(str)){ - var pos : {pos:Int, len:Int} = reg.matchedPos(); - if (min.pos == null || pos.pos < min.pos.pos){ - min = {reg:reg, pos:pos}; - } - } - } - if (min.pos == null) - return null; - return min; - } - - static function contains( i:Iterator, v:Dynamic ){ - for (x in i) - if (x == v) return true; - return false; - } - - static var SELF_CONTAINING_ELEMENTS = ["pre","h1","h2","h3","h4","ul","li","cite"]; -} - -class StringHelper { - - public var str : String; - - public function new( s:String ){ - str = s; - } - - public function extract( key:String, reg:EReg, replace:String ) : List { - var result = new List(); - while (reg.match(str)){ - var matched = reg.matched(0); - result.push(reg.replace(matched, replace)); - str = StringTools.replace(str, matched, ""+key+result.length+""); - } - return result; - } - - public function restore( key:String, list:List ){ - var i = list.length; - for (item in list){ - str = StringTools.replace(str, ""+key+i+"", item); - --i; - } - } -} - -class HaxeColorizer { - static var lineComment = ~/(\/\/\s.*?)$/gm; - static var comment = ~/(\/\*.*?\*\/)/gsm; - static var string = ~/(?!<\\)(".*?(?!<\\)")/gsm; - static var keywords = ~/(^|\s|[^a-zA-Z_0-9])(var|function|static|private|public|class|extends|typedef|signature|throw|extern|enum|in|interface|untyped|cast|this|new|try|catch|default|case|switch|import|continue|break|for|do|while|if|else|return)(\s|[^a-zA-Z_0-9])/gsm; - - public static function colorize( code:String ) : String { - var helper = new StringHelper(code); - var comments = helper.extract("comment", comment, "$1"); - var strings = helper.extract("string", string, "$1"); - var lineComments = helper.extract("lc", lineComment, "$1"); - helper.str = keywords.replace(helper.str, "$1$2$3"); - helper.restore("lc", lineComments); - helper.restore("string", strings); - helper.restore("comment", comments); - return helper.str; - } -} - diff --git a/haxe/std/mtwin/web/Handler.hx b/haxe/std/mtwin/web/Handler.hx deleted file mode 100644 index cb0e46d5ac71d6ebc2c58a5a0d266ca6e918a2d4..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/web/Handler.hx +++ /dev/null @@ -1,225 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.web; - -import mtwin.web.Request; - -enum ActionError { - UnknownAction(name:String); - ObjectNotFound(id:Int); - ActionReservedToLoggedUsers; - ActionReservedToObjectOwner; - ActionReservedToAdministrators; - ActionReservedToModerators; - CallingObjectMethodWithoutId; -} - -/** - Generic class to handle web actions. - - Add to your .htaccess : [ - - - RewriteEngine On - RewriteRule (.*) /index.n - - ] -**/ -class Handler { - - public static var STATIC_DEFAULT = "default"; - public static var OBJECT_DEFAULT = "objectDefault"; - - var ReadWrite : Bool; - var ReadOnly : Bool; - - var actions : HashVoid>; - var objectId : Int; - var level : Int; - var request : mtwin.web.Request; - - public function new(){ - actions = new Hash(); - ReadWrite = true; - ReadOnly = false; - } - - function initialize() { - } - - function getObjectId( part:String ) : Int { - if (~/^[0-9]+$/.match(part)) - return Std.parseInt(part); - return null; - } - - public function execute( request:Request, ?pathLevel:Int ){ - if (pathLevel == null) - pathLevel = 0; - - var part = request.getPathInfoPart(pathLevel); - this.objectId = getObjectId(part); - if( objectId != null ){ - part = request.getPathInfoPart(++pathLevel); - if (part == "") - part = OBJECT_DEFAULT; - } - - this.request = request; - this.level = pathLevel; - - if (part == "") - part = STATIC_DEFAULT; - - initialize(); - if (actions.exists(part)){ - actions.get(part)(); - return; - } - throw UnknownAction(part); - } - - // Methods to override when needed - - function prepareTemplate( t:String ) : Void { - throw "not implemented"; - } - - function isLogged() : Bool { - throw "not implemented"; - return false; - } - - function isAdmin() : Bool { - throw "not implemented"; - return false; - } - - function isModerator() : Bool { - throw "not implemented"; - return false; - } - - function isOwner( o:T ) : Bool { - throw "not implemented"; - return false; - } - - function findObject( id : Int, lock:Bool ) : T { - throw "findObject(Int) not implemented"; - return null; - } - - // callback wrappers - - function object( cb:T->Void, ?lock:Bool ) : Void->Void { - if (lock == null) lock = ReadWrite; - var me = this; - return function(){ - if (me.objectId == null) - throw CallingObjectMethodWithoutId; - var obj = me.findObject(me.objectId, lock); - if (obj == null) - throw ObjectNotFound(me.objectId); - cb(obj); - } - } - - function owner( cb:T->K ) : T->K { - var me = this; - return function(u:T){ - if (!me.isOwner(u)) - throw ActionReservedToObjectOwner; - return cb(u); - } - } - - function handler( h:Handler ) : Void->Void { - var me = this; - return function(){ - h.execute(me.request, me.level+1); - } - } - - function objectHandler( cb : T -> Handler, ?lock : Bool ) { - var me = this; - return object(function(u:T) { - me.handler(cb(u))(); - },lock); - } - - - function instance( h : T -> Void, get : Int -> Bool -> T, lock : Bool ) : Void -> Void { - var me = this; - return function() { - me.objectId = Std.parseInt(me.request.getPathInfoPart(me.level+1)); - var inst = get(me.objectId,lock); - if( inst == null ) throw ObjectNotFound(me.objectId); - h(inst); - }; - } - - // action declarators - - function free( n:String, ?t:String, ?cb:Void->Void ){ - var me = this; - actions.set(n, function(){ - me.run(t,cb); - }); - } - - function logged( n:String, ?t:String, ?cb:Void->Void ){ - var me = this; - actions.set(n, function(){ - if (!me.isLogged()) - throw ActionReservedToLoggedUsers; - me.run(t,cb); - }); - } - - function admin( n:String, ?t:String, ?cb:Void->Void ){ - var me = this; - actions.set(n, function(){ - if (!me.isAdmin()) - throw ActionReservedToAdministrators; - me.run(t,cb); - }); - } - - function moderator( n:String, ?t:String, ?cb:Void->Void ){ - var me = this; - actions.set(n, function(){ - if (!me.isModerator()) - throw ActionReservedToModerators; - me.run(t,cb); - }); - } - - function run( ?t:String, ?cb:Void->Void ){ - if (t != null) prepareTemplate(t); - if (cb != null) cb(); - } -} diff --git a/haxe/std/mtwin/web/Request.hx b/haxe/std/mtwin/web/Request.hx deleted file mode 100644 index bbf47c287bfa8965a79333cd9363bcb45e6c47c3..0000000000000000000000000000000000000000 --- a/haxe/std/mtwin/web/Request.hx +++ /dev/null @@ -1,148 +0,0 @@ -/* - * Copyright (c) 2006, Motion-Twin - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY MOTION-TWIN "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -package mtwin.web; -import neko.Web; - -class Request { - - var pathInfoParts : Array; - var params : Hash; - - public function new( ?uri ) { - pathInfoParts = (uri == null ? neko.Web.getURI() : uri).split( "/" ); - pathInfoParts.shift(); - params = Web.getParams(); - } - - public function getPathInfoPart( level:Int ) : String { - if( pathInfoParts.length > level ) - return pathInfoParts[ level ]; - return ""; - } - - public function setParams( list : Hash ) { - params = new Hash(); - for( k in list.keys() ){ - params.set( k, list.get(k) ); - } - } - - public function getParamsObject( ?keys : List ) : Dynamic { - var ret : Dynamic = cast {}; - if( keys == null ) - for( k in params.keys() ) - Reflect.setField( ret, k, params.get(k) ); - else - for( k in keys ) - Reflect.setField( ret, k, params.get(k) ); - return ret; - } - - public function set( key : String , value : String ) { - params.set(key,value); - } - - public function get( key : String , ?or : String ) : String { - if( params.exists( key ) ) return params.get( key ); - return or; - } - - public function getInt( key : String, ?or : Int ) : Int { - if( params.exists(key) ){ - var v = params.get(key); - if( v == "NULL" ) - throw "DEPRECATED"; - var i = Std.parseInt(v); - return (i == null) ? or : i; - } - return or; - } - - public function getFloat( key : String, ?or : Float ) : Float { - if( params.exists(key) ){ - var v = params.get(key); - if( v == "NULL" ) - throw "DEPRECATED"; - var f = Std.parseFloat(v); - return (f == null) ? or : f; - } - return or; - } - - public function getBool( key:String ) : Bool { - var val = params.get(key); - return (val != null) && (val == "1" || val == "true"); - } - - public function getURI() : String { - return Web.getURI(); - } - - public function getReferer() : String { - return Web.getClientHeader("Referer"); - } - - static var REG_IP = ~/^\s*([0-9]+\.[0-9]+\.[0-9]+\.[0-9]+)/; - public function getIP() : String{ - var ip = Web.getClientIP(); - var xf = Web.getClientHeader("X-Forwarded-For"); - if( xf != null && REG_IP.match( xf ) ){ - var fip = REG_IP.matched(1); - if( !~/^(127\.0\.0\.1|192\.168\..*|172\.16\..*|10\..*|224\..*|240\..*)$/.match(fip) ) - ip = fip; - } - return ip; - } - - public function getIPs() : List { - var ret = new List(); - ret.add(Web.getClientIP()); - var xf = Web.getClientHeader("X-Forwarded-For"); - if( xf != null ){ - var a = xf.split(","); - for( ip in a ){ - if( REG_IP.match( ip ) ){ - var fip = REG_IP.matched(1); - if( !~/^(127\.0\.0\.1|192\.168\..*|172\.16\..*|10\..*|224\..*|240\..*)$/.match(fip) ) - ret.add(fip); - } - } - } - return ret; - } - - public function exists( key ) { - return params.exists( key ); - } - - public function toString() : String { - var lst = new List(); - for (i in params.keys()){ - lst.add("['"+i+"'] => '"+params.get(i)+"'"); - } - return lst.join(",\n"); - } -} diff --git a/haxe/std/neko/FileSystem.hx b/haxe/std/neko/FileSystem.hx deleted file mode 100644 index 4cebec873b9e1ca37d7afea376348b3e7add847a..0000000000000000000000000000000000000000 --- a/haxe/std/neko/FileSystem.hx +++ /dev/null @@ -1,114 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko; - -typedef FileStat = { - var gid : Int; - var uid : Int; - var atime : Date; - var mtime : Date; - var ctime : Date; - var dev : Int; - var ino : Int; - var nlink : Int; - var rdev : Int; - var size : Int; - var mode : Int; -} - -enum FileKind { - kdir; - kfile; - kother( k : String ); -} - -class FileSystem { - - public static function exists( path : String ) : Bool { - return sys_exists(untyped path.__s); - } - - public static function rename( path : String, newpath : String ) { - untyped sys_rename(path.__s,newpath.__s); - } - - public static function stat( path : String ) : FileStat { - var s : FileStat = sys_stat(untyped path.__s); - s.atime = untyped Date.new1(s.atime); - s.mtime = untyped Date.new1(s.mtime); - s.ctime = untyped Date.new1(s.ctime); - return s; - } - - public static function fullPath( relpath : String ) : String { - return new String(file_full_path(untyped relpath.__s)); - } - - public static function kind( path : String ) : FileKind { - var k = new String(sys_file_type(untyped path.__s)); - return switch(k) { - case "file": kfile; - case "dir": kdir; - default: kother(k); - } - } - - public static function isDirectory( path : String ) : Bool { - return kind(path) == kdir; - } - - public static function createDirectory( path : String ) { - sys_create_dir( untyped path.__s, 493 ); - } - - public static function deleteFile( path : String ) { - file_delete(untyped path.__s); - } - - public static function deleteDirectory( path : String ) { - sys_remove_dir(untyped path.__s); - } - - public static function readDirectory( path : String ) : Array { - var l : Array = sys_read_dir(untyped path.__s); - var a = new Array(); - while( l != null ) { - a.push(new String(l[0])); - l = l[1]; - } - return a; - } - - private static var sys_exists = Lib.load("std","sys_exists",1); - private static var file_delete = Lib.load("std","file_delete",1); - private static var sys_rename = Lib.load("std","sys_rename",2); - private static var sys_stat = Lib.load("std","sys_stat",1); - private static var sys_file_type = Lib.load("std","sys_file_type",1); - private static var sys_create_dir = Lib.load("std","sys_create_dir",2); - private static var sys_remove_dir = Lib.load("std","sys_remove_dir",1); - private static var sys_read_dir = Lib.load("std","sys_read_dir",1); - private static var file_full_path = Lib.load("std","file_full_path",1); - -} diff --git a/haxe/std/neko/NativeArray.hx b/haxe/std/neko/NativeArray.hx deleted file mode 100644 index 9941146e1ebad205fa70501a20d8ad6ee3e32eda..0000000000000000000000000000000000000000 --- a/haxe/std/neko/NativeArray.hx +++ /dev/null @@ -1,57 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko; - -class NativeArray implements ArrayAccess { - - public static inline function alloc( length : Int ) : NativeArray { - return untyped __dollar__amake(length); - } - - public static inline function blit( dst : NativeArray, dstPos : Int, src : NativeArray, srcPos : Int, length : Int ) { - return untyped __dollar__ablit(dst,dstPos,src,srcPos,length); - } - - public static inline function ofArrayCopy( a : Array ) : NativeArray { - return untyped a.__neko(); - } - - public static inline function ofArrayRef( a : Array ) : NativeArray { - return untyped a.__a; - } - - public static inline function sub( a : NativeArray, pos : Int, len : Int ) : NativeArray { - return untyped __dollar__asub(a,pos,len); - } - - public static inline function toArray( a : NativeArray ) : Array { - return untyped Array.new1(a,__dollar__asize(a)); - } - - public static inline function length( a : NativeArray ) : Int { - return untyped __dollar__asize(a); - } - -} \ No newline at end of file diff --git a/haxe/std/neko/NativeString.hx b/haxe/std/neko/NativeString.hx deleted file mode 100644 index 31415a40fd0d5078d279cad912e8b87593b81491..0000000000000000000000000000000000000000 --- a/haxe/std/neko/NativeString.hx +++ /dev/null @@ -1,41 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko; - -class NativeString { - - public static inline function ofString( s : String ) : NativeString { - return untyped s.__s; - } - - public static inline function toString( s : NativeString ) : String { - return new String(cast s); - } - - public static inline function length( s : NativeString ) : Int { - return untyped __dollar__ssize(s); - } - -} \ No newline at end of file diff --git a/haxe/std/neko/Random.hx b/haxe/std/neko/Random.hx deleted file mode 100644 index 5f7643580284c2a3848b922f792ef544e19748bc..0000000000000000000000000000000000000000 --- a/haxe/std/neko/Random.hx +++ /dev/null @@ -1,52 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko; - -class Random { - - var r : Void; - - public function new() { - r = random_new(); - } - - public function setSeed( s : Int ) { - random_set_seed(r,s); - } - - public function int( max : Int ) : Int { - return random_int(r,max); - } - - public function float() : Float { - return random_float(r); - } - - static var random_new = Lib.load("std","random_new",0); - static var random_set_seed = Lib.load("std","random_set_seed",2); - static var random_int = Lib.load("std","random_int",2); - static var random_float = Lib.load("std","random_float",1); - -} diff --git a/haxe/std/neko/Sys.hx b/haxe/std/neko/Sys.hx deleted file mode 100644 index c37c4ff6d898b0cd62280c3bd160f36bc7720ad5..0000000000000000000000000000000000000000 --- a/haxe/std/neko/Sys.hx +++ /dev/null @@ -1,138 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko; - -class Sys { - - public static function args() : Array untyped { - var a = __dollar__loader.args; - if( __dollar__typeof(a) != __dollar__tarray ) - return []; - var r = new Array(); - var i = 0; - var l = __dollar__asize(a); - while( i < l ) { - if( __dollar__typeof(a[i]) == __dollar__tstring ) - r.push(new String(a[i])); - i += 1; - } - return r; - } - - public static function getEnv( s : String ) { - var v = get_env(untyped s.__s); - if( v == null ) - return null; - return new String(v); - } - - public static function putEnv( s : String, v : String ) { - untyped put_env(s.__s,if( v == null ) null else v.__s); - } - - public static function sleep( seconds : Float ) { - _sleep(seconds); - } - - public static function setTimeLocale( loc : String ) : Bool { - return set_time_locale(untyped loc.__s); - } - - public static function getCwd() : String { - return new String(get_cwd()); - } - - public static function setCwd( s : String ) { - set_cwd(untyped s.__s); - } - - public static function systemName() : String { - return new String(sys_string()); - } - - public static function escapeArgument( arg : String ) : String { - var ok = true; - for( i in 0...arg.length ) - switch( arg.charCodeAt(i) ) { - case 32, 34: // [space] " - ok = false; - case 0, 13, 10: // [eof] [cr] [lf] - arg = arg.substr(0,i); - } - if( ok ) - return arg; - return '"'+arg.split('"').join('\\"')+'"'; - } - - public static function command( cmd : String, ?args : Array ) : Int { - if( args != null ) { - cmd = escapeArgument(cmd); - for( a in args ) - cmd += " "+escapeArgument(a); - } - return sys_command(untyped cmd.__s); - } - - public static function exit( code : Int ) { - sys_exit(code); - } - - public static function time() : Float { - return sys_time(); - } - - public static function cpuTime() : Float { - return sys_cpu_time(); - } - - public static function executablePath() : String { - return new String(sys_exe_path()); - } - - public static function environment() : Hash { - var l : Array = sys_env(); - var h = new Hash(); - while( l != null ) { - h.set(new String(l[0]),new String(l[1])); - l = l[2]; - } - return h; - } - - private static var get_env = Lib.load("std","get_env",1); - private static var put_env = Lib.load("std","put_env",2); - private static var _sleep = Lib.load("std","sys_sleep",1); - private static var set_time_locale = Lib.load("std","set_time_locale",1); - private static var get_cwd = Lib.load("std","get_cwd",0); - private static var set_cwd = Lib.load("std","set_cwd",1); - private static var sys_string = Lib.load("std","sys_string",0); - private static var sys_command = Lib.load("std","sys_command",1); - private static var sys_exit = Lib.load("std","sys_exit",1); - private static var sys_time = Lib.load("std","sys_time",0); - private static var sys_cpu_time = Lib.load("std","sys_cpu_time",0); - private static var sys_exe_path = Lib.load("std","sys_exe_path",0); - private static var sys_env = Lib.load("std","sys_env",0); - -} diff --git a/haxe/std/neko/Utf8.hx b/haxe/std/neko/Utf8.hx deleted file mode 100644 index 86152f9806bb1081d6f1119de5098f833e3f8de1..0000000000000000000000000000000000000000 --- a/haxe/std/neko/Utf8.hx +++ /dev/null @@ -1,109 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko; - -class Utf8 { - - var __b : Void; - - public function new( ?size : Int ) { - __b = utf8_buf_alloc(if( size == null ) 1 else size); - } - - public function addChar( c : Int ) { - utf8_buf_add(__b,c); - } - - public function toString() { - return new String(utf8_buf_content(__b)); - } - - public static function encode( s : String ) : String { - s = untyped s.__s; - var sl = untyped __dollar__ssize(s); - var buf = utf8_buf_alloc( sl ); - var i = 0; - while( i < sl ) { - utf8_buf_add(buf,untyped __dollar__sget(s,i)); - i += 1; - } - return new String( utf8_buf_content(buf) ); - } - - public static function decode( s : String ) : String { - s = untyped s.__s; - var sl = untyped __dollar__ssize(s); - var ret = untyped __dollar__smake(sl); - var i = 0; - utf8_iter(s,function(c) { - if( c == 8364 ) // euro symbol - c = 164; - else if( c == 0xFEFF ) // BOM - return; - else if( c > 255 ) - throw "Utf8::decode invalid character ("+c+")"; - untyped __dollar__sset(ret,i,c); - i += 1; - }); - return new String( untyped __dollar__ssub(ret,0,i) ); - } - - public static function iter( s : String, chars : Int -> Void ) { - utf8_iter(untyped s.__s,chars); - } - - public static function charCodeAt( s : String, index : Int ) : Int { - return utf8_get(untyped s.__s,index); - } - - public static function validate( s : String ) : Bool { - return utf8_validate(untyped s.__s); - } - - public static function length( s : String ) : Int { - return utf8_length(untyped s.__s); - } - - public static function compare( a : String, b : String ) : Int { - return utf8_compare(untyped a.__s,untyped b.__s); - } - - public static function sub( s : String, pos : Int, len : Int ) : String { - return new String(utf8_sub(untyped s.__s,pos,len)); - } - - static var utf8_buf_alloc = Lib.load("std","utf8_buf_alloc",1); - static var utf8_buf_add = Lib.load("std","utf8_buf_add",2); - static var utf8_buf_content = Lib.load("std","utf8_buf_content",1); - static var utf8_buf_length = Lib.load("std","utf8_buf_length",1); - static var utf8_iter = Lib.load("std","utf8_iter",2); - - static var utf8_get = Lib.load("std","utf8_get",2); - static var utf8_validate = Lib.load("std","utf8_validate",1); - static var utf8_length = Lib.load("std","utf8_length",1); - static var utf8_compare = Lib.load("std","utf8_compare",2); - static var utf8_sub = Lib.load("std","utf8_sub",3); - -} \ No newline at end of file diff --git a/haxe/std/neko/_std/Hash.hx b/haxe/std/neko/_std/Hash.hx deleted file mode 100644 index a90890c79945a04cf1f0e281d2c0802766a029ce..0000000000000000000000000000000000000000 --- a/haxe/std/neko/_std/Hash.hx +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Hash { - - private var h : Dynamic; - - public function new() : Void { - h = untyped __dollar__hnew(0); - } - - public inline function set( key : String, value : T ) : Void { - untyped __dollar__hset(h,key.__s,value,null); - } - - public inline function get( key : String ) : Null { - return untyped __dollar__hget(h,key.__s,null); - } - - public inline function exists( key : String ) : Bool { - return untyped __dollar__hmem(h,key.__s,null); - } - - public inline function remove( key : String ) : Bool { - return untyped __dollar__hremove(h,key.__s,null); - } - - public function keys() : Iterator { - var l = new List(); - untyped __dollar__hiter(h,function(k,_) { l.push(new String(k)); }); - return l.iterator(); - } - - public function iterator() : Iterator { - var l = new List(); - untyped __dollar__hiter(h,function(_,v) { l.push(v); }); - return l.iterator(); - } - - public function toString() : String { - var s = new StringBuf(); - s.add("{"); - var it = keys(); - for( i in it ) { - s.add(i); - s.add(" => "); - s.add(Std.string(get(i))); - if( it.hasNext() ) - s.add(", "); - } - s.add("}"); - return s.toString(); - } - -} diff --git a/haxe/std/neko/_std/IntHash.hx b/haxe/std/neko/_std/IntHash.hx deleted file mode 100644 index 83441ea25edcaff29faa89096d59c8f6a6bd4235..0000000000000000000000000000000000000000 --- a/haxe/std/neko/_std/IntHash.hx +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class IntHash { - - private var h : Dynamic; - - public function new() : Void { - h = untyped __dollar__hnew(0); - } - - public inline function set( key : Int, value : T ) : Void { - untyped __dollar__hset(h,key,value,null); - } - - public function get( key : Int ) : Null { - return untyped __dollar__hget(h,key,null); - } - - public inline function exists( key : Int ) : Bool { - return untyped __dollar__hmem(h,key,null); - } - - public inline function remove( key : Int ) : Bool { - return untyped __dollar__hremove(h,key,null); - } - - public function keys() : Iterator { - var l = new List(); - untyped __dollar__hiter(h,function(k,_) { l.push(k); }); - return l.iterator(); - } - - public function iterator() : Iterator { - var l = new List(); - untyped __dollar__hiter(h,function(_,v) { l.push(v); }); - return l.iterator(); - } - - public function toString() : String { - var s = new StringBuf(); - s.add("{"); - var it = keys(); - for( i in it ) { - s.add(i); - s.add(" => "); - s.add(Std.string(get(i))); - if( it.hasNext() ) - s.add(", "); - } - s.add("}"); - return s.toString(); - } - -} diff --git a/haxe/std/neko/_std/Math.hx b/haxe/std/neko/_std/Math.hx deleted file mode 100644 index 3519927b881d53bdb562f3a917ef0a412063ce26..0000000000000000000000000000000000000000 --- a/haxe/std/neko/_std/Math.hx +++ /dev/null @@ -1,88 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -import neko.Lib; - -@:core_api @:final class Math { - - public static var PI(default,null) : Float; - public static var NaN(default,null) : Float; - public static var POSITIVE_INFINITY(default,null) : Float; - public static var NEGATIVE_INFINITY(default,null) : Float; - - public static function min(a:Float,b:Float) : Float { return if( a < b ) a else b; } - public static function max(a:Float,b:Float) : Float { return if( a < b ) b else a; } - - public static function abs( v : Float ) : Float return 0. - public static function sin( v : Float ) : Float return 0. - public static function cos( v : Float ) : Float return 0. - public static function atan2( y : Float, x : Float ) : Float return 0. - public static function tan( v : Float ) : Float return 0. - public static function exp( v : Float ) : Float return 0. - public static function log( v : Float ) : Float return 0. - public static function sqrt( v : Float ) : Float return 0. - public static function round( v : Float ) : Int return 0 - public static function floor( v : Float ) : Int return 0 - public static function ceil( v : Float ) : Int return 0 - public static function atan( v : Float ) : Float return 0. - public static function asin( v : Float ) : Float return 0. - public static function acos( v : Float ) : Float return 0. - public static function pow( v : Float, exp : Float ) : Float return 0. - - static var __rnd; - static var _rand_float = Lib.load("std","random_float",1); - static var _rand_int = Lib.load("std","random_int",2); - - public static function random() : Float { return _rand_float(__rnd); } - - public static function isNaN(f:Float) : Bool { return untyped __dollar__isnan(f); } - public static function isFinite(f:Float) : Bool { return !untyped __dollar__isinfinite(f); } - - static function __init__() : Void { - __rnd = Lib.load("std","random_new",0)(); - PI = Lib.load("std","math_pi",0)(); - NaN = 0.0 / 0.0; - POSITIVE_INFINITY = 1.0 / 0.0; - NEGATIVE_INFINITY = -POSITIVE_INFINITY; - var M : Dynamic = Math; - M.abs = Lib.load("std","math_abs",1); - M.sin = Lib.load("std","math_sin",1); - M.cos = Lib.load("std","math_cos",1); - M.atan2 = Lib.load("std","math_atan2",2); - M.tan = Lib.load("std","math_tan",1); - M.exp = Lib.load("std","math_exp",1); - M.log = Lib.load("std","math_log",1); - M.sqrt = Lib.load("std","math_sqrt",1); - M.round = Lib.load("std","math_round",1); - M.floor = Lib.load("std","math_floor",1); - M.ceil = Lib.load("std","math_ceil",1); - M.atan = Lib.load("std","math_atan",1); - M.asin = Lib.load("std","math_asin",1); - M.acos = Lib.load("std","math_acos",1); - M.pow = Lib.load("std","math_pow",2); - } - -} - - diff --git a/haxe/std/neko/_std/Reflect.hx b/haxe/std/neko/_std/Reflect.hx deleted file mode 100644 index 9566a62e02337f2ce633732a03d227317d73cce0..0000000000000000000000000000000000000000 --- a/haxe/std/neko/_std/Reflect.hx +++ /dev/null @@ -1,92 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Reflect { - - public static function hasField( o : Dynamic, field : String ) : Bool untyped { - return __dollar__typeof(o) == __dollar__tobject && __dollar__objfield(o,__dollar__hash(field.__s)); - } - - public inline static function field( o : Dynamic, field : String ) : Dynamic untyped { - return if( __dollar__typeof(o) != __dollar__tobject ) null else __dollar__objget(o,__dollar__hash(field.__s)); - } - - public inline static function setField( o : Dynamic, field : String, value : Dynamic ) : Void untyped { - if( __dollar__typeof(o) == __dollar__tobject ) - __dollar__objset(o,__dollar__hash(field.__s),value); - } - - public inline static function callMethod( o : Dynamic, func : Dynamic, args : Array ) : Dynamic untyped { - return __dollar__call(func,o,args.__neko()); - } - - public static function fields( o : Dynamic ) : Array untyped { - if( __dollar__typeof(o) != __dollar__tobject ) - return new Array(); - else { - var a : neko.NativeArray = __dollar__objfields(o); - var i = 0; - var l = __dollar__asize(a); - while( i < l ) { - a[i] = new String(__dollar__field(a[i])); - i++; - } - return Array.new1(a,l); - } - } - - public static function isFunction( f : Dynamic ) : Bool untyped { - return __dollar__typeof(f) == __dollar__tfunction; - } - - public inline static function compare( a : T, b : T ) : Int { - return untyped __dollar__compare(a,b); - } - - public inline static function compareMethods( f1 : Dynamic, f2 : Dynamic ) : Bool { - return same_closure(f1,f2); - } - - public static function isObject( v : Dynamic ) : Bool untyped { - return __dollar__typeof(v) == __dollar__tobject && v.__enum__ == null; - } - - public inline static function deleteField( o : Dynamic, f : String ) : Bool untyped { - return __dollar__objremove(o,__dollar__hash(f.__s)); - } - - public inline static function copy( o : T ) : T { - return untyped __dollar__new(o); - } - - public static function makeVarArgs( f : Array -> Dynamic ) : Dynamic { - return untyped __dollar__varargs(function(a) { return f(Array.new1(a,__dollar__asize(a))); }); - } - - #if neko - static var same_closure = try neko.Lib.load("std","same_closure",2) catch( e : Dynamic ) function(f1,f2) return f1 == f2; - #end - -} diff --git a/haxe/std/neko/_std/Std.hx b/haxe/std/neko/_std/Std.hx deleted file mode 100644 index bd53b2e18b5f86a604b299072b88b40305e8b39a..0000000000000000000000000000000000000000 --- a/haxe/std/neko/_std/Std.hx +++ /dev/null @@ -1,81 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Std { - - public static function is( v : Dynamic, t : Dynamic ) : Bool { - return untyped neko.Boot.__instanceof(v,t); - } - - public static function string( s : Dynamic ) : String { - return new String(untyped __dollar__string(s)); - } - - public static function int( x : Float ) : Int { - if( x < 0 ) return Math.ceil(x); - return Math.floor(x); - } - - public static function parseInt( x : String ) : Null untyped { - var t = __dollar__typeof(x); - if( t == __dollar__tint ) - return x; - if( t == __dollar__tfloat ) - return __dollar__int(x); - if( t != __dollar__tobject ) - return null; - return __dollar__int(x.__s); - } - - public static function parseFloat( x : String ) : Float untyped { - if( x == null ) return Math.NaN; - var t = __dollar__float(x.__s); - if( t == null ) t = Math.NaN; - return t; - } - - public static function random( x : Int ) : Int { - return untyped Math._rand_int(Math.__rnd,x); - } - - static function __init__() : Void untyped { - Int = { __name__ : ["Int"] }; - Float = { __name__ : ["Float"] }; - Bool = { __ename__ : ["Bool"] }; - Dynamic = { __name__ : ["Dynamic"] }; - Class = { __name__ : ["Class"] }; - Enum = {}; - Void = { __ename__ : ["Void"] }; - var cl = neko.Boot.__classes; - cl.Int = Int; - cl.Float = Float; - cl.Bool = Bool; - cl.Dynamic = Dynamic; - cl.Class = Class; - cl.Enum = Enum; - cl.Void = Void; - } - -} diff --git a/haxe/std/neko/_std/StringBuf.hx b/haxe/std/neko/_std/StringBuf.hx deleted file mode 100644 index 29a3d7cbc553dab2f91f3d7cddaef879b112af1e..0000000000000000000000000000000000000000 --- a/haxe/std/neko/_std/StringBuf.hx +++ /dev/null @@ -1,56 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class StringBuf { - - private var b : Dynamic; - - public function new() : Void { - b = __make(); - } - - public inline function add( ?x : Dynamic ) : Void { - __add(b,x); - } - - public inline function addSub( s : String, pos : Int, ?len : Int ) : Void { - __add_sub(b,untyped s.__s,pos,len == null ? s.length - pos : len); - } - - public inline function addChar( c : Int ) : Void untyped { - __add_char(b,c); - } - - public inline function toString() : String { - return new String(__string(b)); - } - - static var __make : Dynamic = neko.Lib.load("std","buffer_new",0); - static var __add : Dynamic = neko.Lib.load("std","buffer_add",2); - static var __add_char : Dynamic = neko.Lib.load("std","buffer_add_char",2); - static var __add_sub : Dynamic = neko.Lib.load("std","buffer_add_sub",4); - static var __string : Dynamic = neko.Lib.load("std","buffer_string",1); - -} diff --git a/haxe/std/neko/db/Connection.hx b/haxe/std/neko/db/Connection.hx deleted file mode 100644 index 0f4d5a5e1ffd317cc369850bad77ff7576aa90ae..0000000000000000000000000000000000000000 --- a/haxe/std/neko/db/Connection.hx +++ /dev/null @@ -1,40 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.db; - -interface Connection { - - function request( s : String ) : ResultSet; - function close() : Void; - function escape( s : String ) : String; - function quote( s : String ) : String; - function addValue( s : StringBuf, v : Dynamic ) : Void; - function lastInsertId() : Int; - function dbName() : String; - function startTransaction() : Void; - function commit() : Void; - function rollback() : Void; - -} diff --git a/haxe/std/neko/db/Manager.hx b/haxe/std/neko/db/Manager.hx deleted file mode 100644 index 5c443136e9877f291f86be1661b76d875ffac284..0000000000000000000000000000000000000000 --- a/haxe/std/neko/db/Manager.hx +++ /dev/null @@ -1,546 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.db; - -#if spod_shard - -typedef Manager = mt.db.ShardManager; - -#else - -import Reflect; -import neko.db.Connection; - -/** - SPOD Manager : the persistent object database manager. See the tutorial on - haXe website to learn how to use SPOD. -**/ -class Manager { - - /* ----------------------------- STATICS ------------------------------ */ - public static var cnx(default,setConnection) : Connection; - private static var object_cache : Hash = new Hash(); - private static var init_list : List> = new List(); - private static var cache_field = "__cache__"; - private static var no_update : Dynamic = function() { throw "Cannot update not locked object"; } - private static var LOCKS = ["","",""]; - private static var KEYWORDS = { - var h = new Hash(); - for( k in ["read","write","desc","out","group","version","option", - "primary","exists","from","key","keys","limit","lock","use", - "create","order","range"] ) - h.set(k,true); - h; - } - - private static function setConnection( c : Connection ) { - Reflect.setField(Manager,"cnx",c); - if( c != null ) { - if( c.dbName() == "MySQL" ) { - LOCKS[1] = " LOCK IN SHARE MODE"; - LOCKS[2] = " FOR UPDATE"; - } else { - LOCKS[1] = ""; - LOCKS[2] = ""; - } - } - return c; - } - - /* ---------------------------- BASIC API ----------------------------- */ - var table_name : String; - var table_fields : List; - var table_keys : Array; - var class_proto : { prototype : Dynamic }; - var lock_mode : Int; - - public function new( classval : Class ) { - var cl : Dynamic = classval; - - // get basic infos - var cname : Array = cl.__name__; - table_name = quoteField(if( cl.TABLE_NAME != null ) cl.TABLE_NAME else cname[cname.length-1]); - table_keys = if( cl.TABLE_IDS != null ) cl.TABLE_IDS else ["id"]; - class_proto = cl; - lock_mode = 2; - - // get the list of private fields - var apriv : Array = cl.PRIVATE_FIELDS; - apriv = if( apriv == null ) new Array() else apriv.copy(); - apriv.push("local_manager"); - apriv.push("__class__"); - - // get the proto fields not marked private (excluding methods) - table_fields = new List(); - var proto : { local_manager : neko.db.Manager } = class_proto.prototype; - for( f in Reflect.fields(proto) ) { - var isfield = !Reflect.isFunction(Reflect.field(proto,f)); - if( isfield ) - for( f2 in apriv ) - if( f == f2 ) { - isfield = false; - break; - } - if( isfield ) - table_fields.add(f); - } - - // set the manager and ready for further init - proto.local_manager = this; - init_list.add(cast this); - } - - public function get( id : Int, ?lock : Bool ) : T { - if( lock == null ) - lock = true; - if( table_keys.length != 1 ) - throw "Invalid number of keys"; - if( id == null ) - return null; - var x : Dynamic = getFromCacheKey(id + table_name); - if( x != null && (!lock || x.update != no_update) ) - return x; - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - s.add(quoteField(table_keys[0])); - s.add(" = "); - cnx.addValue(s,id); - if( lock ) - s.add(getLockMode()); - return object(s.toString(),lock); - } - - public function getWithKeys( keys : {}, ?lock : Bool ) : T { - if( lock == null ) - lock = true; - var x : Dynamic = getFromCacheKey(makeCacheKey(cast keys)); - if( x != null && (!lock || x.update != no_update) ) - return x; - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - addKeys(s,keys); - if( lock ) - s.add(getLockMode()); - return object(s.toString(),lock); - } - - public function delete( x : {} ) { - var s = new StringBuf(); - s.add("DELETE FROM "); - s.add(table_name); - s.add(" WHERE "); - addCondition(s,x); - execute(s.toString()); - } - - public function search( x : {}, ?lock : Bool ) : List { - if( lock == null ) - lock = true; - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - addCondition(s,x); - if( lock ) - s.add(getLockMode()); - return objects(s.toString(),lock); - } - - function addCondition(s : StringBuf,x) { - var first = true; - if( x != null ) - for( f in Reflect.fields(x) ) { - if( first ) - first = false; - else - s.add(" AND "); - s.add(quoteField(f)); - var d = Reflect.field(x,f); - if( d == null ) - s.add(" IS NULL"); - else { - s.add(" = "); - cnx.addValue(s,d); - } - } - if( first ) - s.add("1"); - } - - public function all( ?lock: Bool ) : List { - if( lock == null ) - lock = true; - return objects("SELECT * FROM " + table_name + if( lock ) getLockMode() else "",lock); - } - - public function count( ?x : {} ) : Int { - var s = new StringBuf(); - s.add("SELECT COUNT(*) FROM "); - s.add(table_name); - s.add(" WHERE "); - addCondition(s,x); - return execute(s.toString()).getIntResult(0); - } - - public function quote( s : String ) : String { - return cnx.quote( s ); - } - - public function result( sql : String ) : Dynamic { - return cnx.request(sql).next(); - } - - public function results( sql : String ) : List { - return cast cnx.request(sql).results(); - } - - /* -------------------------- SPODOBJECT API -------------------------- */ - - function doInsert( x : T ) { - unmake(x); - var s = new StringBuf(); - var fields = new List(); - var values = new List(); - for( f in table_fields ) { - var v = Reflect.field(x,f); - if( v != null ) { - fields.add(quoteField(f)); - values.add(v); - } - } - s.add("INSERT INTO "); - s.add(table_name); - s.add(" ("); - s.add(fields.join(",")); - s.add(") VALUES ("); - var first = true; - for( v in values ) { - if( first ) - first = false; - else - s.add(", "); - cnx.addValue(s,v); - } - s.add(")"); - execute(s.toString()); - // table with one key not defined : suppose autoincrement - if( table_keys.length == 1 && Reflect.field(x,table_keys[0]) == null ) - Reflect.setField(x,table_keys[0],cnx.lastInsertId()); - addToCache(x); - } - - function doUpdate( x : T ) { - unmake(x); - var s = new StringBuf(); - s.add("UPDATE "); - s.add(table_name); - s.add(" SET "); - var cache = Reflect.field(x,cache_field); - var mod = false; - for( f in table_fields ) { - var v = Reflect.field(x,f); - var vc = Reflect.field(cache,f); - if( v != vc ) { - if( mod ) - s.add(", "); - else - mod = true; - s.add(quoteField(f)); - s.add(" = "); - cnx.addValue(s,v); - Reflect.setField(cache,f,v); - } - } - if( !mod ) - return; - s.add(" WHERE "); - addKeys(s,x); - execute(s.toString()); - } - - function doDelete( x : T ) { - var s = new StringBuf(); - s.add("DELETE FROM "); - s.add(table_name); - s.add(" WHERE "); - addKeys(s,x); - execute(s.toString()); - removeFromCache(x); - } - - - function doSync( i : T ) { - object_cache.remove(makeCacheKey(i)); - var i2 = getWithKeys(i,(cast i).update != no_update); - // delete all fields - for( f in Reflect.fields(i) ) - Reflect.deleteField(i,f); - // copy fields from new object - for( f in Reflect.fields(i2) ) - Reflect.setField(i,f,Reflect.field(i2,f)); - // set same field-cache - Reflect.setField(i,cache_field,Reflect.field(i2,cache_field)); - // rebuild in case it's needed - make(i); - addToCache(i); - } - - function objectToString( it : T ) : String { - var s = new StringBuf(); - s.add(table_name); - if( table_keys.length == 1 ) { - s.add("#"); - s.add(Reflect.field(it,table_keys[0])); - } else { - s.add("("); - var first = true; - for( f in table_keys ) { - if( first ) - first = false; - else - s.add(","); - s.add(quoteField(f)); - s.add(":"); - s.add(Reflect.field(it,f)); - } - s.add(")"); - } - return s.toString(); - } - - /* ---------------------------- INTERNAL API -------------------------- */ - - function cacheObject( x : T, lock : Bool ) { - addToCache(x); - untyped __dollar__objsetproto(x,class_proto.prototype); - Reflect.setField(x,cache_field,untyped __dollar__new(x)); - if( !lock ) - x.update = no_update; - } - - function make( x : T ) { - } - - function unmake( x : T ) { - } - - function quoteField(f : String) { - return KEYWORDS.exists(f.toLowerCase()) ? "`"+f+"`" : f; - } - - function addKeys( s : StringBuf, x : {} ) { - var first = true; - for( k in table_keys ) { - if( first ) - first = false; - else - s.add(" AND "); - s.add(quoteField(k)); - s.add(" = "); - var f = Reflect.field(x,k); - if( f == null ) - throw ("Missing key "+k); - cnx.addValue(s,f); - } - } - - function execute( sql : String ) { - return cnx.request(sql); - } - - function select( cond : String ) { - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - s.add(cond); - s.add(getLockMode()); - return s.toString(); - } - - function selectReadOnly( cond : String ) { - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - s.add(cond); - return s.toString(); - } - - public function object( sql : String, lock : Bool ) : T { - var r = cnx.request(sql).next(); - if( r == null ) - return null; - var c = getFromCache(r,lock); - if( c != null ) - return c; - cacheObject(r,lock); - make(r); - return r; - } - - public function objects( sql : String, lock : Bool ) : List { - var me = this; - var l = cnx.request(sql).results(); - var l2 = new List(); - for( x in l ) { - var c = getFromCache(x,lock); - if( c != null ) - l2.add(c); - else { - cacheObject(x,lock); - make(x); - l2.add(x); - } - } - return l2; - } - - /* --------------------------- MISC API ------------------------------ */ - - inline function getLockMode() { - return LOCKS[lock_mode]; - } - - public function setLockMode( exclusive, readShared ) { - lock_mode = exclusive ? 2 : (readShared ? 1 : 0); - } - - public function dbClass() : Class { - return cast class_proto; - } - - /* --------------------------- INIT / CLEANUP ------------------------- */ - - public static function initialize() { - var l = init_list; - init_list = new List(); - for( m in l ) { - var rl : Void -> Array = (cast m.class_proto).RELATIONS; - if( rl != null ) - for( r in rl() ) - m.initRelation(r); - } - } - - public static function cleanup() { - object_cache = new Hash(); - } - - function initRelation(r : { prop : String, key : String, manager : Manager, lock : Bool } ) { - // setup getter/setter - var manager = r.manager; - var hprop = "__"+r.prop; - var hkey = r.key; - var lock = r.lock; - if( lock == null ) lock = true; - if( manager == null || manager.table_keys == null ) throw ("Invalid manager for relation "+table_name+":"+r.prop); - if( manager.table_keys.length != 1 ) throw ("Relation "+r.prop+"("+r.key+") on a multiple key table"); - Reflect.setField(class_proto.prototype,"get_"+r.prop,function() { - var othis = untyped this; - var f = Reflect.field(othis,hprop); - if( f != null ) - return f; - var id = Reflect.field(othis,hkey); - f = manager.get(id,lock); - // it's highly possible that in that case the object has been inserted - // after we started our transaction : in that case, let's lock it, since - // it's still better than returning 'null' while it exists - if( f == null && id != null && !lock ) - f = manager.get(id,true); - Reflect.setField(othis,hprop,f); - return f; - }); - Reflect.setField(class_proto.prototype,"set_"+r.prop,function(f) { - var othis = untyped this; - Reflect.setField(othis,hprop,f); - Reflect.setField(othis,hkey,Reflect.field(f,manager.table_keys[0])); - return f; - }); - // remove prop from precomputed table_fields - // always add key to table fields (even if not declared) - table_fields.remove(r.prop); - table_fields.remove(r.key); - table_fields.add(r.key); - } - - /* ---------------------------- OBJECT CACHE -------------------------- */ - - function makeCacheKey( x : T ) : String { - if( table_keys.length == 1 ) { - var k = Reflect.field(x,table_keys[0]); - if( k == null ) - throw("Missing key "+table_keys[0]); - return Std.string(k)+table_name; - } - var s = new StringBuf(); - for( k in table_keys ) { - var v = Reflect.field(x,k); - if( k == null ) - throw("Missing key "+k); - s.add(v); - s.add("#"); - } - s.add(table_name); - return s.toString(); - } - - function addToCache( x : T ) { - object_cache.set(makeCacheKey(x),x); - } - - function removeFromCache( x : T ) { - object_cache.remove(makeCacheKey(x)); - } - - function getFromCacheKey( key : String ) : T { - return cast object_cache.get(key); - } - - function getFromCache( x : T, lock : Bool ) : T { - var c : Dynamic = object_cache.get(makeCacheKey(x)); - if( c != null && lock && c.update == no_update ) { - // restore update method since now the object is locked - c.update = class_proto.prototype.update; - // and synchronize the fields since our result is up-to-date ! - for( f in Reflect.fields(c) ) - Reflect.deleteField(c,f); - for( f in Reflect.fields(x) ) - Reflect.setField(c,f,Reflect.field(x,f)); - // use the new object as our cache of fields - Reflect.setField(c,cache_field,x); - // remake object - make(c); - } - return c; - } - -} - -#end \ No newline at end of file diff --git a/haxe/std/neko/db/Object.hx b/haxe/std/neko/db/Object.hx deleted file mode 100644 index 8855ca593131619475251580c22941394c8bd1e8..0000000000000000000000000000000000000000 --- a/haxe/std/neko/db/Object.hx +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.db; - -/** - SPOD Object : the persistent object base type. See the tutorial on haXe - website to learn how to use SPOD. -**/ -class Object #if spod_rtti implements haxe.rtti.Infos #end { - -/* - (optional) - static var TABLE_NAME = "TableName"; - static var TABLE_IDS = ["id"]; - static var PRIVATE_FIELDS = ["my_priv_field"]; - static function RELATIONS() { - return [{ key : "uid", prop : "user", manager : User.manager }]; - } - - static var manager = new neko.db.Manager(); -*/ - - var local_manager : { - private function doUpdate( o : Object ) : Void; - private function doInsert( o : Object ) : Void; - private function doSync( o : Object ) : Void; - private function doDelete( o : Object ) : Void; - private function objectToString( o : Object ) : String; - }; - - - public function new() { - } - - public function insert() { - local_manager.doInsert(this); - } - - public dynamic function update() { - local_manager.doUpdate(this); - } - - public function sync() { - local_manager.doSync(this); - } - - public function delete() { - local_manager.doDelete(this); - } - - public function toString() { - return local_manager.objectToString(this); - } - -} diff --git a/haxe/std/neko/db/ResultSet.hx b/haxe/std/neko/db/ResultSet.hx deleted file mode 100644 index 04e495a5ebc43e1ab1c588eae700c303cb3f073c..0000000000000000000000000000000000000000 --- a/haxe/std/neko/db/ResultSet.hx +++ /dev/null @@ -1,41 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.db; - -interface ResultSet { - - var length(getLength,null) : Int; - var nfields(getNFields,null) : Int; - - - function hasNext() : Bool; - function next() : Dynamic; - function results() : List; - function getResult( n : Int ) : String; - function getIntResult( n : Int ) : Int; - function getFloatResult( n : Int ) : Float; - function getFieldsNames() : Null>; - -} diff --git a/haxe/std/neko/db/Transaction.hx b/haxe/std/neko/db/Transaction.hx deleted file mode 100644 index b2160c58d286c8115e6d234b2ce345eb79876d12..0000000000000000000000000000000000000000 --- a/haxe/std/neko/db/Transaction.hx +++ /dev/null @@ -1,71 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.db; - -import Reflect; - -class Transaction { - - public static function isDeadlock(e : Dynamic) { - return Std.is(e,String) && (~/Deadlock found/.match(e) || ~/Lock wait timeout/.match(e)); - } - - private static function runMainLoop(mainFun,logError,count) { - try { - mainFun(); - } catch( e : Dynamic ) { - if( count > 0 && isDeadlock(e) ) { - Manager.cleanup(); - Manager.cnx.rollback(); // should be already done, but in case... - Manager.cnx.startTransaction(); - runMainLoop(mainFun,logError,count-1); - return; - } - if( logError == null ) { - Manager.cnx.rollback(); - neko.Lib.rethrow(e); - } - logError(e); // should ROLLBACK if needed - } - } - - public static function main( cnx, mainFun : Void -> Void, logError : Dynamic -> Void ) { - Manager.initialize(); - Manager.cnx = cnx; - Manager.cnx.startTransaction(); - runMainLoop(mainFun,logError,3); - try { - Manager.cnx.commit(); - } catch( e : String ) { - // sqlite can have errors on commit - if( ~/Database is busy/.match(e) ) - logError(e); - } - Manager.cnx.close(); - Manager.cnx = null; - Manager.cleanup(); - } - -} diff --git a/haxe/std/neko/io/File.hx b/haxe/std/neko/io/File.hx deleted file mode 100644 index 55cedec9c6e576ba1d9670ad8864f65ec9caa9b4..0000000000000000000000000000000000000000 --- a/haxe/std/neko/io/File.hx +++ /dev/null @@ -1,94 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.io; - -enum FileHandle { -} - -enum FileSeek { - SeekBegin; - SeekCur; - SeekEnd; -} - -/** - API for reading and writing to files. -**/ -class File { - - public static function getContent( path : String ) { - return new String(file_contents(untyped path.__s)); - } - - public static function getBytes( path : String ) { - return neko.Lib.bytesReference(getContent(path)); - } - - public static function read( path : String, binary : Bool ) { - return new FileInput(untyped file_open(path.__s,(if( binary ) "rb" else "r").__s)); - } - - public static function write( path : String, binary : Bool ) { - return new FileOutput(untyped file_open(path.__s,(if( binary ) "wb" else "w").__s)); - } - - public static function append( path : String, binary : Bool ) { - return new FileOutput(untyped file_open(path.__s,(if( binary ) "ab" else "a").__s)); - } - - public static function copy( src : String, dst : String ) { - var s = read(src,true); - var d = write(dst,true); - d.writeInput(s); - s.close(); - d.close(); - } - - public static function stdin() { - return new FileInput(file_stdin()); - } - - public static function stdout() { - return new FileOutput(file_stdout()); - } - - public static function stderr() { - return new FileOutput(file_stderr()); - } - - public static function getChar( echo : Bool ) : Int { - return getch(echo); - } - - private static var file_stdin = neko.Lib.load("std","file_stdin",0); - private static var file_stdout = neko.Lib.load("std","file_stdout",0); - private static var file_stderr = neko.Lib.load("std","file_stderr",0); - - private static var file_contents = neko.Lib.load("std","file_contents",1); - private static var file_open = neko.Lib.load("std","file_open",2); - - private static var getch = neko.Lib.load("std","sys_getch",1); - -} diff --git a/haxe/std/neko/io/FileInput.hx b/haxe/std/neko/io/FileInput.hx deleted file mode 100644 index d886a51e1905776b704b05d7bd2cf3b6ed8d2ca8..0000000000000000000000000000000000000000 --- a/haxe/std/neko/io/FileInput.hx +++ /dev/null @@ -1,88 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.io; -import neko.io.File; - -/** - Use [neko.io.File.read] to create a [FileInput] -**/ -class FileInput extends haxe.io.Input { - - private var __f : FileHandle; - - public function new(f) { - __f = f; - } - - public override function readByte() : Int { - return try { - file_read_char(__f); - } catch( e : Dynamic ) { - if( untyped __dollar__typeof(e) == __dollar__tarray ) - throw new haxe.io.Eof(); - else - throw haxe.io.Error.Custom(e); - } - } - - public override function readBytes( s : haxe.io.Bytes, p : Int, l : Int ) : Int { - return try { - file_read(__f,s.getData(),p,l); - } catch( e : Dynamic ) { - if( untyped __dollar__typeof(e) == __dollar__tarray ) - throw new haxe.io.Eof(); - else - throw haxe.io.Error.Custom(e); - } - } - - public override function close() { - super.close(); - file_close(__f); - } - - public function seek( p : Int, pos : FileSeek ) { - file_seek(__f,p,switch( pos ) { case SeekBegin: 0; case SeekCur: 1; case SeekEnd: 2; }); - } - - public function tell() : Int { - return file_tell(__f); - } - - - public function eof() : Bool { - return file_eof(__f); - } - - private static var file_eof = neko.Lib.load("std","file_eof",1); - - private static var file_read = neko.Lib.load("std","file_read",4); - private static var file_read_char = neko.Lib.load("std","file_read_char",1); - - private static var file_close = neko.Lib.load("std","file_close",1); - private static var file_seek = neko.Lib.load("std","file_seek",3); - private static var file_tell = neko.Lib.load("std","file_tell",1); - -} diff --git a/haxe/std/neko/io/FileOutput.hx b/haxe/std/neko/io/FileOutput.hx deleted file mode 100644 index 768b8079846cbd49434623b105bbe5e97e150659..0000000000000000000000000000000000000000 --- a/haxe/std/neko/io/FileOutput.hx +++ /dev/null @@ -1,72 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.io; -import neko.io.File; - -/** - Use [neko.io.File.write] to create a [FileOutput] -**/ -class FileOutput extends haxe.io.Output { - - private var __f : FileHandle; - - public function new(f) { - __f = f; - } - - public override function writeByte( c : Int ) { - try file_write_char(__f,c) catch( e : Dynamic ) throw haxe.io.Error.Custom(e); - } - - public override function writeBytes( s : haxe.io.Bytes, p : Int, l : Int ) : Int { - return try file_write(__f,s.getData(),p,l) catch( e : Dynamic ) throw haxe.io.Error.Custom(e); - } - - public override function flush() { - file_flush(__f); - } - - public override function close() { - super.close(); - file_close(__f); - } - - public function seek( p : Int, pos : FileSeek ) { - file_seek(__f,p,switch( pos ) { case SeekBegin: 0; case SeekCur: 1; case SeekEnd: 2; }); - } - - public function tell() : Int { - return file_tell(__f); - } - - private static var file_close = neko.Lib.load("std","file_close",1); - private static var file_seek = neko.Lib.load("std","file_seek",3); - private static var file_tell = neko.Lib.load("std","file_tell",1); - - private static var file_flush = neko.Lib.load("std","file_flush",1); - private static var file_write = neko.Lib.load("std","file_write",4); - private static var file_write_char = neko.Lib.load("std","file_write_char",2); - -} diff --git a/haxe/std/neko/io/Path.hx b/haxe/std/neko/io/Path.hx deleted file mode 100644 index 57977371f9b04ba7b3eb484ff5c0909d68e39db0..0000000000000000000000000000000000000000 --- a/haxe/std/neko/io/Path.hx +++ /dev/null @@ -1,92 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.io; - -class Path { - - public var ext : String; - public var dir : String; - public var file : String; - public var backslash : Bool; - - public function new( path : String ) { - var c1 = path.lastIndexOf("/"); - var c2 = path.lastIndexOf("\\"); - if( c1 < c2 ) { - dir = path.substr(0,c2); - path = path.substr(c2+1); - backslash = true; - } else if( c2 < c1 ) { - dir = path.substr(0,c1); - path = path.substr(c1+1); - } else - dir = null; - var cp = path.lastIndexOf("."); - if( cp != -1 ) { - ext = path.substr(cp+1); - file = path.substr(0,cp); - } else { - ext = null; - file = path; - } - } - - public function toString() { - return (if( dir == null ) "" else dir + if( backslash ) "\\" else "/") + file + (if( ext == null ) "" else "." + ext); - } - - public static function withoutExtension( path : String ) { - var s = new Path(path); - s.ext = null; - return s.toString(); - } - - public static function withoutDirectory( path ) { - var s = new Path(path); - s.dir = null; - return s.toString(); - } - - public static function directory( path ) { - var s = new Path(path); - if( s.dir == null ) - return ""; - return s.dir; - } - - public static function extension( path ) { - var s = new Path(path); - if( s.ext == null ) - return ""; - return s.ext; - } - - public static function withExtension( path, ext ) { - var s = new Path(path); - s.ext = ext; - return s.toString(); - } - -} \ No newline at end of file diff --git a/haxe/std/neko/net/Host.hx b/haxe/std/neko/net/Host.hx deleted file mode 100644 index 3a5ae86345307554a11517492612a88bba134098..0000000000000000000000000000000000000000 --- a/haxe/std/neko/net/Host.hx +++ /dev/null @@ -1,58 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - * - */ -package neko.net; - - -class Host { - - public var ip(default,null) : haxe.Int32; - - public function new( name : String ) { - ip = host_resolve(untyped name.__s); - } - - public function toString() : String { - return new String(host_to_string(ip)); - } - - public function reverse() { - return new String(host_reverse(ip)); - } - - public static function localhost() : String { - return new String(host_local()); - } - - static function __init__() { - neko.Lib.load("std","socket_init",0)(); - } - - private static var host_resolve = neko.Lib.load("std","host_resolve",1); - private static var host_reverse = neko.Lib.load("std","host_reverse",1); - private static var host_to_string = neko.Lib.load("std","host_to_string",1); - private static var host_local = neko.Lib.load("std","host_local",0); - -} diff --git a/haxe/std/neko/net/Socket.hx b/haxe/std/neko/net/Socket.hx deleted file mode 100644 index 828fb90688adf09da73720e022f663ad0db8d3b5..0000000000000000000000000000000000000000 --- a/haxe/std/neko/net/Socket.hx +++ /dev/null @@ -1,178 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - * - * Contributor: Lee McColl Sylvester - */ -package neko.net; - -enum SocketHandle { -} - -class Socket { - - private var __s : SocketHandle; - public var input(default,null) : SocketInput; - public var output(default,null) : SocketOutput; - public var custom : Dynamic; - - public function new( ?s ) { - __s = if( s == null ) socket_new(false) else s; - input = new SocketInput(__s); - output = new SocketOutput(__s); - } - - public function close() : Void { - socket_close(__s); - untyped { - input.__s = null; - output.__s = null; - } - input.close(); - output.close(); - } - - public function read() : String { - return socket_read(__s); - } - - public function write( content : String ) { - socket_write(__s, untyped content.__s); - } - - public function connect(host : Host, port : Int) { - try { - socket_connect(__s, host.ip, port); - } catch( s : String ) { - if( s == "std@socket_connect" ) - throw "Failed to connect on "+(try host.reverse() catch( e : Dynamic ) host.toString())+":"+port; - else - neko.Lib.rethrow(s); - } - } - - public function listen(connections : Int) { - socket_listen(__s, connections); - } - - public function shutdown( read : Bool, write : Bool ){ - socket_shutdown(__s,read,write); - } - - public function bind(host : Host, port : Int) { - socket_bind(__s, host.ip, port); - } - - public function accept() : Socket { - return new Socket(socket_accept(__s)); - } - - public function peer() : { host : Host, port : Int } { - var a : Dynamic = socket_peer(__s); - var h = new Host("127.0.0.1"); - untyped h.ip = a[0]; - return { host : h, port : a[1] }; - } - - public function host() : { host : Host, port : Int } { - var a : Dynamic = socket_host(__s); - var h = new Host("127.0.0.1"); - untyped h.ip = a[0]; - return { host : h, port : a[1] }; - } - - public function setTimeout( timeout : Float ) { - socket_set_timeout(__s, timeout); - } - - public function waitForRead() { - select([this],null,null,null); - } - - public function setBlocking( b : Bool ) { - socket_set_blocking(__s,b); - } - - public function setFastSend( b : Bool ) { - socket_set_fast_send(__s,b); - } - - public static function newUdpSocket() { - return new Socket(socket_new(true)); - } - - // STATICS - public static function select(read : Array, write : Array, others : Array, timeout : Float) : {read: Array,write: Array,others: Array} { - var c = untyped __dollar__hnew( 1 ); - var f = function( a : Array ){ - if( a == null ) return null; - untyped { - var r = __dollar__amake(a.length); - var i = 0; - while( i < a.length ){ - r[i] = a[i].__s; - __dollar__hadd(c,a[i].__s,a[i]); - i += 1; - } - return r; - } - } - var neko_array = socket_select(f(read),f(write),f(others), timeout); - - var g = function( a ) : Array { - if( a == null ) return null; - - var r = new Array(); - var i = 0; - while( i < untyped __dollar__asize(a) ){ - var t = untyped __dollar__hget(c,a[i],null); - if( t == null ) throw "Socket object not found."; - r[i] = t; - i += 1; - } - return r; - } - - return { - read: g(neko_array[0]), - write: g(neko_array[1]), - others: g(neko_array[2]) - }; - } - - private static var socket_new = neko.Lib.load("std","socket_new",1); - private static var socket_close = neko.Lib.load("std","socket_close",1); - private static var socket_write = neko.Lib.load("std","socket_write",2); - private static var socket_read = neko.Lib.load("std","socket_read",1); - private static var socket_connect = neko.Lib.load("std","socket_connect",3); - private static var socket_listen = neko.Lib.load("std","socket_listen",2); - private static var socket_select = neko.Lib.load("std","socket_select",4); - private static var socket_bind = neko.Lib.load("std","socket_bind",3); - private static var socket_accept = neko.Lib.load("std","socket_accept",1); - private static var socket_peer = neko.Lib.load("std","socket_peer",1); - private static var socket_host = neko.Lib.load("std","socket_host",1); - private static var socket_set_timeout = neko.Lib.load("std","socket_set_timeout",2); - private static var socket_shutdown = neko.Lib.load("std","socket_shutdown",3); - private static var socket_set_blocking = neko.Lib.load("std","socket_set_blocking",2); - private static var socket_set_fast_send = neko.Lib.loadLazy("std","socket_set_fast_send",2); -} diff --git a/haxe/std/neko/net/SocketInput.hx b/haxe/std/neko/net/SocketInput.hx deleted file mode 100644 index 42952cbad0eff87da9a5ddc93416ab5734bfa01e..0000000000000000000000000000000000000000 --- a/haxe/std/neko/net/SocketInput.hx +++ /dev/null @@ -1,74 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.net; -import neko.net.Socket; -import haxe.io.Error; - -class SocketInput extends haxe.io.Input { - - var __s : SocketHandle; - - public function new(s) { - __s = s; - } - - public override function readByte() { - return try { - socket_recv_char(__s); - } catch( e : Dynamic ) { - if( e == "Blocking" ) - throw Blocked; - else if( __s == null ) - throw Custom(e); - else - throw new haxe.io.Eof(); - } - } - - public override function readBytes( buf : haxe.io.Bytes, pos : Int, len : Int ) : Int { - var r; - try { - r = socket_recv(__s,buf.getData(),pos,len); - } catch( e : Dynamic ) { - if( e == "Blocking" ) - throw Blocked; - else - throw Custom(e); - } - if( r == 0 ) - throw new haxe.io.Eof(); - return r; - } - - public override function close() { - super.close(); - if( __s != null ) socket_close(__s); - } - - private static var socket_recv = neko.Lib.load("std","socket_recv",4); - private static var socket_recv_char = neko.Lib.load("std","socket_recv_char",1); - private static var socket_close = neko.Lib.load("std","socket_close",1); - -} diff --git a/haxe/std/neko/net/SocketOutput.hx b/haxe/std/neko/net/SocketOutput.hx deleted file mode 100644 index f68aa8a1a596e7aded71b21e3917e2f119b25388..0000000000000000000000000000000000000000 --- a/haxe/std/neko/net/SocketOutput.hx +++ /dev/null @@ -1,68 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.net; -import neko.net.Socket; -import haxe.io.Error; - -class SocketOutput extends haxe.io.Output { - - var __s : SocketHandle; - - public function new(s) { - __s = s; - } - - public override function writeByte( c : Int ) { - try { - socket_send_char(__s, c); - } catch( e : Dynamic ) { - if( e == "Blocking" ) - throw Blocked; - else - throw Custom(e); - } - } - - public override function writeBytes( buf : haxe.io.Bytes, pos : Int, len : Int) : Int { - return try { - socket_send(__s, buf.getData(), pos, len); - } catch( e : Dynamic ) { - if( e == "Blocking" ) - throw Blocked; - else - throw Custom(e); - } - } - - public override function close() { - super.close(); - if( __s != null ) socket_close(__s); - } - - private static var socket_close = neko.Lib.load("std","socket_close",1); - private static var socket_send_char = neko.Lib.load("std","socket_send_char",2); - private static var socket_send = neko.Lib.load("std","socket_send",4); - -} diff --git a/haxe/std/neko/vm/Deque.hx b/haxe/std/neko/vm/Deque.hx deleted file mode 100644 index 30861f0ff044484c54f10ac252030aad22e98a39..0000000000000000000000000000000000000000 --- a/haxe/std/neko/vm/Deque.hx +++ /dev/null @@ -1,45 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.vm; - -class Deque { - var q : Void; - public function new() { - q = deque_create(); - } - public function add( i : T ) { - deque_add(q,i); - } - public function push( i : T ) { - deque_push(q,i); - } - public function pop( block : Bool ) : T { - return deque_pop(q,block); - } - static var deque_create = neko.Lib.loadLazy("std","deque_create",0); - static var deque_add = neko.Lib.loadLazy("std","deque_add",2); - static var deque_push = neko.Lib.loadLazy("std","deque_push",2); - static var deque_pop = neko.Lib.loadLazy("std","deque_pop",2); -} diff --git a/haxe/std/neko/vm/Gc.hx b/haxe/std/neko/vm/Gc.hx deleted file mode 100644 index dfbcc5dcc801dafa00a7c30d1195bfa6ea6fa50b..0000000000000000000000000000000000000000 --- a/haxe/std/neko/vm/Gc.hx +++ /dev/null @@ -1,40 +0,0 @@ -/* - * Copyright (c) 2005-2007, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.vm; - -class Gc { - - public static function run( major : Bool ) { - _run(major); - } - - public static function stats() : { heap : Int, free : Int } { - return _stats(); - } - - static var _run = neko.Lib.load("std","run_gc",1); - static var _stats = neko.Lib.load("std","gc_stats",0); - -} diff --git a/haxe/std/neko/vm/Lock.hx b/haxe/std/neko/vm/Lock.hx deleted file mode 100644 index 1651ea16ceeca625a6a73db54021d98e79da2190..0000000000000000000000000000000000000000 --- a/haxe/std/neko/vm/Lock.hx +++ /dev/null @@ -1,41 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.vm; - -class Lock { - var l : Void; - public function new() { - l = lock_create(); - } - public function wait( ?timeout : Float ) : Bool { - return lock_wait(l,timeout); - } - public function release() { - lock_release(l); - } - static var lock_create = neko.Lib.load("std","lock_create",0); - static var lock_release = neko.Lib.load("std","lock_release",1); - static var lock_wait = neko.Lib.load("std","lock_wait",2); -} diff --git a/haxe/std/neko/vm/Mutex.hx b/haxe/std/neko/vm/Mutex.hx deleted file mode 100644 index cb9bdc59ad71faa3d70f94e3fbe509f8c9d12fdd..0000000000000000000000000000000000000000 --- a/haxe/std/neko/vm/Mutex.hx +++ /dev/null @@ -1,45 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.vm; - -class Mutex { - var m : Void; - public function new() { - m = mutex_create(); - } - public function acquire() { - mutex_acquire(m); - } - public function tryAcquire() : Bool { - return mutex_try(m); - } - public function release() { - mutex_release(m); - } - static var mutex_create = neko.Lib.loadLazy("std","mutex_create",0); - static var mutex_release = neko.Lib.loadLazy("std","mutex_release",1); - static var mutex_acquire = neko.Lib.loadLazy("std","mutex_acquire",1); - static var mutex_try = neko.Lib.loadLazy("std","mutex_try",1); -} diff --git a/haxe/std/neko/vm/Tls.hx b/haxe/std/neko/vm/Tls.hx deleted file mode 100644 index 86cb1571d8b0b1570395e7cd97fd73a7d35a8d56..0000000000000000000000000000000000000000 --- a/haxe/std/neko/vm/Tls.hx +++ /dev/null @@ -1,49 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.vm; - -class Tls { - - var t : Dynamic; - public var value(getValue,setValue) : T; - - public function new() { - t = tls_create(); - } - - function getValue() : T { - return tls_get(t); - } - - function setValue( v : T ) { - tls_set(t,v); - return v; - } - - static var tls_create = neko.Lib.load("std","tls_create",0); - static var tls_get = neko.Lib.load("std","tls_get",1); - static var tls_set = neko.Lib.load("std","tls_set",2); - -} \ No newline at end of file diff --git a/haxe/std/neko/vm/Ui.hx b/haxe/std/neko/vm/Ui.hx deleted file mode 100644 index 004fb3e29e2554d069826be382a0b029f39a41c8..0000000000000000000000000000000000000000 --- a/haxe/std/neko/vm/Ui.hx +++ /dev/null @@ -1,70 +0,0 @@ -/* - * Copyright (c) 2005-2007, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.vm; - -class Ui { - - public static function isMainThread() { - return _is_main_thread(); - } - - public static function loop() { - _loop(); - } - - public static function stopLoop() { - _sync(_stop_loop); - } - - public static function sync( f : Void -> Void ) { - _sync(f); - } - - public static function syncResult( f : Void -> T ) : T { - if( isMainThread() ) - return f(); - var l = new Lock(); - var tmp = null; - var exc = null; - _sync(function() { - try { - tmp = f(); - } catch( e : Dynamic ) { - exc = { v : e }; - } - l.release(); - }); - l.wait(); - if( exc != null ) - throw exc.v; - return tmp; - } - - static var _is_main_thread = neko.Lib.load("ui","ui_is_main",0); - static var _loop = neko.Lib.load("ui","ui_loop",0); - static var _stop_loop = neko.Lib.load("ui","ui_stop_loop",0); - static var _sync = neko.Lib.load("ui","ui_sync",1); - -} \ No newline at end of file diff --git a/haxe/std/neko/zip/CRC32.hx b/haxe/std/neko/zip/CRC32.hx deleted file mode 100644 index e9627b0df930177bff52d0ba482a7dbcb324ab70..0000000000000000000000000000000000000000 --- a/haxe/std/neko/zip/CRC32.hx +++ /dev/null @@ -1,52 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.zip; -import haxe.Int32; - -class CRC32 { - - /* - * Function computes CRC32 code of a given string. - * Warning: returns Int32 as result uses all 32 bits - * UTF - 8 coding is not supported - */ - public static function encode(str : haxe.io.Bytes) : Int32 { - var init = Int32.make(0xFFFF, 0xFFFF); - var polynom = Int32.make(0xEDB8, 0x8320); - var crc = init; - var s = str.getData(); - for( i in 0...str.length ) { - var tmp = Int32.and( Int32.xor(crc,untyped __dollar__sget(s,i)), cast 0xFF ); - for( j in 0...8 ) { - if( Int32.and(tmp,cast 1) == cast 1 ) - tmp = Int32.xor(Int32.ushr(tmp,1),polynom); - else - tmp = Int32.ushr(tmp,1); - } - crc = Int32.xor(Int32.ushr(crc,8), tmp); - } - return Int32.xor(crc, init); - } -} diff --git a/haxe/std/neko/zip/Compress.hx b/haxe/std/neko/zip/Compress.hx deleted file mode 100644 index 1cb0b9c5aa98e22f120ad0c2aed85b3916870828..0000000000000000000000000000000000000000 --- a/haxe/std/neko/zip/Compress.hx +++ /dev/null @@ -1,64 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.zip; - -class Compress { - - var s : Void; - - public function new( level : Int ) { - s = _deflate_init(level); - } - - public function execute( src : haxe.io.Bytes, srcPos : Int, dst : haxe.io.Bytes, dstPos : Int ) : { done : Bool, read : Int, write : Int } { - return _deflate_buffer(s,src.getData(),srcPos,dst.getData(),dstPos); - } - - public function setFlushMode( f : Flush ) { - _set_flush_mode(s,untyped Std.string(f).__s); - } - - public function close() { - _deflate_end(s); - } - - public static function run( s : haxe.io.Bytes, level : Int ) : haxe.io.Bytes { - var c = new Compress(level); - c.setFlushMode(Flush.FINISH); - var out = haxe.io.Bytes.alloc(_deflate_bound(c.s,s.length)); - var r = c.execute(s,0,out,0); - c.close(); - if( !r.done || r.read != s.length ) - throw "Compression failed"; - return out.sub(0,r.write); - } - - static var _deflate_init = neko.Lib.load("zlib","deflate_init",1); - static var _deflate_bound = neko.Lib.load("zlib","deflate_bound",2); - static var _deflate_buffer = neko.Lib.load("zlib","deflate_buffer",5); - static var _deflate_end = neko.Lib.load("zlib","deflate_end",1); - static var _set_flush_mode = neko.Lib.load("zlib","set_flush_mode",2); - -} diff --git a/haxe/std/neko/zip/Flush.hx b/haxe/std/neko/zip/Flush.hx deleted file mode 100644 index c0883d6a13deb2f335cd90cf37aa72fed82ff7df..0000000000000000000000000000000000000000 --- a/haxe/std/neko/zip/Flush.hx +++ /dev/null @@ -1,33 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.zip; - -enum Flush { - NO; - SYNC; - FULL; - FINISH; - BLOCK; -} diff --git a/haxe/std/neko/zip/Reader.hx b/haxe/std/neko/zip/Reader.hx deleted file mode 100644 index f8cb16271abf3a4c98a89a12d08ad9ed9b44763d..0000000000000000000000000000000000000000 --- a/haxe/std/neko/zip/Reader.hx +++ /dev/null @@ -1,287 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.zip; - -typedef ZipEntry = { - var fileName : String; - var fileSize : Int; - var fileTime : Date; - var compressed : Bool; - var compressedSize : Int; - var data : haxe.io.Bytes; - var crc32 : Null; -} - -// see http://www.pkware.com/documents/casestudies/APPNOTE.TXT - -class Reader { - - public static function unzip( f : ZipEntry ) : haxe.io.Bytes { - if( !f.compressed ) - return f.data; - var c = new Uncompress(-15); - var s = haxe.io.Bytes.alloc(f.fileSize); - var r = c.execute(f.data,0,s,0); - c.close(); - if( !r.done || r.read != f.data.length || r.write != f.fileSize ) - throw "Invalid compressed data for "+f.fileName; - return s; - } - - static function readZipDate( i : haxe.io.Input ) { - var t = i.readUInt16(); - var hour = (t >> 11) & 31; - var min = (t >> 5) & 63; - var sec = t & 31; - var d = i.readUInt16(); - var year = d >> 9; - var month = (d >> 5) & 15; - var day = d & 31; - return new Date(year + 1980, month-1, day, hour, min, sec << 1); - } - - public static function readZipEntry( i : haxe.io.Input ) : ZipEntry { - var h = i.readInt31(); - if( h == 0x02014B50 || h == 0x06054B50 ) - return null; - if( h != 0x04034B50 ) - throw "Invalid Zip Data"; - var version = i.readUInt16(); - var flags = i.readUInt16(); - var extraFields = (flags & 8) != 0; - if( (flags & 0xFFF7) != 0 ) - throw "Unsupported flags "+flags; - var compression = i.readUInt16(); - var compressed = (compression != 0); - if( compressed && compression != 8 ) - throw "Unsupported compression "+compression; - var mtime = readZipDate(i); - var crc32 = i.readInt32(); - var csize = i.readUInt30(); - var usize = i.readUInt30(); - var fnamelen = i.readInt16(); - var elen = i.readInt16(); - var fname = i.readString(fnamelen); - var ename = i.readString(elen); - var data; - if( extraFields ) { - // TODO : it is needed to directly read the compressed - // data streamed from the input (needs additional neko apis) - // then, we can set "compressed" to false, and then follows - // 12 bytes with real crc, csize and usize - throw "Zip format with extrafields is currently not supported"; - } else - data = i.read(csize); - return { - fileName : fname, - fileSize : usize, - fileTime : mtime, - compressed : compressed, - compressedSize : csize, - data : data, - crc32 : crc32, - }; - } - - public static function readZip( i : haxe.io.Input ) : List { - var l = new List(); - while( true ) { - var e = readZipEntry(i); - if( e == null ) - break; - l.add(e); - } - return l; - } - - public static function readTar( i : haxe.io.Input, ?gz : Bool ) : List { - if( gz ) { - var tmp = new haxe.io.BytesOutput(); - readGZHeader(i); - readGZData(i,tmp); - i = new haxe.io.BytesInput(tmp.getBytes()); - } - var l = new List(); - while( true ) { - var e = readTarEntry(i); - if( e == null ) - break; - var pad = Math.ceil(e.fileSize / 512) * 512 - e.fileSize; - var data = i.read(e.fileSize); - i.read(pad); - l.add({ - fileName : e.fileName, - fileSize : e.fileSize, - fileTime : e.fileTime, - compressed : false, - compressedSize : e.fileSize, - data : data, - crc32 : null, - }); - } - return l; - } - - public static function readGZHeader( i : haxe.io.Input ) : String { - if( i.readByte() != 0x1F || i.readByte() != 0x8B ) - throw "Invalid GZ header"; - if( i.readByte() != 8 ) - throw "Invalid compression method"; - var flags = i.readByte(); - var mtime = i.read(4); - var xflags = i.readByte(); - var os = i.readByte(); - var fname = null; - var comments = null; - if( flags & 4 != 0 ) { - var xlen = i.readUInt16(); - var xdata = i.read(xlen); - } - if( flags & 8 != 0 ) - fname = i.readUntil(0); - if( flags & 16 != 0 ) - comments = i.readUntil(0); - if( flags & 2 != 0 ) { - var hcrc = i.readUInt16(); - // does not check header crc - } - return fname; - } - - public static function readGZData( i : haxe.io.Input, o : haxe.io.Output, ?bufsize : Int ) : Int { - if( bufsize == null ) bufsize = (1 << 16); // 65Ks - var u = new Uncompress(-15); - u.setFlushMode(Flush.SYNC); - var buf = haxe.io.Bytes.alloc(bufsize); - var out = haxe.io.Bytes.alloc(bufsize); - var bufpos = bufsize; - var tsize = 0; - while( true ) { - if( bufpos == buf.length ) { - buf = refill(i,buf,0); - bufpos = 0; - } - var r = u.execute(buf,bufpos,out,0); - if( r.read == 0 ) { - if( bufpos == 0 ) - throw new haxe.io.Eof(); - var len = buf.length - bufpos; - buf.blit(0,buf,bufpos,len); - buf = refill(i,buf,len); - bufpos = 0; - } else { - bufpos += r.read; - tsize += r.read; - o.writeFullBytes(out,0,r.write); - if( r.done ) - break; - } - } - return tsize; - } - - static function refill( i, buf : haxe.io.Bytes, pos : Int ) { - try { - while( pos != buf.length ) { - var k = i.readBytes(buf,pos,buf.length-pos); - pos += k; - } - } catch( e : haxe.io.Eof ) { - } - if( pos == 0 ) - throw new haxe.io.Eof(); - if( pos != buf.length ) - buf = buf.sub(0,pos); - return buf; - } - - public static function readTarEntry( i : haxe.io.Input ) { - var fname = i.readUntil(0); - if( fname.length == 0 ) { - for( x in 0...511+512 ) - if( i.readByte() != 0 ) - throw "Invalid TAR end"; - return null; - } - i.read(99 - fname.length); // skip - var fmod = parseOctal(i.read(8)); - var uid = parseOctal(i.read(8)); - var gid = parseOctal(i.read(8)); - var fsize = parseOctal(i.read(12)); - // read in two parts in order to prevent overflow - var mtime : Float = parseOctal(i.read(8)); - mtime = mtime * 512.0 + parseOctal(i.read(4)); - var crc = i.read(8); - var type = i.readByte(); - var lname = i.readUntil(0); - i.read(99 - lname.length); // skip - var ustar = i.readString(8); - if( ustar != "ustar \x00" && ustar != "ustar\x00\x00\x00" ) { - //trace(StringTools.urlEncode(ustar)); - throw "Not an tar ustar file"; - } - var uname = i.readUntil(0); - i.read(31 - uname.length); - var gname = i.readUntil(0); - i.read(31 - gname.length); - var devmaj = parseOctal(i.read(8)); - var devmin = parseOctal(i.read(8)); - var prefix = i.readUntil(0); - i.read(166 - prefix.length); - return { - fileName : fname, - fileSize : fsize, - fileTime : Date.fromTime(mtime * 1000.0), - }; - } - - public static function readTarData( i : haxe.io.Input, o : haxe.io.Output, size : Int, ?bufsize ) { - if( bufsize == null ) bufsize = (1 << 16); // 65Ks - var buf = haxe.io.Bytes.alloc(bufsize); - var pad = Math.ceil(size / 512) * 512 - size; - while( size > 0 ) { - var n = i.readBytes(buf,0,if( size > bufsize ) bufsize else size); - size -= n; - o.writeFullBytes(buf,0,n); - } - i.read(pad); - } - - static function parseOctal( n : haxe.io.Bytes ) { - var i = 0; - for( p in 0...n.length ) { - var c = n.get(p); - if( c == 0 ) - break; - if( c == 32 ) - continue; - if( c < 48 || c > 55 ) - throw "Invalid octal char"; - i = (i * 8) + (c - 48); - } - return i; - } - -} \ No newline at end of file diff --git a/haxe/std/neko/zip/Uncompress.hx b/haxe/std/neko/zip/Uncompress.hx deleted file mode 100644 index 03bb6e5a9199872de8857389df96f793075de4b2..0000000000000000000000000000000000000000 --- a/haxe/std/neko/zip/Uncompress.hx +++ /dev/null @@ -1,70 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.zip; - -class Uncompress { - - var s : Void; - - public function new( windowBits : Int ) { - s = _inflate_init(windowBits); - } - - public function execute( src : haxe.io.Bytes, srcPos : Int, dst : haxe.io.Bytes, dstPos : Int ) : { done : Bool, read : Int, write : Int } { - return _inflate_buffer(s,src.getData(),srcPos,dst.getData(),dstPos); - } - - public function setFlushMode( f : Flush ) { - _set_flush_mode(s,untyped Std.string(f).__s); - } - - public function close() { - _inflate_end(s); - } - - public static function run( src : haxe.io.Bytes, ?bufsize ) : haxe.io.Bytes { - var u = new Uncompress(null); - if( bufsize == null ) bufsize = 1 << 16; // 64K - var tmp = haxe.io.Bytes.alloc(bufsize); - var b = new haxe.io.BytesBuffer(); - var pos = 0; - u.setFlushMode(Flush.SYNC); - while( true ) { - var r = u.execute(src,pos,tmp,0); - b.addBytes(tmp,0,r.write); - pos += r.read; - if( r.done ) - break; - } - u.close(); - return b.getBytes(); - } - - static var _inflate_init = neko.Lib.load("zlib","inflate_init",1); - static var _inflate_buffer = neko.Lib.load("zlib","inflate_buffer",5); - static var _inflate_end = neko.Lib.load("zlib","inflate_end",1); - static var _set_flush_mode = neko.Lib.load("zlib","set_flush_mode",2); - -} diff --git a/haxe/std/neko/zip/Writer.hx b/haxe/std/neko/zip/Writer.hx deleted file mode 100644 index dbe305412e9645b8e72c4e11c5ca456cea61ab8d..0000000000000000000000000000000000000000 --- a/haxe/std/neko/zip/Writer.hx +++ /dev/null @@ -1,134 +0,0 @@ -/* - * Copyright (c) 2005-2008, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package neko.zip; - -class Writer { - - /* - * The next constant is required for computing the Central - * Directory Record(CDR) size. CDR consists of some fields - * of constant size and a filename. Constant represents - * total length of all fields with constant size for each - * file in archive - */ - private static var CENTRAL_DIRECTORY_RECORD_FIELDS_SIZE = 46; - - /* - * The following constant is the total size of all fields - * of Local File Header. It's required for calculating - * offset of start of central directory record - */ - private static var LOCAL_FILE_HEADER_FIELDS_SIZE = 30; - - static function writeZipDate( o : haxe.io.Output, date : Date ) { - var hour = date.getHours(); - var min = date.getMinutes(); - var sec = date.getSeconds() >> 1; - o.writeUInt16( (hour << 11) | (min << 5) | sec ); - var year = date.getFullYear() - 1980; - var month = date.getMonth() + 1; - var day = date.getDate(); - o.writeUInt16( (year << 9) | (month << 5) | day ); - } - - static function writeZipEntry( o : haxe.io.Output, level, f : { data : haxe.io.Bytes, fileName : String, fileTime : Date } ) { - var fdata = f.data, cdata = null, crc32, compressed = true; - o.writeUInt30(0x04034B50); - o.writeUInt16(0x0014); // version - o.writeUInt16(0); // flags - if( fdata == null ) { - fdata = haxe.io.Bytes.alloc(0); - cdata = haxe.io.Bytes.ofString("XXXXXX"); - crc32 = haxe.Int32.ofInt(0); - compressed = false; - } else { - crc32 = CRC32.encode(f.data); - cdata = Compress.run( f.data, level ); - } - o.writeUInt16(compressed?8:0); - writeZipDate(o,f.fileTime); - o.writeInt32(crc32); - o.writeUInt30(cdata.length - 6); - o.writeUInt30(fdata.length); - o.writeUInt16(f.fileName.length); - o.writeUInt16(0); - o.writeString(f.fileName); - if( cdata != null ) o.writeFullBytes(cdata,2,cdata.length-6); - return { - compressed : compressed, - fileName : f.fileName, - dlen : fdata.length, - clen : cdata.length - 6, - date : f.fileTime, - crc32 : crc32, - }; - } - - public static function writeZip( o : haxe.io.Output, files, compressionLevel : Int ) { - var files = Lambda.map(files,callback(writeZipEntry,o,compressionLevel)); - var cdr_size = 0; - var cdr_offset = 0; - for( f in files ) { - var namelen = f.fileName.length; - o.writeUInt30(0x02014B50); // header - o.writeUInt16(0x0014); // version made-by - o.writeUInt16(0x0014); // version - o.writeUInt16(0); // flags - o.writeUInt16(f.compressed?8:0); - writeZipDate(o,f.date); - o.writeInt32(f.crc32); - o.writeUInt30(f.clen); - o.writeUInt30(f.dlen); - o.writeUInt16(namelen); - o.writeUInt16(0); //extra field length always 0 - o.writeUInt16(0); //comment length always 0 - o.writeUInt16(0); //disk number start - o.writeUInt16(0); //internal file attributes - o.writeUInt30(0); //external file attributes - o.writeUInt30(cdr_offset); //relative offset of local header - o.writeString(f.fileName); - cdr_size += CENTRAL_DIRECTORY_RECORD_FIELDS_SIZE + namelen; - cdr_offset += LOCAL_FILE_HEADER_FIELDS_SIZE + namelen + f.clen; - } - //end of central dir signature - o.writeUInt30(0x06054B50); - //number of this disk - o.writeUInt16(0); - //number of the disk with the start of the central directory - o.writeUInt16(0); - //total number of entries in the central directory on this disk - o.writeUInt16(files.length); - //total number of entries in the central directory - o.writeUInt16(files.length); - //size of the central directory record - o.writeUInt30(cdr_size); - //offset of start of central directory with respect to the starting disk number - o.writeUInt30(cdr_offset); - // .ZIP file comment length - o.writeUInt16(0); - } - - -} \ No newline at end of file diff --git a/haxe/std/php/Exception.hx b/haxe/std/php/Exception.hx deleted file mode 100644 index 11a21bfc0829aa4348aa6d13befa6f4f28f5be11..0000000000000000000000000000000000000000 --- a/haxe/std/php/Exception.hx +++ /dev/null @@ -1,19 +0,0 @@ -package php; - -extern class Exception { - public function new(?message : String, ?code : Int) : Void; - - private var message : String; - private var code : Int; - private var file : String; - private var line : Int; - - public function getMessage() : String; // message of the exception - public function getCode() : Int; // code of the exception - public function getFile() : String; // source filename - public function getLine() : Int; // source line - public function getTrace() : Array; // an array of the backtrace() - public function getTraceAsString() : String; // formated string of trace - - public function __toString() : String; // formated string for display -} \ No newline at end of file diff --git a/haxe/std/php/FileSystem.hx b/haxe/std/php/FileSystem.hx deleted file mode 100644 index 2b0074680d262feae132408df48ca0affa27e165..0000000000000000000000000000000000000000 --- a/haxe/std/php/FileSystem.hx +++ /dev/null @@ -1,112 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php; - -typedef FileStat = { - var gid : Int; - var uid : Int; - var atime : Date; - var mtime : Date; - var ctime : Date; - var dev : Int; - var ino : Int; - var nlink : Int; - var rdev : Int; - var size : Int; - var mode : Int; -} - -enum FileKind { - kdir; - kfile; - kother( k : String ); -} - -class FileSystem { - - public static inline function exists( path : String ) : Bool { - return untyped __call__("file_exists", path); - } - - public static inline function rename( path : String, newpath : String ) { - return untyped __call__("rename", path, newpath); - } - - public static function stat( path : String ) : FileStat { - untyped __php__('$fp = fopen($path, "r"); - $fstat = fstat($fp); - fclose($fp);'); - return untyped { - gid : __php__("$fstat['gid']"), - uid : __php__("$fstat['uid']"), - atime : Date.fromTime(__php__("$fstat['atime']")*1000), - mtime : Date.fromTime(__php__("$fstat['mtime']")*1000), - ctime : Date.fromTime(__php__("$fstat['ctime']")*1000), - dev : __php__("$fstat['dev']"), - ino : __php__("$fstat['ino']"), - nlink : __php__("$fstat['nlink']"), - rdev : __php__("$fstat['rdev']"), - size : __php__("$fstat['size']"), - mode : __php__("$fstat['mode']") - }; - } - - public static inline function fullPath( relpath : String ) : String { - return untyped __call__("realpath", relpath); - } - - public static function kind( path : String ) : FileKind { - var k = untyped __call__("filetype", path); - switch(k) { - case "file": return kfile; - case "dir": return kdir; - default: return kother(k); - } - } - - public static inline function isDirectory( path : String ) : Bool { - return untyped __call__("is_dir", path); - } - - public static inline function createDirectory( path : String ) { - return untyped __call__("@mkdir", path, 493); // php default is 0777, neko is 0755 - } - - public static inline function deleteFile( path : String ) { - return untyped __call__("@unlink", path); - } - - public static inline function deleteDirectory( path : String ) { - return untyped __call__("@rmdir", path); - } - - public static function readDirectory( path : String ) : Array { - var l = untyped __call__("array"); - untyped __php__('$dh = opendir($path); - while (($file = readdir($dh)) !== false) if("." != $file && ".." != $file) $l[] = $file; - closedir($dh);'); - return untyped __call__("new _hx_array", l); - } -} diff --git a/haxe/std/php/HException.hx b/haxe/std/php/HException.hx deleted file mode 100644 index 04f082493f7815932c8156e28a7cba8300c0b492..0000000000000000000000000000000000000000 --- a/haxe/std/php/HException.hx +++ /dev/null @@ -1,9 +0,0 @@ -package php; - -extern class HException extends Exception { - public var e : Dynamic; - public var p : haxe.PosInfos; - public function new(e : Dynamic, ?message : String, ?code : Int, ?p : haxe.PosInfos) : Void; - public function setLine(l:Int) : Void; - public function setFile(f:String) : Void; -} \ No newline at end of file diff --git a/haxe/std/php/IteratorAggregate.hx b/haxe/std/php/IteratorAggregate.hx deleted file mode 100644 index 2d73cc0ea8da369e29dea54d0afbc26569b32681..0000000000000000000000000000000000000000 --- a/haxe/std/php/IteratorAggregate.hx +++ /dev/null @@ -1,10 +0,0 @@ -package php; - -extern interface IteratorAggregate { - /** - This method is not public to not induce haXe users to use it ;) - Use iterator() instead. - The return type would be Aggregator that is unusable in haXe - **/ - private function getIterator() : Iterator; // -} \ No newline at end of file diff --git a/haxe/std/php/NativeArray.hx b/haxe/std/php/NativeArray.hx deleted file mode 100644 index 23e1d7d8cf413ac6d602c73e66feb5ab0cc88e7f..0000000000000000000000000000000000000000 --- a/haxe/std/php/NativeArray.hx +++ /dev/null @@ -1,5 +0,0 @@ -package php; - -extern class NativeArray implements ArrayAccess { - -} \ No newline at end of file diff --git a/haxe/std/php/NativeString.hx b/haxe/std/php/NativeString.hx deleted file mode 100644 index fdec1b97641e2b8200394ca06e5a0721334b855e..0000000000000000000000000000000000000000 --- a/haxe/std/php/NativeString.hx +++ /dev/null @@ -1,5 +0,0 @@ -package php; - -extern class NativeString implements ArrayAccess { - -} \ No newline at end of file diff --git a/haxe/std/php/PhpDate__.hx b/haxe/std/php/PhpDate__.hx deleted file mode 100644 index 81c611d52e18feeebae71ea1428992567a977ad3..0000000000000000000000000000000000000000 --- a/haxe/std/php/PhpDate__.hx +++ /dev/null @@ -1,98 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php; - -class PhpDate__ //implements Date -{ - static var __name__ = ["Date"]; - private var __t : Float; - - public function new(year : Int, month : Int, day : Int, hour : Int, min : Int, sec : Int ) { - __t = untyped __call__("mktime", hour, min, sec, month+1, day, year); - } - - public function getTime() : Float { - return __t*1000; - } - - public function getPhpTime() : Float { - return __t; - } - - public function getFullYear() : Int { - return untyped __call__("intval", __call__("date", "Y", this.__t)); - } - - public function getMonth() : Int { - var m : Int = untyped __call__("intval", __call__("date", "n", this.__t)); - return -1 + m; - } - - public function getDate() : Int { - return untyped __call__("intval", __call__("date", "j", this.__t)); - } - - public function getHours() : Int { - return untyped __call__("intval", __call__("date", "G", this.__t)); - } - - public function getMinutes() : Int { - return untyped __call__("intval", __call__("date", "i", this.__t)); - } - - public function getSeconds() : Int { - return untyped __call__("intval", __call__("date", "s", this.__t)); - } - - public function getDay() : Int { - return untyped __call__("intval", __call__("date", "w", this.__t)); - } - - public function toString():String { - return untyped __call__("date", "Y-m-d H:i:s", this.__t); - } - - public static function now() { - return fromPhpTime(untyped __call__("time")); - } - - public static function fromPhpTime( t : Float ){ - var d = new PhpDate__(2000,1,1,0,0,0); - d.__t = t; - return d; - } - - public static function fromTime( t : Float ){ - var d = new PhpDate__(2000,1,1,0,0,0); - d.__t = t/1000; - return d; - } - - public static function fromString( s : String ) { - return fromPhpTime(untyped __call__("strtotime", s)); - } -} - - diff --git a/haxe/std/php/PhpMath__.hx b/haxe/std/php/PhpMath__.hx deleted file mode 100644 index b097637c1672eb6b438bb4aca93972c4fad16a78..0000000000000000000000000000000000000000 --- a/haxe/std/php/PhpMath__.hx +++ /dev/null @@ -1,64 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php; - -class PhpMath__ -{ - public static var PI; - public static var NaN; - public static var POSITIVE_INFINITY; - public static var NEGATIVE_INFINITY; - - public static function abs(v) { return untyped __call__("abs", v); } - public static function min(a,b) { return untyped __call__("min", a, b); } - public static function max(a,b) { return untyped __call__("max", a, b); } - public static function sin(v) { return untyped __call__("sin", v); } - public static function cos(v) { return untyped __call__("cos", v); } - public static function atan2(y,x) { return untyped __call__("atan2", y, x); } - public static function tan(v) { return untyped __call__("tan", v); } - public static function exp(v) { return untyped __call__("exp", v); } - public static function log(v) { return untyped __call__("log", v); } - public static function sqrt(v) { return untyped __call__("sqrt", v); } - public static function round(v) { return untyped __call__("(int) floor", v + 0.5); } - public static function floor(v) { return untyped __call__("(int) floor", v); } - public static function ceil(v) { return untyped __call__("(int) ceil", v); } - public static function atan(v) { return untyped __call__("atan", v); } - public static function asin(v) { return untyped __call__("asin", v); } - public static function acos(v) { return untyped __call__("acos", v); } - public static function pow(b,e) { return untyped __call__("pow", b, e); } - public static function random() { return untyped __call__("mt_rand") / __call__("mt_getrandmax"); } - public static function isNaN(f) { return untyped __call__("is_nan", f); } - public static function isFinite(f) { return untyped __call__("is_finite", f); } - - static function __init__() { - PI = untyped __php__("M_PI"); - NaN = untyped __php__("acos(1.01)"); - NEGATIVE_INFINITY = untyped __php__("log(0)"); - POSITIVE_INFINITY = -NEGATIVE_INFINITY; - } - -} - - diff --git a/haxe/std/php/PhpXml__.hx b/haxe/std/php/PhpXml__.hx deleted file mode 100644 index 65a539a798a6988a338f0e1056e347d3d02366de..0000000000000000000000000000000000000000 --- a/haxe/std/php/PhpXml__.hx +++ /dev/null @@ -1,404 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php; -import Xml; - -class PhpXml__ { - - public static var Element(default,null) : XmlType; - public static var PCData(default,null) : XmlType; - public static var CData(default,null) : XmlType; - public static var Comment(default,null) : XmlType; - public static var DocType(default,null) : XmlType; - public static var Prolog(default,null) : XmlType; - public static var Document(default,null) : XmlType; - - public var nodeType(default,null) : XmlType; - public var nodeName(getNodeName,setNodeName) : String; - public var nodeValue(getNodeValue,setNodeValue) : String; - public var parent(getParent,null) : PhpXml__; - - public var _nodeName : String; - public var _nodeValue : String; - public var _attributes : Hash; - public var _children : Array; - public var _parent : PhpXml__; - - private static var build : PhpXml__; - private static function __start_element_handler(parser : Dynamic, name : String, attribs : ArrayAccess) { - var node = createElement(name); - untyped __php__("while(list($k, $v) = each($attribs)) $node->set($k, $v)"); - build.addChild(node); - build = node; - } - - private static function __end_element_handler(parser : Dynamic, name : String) { - build = build.getParent(); - } - - private static function __character_data_handler(parser : Dynamic, data : String) { - // TODO: this function can probably be simplified -// var lc : PhpXml__ = (build._children == null || build._children.length == 0) ? null : build._children[build._children.length-1]; -// if(lc != null && Xml.PCData == lc.nodeType) { -// lc.nodeValue = lc.nodeValue + untyped __call__("htmlentities", data); -// } else - if((untyped __call__("strlen", data) == 1 && __call__("htmlentities", data) != data) || untyped __call__("htmlentities", data) == data) { - build.addChild(createPCData(untyped __call__("htmlentities", data))); - } else - build.addChild(createCData(data)); - } - - private static function __default_handler(parser : Dynamic, data : String) { - build.addChild(createPCData(data)); - } - - static var xmlChecker = new EReg("\\s*(<\\?xml|"+str+""; - - if(1 != untyped __call__("xml_parse", xml_parser, str, true)) { - throw "Xml parse error ("+untyped __call__("xml_error_string", __call__("xml_get_error_code", xml_parser)) + ") line #" + __call__("xml_get_current_line_number", xml_parser); - } - - untyped __call__("xml_parser_free", xml_parser); - - if(isComplete) { - return build; - } else { - build = build._children[0]; - build._parent = null; - build._nodeName = null; - build.nodeType = Document; - return build; - } - } - - private function new(); - - public static function createElement( name : String ) : PhpXml__ { - var r = new PhpXml__(); - r.nodeType = Xml.Element; - r._children = new Array(); - r._attributes = new Hash(); - r.setNodeName( name ); - return r; - } - - public static function createPCData( data : String ) : PhpXml__ { - var r = new PhpXml__(); - r.nodeType = Xml.PCData; - r.setNodeValue( data ); - return r; - } - - public static function createCData( data : String ) : PhpXml__ { - var r = new PhpXml__(); - r.nodeType = Xml.CData; - r.setNodeValue( data ); - return r; - } - - public static function createComment( data : String ) : PhpXml__ { - var r = new PhpXml__(); - r.nodeType = Xml.Comment; - r.setNodeValue( data ); - return r; - } - - public static function createDocType( data : String ) : PhpXml__ { - var r = new PhpXml__(); - r.nodeType = Xml.DocType; - r.setNodeValue( data ); - return r; - } - - public static function createProlog( data : String ) : PhpXml__ { - var r = new PhpXml__(); - r.nodeType = Xml.Prolog; - r.setNodeValue( data ); - return r; - } - - public static function createDocument() : PhpXml__ { - var r = new PhpXml__(); - r.nodeType = Xml.Document; - r._children = new Array(); - return r; - } - - private function getNodeName() : String { - if( nodeType != Xml.Element ) - throw "bad nodeType"; - return _nodeName; - } - - private function setNodeName( n : String ) : String { - if( nodeType != Xml.Element ) - throw "bad nodeType"; - return _nodeName = n; - } - - private function getNodeValue() : String { - if( nodeType == Xml.Element || nodeType == Xml.Document ) - throw "bad nodeType"; - return _nodeValue; - } - - private function setNodeValue( v : String ) : String { - if( nodeType == Xml.Element || nodeType == Xml.Document ) - throw "bad nodeType"; - return _nodeValue = v; - } - - private function getParent() { - return _parent; - } - - public function get( att : String ) : String { - if( nodeType != Xml.Element ) - throw "bad nodeType"; - return _attributes.get( att ); - } - - public function set( att : String, value : String ) : Void { - if( nodeType != Xml.Element ) - throw "bad nodeType"; - _attributes.set( att, untyped __call__("htmlspecialchars", value, __php__('ENT_COMPAT'), 'UTF-8')); - } - - public function remove( att : String ) : Void{ - if( nodeType != Xml.Element ) - throw "bad nodeType"; - _attributes.remove( att ); - } - - public function exists( att : String ) : Bool { - if( nodeType != Xml.Element ) - throw "bad nodeType"; - return _attributes.exists( att ); - } - - public function attributes() : Iterator { - if( nodeType != Xml.Element ) - throw "bad nodeType"; - return _attributes.keys(); - } - - public function iterator() : Iterator { - if( _children == null ) throw "bad nodetype"; - var me = this; - var it = null; - it = untyped { - cur: 0, - x: me._children, - hasNext : function(){ - return it.cur < it.x.length; - }, - next : function(){ - return it.x[it.cur++]; - } - } - return cast it; - } - - public function elements() : Iterator { - if( _children == null ) throw "bad nodetype"; - var me = this; - var it = null; - it = untyped { - cur: 0, - x: me._children, - hasNext : function() { - var k = it.cur; - var l = it.x.length; - while( k < l ) { - - if( it.x[k].nodeType == Xml.Element ) - __php__("break"); - k += 1; - } - it.cur = k; - return k < l; - }, - next : function() { - var k = it.cur; - var l = it.x.length; - while( k < l ) { - var n = it.x[k]; - k += 1; - if( n.nodeType == Xml.Element ) { - it.cur = k; - return n; - } - } - return null; - } - } - return cast it; - } - - public function elementsNamed( name : String ) : Iterator { - if( _children == null ) throw "bad nodetype"; - - var me = this; - var it = null; - it = untyped { - cur: 0, - x: me._children, - hasNext : function() { - var k = it.cur; - var l = it.x.length; - while( k < l ) { - var n = it.x[k]; - if( n.nodeType == Xml.Element && n._nodeName == name ) - __php__("break"); - k++; - } - it.cur = k; - return k < l; - }, - next : function() { - var k = it.cur; - var l = it.x.length; - while( k < l ) { - var n = it.x[k]; - k++; - if( n.nodeType == Xml.Element && n._nodeName == name ) { - it.cur = k; - return n; - } - } - return null; - } - } - return cast it; - } - - public function firstChild() : PhpXml__ { - if( _children == null ) throw "bad nodetype"; - if( _children.length == 0 ) return null; - return _children[0]; - } - - public function firstElement() : PhpXml__ { - if( _children == null ) throw "bad nodetype"; - var cur = 0; - var l = _children.length; - while( cur < l ) { - var n = _children[cur]; - if( n.nodeType == Xml.Element ) - return n; - cur++; - } - return null; - } - - public function addChild( x : PhpXml__ ) : Void { - if( _children == null ) throw "bad nodetype"; - if( x._parent != null ) x._parent._children.remove(x); - x._parent = this; - _children.push( x ); - } - - public function removeChild( x : PhpXml__ ) : Bool { - if( _children == null ) throw "bad nodetype"; - var b = _children.remove( x ); - if( b ) - x._parent = null; - return b; - } - - public function insertChild( x : PhpXml__, pos : Int ) : Void { - if( _children == null ) throw "bad nodetype"; - if( x._parent != null ) x._parent._children.remove(x); - x._parent = this; - _children.insert( pos, x ); - } - - public function toString() { - if( nodeType == Xml.PCData ) - return _nodeValue; - - var s = ""; - - if( nodeType == Xml.Element ) { - s += "<"; - s += _nodeName; - for( k in _attributes.keys() ){ - s += " "; - s += k; - s += "=\""; // \" - s += _attributes.get(k); - s += "\""; // \" - } - if( _children.length == 0 ) { - s += "/>"; - return s; - } - s += ">"; - } else if( nodeType == Xml.CData ) - return ""; - else if( nodeType == Xml.Comment ) - return ""; - else if( nodeType == Xml.DocType ) - return ""; - else if( nodeType == Xml.Prolog ) - return ""; - - - for( x in iterator() ) - s += x.toString(); - - if( nodeType == Xml.Element ) { - s += ""; - } - return s; - } - - static function __init__() : Void untyped { - PhpXml__.Element = "element"; - PhpXml__.PCData = "pcdata"; - PhpXml__.CData = "cdata"; - PhpXml__.Comment = "comment"; - PhpXml__.DocType = "doctype"; - PhpXml__.Prolog = "prolog"; - PhpXml__.Document = "document"; - } - -} diff --git a/haxe/std/php/Sys.hx b/haxe/std/php/Sys.hx deleted file mode 100644 index 192070160efa35b1b56ff4b8184d8f04b27d67c9..0000000000000000000000000000000000000000 --- a/haxe/std/php/Sys.hx +++ /dev/null @@ -1,90 +0,0 @@ -package php; - - -class Sys { - public static function args() : Array { - return untyped __call__('array_key_exists', 'argv', __var__('_SERVER')) ? __call__('new _hx_array', __call__('array_slice', __var__('_SERVER', 'argv'), 1)) : []; - } - - public static function getEnv( s : String ) : String { - return untyped __call__("getenv", s); - } - - public static function putEnv( s : String, v : String ) : Void { - return untyped __call__("putenv", s + "=" + v); - } - - public static function sleep( seconds : Float ) { - return untyped __call__("usleep", seconds*1000000); - } - - public static function setTimeLocale( loc : String ) : Bool { - return untyped __call__("setlocale", __php__("LC_TIME"), loc) != false; - } - - public static function getCwd() : String { - var cwd : String = untyped __call__("getcwd"); - var l = cwd.substr(-1); - return cwd + (l == '/' || l == '\\' ? '' : '/'); - } - - public static function setCwd( s : String ) { - return untyped __call__("chdir", s); - } - - public static function systemName() : String { - var s : String = untyped __call__("php_uname", "s"); - var p : Int; - if((p = s.indexOf(" ")) >= 0) - return s.substr(0, p); - else - return s; - } - - public static function escapeArgument( arg : String ) : String { - var ok = true; - for( i in 0...arg.length ) - switch( arg.charCodeAt(i) ) { - case 32, 34: // [space] " - ok = false; - case 0, 13, 10: // [eof] [cr] [lf] - arg = arg.substr(0,i); - } - if( ok ) - return arg; - return '"'+arg.split('"').join('\\"')+'"'; - } - - public static function command( cmd : String, ?args : Array ) : Int { - if( args != null ) { - cmd = escapeArgument(cmd); - for( a in args ) - cmd += " "+escapeArgument(a); - } - var result = 0; - var output = ""; -// untyped __call__("exec", cmd, output, result); - untyped __call__("system", cmd, result); - return result; - } - - public static function exit( code : Int ) { - return untyped __call__("exit", code); - } - - public static function time() : Float { - return untyped __call__("microtime", true); - } - - public static function cpuTime() : Float { - return untyped __call__("microtime", true) - __php__("$_SERVER['REQUEST_TIME']"); - } - - public static function executablePath() : String { - return untyped __php__("$_SERVER['SCRIPT_FILENAME']"); - } - - public static function environment() : Hash { - return Lib.hashOfAssociativeArray(untyped __php__("$_SERVER")); - } -} diff --git a/haxe/std/php/Utf8.hx b/haxe/std/php/Utf8.hx deleted file mode 100644 index de903660760537c00f62fddf83d371c433764736..0000000000000000000000000000000000000000 --- a/haxe/std/php/Utf8.hx +++ /dev/null @@ -1,87 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php; - -class Utf8 { - - var __b : String; - - public function new() { - __b = ''; - } - - public function addChar( c : Int ) { - __b += uchr(c); - } - - public function toString() : String { - return __b; - } - - public static function encode( s : String ) : String { - return untyped __call__("utf8_encode", s); - } - - public static function decode( s : String ) : String { - return untyped __call__("utf8_decode", s); - } - - public static function iter(s : String, chars : Int -> Void ) { - var len = length(s); - for(i in 0...len) - chars(charCodeAt(s, i)); - } - - public static function charCodeAt( s : String, index : Int ) : Int { - return uord(sub(s, index, 1)); - } - - public static function uchr(i : Int) : String { - return untyped __php__("mb_convert_encoding(pack('N',$i), 'UTF-8', 'UCS-4BE')"); - } - - public static function uord(s : String) : Int untyped { - var c : Array = untyped __php__("unpack('N', mb_convert_encoding($s, 'UCS-4BE', 'UTF-8'))"); - return c[1]; - } - - public static function validate( s : String ) : Bool { - return untyped __call__("mb_check_encoding", s, enc); - } - - public static function length( s : String ) : Int { - return untyped __call__("mb_strlen", s, enc); - } - - public static function compare( a : String, b : String ) : Int { - return untyped __call__("strcmp", a, b); - } - - public static function sub( s : String, pos : Int, len : Int ) : String { - return untyped __call__("mb_substr", s, pos, len, enc); - } - - private static inline var enc = "UTF-8"; -} \ No newline at end of file diff --git a/haxe/std/php/_std/EReg.hx b/haxe/std/php/_std/EReg.hx deleted file mode 100644 index ea27e59d464bb27daec5496e08365bc4c67db1b5..0000000000000000000000000000000000000000 --- a/haxe/std/php/_std/EReg.hx +++ /dev/null @@ -1,102 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api @:final class EReg { - - var r : Dynamic; - var last : String; - var global : Bool; - var pattern : String; - var options : String; - var re : String; - var matches : ArrayAccess; - - public function new( r : String, opt : String ) : Void { - this.pattern = r; - var a = opt.split("g"); - global = a.length > 1; - if( global ) - opt = a.join(""); - this.options = opt; - this.re = "/" + untyped __call__("str_replace", "/", "\\/", r) + "/" + opt; - } - - public function match( s : String ) : Bool { - var p : Int = untyped __call__("preg_match", re, s, matches, __php__("PREG_OFFSET_CAPTURE")); - if(p > 0) - last = s; - else - last = null; - return p > 0; - } - - public function matched( n : Int ) : String { - if( n < 0 ) throw "EReg::matched"; - // we can't differenciate between optional groups at the end of a match - // that have not been matched and invalid groups - if( n >= untyped __call__("count", matches)) return null; - if(untyped __php__("$this->matches[$n][1] < 0")) return null; - return untyped __php__("$this->matches[$n][0]"); - } - - public function matchedLeft() : String { - if( untyped __call__("count", matches) == 0 ) throw "No string matched"; - return last.substr(0, untyped __php__("$this->matches[0][1]")); - } - - public function matchedRight() : String { - if( untyped __call__("count", matches) == 0 ) throw "No string matched"; - var x : Int = untyped __php__("$this->matches[0][1]") + __call__("strlen",__php__("$this->matches[0][0]")); - return last.substr(x); - } - - public function matchedPos() : { pos : Int, len : Int } { - return untyped { pos : __php__("$this->matches[0][1]"), len : __call__("strlen",__php__("$this->matches[0][0]")) }; - } - - public function split( s : String ) : Array { - return untyped __php__("new _hx_array(preg_split($this->re, $s, $this->hglobal ? -1 : 2))"); - } - - public function replace( s : String, by : String ) : String { - by = untyped __call__("str_replace", "\\$", "\\\\$", by); - by = untyped __call__("str_replace", "$$", "\\$", by); - untyped __php__("if(!preg_match('/\\\\([^?].+?\\\\)/', $this->re)) $by = preg_replace('/\\$(\\d+)/', '\\\\\\$\\1', $by)"); - return untyped __call__("preg_replace", re, by, s, global ? -1 : 1); - } - - public function customReplace( s : String, f : EReg -> String ) : String { - var buf = ""; - while( true ) { - if( !match(s) ) - break; - buf += matchedLeft(); - buf += f(this); - s = matchedRight(); - } - buf += s; - return buf; - } -} diff --git a/haxe/std/php/_std/Hash.hx b/haxe/std/php/_std/Hash.hx deleted file mode 100644 index 5e873d9142fa8e01bc8e25bea2b1392c304943cf..0000000000000000000000000000000000000000 --- a/haxe/std/php/_std/Hash.hx +++ /dev/null @@ -1,85 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Hash implements php.IteratorAggregate { - private var h : ArrayAccess; - - public function new() : Void { - h = untyped __call__('array'); - } - - public function set( key : String, value : T ) : Void { - untyped h[key] = value; - } - - public function get( key : String ) : Null { - if (untyped __call__("array_key_exists", key, h)) - return untyped h[key]; - else - return null; - } - - public function exists( key : String ) : Bool { - return untyped __call__("array_key_exists", key, h); - } - - public function remove( key : String ) : Bool { - if (untyped __call__("array_key_exists", key, h)) { - untyped __call__("unset", h[key]); - return true; - } else - return false; - } - - public function keys() : Iterator { - return untyped __call__("new _hx_array_iterator", __call__("array_keys", h)); - } - - public function iterator() : Iterator { - return untyped __call__("new _hx_array_iterator", __call__("array_values", h)); - } - - public function toString() : String { - var s = "{"; - var it = keys(); - for( i in it ) { - s += i; - s += " => "; - s += Std.string(get(i)); - if( it.hasNext() ) - s += ", "; - } - return s + "}"; - } - - /** - Implement IteratorAggregate for native php iteration - **/ - #if php - function getIterator() : Iterator { - return iterator(); - } - #end -} diff --git a/haxe/std/php/_std/IntHash.hx b/haxe/std/php/_std/IntHash.hx deleted file mode 100644 index e6951e46d76f82a12e85689ab25ee941a5468c2a..0000000000000000000000000000000000000000 --- a/haxe/std/php/_std/IntHash.hx +++ /dev/null @@ -1,84 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class IntHash implements php.IteratorAggregate { - private var h : ArrayAccess; - public function new() : Void { - h = untyped __call__('array'); - } - - public function set( key : Int, value : T ) : Void { - untyped h[key] = value; - } - - public function get( key : Int ) : Null { - if (untyped __call__("array_key_exists", key, h)) - return untyped h[key]; - else - return null; - } - - public function exists( key : Int ) : Bool { - return untyped __call__("array_key_exists", key, h); - } - - public function remove( key : Int ) : Bool { - if (untyped __call__("array_key_exists", key, h)) { - untyped __call__("unset", h[key]); - return true; - } else - return false; - } - - public function keys() : Iterator { - return untyped __call__("new _hx_array_iterator", __call__("array_keys", h)); - } - - public function iterator() : Iterator { - return untyped __call__("new _hx_array_iterator", __call__("array_values", h)); - } - - public function toString() : String { - var s = "{"; - var it = keys(); - for( i in it ) { - s += i; - s += " => "; - s += Std.string(get(i)); - if( it.hasNext() ) - s += ", "; - } - return s + "}"; - } - - /** - Implement IteratorAggregate for native php iteration - **/ - #if php - function getIterator() : Iterator { - return iterator(); - } - #end -} diff --git a/haxe/std/php/_std/Reflect.hx b/haxe/std/php/_std/Reflect.hx deleted file mode 100644 index da4a1ead5a44673d345c4ec00d1e437db6d8d565..0000000000000000000000000000000000000000 --- a/haxe/std/php/_std/Reflect.hx +++ /dev/null @@ -1,100 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Reflect { - - public inline static function hasField( o : Dynamic, field : String ) : Bool { - return untyped __call__("_hx_has_field", o, field); - } - - public static function field( o : Dynamic, field : String ) : Dynamic { - return untyped __call__("_hx_field", o, field); - } - - public inline static function setField( o : Dynamic, field : String, value : Dynamic ) : Void { - untyped __setfield__(o, field, value); - } - - public static function callMethod( o : Dynamic, func : Dynamic, args : Array ) : Dynamic untyped { - if (__call__("is_string", o) && !__call__("is_array", func)) { - return __call__("call_user_func_array", field(o, func), __field__(args, "»a")); - } - return __call__("call_user_func_array", __call__("is_callable", func) ? func : __call__("array", o, func), (null == args ? __call__("array") : __field__(args, "»a"))); - } - - public static function fields( o : Dynamic ) : Array { - if( o == null ) return new Array(); - return untyped __php__('$o instanceof _hx_array') - ? __php__("new _hx_array(array('concat','copy','insert','iterator','length','join','pop','push','remove','reverse','shift','slice','sort','splice','toString','unshift'))") - : (__call__('is_string', o) - ? __php__("new _hx_array(array('charAt','charCodeAt','indexOf','lastIndexOf','length','split','substr','toLowerCase','toString','toUpperCase'))") - : __php__("new _hx_array(_hx_get_object_vars($o))")); - } - - public static function isFunction( f : Dynamic ) : Bool { - return untyped __php__("(is_array($f) && is_callable($f)) || _hx_is_lambda($f)") || (__php__("is_array($f)") && hasField(__php__("$f[0]"), __php__("$f[1]")) && __php__("$f[1]") != "length"); - } - - public static function compare( a : T, b : T ) : Int { - return ( a == b ) ? 0 : (((cast a) > (cast b)) ? 1 : -1); - } - - public static function compareMethods( f1 : Dynamic, f2 : Dynamic ) : Bool { - if(untyped __call__("is_array", f1) && untyped __call__("is_array", f1)) - return untyped __php__("$f1[0] === $f2[0] && $f1[1] == $f2[1]"); - if(untyped __call__("is_string", f1) && untyped __call__("is_string", f2)) - return f1 == f2; - return false; - } - - public static function isObject( v : Dynamic ) : Bool { - if( v == null ) - return false; - if(untyped __call__("is_object", v)) - return untyped __php__("$v instanceof _hx_anonymous") || Type.getClass(v) != null; - if(untyped __php__("is_string($v) && !_hx_is_lambda($v)")) return true; - return false; - } - - public static function deleteField( o : Dynamic, f : String ) : Bool { - if(!hasField(o,f)) return false; - untyped __php__("if(isset($o->»dynamics[$f])) unset($o->»dynamics[$f]); else unset($o->$f)"); - return true; - } - - public static function copy( o : T ) : T { - if(untyped __call__("is_string", o)) return o; - var o2 : Dynamic = {}; - for( f in Reflect.fields(o) ) - Reflect.setField(o2,f,Reflect.field(o,f)); - return o2; - } - - public static function makeVarArgs( f : Array -> Dynamic ) : Dynamic { - untyped __php__("return array(new _hx_lambda(array(&$f), '_hx_make_var_args'), 'execute')"); - } - - -} diff --git a/haxe/std/php/_std/Std.hx b/haxe/std/php/_std/Std.hx deleted file mode 100644 index b0af4038a25b6d57f8a5cc0e89cc12e96669d843..0000000000000000000000000000000000000000 --- a/haxe/std/php/_std/Std.hx +++ /dev/null @@ -1,56 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class Std { - - public static function is( v : Dynamic, t : Dynamic ) : Bool { - return untyped untyped __call__("_hx_instanceof", v,t); - } - - public static function string( s : Dynamic ) : String { - return untyped __call__("_hx_string_rec", s, ''); - } - - public inline static function int( x : Float ) : Int { - return untyped __call__("intval", x); - } - - public static function parseInt( x : String ) : Null { - untyped if (!__call__("is_numeric", x)) { - var matches = null; - __call__('preg_match', '/\\d+/', x, matches); - return __call__("count", matches) == 0 ? null : __call__('intval', matches[0]); - } else - return x.substr(0, 2).toLowerCase() == "0x" ? __php__("(int) hexdec(substr($x, 2))") : __php__("intval($x)"); - } - - public static function parseFloat( x : String ) : Float { - return untyped __php__("is_numeric($x) ? floatval($x) : acos(1.01)"); - } - - public static function random( x : Int ) : Int { - return untyped __call__("rand", 0, x-1); - } -} diff --git a/haxe/std/php/_std/StringBuf.hx b/haxe/std/php/_std/StringBuf.hx deleted file mode 100644 index 4959d3e14793eb508974d49552c7bdbe817018dc..0000000000000000000000000000000000000000 --- a/haxe/std/php/_std/StringBuf.hx +++ /dev/null @@ -1,48 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class StringBuf { - private var b : String; - - public function new() : Void { - b = ""; - } - - public inline function add( ?x : Dynamic ) : Void { - b += x; - } - - public inline function addSub( s : String, pos : Int, ?len : Int ) : Void { - b += s.substr(pos,len); - } - - public inline function addChar( c : Int ) : Void { - b += String.fromCharCode(c); - } - - public inline function toString() : String { - return b; - } -} diff --git a/haxe/std/php/_std/StringTools.hx b/haxe/std/php/_std/StringTools.hx deleted file mode 100644 index 87f05765e8de7e5cdc4342063caf6562b042b451..0000000000000000000000000000000000000000 --- a/haxe/std/php/_std/StringTools.hx +++ /dev/null @@ -1,98 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ - -@:core_api class StringTools { - - public inline static function urlEncode( s : String ) : String untyped { - return __call__("rawurlencode", s); - } - - public inline static function urlDecode( s : String ) : String untyped { - return __call__("urldecode", s); - } - - public static function htmlEscape( s : String ) : String { - return s.split("&").join("&").split("<").join("<").split(">").join(">"); - } - - public inline static function htmlUnescape( s : String ) : String { - return untyped __call__("htmlspecialchars_decode", s); - } - - public static function startsWith( s : String, start : String ) : Bool { - return( s.length >= start.length && s.substr(0,start.length) == start ); - } - - public static function endsWith( s : String, end : String ) : Bool { - var elen = end.length; - var slen = s.length; - return( slen >= elen && s.substr(slen-elen,elen) == end ); - } - - public static function isSpace( s : String, pos : Int ) : Bool { - var c = s.charCodeAt( pos ); - return (c >= 9 && c <= 13) || c == 32; - } - - public inline static function ltrim( s : String ) : String { - return untyped __call__("ltrim", s); - } - - public inline static function rtrim( s : String ) : String { - return untyped __call__("rtrim", s); - } - - public inline static function trim( s : String ) : String { - return untyped __call__("trim", s); - } - - public inline static function rpad( s : String, c : String, l : Int ) : String { - return untyped __call__("str_pad", s, l, c, __php__("STR_PAD_RIGHT")); - } - - public inline static function lpad( s : String, c : String, l : Int ) : String { - return untyped __call__("str_pad", s, l, c, __php__("STR_PAD_LEFT")); - } - - public inline static function replace( s : String, sub : String, by : String ) : String { - return untyped __call__("str_replace", sub, by, s); - } - - public static function hex( n : Int, ?digits : Int ) : String { - var s : String = untyped __call__("dechex", n); - if ( digits != null ) - s = lpad(s, '0', digits); - return s.toUpperCase(); - } - - public static inline function fastCodeAt( s : String, index : Int ) : Int { - return untyped s.cca(index); - } - - public static inline function isEOF( c : Int ) : Bool { - return untyped __physeq__(c, 0); - } - -} diff --git a/haxe/std/php/db/Connection.hx b/haxe/std/php/db/Connection.hx deleted file mode 100644 index 038239f6b29bf53c3767b0a4271ab518373733c2..0000000000000000000000000000000000000000 --- a/haxe/std/php/db/Connection.hx +++ /dev/null @@ -1,40 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.db; - -interface Connection { - - function request( s : String ) : ResultSet; - function close() : Void; - function escape( s : String ) : String; - function quote( s : String ) : String; - function addValue( s : StringBuf, v : Dynamic ) : Void; - function lastInsertId() : Int; - function dbName() : String; - function startTransaction() : Void; - function commit() : Void; - function rollback() : Void; - -} diff --git a/haxe/std/php/db/Manager.hx b/haxe/std/php/db/Manager.hx deleted file mode 100644 index 75304185dfe7377ad7bea53f3a553f9f54c39085..0000000000000000000000000000000000000000 --- a/haxe/std/php/db/Manager.hx +++ /dev/null @@ -1,502 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.db; - -import Reflect; -import php.db.Connection; - -/** - SPOD Manager : the persistent object database manager. See the tutorial on - haXe website to learn how to use SPOD. -**/ -class Manager { - - /* ----------------------------- STATICS ------------------------------ */ - public static var cnx(default,setConnection) : Connection; - private static var object_cache : Hash = new Hash(); - private static var cache_field = "__cache__"; - private static var FOR_UPDATE = ""; - - public static var managers = new Hash>(); - - private static dynamic function setConnection( c : Connection ) { - Reflect.setField(Manager,"cnx",c); - if( c != null ) - FOR_UPDATE = if( c.dbName() == "MySQL" ) " FOR UPDATE" else ""; - return c; - } - - /* ---------------------------- BASIC API ----------------------------- */ - var table_name : String; - var table_fields : List; - var table_keys : Array; - var cls : Dynamic; //Class; - - public function new( classval : Class ) { - cls = classval; - var clname = Type.getClassName(cls); - // get basic infos - table_name = quoteField((cls.TABLE_NAME != null ) ? cls.TABLE_NAME : clname.split('.').pop()); - table_keys = if( cls.TABLE_IDS != null ) cls.TABLE_IDS else ["id"]; - - // get the list of private fields - var apriv : Array = cls.PRIVATE_FIELDS; - apriv = if( apriv == null ) new Array() else apriv.copy(); - apriv.push("__cache__"); - apriv.push("__noupdate__"); - apriv.push("__manager__"); - apriv.push("update"); - - // get the proto fields not marked private (excluding methods) - table_fields = new List(); - var stub = Type.createEmptyInstance(cls); - - var instance_fields = Type.getInstanceFields(cls); - var scls = Type.getSuperClass(cls); - while(scls != null) { - for(remove in Type.getInstanceFields(scls)) - instance_fields.remove(remove); - scls = Type.getSuperClass(scls); - } - - for( f in instance_fields ) { - var isfield = !Reflect.isFunction(Reflect.field(stub,f)); - if( isfield ) - for( f2 in apriv ) { - if(f == f2 ) { - isfield = false; - break; - } - } - if( isfield ) { - table_fields.add(f); - } - } - - // set the manager and ready for further init - managers.set(clname, this); - - var rl : Array; - try { - rl = untyped cls.RELATIONS(); - } catch(e : Dynamic) { return; } - for(r in rl) { - // remove prop from precomputed table_fields - // always add key to table fields (even if not declared) - table_fields.remove(r.prop); - table_fields.remove("get_" + r.prop); - table_fields.remove("set_" + r.prop); - table_fields.remove(r.key); - table_fields.add(r.key); - } - } - - public function get( id : Int, ?lock : Bool ) : T { - if( lock == null ) - lock = true; - if( table_keys.length != 1 ) - throw "Invalid number of keys"; - if( id == null ) - return null; - var x : Dynamic = untyped object_cache.get(id + table_name); - if( x != null && (!lock || !x.__noupdate__) ) - return x; - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - s.add(quoteField(table_keys[0])); - s.add(" = "); - cnx.addValue(s,id); - if( lock ) - s.add(FOR_UPDATE); - return object(s.toString(),lock); - } - - public function getWithKeys( keys : {}, ?lock : Bool ) : T { - if( lock == null ) - lock = true; - var x : Dynamic = getFromCache(untyped keys,false); - if( x != null && (!lock || !x.__noupdate__) ) - return x; - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - addKeys(s,keys); - if( lock ) - s.add(FOR_UPDATE); - return object(s.toString(),lock); - } - - public function delete( x : {} ) { - var s = new StringBuf(); - s.add("DELETE FROM "); - s.add(table_name); - s.add(" WHERE "); - addCondition(s,x); - execute(s.toString()); - } - - public function search( x : {}, ?lock : Bool ) : List { - if( lock == null ) - lock = true; - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - addCondition(s,x); - if( lock ) - s.add(FOR_UPDATE); - return objects(s.toString(),lock); - } - - function addCondition(s : StringBuf,x) { - var first = true; - if( x != null ) - for( f in Reflect.fields(x) ) { - if( first ) - first = false; - else - s.add(" AND "); - s.add(quoteField(f)); - var d = Reflect.field(x,f); - if( d == null ) - s.add(" IS NULL"); - else { - s.add(" = "); - cnx.addValue(s,d); - } - } - if( first ) - s.add("1"); - } - - public function all( ?lock: Bool ) : List { - if( lock == null ) - lock = true; - return objects("SELECT * FROM " + table_name + if( lock ) FOR_UPDATE else "",lock); - } - - public function count( ?x : {} ) : Int { - var s = new StringBuf(); - s.add("SELECT COUNT(*) FROM "); - s.add(table_name); - s.add(" WHERE "); - addCondition(s,x); - return execute(s.toString()).getIntResult(0); - } - - public function quote( s : String ) : String { - return cnx.quote( s ); - } - - public function result( sql : String ) : Dynamic { - return cnx.request(sql).next(); - } - - public function results( sql : String ) : List { - return cast cnx.request(sql).results(); - } - - /* -------------------------- SPODOBJECT API -------------------------- */ - - function doInsert( x : T ) { - unmake(x); - var s = new StringBuf(); - var fields = new List(); - var values = new List(); - for( f in table_fields ) { - var v = Reflect.field(x,f); - if( v != null ) { - fields.add(quoteField(f)); - values.add(v); - } - } - s.add("INSERT INTO "); - s.add(table_name); - s.add(" ("); - s.add(fields.join(",")); - s.add(") VALUES ("); - var first = true; - for( v in values ) { - if( first ) - first = false; - else - s.add(", "); - cnx.addValue(s,v); - } - s.add(")"); - execute(s.toString()); - // table with one key not defined : suppose autoincrement - if( table_keys.length == 1 && Reflect.field(x,table_keys[0]) == null ) - Reflect.setField(x,table_keys[0],cnx.lastInsertId()); - addToCache(x); - } - - function doUpdate( x : T ) { - unmake(x); - var s = new StringBuf(); - s.add("UPDATE "); - s.add(table_name); - s.add(" SET "); - var cache = Reflect.field(x, cache_field); - if (null == cache) - { - cache = cacheObject(x, false); - Reflect.setField(x, cache_field, cache); - } - var mod = false; - for( f in table_fields ) { - var v = Reflect.field(x,f); - var vc = Reflect.field(cache,f); - if( v != vc ) { - if( mod ) - s.add(", "); - else - mod = true; - s.add(quoteField(f)); - s.add(" = "); - cnx.addValue(s,v); - Reflect.setField(cache,f,v); - } - } - if( !mod ) - return; - s.add(" WHERE "); - addKeys(s,x); - execute(s.toString()); - } - - function doDelete( x : T ) { - var s = new StringBuf(); - s.add("DELETE FROM "); - s.add(table_name); - s.add(" WHERE "); - addKeys(s,x); - execute(s.toString()); - } - - - function doSync( i : T ) { - object_cache.remove(makeCacheKey(i)); - var i2 = getWithKeys(i, untyped !i.__noupdate__); - // delete all fields - for( f in Reflect.fields(i) ) - Reflect.deleteField(i,f); - // copy fields from new object - for( f in Reflect.fields(i2) ) - Reflect.setField(i,f,Reflect.field(i2,f)); - // set same field-cache - Reflect.setField(i,cache_field,Reflect.field(i2,cache_field)); - addToCache(i); - } - - function objectToString( it : T ) : String { - var s = new StringBuf(); - s.add(table_name); - if( table_keys.length == 1 ) { - s.add("#"); - s.add(Reflect.field(it,table_keys[0])); - } else { - s.add("("); - var first = true; - for( f in table_keys ) { - if( first ) - first = false; - else - s.add(","); - s.add(quoteField(f)); - s.add(":"); - s.add(Reflect.field(it,f)); - } - s.add(")"); - } - return s.toString(); - } - - /* ---------------------------- INTERNAL API -------------------------- */ - - function cacheObject( x : T, lock : Bool ) { - var o : T = Type.createEmptyInstance(cls); - for(field in Reflect.fields(x)) { - Reflect.setField(o, field, Reflect.field(x, field)); - } - untyped o.__init_object(); - addToCache(o); - Reflect.setField(o, cache_field, Type.createEmptyInstance(cls)); - if( !lock ) - untyped o.__noupdate__ = true; - return o; - } - - function make( x : T ) { - } - - function unmake( x : T ) { - } - - function quoteField(f : String) { - var fsmall = f.toLowerCase(); - if( fsmall == "read" || fsmall == "desc" || fsmall == "out" || fsmall == "group" || fsmall == "version" || fsmall == "option" ) - return "`"+f+"`"; - return f; - } - - function addKeys( s : StringBuf, x : {} ) { - var first = true; - for( k in table_keys ) { - if( first ) - first = false; - else - s.add(" AND "); - s.add(quoteField(k)); - s.add(" = "); - var f = Reflect.field(x,k); - if( f == null ) - throw ("Missing key "+k); - cnx.addValue(s,f); - } - } - - function execute( sql : String ) { - return cnx.request(sql); - } - - function select( cond : String ) { - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - s.add(cond); - s.add(FOR_UPDATE); - return s.toString(); - } - - function selectReadOnly( cond : String ) { - var s = new StringBuf(); - s.add("SELECT * FROM "); - s.add(table_name); - s.add(" WHERE "); - s.add(cond); - return s.toString(); - } - - public function object( sql : String, lock : Bool ) : T { - var r = cnx.request(sql).next(); - if( r == null ) - return null; - var c = getFromCache(r,lock); - if( c != null ) - return c; - var o = cacheObject(r,lock); - make(o); - return o; - } - - public function objects( sql : String, lock : Bool ) : List { - var me = this; - var l = cnx.request(sql).results(); - var l2 = new List(); - for( x in l ) { - var c = getFromCache(x,lock); - if( c != null ) { - l2.add(c); - } else { - var o = cacheObject(x,lock); - make(o); - l2.add(o); - } - } - return l2; - } - - public function dbClass() : Class { - return cls; - } - - /* --------------------------- INIT / CLEANUP ------------------------- */ - - /** - * Left for compability with neko SPOD - */ - public static function initialize() { - - } - - public static function cleanup() { - object_cache = new Hash(); - } - - function initRelation(o : Dynamic, r : { prop : String, key : String, manager : Manager, lock : Bool } ) { - // setup getter/setter - var manager = r.manager; - var hkey = r.key; - var lock = r.lock; - if( lock == null ) lock = true; - if( manager == null || manager.table_keys == null ) throw ("Invalid manager for relation "+table_name+":"+r.prop); - if( manager.table_keys.length != 1 ) throw ("Relation "+r.prop+"("+r.key+") on a multiple key table"); - Reflect.setField(o,"get_"+r.prop,function() { - return manager.get(Reflect.field(o,hkey), lock); - }); - Reflect.setField(o,"set_"+r.prop,function(f) { - Reflect.setField(o, hkey, Reflect.field(f, manager.table_keys[0])); - return f; - }); - } - - /* ---------------------------- OBJECT CACHE -------------------------- */ - - function makeCacheKey( x : T ) : String { - if( table_keys.length == 1 ) { - var k = Reflect.field(x,table_keys[0]); - if( k == null ) - throw("Missing key "+table_keys[0]); - return Std.string(k)+table_name; - } - var s = new StringBuf(); - for( k in table_keys ) { - var v = Reflect.field(x,k); - if( k == null ) - throw("Missing key "+k); - s.add(v); - s.add("#"); - } - s.add(table_name); - return s.toString(); - } - - function addToCache( x : T ) { - object_cache.set(makeCacheKey(x),x); - } - - function getFromCache( x : T, lock : Bool ) : T { - var c : Dynamic = object_cache.get(makeCacheKey(x)); - // restore update method since now the object is locked - if( c != null && lock && c.__noupdate__) - c.__noupdate__ = false; - return c; - } -} diff --git a/haxe/std/php/db/Object.hx b/haxe/std/php/db/Object.hx deleted file mode 100644 index 1689d02904cf0ffc3baf694fcb0822ff786fb6a3..0000000000000000000000000000000000000000 --- a/haxe/std/php/db/Object.hx +++ /dev/null @@ -1,91 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.db; - -/** - SPOD Object : the persistent object base type. See the tutorial on haXe - website to learn how to use SPOD. -**/ -class Object #if spod_rtti implements haxe.rtti.Infos #end { - -/* - (optional) - static var TABLE_NAME = "TableName"; - static var TABLE_IDS = ["id"]; - static var PRIVATE_FIELDS = ["my_priv_field"]; - static function RELATIONS() { - return [{ key : "uid", prop : "user", manager : User.manager }]; - } - - static var manager = new php.db.Manager(); -*/ - - var __cache__ : Object; - var __noupdate__ : Bool; - var __manager__ : { - private function doUpdate( o : Object ) : Void; - private function doInsert( o : Object ) : Void; - private function doSync( o : Object ) : Void; - private function doDelete( o : Object ) : Void; - private function objectToString( o : Object ) : String; - }; - - public function new() { - __init_object(); - } - - private function __init_object() { - __noupdate__ = false; - __manager__ = Manager.managers.get(Type.getClassName(Type.getClass(this))); - var rl : Array; - try { - rl = untyped __manager__.cls.RELATIONS(); - } catch(e : Dynamic) { return; } - for(r in rl) - untyped __manager__.initRelation(this, r); - } - - public function insert() { - __manager__.doInsert(this); - } - - public function update() { - if( __noupdate__ ) throw "Cannot update not locked object"; - __manager__.doUpdate(this); - } - - public function sync() { - __manager__.doSync(this); - } - - public function delete() { - __manager__.doDelete(this); - } - - public function toString() { - return __manager__.objectToString(this); - } - -} diff --git a/haxe/std/php/db/ResultSet.hx b/haxe/std/php/db/ResultSet.hx deleted file mode 100644 index a6355936eefa83a92d4282236e8afdf6ae77825d..0000000000000000000000000000000000000000 --- a/haxe/std/php/db/ResultSet.hx +++ /dev/null @@ -1,40 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.db; - -interface ResultSet { - - var length(getLength,null) : Int; - var nfields(getNFields,null) : Int; - - - function hasNext() : Bool; - function next() : Dynamic; - function results() : List; - function getResult( n : Int ) : String; - function getIntResult( n : Int ) : Int; - function getFloatResult( n : Int ) : Float; - -} diff --git a/haxe/std/php/db/Transaction.hx b/haxe/std/php/db/Transaction.hx deleted file mode 100644 index e82fa51851cfdda432832c2b376cc3b13be55bca..0000000000000000000000000000000000000000 --- a/haxe/std/php/db/Transaction.hx +++ /dev/null @@ -1,69 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.db; - -class Transaction { - - public static function isDeadlock(e : Dynamic) { - return Std.is(e,String) && (~/Deadlock found/.match(e) || ~/Lock wait timeout/.match(e)); - } - - private static function runMainLoop(mainFun,logError,count) { - try { - mainFun(); - } catch( e : Dynamic ) { - if( count > 0 && isDeadlock(e) ) { - Manager.cleanup(); - Manager.cnx.rollback(); // should be already done, but in case... - Manager.cnx.startTransaction(); - runMainLoop(mainFun,logError,count-1); - return; - } - if( logError == null ) { - Manager.cnx.rollback(); - throw e; - } - logError(e); // should ROLLBACK if needed - } - } - - public static function main( cnx, mainFun : Void -> Void, logError : Dynamic -> Void ) { - Manager.initialize(); - Manager.cnx = cnx; - Manager.cnx.startTransaction(); - runMainLoop(mainFun,logError,3); - try { - Manager.cnx.commit(); - } catch( e : String ) { - // sqlite can have errors on commit - if( ~/Database is busy/.match(e) ) - logError(e); - } - Manager.cnx.close(); - Manager.cnx = null; - Manager.cleanup(); - } - -} diff --git a/haxe/std/php/io/File.hx b/haxe/std/php/io/File.hx deleted file mode 100644 index 979e194fb972f0d15bde77b7fe42a8bec47cb6a7..0000000000000000000000000000000000000000 --- a/haxe/std/php/io/File.hx +++ /dev/null @@ -1,87 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.io; - -enum FileHandle { -} - -enum FileSeek { - SeekBegin; - SeekCur; - SeekEnd; -} - -/** - API for reading and writing to files. -**/ -class File { - - public static function getContent( path : String ) : String { - return untyped __call__("file_get_contents", path); - } - - public static function getBytes( path : String ) { - return haxe.io.Bytes.ofString(getContent(path)); - } - - public static function putContent( path : String, content : String) : Int { - return untyped __call__("file_put_contents", path, content); - } - - public static function read( path : String, binary : Bool ) { - return new FileInput(untyped __call__('fopen', path, binary ? "rb" : "r")); - } - - public static function write( path : String, binary : Bool ) { - return new FileOutput(untyped __call__('fopen', path, binary ? "wb" : "w")); - } - - public static function append( path : String, binary : Bool ) { - return new FileOutput(untyped __call__('fopen', path, binary ? "ab" : "a")); - } - - public static function copy( src : String, dst : String ) { - return untyped __call__("copy", src, dst); - } - - public static function stdin() { - return new FileInput(untyped __call__('fopen', 'php://stdin', "r")); - } - - public static function stdout() { - return new FileOutput(untyped __call__('fopen', 'php://stdout', "w")); - } - - public static function stderr() { - return new FileOutput(untyped __call__('fopen', 'php://stderr', "w")); - } - - public static function getChar( echo : Bool ) : Int { - var v : Int = untyped __call__("fgetc", __php__("STDIN")); - if(echo) - untyped __call__('echo', v); - return v; - } -} diff --git a/haxe/std/php/io/FileInput.hx b/haxe/std/php/io/FileInput.hx deleted file mode 100644 index d482bcbf7f196d5e7aebf2bd345d0d3f49362923..0000000000000000000000000000000000000000 --- a/haxe/std/php/io/FileInput.hx +++ /dev/null @@ -1,84 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.io; -import haxe.io.Eof; -import php.io.File; - -/** - Use [php.io.File.read] to create a [FileInput] -**/ -class FileInput extends haxe.io.Input { - - private var __f : FileHandle; - - public function new(f) { - __f = f; - } - - public override function readByte() : Int { - if(untyped __call__('feof', __f)) return throw new haxe.io.Eof(); - var r = untyped __call__('fread', __f, 1); - if(untyped __physeq__(r, false)) return throw haxe.io.Error.Custom('An error occurred'); - return untyped __call__('ord', r); - } - - public override function readBytes( s : haxe.io.Bytes, p : Int, l : Int ) : Int { - if(untyped __call__('feof', __f)) return throw new haxe.io.Eof(); - var r : String = untyped __call__('fread', __f, l); - if(untyped __physeq__(r, false)) return throw haxe.io.Error.Custom('An error occurred'); - var b = haxe.io.Bytes.ofString(r); - s.blit(p, b, 0, r.length); - return r.length; - } - - public override function close() { - super.close(); - if(__f != null) untyped __call__('fclose', __f); - } - - public function seek( p : Int, pos : FileSeek ) { - var w; - switch( pos ) { - case SeekBegin: w = untyped __php__('SEEK_SET'); - case SeekCur : w = untyped __php__('SEEK_CUR'); - case SeekEnd : w = untyped __php__('SEEK_END'); - } - var r = untyped __call__('fseek', __f, p, w); - if(untyped __physeq__(r, false)) throw haxe.io.Error.Custom('An error occurred'); - } - - public function tell() : Int { - var r = untyped __call__('ftell', __f); - if(untyped __physeq__(r, false)) return throw haxe.io.Error.Custom('An error occurred'); - return cast r; - } - - override function readLine() : String { - var r : String = untyped __call__('fgets', __f); - if (untyped __physeq__(false, r)) - throw new Eof(); - return untyped __call__("rtrim", r, "\r\n"); - } -} diff --git a/haxe/std/php/io/FileOutput.hx b/haxe/std/php/io/FileOutput.hx deleted file mode 100644 index 99567c115f4f10e1707840153ed87e0abc746bdf..0000000000000000000000000000000000000000 --- a/haxe/std/php/io/FileOutput.hx +++ /dev/null @@ -1,82 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.io; -import php.io.File; - -/** - Use [php.io.File.write] to create a [FileOutput] -**/ -class FileOutput extends haxe.io.Output { - private var __f : FileHandle; - - public function new(f) { - __f = f; - } - - public override function writeByte( c : Int ) { - var r = untyped __call__('fwrite', __f, __call__('chr', c)); - if(untyped __physeq__(r, false)) return throw haxe.io.Error.Custom('An error occurred'); - return r; - } - - public override function writeBytes( b : haxe.io.Bytes, p : Int, l : Int ) : Int { - var s = b.readString(p, l); - if(untyped __call__('feof', __f)) return throw new haxe.io.Eof(); - var r = untyped __call__('fwrite', __f, s, l); - if(untyped __physeq__(r, false)) return throw haxe.io.Error.Custom('An error occurred'); - return r; - } - - public override function flush() { - var r = untyped __call__('fflush', __f); - if(untyped __physeq__(r, false)) throw haxe.io.Error.Custom('An error occurred'); - } - - public override function close() { - super.close(); - if(__f != null) untyped __call__('fclose', __f); - } - - public function seek( p : Int, pos : FileSeek ) { - var w; - switch( pos ) { - case SeekBegin: w = untyped __php__('SEEK_SET'); - case SeekCur : w = untyped __php__('SEEK_CUR'); - case SeekEnd : w = untyped __php__('SEEK_END'); - } - var r = untyped __call__('fseek', __f, p, w); - if(untyped __physeq__(r, false)) throw haxe.io.Error.Custom('An error occurred'); - } - - public function tell() : Int { - var r = untyped __call__('ftell', __f); - if(untyped __physeq__(r, false)) return throw haxe.io.Error.Custom('An error occurred'); - return cast r; - } - - public function eof() : Bool { - return untyped __call__('feof', __f); - } -} diff --git a/haxe/std/php/io/Path.hx b/haxe/std/php/io/Path.hx deleted file mode 100644 index 57ac4c44e0bbcd2b74683b0c3f03217b50c28af5..0000000000000000000000000000000000000000 --- a/haxe/std/php/io/Path.hx +++ /dev/null @@ -1,87 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.io; - -class Path { - - public var ext : String; - public var dir : String; - public var file : String; - public var backslash : Bool; - - public function new( path : String ) { - var c1 = path.lastIndexOf("/"); - var c2 = path.lastIndexOf("\\"); - if( c1 < c2 ) { - dir = path.substr(0,c2); - path = path.substr(c2+1); - backslash = true; - } else if( c2 < c1 ) { - dir = path.substr(0,c1); - path = path.substr(c1+1); - } else - dir = null; - var cp = path.lastIndexOf("."); - if( cp != -1 ) { - ext = path.substr(cp+1); - file = path.substr(0,cp); - } else { - ext = null; - file = path; - } - } - - public function toString() { - return (if( dir == null ) "" else dir + if( backslash ) "\\" else "/") + file + (if( ext == null ) "" else "." + ext); - } - - public static function withoutExtension( path : String ) { - var s = new Path(path); - s.ext = null; - return s.toString(); - } - - public static inline function withoutDirectory( path : String) : String { - return untyped __call__("basename", path); - } - - public static inline function directory( path : String) : String { - return untyped __call__("dirname", path); - } - - public static function extension( path ) { - var s = new Path(path); - if( s.ext == null ) - return ""; - return s.ext; - } - - public static function withExtension( path, ext ) { - var s = new Path(path); - s.ext = ext; - return s.toString(); - } - -} \ No newline at end of file diff --git a/haxe/std/php/net/Host.hx b/haxe/std/php/net/Host.hx deleted file mode 100644 index d8c48e719513a6e6c3120889f7070d8dd1964e00..0000000000000000000000000000000000000000 --- a/haxe/std/php/net/Host.hx +++ /dev/null @@ -1,59 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - * - */ -package php.net; - - -class Host { - - private var _ip : String; - public var ip(default,null) : haxe.Int32; - - public function new( name : String ) { - if(~/^(\d{1,3}\.){3}\d{1,3}$/.match(name)) { - _ip = name; - } else { - _ip = untyped __call__('gethostbyname', name); - if(_ip == name) { - ip = haxe.Int32.ofInt(0); - return; - } - } - var p = _ip.split('.'); - ip = haxe.Int32.ofInt(untyped __call__('intval', __call__('sprintf', '%02X%02X%02X%02X', p[3], p[2], p[1], p[0]), 16)); - } - - public function toString() : String { - return _ip; - } - - public function reverse() : String { - return untyped __call__('gethostbyaddress', _ip); - } - - public static function localhost() : String { - return untyped __var__('_SERVER', 'HTTP_HOST'); - } -} diff --git a/haxe/std/php/net/SocketInput.hx b/haxe/std/php/net/SocketInput.hx deleted file mode 100644 index 6428ae94adc5892bb624e8ada344b92c841dfca9..0000000000000000000000000000000000000000 --- a/haxe/std/php/net/SocketInput.hx +++ /dev/null @@ -1,27 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.net; - -typedef SocketInput = php.io.FileInput; \ No newline at end of file diff --git a/haxe/std/php/net/SocketOutput.hx b/haxe/std/php/net/SocketOutput.hx deleted file mode 100644 index 8784d9207d502f387697f4cafe5d057e0b2c1292..0000000000000000000000000000000000000000 --- a/haxe/std/php/net/SocketOutput.hx +++ /dev/null @@ -1,27 +0,0 @@ -/* - * Copyright (c) 2005, The haXe Project Contributors - * All rights reserved. - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR - * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - * DAMAGE. - */ -package php.net; - -typedef SocketOutput = php.io.FileOutput; \ No newline at end of file diff --git a/haxe/std/tools/haxedoc/haxedoc.hxp b/haxe/std/tools/haxedoc/haxedoc.hxp deleted file mode 100644 index c59ab58f7387601f69f316d356cb3eb557cd8032..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxedoc/haxedoc.hxp +++ /dev/null @@ -1,9 +0,0 @@ - - -cmd nekotools boot haxedoc.n - - - - - - - \ No newline at end of file diff --git a/haxe/std/tools/haxelib/.htaccess b/haxe/std/tools/haxelib/.htaccess deleted file mode 100644 index 0629eeea4076de196af5c9e1c6645b827436e9a1..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/.htaccess +++ /dev/null @@ -1,4 +0,0 @@ - - RewriteEngine On - RewriteRule (.*) /index.n - \ No newline at end of file diff --git a/haxe/std/tools/haxelib/Datas.hx b/haxe/std/tools/haxelib/Datas.hx deleted file mode 100644 index c262aef3b28492029a57a8e9704f0a626f39f6e4..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/Datas.hx +++ /dev/null @@ -1,150 +0,0 @@ -package tools.haxelib; - -import neko.zip.Reader; -import haxe.xml.Check; - -typedef UserInfos = { - var name : String; - var fullname : String; - var email : String; - var projects : Array; -} - -typedef VersionInfos = { - var date : String; - var name : String; - var comments : String; -} - -typedef ProjectInfos = { - var name : String; - var desc : String; - var website : String; - var owner : String; - var license : String; - var curversion : String; - var versions : Array; - var tags : List; -} - -typedef XmlInfos = { - var project : String; - var website : String; - var desc : String; - var license : String; - var version : String; - var versionComments : String; - var developers : List; - var tags : List; - var dependencies : List<{ project : String, version : String }>; -} - -class Datas { - - public static var XML = "haxelib.xml"; - public static var DOCXML = "haxedoc.xml"; - public static var REPOSITORY = "files"; - public static var alphanum = ~/^[A-Za-z0-9_.-]+$/; - static var LICENSES = ["GPL","LGPL","BSD","Public"]; - - static function requiredAttribute( x : Xml, name ) { - var v = x.get(name); - if( v == null ) - throw "Missing required attribute '"+name+"' in node "+x.nodeName; - return v; - } - - static function requiredNode( x : Xml, name ) { - var v = x.elementsNamed(name).next(); - if( v == null ) - throw "Missing required node '"+name+"' in node "+x.nodeName; - return v; - } - - static function requiredText( x : Xml ) { - var v = x.firstChild(); - if( v == null || (v.nodeType != Xml.PCData && v.nodeType != Xml.CData) ) - throw "Missing required text in node "+x.nodeName; - return v.nodeValue; - } - - public static function safe( name : String ) { - if( !alphanum.match(name) ) - throw "Invalid parameter : "+name; - return name.split(".").join(","); - } - - public static function unsafe( name : String ) { - return name.split(",").join("."); - } - - public static function fileName( lib : String, ver : String ) { - return safe(lib)+"-"+safe(ver)+".zip"; - } - - public static function readDoc( zip : List ) : String { - for( f in zip ) - if( StringTools.endsWith(f.fileName,DOCXML) ) - return neko.zip.Reader.unzip(f).toString(); - return null; - } - - public static function readInfos( zip : List, check : Bool ) : XmlInfos { - var xmldata = null; - for( f in zip ) - if( StringTools.endsWith(f.fileName,XML) ) { - xmldata = neko.zip.Reader.unzip(f).toString(); - break; - } - if( xmldata == null ) - throw XML+" not found in package"; - return readData(xmldata,check); - } - - static function doCheck( doc : Xml ) { - var sname = Att("name",FReg(alphanum)); - var schema = RNode( - "project", - [ sname, Att("url"), Att("license",FEnum(LICENSES)) ], - RList([ - RMulti( RNode("user",[sname]), true ), - RMulti( RNode("tag",[Att("v",FReg(alphanum))]) ), - RNode("description",[],RData()), - RNode("version",[sname],RData()), - RMulti( RNode("depends",[sname,Att("version",FReg(alphanum),"")]) ), - ]) - ); - haxe.xml.Check.checkDocument(doc,schema); - } - - public static function readData( xmldata : String, check : Bool ) : XmlInfos { - var doc = Xml.parse(xmldata); - if( check ) - doCheck(doc); - var p = new haxe.xml.Fast(doc).node.project; - var project = p.att.name; - if( project.length < 3 ) - throw "Project name must contain at least 3 characters"; - var tags = new List(); - for( t in p.nodes.tag ) - tags.add(t.att.v.toLowerCase()); - var devs = new List(); - for( d in p.nodes.user ) - devs.add(d.att.name); - var deps = new List(); - for( d in p.nodes.depends ) - deps.add({ project : d.att.name, version : if( d.has.version ) d.att.version else "" }); - return { - project : project, - website : p.att.url, - desc : p.node.description.innerData, - version : p.node.version.att.name, - versionComments : p.node.version.innerData, - license : p.att.license, - tags : tags, - developers : devs, - dependencies : deps, - } - } - -} diff --git a/haxe/std/tools/haxelib/Main.hx b/haxe/std/tools/haxelib/Main.hx deleted file mode 100644 index 3604e3b75d6bca7244abb145a26d929ecddfb57f..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/Main.hx +++ /dev/null @@ -1,780 +0,0 @@ -package tools.haxelib; - -enum Answer { - Yes; - No; - Always; -} - -class SiteProxy extends haxe.remoting.Proxy { -} - -class Progress extends haxe.io.Output { - - var o : haxe.io.Output; - var cur : Int; - var max : Int; - var start : Float; - - public function new(o) { - this.o = o; - cur = 0; - start = haxe.Timer.stamp(); - } - - function bytes(n) { - cur += n; - if( max == null ) - neko.Lib.print(cur+" bytes\r"); - else - neko.Lib.print(cur+"/"+max+" ("+Std.int((cur*100.0)/max)+"%)\r"); - } - - public override function writeByte(c) { - o.writeByte(c); - bytes(1); - } - - public override function writeBytes(s,p,l) { - var r = o.writeBytes(s,p,l); - bytes(r); - return r; - } - - public override function close() { - super.close(); - o.close(); - var time = haxe.Timer.stamp() - start; - var speed = (cur / time) / 1024; - time = Std.int(time * 10) / 10; - speed = Std.int(speed * 10) / 10; - neko.Lib.print("Download complete : "+cur+" bytes in "+time+"s ("+speed+"KB/s)\n"); - } - - public override function prepare(m) { - max = m; - } - -} - -class ProgressIn extends haxe.io.Input { - - var i : haxe.io.Input; - var pos : Int; - var tot : Int; - - public function new( i, tot ) { - this.i = i; - this.pos = 0; - this.tot = tot; - } - - public override function readByte() { - var c = i.readByte(); - doRead(1); - return c; - } - - public override function readBytes(buf,pos,len) { - var k = i.readBytes(buf,pos,len); - doRead(k); - return k; - } - - function doRead( nbytes : Int ) { - pos += nbytes; - neko.Lib.print( Std.int((pos * 100.0) / tot) + "%\r" ); - } - -} - -class Main { - - static var VERSION = 103; - static var REPNAME = "lib"; - static var SERVER = { - host : "lib.haxe.org", - port : 80, - dir : "", - url : "index.n" - }; - - var argcur : Int; - var args : Array; - var commands : List<{ name : String, doc : String, f : Void -> Void, net : Bool }>; - var siteUrl : String; - var site : SiteProxy; - - function new() { - args = neko.Sys.args(); - commands = new List(); - addCommand("install",install,"install a given project"); - addCommand("list",list,"list all installed projects",false); - addCommand("upgrade",upgrade,"upgrade all installed projects"); - addCommand("remove",remove,"remove a given project/version",false); - addCommand("set",set,"set the current version for a project",false); - addCommand("search",search,"list projects matching a word"); - addCommand("info",info,"list informations on a given project"); - addCommand("user",user,"list informations on a given user"); - addCommand("register",register,"register a new user"); - addCommand("submit",submit,"submit or update a project package"); - addCommand("setup",setup,"set the haxelib repository path",false); - addCommand("config",config,"print the repository path",false); - addCommand("path",path,"give paths to libraries",false); - addCommand("run",run,"run the specified project with parameters",false); - addCommand("test",test,"install the specified package localy",false); - addCommand("dev",dev,"set the development directory for a given project",false); - initSite(); - } - - function initSite() { - siteUrl = "http://"+SERVER.host+":"+SERVER.port+"/"+SERVER.dir; - site = new SiteProxy(haxe.remoting.HttpConnection.urlConnect(siteUrl+SERVER.url).api); - } - - function param( name, ?passwd ) { - if( args.length > argcur ) - return args[argcur++]; - neko.Lib.print(name+" : "); - if( passwd ) { - var s = new StringBuf(); - var c; - while( (c = neko.io.File.getChar(false)) != 13 ) - s.addChar(c); - print(""); - return s.toString(); - } - return neko.io.File.stdin().readLine(); - } - - function ask( question ) { - while( true ) { - neko.Lib.print(question+" [y/n/a] ? "); - switch( neko.io.File.stdin().readLine() ) { - case "n": return No; - case "y": return Yes; - case "a": return Always; - } - } - return null; - } - - function paramOpt() { - if( args.length > argcur ) - return args[argcur++]; - return null; - } - - function addCommand( name, f, doc, ?net = true ) { - commands.add({ name : name, doc : doc, f : f, net : net }); - } - - function usage() { - var vmin = Std.string(VERSION % 100); - var ver = Std.int(VERSION/100) + "." + if( vmin.length == 1 ) "0"+vmin else vmin; - print("Haxe Library Manager "+ver+" - (c)2006 Motion-Twin"); - print(" Usage : haxelib [command] [options]"); - print(" Commands :"); - for( c in commands ) - print(" "+c.name+" : "+c.doc); - neko.Sys.exit(1); - } - - function process() { - var debug = false; - argcur = 0; - while( true ) { - var a = args[argcur++]; - if( a == null ) - break; - switch( a ) { - case "-debug": - debug = true; - case "-R": - var path = args[argcur++]; - var r = ~/^(http:\/\/)?([^:\/]+)(:[0-9]+)?\/?(.*)$/; - if( !r.match(path) ) - throw "Invalid repository format '"+path+"'"; - SERVER.host = r.matched(2); - if( r.matched(3) != null ) - SERVER.port = Std.parseInt(r.matched(3).substr(1)); - SERVER.dir = r.matched(4); - initSite(); - default: - argcur--; - break; - } - } - var cmd = args[argcur++]; - if( cmd == null ) - usage(); - for( c in commands ) - if( c.name == cmd ) { - try { - if( c.net ) { - var p = neko.net.ProxyDetect.detect(); - if( p != null ) { - print("Using proxy "+p.host+":"+p.port); - haxe.Http.PROXY = p; - } - } - c.f(); - } catch( e : Dynamic ) { - if( e == "std@host_resolve" ) { - print("Host "+SERVER.host+" was not found"); - print("Please ensure that your internet connection is on"); - print("If you don't have an internet connection or if you are behing a proxy"); - print("please download manually the file from http://lib.haxe.org/files"); - print("and run 'haxelib test ' to install the Library."); - neko.Sys.exit(1); - } - if( debug ) - neko.Lib.rethrow(e); - print(Std.string(e)); - neko.Sys.exit(1); - } - return; - } - print("Unknown command "+cmd); - usage(); - } - - // ---- COMMANDS -------------------- - - function search() { - var word = param("Search word"); - var l = site.search(word); - for( s in l ) - print(s.name); - print(l.length+" projects found"); - } - - function info() { - var prj = param("Project name"); - var inf = site.infos(prj); - print("Name: "+inf.name); - print("Tags: "+inf.tags.join(", ")); - print("Desc: "+inf.desc); - print("Website: "+inf.website); - print("License: "+inf.license); - print("Owner: "+inf.owner); - print("Version: "+inf.curversion); - print("Releases: "); - if( inf.versions.length == 0 ) - print(" (no version released yet)"); - for( v in inf.versions ) - print(" "+v.date+" "+v.name+" : "+v.comments); - } - - function user() { - var uname = param("User name"); - var inf = site.user(uname); - print("Id: "+inf.name); - print("Name: "+inf.fullname); - print("Mail: "+inf.email); - print("Projects: "); - if( inf.projects.length == 0 ) - print(" (no projects)"); - for( p in inf.projects ) - print(" "+p); - } - - function register() { - doRegister(param("User")); - print("Registration successful"); - } - - function doRegister(name) { - var email = param("Email"); - var fullname = param("Fullname"); - var pass = param("Password",true); - var pass2 = param("Confirm",true); - if( pass != pass2 ) - throw "Password does not match"; - pass = haxe.Md5.encode(pass); - site.register(name,pass,email,fullname); - return pass; - } - - function submit() { - var file = param("Package"); - var data = neko.io.File.getBytes(file); - var zip = neko.zip.Reader.readZip(new haxe.io.BytesInput(data)); - var infos = Datas.readInfos(zip,true); - var user = infos.developers.first(); - var password; - if( site.isNewUser(user) ) { - print("This is your first submission as '"+user+"'"); - print("Please enter the following informations for registration"); - password = doRegister(user); - } else { - if( infos.developers.length > 1 ) - user = param("User"); - password = haxe.Md5.encode(param("Password",true)); - if( !site.checkPassword(user,password) ) - throw "Invalid password for "+user; - } - site.checkDeveloper(infos.project,user); - - // check dependencies validity - for( d in infos.dependencies ) { - var infos = site.infos(d.project); - if( d.version == "" ) - continue; - var found = false; - for( v in infos.versions ) - if( v.name == d.version ) { - found = true; - break; - } - if( !found ) - throw "Project "+d.project+" does not have version "+d.version; - } - - // check if this version already exists - var sinfos = try site.infos(infos.project) catch( _ : Dynamic ) null; - if( sinfos != null ) - for( v in sinfos.versions ) - if( v.name == infos.version && ask("You're about to overwrite existing version '"+v.name+"', please confirm") == No ) - throw "Aborted"; - - // query a submit id that will identify the file - var id = site.getSubmitId(); - - // directly send the file data over Http - var h = new haxe.Http("http://"+SERVER.host+":"+SERVER.port+"/"+SERVER.url); - h.onError = function(e) { throw e; }; - h.onData = print; - h.fileTransfert("file",id,new ProgressIn(new haxe.io.BytesInput(data),data.length),data.length); - print("Sending data.... "); - h.request(true); - - // processing might take some time, make sure we wait - print("Processing file.... "); - haxe.remoting.HttpConnection.TIMEOUT = 1000; - // ask the server to register the sent file - var msg = site.processSubmit(id,user,password); - print(msg); - } - - function install() { - var prj = param("Project name"); - var inf = site.infos(prj); - if( inf.curversion == null ) - throw "This project has not yet released a version"; - var reqversion = paramOpt(); - var version = if( reqversion != null ) reqversion else inf.curversion; - var found = false; - for( v in inf.versions ) - if( v.name == version ) { - found = true; - break; - } - if( !found ) - throw "No such version "+version; - doInstall(inf.name,version,version == inf.curversion); - } - - function doInstall( project, version, setcurrent ) { - var rep = getRepository(); - - // check if exists already - if( neko.FileSystem.exists(rep+Datas.safe(project)+"/"+Datas.safe(version)) ) { - print("You already have "+project+" version "+version+" installed"); - setCurrent(project,version,true); - return; - } - - // download to temporary file - var filename = Datas.fileName(project,version); - var filepath = rep+filename; - var out = neko.io.File.write(filepath,true); - var progress = new Progress(out); - var h = new haxe.Http(siteUrl+Datas.REPOSITORY+"/"+filename); - h.onError = function(e) { - progress.close(); - neko.FileSystem.deleteFile(filepath); - throw e; - }; - print("Downloading "+filename+"..."); - h.customRequest(false,progress); - - doInstallFile(filepath,setcurrent); - site.postInstall(project,version); - } - - function doInstallFile(filepath,setcurrent,?nodelete) { - - // read zip content - var f = neko.io.File.read(filepath,true); - var zip = neko.zip.Reader.readZip(f); - f.close(); - var infos = Datas.readInfos(zip,false); - - // create directories - var pdir = getRepository() + Datas.safe(infos.project); - safeDir(pdir); - pdir += "/"; - var target = pdir + Datas.safe(infos.version); - safeDir(target); - target += "/"; - - // locate haxelib.xml base path - var basepath = null; - for( f in zip ) { - if( StringTools.endsWith(f.fileName,Datas.XML) ) { - basepath = f.fileName.substr(0,f.fileName.length - Datas.XML.length); - break; - } - } - if( basepath == null ) - throw "No "+Datas.XML+" found"; - - // unzip content - for( zipfile in zip ) { - var n = zipfile.fileName; - if( StringTools.startsWith(n,basepath) ) { - // remove basepath - n = n.substr(basepath.length,n.length-basepath.length); - if( n.charAt(0) == "/" || n.charAt(0) == "\\" || n.split("..").length > 1 ) - throw "Invalid filename : "+n; - var dirs = ~/[\/\\]/g.split(n); - var path = ""; - var file = dirs.pop(); - for( d in dirs ) { - path += d; - safeDir(target+path); - path += "/"; - } - if( file == "" ) { - if( path != "" ) print(" Created "+path); - continue; // was just a directory - } - path += file; - print(" Install "+path); - var data = neko.zip.Reader.unzip(zipfile); - var f = neko.io.File.write(target+path,true); - f.write(data); - f.close(); - } - } - - // set current version - if( setcurrent || !neko.FileSystem.exists(pdir+".current") ) { - var f = neko.io.File.write(pdir+".current",true); - f.writeString(infos.version); - f.close(); - print(" Current version is now "+infos.version); - } - - // end - if( !nodelete ) - neko.FileSystem.deleteFile(filepath); - print("Done"); - - // process dependencies - for( d in infos.dependencies ) { - print("Installing dependency "+d.project+" "+d.version); - if( d.version == "" ) - d.version = site.infos(d.project).curversion; - doInstall(d.project,d.version,false); - } - } - - function safeDir( dir ) { - if( neko.FileSystem.exists(dir) ) { - if( !neko.FileSystem.isDirectory(dir) ) - throw ("A file is preventing "+dir+" to be created"); - return false; - } - try { - neko.FileSystem.createDirectory(dir); - } catch( e : Dynamic ) { - throw "You don't have enough user rights to create the directory "+dir; - } - return true; - } - - function getRepository( ?setup : Bool ) { - var sys = neko.Sys.systemName(); - if( sys == "Windows" ) { - var haxepath = neko.Sys.getEnv("HAXEPATH"); - if( haxepath == null ) - throw "HAXEPATH environment variable not defined, please run haxesetup.exe first"; - var last = haxepath.charAt(haxepath.length - 1); - if( last != "/" && last != "\\" ) - haxepath += "/"; - var rep = haxepath+REPNAME; - try { - safeDir(rep); - } catch( e : Dynamic ) { - throw "The directory defined by HAXEPATH does not exist, please run haxesetup.exe again"; - } - return rep+"\\"; - } - var config = neko.Sys.getEnv("HOME")+"/.haxelib"; - var rep = try - neko.io.File.getContent(config) - catch( e : Dynamic ) try - neko.io.File.getContent("/etc/.haxelib") - catch( e : Dynamic ) - if( setup ) - "/usr/lib/haxe/"+REPNAME; - else - throw "This is the first time you are runing haxelib. Please run haxelib setup first"; - if( setup ) { - print("Please enter haxelib repository path with write access"); - print("Hit enter for default ("+rep+")"); - var line = param("Path"); - if( line != "" ) - rep = line; - if( !neko.FileSystem.exists(rep) ) { - try { - neko.FileSystem.createDirectory(rep); - } catch( e : Dynamic ) { - print("Failed to create directory '"+rep+"' ("+Std.string(e)+"), maybe you need appropriate user rights"); - neko.Sys.exit(1); - } - } - var f = neko.io.File.write(config,true); - f.writeString(rep); - f.close(); - } else if( !neko.FileSystem.exists(rep) ) - throw "haxelib Repository "+rep+" does not exists. Please run haxelib setup again"; - return rep+"/"; - } - - function setup() { - var path = getRepository(true); - print("haxelib repository is now "+path); - } - - function config() { - print(getRepository()); - } - - function list() { - var rep = getRepository(); - for( p in neko.FileSystem.readDirectory(rep) ) { - if( p.charAt(0) == "." ) - continue; - var versions = new Array(); - var current = neko.io.File.getContent(rep+p+"/.current"); - var dev = try neko.io.File.getContent(rep+p+"/.dev") catch( e : Dynamic ) null; - for( v in neko.FileSystem.readDirectory(rep+p) ) { - if( v.charAt(0) == "." ) - continue; - v = Datas.unsafe(v); - if( dev == null && v == current ) - v = "["+v+"]"; - versions.push(v); - } - if( dev != null ) - versions.push("[dev:"+dev+"]"); - print(Datas.unsafe(p) + ": "+versions.join(" ")); - } - } - - function upgrade() { - var rep = getRepository(); - var prompt = true; - var update = false; - for( p in neko.FileSystem.readDirectory(rep) ) { - if( p.charAt(0) == "." || !neko.FileSystem.isDirectory(rep+"/"+p) ) - continue; - var p = Datas.unsafe(p); - print("Checking "+p); - var inf = try site.infos(p) catch( e : Dynamic ) { neko.Lib.println(e); continue; }; - if( !neko.FileSystem.exists(rep+Datas.safe(p)+"/"+Datas.safe(inf.curversion)) ) { - if( prompt ) - switch ask("Upgrade "+p+" to "+inf.curversion) { - case Yes: - case Always: prompt = false; - case No: continue; - } - doInstall(p,inf.curversion,true); - update = true; - } else - setCurrent(p,inf.curversion,true); - } - if( update ) - print("Done"); - else - print("All projects are up-to-date"); - } - - function deleteRec(dir) { - for( p in neko.FileSystem.readDirectory(dir) ) { - var path = dir+"/"+p; - if( neko.FileSystem.isDirectory(path) ) - deleteRec(path); - else - neko.FileSystem.deleteFile(path); - } - neko.FileSystem.deleteDirectory(dir); - } - - function remove() { - var prj = param("Project"); - var version = paramOpt(); - var rep = getRepository(); - var pdir = rep + Datas.safe(prj); - - if( version == null ) { - if( !neko.FileSystem.exists(pdir) ) - throw "Project "+prj+" is not installed"; - deleteRec(pdir); - print("Project "+prj+" removed"); - return; - } - - var vdir = pdir + "/" + Datas.safe(version); - if( !neko.FileSystem.exists(vdir) ) - throw "Project "+prj+" does not have version "+version+" installed"; - - var cur = neko.io.File.getContent(pdir+"/.current"); - if( cur == version ) - throw "Can't remove current version of project "+prj; - deleteRec(vdir); - print("Project "+prj+" version "+version+" removed"); - } - - function set() { - var prj = param("Project"); - var version = param("Version"); - setCurrent(prj,version,false); - } - - function setCurrent( prj : String, version : String, doAsk : Bool ) { - var pdir = getRepository() + Datas.safe(prj); - var vdir = pdir + "/" + Datas.safe(version); - if( !neko.FileSystem.exists(vdir) ) - throw "Project "+prj+" version "+version+" is not installed"; - var current = pdir+"/.current"; - if( neko.io.File.getContent(current) == version ) - return; - if( doAsk && ask("Set "+prj+" to version "+version) == No ) - return; - var f = neko.io.File.write(current,true); - f.writeString(version); - f.close(); - print("Project "+prj+" current version is now "+version); - } - - function checkRec( prj : String, version : String, l : List<{ project : String, version : String }> ) { - var pdir = getRepository() + Datas.safe(prj); - if( !neko.FileSystem.exists(pdir) ) - throw "Project "+prj+" is not installed"; - var version = if( version != null ) version else neko.io.File.getContent(pdir+"/.current"); - var vdir = pdir + "/" + Datas.safe(version); - if( !neko.FileSystem.exists(vdir) ) - throw "Project "+prj+" version "+version+" is not installed"; - for( p in l ) - if( p.project == prj ) { - if( p.version == version ) - return; - throw "Project "+prj+" has two version included "+version+" and "+p.version; - } - l.add({ project : prj, version : version }); - var xml = neko.io.File.getContent(vdir+"/haxelib.xml"); - var inf = Datas.readData(xml,false); - for( d in inf.dependencies ) - checkRec(d.project,if( d.version == "" ) null else d.version,l); - } - - function path() { - var list = new List(); - while( argcur < args.length ) { - var a = args[argcur++].split(":"); - checkRec(a[0],a[1],list); - } - var rep = getRepository(); - for( d in list ) { - var pdir = Datas.safe(d.project)+"/"+Datas.safe(d.version)+"/"; - var dir = rep + pdir; - try { - dir = neko.io.File.getContent(rep+Datas.safe(d.project)+"/.dev"); - if( dir.length == 0 || (dir.charAt(dir.length-1) != '/' && dir.charAt(dir.length-1) != '\\') ) - dir += "/"; - pdir = dir; - } catch( e : Dynamic ) { - } - var ndir = dir + "ndll"; - if( neko.FileSystem.exists(ndir) ) { - var sysdir = ndir+"/"+neko.Sys.systemName(); - if( !neko.FileSystem.exists(sysdir) ) - throw "Project "+d.project+" version "+d.version+" does not have a neko dll for your system"; - neko.Lib.println("-L "+pdir+"ndll/"); - } - neko.Lib.println(dir); - neko.Lib.println("-D "+d.project); - } - } - - function dev() { - var rep = getRepository(); - var project = param("Project"); - var dir = paramOpt(); - var proj = rep + Datas.safe(project); - if( !neko.FileSystem.exists(proj) ) { - neko.FileSystem.createDirectory(proj); - var f = neko.io.File.write(proj + "/.current", false); - f.writeString("dev"); - f.close(); - } - var devfile = proj+"/.dev"; - if( dir == null ) { - if( neko.FileSystem.exists(devfile) ) - neko.FileSystem.deleteFile(devfile); - print("Development directory disabled"); - } else { - var f = neko.io.File.write(devfile,false); - f.writeString(dir); - f.close(); - print("Development directory set to "+dir); - } - } - - function run() { - var rep = getRepository(); - var project = param("Project"); - var pdir = rep + Datas.safe(project); - if( !neko.FileSystem.exists(pdir) ) - throw "Project "+project+" is not installed"; - pdir += "/"; - var version = neko.io.File.getContent(pdir+".current"); - var dev = try neko.io.File.getContent(pdir+".dev") catch( e : Dynamic ) null; - var vdir = dev!=null ? dev : pdir + Datas.safe(version); - var rdir = vdir + "/run.n"; - if( !neko.FileSystem.exists(rdir) ) - throw "Project "+project+" version "+version+" does not have a run script"; - args.push(neko.Sys.getCwd()); - neko.Sys.setCwd(vdir); - var cmd = "neko run.n"; - for( i in argcur...args.length ) - cmd += " "+escapeArg(args[i]); - neko.Sys.exit(neko.Sys.command(cmd)); - } - - function escapeArg( a : String ) { - if( a.indexOf(" ") == -1 ) - return a; - return '"'+a+'"'; - } - - function test() { - var file = param("Package"); - doInstallFile(file,true,true); - } - - // ---------------------------------- - - static function print(str) { - neko.Lib.print(str+"\n"); - } - - static function main() { - new Main().process(); - } - -} diff --git a/haxe/std/tools/haxelib/Site.hx b/haxe/std/tools/haxelib/Site.hx deleted file mode 100644 index 452437982df7488a9d50836035a7a38989cbde71..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/Site.hx +++ /dev/null @@ -1,236 +0,0 @@ -package tools.haxelib; -import tools.haxelib.SiteDb; -import haxe.rtti.CType; - -class Site { - - static var db : neko.db.Connection; - - static var CWD = neko.Web.getCwd(); - static var DB_FILE = CWD+"haxelib.db"; - public static var TMP_DIR = CWD+"tmp"; - public static var REP_DIR = CWD+Datas.REPOSITORY; - - static function setup() { - SiteDb.create(db); - } - - static function initDatabase() { - db = neko.db.Sqlite.open(DB_FILE); - neko.db.Manager.cnx = db; - neko.db.Manager.initialize(); - } - - static function run() { - if( !neko.FileSystem.exists(TMP_DIR) ) - neko.FileSystem.createDirectory(TMP_DIR); - if( !neko.FileSystem.exists(REP_DIR) ) - neko.FileSystem.createDirectory(REP_DIR); - - var ctx = new haxe.remoting.Context(); - ctx.addObject("api",new SiteApi(db)); - if( haxe.remoting.HttpConnection.handleRequest(ctx) ) - return; - if( neko.Sys.args()[0] == "setup" ) { - setup(); - neko.Lib.print("Setup done\n"); - return; - } - var file = null; - var sid = null; - var bytes = 0; - neko.Web.parseMultipart(function(p,filename) { - if( p == "file" ) { - sid = Std.parseInt(filename); - file = neko.io.File.write(TMP_DIR+"/"+sid+".tmp",true); - } else - throw p+" not accepted"; - },function(data,pos,len) { - bytes += len; - file.writeFullBytes(data,pos,len); - }); - if( file != null ) { - file.close(); - neko.Lib.print("File #"+sid+" accepted : "+bytes+" bytes written"); - return; - } - display(); - } - - static function display() { - var data = neko.io.File.getContent(CWD + "website.mtt"); - var page = new haxe.Template(data); - var ctx : Dynamic = {}; - var macros = { - download : function( res, p, v ) { - return "/"+Datas.REPOSITORY+"/"+Datas.fileName(res(p).name,res(v).name); - } - }; - if( fillContent(ctx) ) - neko.Lib.print( page.execute(ctx,macros) ); - } - - static function fillContent( ctx : Dynamic ) { - var uri = neko.Web.getURI().split("/"); - var error = function(msg) { ctx.error = StringTools.htmlEscape(msg); return true; } - if( uri[0] == "" ) - uri.shift(); - var act = uri.shift(); - if( act == null || act == "" || act == "index.n" ) - act = "index"; - ctx.menuTags = Tag.manager.topTags(10); - switch( act ) { - case "p": - var name = uri.shift(); - var p = Project.manager.search({ name : name }).first(); - if( p == null ) - return error("Unknown project '"+name+"'"); - ctx.p = p; - ctx.owner = p.owner; - ctx.version = p.version; - ctx.versions = Version.manager.byProject(p); - var tags = Tag.manager.search({ project : p.id }); - if( !tags.isEmpty() ) ctx.tags = tags; - case "u": - var name = uri.shift(); - var u = User.manager.search({ name : name }).first(); - if( u == null ) - return error("Unknown user '"+name+"'"); - ctx.u = u; - ctx.uprojects = Developer.manager.search({ user : u.id }).map(function(d:Developer) { return d.project; }); - case "t": - var tag = uri.shift(); - ctx.tag = StringTools.htmlEscape(tag); - ctx.tprojects = Tag.manager.search({ tag : tag }).map(function(t) return t.project); - case "d": - var name = uri.shift(); - var p = Project.manager.search({ name : name }).first(); - if( p == null ) - return error("Unknown project '"+name+"'"); - var version = uri.shift(); - var v; - if( version == null ) { - v = p.version; - version = v.name; - } else { - v = Version.manager.search({ project : p.id, name : version }).first(); - if( v == null ) return error("Unknown version '"+version+"'"); - } - if( v.documentation == null ) - return error("Project "+p.name+" version "+version+" has no documentation"); - var root : TypeRoot = haxe.Unserializer.run(v.documentation); - var buf = new StringBuf(); - var html = new tools.haxedoc.HtmlPrinter("/d/"+p.name+"/"+version+"/","",""); - html.output = function(str) buf.add(str); - var path = uri.join(".").toLowerCase().split("."); - if( path.length == 1 && path[0] == "" ) - path = []; - if( path.length == 0 ) { - ctx.index = true; - html.process(TPackage("root","root",root)); - } else { - var cl = html.find(root,path,0); - if( cl == null ) { - // we most likely clicked on a class which is part of the haxe core documentation - neko.Web.redirect("http://haxe.org/api/"+path.join("/")); - return false; - } - html.process(cl); - } - ctx.p = p; - ctx.v = v; - ctx.content = buf.toString(); - case "index": - var vl = Version.manager.latest(10); - for( v in vl ) { - var p = v.project; // fetch - } - ctx.versions = vl; - case "all": - ctx.projects = Project.manager.allByName(); - case "search": - var v = neko.Web.getParams().get("v"); - var p = Project.manager.search({ name : v }).first(); - if( p != null ) { - neko.Web.redirect("/p/"+p.name); - return false; - } - if( Tag.manager.count({ tag : v }) > 0 ) { - neko.Web.redirect("/t/"+v); - return false; - } - ctx.projects = Project.manager.containing(v).map(function(p) return Project.manager.get(p.id)); - ctx.act_all = true; - ctx.search = StringTools.htmlEscape(v); - case "rss": - neko.Web.setHeader("Content-Type", "text/xml; charset=UTF-8"); - neko.Lib.println(''); - neko.Lib.print(buildRss().toString()); - return false; - default: - ctx.error = "Unknown action : "+act; - return true; - } - Reflect.setField(ctx,"act_"+act,true); - return true; - } - - static function buildRss() : Xml { - var createChild = function(root:Xml, name:String){ - var c = Xml.createElement(name); - root.addChild(c); - return c; - } - var createChildWithContent = function(root:Xml, name:String, content:String){ - var e = Xml.createElement(name); - var c = Xml.createPCData(if (content != null) content else ""); - e.addChild(c); - root.addChild(e); - return e; - } - var createChildWithCdata = function(root:Xml, name:String, content:String){ - var e = Xml.createElement(name); - var c = Xml.createCData(if (content != null) content else ""); - e.addChild(c); - root.addChild(e); - return e; - } - neko.Sys.setTimeLocale("en_US.UTF8"); - var url = "http://"+neko.Web.getClientHeader("Host"); - var rss = Xml.createElement("rss"); - rss.set("version","2.0"); - var channel = createChild(rss, "channel"); - createChildWithContent(channel, "title", "haxe-libs"); - createChildWithContent(channel, "link", url); - createChildWithContent(channel, "description", "lib.haxe.org RSS"); - createChildWithContent(channel, "generator", "haxe"); - createChildWithContent(channel, "language", "en"); - for (v in Version.manager.latest(10)){ - var project = v.project; - var item = createChild(channel, "item"); - createChildWithContent(item, "title", StringTools.htmlEscape(project.name+" "+v.name)); - createChildWithContent(item, "link", url+"/p/"+project.name); - createChildWithContent(item, "guid", url+"/p/"+project.name+"?v="+v.id); - var date = DateTools.format(Date.fromString(v.date), "%a, %e %b %Y %H:%M:%S %z"); - createChildWithContent(item, "pubDate", date); - createChildWithContent(item, "author", project.owner.name); - createChildWithContent(item, "description", StringTools.htmlEscape(v.comments)); - } - return rss; - } - - static function main() { - var error = null; - initDatabase(); - try { - run(); - } catch( e : Dynamic ) { - error = { e : e }; - } - db.close(); - neko.db.Manager.cleanup(); - if( error != null ) - neko.Lib.rethrow(error.e); - } - -} diff --git a/haxe/std/tools/haxelib/SiteApi.hx b/haxe/std/tools/haxelib/SiteApi.hx deleted file mode 100644 index 983caf1c65892c7ef860bac9b305b8d22bc0dfd7..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/SiteApi.hx +++ /dev/null @@ -1,255 +0,0 @@ -package tools.haxelib; -import tools.haxelib.Datas; -import tools.haxelib.SiteDb; - -class SiteApi { - - var db : neko.db.Connection; - - public function new( db ) { - this.db = db; - } - - public function search( word : String ) : List<{ id : Int, name : String }> { - return Project.manager.containing(word); - } - - public function infos( project : String ) : ProjectInfos { - var p = Project.manager.search({ name : project }).first(); - if( p == null ) - throw "No such Project : "+project; - var vl = Version.manager.search({ project : p.id }); - var versions = new Array(); - for( v in vl ) - versions.push({ name : v.name, comments : v.comments, date : v.date }); - return { - name : p.name, - curversion : if( p.version == null ) null else p.version.name, - desc : p.description, - versions : versions, - owner : p.owner.name, - website : p.website, - license : p.license, - tags : Tag.manager.search({ project : p.id }).map(function(t) return t.tag), - }; - } - - public function user( name : String ) : UserInfos { - var u = User.manager.search({ name : name }).first(); - if( u == null ) - throw "No such user : "+name; - var pl = Project.manager.search({ owner : u.id }); - var projects = new Array(); - for( p in pl ) - projects.push(p.name); - return { - name : u.name, - fullname : u.fullname, - email : u.email, - projects : projects, - }; - } - - public function register( name : String, pass : String, mail : String, fullname : String ) : Bool { - if( !Datas.alphanum.match(name) ) - throw "Invalid user name, please use alphanumeric characters"; - if( name.length < 3 ) - throw "User name must be at least 3 characters"; - var u = new User(); - u.name = name; - u.pass = pass; - u.email = mail; - u.fullname = fullname; - u.insert(); - return null; - } - - public function isNewUser( name : String ) : Bool { - return User.manager.search({ name : name }).first() == null; - } - - public function checkDeveloper( prj : String, user : String ) : Void { - var p = Project.manager.search({ name : prj }).first(); - if( p == null ) - return; - for( d in Developer.manager.search({ project : p.id }) ) - if( d.user.name == user ) - return; - throw "User '"+user+"' is not a developer of project '"+prj+"'"; - } - - public function checkPassword( user : String, pass : String ) : Bool { - var u = User.manager.search({ name : user }).first(); - return u != null && u.pass == pass; - } - - public function getSubmitId() : String { - return Std.string(Std.random(100000000)); - } - - public function processSubmit( id : String, user : String, pass : String ) : String { - var path = Site.TMP_DIR+"/"+Std.parseInt(id)+".tmp"; - - var file = try neko.io.File.read(path,true) catch( e : Dynamic ) throw "Invalid file id #"+id; - var zip = try neko.zip.Reader.readZip(file) catch( e : Dynamic ) { file.close(); neko.Lib.rethrow(e); }; - file.close(); - - var infos = Datas.readInfos(zip,true); - var u = User.manager.search({ name : user }).first(); - if( u == null || u.pass != pass ) - throw "Invalid username or password"; - - var devs = infos.developers.map(function(user) { - var u = User.manager.search({ name : user }).first(); - if( u == null ) - throw "Unknown user '"+user+"'"; - return u; - }); - - var tags = Lambda.array(infos.tags); - tags.sort(Reflect.compare); - - var p = Project.manager.search({ name : infos.project }).first(); - - // create project if needed - if( p == null ) { - p = new Project(); - p.name = infos.project; - p.description = infos.desc; - p.website = infos.website; - p.license = infos.license; - p.owner = u; - p.insert(); - for( u in devs ) { - var d = new Developer(); - d.user = u; - d.project = p; - d.insert(); - } - for( tag in tags ) { - var t = new Tag(); - t.tag = tag; - t.project = p; - t.insert(); - } - } - - // check submit rights - var pdevs = Developer.manager.search({ project : p.id }); - var isdev = false; - for( d in pdevs ) - if( d.user.id == u.id ) { - isdev = true; - break; - } - if( !isdev ) - throw "You are not a developer of this project"; - - var otags = Tag.manager.search({ project : p.id }); - var curtags = otags.map(function(t) return t.tag).join(":"); - - // update public infos - if( infos.desc != p.description || p.website != infos.website || pdevs.length != devs.length || tags.join(":") != curtags ) { - if( u.id != p.owner.id ) - throw "Only project owner can modify project infos"; - p.description = infos.desc; - p.website = infos.website; - p.update(); - if( pdevs.length != devs.length ) { - for( d in pdevs ) - d.delete(); - for( u in devs ) { - var d = new Developer(); - d.user = u; - d.project = p; - d.insert(); - } - } - if( tags.join(":") != curtags ) { - for( t in otags ) - t.delete(); - for( tag in tags ) { - var t = new Tag(); - t.tag = tag; - t.project = p; - t.insert(); - } - } - } - - // look for current version - var current = null; - for( v in Version.manager.search({ project : p.id }) ) - if( v.name == infos.version ) { - current = v; - break; - } - - // update documentation - var doc = null; - var docXML = Datas.readDoc(zip); - if( docXML != null ) { - var p = new haxe.rtti.XmlParser(); - p.process(Xml.parse(docXML).firstElement(),null); - p.sort(); - var roots = new Array(); - for( x in p.root ) - switch( x ) { - case TPackage(name,_,_): - switch( name ) { - case "flash","flash9","haxe","js","neko","cpp","php","tools": // don't include haXe core types - default: roots.push(x); - } - default: - // don't include haXe root types - } - var s = new haxe.Serializer(); - s.useEnumIndex = true; - s.useCache = true; - s.serialize(roots); - doc = s.toString(); - } - - // update file - var target = Site.REP_DIR+"/"+Datas.fileName(p.name,infos.version); - if( current != null ) neko.FileSystem.deleteFile(target); - neko.FileSystem.rename(path,target); - - // update existing version - if( current != null ) { - current.documentation = doc; - current.comments = infos.versionComments; - current.update(); - return "Version "+current.name+" (id#"+current.id+") updated"; - } - - // add new version - var v = new Version(); - v.project = p; - v.name = infos.version; - v.comments = infos.versionComments; - v.downloads = 0; - v.date = Date.now().toString(); - v.documentation = doc; - v.insert(); - - p.version = v; - p.update(); - return "Version "+v.name+" (id#"+v.id+") added"; - } - - public function postInstall( project : String, version : String ) { - var p = Project.manager.search({ name : project }).first(); - if( p == null ) - throw "No such Project : "+project; - var v = Version.manager.search({ project : p.id, name : version }).first(); - if( v == null ) - throw "No such Version : "+version; - v.downloads++; - v.update(); - p.downloads++; - p.update(); - } - -} - diff --git a/haxe/std/tools/haxelib/SiteDb.hx b/haxe/std/tools/haxelib/SiteDb.hx deleted file mode 100644 index 9834ed2eb18a424a0226e66211d65bef1474fc8b..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/SiteDb.hx +++ /dev/null @@ -1,177 +0,0 @@ -package tools.haxelib; - -class User extends neko.db.Object { - - public static var manager = new neko.db.Manager(User); - - public var id : Int; - public var name : String; - public var fullname : String; - public var email : String; - public var pass : String; - -} - -class Project extends neko.db.Object { - - static function RELATIONS() { - return [ - { key : "owner", prop : "owner", manager : User.manager }, - { key : "version", prop : "version", manager : Version.manager }, - ]; - } - - public static var manager = new ProjectManager(Project); - - public var id : Int; - public var name : String; - public var description : String; - public var website : String; - public var license : String; - public var downloads : Int; - public var owner(dynamic,dynamic) : User; - public var version(dynamic,dynamic) : Version; - -} - -class Tag extends neko.db.Object { - - static function RELATIONS() { - return [ - { key : "project", prop : "project", manager : Project.manager }, - ]; - } - - public static var manager = new TagManager(Tag); - - public var id : Int; - public var tag : String; - public var project(dynamic,dynamic) : Project; - -} - -class Version extends neko.db.Object { - - static function RELATIONS() { - return [{ key : "project", prop : "project", manager : Project.manager }]; - } - - public static var manager = new VersionManager(Version); - - public var id : Int; - public var project(dynamic,dynamic) : Project; - public var name : String; - public var date : String; // sqlite does not have a proper 'date' type - public var comments : String; - public var downloads : Int; - public var documentation : Null; - -} - -class Developer extends neko.db.Object { - - static var TABLE_IDS = ["user","project"]; - static function RELATIONS() { - return [ - { key : "user", prop : "user", manager : User.manager }, - { key : "project", prop : "project", manager : Project.manager }, - ]; - } - - public static var manager = new neko.db.Manager(Developer); - - public var user(dynamic,dynamic) : User; - public var project(dynamic,dynamic) : Project; - -} - -class ProjectManager extends neko.db.Manager { - - public function containing( word ) : List<{ id : Int, name : String }> { - word = quote("%"+word+"%"); - return results("SELECT id, name FROM Project WHERE name LIKE "+word+" OR description LIKE "+word); - } - - public function allByName() { - return objects("SELECT * FROM Project ORDER BY name COLLATE NOCASE",false); - } - -} - -class VersionManager extends neko.db.Manager { - - public function latest( n : Int ) { - return objects("SELECT * FROM Version ORDER BY date DESC LIMIT "+n,false); - } - - public function byProject( p : Project ) { - return objects("SELECT * FROM Version WHERE project = "+p.id+" ORDER BY date DESC",false); - } - -} - -class TagManager extends neko.db.Manager { - - public function topTags( n : Int ) { - return results("SELECT tag, COUNT(*) as count FROM Tag GROUP BY tag ORDER BY count DESC LIMIT "+n); - } - -} - -class SiteDb { - - public static function create( db : neko.db.Connection ) { - db.request("DROP TABLE IF EXISTS User"); - db.request(" - CREATE TABLE User ( - id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, - name VARCHAR(16) NOT NULL UNIQUE, - fullname VARCHAR(50) NOT NULL, - pass VARCHAR(32) NOT NULL, - email VARCHAR(50) NOT NULL - ) - "); - db.request("DROP TABLE IF EXISTS Project"); - db.request(" - CREATE TABLE Project ( - id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, - owner INTEGER NOT NULL, - name VARCHAR(32) NOT NULL UNIQUE, - license VARCHAR(20) NOT NULL, - description TEXT NOT NULL, - website VARCHAR(100) NOT NULL, - version INT, - downloads INT NOT NULL - ) - "); - db.request("DROP TABLE IF EXISTS Version"); - db.request(" - CREATE TABLE Version ( - id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, - project INTEGER NOT NULL, - downloads INTEGER NOT NULL, - date VARCHAR(19) NOT NULL, - name VARCHAR(32) NOT NULL, - comments TEXT NOT NULL, - documentation TEXT NULL - ) - "); - db.request("DROP TABLE IF EXISTS Developer"); - db.request(" - CREATE TABLE Developer ( - user INTEGER NOT NULL, - project INTEGER NOT NULL - ) - "); - db.request("DROP TABLE IF EXISTS Tag"); - db.request(" - CREATE TABLE Tag ( - id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, - tag VARCHAR(32) NOT NULL, - project INTEGER NOT NULL - ) - "); - db.request("DROP INDEX IF EXISTS TagSearch"); - db.request("CREATE INDEX TagSearch ON Tag(tag)"); - } -} diff --git a/haxe/std/tools/haxelib/haxelib.css b/haxe/std/tools/haxelib/haxelib.css deleted file mode 100644 index 6a708cdb8d8cdba2e0c90e96b3d85074967e77ef..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/haxelib.css +++ /dev/null @@ -1,212 +0,0 @@ - -/* structure */ - -body { - margin : 0; - padding : 0; - text-align: center; - font-family : "trebuchet ms",sans-serif; - font-size : 10.5pt; - background : #FFFFFF url("http://haxe.org/img/haxe/bg_main.gif") repeat-x; -} - -.page { - margin: 10px auto 10px auto; - padding : 5px; - width : 750px; - background-color : #FFFFFF; - border : 1px solid #AAA; - -moz-border-radius : 10px; -} - -.menu { - text-align : left; - float : left; - width : 150px; -} - -.content { - text-align : left; - float : left; - width : 600px; -} - -.clear { - clear : both; -} - -/* style */ - -a, a:visited { - color : #C35700; - text-decoration : none; -} - -a:hover { - text-decoration : underline; -} - -h1 { - text-align : center; - margin-top : 20px; -} - -h1 a, h1 a:hover, h1 a:visited { - color : #C35700; - text-decoration : none; -} - -.content p { - text-align : justify; - margin : 0px; - padding : 0px 10px 0px 10px; -} - -.menu ul { - list-style : none; - margin : 5px; - padding : 0px; -} - -.versions .date, .versions .project, .versions .name { - display : inline; -} - -.versions ul, .projects ul { - list-style : circle; - margin : 25px; - padding : 0px; -} - -.date { - color : #555; - font-size : 12px; -} - -.versions .name { - font-weight : bold; -} - -.versions .download { - float : right; - margin-top : -22px; - margin-right : 30px; -} - -.download { - padding : 2px 4px 2px 4px; - background-color : #eee; - display : inline; -} - -.download a { - color : #555; - font-size : 12px; - text-decoration : none; -} - -.download a:visited { - color : #555; -} - -.versions .comments { - margin-right : 40px; - margin-left : 10px; - margin-bottom : 5px; - text-align : justify; -} - -.pinfos .description { - padding : 10px; -} - -.pinfos .download { - margin : 200px; -} - -.label { - color : #555; - width : 80px; - float : left; -} - -.tags a { - margin-right : 5px; -} - -form { - margin-left : 5px; - margin-top : 5px; -} - -input { - width : 80px; -} - -/* documentation */ - -.api .title { - font-size: 35; - font-weight: bold; - text-align: center; - background-color : #FFD473; - color : white; -} - -.api ul.entry { - list-style-type: disc; - margin-left : 30px; - padding-left : 0px; -} - -.api .package_content { - display : none; -} - -.api a { - text-decoration : none; -} - -.api a:hover { - text-decoration : underline; -} - -.api a.package { - color : black; -} - -.api .index { -} - -.api .kwd { - color : #09598A; - font-weight : bold; -} - -.api .classname { - font-size : 30; - font-weight : bold; -} - -.api .classdoc { - border : 1px dashed #666; - margin-left : 20px; - margin-right : 20px; - padding : 5 5 5 5; -} - -.api .importmod, .api .extends, .api .implements, .api .typedef, .api .platforms { - color : #777; -} - -.api dd { - margin-top : 10px; - font-size : 12pt; - color : #444; -} - -.api dt { - margin-left : 20px; - margin-bottom : 5px; - text-align : left; -} diff --git a/haxe/std/tools/haxelib/haxelib.hxml b/haxe/std/tools/haxelib/haxelib.hxml deleted file mode 100644 index ff211e2ba4b76ad379f96cee7cf3fbd84b275722..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/haxelib.hxml +++ /dev/null @@ -1,9 +0,0 @@ -# Site --neko index.n --main tools.haxelib.Site - ---next -# Command --neko haxelib.n --main tools.haxelib.Main --cmd nekotools boot haxelib.n diff --git a/haxe/std/tools/haxelib/haxelib.hxp b/haxe/std/tools/haxelib/haxelib.hxp deleted file mode 100644 index e03495e51f62dafb97c127bad12dc8031eb71f8a..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/haxelib.hxp +++ /dev/null @@ -1,14 +0,0 @@ - - -cp ../.. - -cp ../.. --cmd nekotools boot haxelib.n - - - - - - - - - - \ No newline at end of file diff --git a/haxe/std/tools/haxelib/website.mtt b/haxe/std/tools/haxelib/website.mtt deleted file mode 100644 index 3b5c36783dd61627a59d5e0c27dac587dbe941a9..0000000000000000000000000000000000000000 --- a/haxe/std/tools/haxelib/website.mtt +++ /dev/null @@ -1,179 +0,0 @@ - - - -lib.haxe.org - - - - - - -

lib.haxe.org

- -
- -
-
Search :
- - - -
Top tags :
-
    - ::foreach menuTags:: -
  • ::tag:: (::count::)
    • - ::end:: -
-
- - -
- -::if error:: - -
- ::error:: -
- -::elseif act_index:: - -

Welcome

- -

- This website is listing all the libraries available through the haxelib haXe package manager. - Please visit the haxelib page on haXe website to learn more about haxelib. -

- -

Latest releases

- -
- -
- -Browse Projects - -::elseif act_p:: - -

::(p.name)::

- -
-
::(p.description)::
- ::if tags::
Tags
::foreach tags::::tag::::end::
::end:: -
Website
::(p.website)::
-
Version
::(version.name)::
-
Owner
::(owner.name)::
-
License
::(p.license)::
- ::if (version.documentation)::
Documentation
::end:: -
Download
-
- -

History

- -
-
    - ::foreach versions:: -
  • -
    ::date::
    -
    ::name::
    -
    Download
    -
    ::comments::
    -
    • - ::end:: -
-
- -::elseif act_u:: - -

::(u.name)::

- -
-
Name
::(u.fullname)::
- -
- -

Projects

- -
-
    -::foreach uprojects:: -
  • ::name::
    • -::end:: -
-
- -::elseif act_t:: - -

Tag ::tag::

- -

- Here's the list of projects using this tag : -

- -
-
    -::foreach tprojects:: -
  • - ::name:: -
    ::description::
    -
    • -::end:: -
-
- -::elseif act_all:: - -

::if search::Search Results for '::search::'::else::All Projects::end:::

- -
-
    -::foreach projects:: -
  • - ::name:: -
    ::description::
    -
    • -::end:: -
-
- -::elseif act_d:: - -

::(p.name):: ::(v.name):: Documentation

- - - -
-::content:: -
- -::else:: - -

- No content for this action -

- -::end:: - -
- -
- -
- - - diff --git a/haxe/std/tools/hxinst/hxinst.hxml b/haxe/std/tools/hxinst/hxinst.hxml deleted file mode 100644 index 19391be812b88856b8007749259f6ee8524c2715..0000000000000000000000000000000000000000 --- a/haxe/std/tools/hxinst/hxinst.hxml +++ /dev/null @@ -1,5 +0,0 @@ -# Neko --neko hxinst.n --main tools.hxinst.Main --lib xcross --cmd haxelib run xcross -bundle "haXe Installer" hxinst.n diff --git a/haxe/std/tools/hxinst/hxinst.hxp b/haxe/std/tools/hxinst/hxinst.hxp deleted file mode 100644 index fa43e2a5fbc71f83ff1fa8d90898616499cd5346..0000000000000000000000000000000000000000 --- a/haxe/std/tools/hxinst/hxinst.hxp +++ /dev/null @@ -1,7 +0,0 @@ - - -lib xcross --cmd haxelib run xcross -bundle "haXe Installer" hxinst.n - - - - \ No newline at end of file diff --git a/haxe/tests/unit/MyClass.hx b/haxe/tests/unit/MyClass.hx deleted file mode 100644 index 981286320d524f7441d19959df524b2f7d537f56..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/MyClass.hx +++ /dev/null @@ -1,28 +0,0 @@ -package unit; - -class MyClass { - - #if as3 public #end var val : Int; - - public var ref : MyClass; - public var intValue : Int; - public var stringValue : String; - - public function new(v) { - val = v; - intValue = 55; - } - - public function get() { - return val; - } - - public function set(v) { - val = v; - } - - public function add(x,y) { - return val + x + y; - } - -} \ No newline at end of file diff --git a/haxe/tests/unit/RunCpp.hx b/haxe/tests/unit/RunCpp.hx deleted file mode 100644 index cd8f0ff709470a377c6cb1dc5e621a7a21140b96..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/RunCpp.hx +++ /dev/null @@ -1,18 +0,0 @@ -class RunCpp { - - static function main() { - var p = new neko.io.Process(neko.Web.getCwd()+"cpp/Test-debug",[]); - try { - while( true ) { - var c = p.stdout.readByte(); - if( c == "\n".code ) - neko.Lib.print("
"); - else - neko.Lib.print(StringTools.htmlEscape(String.fromCharCode(c))); - } - } catch( e : haxe.io.Eof ) { - } - neko.Lib.print(StringTools.htmlEscape(p.stderr.readAll().toString()).split("\n").join("
")); - } - -} \ No newline at end of file diff --git a/haxe/tests/unit/TestBasetypes.hx b/haxe/tests/unit/TestBasetypes.hx deleted file mode 100644 index e5be9dabb7ef7db310d6fd28c4964bb2b85eeaaf..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/TestBasetypes.hx +++ /dev/null @@ -1,142 +0,0 @@ -package unit; - -class TestBasetypes extends Test { - - function testArray() { - var a : Array> = [1,2,3]; - eq( a.length, 3 ); - eq( a[0], 1 ); - eq( a[2], 3 ); - - eq( a[3], null ); - eq( a[1000], null ); - eq( a[-1], null ); - - a.remove(2); - eq( a.length, 2); - eq( a[0], 1 ); - eq( a[1], 3 ); - eq( a[2], null ); - - var a : Array> = [1,2,3]; - a.splice(1,1); - eq( a.length, 2 ); - eq( a[0], 1 ); - eq( a[1], 3 ); - eq( a[2], null ); - } - - function testString() { - eq( String.fromCharCode(77), "M" ); - unspec(function() String.fromCharCode(0)); - unspec(function() String.fromCharCode(-1)); - unspec(function() String.fromCharCode(256)); -#if php - eq( Std.string(null) + "x", "nullx" ); - eq( "x" + Std.string(null), "xnull" ); -#else - eq( null + "x", "nullx" ); - eq( "x" + null, "xnull" ); -#end - - var abc = "abc".split(""); - eq( abc.length, 3 ); - eq( abc[0], "a" ); - eq( abc[1], "b" ); - eq( abc[2], "c" ); - - var str = "abc"; - eq( str.charCodeAt(0), "a".code ); - eq( str.charCodeAt(1), "b".code ); - eq( str.charCodeAt(2), "c".code ); - eq( str.charCodeAt(-1), null ); - eq( str.charCodeAt(3), null ); - } - - function testMath() { - eq( Std.int(-1.7), -1 ); - eq( Std.int(-1.2), -1 ); - eq( Std.int(1.7), 1 ); - eq( Std.int(1.2), 1 ); - eq( Std.int(-0.7), 0 ); - eq( Std.int(-0.2), 0 ); - eq( Std.int(0.7), 0 ); - eq( Std.int(0.2), 0 ); - - eq( Math.floor(-1.7), -2 ); - eq( Math.floor(-1.5), -2 ); - eq( Math.floor(-1.2), -2 ); - eq( Math.floor(1.7), 1 ); - eq( Math.floor(1.5), 1 ); - eq( Math.floor(1.2), 1 ); - eq( Math.ceil(-1.7), -1 ); - eq( Math.ceil(-1.5), -1 ); - eq( Math.ceil(-1.2), -1 ); - eq( Math.ceil(1.7), 2 ); - eq( Math.ceil(1.5), 2 ); - eq( Math.ceil(1.2), 2 ); - eq( Math.round(-1.7), -2 ); - eq( Math.round(-1.5), -1 ); - eq( Math.round(-1.2), -1 ); - eq( Math.round(1.7), 2 ); - eq( Math.round(1.5), 2 ); - eq( Math.round(1.2), 1 ); - - // overflows might occurs depending on the platform - unspec(function() Std.int(-10000000000.7)); - unspec( function() Math.floor(-10000000000.7) ); - unspec( function() Math.ceil(-10000000000.7) ); - unspec( function() Math.round(-10000000000.7) ); - // should still give a proper result for lower bits - eq( Std.int(-10000000000.7) & 0xFFFFFF, 15997952 ); - eq( Math.floor(-10000000000.7) & 0xFFFFFF, 15997951 ); - eq( Math.ceil(-10000000000.7) & 0xFFFFFF, 15997952 ); - eq( Math.round(-10000000000.7) & 0xFFFFFF, 15997951 ); - } - - function testParse() { - eq( Std.parseInt("0"), 0 ); - eq( Std.parseInt(" 5"), 5 ); - eq( Std.parseInt("0001"), 1 ); - eq( Std.parseInt("0010"), 10 ); - eq( Std.parseInt("100"), 100 ); - eq( Std.parseInt("-100"), -100 ); - eq( Std.parseInt("100x123"), 100 ); - eq( Std.parseInt(""), null ); - eq( Std.parseInt("abcd"), null ); - eq( Std.parseInt("a10"), null ); - eq( Std.parseInt(null), null ); - eq( Std.parseInt("0xFF"), 255 ); - unspec(function() Std.parseInt("0xFG")); - - eq( Std.parseFloat("0"), 0. ); - eq( Std.parseFloat(" 5.3"), 5.3 ); - eq( Std.parseFloat("0001"), 1. ); - eq( Std.parseFloat("100.45"), 100.45 ); - eq( Std.parseFloat("-100.01"), -100.01 ); - eq( Std.parseFloat("100x123"), 100. ); - t( Math.isNaN(Std.parseFloat("")) ); - t( Math.isNaN(Std.parseFloat("abcd")) ); - t( Math.isNaN(Std.parseFloat("a10")) ); - t( Math.isNaN(Std.parseFloat(null)) ); - - } - - function testStringTools() { - eq( StringTools.hex(0xABCDEF,7), "0ABCDEF" ); - eq( StringTools.hex(-1,8), "FFFFFFFF" ); - eq( StringTools.hex(-481400000,8), "E34E6B40" ); - } - - function testCCA() { - var str = "abc"; - eq( StringTools.fastCodeAt(str, 0), "a".code ); - eq( StringTools.fastCodeAt(str, 1), "b".code ); - eq( StringTools.fastCodeAt(str, 2), "c".code ); - f( StringTools.isEOF(StringTools.fastCodeAt(str, 2)) ); - t( StringTools.isEOF(StringTools.fastCodeAt(str, 3)) ); - - t( StringTools.isEOF(StringTools.fastCodeAt("", 0)) ); - } - -} diff --git a/haxe/tests/unit/TestEReg.hx b/haxe/tests/unit/TestEReg.hx deleted file mode 100644 index a88ef3f37f338cdc774e11bfcf559ac51de67c66..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/TestEReg.hx +++ /dev/null @@ -1,52 +0,0 @@ -package unit; - -class TestEReg extends Test { - - - function test() { - #if !flash8 - var r = ~/a+(b)?(c*)a+/; - f( r.match("") ); - f( r.match("xxyy") ); - t( r.match("xxaabcayyy") ); - eq( r.matched(0), "aabca" ); - eq( r.matched(1), "b" ); - eq( r.matched(2), "c" ); - eq( r.matchedLeft(), "xx" ); - eq( r.matchedRight(), "yyy" ); - eq( r.matchedPos().pos, 2 ); - eq( r.matchedPos().len, 5 ); - - t( r.match("aaa") ); - eq( r.matched(0), "aaa" ); - eq( r.matchedLeft(), "" ); - eq( r.matchedRight(), "" ); - eq( r.matched(1), null ); // JS/IE7 bug - eq( r.matched(2), "" ); - unspec(function() r.matched(3)); - unspec(function() r.matched(-1)); - - var r = ~/^(b)?$/; - t( r.match("") ); - eq( r.matched(0), "" ); - eq( r.matched(1), null ); // JS/IE7 bug - - t( ~/\//.match("/") ); - - t( ~/\n/.match("\n") ); - f( ~/\\n/.match("\n") ); - t( ~/\\n/.match("\\n") ); - - t( ~/"/.match('"') ); - f( ~/\\"/.match('"') ); - t( ~/\\"/.match('\\"') ); - - t( ~/\$/.match('$') ); - f( ~/\\$/.match('$') ); - f( ~/\\$/.match('\\$') ); - t( ~/\\\$/.match('\\$') ); - - #end - } - -} \ No newline at end of file diff --git a/haxe/tests/unit/TestInt32.hx b/haxe/tests/unit/TestInt32.hx deleted file mode 100644 index d8a8192d4bb24136ffcf771de5f17ede7d0860e8..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/TestInt32.hx +++ /dev/null @@ -1,82 +0,0 @@ -package unit; -import haxe.Int32; - -class TestInt32 extends Test { - - static inline function i( x ) { - return Int32.toInt(x); - } - - static inline function i32( x ) { - return Int32.ofInt(x); - } - - public function test() { - // constants - eq( 0xFE08BE39, -32981447 ); - - // 31bits platforms might overflow on the last bit of the constant - allow( 0x5E08BE39 >> 16, [0x5E08,0xFFFFDE08] ); - allow( 0xAE08BE39 >>> 16, [0xAE08,0x2E08] ); - - var one = i32(1); - var minone = i32(-1); - var zero = i32(0); - - // ofInt / make - eq( i(zero), 0 ); - eq( i(one), 1 ); - eq( i(minone), -1 ); - eq( i(i32(0x01020304)), 0x01020304 ); - eq( i(Int32.make(0x0102,0x0304)), 0x01020304 ); - - // 31 bits overflow - exc( function() i(Int32.shl(one,30)) ); - exc( function() i(Int32.shl(i32(2),30)) ); - exc( function() i(Int32.neg(Int32.add(Int32.shl(one,30),one))) ); - - // check correct closure creation (not inlined) - var f = Int32.make; - eq( i(f(0x0102,0x0304)), 0x01020304 ); - - eq( Int32.compare(one,one), 0 ); - eq( Int32.compare(one,zero), 1 ); - eq( Int32.compare(zero,one), -1 ); - eq( Int32.compare(minone,minone), 0 ); - eq( Int32.compare(minone,zero), -1 ); - eq( Int32.compare(zero,minone), 1 ); - - eq( i(Int32.add(one,one)), 2 ); - eq( i(Int32.sub(minone,one)), -2 ); - eq( i(Int32.mul(i32(5),i32(100))), 500 ); - - // overflow - eq( i(Int32.mul(i32(160427),i32(160427))), 0xFE08BE39 ); - - // signed divide and modulo - eq( i(Int32.div(i32(0x3E08BE39),i32(16))), 0x03E08BE3 ); - eq( i(Int32.div(i32(0xFE08BE39),i32(16))), 0xFFE08BE4 ); - eq( i(Int32.mod(i32(0xFE08BE39),i32(0xFFFF))), -17342 ); - eq( i(Int32.mod(i32(0xE08BE39),i32(0x10000))), 0xBE39 ); - - // logical - eq( i(Int32.shl(i32(5),16)), 0x50000 ); - eq( i(Int32.shl(i32(3),30)), 0xC0000000 ); - eq( i(Int32.shr(i32(-1),16)), -1 ); - eq( i(Int32.ushr(i32(-1),16)), 0xFFFF ); - - eq( i(Int32.and(i32(0xFE08BE39),i32(0xFFFF))), 0xBE39 ); - eq( i(Int32.and(i32(0xFE08BE39),i32(0xFFFF0000))), 0xFE080000 ); - eq( i(Int32.and(i32(0xFE08BE39),i32(0xFFF0000))), 0x0E080000 ); - - eq( i(Int32.or(i32(0xFE08BE39),i32(0xFFFF))), 0xFE08FFFF ); - eq( i(Int32.or(i32(0xFE08BE39),i32(0xFFFF0000))), 0xFFFFBE39 ); - eq( i(Int32.or(i32(0xBE39),i32(0xFE080000))), 0xFE08BE39 ); - - eq( i(Int32.xor(i32(0xFE08BE39),i32(0xCBCDEF99))), 0x35C551A0 ); - eq( i(Int32.neg(one)), -1 ); - eq( i(Int32.complement(i32(55))), -56 ); - eq( i(Int32.complement(i32(-0x10000))), 0xFFFF ); - } - -} \ No newline at end of file diff --git a/haxe/tests/unit/TestMisc.hx b/haxe/tests/unit/TestMisc.hx deleted file mode 100644 index e9733fa3073b47c0f084a127fa16f2c167fb9971..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/TestMisc.hx +++ /dev/null @@ -1,302 +0,0 @@ -package unit; - -class MyDynamicClass { - - var v : Int; - - public function new(v) { - this.v = v; - } - - public function get() { - return v; - } - - public dynamic function add(x,y) { - return v + x + y; - } - - public inline function iadd(x,y) { - return v + x + y; - } - -#if php - static var Z = 10; - - public dynamic static function staticDynamic(x,y) { - return Z + x + y; - } -#else - static var V = 10; - - public dynamic static function staticDynamic(x,y) { - return V + x + y; - } -#end -} - -class MyDynamicSubClass extends MyDynamicClass { - - override function add(x,y) { - return (v + x + y) * 2; - } - -} - -class MyOtherDynamicClass extends MyDynamicClass { - - public function new(v) { - add = function(x,y) return x + y + 10; - super(v); - } - -} - -interface IDefArgs { - public function get( x : Int = 5 ) : Int; -} - -class BaseDefArgs { - public function get( x = 3 ) { - return x; - } -} - -class ExtDefArgs extends BaseDefArgs, implements IDefArgs { - public function new() { - } - override function get( x = 7 ) { - return x; - } -} - -class TestMisc extends Test { - - function testClosure() { - var c = new MyClass(100); - var add = c.add; - eq( c.add(1,2), 103 ); - eq( callback(c.add,1)(2), 103 ); - eq( add(1,2), 103 ); - - var x = 4; - var f = function() return x; - eq( f(), 4 ); - x++; - eq( f(), 5 ); - - var o = { f : f }; - eq( o.f(), 5 ); - eq( o.f, o.f ); // we shouldn't create a new closure here - - var o = { add : c.add }; - eq( o.add(1,2), 103 ); - eq( o.add, o.add ); // we shouldn't create a new closure here - - var o = { cos : Math.cos }; - eq( o.cos(0), 1. ); - - // check enum - var c = MyEnum.C; - t( Type.enumEq(MyEnum.C(1,"hello"), c(1,"hello")) ); - } - - function testInlineClosure() { - var inst = new MyDynamicClass(100); - var add = inst.iadd; - eq( inst.iadd(1,2), 103 ); - eq( add(1,2), 103 ); - } - - function testDynamicClosure() { - var inst = new MyDynamicClass(100); - var add = inst.add; - eq( inst.add(1,2), 103 ); - eq( callback(inst.add,1)(2), 103 ); - eq( add(1,2), 103 ); - - // check overriden dynamic method - var inst = new MyDynamicSubClass(100); - var add = inst.add; - eq( inst.add(1,2), 206 ); - eq( callback(inst.add,1)(2), 206 ); - eq( add(1,2), 206 ); - - // check redefined dynamic method - inst.add = function(x,y) return inst.get() * 2 + x + y; - var add = inst.add; - eq( inst.add(1,2), 203 ); - eq( callback(inst.add,1)(2), 203 ); - eq( add(1,2), 203 ); - - // check inherited dynamic method - var inst = new MyOtherDynamicClass(0); - var add = inst.add; - eq( inst.add(1,2), 13 ); - eq( callback(inst.add,1)(2), 13 ); - eq( add(1,2), 13 ); - - // check static dynamic - eq( MyDynamicClass.staticDynamic(1,2), 13 ); - MyDynamicClass.staticDynamic = function(x,y) return x + y + 100; - eq( MyDynamicClass.staticDynamic(1,2), 103 ); - } - - function testMD5() { - eq( haxe.Md5.encode(""), "d41d8cd98f00b204e9800998ecf8427e" ); - eq( haxe.Md5.encode("hello"), "5d41402abc4b2a76b9719d911017c592" ); - // depending of ISO/UTF8 native - allow( haxe.Md5.encode("héllo"), ["1a722f7e6c801d9e470a10cb91ba406d","be50e8478cf24ff3595bc7307fb91b50"] ); - } - - function testBaseCode() { - var b = new haxe.BaseCode(haxe.io.Bytes.ofString("0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-")); - eq( b.encodeString("Héllow"), "iceFr6NLtM" ); - eq( b.decodeString("iceFr6NLtM"), "Héllow" ); - } - - function testUrlEncode() { - eq( StringTools.urlEncode("é"), "%C3%A9" ); - eq( StringTools.urlDecode("%C3%A9"), "é" ); - } - - function opt1( ?x : Int, ?y : String ) { - return { x : x, y : y }; - } - - function opt2( ?x = 5, ?y = "hello" ) { - return { x : x, y : y }; - } - - function opt3( ?x : Null = 5, ?y : Null = 6 ) { - return { x : x, y : y }; - } - - function testOptionalParams() { - eq( opt1().x, null ); - eq( opt1().y, null ); - eq( opt1(55).x, 55 ); - eq( opt1(55).y, null ); - eq( opt1("str").x, null ); - eq( opt1("str").y, "str" ); - eq( opt1(66,"hello").x, 66 ); - eq( opt1(66, "hello").y, "hello" ); - - eq( opt2().x, 5 ); - eq( opt2().y, "hello" ); - - #if !flash9 - eq( opt2(null, null).x, 5 ); - #end - eq( opt2(0, null).y, "hello" ); - - eq( opt3().x, 5 ); - eq( opt3().y, 6 ); - eq( opt3(9).x, 9 ); - eq( opt3(9).y, 6 ); - eq( opt3(9,10).x, 9 ); - eq( opt3(9,10).y, 10 ); - eq( opt3(null,null).x, 5 ); - eq( opt3(null,null).y, 6 ); - eq( opt3(null).x, 5 ); - eq( opt3(null).y, 6 ); - eq( opt3(null,7).x, 5 ); - eq( opt3(null, 7).y, 7 ); - - // skipping - eq( opt3(7.4).x, 5 ); - eq( opt3(7.4).y, 7.4 ); - } - - function testIncr() { - var z = 0; - eq( z++, 0 ); - eq( z, 1 ); - eq( ++z, 2 ); - eq( z, 2 ); - z++; - eq( z, 3 ); - ++z; - eq( z, 4 ); - - eq( z += 3, 7 ); - - var x = 0; - var arr = [3]; - eq( arr[x++]++, 3 ); - eq( x, 1 ); - eq( arr[0], 4 ); - x = 0; - eq( arr[x++] += 3, 7 ); - eq( arr[0], 7 ); - - var x = 0; - var arr = [{ v : 3 }]; - eq( arr[x++].v++, 3 ); - eq( x, 1 ); - eq( arr[0].v, 4 ); - - #if !as3 - x = 0; - eq( arr[x++].v += 3, 7 ); - eq( arr[0].v, 7 ); - #end - } - - function testInitOrder() { - var i = 0; - var o = { - y : i++, - x : i++, - z : i++, - blabla : i++, - }; - eq(o.y,0); - eq(o.x,1); - eq(o.z,2); - eq(o.blabla,3); - } - - static inline function foo(x) return x + 5 - - function testInline() { - // check that operations are correctly generated - var x = 3; // prevent optimization - eq( 2 * foo(x), 16 ); - eq( -foo(x), -8 ); - } - - function testEvalAccessOrder() { - var a = [0,0]; - var x = 0; - a[x++]++; - eq(a[0],1); - eq(a[1],0); - - var x = 0; - var a = new Array(); - a[x++] = x++; - eq(a[0],1); - - var x = 0; - var foo = function() return x++; - a[foo()] = foo(); - eq(a[0],1); - } - - static var add = function (x, y) return x + y; - - function testStaticVarFun() { - eq( add(2,3), 5); - } - - function testDefArgs() { - var e = new ExtDefArgs(); - eq( e.get(), 7 ); - var b : BaseDefArgs = e; - eq( e.get(), 7 ); - var i : IDefArgs = e; - eq( e.get(), 7 ); - } - -} diff --git a/haxe/tests/unit/TestType.hx b/haxe/tests/unit/TestType.hx deleted file mode 100644 index 49262fb3ef855a7c5ee1b6ea4e428f9edf9a7b95..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/TestType.hx +++ /dev/null @@ -1,52 +0,0 @@ -package unit; -import unit.MyEnum; - -class TestType extends Test { - - static inline function u( s : String ) : String { - #if flash - return untyped __unprotect__(s); - #else - return s; - #end - } - - public function testType() { - var name = u("unit")+"."+u("MyClass"); - eq( Type.resolveClass(name), unit.MyClass ); - eq( Type.getClassName(unit.MyClass), name ); - eq( Type.getClassFields(unit.MyClass).length , 0 ); - } - - public function testFields() { - var sfields = Type.getClassFields(unit.MySubClass); - eq( sfields.length , 1 ); - eq( sfields[0], u("XXX") ); - - var fields = [u("add"),u("get"),u("intValue"),u("ref"),u("set"),u("stringValue"),u("val")]; - var fl = Type.getInstanceFields(unit.MyClass); - fl.sort(Reflect.compare); - eq( fl.join("|"), fields.join("|") ); - var fl = Type.getInstanceFields(unit.MySubClass); - fl.sort(Reflect.compare); - eq( fl.join("|"), fields.join("|") ); - } - - public function testEnumEq() { - t( Type.enumEq(null,null) ); - f( Type.enumEq(A,null) ); - f( Type.enumEq(null,D(A)) ); - - t( Type.enumEq(A,A) ); - t( Type.enumEq(B,B) ); - f( Type.enumEq(A,B) ); - - t( Type.enumEq(C(1,"hello"),C(1,"hello")) ); - f( Type.enumEq(C(1,"hello"),C(1,"hellox")) ); - - t( Type.enumEq(D(A),D(A)) ); - f( Type.enumEq(D(A),D(B)) ); - - } - -} \ No newline at end of file diff --git a/haxe/tests/unit/params.hxml b/haxe/tests/unit/params.hxml deleted file mode 100644 index f24dd388fe28fc3f0682e7d608e553ad573f16e9..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/params.hxml +++ /dev/null @@ -1,5 +0,0 @@ --debug --cp .. --resource res1.txt --resource res2.bin ---no-opt \ No newline at end of file diff --git a/haxe/tests/unit/unit.hxml b/haxe/tests/unit/unit.hxml deleted file mode 100644 index fe1759d492885bc88608a9b8a426e545b904985c..0000000000000000000000000000000000000000 --- a/haxe/tests/unit/unit.hxml +++ /dev/null @@ -1,41 +0,0 @@ --cp .. --swf unit8.swf --swf-header 300:300:30:FFFFFF --main unit.Test --swf-version 8 -params.hxml ---next --swf9 unit9.swf --main unit.Test -params.hxml ---next --as3 as3 --cp .. --main unit.Test ---next --js unit.js -unit.Test -params.hxml ---next --neko unit.n --main unit.Test -params.hxml ---next --main unit.Test -params.hxml ---interp ---next --neko remoting.n --main unit.RemotingServer --cp .. ---next --php php --main unit.Test -params.hxml ---next --neko runcpp.n --main RunCpp ---next --cpp cpp --main unit.Test -params.hxml diff --git a/haxe/typecore.ml b/haxe/typecore.ml deleted file mode 100644 index 6da1b29a448ef8068924043804f45eb88a83127a..0000000000000000000000000000000000000000 --- a/haxe/typecore.ml +++ /dev/null @@ -1,246 +0,0 @@ -(* - * Haxe Compiler - * Copyright (c)2005-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 Common -open Type - -type type_patch = { - mutable tp_type : Ast.complex_type option; - mutable tp_remove : bool; - mutable tp_meta : Ast.metadata; -} - -type typer_globals = { - types_module : (path, path) Hashtbl.t; - modules : (path , module_def) Hashtbl.t; - mutable delayed : (unit -> unit) list; - constructs : (path , Ast.access list * Ast.type_param list * Ast.func) Hashtbl.t; - doinline : bool; - mutable core_api : typer option; - mutable macros : ((unit -> unit) * typer) option; - mutable std : module_def; - mutable hook_generate : (unit -> unit) list; - type_patches : (path, (string * bool, type_patch) Hashtbl.t * type_patch) Hashtbl.t; - (* api *) - do_inherit : typer -> Type.tclass -> Ast.pos -> Ast.class_flag -> bool; - do_create : Common.context -> typer; - do_macro : typer -> path -> string -> Ast.expr list -> Ast.pos -> Ast.expr option; - do_load_module : typer -> path -> pos -> module_def; - do_optimize : typer -> texpr -> texpr; - do_build_instance : typer -> module_type -> pos -> ((string * t) list * path * (t list -> t)); -} - -and typer = { - (* shared *) - com : context; - mutable t : basic_types; - g : typer_globals; - mutable in_macro : bool; - (* per-module *) - current : module_def; - mutable local_types : module_type list; - mutable local_using : module_type list; - (* per-class *) - mutable curclass : tclass; - mutable tthis : t; - mutable type_params : (string * t) list; - (* per-function *) - mutable curmethod : string; - mutable untyped : bool; - mutable in_super_call : bool; - mutable in_constructor : bool; - mutable in_static : bool; - mutable in_loop : bool; - mutable in_display : bool; - mutable ret : t; - mutable locals : (string, t) PMap.t; - mutable locals_map : (string, string) PMap.t; - mutable locals_map_inv : (string, string) PMap.t; - mutable opened : anon_status ref list; - mutable param_type : t option; -} - -type error_msg = - | Module_not_found of path - | Type_not_found of path * string - | Unify of unify_error list - | Custom of string - | Protect of error_msg - | Unknown_ident of string - | Stack of error_msg * error_msg - | Forbid_package of string * path - -exception Error of error_msg * pos - -let type_expr_ref : (typer -> Ast.expr -> bool -> texpr) ref = ref (fun _ _ _ -> assert false) - -let unify_error_msg ctx = function - | Cannot_unify (t1,t2) -> - s_type ctx t1 ^ " should be " ^ s_type ctx t2 - | Invalid_field_type s -> - "Invalid type for field " ^ s ^ " :" - | Has_no_field (t,n) -> - s_type ctx t ^ " has no field " ^ n - | Has_extra_field (t,n) -> - s_type ctx t ^ " has extra field " ^ n - | Invalid_kind (f,a,b) -> - (match a, b with - | Var va, Var vb -> - let name, stra, strb = if va.v_read = vb.v_read then - "setter", s_access va.v_write, s_access vb.v_write - else if va.v_write = vb.v_write then - "getter", s_access va.v_read, s_access vb.v_read - else - "access", "(" ^ s_access va.v_read ^ "," ^ s_access va.v_write ^ ")", "(" ^ s_access vb.v_read ^ "," ^ s_access vb.v_write ^ ")" - in - "Inconsistent " ^ name ^ " for field " ^ f ^ " : " ^ stra ^ " should be " ^ strb - | _ -> - "Field " ^ f ^ " is " ^ s_kind a ^ " but should be " ^ s_kind b) - | Invalid_visibility n -> - "The field " ^ n ^ " is not public" - | Not_matching_optional n -> - "Optional attribute of parameter " ^ n ^ " differs" - | Cant_force_optional -> - "Optional parameters can't be forced" - -let rec error_msg = function - | Module_not_found m -> "Class not found : " ^ Ast.s_type_path m - | Type_not_found (m,t) -> "Module " ^ Ast.s_type_path m ^ " does not define type " ^ t - | Unify l -> - let ctx = print_context() in - String.concat "\n" (List.map (unify_error_msg ctx) l) - | Unknown_ident s -> "Unknown identifier : " ^ s - | Custom s -> s - | Stack (m1,m2) -> error_msg m1 ^ "\n" ^ error_msg m2 - | Protect m -> error_msg m - | Forbid_package (p,m) -> - "You can't access the " ^ p ^ " package with current compilation flags (for " ^ Ast.s_type_path m ^ ")" - -let display_error ctx msg p = ctx.com.error msg p - -let error msg p = raise (Error (Custom msg,p)) - -let type_expr ctx e need_val = (!type_expr_ref) ctx e need_val - -let unify ctx t1 t2 p = - try - Type.unify t1 t2 - with - Unify_error l -> - if not ctx.untyped then display_error ctx (error_msg (Unify l)) p - -let unify_raise ctx t1 t2 p = - try - Type.unify t1 t2 - with - Unify_error l -> - (* no untyped check *) - raise (Error (Unify l,p)) - -let exc_protect f = - let rec r = ref (fun() -> - try - f r - with - | Error (Protect _,_) as e -> raise e - | Error (m,p) -> raise (Error (Protect m,p)) - ) in - r - -let save_locals ctx = - let locals = ctx.locals in - let map = ctx.locals_map in - let inv = ctx.locals_map_inv in - (fun() -> - ctx.locals <- locals; - ctx.locals_map <- map; - ctx.locals_map_inv <- inv; - ) - -let add_local ctx v t = - let rec loop n = - let nv = (if n = 0 then v else v ^ string_of_int n) in - if PMap.mem nv ctx.locals || PMap.mem nv ctx.locals_map_inv then - loop (n+1) - else begin - ctx.locals <- PMap.add v t ctx.locals; - if n <> 0 then begin - ctx.locals_map <- PMap.add v nv ctx.locals_map; - ctx.locals_map_inv <- PMap.add nv v ctx.locals_map_inv; - end; - nv - end - in - loop 0 - -let gen_local ctx t = - let rec loop n = - let nv = (if n = 0 then "_g" else "_g" ^ string_of_int n) in - if PMap.mem nv ctx.locals || PMap.mem nv ctx.locals_map_inv then - loop (n+1) - else - nv - in - add_local ctx (loop 0) t - -let rec is_nullable = function - | TMono r -> - (match !r with None -> true | Some t -> is_nullable t) - | TType ({ t_path = ([],"Null") },[_]) -> - false - | TLazy f -> - is_nullable (!f()) - | TType (t,tl) -> - is_nullable (apply_params t.t_types tl t.t_type) - | TFun _ -> - true - | TInst ({ cl_path = (["haxe"],"Int32") },[]) - | TInst ({ cl_path = ([],"Int") },[]) - | TInst ({ cl_path = ([],"Float") },[]) - | TEnum ({ e_path = ([],"Bool") },[]) -> true - | _ -> - false - -let rec is_null = function - | TMono r -> - (match !r with None -> false | Some t -> is_null t) - | TType ({ t_path = ([],"Null") },[t]) -> - is_nullable t - | TLazy f -> - is_null (!f()) - | TType (t,tl) -> - is_null (apply_params t.t_types tl t.t_type) - | _ -> - false - -let not_opened = ref Closed -let mk_anon fl = TAnon { a_fields = fl; a_status = not_opened; } - -let delay ctx f = - ctx.g.delayed <- f :: ctx.g.delayed - -let mk_field name t = { - cf_name = name; - cf_type = t; - cf_doc = None; - cf_meta = no_meta; - cf_public = true; - cf_kind = Var { v_read = AccNormal; v_write = AccNormal }; - cf_expr = None; - cf_params = []; -} diff --git a/haxe/typeload.ml b/haxe/typeload.ml deleted file mode 100644 index 241975cf9660af7431228ef62401ce6c1b235249..0000000000000000000000000000000000000000 --- a/haxe/typeload.ml +++ /dev/null @@ -1,1443 +0,0 @@ -(* - * Haxe Compiler - * Copyright (c)2005-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 Ast -open Type -open Common -open Typecore - -let type_function_param ctx t e opt p = - match e with - | None -> - if opt then ctx.t.tnull t, Some (EConst (Ident "null"),p) else t, None - | Some e -> - t, Some e - -let type_static_var ctx t e p = - ctx.in_static <- true; - let e = type_expr ctx e true in - unify ctx e.etype t p; - (* specific case for UInt statics *) - match t with - | TType ({ t_path = ([],"UInt") },[]) -> { e with etype = t } - | _ -> e - -let apply_macro ctx path el p = - let cpath, meth = (match List.rev (ExtString.String.nsplit path ".") with - | meth :: name :: pack -> (List.rev pack,name), meth - | _ -> error "Invalid macro path" p - ) in - ctx.g.do_macro ctx cpath meth el p - -(** since load_type_def and load_instance are used in PASS2, they should not access the structure of a type **) - -(* - load a type or a subtype definition -*) -let rec load_type_def ctx p t = - let no_pack = t.tpackage = [] in - let tname = (match t.tsub with None -> t.tname | Some n -> n) in - try - if t.tsub <> None then raise Not_found; - List.find (fun t2 -> - let tp = t_path t2 in - tp = (t.tpackage,tname) || (no_pack && snd tp = tname) - ) ctx.local_types - with - Not_found -> - let next() = - let m = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in - let tpath = (t.tpackage,tname) in - try - List.find (fun t -> not (t_private t) && t_path t = tpath) m.mtypes - with - Not_found -> raise (Error (Type_not_found (m.mpath,tname),p)) - in - let rec loop = function - | [] -> raise Exit - | (_ :: lnext) as l -> - try - load_type_def ctx p { t with tpackage = List.rev l } - with - | Error (Module_not_found _,p2) - | Error (Type_not_found _,p2) when p == p2 -> loop lnext - in - try - if not no_pack then raise Exit; - (match fst ctx.current.mpath with - | [] -> raise Exit - | x :: _ -> - (* this can occur due to haxe remoting : a module can be - already defined in the "js" package and is not allowed - to access the js classes *) - try - (match PMap.find x ctx.com.package_rules with - | Forbidden -> raise Exit - | _ -> ()) - with Not_found -> ()); - loop (List.rev (fst ctx.current.mpath)); - with - Exit -> next() - -let check_param_constraints ctx types t pl c p = - List.iter (fun (i,tl) -> - let ti = try snd (List.find (fun (_,t) -> match follow t with TInst(i2,[]) -> i == i2 | _ -> false) types) with Not_found -> TInst (i,tl) in - let ti = apply_params types pl ti in - unify ctx t ti p - ) c.cl_implements - -(* build an instance from a full type *) -let rec load_instance ctx t p allow_no_params = - try - if t.tpackage <> [] || t.tsub <> None then raise Not_found; - let pt = List.assoc t.tname ctx.type_params in - if t.tparams <> [] then error ("Class type parameter " ^ t.tname ^ " can't have parameters") p; - pt - with Not_found -> - let types , path , f = ctx.g.do_build_instance ctx (load_type_def ctx p t) p in - if allow_no_params && t.tparams = [] then begin - let pl = ref [] in - pl := List.map (fun (name,t) -> - match follow t with - | TInst (c,_) -> - let t = mk_mono() in - if c.cl_implements <> [] then delay ctx (fun() -> check_param_constraints ctx types t (!pl) c p); - t; - | _ -> assert false - ) types; - f (!pl) - end else if path = ([],"Dynamic") then - match t.tparams with - | [] -> t_dynamic - | [TPType t] -> TDynamic (load_complex_type ctx p t) - | _ -> error "Too many parameters for Dynamic" p - else begin - if List.length types <> List.length t.tparams then error ("Invalid number of type parameters for " ^ s_type_path path) p; - let tparams = List.map (fun t -> - match t with - | TPConst c -> - let name, const = (match c with - | String s -> "S" ^ s, TString s - | Int i -> "I" ^ i, TInt (Int32.of_string i) - | Float f -> "F" ^ f, TFloat f - | _ -> assert false - ) in - let c = mk_class ([],name) p in - c.cl_kind <- KConstant const; - TInst (c,[]) - | TPType t -> load_complex_type ctx p t - ) t.tparams in - let params = List.map2 (fun t (name,t2) -> - let isconst = (match t with TInst ({ cl_kind = KConstant _ },_) -> true | _ -> false) in - if isconst <> (name = "Const") && t != t_dynamic then error (if isconst then "Constant value unexpected here" else "Constant value excepted as type parameter") p; - match follow t2 with - | TInst ({ cl_implements = [] }, []) -> - t - | TInst (c,[]) -> - let r = exc_protect (fun r -> - r := (fun() -> t); - check_param_constraints ctx types t tparams c p; - t - ) in - delay ctx (fun () -> ignore(!r())); - TLazy r - | _ -> assert false - ) tparams types in - f params - end -(* - build an instance from a complex type -*) -and load_complex_type ctx p t = - match t with - | CTParent t -> load_complex_type ctx p t - | CTPath t -> load_instance ctx t p false - | CTExtend (t,l) -> - (match load_complex_type ctx p (CTAnonymous l) with - | TAnon a -> - let rec loop t = - match follow t with - | TInst (c,tl) -> - let c2 = mk_class (fst c.cl_path,"+" ^ snd c.cl_path) p in - c2.cl_private <- true; - PMap.iter (fun f _ -> - try - ignore(class_field c f); - error ("Cannot redefine field " ^ f) p - with - Not_found -> () - ) a.a_fields; - (* do NOT tag as extern - for protect *) - c2.cl_kind <- KExtension (c,tl); - c2.cl_super <- Some (c,tl); - c2.cl_fields <- a.a_fields; - TInst (c2,[]) - | TMono _ -> - error "Please ensure correct initialization of cascading signatures" p - | TAnon a2 -> - PMap.iter (fun f _ -> - if PMap.mem f a2.a_fields then error ("Cannot redefine field " ^ f) p - ) a.a_fields; - mk_anon (PMap.foldi PMap.add a.a_fields a2.a_fields) - | _ -> error "Cannot only extend classes and anonymous" p - in - loop (load_instance ctx t p false) - | _ -> assert false) - | CTAnonymous l -> - let rec loop acc (n,pub,f,p) = - if PMap.mem n acc then error ("Duplicate field declaration : " ^ n) p; - let t , access = (match f with - | AFVar t -> - load_complex_type ctx p t, Var { v_read = AccNormal; v_write = AccNormal } - | AFFun (tl,t) -> - let t = load_complex_type ctx p t in - let args = List.map (fun (name,o,t) -> name , o, load_complex_type ctx p t) tl in - TFun (args,t), Method MethNormal - | AFProp (t,i1,i2) -> - let access m get = - match m with - | "null" -> AccNo - | "never" -> AccNever - | "default" -> AccNormal - | "dynamic" -> AccCall ((if get then "get_" else "set_") ^ n) - | _ -> AccCall m - in - load_complex_type ctx p t, Var { v_read = access i1 true; v_write = access i2 false } - ) in - PMap.add n { - cf_name = n; - cf_type = t; - cf_public = (match pub with None -> true | Some p -> p); - cf_kind = access; - cf_params = []; - cf_expr = None; - cf_doc = None; - cf_meta = no_meta; - } acc - in - mk_anon (List.fold_left loop PMap.empty l) - | CTFunction (args,r) -> - match args with - | [CTPath { tpackage = []; tparams = []; tname = "Void" }] -> - TFun ([],load_complex_type ctx p r) - | _ -> - TFun (List.map (fun t -> "",false,load_complex_type ctx p t) args,load_complex_type ctx p r) - -let hide_types ctx = - let old_locals = ctx.local_types in - let old_type_params = ctx.type_params in - ctx.local_types <- ctx.g.std.mtypes; - ctx.type_params <- []; - (fun() -> - ctx.local_types <- old_locals; - ctx.type_params <- old_type_params; - ) - -(* - load a type while ignoring the current imports or local types -*) -let load_core_type ctx name = - let show = hide_types ctx in - let t = load_instance ctx { tpackage = []; tname = name; tparams = []; tsub = None; } null_pos false in - show(); - t - -let t_iterator ctx = - let show = hide_types ctx in - match load_type_def ctx null_pos { tpackage = []; tname = "Iterator"; tparams = []; tsub = None } with - | TTypeDecl t -> - show(); - if List.length t.t_types <> 1 then assert false; - let pt = mk_mono() in - apply_params t.t_types [pt] t.t_type, pt - | _ -> - assert false - -(* - load either a type t or Null if not defined -*) -let load_type_opt ?(opt=false) ctx p t = - let t = (match t with None -> mk_mono() | Some t -> load_complex_type ctx p t) in - if opt then ctx.t.tnull t else t - -(* ---------------------------------------------------------------------- *) -(* Structure check *) - -let valid_redefinition ctx f1 t1 f2 t2 = - let valid t1 t2 = - type_eq EqStrict t1 t2; - if is_null t1 <> is_null t2 then raise (Unify_error [Cannot_unify (t1,t2)]); - in - let t1, t2 = (match f1.cf_params, f2.cf_params with - | [], [] -> t1, t2 - | l1, l2 when List.length l1 = List.length l2 -> - let monos = List.map (fun _ -> mk_mono()) l1 in - apply_params l1 monos t1, apply_params l2 monos t2 - | _ -> t1, t2 - ) in - match follow t1, follow t2 with - | TFun (args1,r1) , TFun (args2,r2) when List.length args1 = List.length args2 -> - List.iter2 (fun (n,o1,a1) (_,o2,a2) -> - if o1 <> o2 then raise (Unify_error [Not_matching_optional n]); - valid a1 a2; - ) args1 args2; - valid r1 r2; - | _ , _ -> - (* in case args differs, or if an interface var *) - valid t1 t2 - -let check_overriding ctx c p () = - match c.cl_super with - | None -> - (match c.cl_overrides with - | [] -> () - | i :: _ -> - display_error ctx ("Field " ^ i ^ " is declared 'override' but doesn't override any field") p) - | Some (csup,params) -> - PMap.iter (fun i f -> - try - let t , f2 = raw_class_field (fun f -> f.cf_type) csup i in - ignore(follow f.cf_type); (* force evaluation *) - let p = (match f.cf_expr with None -> p | Some e -> e.epos) in - if not (List.mem i c.cl_overrides) then - display_error ctx ("Field " ^ i ^ " should be declared with 'override' since it is inherited from superclass") p - else if f.cf_public <> f2.cf_public then - display_error ctx ("Field " ^ i ^ " has different visibility (public/private) than superclass one") p - else (match f.cf_kind, f2.cf_kind with - | _, Method MethInline -> - display_error ctx ("Field " ^ i ^ " is inlined and cannot be overridden") p - | a, b when a = b -> () - | Method MethInline, Method MethNormal -> - () (* allow to redefine a method as inlined *) - | _ -> - display_error ctx ("Field " ^ i ^ " has different property access than in superclass") p); - try - let t = apply_params csup.cl_types params t in - valid_redefinition ctx f f.cf_type f2 t - with - Unify_error l -> - display_error ctx ("Field " ^ i ^ " overload parent class with different or incomplete type") p; - display_error ctx (error_msg (Unify l)) p; - with - Not_found -> - if List.mem i c.cl_overrides then display_error ctx ("Field " ^ i ^ " is declared 'override' but doesn't override any field") p - ) c.cl_fields - -let class_field_no_interf c i = - try - let f = PMap.find i c.cl_fields in - f.cf_type , f - with Not_found -> - match c.cl_super with - | None -> - raise Not_found - | Some (c,tl) -> - (* rec over class_field *) - let t , f = raw_class_field (fun f -> f.cf_type) c i in - apply_params c.cl_types tl t , f - -let rec check_interface ctx c p intf params = - PMap.iter (fun i f -> - try - let t2, f2 = class_field_no_interf c i in - ignore(follow f2.cf_type); (* force evaluation *) - let p = (match f2.cf_expr with None -> p | Some e -> e.epos) in - if f.cf_public && not f2.cf_public then - display_error ctx ("Field " ^ i ^ " should be public as requested by " ^ s_type_path intf.cl_path) p - else if not (unify_kind f2.cf_kind f.cf_kind) then - display_error ctx ("Field " ^ i ^ " has different property access than in " ^ s_type_path intf.cl_path ^ " (" ^ s_kind f2.cf_kind ^ " should be " ^ s_kind f.cf_kind ^ ")") p - else try - valid_redefinition ctx f2 t2 f (apply_params intf.cl_types params f.cf_type) - with - Unify_error l -> - display_error ctx ("Field " ^ i ^ " has different type than in " ^ s_type_path intf.cl_path) p; - display_error ctx (error_msg (Unify l)) p; - with - Not_found -> - if not c.cl_interface then display_error ctx ("Field " ^ i ^ " needed by " ^ s_type_path intf.cl_path ^ " is missing") p - ) intf.cl_fields; - List.iter (fun (i2,p2) -> - check_interface ctx c p i2 (List.map (apply_params intf.cl_types params) p2) - ) intf.cl_implements - -let check_interfaces ctx c p () = - match c.cl_path with - | "Proxy" :: _ , _ -> () - | _ -> - List.iter (fun (intf,params) -> check_interface ctx c p intf params) c.cl_implements - -let rec return_flow ctx e = - let error() = display_error ctx "A return is missing here" e.epos; raise Exit in - let return_flow = return_flow ctx in - match e.eexpr with - | TReturn _ | TThrow _ -> () - | TParenthesis e -> - return_flow e - | TBlock el -> - let rec loop = function - | [] -> error() - | [e] -> return_flow e - | { eexpr = TReturn _ } :: _ | { eexpr = TThrow _ } :: _ -> () - | _ :: l -> loop l - in - loop el - | TIf (_,e1,Some e2) -> - return_flow e1; - return_flow e2; - | TSwitch (v,cases,Some e) -> - List.iter (fun (_,e) -> return_flow e) cases; - return_flow e - | TSwitch (e,cases,None) when (match follow e.etype with TEnum _ -> true | _ -> false) -> - List.iter (fun (_,e) -> return_flow e) cases; - | TMatch (_,_,cases,def) -> - List.iter (fun (_,_,e) -> return_flow e) cases; - (match def with None -> () | Some e -> return_flow e) - | TTry (e,cases) -> - return_flow e; - List.iter (fun (_,_,e) -> return_flow e) cases; - | _ -> - error() - -(* ---------------------------------------------------------------------- *) -(* PASS 1 & 2 : Module and Class Structure *) - -let set_heritance ctx c herits p = - let process_meta csup = - List.iter (fun m -> - match m with - | ":final", _, _ -> if not (Type.has_meta ":hack" c.cl_meta) then error "Cannot extend a final class" p; - | ":autoBuild", el, p -> c.cl_meta <- (":build",el,p) :: m :: c.cl_meta; - | _ -> () - ) csup.cl_meta - in - let rec loop = function - | HPrivate | HExtern | HInterface -> - () - | HExtends t -> - if c.cl_super <> None then error "Cannot extend several classes" p; - let t = load_instance ctx t p false in - (match follow t with - | TInst ({ cl_path = [],"Array" },_) - | TInst ({ cl_path = [],"String" },_) - | TInst ({ cl_path = [],"Date" },_) - | TInst ({ cl_path = [],"Xml" },_) when ((not (platform ctx.com Cpp)) && (match c.cl_path with "mt" :: _ , _ -> false | _ -> true)) -> - error "Cannot extend basic class" p; - | TInst (csup,params) -> - if is_parent c csup then error "Recursive class" p; - if c.cl_interface then error "Cannot extend an interface" p; - if csup.cl_interface then error "Cannot extend by using an interface" p; - process_meta csup; - c.cl_super <- Some (csup,params) - | _ -> error "Should extend by using a class" p) - | HImplements t -> - let t = load_instance ctx t p false in - (match follow t with - | TInst ({ cl_path = [],"ArrayAccess"; cl_extern = true; },[t]) -> - if c.cl_array_access <> None then error "Duplicate array access" p; - c.cl_array_access <- Some t - | TInst (intf,params) -> - if is_parent c intf then error "Recursive class" p; - process_meta intf; - c.cl_implements <- (intf, params) :: c.cl_implements - | TDynamic t -> - if c.cl_dynamic <> None then error "Cannot have several dynamics" p; - c.cl_dynamic <- Some t - | _ -> error "Should implement by using an interface or a class" p) - in - (* - resolve imports before calling build_inheritance, since it requires full paths. - that means that typedefs are not working, but that's a fair limitation - *) - let rec resolve_imports t = - match t.tpackage with - | _ :: _ -> t - | [] -> - try - let lt = List.find (fun lt -> snd (t_path lt) = t.tname) ctx.local_types in - { t with tpackage = fst (t_path lt) } - with - Not_found -> t - in - let herits = List.map (function - | HExtends t -> HExtends (resolve_imports t) - | HImplements t -> HImplements (resolve_imports t) - | h -> h - ) herits in - List.iter loop (List.filter (ctx.g.do_inherit ctx c p) herits) - -let type_type_params ctx path get_params p (n,flags) = - let c = mk_class (fst path @ [snd path],n) p in - c.cl_kind <- KTypeParameter; - let t = TInst (c,[]) in - match flags with - | [] -> n, t - | _ -> - let r = exc_protect (fun r -> - r := (fun _ -> t); - let ctx = { ctx with type_params = ctx.type_params @ get_params() } in - set_heritance ctx c (List.map (fun t -> HImplements t) flags) p; - t - ) in - delay ctx (fun () -> ignore(!r())); - n, TLazy r - -let type_function ctx args ret static constr f p = - let locals = save_locals ctx in - let fargs = List.map (fun (n,c,t) -> - let c = (match c with - | None -> None - | Some e -> - let p = pos e in - let e = ctx.g.do_optimize ctx (type_expr ctx e true) in - unify ctx e.etype t p; - match e.eexpr with - | TConst c -> Some c - | _ -> display_error ctx "Parameter default value should be constant" p; None - ) in - let n = add_local ctx n t in - n, c, t - ) args in - let old_ret = ctx.ret in - let old_static = ctx.in_static in - let old_constr = ctx.in_constructor in - let old_opened = ctx.opened in - ctx.in_static <- static; - ctx.in_constructor <- constr; - ctx.ret <- ret; - ctx.opened <- []; - let e = type_expr ctx f.f_expr false in - let rec loop e = - match e.eexpr with - | TReturn (Some _) -> raise Exit - | TFunction _ -> () - | _ -> Type.iter loop e - in - let have_ret = (try loop e; false with Exit -> true) in - if have_ret then - (try return_flow ctx e with Exit -> ()) - else - unify ctx ret ctx.t.tvoid p; - let rec loop e = - match e.eexpr with - | TCall ({ eexpr = TConst TSuper },_) -> raise Exit - | TFunction _ -> () - | _ -> Type.iter loop e - in - if constr && (match ctx.curclass.cl_super with None -> false | Some (cl,_) -> cl.cl_constructor <> None) then - (try - loop e; - display_error ctx "Missing super constructor call" p - with - Exit -> ()); - locals(); - List.iter (fun r -> r := Closed) ctx.opened; - ctx.ret <- old_ret; - ctx.in_static <- old_static; - ctx.in_constructor <- old_constr; - ctx.opened <- old_opened; - e , fargs - -let init_core_api ctx c = - let ctx2 = (match ctx.g.core_api with - | None -> - let com2 = Common.clone ctx.com in - Common.define com2 "core_api"; - com2.class_path <- ctx.com.std_path; - let ctx2 = ctx.g.do_create com2 in - ctx.g.core_api <- Some ctx2; - ctx2 - | Some c -> - c - ) in - let t = load_instance ctx2 { tpackage = fst c.cl_path; tname = snd c.cl_path; tparams = []; tsub = None; } c.cl_pos true in - match t with - | TInst (ccore,_) -> - (match c.cl_doc with - | None -> c.cl_doc <- ccore.cl_doc - | Some _ -> ()); - let check_fields fcore fl = - PMap.iter (fun i f -> - if not f.cf_public then () else - let f2 = try PMap.find f.cf_name fl with Not_found -> error ("Missing field " ^ i ^ " required by core type") c.cl_pos in - let p = (match f2.cf_expr with None -> c.cl_pos | Some e -> e.epos) in - (try - type_eq EqCoreType (apply_params ccore.cl_types (List.map snd c.cl_types) f.cf_type) f2.cf_type - with Unify_error l -> - display_error ctx ("Field " ^ i ^ " has different type than in core type") p; - display_error ctx (error_msg (Unify l)) p); - if f2.cf_public <> f.cf_public then error ("Field " ^ i ^ " has different visibility than core type") p; - (match f2.cf_doc with - | None -> f2.cf_doc <- f.cf_doc - | Some _ -> ()); - if f2.cf_kind <> f.cf_kind then begin - match f2.cf_kind, f.cf_kind with - | Method MethInline, Method MethNormal -> () (* allow to add 'inline' *) - | _ -> - error ("Field " ^ i ^ " has different property access than core type") p; - end; - (match follow f.cf_type, follow f2.cf_type with - | TFun (pl1,_), TFun (pl2,_) -> - if List.length pl1 != List.length pl2 then assert false; - List.iter2 (fun (n1,_,_) (n2,_,_) -> - if n1 <> n2 then error ("Method parameter name '" ^ n2 ^ "' should be '" ^ n1 ^ "'") p; - ) pl1 pl2; - | _ -> ()); - ) fcore; - PMap.iter (fun i f -> - let p = (match f.cf_expr with None -> c.cl_pos | Some e -> e.epos) in - if f.cf_public && not (PMap.mem f.cf_name fcore) then error ("Public field " ^ i ^ " is not part of core type") p; - ) fl; - in - check_fields ccore.cl_fields c.cl_fields; - check_fields ccore.cl_statics c.cl_statics; - | _ -> assert false - -let patch_class ctx c fields = - let h = (try Some (Hashtbl.find ctx.g.type_patches c.cl_path) with Not_found -> None) in - match h with - | None -> fields - | Some (h,hcl) -> - c.cl_meta <- c.cl_meta @ hcl.tp_meta; - let rec loop acc = function - | [] -> List.rev acc - | f :: l -> - (* patch arguments types *) - (match f.cff_kind with - | FFun (pl,ff) -> - let param ((n,opt,t,e) as p) = - try n, opt, (Hashtbl.find h (("$" ^ n),false)).tp_type, e with Not_found -> p - in - f.cff_kind <- FFun (pl,{ ff with f_args = List.map param ff.f_args }) - | _ -> ()); - (* other patches *) - match (try Some (Hashtbl.find h (f.cff_name,List.mem AStatic f.cff_access)) with Not_found -> None) with - | None -> loop (f :: acc) l - | Some { tp_remove = true } -> loop acc l - | Some p -> - f.cff_meta <- f.cff_meta @ p.tp_meta; - (match p.tp_type with - | None -> () - | Some t -> - f.cff_kind <- match f.cff_kind with - | FVar (_,e) -> FVar (Some t,e) - | FProp (get,set,_) -> FProp (get,set,t) - | FFun (pl,f) -> FFun (pl,{ f with f_type = Some t })); - loop (f :: acc) l - in - List.rev (loop [] fields) - -let build_module_def ctx meta fbuild = - let rec loop = function - | (":build",args,p) :: l -> - let epath, el = (match args with - | [ECall (epath,el),p] -> epath, el - | _ -> error "Invalid build parameters" p - ) in - let rec getpath (e,p) = - match e with - | EConst (Ident i) | EConst (Type i) -> [i] - | EField (e,f) | EType (e,f) -> f :: getpath e - | _ -> error "Build call parameter must be a class path" p - in - let s = String.concat "." (List.rev (getpath epath)) in - if ctx.in_macro then error "You cannot used :build inside a macro : make sure that your enum is not used in macro" p; - (match apply_macro ctx s el p with - | None -> error "Build failure" p - | Some e -> fbuild e) @ loop l - | _ :: l -> loop l - | [] -> [] - in - loop meta - -let init_class ctx c p herits fields = - let fields = patch_class ctx c fields in - let ctx = { ctx with type_params = c.cl_types } in - c.cl_extern <- List.mem HExtern herits; - c.cl_interface <- List.mem HInterface herits; - set_heritance ctx c herits p; - let fields = fields @ build_module_def { ctx with curclass = c } c.cl_meta (fun (e,p) -> - match e with - | EBlock el -> - List.map (fun (e,p) -> - let n, k = (match e with - | EVars [v,t,e] -> v, FVar (t,e) - | EFunction (Some n,f) -> (if n = "__new__" then "new" else n), FFun ([],f) - | _ -> error "Class build expression should be a single variable or a named function" p - ) in - let accesses = [APublic; APrivate; AStatic; AOverride; ADynamic; AInline] in - let k = ref k in - let rec loop acc l = - match l with - | [] -> error "Missing name" p - | "property" :: get :: set :: l -> - (match !k with - | FVar (Some t,None) -> k := FProp (get,set,t); loop acc l - | _ -> error "Invalid property declaration" p) - | x :: l -> - try - let a = List.find (fun a -> Ast.s_access a = x) accesses in - loop (a :: acc) l - with Not_found -> - String.concat "__" (x :: l), acc - in - let n, access = loop [] (ExtString.String.nsplit n "__") in - { cff_name = n; cff_doc = None; cff_pos = p; cff_meta = []; cff_access = if access = [] then [APublic] else access; cff_kind = !k } - ) el - | _ -> error "Class build macro must return a block" p - ) in - let core_api = has_meta ":core_api" c.cl_meta in - let is_macro = has_meta ":macro" c.cl_meta in - let fields, herits = if is_macro && not ctx.in_macro then begin - c.cl_extern <- true; - List.filter (fun f -> List.mem AStatic f.cff_access) fields, [] - end else fields, herits in - if core_api && not ctx.com.display then delay ctx ((fun() -> init_core_api ctx c)); - let tthis = TInst (c,List.map snd c.cl_types) in - let rec extends_public c = - List.exists (fun (c,_) -> c.cl_path = (["haxe"],"Public") || extends_public c) c.cl_implements || - match c.cl_super with - | None -> false - | Some (c,_) -> extends_public c - in - let extends_public = extends_public c in - let is_public access parent = - if List.mem APrivate access then - false - else if List.mem APublic access then - true - else match parent with - | Some { cf_public = p } -> p - | _ -> c.cl_extern || c.cl_interface || extends_public - in - let rec get_parent c name = - match c.cl_super with - | None -> None - | Some (csup,_) -> - try - Some (PMap.find name csup.cl_fields) - with - Not_found -> get_parent csup name - in - let type_opt ctx p t = - match t with - | None when c.cl_extern || c.cl_interface -> - display_error ctx "Type required for extern classes and interfaces" p; - t_dynamic - | None when core_api -> - display_error ctx "Type required for core api classes" p; - t_dynamic - | _ -> - load_type_opt ctx p t - in - let rec has_field f = function - | None -> false - | Some (c,_) -> - PMap.exists f c.cl_fields || has_field f c.cl_super || List.exists (fun i -> has_field f (Some i)) c.cl_implements - in - - (* ----------------------- DEAD CODE REMOVAL ----------------------------- *) - - let is_main n = (match ctx.com.main_class with | Some cl when c.cl_path = cl -> true | _ -> false) && n = "main" in - let must_keep_types pf = match pf with - | Flash -> [["flash"], "Boot"] - | Flash9 -> [["flash"; "_Boot"], "RealBoot"; ["flash"], "Boot"] - | Js -> [["js"], "Boot"] - | Neko -> [["neko"], "Boot"] - | Php -> [["php"], "Boot"] - | Cpp -> [["cpp"], "Boot"] - | _ -> [] in - let must_keep_class = (List.exists (fun p -> p = c.cl_path) (must_keep_types ctx.com.platform)) in - let keep f stat = core_api || (is_main f.cff_name) || c.cl_extern || must_keep_class || has_meta ":keep" c.cl_meta || has_meta ":keep" f.cff_meta || (stat && f.cff_name = "__init__") in - let remove_by_cfname item lst = List.filter (fun i -> item <> i.cf_name) lst in - let remove_field cf stat = - if stat then begin - c.cl_statics <- PMap.remove cf.cf_name c.cl_statics; - c.cl_ordered_statics <- remove_by_cfname cf.cf_name c.cl_ordered_statics; - end else begin - if cf.cf_name = "new" then c.cl_constructor <- None; - c.cl_fields <- PMap.remove cf.cf_name c.cl_fields; - c.cl_ordered_fields <- remove_by_cfname cf.cf_name c.cl_ordered_fields; - end - in - let remove_method_if_unreferenced cf stat = (fun () -> - match cf.cf_expr with - | None -> - if ctx.com.verbose then print_endline ("Remove method " ^ (s_type_path c.cl_path) ^ "." ^ cf.cf_name); - remove_field cf stat - | _ -> ()) - in - let remove_var_if_unreferenced cf stat = (fun () -> - if not (has_meta ":?keep" cf.cf_meta) then begin - if ctx.com.verbose then print_endline ("Remove var " ^ (s_type_path c.cl_path) ^ "." ^ cf.cf_name); - remove_field cf stat - end) - in - - (* ----------------------- COMPLETION ----------------------------- *) - - let display_file = if ctx.com.display then String.lowercase (Common.get_full_path p.pfile) = String.lowercase (!Parser.resume_display).pfile else false in - let rec is_full_type t = - match t with - | TFun (args,ret) -> is_full_type ret && List.for_all (fun (_,_,t) -> is_full_type t) args - | TMono r -> (match !r with None -> false | Some t -> is_full_type t) - | TInst _ | TEnum _ | TLazy _ | TDynamic _ | TAnon _ | TType _ -> true - in - let bind_type cf r p macro = - if ctx.com.display then begin - let cp = !Parser.resume_display in - if display_file && (cp.pmin = 0 || (p.pmin <= cp.pmin && p.pmax >= cp.pmax)) then begin - if macro && not ctx.in_macro then - (* force macro system loading of this class in order to get completion *) - (fun() -> ignore(ctx.g.do_macro ctx c.cl_path cf.cf_name [] p)) - else begin - cf.cf_type <- TLazy r; - (fun() -> ignore((!r)())) - end - end else begin - if not (is_full_type cf.cf_type) then cf.cf_type <- TLazy r; - (fun() -> ()) - end - end else begin - cf.cf_type <- TLazy r; - (fun () -> ignore(!r())) - end - in - - (* ----------------------- FIELD INIT ----------------------------- *) - - let loop_cf f = - let name = f.cff_name in - let p = f.cff_pos in - let stat = List.mem AStatic f.cff_access in - let inline = List.mem AInline f.cff_access in - match f.cff_kind with - | FVar (t,e) -> - if not stat && has_field name c.cl_super then error ("Redefinition of variable " ^ name ^ " in subclass is not allowed") p; - if inline && not stat then error "Inline variable must be static" p; - if inline && e = None then error "Inline variable must be initialized" p; - let t = (match t with - | None -> - if not stat then display_error ctx ("Type required for member variable " ^ name) p; - mk_mono() - | Some t -> - let old = ctx.type_params in - if stat then ctx.type_params <- []; - let t = load_complex_type ctx p t in - if stat then ctx.type_params <- old; - t - ) in - let cf = { - cf_name = name; - cf_doc = f.cff_doc; - cf_meta = f.cff_meta; - cf_type = t; - cf_kind = Var (if inline then { v_read = AccInline ; v_write = AccNever } else { v_read = AccNormal; v_write = AccNormal }); - cf_expr = None; - cf_public = is_public f.cff_access None; - cf_params = []; - } in - let delay = if (ctx.com.dead_code_elimination && not ctx.com.display) then begin - (match e with - | None -> - let r = exc_protect (fun r -> - r := (fun() -> t); - cf.cf_meta <- if has_meta ":?keep" cf.cf_meta then f.cff_meta else (":?keep", [], p) :: f.cff_meta; - t - ) in - cf.cf_type <- TLazy r; - (fun() -> - if not (keep f stat) then - delay ctx (remove_var_if_unreferenced cf stat) - else - ignore(!r()) - ) - | Some e -> - let ctx = { ctx with curclass = c; tthis = tthis } in - let r = exc_protect (fun r -> - r := (fun() -> t); - if ctx.com.verbose then print_endline ("Typing " ^ s_type_path c.cl_path ^ "." ^ name); - cf.cf_meta <- if has_meta ":?keep" cf.cf_meta then f.cff_meta else (":?keep", [], p) :: f.cff_meta; - cf.cf_expr <- Some (type_static_var ctx t e p); - t - ) in - cf.cf_type <- TLazy r; - (fun () -> - if not (keep f stat) then - delay ctx (remove_var_if_unreferenced cf stat) - else - ignore(!r()) - ) - ) - end else (match e with - | None -> (fun() -> ()) - | Some e -> - let ctx = { ctx with curclass = c; tthis = tthis } in - let r = exc_protect (fun r -> - r := (fun() -> t); - if ctx.com.verbose then print_endline ("Typing " ^ s_type_path c.cl_path ^ "." ^ name); - cf.cf_expr <- Some (type_static_var ctx t e p); - t - ) in - bind_type cf r (snd e) false - ) in - f, false, cf, delay - | FFun (fparams,fd) -> - let params = ref [] in - params := List.map (fun (n,flags) -> - match flags with - | [] -> - type_type_params ctx ([],name) (fun() -> !params) p (n,[]) - | _ -> error "This notation is not allowed because it can't be checked" p - ) fparams; - let params = !params in - if inline && c.cl_interface then error "You can't declare inline methods in interfaces" p; - let is_macro = (is_macro && stat) || has_meta ":macro" f.cff_meta in - if is_macro && not stat then error "Only static methods can be macros" p; - let fd = if not is_macro then - fd - else if ctx.in_macro then - let texpr = CTPath { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None } in - { - f_type = (match fd.f_type with None -> Some texpr | t -> t); - f_args = List.map (fun (a,o,t,e) -> a,o,(match t with None -> Some texpr | _ -> t),e) fd.f_args; - f_expr = fd.f_expr; - } - else - let tdyn = Some (CTPath { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None }) in - { - f_type = tdyn; - f_args = List.map (fun (a,o,_,_) -> a,o,tdyn,None) fd.f_args; - f_expr = (EBlock [],p) - } - in - let parent = (if not stat then get_parent c name else None) in - let dynamic = List.mem ADynamic f.cff_access || (match parent with Some { cf_kind = Method MethDynamic } -> true | _ -> false) in - if inline && dynamic then error "You can't have both 'inline' and 'dynamic'" p; - let ctx = { ctx with - curclass = c; - curmethod = name; - tthis = tthis; - type_params = if stat then params else params @ ctx.type_params; - } in - let ret = type_opt ctx p fd.f_type in - let args = List.map (fun (name,opt,t,c) -> - let t, c = type_function_param ctx (type_opt ctx p t) c opt p in - name, c, t - ) fd.f_args in - let t = TFun (fun_args args,ret) in - let constr = (name = "new") in - if constr && c.cl_interface then error "An interface cannot have a constructor" p; - if c.cl_interface && not stat && (match fd.f_expr with EBlock [] , _ -> false | _ -> true) then error "An interface method cannot have a body" p; - if constr then (match fd.f_type with - | None | Some (CTPath { tpackage = []; tname = "Void" }) -> () - | _ -> error "A class constructor can't have a return value" p - ); - let cf = { - cf_name = name; - cf_doc = f.cff_doc; - cf_meta = f.cff_meta; - cf_type = t; - cf_kind = Method (if is_macro then MethMacro else if inline then MethInline else if dynamic then MethDynamic else MethNormal); - cf_expr = None; - cf_public = is_public f.cff_access parent; - cf_params = params; - } in - let r = exc_protect (fun r -> - r := (fun() -> t); - if ctx.com.verbose then print_endline ("Typing " ^ s_type_path c.cl_path ^ "." ^ name); - let e , fargs = type_function ctx args ret stat constr fd p in - let f = { - tf_args = fargs; - tf_type = ret; - tf_expr = e; - } in - if stat && name = "__init__" then - (match e.eexpr with - | TBlock [] | TBlock [{ eexpr = TConst _ }] | TConst _ | TObjectDecl [] -> () - | _ -> c.cl_init <- Some e); - cf.cf_expr <- Some (mk (TFunction f) t p); - t - ) in - let delay = if (ctx.com.dead_code_elimination && not ctx.com.display) then begin - if ((c.cl_extern && not inline) || c.cl_interface) && cf.cf_name <> "__init__" then begin - (fun() -> ()) - end else begin - cf.cf_type <- TLazy r; - (fun() -> - if not (keep f stat) then begin - delay ctx (remove_method_if_unreferenced cf stat) - end else - ignore((!r)()) - ) - end - end else if ((c.cl_extern && not inline) || c.cl_interface) && cf.cf_name <> "__init__" then - (fun() -> ()) - else - bind_type cf r (snd fd.f_expr) is_macro - in - f, constr, cf, delay - | FProp (get,set,t) -> - let ret = load_complex_type ctx p t in - let check_get = ref (fun() -> ()) in - let check_set = ref (fun() -> ()) in - let check_method m t () = - if ctx.com.display then () else - try - let t2 = (if stat then (PMap.find m c.cl_statics).cf_type else fst (class_field c m)) in - unify_raise ctx t2 t p; - with - | Error (Unify l,_) -> raise (Error (Stack (Custom ("In method " ^ m ^ " required by property " ^ name),Unify l),p)) - | Not_found -> if not (c.cl_interface || c.cl_extern) then display_error ctx ("Method " ^ m ^ " required by property " ^ name ^ " is missing") p - in - let get = (match get with - | "null" -> AccNo - | "dynamic" -> AccCall ("get_" ^ name) - | "never" -> AccNever - | "default" -> AccNormal - | _ -> - check_get := check_method get (TFun ([],ret)); - AccCall get - ) in - let set = (match set with - | "null" -> - (* standard flash library read-only variables can't be accessed for writing, even in subclasses *) - if c.cl_extern && (match c.cl_path with "flash" :: _ , _ -> true | _ -> false) && Common.defined ctx.com "flash9" then - AccNever - else - AccNo - | "never" -> AccNever - | "dynamic" -> AccCall ("set_" ^ name) - | "default" -> AccNormal - | _ -> - check_set := check_method set (TFun (["",false,ret],ret)); - AccCall set - ) in - if set = AccNormal && (match get with AccCall _ -> true | _ -> false) then error "Unsupported property combination" p; - let cf = { - cf_name = name; - cf_doc = f.cff_doc; - cf_meta = f.cff_meta; - cf_kind = Var { v_read = get; v_write = set }; - cf_expr = None; - cf_type = ret; - cf_public = is_public f.cff_access None; - cf_params = []; - } in - f, false, cf, (fun() -> (!check_get)(); (!check_set)()) - in - let rec check_require = function - | [] -> None - | (":require",conds,_) :: l -> - let rec loop = function - | [] -> check_require l - | (EConst (Ident i | Type i),_) :: l -> - if not (Common.defined ctx.com i) then - Some i - else - loop l - | _ -> error "Invalid require identifier" p - in - loop conds - | _ :: l -> - check_require l - in - let cl_req = check_require c.cl_meta in - let fl = List.map (fun f -> - let fd , constr, f , delayed = loop_cf f in - let is_static = List.mem AStatic fd.cff_access in - if is_static && f.cf_name = "name" && Common.defined ctx.com "js" then error "This identifier cannot be used in Javascript for statics" p; - if (is_static || constr) && c.cl_interface && f.cf_name <> "__init__" then error "You can't declare static fields in interfaces" p; - let req = check_require fd.cff_meta in - let req = (match req with None -> if is_static || constr then cl_req else None | _ -> req) in - (match req with - | None -> () - | Some r -> f.cf_kind <- Var { v_read = AccRequire r; v_write = AccRequire r }); - if constr then begin - if c.cl_constructor <> None then error "Duplicate constructor" p; - c.cl_constructor <- Some f; - end else if not is_static || f.cf_name <> "__init__" then begin - if PMap.mem f.cf_name (if is_static then c.cl_statics else c.cl_fields) then error ("Duplicate class field declaration : " ^ f.cf_name) p; - if PMap.exists f.cf_name (if is_static then c.cl_fields else c.cl_statics) then error ("Same field name can't be use for both static and instance : " ^ f.cf_name) p; - if is_static then begin - c.cl_statics <- PMap.add f.cf_name f c.cl_statics; - c.cl_ordered_statics <- f :: c.cl_ordered_statics; - end else begin - c.cl_fields <- PMap.add f.cf_name f c.cl_fields; - c.cl_ordered_fields <- f :: c.cl_ordered_fields; - if List.mem AOverride fd.cff_access then c.cl_overrides <- f.cf_name :: c.cl_overrides; - end; - end; - delayed - ) fields in - c.cl_ordered_statics <- List.rev c.cl_ordered_statics; - c.cl_ordered_fields <- List.rev c.cl_ordered_fields; - (* - define a default inherited constructor. - This is actually pretty tricky since we can't assume that the constructor of the - superclass has been defined yet because type structure is not stabilized wrt recursion. - *) - let rec define_constructor ctx c = - try - Some (Hashtbl.find ctx.g.constructs c.cl_path) - with Not_found -> - match c.cl_super with - | None -> None - | Some (csuper,_) -> - match define_constructor ctx csuper with - | None -> None - | Some (acc,pl,f) as infos -> - let p = c.cl_pos in - let esuper = (ECall ((EConst (Ident "super"),p),List.map (fun (n,_,_,_) -> (EConst (Ident n),p)) f.f_args),p) in - let acc = (if csuper.cl_extern && acc = [] then [APublic] else acc) in - let fnew = { f with f_expr = esuper; f_args = List.map (fun (a,opt,t,def) -> - (* - we are removing the type and letting the type inference - work because the current package is not the same as the superclass one - or there might be private and/or imported types - - if we are an extern class then we need a type - if the type is Dynamic also because it would not propagate - if we have a package declaration, we are sure it's fully qualified - *) - let rec is_qualified = function - | CTPath t -> is_qual_name t - | CTParent t -> is_qualified t - | CTFunction (tl,t) -> List.for_all is_qualified tl && is_qualified t - | CTAnonymous fl -> List.for_all (fun (_,_,f,_) -> is_qual_field f) fl - | CTExtend (t,fl) -> is_qual_name t && List.for_all (fun (_,_,f,_) -> is_qual_field f) fl - and is_qual_field = function - | AFVar t -> is_qualified t - | AFProp (t,_,_) -> is_qualified t - | AFFun (pl,t) -> List.for_all (fun (_,_,t) -> is_qualified t) pl && is_qualified t - and is_qual_name t = - match t.tpackage with - | [] -> t.tname = "Dynamic" && List.for_all is_qual_param t.tparams - | _ :: _ -> true - and is_qual_param = function - | TPType t -> is_qualified t - | TPConst _ -> false (* prevent multiple incompatible types *) - in - let t = (match t with - | Some t when is_qualified t -> Some t - | _ -> None - ) in - a,opt,t,def - ) f.f_args } in - let _, _, cf, delayed = loop_cf { cff_name = "new"; cff_pos = p; cff_doc = None; cff_meta = []; cff_access = acc; cff_kind = FFun (pl,fnew) } in - c.cl_constructor <- Some cf; - Hashtbl.add ctx.g.constructs c.cl_path (acc,pl,f); - delay ctx delayed; - infos - in - (* - extern classes will browse superclass to find a constructor - *) - if not c.cl_extern then ignore(define_constructor ctx c); - fl - -let resolve_typedef ctx t = - match t with - | TClassDecl _ | TEnumDecl _ -> t - | TTypeDecl td -> - match follow td.t_type with - | TEnum (e,_) -> TEnumDecl e - | TInst (c,_) -> TClassDecl c - | _ -> t - -let type_module ctx m tdecls loadp = - (* PASS 1 : build module structure - does not load any module or type - should be atomic ! *) - let decls = ref [] in - let decl_with_name name p priv = - let tpath = if priv then (fst m @ ["_" ^ snd m], name) else (fst m, name) in - if priv && List.exists (fun t -> tpath = t_path t) (!decls) then error ("Type name " ^ name ^ " is already defined in this module") p; - try - let m2 = Hashtbl.find ctx.g.types_module tpath in - if m <> m2 && String.lowercase (s_type_path m2) = String.lowercase (s_type_path m) then error ("Module " ^ s_type_path m2 ^ " is loaded with a different case than " ^ s_type_path m) loadp; - error ("Type name " ^ s_type_path tpath ^ " is redefined from module " ^ s_type_path m2) p - with - Not_found -> - Hashtbl.add ctx.g.types_module tpath m; - tpath - in - List.iter (fun (d,p) -> - match d with - | EImport _ | EUsing _ -> () - | EClass d -> - let priv = List.mem HPrivate d.d_flags in - let path = decl_with_name d.d_name p priv in - let c = mk_class path p in - c.cl_private <- priv; - c.cl_doc <- d.d_doc; - c.cl_meta <- d.d_meta; - (* store the constructor for later usage *) - List.iter (fun cf -> - match cf with - | { cff_name = "new"; cff_kind = FFun (pl,f) } -> Hashtbl.add ctx.g.constructs path (cf.cff_access,pl,f) - | _ -> () - ) d.d_data; - decls := TClassDecl c :: !decls - | EEnum d -> - let priv = List.mem EPrivate d.d_flags in - let path = decl_with_name d.d_name p priv in - let e = { - e_path = path; - e_pos = p; - e_doc = d.d_doc; - e_meta = d.d_meta; - e_types = []; - e_private = priv; - e_extern = List.mem EExtern d.d_flags; - e_constrs = PMap.empty; - e_names = []; - } in - decls := TEnumDecl e :: !decls - | ETypedef d -> - let priv = List.mem EPrivate d.d_flags in - let path = decl_with_name d.d_name p priv in - let t = { - t_path = path; - t_pos = p; - t_doc = d.d_doc; - t_private = priv; - t_types = []; - t_type = mk_mono(); - t_meta = d.d_meta; - } in - decls := TTypeDecl t :: !decls - ) tdecls; - let m = { - mpath = m; - mtypes = List.rev !decls; - } in - Hashtbl.add ctx.g.modules m.mpath m; - (* PASS 2 : build types structure - does not type any expression ! *) - let ctx = { - com = ctx.com; - g = ctx.g; - t = ctx.t; - curclass = ctx.curclass; - tthis = ctx.tthis; - ret = ctx.ret; - current = m; - locals = PMap.empty; - locals_map = PMap.empty; - locals_map_inv = PMap.empty; - local_types = ctx.g.std.mtypes @ m.mtypes; - local_using = []; - type_params = []; - curmethod = ""; - untyped = false; - in_super_call = false; - in_constructor = false; - in_static = false; - in_macro = ctx.in_macro; - in_display = false; - in_loop = false; - opened = []; - param_type = None; - } in - let delays = ref [] in - let get_class name = - let c = List.find (fun d -> match d with TClassDecl { cl_path = _ , n } -> n = name | _ -> false) m.mtypes in - match c with TClassDecl c -> c | _ -> assert false - in - let get_enum name = - let e = List.find (fun d -> match d with TEnumDecl { e_path = _ , n } -> n = name | _ -> false) m.mtypes in - match e with TEnumDecl e -> e | _ -> assert false - in - let get_tdef name = - let s = List.find (fun d -> match d with TTypeDecl { t_path = _ , n } -> n = name | _ -> false) m.mtypes in - match s with TTypeDecl s -> s | _ -> assert false - in - (* here is an additional PASS 1 phase, which handle the type parameters declaration, with lazy contraints *) - List.iter (fun (d,p) -> - match d with - | EImport _ | EUsing _ -> () - | EClass d -> - let c = get_class d.d_name in - c.cl_types <- List.map (type_type_params ctx c.cl_path (fun() -> c.cl_types) p) d.d_params; - | EEnum d -> - let e = get_enum d.d_name in - e.e_types <- List.map (type_type_params ctx e.e_path (fun() -> e.e_types) p) d.d_params; - | ETypedef d -> - let t = get_tdef d.d_name in - t.t_types <- List.map (type_type_params ctx t.t_path (fun() -> t.t_types) p) d.d_params; - ) tdecls; - (* back to PASS2 *) - List.iter (fun (d,p) -> - match d with - | EImport t -> - (match t.tsub with - | None -> - let md = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in - let types = List.filter (fun t -> not (t_private t)) md.mtypes in - ctx.local_types <- ctx.local_types @ types - | Some _ -> - let t = load_type_def ctx p t in - ctx.local_types <- ctx.local_types @ [t] - ) - | EUsing t -> - (match t.tsub with - | None -> - let md = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in - let types = List.filter (fun t -> not (t_private t)) md.mtypes in - ctx.local_using <- ctx.local_using @ (List.map (resolve_typedef ctx) types); - | Some _ -> - let t = load_type_def ctx p t in - ctx.local_using<- ctx.local_using @ [resolve_typedef ctx t]) - | EClass d -> - let c = get_class d.d_name in - let checks = if not ctx.com.display then [check_overriding ctx c p; check_interfaces ctx c p] else [] in - delays := !delays @ (checks @ init_class ctx c p d.d_flags d.d_data) - | EEnum d -> - let e = get_enum d.d_name in - let ctx = { ctx with type_params = e.e_types } in - let et = TEnum (e,List.map snd e.e_types) in - let names = ref [] in - let index = ref 0 in - let extra = build_module_def ctx e.e_meta (fun (e,p) -> - match e with - | EArrayDecl el | EBlock el -> - List.map (fun (e,p) -> - match e with - | EConst (Ident i) | EConst (Type i) | EConst (String i) -> i, None, [], [], p - | EFunction (Some name,f) -> name, None, [], (List.map (fun (n,o,t,_) -> n,o,(match t with None -> error "Missing function parameter type" p | Some t -> t)) f.f_args), p - | _ -> error "Enum build expression should be a single identifier or a named function" p - ) el - | _ -> error "Enum build macro must return an block" p - ) in - List.iter (fun (c,doc,meta,t,p) -> - if c = "name" && Common.defined ctx.com "js" then error "This identifier cannot be used in Javascript" p; - let t = (match t with - | [] -> et - | l -> - let pnames = ref PMap.empty in - TFun (List.map (fun (s,opt,t) -> - if PMap.mem s (!pnames) then error ("Duplicate parameter '" ^ s ^ "' in enum constructor " ^ c) p; - pnames := PMap.add s () (!pnames); - s, opt, load_type_opt ~opt ctx p (Some t) - ) l, et) - ) in - if PMap.mem c e.e_constrs then error ("Duplicate constructor " ^ c) p; - e.e_constrs <- PMap.add c { - ef_name = c; - ef_type = t; - ef_pos = p; - ef_doc = doc; - ef_index = !index; - ef_meta = meta; - } e.e_constrs; - incr index; - names := c :: !names; - ) (d.d_data @ extra); - e.e_names <- List.rev !names; - e.e_extern <- e.e_extern || e.e_names = []; - | ETypedef d -> - let t = get_tdef d.d_name in - let ctx = { ctx with type_params = t.t_types } in - let tt = load_complex_type ctx p d.d_data in - if t.t_type == follow tt then error "Recursive typedef is not allowed" p; - (match t.t_type with - | TMono r -> - (match !r with - | None -> r := Some tt; - | Some _ -> assert false); - | _ -> assert false); - ) tdecls; - (* PASS 3 : type checking, delayed until all modules and types are built *) - List.iter (delay ctx) (List.rev (!delays)); - m - -let parse_module ctx m p = - let remap = ref (fst m) in - let file = (match m with - | [] , name -> name - | x :: l , name -> - let x = (try - match PMap.find x ctx.com.package_rules with - | Forbidden -> raise (Error (Forbid_package (x,m),p)); - | Directory d -> d - | Remap d -> remap := d :: l; d - with Not_found -> x - ) in - String.concat "/" (x :: l) ^ "/" ^ name - ) ^ ".hx" in - let file = Common.find_file ctx.com file in - let ch = (try open_in_bin file with _ -> error ("Could not open " ^ file) p) in - let t = Common.timer "parsing" in - Lexer.init file; - let pack , decls = (try Parser.parse ctx.com (Lexing.from_channel ch) with e -> close_in ch; t(); raise e) in - t(); - close_in ch; - if ctx.com.verbose then print_endline ("Parsed " ^ file); - if pack <> !remap then begin - let spack m = if m = [] then "" else String.concat "." m in - if p == Ast.null_pos then - error ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p - else - error ("Invalid package : " ^ spack (fst m) ^ " should be " ^ spack pack) p - end; - if !remap <> fst m then - (* build typedefs to redirect to real package *) - List.rev (List.fold_left (fun acc (t,p) -> - let build f d = - let priv = List.mem f d.d_flags in - (ETypedef { - d_name = d.d_name; - d_doc = None; - d_meta = []; - d_params = d.d_params; - d_flags = if priv then [EPrivate] else []; - d_data = CTPath (if priv then { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None; } else - { - tpackage = !remap; - tname = d.d_name; - tparams = List.map (fun (s,_) -> - TPType (CTPath { tpackage = []; tname = s; tparams = []; tsub = None; }) - ) d.d_params; - tsub = None; - }); - },p) :: acc - in - match t with - | EClass d -> build HPrivate d - | EEnum d -> build EPrivate d - | ETypedef d -> build EPrivate d - | EImport _ | EUsing _ -> acc - ) [(EImport { tpackage = !remap; tname = snd m; tparams = []; tsub = None; },null_pos)] decls) - else - decls - -let load_module ctx m p = - try - Hashtbl.find ctx.g.modules m - with - Not_found -> - let decls = (try - parse_module ctx m p - with Not_found -> - let rec loop = function - | [] -> raise (Error (Module_not_found m,p)) - | load :: l -> - match load m p with - | None -> loop l - | Some (_,a) -> a - in - loop ctx.com.load_extern_type - ) in - type_module ctx m decls p diff --git a/haxe/typer.ml b/haxe/typer.ml deleted file mode 100644 index 5e688e4e32d951926cd7c444ce35b01c78462ad4..0000000000000000000000000000000000000000 --- a/haxe/typer.ml +++ /dev/null @@ -1,2224 +0,0 @@ -(* - * Haxe Compiler - * Copyright (c)2005-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 Ast -open Type -open Common -open Typecore - -(* ---------------------------------------------------------------------- *) -(* TOOLS *) - -type switch_mode = - | CMatch of (tenum_field * (string option * t) list option * pos) - | CExpr of texpr - -type access_mode = - | MGet - | MSet - | MCall - -exception Display of t - -type access_kind = - | AKNo of string - | AKExpr of texpr - | AKSet of texpr * string * t * string - | AKInline of texpr * tclass_field * t - | AKMacro of texpr * tclass_field - | AKUsing of texpr * texpr - -let mk_infos ctx p params = - let file = if ctx.in_macro then 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.curmethod = "" then - params - else - ("methodName", (EConst (String ctx.curmethod),p)) :: params - ) ,p) - -let check_locals_masking ctx e = - let path = (match e.eexpr with - | TEnumField (e,_) - | TTypeExpr (TEnumDecl e) -> - Some e.e_path - | TTypeExpr (TClassDecl c) -> - Some c.cl_path - | _ -> None - ) in - match path with - | Some ([],name) | Some (name::_,_) when PMap.mem name ctx.locals -> - error ("Local variable '" ^ name ^ "' is preventing usage of this type here") e.epos; - | _ -> () - -let check_assign ctx e = - match e.eexpr with - | TLocal _ | TArray _ | TField _ -> - () - | TTypeExpr _ when ctx.untyped -> - () - | _ -> - error "Invalid assign" e.epos - -type type_class = - | KInt - | KFloat - | KString - | KUnk - | KDyn - | KOther - | KParam of t - -let classify t = - match follow t with - | TInst ({ cl_path = ([],"Int") },[]) -> KInt - | TInst ({ cl_path = ([],"Float") },[]) -> KFloat - | TInst ({ cl_path = ([],"String") },[]) -> KString - | TInst ({ cl_kind = KTypeParameter; cl_implements = [{ cl_path = ([],"Float")},[]] },[]) -> KParam t - | TInst ({ cl_kind = KTypeParameter; cl_implements = [{ cl_path = ([],"Int")},[]] },[]) -> KParam t - | TMono r when !r = None -> KUnk - | TDynamic _ -> KDyn - | _ -> KOther - -let type_field_rec = ref (fun _ _ _ _ _ -> assert false) - -(* ---------------------------------------------------------------------- *) -(* PASS 3 : type expression & check structure *) - -let type_expr_with_type ctx e t = - match e with - | (EFunction _,_) -> - let old = ctx.param_type in - (try - ctx.param_type <- t; - let e = type_expr ctx e true in - ctx.param_type <- old; - e - with - exc -> - ctx.param_type <- old; - raise exc) - | _ -> - type_expr ctx e true - -let unify_call_params ctx name el args p inline = - let error txt = - let format_arg = (fun (name,opt,_) -> (if opt then "?" else "") ^ name) in - let argstr = "Function " ^ (match name with None -> "" | Some n -> "'" ^ n ^ "' ") ^ "requires " ^ (if args = [] then "no arguments" else "arguments : " ^ String.concat ", " (List.map format_arg args)) in - display_error ctx (txt ^ " arguments\n" ^ argstr) p - in - let arg_error ul name opt p = - 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 -> List.map fst l - in - let rec default_value t = - 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 - in - if is_pos_infos t then - let infos = mk_infos ctx p [] in - let e = type_expr ctx infos true in - (e, true) - else - (null t p, true) - in - let rec loop acc l l2 skip = - match l , l2 with - | [] , [] -> - if not (inline && ctx.g.doinline) && (match ctx.com.platform with Flash | Flash9 | Js -> true | _ -> false) then - List.rev (no_opt acc) - else - List.rev (List.map fst acc) - | [] , (_,false,_) :: _ -> - error "Not enough"; - [] - | [] , (name,true,t) :: l -> - loop (default_value t :: acc) [] l skip - | _ , [] -> - (match List.rev skip with - | [] -> error "Too many" - | [name,ul] -> arg_error ul name true p - | _ -> error "Invalid"); - [] - | ee :: l, (name,opt,t) :: l2 -> - let e = type_expr_with_type ctx ee (Some t) in - try - unify_raise ctx e.etype t e.epos; - loop ((e,false) :: acc) l l2 skip - with - Error (Unify ul,_) -> - if opt then - loop (default_value t :: acc) (ee :: l) l2 ((name,ul) :: skip) - else - arg_error ul name false e.epos - in - loop [] el args [] - -let type_local ctx i p = - (* local lookup *) - let t = PMap.find i ctx.locals in - let i = (try PMap.find i ctx.locals_map with Not_found -> i) in - mk (TLocal i) t p - -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_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 - let e = mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p in - check_locals_masking ctx e; - e - | 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_doc = None; - cf_meta = no_meta; - cf_expr = None; - cf_params = []; - } acc - ) e.e_constrs PMap.empty in - let t_tmp = { - t_path = fst e.e_path, "#" ^ snd e.e_path; - 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 - let e = mk (TTypeExpr (TEnumDecl e)) (TType (t_tmp,types)) p in - check_locals_masking ctx e; - e - | 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 - | _ -> - error (s_type_path s.t_path ^ " is not a value") 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 c p = - let rec loop c = - match c.cl_constructor with - | Some f -> f - | None -> - if not c.cl_extern then raise Not_found; - match c.cl_super with - | None -> raise Not_found - | Some (csup,[]) -> loop csup - | Some (_,_) -> error (s_type_path c.cl_path ^ " must define its own constructor") p - in - try - loop c - with Not_found -> - error (s_type_path c.cl_path ^ " does not have a constructor") p - -let make_call ctx e params t p = - try - let ethis, fname = (match e.eexpr with TField (ethis,fname) -> ethis, fname | _ -> raise Exit) in - let f, cl = (match follow ethis.etype with - | TInst (c,params) -> snd (try class_field c fname 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 ctx.com.display || f.cf_kind <> Method MethInline then raise Exit; - if not ctx.g.doinline then (match cl with Some { cl_extern = true } -> () | _ -> raise Exit); - 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 p with - | None -> raise Exit - | Some e -> e) - | _ -> - error "Recursive inline is not supported" p) - 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 _ -> 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 ecall = make_call ctx et (List.map (fun (n,_,t) -> mk (TLocal n) t p) (("_e",false,e.etype) :: args)) ret p in - let ecallb = mk (TFunction { - tf_args = List.map (fun (n,_,t) -> n,None,t) args; - tf_type = ret; - tf_expr = mk (TReturn (Some ecall)) t_dynamic p; - }) tcallb p in - let ewrap = mk (TFunction { - tf_args = [("_e",None,e.etype)]; - 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,t) -> - ignore(follow f.cf_type); (* force computing *) - (match f.cf_expr with - | None -> - if ctx.com.display then - mk (TClosure (e,f.cf_name)) t p - else - error "Recursive inline is not supported" p - | Some { eexpr = TFunction _ } -> - let chk_class c = if c.cl_extern then error "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 (TClosure (e,f.cf_name)) 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 = 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 require " ^ r) p - -let field_access ctx mode f t e p = - let fnormal() = AKExpr (mk (TField (e,f.cf_name)) t p) in - let normal() = - match follow e.etype with - | TAnon a -> (match !(a.a_status) with EnumStatics e -> AKExpr (mk (TEnumField (e,f.cf_name)) 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 - | MethInline, _ -> AKInline (e,f,t) - | MethMacro, MGet -> error "Macro functions must be called immediatly" p - | MethMacro, MCall -> AKMacro (e,f) - | _ , MGet -> AKExpr (mk (TClosure (e,f.cf_name)) 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 -> normal() - | TAnon a -> - (match !(a.a_status) with - | Statics c2 when ctx.curclass == c2 -> 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 (TClosure (e,f.cf_name)) t p) - else - normal() - | AccCall m -> - if m = ctx.curmethod && (match e.eexpr with TConst TThis -> true | TTypeExpr (TClassDecl c) when c == ctx.curclass -> true | _ -> false) then - let prefix = (match ctx.com.platform with Flash9 when Common.defined ctx.com "as3" -> "$" | _ -> "") in - AKExpr (mk (TField (e,prefix ^ f.cf_name)) t p) - else if mode = MSet then - AKSet (e,m,t,f.cf_name) - else - AKExpr (make_call ctx (mk (TField (e,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,"resolve")) tresolve p) [fstring] t p) - | AccNever -> - AKNo f.cf_name - | AccInline -> - AKInline (e,f,t) - | AccRequire r -> - error_require r p - -let using_field ctx mode e i p = - if mode = MSet then raise Not_found; - let rec loop = function - | [] -> - raise Not_found - | TEnumDecl _ :: l | TTypeDecl _ :: l -> - loop l - | TClassDecl c :: l -> - try - let f = PMap.find i c.cl_statics in - let t = field_type f in - (match follow t with - | TFun ((_,_,t0) :: args,r) -> - (try unify_raise ctx e.etype t0 p with Error (Unify _,_) -> raise Not_found); - if follow e.etype == t_dynamic && follow t0 != t_dynamic then raise Not_found; - let et = type_module_type ctx (TClassDecl c) None p in - AKUsing (mk (TField (et,i)) t p,e) - | _ -> raise Not_found) - with Not_found -> - loop l - in - loop ctx.local_using - -let type_ident ctx i is_type 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" -> - if not ctx.untyped && ctx.in_static then error "Cannot access this from a static function" p; - if mode = MGet then - AKExpr (mk (TConst TThis) ctx.tthis 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 - if ctx.in_static then error "Cannot access super from a static function" p; - if mode = MSet || not ctx.in_super_call then - AKNo i - else begin - ctx.in_super_call <- false; - AKExpr (mk (TConst TSuper) t p) - end - | "null" -> - if mode = MGet then - AKExpr (null (mk_mono()) p) - else - AKNo i - | _ -> - try - let e = type_local ctx i p in - AKExpr e - with Not_found -> try - (* member variable lookup *) - if ctx.in_static then raise Not_found; - let t , f = class_field ctx.curclass i in - field_access ctx mode f t (mk (TConst TThis) ctx.tthis p) p - with Not_found -> try - if ctx.in_static then raise Not_found; - using_field ctx mode (mk (TConst TThis) ctx.tthis p) i p - 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 (field_type f) e p - with Not_found -> try - (* lookup imported *) - let rec loop l = - match l with - | [] -> raise Not_found - | t :: l -> - match t with - | TClassDecl _ -> - 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 - mk (TEnumField (e,i)) (monomorphs e.e_types ef.ef_type) p - with - Not_found -> loop l - in - let e = loop ctx.local_types in - check_locals_masking ctx e; - if mode = MSet then - AKNo i - else - AKExpr e - with Not_found -> try - (* lookup type *) - if not is_type 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 - AKExpr (mk (TLocal i) (mk_mono()) p) - else begin - if ctx.in_static && PMap.mem i ctx.curclass.cl_fields then error ("Cannot access " ^ i ^ " in static function") p; - raise (Error (Unknown_ident i,p)) - end - -let rec type_field ctx e i p mode = - let no_field() = - if not ctx.untyped then display_error ctx (s_type (print_context()) e.etype ^ " has no field " ^ i) p; - AKExpr (mk (TField (e,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 - AKExpr (make_call ctx (mk (TField (e,"resolve")) (tfun [ctx.t.tstring] t) p) [Codegen.type_constant ctx.com (String i) p] t p) - else - AKExpr (mk (TField (e,i)) t p) - | None -> - match c.cl_super with - | None -> raise Not_found - | Some (c,params) -> loop_dyn c params - in - (try - let t , f = class_field c i in - if e.eexpr = TConst TSuper && (match f.cf_kind with Var _ -> true | _ -> false) && Common.platform ctx.com Flash9 then error "Cannot access superclass variable for calling : needs to be a proper method" p; - if not f.cf_public && not (is_parent c ctx.curclass) && not ctx.untyped then display_error ctx ("Cannot access to private field " ^ i) p; - field_access ctx mode 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; - no_field()) - | TDynamic t -> - (try - using_field ctx mode e i p - with Not_found -> - AKExpr (mk (TField (e,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 is_parent c ctx.curclass -> () - | _ -> display_error ctx ("Cannot access to private field " ^ i) p - end; - field_access ctx mode f (field_type f) 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_kind = Var { v_read = AccNormal; v_write = (match mode with MSet -> AccNormal | MGet | MCall -> AccNo) }; - cf_expr = None; - cf_params = []; - } in - a.a_fields <- PMap.add i f a.a_fields; - field_access ctx mode f (field_type f) e p - ) - | TMono r -> - if ctx.untyped && (match ctx.com.platform with Flash -> Common.defined ctx.com "swf-mark" | _ -> 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_kind = Var { v_read = AccNormal; v_write = (match mode with MSet -> AccNormal | MGet | MCall -> AccNo) }; - cf_expr = None; - cf_params = []; - } 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 (field_type f) e p - | _ -> - try using_field ctx mode e i p with Not_found -> no_field() - -(* - 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 -> true) - | _ -> true - in - let is_dynamic_return t = - match follow t with - | TFun (_,r) -> is_dynamic r - | _ -> true - in - let maybe_dynamic_mono() = - match e.eexpr with - | TLocal _ when not (is_dynamic e.etype) -> false - | TArray({ etype = t },_) when not (is_dynamic_array t) -> false - | TField({ etype = t },f) when not (is_dynamic_field t f) -> false - | TCall({ etype = t },_) when not (is_dynamic_return t) -> false - | _ -> true - in - match k with - | KUnk | KDyn when maybe_dynamic_mono() -> - unify ctx e.etype ctx.t.tfloat e.epos; - false - | _ -> - unify ctx e.etype ctx.t.tint e.epos; - true - -let rec type_binop ctx op e1 e2 p = - match op with - | OpAssign -> - let e1 = type_access ctx (fst e1) (snd e1) MSet in - let e2 = type_expr_with_type ctx e2 (match e1 with AKNo _ | AKInline _ | AKUsing _ | AKMacro _ -> None | AKExpr e | AKSet(e,_,_,_) -> Some e.etype) 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 - | TField ({ eexpr = TConst TThis },i1) , TField ({ eexpr = TConst TThis },i2) when i1 = i2 -> - error "Assigning a value to itself" p - | _ , _ -> ()); - mk (TBinop (op,e1,e2)) e1.etype p - | AKSet (e,m,t,_) -> - unify ctx e2.etype t p; - make_call ctx (mk (TField (e,m)) (tfun [t] t) p) [e2] t p - | AKInline _ | AKUsing _ | 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 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; - | _ -> - assert false) - | AKSet (e,m,t,f) -> - 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),p),f),p) e2 p in - unify ctx get.etype t p; - l(); - mk (TBlock [ - mk (TVars [v,e.etype,Some e]) ctx.t.tvoid p; - make_call ctx (mk (TField (ev,m)) (tfun [t] t) p) [get] t p - ]) t p - | AKInline _ | AKUsing _ | AKMacro _ -> - assert false) - | _ -> - let e1 = type_expr ctx e1 in - let e2 = type_expr ctx e2 in - let tint = ctx.t.tint in - let tfloat = ctx.t.tfloat in - let mk_op t = mk (TBinop (op,e1,e2)) t p in - match op with - | OpAdd -> - mk_op (match classify e1.etype, classify e2.etype with - | KInt , KInt -> - 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 - | _ , KDyn -> - e2.etype - | KString , _ - | 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 t1 == t2 -> - t1 - | KParam t, KInt | KInt, KParam t -> - t - | KParam _, KFloat | KFloat, KParam _ | KParam _, KParam _ -> - tfloat - | 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 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 - 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 -> () - | 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 "IntIter" 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 - | OpAssign - | OpAssignOp _ -> - assert false - -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 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 - 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 _ -> - error "This kind of operation is not supported" p - | AKSet (e,m,t,f) -> - 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),p),f),p) in - match flag with - | Prefix -> - let get = type_binop ctx op eget one p in - unify ctx get.etype t p; - l(); - mk (TBlock [ - mk (TVars [v,e.etype,Some e]) ctx.t.tvoid p; - make_call ctx (mk (TField (ev,m)) (tfun [t] t) p) [get] t p - ]) t p - | Postfix -> - let v2 = gen_local ctx t in - let ev2 = mk (TLocal v2) t p in - let get = type_expr ctx eget in - let plusone = type_binop ctx op (EConst (Ident v2),p) one p in - unify ctx get.etype t p; - l(); - mk (TBlock [ - mk (TVars [v,e.etype,Some e; v2,t,Some get]) ctx.t.tvoid p; - make_call ctx (mk (TField (ev,m)) (tfun [plusone.etype] t) p) [plusone] t p; - ev2 - ]) t p - -and type_switch ctx e cases def need_val p = - let eval = type_expr ctx e in - let old = ctx.local_types in - let enum = ref None in - let used_cases = Hashtbl.create 0 in - let is_fake_enum e = - e.e_path = ([],"Bool") || 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)); - ctx.local_types <- TEnumDecl e :: ctx.local_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 pl = (match cst.ef_type with - | TFun (l,_) -> - 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) -> p, apply_params en.e_types params t) pl l) - | TEnum _ -> - if pl <> [] then error "This constructor does not require any argument" p; - None - | _ -> assert false - ) in - CMatch (cst,pl,p) - in - let type_case efull e pl p = - try - (match !enum, e with - | None, _ -> raise Exit - | Some (Some (en,params)), (EConst (Ident i | Type i),p) -> - if not (PMap.mem i en.e_constrs) then error ("This constructor is not part of the enum " ^ s_type_path en.e_path) p; - | _ -> ()); - let pl = List.map (fun e -> - match fst e with - | EConst (Ident "_") -> None - | EConst (Ident i | Type i) -> Some i - | _ -> raise Exit - ) pl in - let e = type_expr ctx e in - (match e.eexpr with - | TEnumField (en,s) | TClosure ({ eexpr = TTypeExpr (TEnumDecl en) },s) -> type_match e en s pl - | _ -> if pl = [] then case_expr e else raise Exit) - with Exit -> - case_expr (type_expr ctx efull) - in - let cases = List.map (fun (el,e2) -> - if el = [] then error "Case must match at least one expression" (pos e2); - 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.local_types <- old; - let t = ref (mk_mono()) in - let type_case_code e = - let e = (match e with - | (EBlock [],p) when need_val -> (EConst (Ident "null"),p) - | _ -> e - ) in - let e = type_expr ~need_val ctx e in - if need_val then begin - try - (match e.eexpr with - | TBlock [{ eexpr = TConst TNull }] -> t := ctx.t.tnull !t; - | _ -> ()); - unify_raise ctx e.etype (!t) e.epos; - if is_null e.etype then t := ctx.t.tnull !t; - with Error (Unify _,_) -> try - unify_raise ctx (!t) e.etype e.epos; - t := if is_null !t then ctx.t.tnull e.etype else e.etype; - with Error (Unify _,_) -> - (* will display the error *) - unify ctx e.etype (!t) e.epos; - end; - 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 - | (n,_) :: l , [] | [] , (n,_) :: l -> n = None && loop (l,[]) - | (n1,t1) :: l1, (n2,t2) :: l2 -> - n1 = n2 && (n1 = None || type_iseq t1 t2) && loop (l1,l2) - 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 -> - Some (List.map (fun (p,t) -> - match p with - | None -> None, t - | Some v -> Some (add_local ctx v t), t - ) l) - ) 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 - (match def with - | Some _ -> () - | None -> - let l = PMap.fold (fun c acc -> - if Hashtbl.mem used_cases c.ef_name 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 - ); - 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 - mk (TSwitch (eval,cases,def)) (!t) p - -and type_ident_noerr ctx s t p mode = - try - type_ident ctx s t p mode - with Error (Unknown_ident _ as e,p) when not ctx.in_display -> - display_error ctx (error_msg e) p; - AKExpr (mk (TConst TNull) t_dynamic p) - -and type_access ctx e p mode = - match e with - | EConst (Ident s) -> - type_ident_noerr ctx s false p mode - | EConst (Type s) -> - type_ident_noerr ctx s true p mode - | EField _ - | EType _ -> - 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 (if flag then Type name else 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 - 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 - | [] -> assert false - | (name,_,p) :: pnext -> - try - fields pnext (fun _ -> AKExpr (type_local ctx name p)) - with - Not_found -> loop [] path - in - let rec loop acc e = - match fst e with - | EField (e,s) -> - loop ((s,false,p) :: acc) e - | EType (e,s) -> - loop ((s,true,p) :: acc) e - | EConst (Ident i) -> - type_path ((i,false,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 in - let e2 = type_expr ctx e2 in - 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 - | _ -> - let pt = mk_mono() in - let t = ctx.t.tarray pt in - unify ctx e1.etype t e1.epos; - pt - in - let pt = loop e1.etype in - AKExpr (mk (TArray (e1,e2)) pt p) - | _ -> - AKExpr (type_expr ctx (e,p)) - -and type_expr ctx ?(need_val=true) (e,p) = - match e with - | EField ((EConst (String s),p),"code") -> - if UTF8.length s <> 1 then error "String must be a single UTF8 char" p; - mk (TConst (TInt (Int32.of_int (UChar.code (UTF8.get s 0))))) ctx.t.tint p - | EField _ - | EType _ - | EArray _ - | EConst (Ident _) - | EConst (Type _) -> - 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 c -> - Codegen.type_constant ctx.com c p - | EBinop (op,e1,e2) -> - type_binop ctx op e1 e2 p - | EBlock [] when need_val -> - type_expr ctx (EObjectDecl [],p) - | EBlock l -> - let locals = save_locals ctx in - let rec loop = function - | [] -> [] - | [e] -> - (try - [type_expr ctx ~need_val e] - with - Error (e,p) -> display_error ctx (error_msg e) p; []) - | e :: l -> - try - let e = type_expr ctx ~need_val:false e 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 ~need_val e in - mk (TParenthesis e) e.etype p - | EObjectDecl fl -> - let rec loop (l,acc) (f,e) = - if PMap.mem f acc then error ("Duplicate field in object declaration : " ^ f) p; - let e = type_expr ctx e in - let cf = mk_field f e.etype in - ((f,e) :: l, PMap.add f cf 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 - | EArrayDecl el -> - let t = ref (mk_mono()) in - let is_null = ref false in - let el = List.map (fun e -> - let e = type_expr ctx e in - (match e.eexpr with - | TConst TNull when not !is_null -> - is_null := true; - t := ctx.t.tnull !t; - | _ -> ()); - (try - unify_raise ctx e.etype (!t) e.epos; - with Error (Unify _,_) -> try - unify_raise ctx (!t) e.etype e.epos; - t := e.etype; - with Error (Unify _,_) -> - t := t_dynamic); - e - ) el in - mk (TArrayDecl el) (ctx.t.tarray !t) p - | EVars vl -> - 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_with_type ctx e (Some t) in - unify ctx e.etype t p; - Some e - ) in - let v = add_local ctx v t in - v , t , e - with - Error (e,p) -> - display_error ctx (error_msg e) p; - let t = t_dynamic in - let v = add_local ctx v t in - v , t, None - ) vl in - mk (TVars vl) ctx.t.tvoid p - | EFor (i,e1,e2) -> - let e1 = type_expr ctx e1 in - let old_loop = ctx.in_loop in - 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 _ -> - error "You can't iterate on a Dynamic value, please specify Iterator or Iterable" e1.epos; - | 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 TClosure (e,f) -> { acc with eexpr = TField (e,f) } | _ -> acc) in - match follow acc.etype with - | TFun ([],it) -> - unify ctx it t e1.epos; - make_call ctx acc [] t e1.epos - | _ -> - error "The field iterator is not a method" e1.epos - ) - ) in - let e2 = type_expr ~need_val:false ctx e2 in - mk (TFor (i,pt,e1,e2)) ctx.t.tvoid p - ) in - ctx.in_loop <- old_loop; - old_locals(); - e - | ETernary (e1,e2,e3) -> - type_expr ctx ~need_val (EIf (e1,e2,Some e3),p) - | EIf (e,e1,e2) -> - let e = type_expr ctx e in - unify ctx e.etype ctx.t.tbool e.epos; - let e1 = type_expr ctx ~need_val e1 in - (match e2 with - | None -> - if need_val then begin - let t = ctx.t.tnull e1.etype in - mk (TIf (e,e1,Some (null t p))) t p - end else - mk (TIf (e,e1,None)) ctx.t.tvoid p - | Some e2 -> - let e2 = type_expr ctx ~need_val e2 in - let t = if not need_val then ctx.t.tvoid else (try - (match e1.eexpr, e2.eexpr with - | _ , TConst TNull -> ctx.t.tnull e1.etype - | TConst TNull, _ -> ctx.t.tnull e2.etype - | _ -> - unify_raise ctx e1.etype e2.etype p; - if is_null e1.etype then ctx.t.tnull e2.etype else e2.etype) - with - Error (Unify _,_) -> - unify ctx e2.etype e1.etype p; - if is_null e2.etype then ctx.t.tnull e1.etype else e1.etype - ) in - mk (TIf (e,e1,Some e2)) t p) - | EWhile (cond,e,NormalWhile) -> - let old_loop = ctx.in_loop in - let cond = type_expr ctx cond in - unify ctx cond.etype ctx.t.tbool cond.epos; - ctx.in_loop <- true; - let e = type_expr ~need_val:false ctx e in - ctx.in_loop <- old_loop; - mk (TWhile (cond,e,NormalWhile)) ctx.t.tvoid p - | EWhile (cond,e,DoWhile) -> - let old_loop = ctx.in_loop in - ctx.in_loop <- true; - let e = type_expr ~need_val:false ctx e in - ctx.in_loop <- old_loop; - let cond = type_expr ctx cond in - unify ctx cond.etype ctx.t.tbool cond.epos; - mk (TWhile (cond,e,DoWhile)) ctx.t.tvoid p - | ESwitch (e,cases,def) -> - type_switch ctx e cases def need_val p - | EReturn e -> - let e , t = (match e with - | None -> - let v = ctx.t.tvoid in - unify ctx v ctx.ret p; - None , v - | Some e -> - let e = type_expr ctx e in - unify ctx e.etype ctx.ret e.epos; - 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 ~need_val e1 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; - (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 ~need_val e in - locals(); - if need_val 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 , t , e - ) catches in - mk (TTry (e1,catches)) (if not need_val then ctx.t.tvoid else e1.etype) p - | EThrow e -> - let e = type_expr ctx e in - mk (TThrow e) (mk_mono()) p - | ECall (e,el) -> - type_call ctx e el p - | ENew (t,el) -> - let t = Typeload.load_instance ctx t p true in - let el, c , params = (match follow t with - | TInst (c,params) -> - let name = (match c.cl_path with [], name -> name | x :: _ , _ -> x) in - if PMap.mem name ctx.locals then error ("Local variable " ^ name ^ " is preventing usage of this class here") p; - let f = get_constructor c p in - if not f.cf_public && not (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 } -> error_require r p - | _ -> ()); - let el = (match follow (apply_params c.cl_types params (field_type f)) with - | TFun (args,r) -> - unify_call_params ctx (Some "new") el args p false - | _ -> - error "Constructor is not a function" p - ) in - el , c , params - | _ -> - error (s_type (print_context()) t ^ " cannot be constructed") p - ) in - mk (TNew (c,params,el)) t p - | EUnop (op,flag,e) -> - type_unop ctx op flag e p - | EFunction (name,f) -> - 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 ctx.param_type with - | None -> () - | Some t -> - ctx.param_type <- None; - 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; - | _ -> ()); - let ft = TFun (fun_args args,rt) in - let vname = (match name with - | None -> None - | Some v -> Some (add_local ctx v ft) - ) in - let e , fargs = Typeload.type_function ctx args rt true false f p in - let f = { - tf_args = fargs; - tf_type = rt; - tf_expr = e; - } in - let e = mk (TFunction f) ft p in - (match vname with - | None -> e - | Some v -> mk (TVars [v,ft,Some e]) ctx.t.tvoid p) - | EUntyped e -> - let old = ctx.untyped in - ctx.untyped <- true; - let e = type_expr ctx e in - ctx.untyped <- old; - { - eexpr = e.eexpr; - etype = mk_mono(); - epos = e.epos; - } - | ECast (e,None) -> - let e = type_expr ctx e in - mk (TCast (e,None)) (mk_mono()) p - | ECast (e, Some t) -> - (* force compilation of class "Std" since we might need it *) - ignore(Typeload.load_type_def ctx p { tpackage = []; tparams = []; tname = "Std"; tsub = None }); - 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,_) -> TClassDecl c - | TEnum (e,_) -> TEnumDecl e - | _ -> assert false); - | _ -> - error "Cast type must be a class or an enum" p - ) in - mk (TCast (type_expr ctx e,Some texpr)) t p - | EDisplay (e,iscall) -> - let old = ctx.in_display in - ctx.in_display <- true; - let e = (try type_expr ctx e with Error (Unknown_ident n,_) -> raise (Parser.TypePath ([n],None))) in - ctx.in_display <- old; - let t = (match follow e.etype 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 || f.cf_public) c.cl_fields m in - PMap.map (fun f -> { f with cf_type = apply_params c.cl_types params f.cf_type; cf_public = true; }) m - in - let fields = loop c params in - TAnon { a_fields = fields; a_status = ref Closed; } - | TAnon a as t -> - (match !(a.a_status) with - | Statics c when is_parent c ctx.curclass -> - TAnon { a_fields = PMap.map (fun f -> { f with cf_public = true }) a.a_fields; a_status = ref Closed } - | _ -> t) - | t -> t - ) in - (* - add 'using' methods compatible with this type - *) - let rec loop acc = function - | [] -> acc - | x :: l -> - let acc = ref (loop acc l) in - (match x with - | TClassDecl c -> - let rec dup t = Type.map dup t in - List.iter (fun f -> - match follow (field_type f) with - | TFun ((_,_,t) :: args, ret) when (try unify_raise ctx (dup e.etype) t e.epos; true with _ -> false) -> - let f = { f with cf_type = TFun (args,ret); cf_params = [] } in - if follow e.etype == t_dynamic && follow t != t_dynamic then - () - else - acc := PMap.add f.cf_name f (!acc) - | _ -> () - ) c.cl_ordered_statics - | _ -> ()); - !acc - in - let use_methods = loop PMap.empty ctx.local_using in - let t = (if iscall then - match follow t with - | TFun _ -> t - | _ -> t_dynamic - else if PMap.is_empty use_methods then - t - else match follow t with - | TAnon a -> TAnon { a_fields = PMap.fold (fun f acc -> PMap.add f.cf_name f acc) a.a_fields use_methods; a_status = ref Closed; } - | _ -> TAnon { a_fields = use_methods; a_status = ref Closed } - ) in - (match follow t with - | TMono _ | TDynamic _ when ctx.in_macro -> mk (TConst TNull) t p - | _ -> raise (Display t)) - | EDisplayNew t -> - let t = Typeload.load_instance ctx t p true in - (match follow t with - | TInst (c,params) -> - let f = get_constructor c p in - let t = apply_params c.cl_types params (field_type f) in - raise (Display t) - | _ -> - error "Not a class" p) - -and type_call ctx e el p = - match e, el with - | (EConst (Ident "trace"),p) , e :: el -> - if Common.defined ctx.com "no_traces" then - null ctx.t.tvoid p - else - let params = (match el with [] -> [] | _ -> ["customParams",(EArrayDecl el , p)]) in - let infos = mk_infos ctx p params in - type_expr ctx (ECall ((EField ((EType ((EConst (Ident "haxe"),p),"Log"),p),"trace"),p),[e;EUntyped infos,p]),p) - | (EConst (Ident "callback"),p) , e :: params -> - let e = type_expr ctx e in - let eparams = List.map (type_expr ctx) params in - (match follow e.etype with - | TFun (args,ret) -> - let rec loop args params eargs = - match args, params with - | _ , [] -> - let k = ref 0 in - let fun_arg = ("f",None,e.etype) in - let first_args = List.map (fun t -> incr k; "a" ^ string_of_int !k, None, t) (List.rev eargs) in - let missing_args = List.map (fun (_,opt,t) -> incr k; "a" ^ string_of_int !k, (if opt then Some TNull else None), t) args in - let vexpr (v,_,t) = mk (TLocal v) t p in - let func = mk (TFunction { - tf_args = missing_args; - tf_type = ret; - tf_expr = mk (TReturn (Some ( - make_call ctx (vexpr fun_arg) (List.map vexpr (first_args @ missing_args)) ret p - ))) ret p; - }) (TFun (fun_args missing_args,ret)) p in - let func = mk (TFunction { - tf_args = fun_arg :: first_args; - tf_type = func.etype; - tf_expr = mk (TReturn (Some func)) e.etype p; - }) (TFun (fun_args first_args,func.etype)) p in - mk (TCall (func,e :: eparams)) (TFun (fun_args missing_args,ret)) p - | [], _ -> error "Too many callback arguments" p - | (_,_,t) :: args , e :: params -> - unify ctx e.etype t p; - loop args params (t :: eargs) - in - loop args eparams [] - | _ -> error "First parameter of callback is not a function" p); - | (EConst (Ident "type"),_) , [e] -> - let e = type_expr ctx e 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 in - if Common.defined ctx.com "flash" then - mk (TCall (mk (TLocal "__unprotect__") (tfun [e.etype] e.etype) p,[e])) e.etype e.epos - else - e - | (EConst (Ident "super"),sp) , el -> - if ctx.in_static || not ctx.in_constructor then error "Cannot call superconstructor 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 f = get_constructor c p in - let el = (match follow (apply_params c.cl_types params (field_type f)) with - | TFun (args,_) -> - unify_call_params ctx (Some "new") el args 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 - | _ -> - (match e with - | EField ((EConst (Ident "super"),_),_) , _ | EType ((EConst (Ident "super"),_),_) , _ -> ctx.in_super_call <- true - | _ -> ()); - match type_access ctx (fst e) (snd e) MCall with - | AKInline (ethis,f,t) -> - let params, tret = (match follow t with - | TFun (args,r) -> unify_call_params ctx (Some f.cf_name) el args p true, r - | _ -> error (s_type (print_context()) t ^ " cannot be called") p - ) in - make_call ctx (mk (TField (ethis,f.cf_name)) t p) params tret p - | AKUsing (et,eparam) -> - let fname = (match et.eexpr with TField (_,f) -> f | _ -> assert false) in - let params, tret = (match follow et.etype with - | TFun ( _ :: args,r) -> unify_call_params ctx (Some fname) el args p false, r - | _ -> assert false - ) in - make_call ctx et (eparam::params) tret p - | AKMacro (ethis,f) -> - (match ethis.eexpr with - | TTypeExpr (TClassDecl c) -> - (match ctx.g.do_macro ctx c.cl_path f.cf_name el p with - | None -> type_expr ctx (EConst (Ident "null"),p) - | Some e -> type_expr ctx e) - | _ -> assert false) - | acc -> - let e = acc_get ctx acc p in - let el , t = (match follow e.etype with - | TFun (args,r) -> - let el = unify_call_params ctx (match e.eexpr with TField (_,f) -> Some f | _ -> None) el args p false in - el , r - | TMono _ -> - let t = mk_mono() in - let el = List.map (type_expr ctx) el in - unify ctx (tfun (List.map (fun e -> e.etype) el) t) e.etype e.epos; - el, t - | t -> - let el = List.map (type_expr ctx) 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 - ) in - mk (TCall (e,el)) t p - -(* ---------------------------------------------------------------------- *) -(* FINALIZATION *) - -let rec finalize ctx = - let delays = ctx.g.delayed in - ctx.g.delayed <- []; - match delays with - | [] -> () (* at last done *) - | l -> - List.iter (fun f -> f()) l; - finalize ctx - -type state = - | Generating - | Done - | NotYet - -let generate ctx main = - let types = ref [] in - let modules = ref [] in - let states = Hashtbl.create 0 in - let state p = try Hashtbl.find states p with Not_found -> NotYet in - let statics = ref PMap.empty in - - let rec loop t = - let p = t_path t in - match state p with - | Done -> () - | Generating -> - prerr_endline ("Warning : maybe loop in static generation of " ^ s_type_path p); - | NotYet -> - Hashtbl.add states p Generating; - let t = (match t with - | TClassDecl c -> - walk_class p c; - t - | TEnumDecl _ | TTypeDecl _ -> - 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 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 - | TTypeDecl _ -> assert false) - | TEnumField (e,_) -> - loop_enum p e - | TNew (c,_,_) -> - iter (walk_expr p) e; - loop_class p 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 _ -> () - | TTypeDecl _ -> assert false - | TClassDecl c -> walk_static_call p c 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 - Hashtbl.iter (fun _ m -> modules := m :: !modules; List.iter loop m.mtypes) ctx.g.modules; - let main = (match main 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 ft, r = (match t with - | TEnumDecl _ | TTypeDecl _ -> - 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 = field_type f in - (match follow t with - | TFun ([],r) -> t, r - | _ -> error ("Invalid -main : " ^ s_type_path cl ^ " has invalid main function") null_pos); - with - Not_found -> error ("Invalid -main : " ^ s_type_path cl ^ " does not have static function main") null_pos - ) in - let emain = type_type ctx cl null_pos in - Some (mk (TCall (mk (TField (emain,"main")) ft null_pos,[])) r null_pos); - ) in - main, List.rev !types, List.rev !modules - -(* ---------------------------------------------------------------------- *) -(* MACROS *) - -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 parse_string ctx s p = - let old = Lexer.save() in - let old_file = (try Some (Hashtbl.find Lexer.all_files p.pfile) with Not_found -> None) in - let restore() = - (match old_file with - | None -> () - | Some f -> Hashtbl.replace Lexer.all_files p.pfile f); - Lexer.restore old; - in - Lexer.init p.pfile; - let _, decls = try - Parser.parse ctx.com (Lexing.from_string s) - with Parser.Error (e,_) -> - restore(); - failwith (Parser.error_msg e) - | Lexer.Error (e,_) -> - restore(); - failwith (Lexer.error_msg e) - in - restore(); - match decls with - | [(d,_)] -> d - | _ -> assert false - -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) - in - { - Interp.pos = p; - Interp.defined = Common.defined ctx.com; - Interp.get_type = (fun s -> - let path = parse_path s in - try - Some (Typeload.load_instance ctx { tpackage = fst path; tname = snd path; tparams = []; tsub = None } p true) - with Error (Module_not_found _,p2) when p == p2 -> - None - ); - Interp.get_module = (fun s -> - let path = parse_path s in - List.map make_instance (Typeload.load_module ctx path p).mtypes - ); - Interp.on_generate = (fun f -> - Common.add_filter ctx.com (fun() -> f (List.map make_instance ctx.com.types)) - ); - Interp.parse_string = (fun s p -> - 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 - match parse_string ctx (head ^ s ^ "}") p with - | EClass { d_data = [{ cff_name = "main"; cff_kind = FFun (_,{ f_expr = e }) }]} -> e - | _ -> assert false - ); - Interp.typeof = (fun e -> - let e = (try type_expr ctx ~need_val:true e with Error (msg,_) -> failwith (error_msg msg)) in - e.etype - ); - Interp.type_patch = (fun t f s v -> - let v = (match v with None -> None | Some s -> - match parse_string ctx ("typedef T = " ^ s) null_pos 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 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.print = (fun s -> - if not ctx.com.display then print_string s - ); - Interp.set_js_generator = (fun gen -> - let js_ctx = Genjs.alloc_ctx ctx.com in - ctx.com.js_gen <- Some (fun() -> - let ctx = 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); - "generateExpr", 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 - )); - "setDebugInfos", Interp.VFunction (Interp.Fun3 (fun c m s -> - Genjs.set_debug_infos js_ctx (match Interp.decode_tdecl c with TClassDecl c -> c | _ -> assert false) (Interp.dec_string m) (Interp.dec_bool s); - Interp.VNull - )); - "generateConstructor", 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 - )); - "stackVar", Interp.enc_string (js_ctx.Genjs.stack.Codegen.stack_var); - "excVar", Interp.enc_string (js_ctx.Genjs.stack.Codegen.stack_exc_var); - ] in - gen ctx - ); - ); - Interp.get_cur_class = (fun() -> Some ctx.curclass); - } - -let load_macro ctx cpath f p = - let t = Common.timer "macro execution" in - let api = make_macro_api ctx p in - let ctx2 = (match ctx.g.macros with - | Some (select,ctx) -> - select(); - ctx - | None -> - let com2 = Common.clone ctx.com in - com2.package_rules <- PMap.empty; - com2.main_class <- None; - com2.display <- false; - com2.dead_code_elimination <- false; - List.iter (fun p -> com2.defines <- PMap.remove (platform_name p) com2.defines) platforms; - com2.class_path <- List.filter (fun s -> not (ExtString.String.exists s "/_std/")) com2.class_path; - com2.class_path <- List.map (fun p -> p ^ "neko" ^ "/_std/") com2.std_path @ com2.class_path; - Common.define com2 "macro"; - Common.init_platform com2 Neko; - let ctx2 = ctx.g.do_create com2 in - let mctx = Interp.create com2 api in - let on_error = com2.error in - com2.error <- (fun e p -> Interp.set_error mctx true; on_error e p); - let macro = ((fun() -> Interp.select mctx), ctx2) in - ctx.g.macros <- Some macro; - ctx2.g.macros <- Some macro; - (* ctx2.g.core_api <- ctx.g.core_api; // causes some issues because of optional args and Null type in Flash9 *) - ignore(Typeload.load_module ctx2 (["haxe";"macro"],"Expr") p); - ignore(Typeload.load_module ctx2 (["haxe";"macro"],"Type") p); - finalize ctx2; - let _, types, _ = generate ctx2 None in - Interp.add_types mctx types; - Interp.init mctx; - ctx2 - ) in - let mctx = Interp.get_ctx() in - let m = (try Hashtbl.find ctx.g.types_module cpath with Not_found -> cpath) in - ctx2.local_types <- (Typeload.load_module ctx2 m p).mtypes; - let meth = (match Typeload.load_instance ctx2 { tpackage = fst cpath; tname = snd cpath; tparams = []; tsub = None } p true with - | TInst (c,_) -> (try PMap.find f c.cl_statics with Not_found -> error ("Method " ^ f ^ " not found on class " ^ s_type_path cpath) p) - | _ -> error "Macro should be called on a class" p - ) in - let meth = (match follow meth.cf_type with TFun (args,ret) -> args,ret | _ -> error "Macro call should be a method" p) in - let in_macro = ctx.in_macro in - if not in_macro then begin - finalize ctx2; - let _, types, modules = generate ctx2 None in - ctx2.com.types <- types; - ctx2.com.Common.modules <- modules; - Interp.add_types mctx types; - end else t(); - let call args = - let r = Interp.call_path mctx ((fst cpath) @ [snd cpath]) f args api in - if not in_macro then t(); - r - in - ctx2, meth, call - -let type_macro ctx cpath f el p = - let ctx2, (margs,mret), call_macro = load_macro ctx cpath f p in - let expr = Typeload.load_instance ctx2 { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None} p false in - unify ctx2 mret expr p; - let nargs = (match margs with - | [(_,_,t)] -> - (try - unify_raise ctx2 t expr p; - Some 1 - with Error (Unify _,_) -> - unify ctx2 t (ctx2.t.tarray expr) p; - None) - | _ -> - List.iter (fun (_,_,t) -> unify ctx2 t expr p) margs; - Some (List.length margs) - ) in - (match nargs with - | Some n -> if List.length el <> n then error ("This macro requires " ^ string_of_int n ^ " arguments") p - | None -> ()); - let call() = - let el = List.map Interp.encode_expr el in - match call_macro (if nargs = None then [Interp.enc_array el] else el) with - | None -> None - | Some v -> Some (try Interp.decode_expr v with Interp.Invalid_expr -> error "The macro didn't return a valid expression" p) - in - let e = (if 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 mctx = Interp.get_ctx() in - let pos = Interp.alloc_delayed mctx (fun() -> - (* remove $delay_call calls from the stack *) - Interp.unwind_stack mctx; - match call() with - | None -> raise Interp.Abort - | Some e -> Interp.eval mctx (Genneko.gen_expr mctx.Interp.gen (type_expr ctx e)) - ) in - let e = (EConst (Ident "__dollar__delay_call"),p) in - Some (EUntyped (ECall (e,[EConst (Int (string_of_int pos)),p]),p),p) - end else - call() - ) in - e - -let call_macro ctx path meth args p = - let ctx2, (margs,_), call = load_macro ctx path meth p in - let el = unify_call_params ctx2 (Some meth) args margs 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 in - match fst e with - | ECall (e,args) -> - let rec loop e = - match fst e with - | EField (e,f) | EType (e,f) -> f :: loop e - | EConst (Ident i | Type 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 empty = { - mpath = [] , ""; - mtypes = []; - } in - let ctx = { - com = com; - t = com.basic; - g = { - core_api = None; - macros = None; - modules = Hashtbl.create 0; - types_module = Hashtbl.create 0; - constructs = Hashtbl.create 0; - type_patches = Hashtbl.create 0; - delayed = []; - doinline = not (Common.defined com "no_inline" || com.display); - hook_generate = []; - std = empty; - 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; - }; - untyped = false; - in_constructor = false; - in_static = false; - in_loop = false; - in_super_call = false; - in_display = false; - in_macro = Common.defined com "macro"; - ret = mk_mono(); - locals = PMap.empty; - locals_map = PMap.empty; - locals_map_inv = PMap.empty; - local_types = []; - local_using = []; - type_params = []; - curmethod = ""; - curclass = null_class; - tthis = mk_mono(); - current = empty; - opened = []; - param_type = None; - } 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 - | TEnumDecl e -> - (match snd e.e_path with - | "Void" -> ctx.t.tvoid <- TEnum (e,[]) - | "Bool" -> ctx.t.tbool <- TEnum (e,[]) - | _ -> ()) - | TClassDecl c -> - (match snd c.cl_path with - | "Float" -> ctx.t.tfloat <- TInst (c,[]) - | "Int" -> ctx.t.tint <- TInst (c,[]) - | _ -> ()) - | TTypeDecl td -> - (match snd td.t_path with - | "Null" -> - let f9 = platform com Flash9 in - let cpp = platform com Cpp in - ctx.t.tnull <- if not (f9 || cpp) then (fun t -> t) else (fun t -> if is_nullable t then TType (td,[t]) else t); - | _ -> ()); - ) ctx.g.std.mtypes; - let m = Typeload.load_module ctx ([],"String") null_pos in - (match m.mtypes with - | [TClassDecl c] -> ctx.t.tstring <- TInst (c,[]) - | _ -> assert false); - let m = Typeload.load_module ctx ([],"Array") null_pos in - (match m.mtypes with - | [TClassDecl c] -> ctx.t.tarray <- (fun t -> TInst (c,[t])) - | _ -> assert false); - ctx - -;; -type_field_rec := type_field; diff --git a/interp.ml b/interp.ml new file mode 100644 index 0000000000000000000000000000000000000000..c13ae0a35bd871344987a9ed566e626f22d02eae --- /dev/null +++ b/interp.ml @@ -0,0 +1,4545 @@ +(* + * 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_hash \ No newline at end of file diff --git a/haxe/lexer.mll b/lexer.mll similarity index 72% rename from haxe/lexer.mll rename to lexer.mll index be89e4cd7db0a6ab97a5443f7e099c470fca1bf5..9b09028a663a63d77c0acb4ab6b1d3aa39754d0f 100755 --- a/haxe/lexer.mll +++ b/lexer.mll @@ -1,20 +1,23 @@ (* - * Haxe Compiler - * Copyright (c)2005 Nicolas Cannasse + * Copyright (C)2005-2012 Haxe Foundation * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. + * 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: * - * 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. + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. * - * 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 + * 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. *) { @@ -45,7 +48,8 @@ type lexer_file = { mutable lline : int; mutable lmaxline : int; mutable llines : (int * int) list; - mutable lrlines : (int * int) list; + mutable lalines : (int * int) array; + mutable lstrings : int list; } let make_file file = @@ -53,8 +57,9 @@ let make_file file = lfile = file; lline = 1; lmaxline = 1; - llines = []; - lrlines = []; + llines = [0,1]; + lalines = [|0,1|]; + lstrings = []; } @@ -74,41 +79,81 @@ let keywords = Break;Return;Continue;Extends;Implements;Import; Switch;Case;Default;Public;Private;Try;Untyped; Catch;New;This;Throw;Extern;Enum;In;Interface; - Cast;Override;Dynamic;Typedef;Package;Callback; - Inline;Using]; + Cast;Override;Dynamic;Typedef;Package; + Inline;Using;Null;True;False;Abstract;Macro]; h let init file = let f = make_file file in cur := f; - Hashtbl.add all_files file f + Hashtbl.replace all_files file f let save() = !cur -let restore c = +let restore c = cur := c let newline lexbuf = let cur = !cur in - cur.llines <- (lexeme_end lexbuf,cur.lline) :: cur.llines; - cur.lline <- cur.lline + 1 + cur.lline <- cur.lline + 1; + cur.llines <- (lexeme_end lexbuf,cur.lline) :: cur.llines + +let fmt_pos p = + p.pmin + (p.pmax - p.pmin) * 1000000 + +let add_fmt_string p = + let file = (try + Hashtbl.find all_files p.pfile + with Not_found -> + let f = make_file p.pfile in + Hashtbl.replace all_files p.pfile f; + f + ) in + file.lstrings <- (fmt_pos p) :: file.lstrings + +let fast_add_fmt_string p = + let cur = !cur in + cur.lstrings <- (fmt_pos p) :: cur.lstrings + +let is_fmt_string p = + try + let file = Hashtbl.find all_files p.pfile in + List.mem (fmt_pos p) file.lstrings + with Not_found -> + false + +let remove_fmt_string p = + try + let file = Hashtbl.find all_files p.pfile in + file.lstrings <- List.filter ((<>) (fmt_pos p)) file.lstrings + with Not_found -> + () let find_line p f = - let rec loop delta = function - | [] -> f.lmaxline, p - delta - | (lp,line) :: l when lp > p -> line, p - delta - | (lp,_) :: l -> loop lp l - in + (* rebuild cache if we have a new line *) if f.lmaxline <> f.lline then begin f.lmaxline <- f.lline; - f.lrlines <- List.rev f.llines; + f.lalines <- Array.of_list (List.rev f.llines); end; - loop 0 f.lrlines + let rec loop min max = + let med = (min + max) lsr 1 in + let lp, line = Array.unsafe_get f.lalines med in + if med = min then + line, p - lp + else if lp > p then + loop min med + else + loop med max + in + loop 0 (Array.length f.lalines) -let get_error_line p = +let find_pos p = let file = (try Hashtbl.find all_files p.pfile with Not_found -> make_file p.pfile) in - let l, _ = find_line p.pmin file in + find_line p.pmin file + +let get_error_line p = + let l, _ = find_pos p in l let get_error_pos printer p = @@ -136,9 +181,8 @@ let mk lexbuf t = mk_tok t (lexeme_start lexbuf) (lexeme_end lexbuf) let mk_ident lexbuf = - match lexeme lexbuf with - | s -> - mk lexbuf (try Kwd (Hashtbl.find keywords s) with Not_found -> Const (Ident s)) + let s = lexeme lexbuf in + mk lexbuf (try Kwd (Hashtbl.find keywords s) with Not_found -> Const (Ident s)) let invalid_char lexbuf = error (Invalid_character (lexeme_char lexbuf 0)) (lexeme_start lexbuf) @@ -195,6 +239,7 @@ and token = parse | "<<" { mk lexbuf (Binop OpShl) } | "->" { mk lexbuf Arrow } | "..." { mk lexbuf (Binop OpInterval) } + | "=>" { mk lexbuf (Binop OpArrow)} | "!" { mk lexbuf (Unop Not) } | "<" { mk lexbuf (Binop OpLt) } | ">" { mk lexbuf (Binop OpGt) } @@ -237,7 +282,9 @@ and token = parse let pmin = lexeme_start lexbuf in let pmax = (try string2 lexbuf with Exit -> error Unterminated_string pmin) in let str = (try unescape (contents()) with Exit -> error Invalid_escape pmin) in - mk_tok (Const (String str)) pmin pmax; + let t = mk_tok (Const (String str)) pmin pmax in + fast_add_fmt_string (snd t); + t } | "~/" { reset(); @@ -249,10 +296,15 @@ and token = parse | '#' ident { let v = lexeme lexbuf in let v = String.sub v 1 (String.length v - 1) in - mk lexbuf (Macro v) + mk lexbuf (Sharp v) + } + | '$' ['_' 'a'-'z' 'A'-'Z' '0'-'9']* { + let v = lexeme lexbuf in + let v = String.sub v 1 (String.length v - 1) in + mk lexbuf (Dollar v) } | ident { mk_ident lexbuf } - | idtype { mk lexbuf (Const (Type (lexeme lexbuf))) } + | idtype { mk lexbuf (Const (Ident (lexeme lexbuf))) } | _ { invalid_char lexbuf } and comment = parse @@ -288,6 +340,7 @@ and regexp = parse | '\\' 't' { add "\t"; regexp lexbuf } | '\\' ['\\' '$' '.' '*' '+' '^' '|' '{' '}' '[' ']' '(' ')' '?' '-' '0'-'9'] { add (lexeme lexbuf); regexp lexbuf } | '\\' ['w' 'W' 'b' 'B' 's' 'S' 'd' 'D' 'x'] { add (lexeme lexbuf); regexp lexbuf } + | '\\' ['u' 'U'] ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] { add (lexeme lexbuf); regexp lexbuf } | '\\' [^ '\\'] { error (Invalid_character (lexeme lexbuf).[1]) (lexeme_end lexbuf - 1) } | '/' { regexp_options lexbuf, lexeme_end lexbuf } | [^ '\\' '/' '\r' '\n']+ { store lexbuf; regexp lexbuf } diff --git a/ocaml/extc/LICENSE b/libs/extc/LICENSE similarity index 100% rename from ocaml/extc/LICENSE rename to libs/extc/LICENSE diff --git a/libs/extc/Makefile b/libs/extc/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..82c841bd8ef08a7923594a08b4f1ac03d877c302 --- /dev/null +++ b/libs/extc/Makefile @@ -0,0 +1,17 @@ +CFLAGS = -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 diff --git a/ocaml/extc/extc.ml b/libs/extc/extc.ml similarity index 76% rename from ocaml/extc/extc.ml rename to libs/extc/extc.ml index 96b38b9a2dcc5020b0646f7a03d0dbc40770dde1..c7e29ea5b52270a237d04192a041fe5b58d67d13 100644 --- a/ocaml/extc/extc.ml +++ b/libs/extc/extc.ml @@ -33,7 +33,7 @@ type zresult = { z_wrote : int; } -external zlib_deflate_init : int -> zstream = "zlib_deflate_init" +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" @@ -43,8 +43,39 @@ 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() = diff --git a/libs/extc/extc_stubs.c b/libs/extc/extc_stubs.c new file mode 100644 index 0000000000000000000000000000000000000000..07f174958042f980e2d91707406595a6ae7cf674 --- /dev/null +++ b/libs/extc/extc_stubs.c @@ -0,0 +1,440 @@ +/* + * 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; +} diff --git a/ocaml/extc/test.ml b/libs/extc/test.ml similarity index 100% rename from ocaml/extc/test.ml rename to libs/extc/test.ml diff --git a/ocaml/extc/zlib/README.txt b/libs/extc/zlib/README.txt similarity index 100% rename from ocaml/extc/zlib/README.txt rename to libs/extc/zlib/README.txt diff --git a/ocaml/extc/zlib/zconf.h b/libs/extc/zlib/zconf.h similarity index 100% rename from ocaml/extc/zlib/zconf.h rename to libs/extc/zlib/zconf.h diff --git a/ocaml/extc/zlib/zlib.h b/libs/extc/zlib/zlib.h similarity index 100% rename from ocaml/extc/zlib/zlib.h rename to libs/extc/zlib/zlib.h diff --git a/ocaml/extc/zlib/zlib.lib b/libs/extc/zlib/zlib.lib similarity index 100% rename from ocaml/extc/zlib/zlib.lib rename to libs/extc/zlib/zlib.lib diff --git a/ocaml/extlib-dev/IO.ml b/libs/extlib/IO.ml similarity index 100% rename from ocaml/extlib-dev/IO.ml rename to libs/extlib/IO.ml diff --git a/ocaml/extlib-dev/IO.mli b/libs/extlib/IO.mli similarity index 100% rename from ocaml/extlib-dev/IO.mli rename to libs/extlib/IO.mli diff --git a/ocaml/extlib-dev/LICENSE b/libs/extlib/LICENSE similarity index 100% rename from ocaml/extlib-dev/LICENSE rename to libs/extlib/LICENSE diff --git a/ocaml/extlib-dev/META.txt b/libs/extlib/META.txt similarity index 100% rename from ocaml/extlib-dev/META.txt rename to libs/extlib/META.txt diff --git a/ocaml/extlib-dev/Makefile b/libs/extlib/Makefile similarity index 61% rename from ocaml/extlib-dev/Makefile rename to libs/extlib/Makefile index d2d044967d0acced4cc64340cbb146c47f611603..e0842560fcb797e2e31d8a757323145d431a7013 100644 --- a/ocaml/extlib-dev/Makefile +++ b/libs/extlib/Makefile @@ -2,23 +2,26 @@ MODULES = \ enum bitSet dynArray extArray extHashtbl extList extString global IO option \ - pMap std uChar uTF8 base64 unzip refList optParse dllist + 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: +all: ocamlc -a -o extLib.cma $(SRC) -opt: - ocamlopt -a -o extLib.cmxa $(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) @@ -27,5 +30,5 @@ uninstall: ocamlfind remove extlib clean: - rm -f *.cmo *.cmx *.o *.cmi *.cma *.cmxa *.a + rm -f $(wildcard *.cmo) $(wildcard *.cmx) $(wildcard *.o) $(wildcard *.cmi) $(wildcard *.cma) $(wildcard *.cmxa) $(wildcard *.a) $(wildcard *.lib) $(wildcard *.obj) rm -Rf doc diff --git a/ocaml/extlib-dev/README.txt b/libs/extlib/README.txt similarity index 100% rename from ocaml/extlib-dev/README.txt rename to libs/extlib/README.txt diff --git a/ocaml/extlib-dev/base64.ml b/libs/extlib/base64.ml similarity index 100% rename from ocaml/extlib-dev/base64.ml rename to libs/extlib/base64.ml diff --git a/ocaml/extlib-dev/base64.mli b/libs/extlib/base64.mli similarity index 100% rename from ocaml/extlib-dev/base64.mli rename to libs/extlib/base64.mli diff --git a/ocaml/extlib-dev/bitSet.ml b/libs/extlib/bitSet.ml similarity index 100% rename from ocaml/extlib-dev/bitSet.ml rename to libs/extlib/bitSet.ml diff --git a/ocaml/extlib-dev/bitSet.mli b/libs/extlib/bitSet.mli similarity index 100% rename from ocaml/extlib-dev/bitSet.mli rename to libs/extlib/bitSet.mli diff --git a/ocaml/extlib-dev/dllist.ml b/libs/extlib/dllist.ml similarity index 100% rename from ocaml/extlib-dev/dllist.ml rename to libs/extlib/dllist.ml diff --git a/ocaml/extlib-dev/dllist.mli b/libs/extlib/dllist.mli similarity index 100% rename from ocaml/extlib-dev/dllist.mli rename to libs/extlib/dllist.mli diff --git a/ocaml/extlib-dev/dynArray.ml b/libs/extlib/dynArray.ml similarity index 100% rename from ocaml/extlib-dev/dynArray.ml rename to libs/extlib/dynArray.ml diff --git a/ocaml/extlib-dev/dynArray.mli b/libs/extlib/dynArray.mli similarity index 100% rename from ocaml/extlib-dev/dynArray.mli rename to libs/extlib/dynArray.mli diff --git a/ocaml/extlib-dev/enum.ml b/libs/extlib/enum.ml similarity index 100% rename from ocaml/extlib-dev/enum.ml rename to libs/extlib/enum.ml diff --git a/ocaml/extlib-dev/enum.mli b/libs/extlib/enum.mli similarity index 100% rename from ocaml/extlib-dev/enum.mli rename to libs/extlib/enum.mli diff --git a/ocaml/extlib-dev/extArray.ml b/libs/extlib/extArray.ml similarity index 100% rename from ocaml/extlib-dev/extArray.ml rename to libs/extlib/extArray.ml diff --git a/ocaml/extlib-dev/extArray.mli b/libs/extlib/extArray.mli similarity index 100% rename from ocaml/extlib-dev/extArray.mli rename to libs/extlib/extArray.mli diff --git a/ocaml/extlib-dev/extHashtbl.ml b/libs/extlib/extHashtbl.ml similarity index 98% rename from ocaml/extlib-dev/extHashtbl.ml rename to libs/extlib/extHashtbl.ml index f667dff510c97a8b514bd8bba0e97f92a7766bdd..52ff0734c9aed5427a9b8bfd95aa99a0d66c2622 100644 --- a/ocaml/extlib-dev/extHashtbl.ml +++ b/libs/extlib/extHashtbl.ml @@ -36,6 +36,8 @@ module 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 = diff --git a/ocaml/extlib-dev/extHashtbl.mli b/libs/extlib/extHashtbl.mli similarity index 100% rename from ocaml/extlib-dev/extHashtbl.mli rename to libs/extlib/extHashtbl.mli diff --git a/ocaml/extlib-dev/extLib.ml b/libs/extlib/extLib.ml similarity index 100% rename from ocaml/extlib-dev/extLib.ml rename to libs/extlib/extLib.ml diff --git a/ocaml/extlib-dev/extList.ml b/libs/extlib/extList.ml similarity index 100% rename from ocaml/extlib-dev/extList.ml rename to libs/extlib/extList.ml diff --git a/ocaml/extlib-dev/extList.mli b/libs/extlib/extList.mli similarity index 100% rename from ocaml/extlib-dev/extList.mli rename to libs/extlib/extList.mli diff --git a/ocaml/extlib-dev/extString.ml b/libs/extlib/extString.ml similarity index 100% rename from ocaml/extlib-dev/extString.ml rename to libs/extlib/extString.ml diff --git a/ocaml/extlib-dev/extString.mli b/libs/extlib/extString.mli similarity index 100% rename from ocaml/extlib-dev/extString.mli rename to libs/extlib/extString.mli diff --git a/ocaml/extlib-dev/global.ml b/libs/extlib/global.ml similarity index 100% rename from ocaml/extlib-dev/global.ml rename to libs/extlib/global.ml diff --git a/ocaml/extlib-dev/global.mli b/libs/extlib/global.mli similarity index 100% rename from ocaml/extlib-dev/global.mli rename to libs/extlib/global.mli diff --git a/ocaml/extlib-dev/install.ml b/libs/extlib/install.ml similarity index 99% rename from ocaml/extlib-dev/install.ml rename to libs/extlib/install.ml index 63271373d661c526d5c0aa81fe5111f36f30451e..009ebab8a0e02c1a79544903f795e111652ebb1d 100644 --- a/ocaml/extlib-dev/install.ml +++ b/libs/extlib/install.ml @@ -44,6 +44,7 @@ let modules = [ "refList"; "optParse"; "dllist"; + "multiArray"; ] let m_list suffix = diff --git a/libs/extlib/multiArray.ml b/libs/extlib/multiArray.ml new file mode 100644 index 0000000000000000000000000000000000000000..e9d439d03c43369db130bdebe35d69614f54028d --- /dev/null +++ b/libs/extlib/multiArray.ml @@ -0,0 +1,284 @@ +(* + * 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; + !acc \ No newline at end of file diff --git a/libs/extlib/multiArray.mli b/libs/extlib/multiArray.mli new file mode 100644 index 0000000000000000000000000000000000000000..72bbba76ed483c933c33790cfc700a422c49d392 --- /dev/null +++ b/libs/extlib/multiArray.mli @@ -0,0 +1,115 @@ +(* + * 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]. *) \ No newline at end of file diff --git a/ocaml/extlib-dev/odoc_style.css b/libs/extlib/odoc_style.css similarity index 100% rename from ocaml/extlib-dev/odoc_style.css rename to libs/extlib/odoc_style.css diff --git a/ocaml/extlib-dev/optParse.ml b/libs/extlib/optParse.ml similarity index 100% rename from ocaml/extlib-dev/optParse.ml rename to libs/extlib/optParse.ml diff --git a/ocaml/extlib-dev/optParse.mli b/libs/extlib/optParse.mli similarity index 100% rename from ocaml/extlib-dev/optParse.mli rename to libs/extlib/optParse.mli diff --git a/ocaml/extlib-dev/option.ml b/libs/extlib/option.ml similarity index 100% rename from ocaml/extlib-dev/option.ml rename to libs/extlib/option.ml diff --git a/ocaml/extlib-dev/option.mli b/libs/extlib/option.mli similarity index 100% rename from ocaml/extlib-dev/option.mli rename to libs/extlib/option.mli diff --git a/ocaml/extlib-dev/pMap.ml b/libs/extlib/pMap.ml similarity index 100% rename from ocaml/extlib-dev/pMap.ml rename to libs/extlib/pMap.ml diff --git a/ocaml/extlib-dev/pMap.mli b/libs/extlib/pMap.mli similarity index 100% rename from ocaml/extlib-dev/pMap.mli rename to libs/extlib/pMap.mli diff --git a/ocaml/extlib-dev/refList.ml b/libs/extlib/refList.ml similarity index 100% rename from ocaml/extlib-dev/refList.ml rename to libs/extlib/refList.ml diff --git a/ocaml/extlib-dev/refList.mli b/libs/extlib/refList.mli similarity index 100% rename from ocaml/extlib-dev/refList.mli rename to libs/extlib/refList.mli diff --git a/ocaml/extlib-dev/std.ml b/libs/extlib/std.ml similarity index 100% rename from ocaml/extlib-dev/std.ml rename to libs/extlib/std.ml diff --git a/ocaml/extlib-dev/std.mli b/libs/extlib/std.mli similarity index 100% rename from ocaml/extlib-dev/std.mli rename to libs/extlib/std.mli diff --git a/ocaml/extlib-dev/uChar.ml b/libs/extlib/uChar.ml similarity index 100% rename from ocaml/extlib-dev/uChar.ml rename to libs/extlib/uChar.ml diff --git a/ocaml/extlib-dev/uChar.mli b/libs/extlib/uChar.mli similarity index 100% rename from ocaml/extlib-dev/uChar.mli rename to libs/extlib/uChar.mli diff --git a/ocaml/extlib-dev/uTF8.ml b/libs/extlib/uTF8.ml similarity index 100% rename from ocaml/extlib-dev/uTF8.ml rename to libs/extlib/uTF8.ml diff --git a/ocaml/extlib-dev/uTF8.mli b/libs/extlib/uTF8.mli similarity index 100% rename from ocaml/extlib-dev/uTF8.mli rename to libs/extlib/uTF8.mli diff --git a/ocaml/extlib-dev/unzip.ml b/libs/extlib/unzip.ml similarity index 100% rename from ocaml/extlib-dev/unzip.ml rename to libs/extlib/unzip.ml diff --git a/ocaml/extlib-dev/unzip.mli b/libs/extlib/unzip.mli similarity index 100% rename from ocaml/extlib-dev/unzip.mli rename to libs/extlib/unzip.mli diff --git a/libs/javalib/Makefile b/libs/javalib/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..a0b789a2dcdbdca98e256b992802d7a3f10c012d --- /dev/null +++ b/libs/javalib/Makefile @@ -0,0 +1,5 @@ +all: + 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) diff --git a/libs/javalib/jData.ml b/libs/javalib/jData.ml new file mode 100644 index 0000000000000000000000000000000000000000..82fe19c7615245c57b742b24679cbea7e80d7692 --- /dev/null +++ b/libs/javalib/jData.ml @@ -0,0 +1,250 @@ +(* + * 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}" + diff --git a/libs/javalib/jReader.ml b/libs/javalib/jReader.ml new file mode 100644 index 0000000000000000000000000000000000000000..5c0d5b17d6e605b0a934d1c2e9df54d033b15573 --- /dev/null +++ b/libs/javalib/jReader.ml @@ -0,0 +1,590 @@ +(* + * 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; + } + diff --git a/libs/javalib/jWriter.ml b/libs/javalib/jWriter.ml new file mode 100644 index 0000000000000000000000000000000000000000..76486a43da4b5b3018997f27ed971c93fca72dbe --- /dev/null +++ b/libs/javalib/jWriter.ml @@ -0,0 +1,131 @@ +(* + * 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 diff --git a/libs/neko/Makefile b/libs/neko/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..5b592cde29fd89a916c6fb0d69f66acf990e6445 --- /dev/null +++ b/libs/neko/Makefile @@ -0,0 +1,5 @@ +all: + ocamlopt -I ../extlib -a -o neko.cmxa nast.ml nxml.ml binast.ml nbytecode.ml ncompile.ml + +clean: + rm -rf neko.cmxa neko.lib neko.a $(wilcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi) \ No newline at end of file diff --git a/neko/libs/include/ocaml/binast.ml b/libs/neko/binast.ml similarity index 98% rename from neko/libs/include/ocaml/binast.ml rename to libs/neko/binast.ml index 355c92ceee9a29130456e0c859e53f94cec50d38..4af62f60e64b4391b835fec3ebddd275b125649b 100644 --- a/neko/libs/include/ocaml/binast.ml +++ b/libs/neko/binast.ml @@ -72,6 +72,9 @@ let write_constant ctx = function | Ident s -> b ctx 9; write_string ctx s + | Int32 n -> + b ctx 10; + IO.write_real_i32 ctx.ch n let write_op ctx op = b ctx (match op with diff --git a/neko/libs/include/ocaml/nast.ml b/libs/neko/nast.ml similarity index 98% rename from neko/libs/include/ocaml/nast.ml rename to libs/neko/nast.ml index 9d01f20ce3f68141815fd43a2d68613cea84a620..90c84a7206d35621465ec6769c7cea494c40a52a 100644 --- a/neko/libs/include/ocaml/nast.ml +++ b/libs/neko/nast.ml @@ -32,6 +32,7 @@ type constant = | String of string | Builtin of string | Ident of string + | Int32 of int32 type while_flag = | NormalWhile @@ -149,3 +150,5 @@ let s_constant = function | String s -> "\"" ^ escape s ^ "\"" | Builtin s -> "$" ^ s | Ident s -> s + | Int32 i -> Int32.to_string i + diff --git a/libs/neko/nbytecode.ml b/libs/neko/nbytecode.ml new file mode 100644 index 0000000000000000000000000000000000000000..8965013bc56c177e620b1eff8b271aefb8dcc822 --- /dev/null +++ b/libs/neko/nbytecode.ml @@ -0,0 +1,377 @@ +(* + * Neko Compiler + * Copyright (c)2005 Motion-Twin + * + * This library is free software; you can redistribute it and/lor + * 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, lor (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 lor FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License lor the LICENSE file for more details. + *) + +type opcode = + (* getters *) + | AccNull + | AccTrue + | AccFalse + | AccThis + | AccInt of int + | AccStack of int + | AccGlobal of int + | AccEnv of int + | AccField of string + | AccArray + | AccIndex of int + | AccBuiltin of string + (* setters *) + | SetStack of int + | SetGlobal of int + | SetEnv of int + | SetField of string + | SetArray + | SetIndex of int + | SetThis + (* stack ops *) + | Push + | Pop of int + | Call of int + | ObjCall of int + | Jump of int + | JumpIf of int + | JumpIfNot of int + | Trap of int + | EndTrap + | Ret of int + | MakeEnv of int + | MakeArray of int + (* value ops *) + | Bool + | IsNull + | IsNotNull + | Add + | Sub + | Mult + | Div + | Mod + | Shl + | Shr + | UShr + | Or + | And + | Xor + | Eq + | Neq + | Gt + | Gte + | Lt + | Lte + | Not + (* extra ops *) + | TypeOf + | Compare + | Hash + | New + | JumpTable of int + | Apply of int + | AccStack0 + | AccStack1 + | AccIndex0 + | AccIndex1 + | PhysCompare + | TailCall of int * int + | Loop + (* ocaml-specific *) + | AccInt32 of int32 + +type global = + | GlobalVar of string + | GlobalFunction of int * int + | GlobalString of string + | GlobalFloat of string + | GlobalDebug of string array * ((int * int) array) + | GlobalVersion of int + +exception Invalid_file + +let error msg = failwith msg + +let trap_stack_delta = 6 + +let hash_field 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 op_param x = + match x with + | AccInt _ + | AccInt32 _ + | AccStack _ + | AccGlobal _ + | AccEnv _ + | AccField _ + | AccBuiltin _ + | SetStack _ + | SetGlobal _ + | SetEnv _ + | SetField _ + | Pop _ + | Call _ + | ObjCall _ + | Jump _ + | JumpIf _ + | JumpIfNot _ + | JumpTable _ + | Trap _ + | MakeEnv _ + | MakeArray _ + | Ret _ + | AccIndex _ + | SetIndex _ + | Apply _ + | TailCall _ + -> true + | AccNull + | AccTrue + | AccFalse + | AccThis + | AccArray + | SetArray + | SetThis + | Push + | EndTrap + | Bool + | Add + | Sub + | Mult + | Div + | Mod + | Shl + | Shr + | UShr + | Or + | And + | Xor + | Eq + | Neq + | Gt + | Gte + | Lt + | Lte + | IsNull + | IsNotNull + | Not + | TypeOf + | Compare + | Hash + | New + | AccStack0 + | AccStack1 + | AccIndex0 + | AccIndex1 + | PhysCompare + | Loop + -> false + +let code_tables ops = + let ids = Hashtbl.create 0 in + let fids = DynArray.create() in + Array.iter (fun x -> + match x with + | AccField s + | SetField s + | AccBuiltin s -> + let id = hash_field s in + (try + let f = Hashtbl.find ids id in + if f <> s then error("Field hashing conflict " ^ s ^ " and " ^ f); + with Not_found -> + Hashtbl.add ids id s; + DynArray.add fids s + ) + | _ -> () + ) ops; + let p = ref 0 in + let pos = Array.make (Array.length(ops) + 1) 0 in + Array.iteri (fun i op -> + pos.(i) <- !p; + p := !p + (if op_param op then 2 else 1); + ) ops; + pos.(Array.length ops) <- !p; + (DynArray.to_array fids , pos , !p) + +let write_debug_infos ch files inf = + let nfiles = Array.length files in + (* + // the encoding of nfiles was set to keep + // backward compatibility with 1.3 which + // only allowed up to 127 filenames + *) + let lot_of_files = ref false in + if nfiles < 0x80 then + IO.write_byte ch nfiles + else if nfiles < 0x8000 then begin + lot_of_files := true; + IO.write_byte ch ((nfiles lsr 8) lor 0x80); + IO.write_byte ch (nfiles land 0xFF); + end else + assert false; + Array.iter (fun s -> IO.write_string ch s) files; + IO.write_i32 ch (Array.length inf); + let curfile = ref 0 in + let curpos = ref 0 in + let rcount = ref 0 in + let rec flush_repeat p = + if !rcount > 0 then begin + if !rcount > 15 then begin + IO.write_byte ch ((15 lsl 2) lor 2); + rcount := !rcount - 15; + flush_repeat(p) + end else begin + let delta = p - !curpos in + let delta = (if delta > 0 && delta < 4 then delta else 0) in + IO.write_byte ch ((delta lsl 6) lor (!rcount lsl 2) lor 2); + rcount := 0; + curpos := !curpos + delta; + end + end + in + Array.iter (fun (f,p) -> + if f <> !curfile then begin + flush_repeat(p); + curfile := f; + if !lot_of_files then begin + IO.write_byte ch ((f lsr 7) lor 1); + IO.write_byte ch (f land 0xFF); + end else + IO.write_byte ch ((f lsl 1) lor 1); + end; + if p <> !curpos then flush_repeat(p); + if p = !curpos then + rcount := !rcount + 1 + else + let delta = p - !curpos in + if delta > 0 && delta < 32 then + IO.write_byte ch ((delta lsl 3) lor 4) + else begin + IO.write_byte ch (p lsl 3); + IO.write_byte ch (p lsr 5); + IO.write_byte ch (p lsr 13); + end; + curpos := p; + ) inf; + flush_repeat(!curpos) + +let write ch (globals,ops) = + IO.nwrite ch "NEKO"; + let ids , pos , csize = code_tables ops in + IO.write_i32 ch (Array.length globals); + IO.write_i32 ch (Array.length ids); + IO.write_i32 ch csize; + Array.iter (fun x -> + match x with + | GlobalVar s -> IO.write_byte ch 1; IO.write_string ch s + | GlobalFunction (p,nargs) -> IO.write_byte ch 2; IO.write_i32 ch (pos.(p) lor (nargs lsl 24)) + | GlobalString s -> IO.write_byte ch 3; IO.write_ui16 ch (String.length s); IO.nwrite ch s + | GlobalFloat s -> IO.write_byte ch 4; IO.write_string ch s + | GlobalDebug (files,inf) -> IO.write_byte ch 5; write_debug_infos ch files inf; + | GlobalVersion v -> IO.write_byte ch 6; IO.write_byte ch v + ) globals; + Array.iter (fun s -> + IO.write_string ch s; + ) ids; + Array.iteri (fun i op -> + let pop = ref None in + let opid = (match op with + | AccNull -> 0 + | AccTrue -> 1 + | AccFalse -> 2 + | AccThis -> 3 + | AccInt n -> pop := Some n; 4 + | AccInt32 n -> + let opid = 4 in + IO.write_byte ch ((opid lsl 2) lor 3); + IO.write_real_i32 ch n; + -1 + | AccStack n -> pop := Some (n - 2); 5 + | AccGlobal n -> pop := Some n; 6 + | AccEnv n -> pop := Some n; 7 + | AccField s -> pop := Some (hash_field s); 8 + | AccArray -> 9 + | AccIndex n -> pop := Some (n - 2); 10 + | AccBuiltin s -> pop := Some (hash_field s); 11 + | SetStack n -> pop := Some n; 12 + | SetGlobal n -> pop := Some n; 13 + | SetEnv n -> pop := Some n; 14 + | SetField s -> pop := Some (hash_field s); 15 + | SetArray -> 16 + | SetIndex n -> pop := Some n; 17 + | SetThis -> 18 + | Push -> 19 + | Pop n -> pop := Some n; 20 + | Call n -> pop := Some n; 21 + | ObjCall n -> pop := Some n; 22 + | Jump n -> pop := Some (pos.(i+n) - pos.(i)); 23 + | JumpIf n -> pop := Some (pos.(i+n) - pos.(i)); 24 + | JumpIfNot n -> pop := Some (pos.(i+n) - pos.(i)); 25 + | Trap n -> pop := Some (pos.(i+n) - pos.(i)); 26 + | EndTrap -> 27 + | Ret n -> pop := Some n; 28 + | MakeEnv n -> pop := Some n; 29 + | MakeArray n -> pop := Some n; 30 + | Bool -> 31 + | IsNull -> 32 + | IsNotNull -> 33 + | Add -> 34 + | Sub -> 35 + | Mult -> 36 + | Div -> 37 + | Mod -> 38 + | Shl -> 39 + | Shr -> 40 + | UShr -> 41 + | Or -> 42 + | And -> 43 + | Xor -> 44 + | Eq -> 45 + | Neq -> 46 + | Gt -> 47 + | Gte -> 48 + | Lt -> 49 + | Lte -> 50 + | Not -> 51 + | TypeOf -> 52 + | Compare -> 53 + | Hash -> 54 + | New -> 55 + | JumpTable n -> pop := Some n; 56 + | Apply n -> pop := Some n; 57 + | AccStack0 -> 58 + | AccStack1 -> 59 + | AccIndex0 -> 60 + | AccIndex1 -> 61 + | PhysCompare -> 62 + | TailCall (args,st) -> pop := Some (args lor (st lsl 3)); 63 + | Loop -> pop := Some 64; 0 + ) in + match !pop with + | None -> + if opid >= 0 then IO.write_byte ch (opid lsl 2) + | Some n -> + if opid < 32 && (n = 0 || n = 1) then + IO.write_byte ch ((opid lsl 3) lor (n lsl 2) lor 1) + else if n >= 0 && n <= 0xFF then begin + IO.write_byte ch ((opid lsl 2) lor 2); + IO.write_byte ch n; + end else begin + IO.write_byte ch ((opid lsl 2) lor 3); + IO.write_i32 ch n; + end + ) ops diff --git a/libs/neko/ncompile.ml b/libs/neko/ncompile.ml new file mode 100644 index 0000000000000000000000000000000000000000..cb367205d4ea27300596982d5b3cd4138533a4d9 --- /dev/null +++ b/libs/neko/ncompile.ml @@ -0,0 +1,1045 @@ +(* + * Neko Compiler + * Copyright (c)2005 Motion-Twin + * + * 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 or the LICENSE file for more details. + *) +open Nast +open Nbytecode + +type access = + | XEnv of int + | XStack of int + | XGlobal of int + | XField of string + | XIndex of int + | XArray + | XThis + +type label = { + lname : string; + ltraps : int list; + lstack : int; + mutable lpos : int option; + mutable lwait : (unit -> unit) list; +} + +type globals = { + globals : (global,int) Hashtbl.t; + gobjects : (string list,int) Hashtbl.t; + mutable functions : (opcode DynArray.t * (int * int) DynArray.t * int * int) list; + mutable gtable : global DynArray.t; + labels : (string,label) Hashtbl.t; + hfiles : (string,int) Hashtbl.t; + files : string DynArray.t; +} + +type context = { + g : globals; + version : int; + mutable ops : opcode DynArray.t; + mutable locals : (string,int) PMap.t; + mutable env : (string,int) PMap.t; + mutable nenv : int; + mutable stack : int; + mutable loop_limit : int; + mutable limit : int; + mutable traps : int list; + mutable breaks : ((unit -> unit) * pos) list; + mutable continues : ((unit -> unit) * pos) list; + mutable pos : (int * int) DynArray.t; + mutable curpos : (int * int); + mutable curfile : string; +} + +type error_msg = string + +exception Error of error_msg * pos + +let error e p = + raise (Error(e,p)) + +let error_msg s = + s + +let stack_delta o = + match o with + | AccNull + | AccTrue + | AccFalse + | AccThis + | AccInt _ + | AccInt32 _ + | AccStack _ + | AccGlobal _ + | AccEnv _ + | AccField _ + | AccBuiltin _ + | AccIndex _ + | JumpIf _ + | JumpIfNot _ + | Jump _ + | JumpTable _ + | Ret _ + | SetGlobal _ + | SetStack _ + | SetEnv _ + | SetThis + | Bool + | IsNull + | IsNotNull + | Not + | Hash + | TypeOf + | New + | AccStack0 + | AccStack1 + | AccIndex0 + | AccIndex1 + | Loop + -> 0 + | Add + | Sub + | Mult + | Div + | Mod + | Shl + | Shr + | UShr + | Or + | And + | Xor + | Eq + | Neq + | Gt + | Gte + | Lt + | Lte + | PhysCompare + -> -1 + | AccArray -> -1 + | SetField _ | SetIndex _ | Compare -> -1 + | SetArray -> -2 + | Push -> 1 + | Pop x -> -x + | Apply nargs | Call nargs | TailCall (nargs,_) -> -nargs + | ObjCall nargs -> -(nargs + 1) + | MakeEnv size | MakeArray size -> -size + | Trap _ -> trap_stack_delta + | EndTrap -> -trap_stack_delta + +let check_stack ctx stack p = + if ctx.stack <> stack then error "Stack alignment failure" p + +let pos ctx = + DynArray.length ctx.ops + +let real_null_pos = + { pline = 0; psource = "" } + +let set_pos ctx p = + if p.psource = ctx.curfile then begin + if p.pline <> snd ctx.curpos then ctx.curpos <- (fst ctx.curpos, p.pline); + end else if p = real_null_pos then + () + else + let fid = (try + Hashtbl.find ctx.g.hfiles p.psource + with Not_found -> + let fid = DynArray.length ctx.g.files in + DynArray.add ctx.g.files p.psource; + Hashtbl.add ctx.g.hfiles p.psource fid; + fid + ) in + ctx.curfile <- p.psource; + ctx.curpos <- (fid,p.pline) + +let write ctx op = + ctx.stack <- ctx.stack + stack_delta op; + DynArray.add ctx.pos ctx.curpos; + if op_param op then DynArray.add ctx.pos ctx.curpos; + DynArray.add ctx.ops op + +let jmp ctx = + let p = pos ctx in + write ctx (Jump 0); + (fun() -> DynArray.set ctx.ops p (Jump(pos ctx - p))) + +let cjmp cond ctx = + let p = pos ctx in + write ctx (Jump 0); + (fun() -> DynArray.set ctx.ops p (if cond then JumpIf(pos ctx - p) else JumpIfNot(pos ctx - p))) + +let trap ctx = + let p = pos ctx in + write ctx (Trap 0); + (fun() -> DynArray.set ctx.ops p (Trap(pos ctx - p))) + +let goto ctx p = + write ctx (Jump(p - pos ctx)) + +let global ctx g = + let ginf = ctx.g in + try + Hashtbl.find ginf.globals g + with Not_found -> + let gid = DynArray.length ginf.gtable in + Hashtbl.add ginf.globals g gid; + DynArray.add ginf.gtable g; + gid + +let save_breaks ctx = + let oldc = ctx.continues in + let oldb = ctx.breaks in + let oldl = ctx.loop_limit in + ctx.loop_limit <- ctx.stack; + ctx.breaks <- []; + ctx.continues <- []; + (ctx , oldc, oldb , oldl) + +let process_continues (ctx,oldc,_,_) = + List.iter (fun (f,_) -> f()) ctx.continues; + ctx.continues <- oldc + +let process_breaks (ctx,_,oldb,oldl) = + List.iter (fun (f,_) -> f()) ctx.breaks; + ctx.loop_limit <- oldl; + ctx.breaks <- oldb + +let check_breaks ctx = + List.iter (fun (_,p) -> error "Break outside a loop" p) ctx.breaks; + List.iter (fun (_,p) -> error "Continue outside a loop" p) ctx.continues + +let make_array p el = + (ECall ((EConst (Builtin "array"),p),el), p) + +let get_cases_ints(cases) = + let max = ref (-1) in + let l = List.map (fun (e,e2) -> + match e with + | (EConst (Int n),_) when n >= 0 -> + if n > !max then max := n; + (n,e2) + | _ -> raise Exit + ) cases in + (* // only create jump table if small or >10% cases matched *) + let nmatches = List.length l in + if nmatches < 3 then raise Exit; + if !max >= 16 && (nmatches * 100) / (!max + 1) < 10 then raise Exit; + if !max > 512 then raise Exit; + (l,!max + 1) + +let rec scan_labels ctx supported in_block e = + match fst e with + | EFunction (args,e) -> + let nargs = List.length args in + let traps = ctx.traps in + ctx.traps <- []; + ctx.stack <- ctx.stack + nargs; + scan_labels ctx supported false e; + ctx.stack <- ctx.stack - nargs; + ctx.traps <- traps + | EBlock _ -> + let old = ctx.stack in + Nast.iter (scan_labels ctx supported true) e; + ctx.stack <- old + | EVars l -> + if not in_block then error "Variable declaration must be done inside a block" (snd e); + List.iter (fun (_,e) -> + (match e with + | None -> () + | Some e -> scan_labels ctx supported false e); + ctx.stack <- ctx.stack + 1 + ) l + | ELabel l when not supported -> + error "Label is not supported in this part of the program" (snd e); + | ELabel l when Hashtbl.mem ctx.g.labels l -> + error ("Duplicate label " ^ l) (snd e) + | ELabel l -> + let label = { + lname = l; + ltraps = List.rev ctx.traps; + lstack = ctx.stack; + lpos = None; + lwait = []; + } in + Hashtbl.add ctx.g.labels l label + | ETry (e,_,e2) -> + ctx.stack <- ctx.stack + trap_stack_delta; + ctx.traps <- ctx.stack :: ctx.traps; + scan_labels ctx supported false e; + ctx.stack <- ctx.stack - trap_stack_delta; + ctx.traps <- (match ctx.traps with [] -> assert false | _ :: l -> l); + ctx.stack <- ctx.stack + 1; + scan_labels ctx supported false e2; + ctx.stack <- ctx.stack - 1; + | EBinop ("=",e1,e2) -> + let rec is_extended (e,_) = + match e with + | EParenthesis e -> is_extended e + | EArray _ + | EField _ -> + true + | _ -> + false + in + let ext = is_extended e1 in + if ext then ctx.stack <- ctx.stack + 1; + scan_labels ctx supported false e2; + ctx.stack <- ctx.stack + 1; + scan_labels ctx supported false e1; + ctx.stack <- ctx.stack - (if ext then 2 else 1); + | ECall ((EConst (Builtin "array"),_),e :: el) -> + if ctx.version >= 2 then begin + scan_labels ctx supported false e; + List.iter (fun e -> + ctx.stack <- ctx.stack + 1; + scan_labels ctx supported false e; + ) el; + ctx.stack <- ctx.stack - List.length el + end else begin + List.iter (fun e -> + scan_labels ctx supported false e; + ctx.stack <- ctx.stack + 1; + ) el; + scan_labels ctx supported false e; + ctx.stack <- ctx.stack - List.length el + end + | ECall ((EConst (Builtin x),_),el) when x <> "apply" -> + Nast.iter (scan_labels ctx false false) e + | ECall ((EConst (Builtin "apply"),_),e :: el) + | ECall(e,el) -> + List.iter (fun e -> + scan_labels ctx supported false e; + ctx.stack <- ctx.stack + 1; + ) el; + scan_labels ctx supported false e; + ctx.stack <- ctx.stack - List.length el + | EObject fl -> + ctx.stack <- ctx.stack + 2; + List.iter (fun (s,e) -> + scan_labels ctx supported false e + ) fl; + ctx.stack <- ctx.stack - 2; + | ESwitch (ee,[(econd,exec)],eo) -> + let p = snd e in + scan_labels ctx supported false (EIf ((EBinop ("==",ee,econd),p),exec,eo),p) + | ESwitch (e,cases,eo) -> + scan_labels ctx supported false e; + let delta = (try ignore(get_cases_ints cases); 0 with Exit -> 1) in + ctx.stack <- ctx.stack + delta; + List.iter (fun (e1,e2) -> + ctx.stack <- ctx.stack + delta; + scan_labels ctx supported false e1; + ctx.stack <- ctx.stack - delta; + scan_labels ctx supported false e2; + ) cases; + (match eo with + | None -> () + | Some e -> scan_labels ctx supported false e); + ctx.stack <- ctx.stack - delta; + | ENext (e1,e2) -> + scan_labels ctx supported in_block e1; + scan_labels ctx supported in_block e2; + | EConst _ + | EContinue + | EBreak _ + | EReturn _ + | EIf _ + | EWhile _ + | EParenthesis _ -> + Nast.iter (scan_labels ctx supported false) e + | EBinop (_,_,_) + | EArray _ + | EField _ + -> + Nast.iter (scan_labels ctx false false) e + | ENeko _ -> + assert false + +let compile_constant ctx c p = + match c with + | True -> write ctx AccTrue + | False -> write ctx AccFalse + | Null -> write ctx AccNull + | This -> write ctx AccThis + | Int n -> write ctx (AccInt n) + | Int32 n -> write ctx (AccInt32 n) + | Float f -> write ctx (AccGlobal (global ctx (GlobalFloat f))) + | String s -> write ctx (AccGlobal (global ctx (GlobalString s))) + | Builtin s -> + (match s with + | "tnull" -> write ctx (AccInt 0) + | "tint" -> write ctx (AccInt 1) + | "tfloat" -> write ctx (AccInt 2) + | "tbool" -> write ctx (AccInt 3) + | "tstring" -> write ctx (AccInt 4) + | "tobject" -> write ctx (AccInt 5) + | "tarray" -> write ctx (AccInt 6) + | "tfunction" -> write ctx (AccInt 7) + | "tabstract" -> write ctx (AccInt 8) + | s -> + write ctx (AccBuiltin s)) + | Ident s -> + try + let l = PMap.find s ctx.locals in + if l <= ctx.limit then + let e = (try + PMap.find s ctx.env + with Not_found -> + let e = ctx.nenv in + ctx.nenv <- ctx.nenv + 1; + ctx.env <- PMap.add s e ctx.env; + e + ) in + write ctx (AccEnv e); + else + let p = ctx.stack - l in + write ctx (if p = 0 then AccStack0 else if p = 1 then AccStack1 else AccStack p); + with Not_found -> + let g = global ctx (GlobalVar s) in + write ctx (AccGlobal g) + +let rec compile_access ctx e = + match fst e with + | EConst (Ident s) -> + (try + let l = PMap.find s ctx.locals in + if l <= ctx.limit then + let e = (try + PMap.find s ctx.env + with Not_found -> + let e = ctx.nenv in + ctx.nenv <- ctx.nenv + 1; + ctx.env <- PMap.add s e ctx.env; + e + ) in + XEnv e + else + XStack l + with Not_found -> + let g = global ctx (GlobalVar s) in + XGlobal g) + | EField (e,f) -> + compile ctx false e; + write ctx Push; + XField f + | EArray (e1,(EConst (Int n),_)) -> + compile ctx false e1; + write ctx Push; + XIndex n + | EArray (ea,ei) -> + compile ctx false ei; + write ctx Push; + compile ctx false ea; + write ctx Push; + XArray + | EConst This -> + XThis + | _ -> + error "Invalid access" (snd e) + +and compile_access_set ctx a = + match a with + | XEnv n -> write ctx (SetEnv n) + | XStack l -> write ctx (SetStack (ctx.stack - l)) + | XGlobal g -> write ctx (SetGlobal g) + | XField f -> write ctx (SetField f) + | XIndex i -> write ctx (SetIndex i) + | XThis -> write ctx SetThis + | XArray -> write ctx SetArray + +and compile_access_get ctx a = + match a with + | XEnv n -> write ctx (AccEnv n) + | XStack l -> write ctx (AccStack (ctx.stack - l)) + | XGlobal g -> write ctx (AccGlobal g) + | XField f -> write ctx (AccField f) + | XIndex i -> write ctx (AccIndex i) + | XThis -> write ctx AccThis + | XArray -> + write ctx Push; + write ctx (AccStack 2); + write ctx AccArray + +and write_op ctx op p = + match op with + | "+" -> write ctx Add + | "-" -> write ctx Sub + | "/" -> write ctx Div + | "*" -> write ctx Mult + | "%" -> write ctx Mod + | "<<" -> write ctx Shl + | ">>" -> write ctx Shr + | ">>>" -> write ctx UShr + | "|" -> write ctx Or + | "&" -> write ctx And + | "^" -> write ctx Xor + | "==" -> write ctx Eq + | "!=" -> write ctx Neq + | ">" -> write ctx Gt + | ">=" -> write ctx Gte + | "<" -> write ctx Lt + | "<=" -> write ctx Lte + | _ -> error "Unknown operation" p + +and compile_binop ctx tail op e1 e2 p = + match op with + | "=" -> + let a = compile_access ctx e1 in + compile ctx false e2; + compile_access_set ctx a + | "&&" -> + compile ctx false e1; + let jnext = cjmp false ctx in + compile ctx tail e2; + jnext() + | "||" -> + compile ctx false e1; + let jnext = cjmp true ctx in + compile ctx tail e2; + jnext() + | "++=" + | "--=" -> + write ctx Push; + let base = ctx.stack in + let a = compile_access ctx e1 in + compile_access_get ctx a; + write ctx (SetStack(ctx.stack - base)); + write ctx Push; + compile ctx false e2; + write_op ctx (String.sub op 0 (String.length op - 2)) p; + compile_access_set ctx a; + write ctx (AccStack 0); + write ctx (Pop 1); + | "+=" + | "-=" + | "/=" + | "*=" + | "%=" + | "<<=" + | ">>=" + | ">>>=" + | "|=" + | "&=" + | "^=" -> + let a = compile_access ctx e1 in + compile_access_get ctx a; + write ctx Push; + compile ctx false e2; + write_op ctx (String.sub op 0 (String.length op - 1)) p; + compile_access_set ctx a + | _ -> + match (op , e1 , e2) with + | ("==" , _ , (EConst Null,_)) -> + compile ctx false e1; + write ctx IsNull + | ("!=" , _ , (EConst Null,_)) -> + compile ctx false e1; + write ctx IsNotNull + | ("==" , (EConst Null,_) , _) -> + compile ctx false e2; + write ctx IsNull + | ("!=" , (EConst Null,_) , _) -> + compile ctx false e2; + write ctx IsNotNull + | ("-", (EConst (Int 0),_) , (EConst (Int i),_)) -> + compile ctx tail (EConst (Int (-i)),p) + | _ -> + compile ctx false e1; + write ctx Push; + compile ctx false e2; + write_op ctx op p + +and compile_function main params e = + let ctx = { + g = main.g; + (* // reset *) + ops = DynArray.create(); + pos = DynArray.create(); + breaks = []; + continues = []; + env = PMap.empty; + nenv = 0; + traps = []; + limit = main.stack; + (* // dup *) + version = main.version; + stack = main.stack; + locals = main.locals; + loop_limit = main.loop_limit; + curpos = main.curpos; + curfile = main.curfile; + } in + List.iter (fun v -> + ctx.stack <- ctx.stack + 1; + ctx.locals <- PMap.add v ctx.stack ctx.locals; + ) params; + let s = ctx.stack in + compile ctx true e; + write ctx (Ret (ctx.stack - ctx.limit)); + check_stack ctx s (snd e); + check_breaks ctx; + (* // add let *) + let gid = DynArray.length ctx.g.gtable in + ctx.g.functions <- (ctx.ops,ctx.pos,gid,List.length params) :: ctx.g.functions; + DynArray.add ctx.g.gtable (GlobalFunction(gid,-1)); + (* // environment *) + if ctx.nenv > 0 then + let a = Array.make ctx.nenv "" in + PMap.iter (fun v i -> a.(i) <- v) ctx.env; + Array.iter (fun v -> + compile_constant main (Ident v) (snd e); + write main Push; + ) a; + write main (AccGlobal gid); + write main (MakeEnv ctx.nenv); + else + write main (AccGlobal gid); + +and compile_builtin ctx tail b el p = + match (b , el) with + | ("istrue" , [e]) -> + compile ctx false e; + write ctx Bool + | ("not" , [e]) -> + compile ctx false e; + write ctx Not + | ("typeof" , [e]) -> + compile ctx false e; + write ctx TypeOf + | ("hash" , [e]) -> + compile ctx false e; + write ctx Hash + | ("new" , [e]) -> + compile ctx false e; + write ctx New + | ("compare" , [e1;e2]) -> + compile ctx false e1; + write ctx Push; + compile ctx false e2; + write ctx Compare + | ("pcompare" , [e1;e2]) -> + compile ctx false e1; + write ctx Push; + compile ctx false e2; + write ctx PhysCompare + | ("goto" , [(EConst (Ident l) , _)] ) -> + let l = (try Hashtbl.find ctx.g.labels l with Not_found -> error ("Unknown label " ^ l) p) in + let os = ctx.stack in + let rec loop l1 l2 = + match l1, l2 with + | x :: l1 , y :: l2 when x == y -> loop l1 l2 + | _ -> (l1,l2) + in + let straps , dtraps = loop (List.rev ctx.traps) l.ltraps in + List.iter (fun l -> + if ctx.stack <> l then write ctx (Pop(ctx.stack - l)); + write ctx EndTrap; + ) (List.rev straps); + let dtraps = List.map (fun l -> + let l = l - trap_stack_delta in + if l < ctx.stack then write ctx (Pop(ctx.stack - l)); + while ctx.stack < l do + write ctx Push; + done; + trap ctx + ) dtraps in + if l.lstack < ctx.stack then write ctx (Pop(ctx.stack - l.lstack)); + while l.lstack > ctx.stack do + write ctx Push; + done; + ctx.stack <- os; + (match l.lpos with + | None -> l.lwait <- jmp ctx :: l.lwait + | Some p -> write ctx (Jump p)); + List.iter (fun t -> + t(); + write ctx Push; + compile_constant ctx (Builtin "raise") p; + write ctx (Call 1); + (* // insert an infinite loop in order to + // comply with bytecode checker *) + let _ = jmp ctx in + () + ) dtraps; + | ("goto" , _) -> + error "Invalid $goto statement" p + | ("array",e :: el) -> + let count = List.length el in + (* // a single let can't have >128 stack *) + if count > 120 - ctx.stack && count > 8 then begin + (* // split in 8 and recurse *) + let part = count lsr 3 in + let rec loop el acc count = + match el with + | [] -> [List.rev acc] + | e :: l -> + if count == part then + (List.rev acc) :: loop el [] 0 + else + loop l (e :: acc) (count + 1) + in + let arr = make_array p (List.map (make_array p) (loop (e :: el) [] 0)) in + compile_builtin ctx tail "aconcat" [arr] p; + end else if ctx.version >= 2 then begin + compile ctx false e; + List.iter (fun e -> + write ctx Push; + compile ctx false e; + ) el; + write ctx (MakeArray count); + end else begin + List.iter (fun e -> + compile ctx false e; + write ctx Push; + ) el; + compile ctx false e; + write ctx (MakeArray count); + end + | ("apply",e :: el) -> + List.iter (fun e -> + compile ctx false e; + write ctx Push; + ) el; + compile ctx false e; + let nargs = List.length el in + if nargs > 0 then write ctx (Apply nargs); + | _ -> + List.iter (fun e -> + compile ctx false e; + write ctx Push; + ) el; + compile_constant ctx (Builtin b) p; + if tail then + write ctx (TailCall(List.length el,ctx.stack - ctx.limit)) + else + write ctx (Call (List.length el)) + +and compile ctx tail (e,p) = + set_pos ctx p; + match e with + | EConst c -> + compile_constant ctx c p + | EBlock [] -> + write ctx AccNull + | EBlock el -> + let locals = ctx.locals in + let stack = ctx.stack in + let rec loop(el) = + match el with + | [] -> assert false + | [e] -> compile ctx tail e + | [e; (ELabel _,_) as f] -> + compile ctx tail e; + compile ctx tail f + | e :: el -> + compile ctx false e; + loop el + in + loop el; + if stack < ctx.stack then write ctx (Pop (ctx.stack - stack)); + check_stack ctx stack p; + ctx.locals <- locals + | EParenthesis e -> + compile ctx tail e + | EField (e,f) -> + compile ctx false e; + write ctx (AccField f) + | ECall (e,a :: b :: c :: d :: x1 :: x2 :: l) when (match e with (EConst (Builtin "array"),_) -> false | _ -> true) -> + let call = (EConst (Builtin "call"),p) in + let args = (ECall ((EConst (Builtin "array"),p),(a :: b :: c :: d :: x1 :: x2 :: l)),p) in + (match e with + | (EField (e,name) , p2) -> + let locals = ctx.locals in + let etmp = (EConst (Ident "$tmp"),p2) in + compile ctx false (EVars [("$tmp",Some e)],p2); + compile ctx tail (ECall (call,[(EField (etmp,name),p2);etmp;args]), p); + write ctx (Pop 1); + ctx.locals <- locals + | _ -> + compile ctx tail (ECall (call,[e; (EConst This,p); args]),p)) + | ECall ((EConst (Builtin b),_),el) -> + compile_builtin ctx tail b el p + | ECall ((EField (e,f),_),el) -> + List.iter (fun e -> + compile ctx false e; + write ctx Push; + ) el; + compile ctx false e; + write ctx Push; + write ctx (AccField f); + write ctx (ObjCall(List.length el)) + | ECall (e,el) -> + List.iter (fun e -> + compile ctx false e; + write ctx Push; + ) el; + compile ctx false e; + if tail then + write ctx (TailCall(List.length el,ctx.stack - ctx.limit)) + else + write ctx (Call(List.length el)) + | EArray (e1,(EConst (Int n),_)) -> + compile ctx false e1; + write ctx (if n == 0 then AccIndex0 else if n == 1 then AccIndex1 else AccIndex n) + | EArray (e1,e2) -> + compile ctx false e1; + write ctx Push; + compile ctx false e2; + write ctx AccArray + | EVars vl -> + List.iter (fun (v,o) -> + (match o with + | None -> write ctx AccNull + | Some e -> compile ctx false e); + write ctx Push; + ctx.locals <- PMap.add v ctx.stack ctx.locals; + ) vl + | EWhile (econd,e,NormalWhile) -> + let start = pos ctx in + if ctx.version >= 2 then write ctx Loop; + compile ctx false econd; + let jend = cjmp false ctx in + let save = save_breaks ctx in + compile ctx false e; + process_continues save; + goto ctx start; + process_breaks save; + jend(); + | EWhile (econd,e,DoWhile) -> + let start = pos ctx in + if ctx.version >= 2 then write ctx Loop; + let save = save_breaks ctx in + compile ctx false e; + process_continues save; + compile ctx false econd; + write ctx (JumpIf (start - pos ctx)); + process_breaks save + | EIf (e,e1,e2) -> + let stack = ctx.stack in + compile ctx false e; + let jelse = cjmp false ctx in + compile ctx tail e1; + check_stack ctx stack p; + (match e2 with + | None -> + jelse() + | Some e2 -> + let jend = jmp ctx in + jelse(); + compile ctx tail e2; + check_stack ctx stack p; + jend()) + | ETry (e,v,ecatch) -> + let trap = trap ctx in + let breaks = ctx.breaks in + let continues = ctx.continues in + ctx.breaks <- []; + ctx.continues <- []; + ctx.traps <- ctx.stack :: ctx.traps; + compile ctx false e; + if ctx.breaks <> [] then error "Break in try...catch is not allowed" p; + if ctx.continues <> [] then error "Continue in try...catch is not allowed" p; + ctx.breaks <- breaks; + ctx.continues <- continues; + write ctx EndTrap; + ctx.traps <- (match ctx.traps with [] -> assert false | _ :: l -> l); + let jend = jmp ctx in + trap(); + write ctx Push; + let locals = ctx.locals in + ctx.locals <- PMap.add v ctx.stack ctx.locals; + compile ctx tail ecatch; + write ctx (Pop 1); + ctx.locals <- locals; + jend() + | EBinop (op,e1,e2) -> + compile_binop ctx tail op e1 e2 p + | EReturn e -> + (match e with None -> write ctx AccNull | Some e -> compile ctx (ctx.traps == []) e); + let stack = ctx.stack in + List.iter (fun t -> + if ctx.stack > t then write ctx (Pop(ctx.stack - t)); + write ctx EndTrap; + ) ctx.traps; + write ctx (Ret (ctx.stack - ctx.limit)); + ctx.stack <- stack + | EBreak e -> + (match e with + | None -> () + | Some e -> compile ctx false e); + if ctx.loop_limit <> ctx.stack then begin + let s = ctx.stack in + write ctx (Pop(ctx.stack - ctx.loop_limit)); + ctx.stack <- s; + end; + ctx.breaks <- (jmp ctx , p) :: ctx.breaks + | EContinue -> + if ctx.loop_limit <> ctx.stack then begin + let s = ctx.stack in + write ctx (Pop(ctx.stack - ctx.loop_limit)); + ctx.stack <- s; + end; + ctx.continues <- (jmp ctx , p) :: ctx.continues + | EFunction (params,e) -> + compile_function ctx params e + | ENext (e1,e2) -> + compile ctx false e1; + compile ctx tail e2 + | EObject [] -> + write ctx AccNull; + write ctx New + | EObject fl -> + let fields = List.sort compare (List.map fst fl) in + let id = (try + Hashtbl.find ctx.g.gobjects fields + with Not_found -> + let id = global ctx (GlobalVar ("o:" ^ string_of_int (Hashtbl.length ctx.g.gobjects))) in + Hashtbl.add ctx.g.gobjects fields id; + id + ) in + write ctx (AccGlobal id); + write ctx New; + write ctx Push; + List.iter (fun (f,e) -> + write ctx Push; + compile ctx false e; + write ctx (SetField f); + write ctx AccStack0; + ) fl; + write ctx (Pop 1) + | ELabel l -> + let l = (try Hashtbl.find ctx.g.labels l with Not_found -> assert false) in + if ctx.stack <> l.lstack || List.rev ctx.traps <> l.ltraps then error (Printf.sprintf "Label failure %d %d" ctx.stack l.lstack) p; + List.iter (fun f -> f()) l.lwait; + l.lwait <- []; + l.lpos <- Some (pos ctx) + | ESwitch (e,[(econd,exec)],eo) -> + compile ctx tail (EIf ((EBinop ("==",e,econd),p),exec,eo),p) + | ENeko _ -> + assert false + | ESwitch (e,cases,eo) -> + try + let ints , size = get_cases_ints cases in + compile ctx false e; + write ctx (JumpTable size); + let tbl = Array.make size None in + List.iter (fun (i,e) -> + tbl.(i) <- Some e; + ) ints; + let tbl = Array.map (fun e -> (jmp ctx,e)) tbl in + Array.iter (fun (j,e) -> + if e == None then j() + ) tbl; + (match eo with + | None -> write ctx AccNull + | Some e -> compile ctx tail e); + let jump_end = jmp ctx in + let tbl = Array.map (fun (j,e) -> + match e with + | Some e -> + j(); + compile ctx tail e; + jmp ctx + | None -> + (fun() -> ()) + ) tbl in + jump_end(); + Array.iter (fun j -> j()) tbl + with Exit -> + compile ctx false e; + write ctx Push; + let jumps = List.map (fun (e1,e2) -> + write ctx AccStack0; + write ctx Push; + compile ctx false e1; + write ctx Eq; + (cjmp true ctx , e2) + ) cases in + (match eo with + | None -> write ctx AccNull + | Some e -> compile ctx tail (EBlock [e],p)); + let jump_end = jmp ctx in + let jumps = List.map (fun (j,e) -> + j(); + compile ctx tail (EBlock [e],p); + jmp ctx; + ) jumps in + jump_end(); + List.iter (fun j -> j()) jumps; + write ctx (Pop 1) + +let compile version ast = + let g = { + globals = Hashtbl.create 0; + gobjects = Hashtbl.create 0; + gtable = DynArray.create(); + functions = []; + labels = Hashtbl.create 0; + hfiles = Hashtbl.create 0; + files = DynArray.create(); + } in + let ctx = { + g = g; + version = version; + stack = 0; + loop_limit = 0; + limit = -1; + locals = PMap.empty; + ops = DynArray.create(); + breaks = []; + continues = []; + env = PMap.empty; + nenv = 0; + traps = []; + pos = DynArray.create(); + curpos = (0,0); + curfile = "_"; + } in + if version >= 2 then DynArray.add g.gtable (GlobalVersion version); + scan_labels ctx true true ast; + compile ctx false ast; + check_breaks ctx; + if g.functions <> [] || Hashtbl.length g.gobjects <> 0 then begin + let ctxops = ctx.ops in + let ctxpos = ctx.pos in + let ops = DynArray.create() in + let pos = DynArray.create() in + ctx.pos <- pos; + ctx.ops <- ops; + write ctx (Jump 0); + List.iter (fun (fops,fpos,gid,nargs) -> + DynArray.set g.gtable gid (GlobalFunction(DynArray.length ops,nargs)); + DynArray.append fops ops; + DynArray.append fpos pos; + ) (List.rev g.functions); + DynArray.set ops 0 (Jump (DynArray.length ops)); + let objects = DynArray.create() in + Hashtbl.iter (fun fl g -> DynArray.add objects (fl,g)) g.gobjects; + let objects = DynArray.to_array objects in + Array.sort (fun (_,g1) (_,g2) -> g1 - g2) objects; + Array.iter (fun (fl,g) -> + write ctx AccNull; + write ctx New; + write ctx (SetGlobal g); + List.iter (fun f -> + write ctx (AccGlobal g); + write ctx Push; + write ctx (SetField f); + ) fl + ) objects; + DynArray.append ctxpos pos; + DynArray.append ctxops ops; + end; + DynArray.add g.gtable (GlobalDebug (DynArray.to_array ctx.g.files,DynArray.to_array ctx.pos)); + (DynArray.to_array g.gtable, DynArray.to_array ctx.ops) + diff --git a/neko/libs/include/ocaml/nxml.ml b/libs/neko/nxml.ml similarity index 98% rename from neko/libs/include/ocaml/nxml.ml rename to libs/neko/nxml.ml index 0e9286f678ff386bca69be5974822208da7e3528..8dbe61dc4f13fe0e13847a4b170f2dc4dfde872f 100644 --- a/neko/libs/include/ocaml/nxml.ml +++ b/libs/neko/nxml.ml @@ -49,6 +49,9 @@ let rec to_xml_rec p2 ast = | String s -> name := "s"; aval := Some s; + | Int32 i -> + name := "i"; + aval := Some (Int32.to_string i); ) | EBlock el -> name := "b"; diff --git a/libs/ocamake/ocamake.dsp b/libs/ocamake/ocamake.dsp new file mode 100644 index 0000000000000000000000000000000000000000..e18f64b0951e05a07044c611782a5f1c31d0219d --- /dev/null +++ b/libs/ocamake/ocamake.dsp @@ -0,0 +1,66 @@ +# 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 diff --git a/libs/ocamake/ocamake.dsw b/libs/ocamake/ocamake.dsw new file mode 100644 index 0000000000000000000000000000000000000000..a5e699a475d9d7dc238765c9992f301b3b331f20 --- /dev/null +++ b/libs/ocamake/ocamake.dsw @@ -0,0 +1,29 @@ +Microsoft 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> +{{{ +}}} + +############################################################################### + diff --git a/libs/ocamake/ocamake.html b/libs/ocamake/ocamake.html new file mode 100644 index 0000000000000000000000000000000000000000..1e0e613e20605cf08e129d6052559254ed5d7b33 --- /dev/null +++ b/libs/ocamake/ocamake.html @@ -0,0 +1,94 @@ + + +
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. + +
+
+ +