diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 17d25d27f31..0f28548a6b6 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -371,7 +371,7 @@ jobs: fail-fast: false matrix: ocaml: ["4.08.1", "5.0.0"] - target: [macro, js, hl, cpp, 'java,jvm', cs, php, python, lua, flash, neko] + target: [macro, js, hl, cpp, jvm, php, python, lua, flash, neko] include: - target: hl APT_PACKAGES: cmake ninja-build libturbojpeg-dev @@ -519,7 +519,7 @@ jobs: haxe dox.hxml mkdir resources cp ../../src-json/* resources - cpp/Dox -i ../../xmldoc -ex microsoft -ex javax -ex cs.internal -theme $(haxelib libpath dox)/themes/default + cpp/Dox -i ../../xmldoc -ex microsoft -ex javax -theme $(haxelib libpath dox)/themes/default working-directory: ${{github.workspace}}/tests/docgen linux-arm64: @@ -616,23 +616,16 @@ jobs: - name: Install dependencies env: # For compatibility with macOS 10.13 - ZLIB_VERSION: 1.3 + ZLIB_VERSION: 1.3.1 MBEDTLS_VERSION: 2.28.5 PCRE2_VERSION: 10.42 run: | set -ex - brew uninstall openssl@1.0.2t || echo - brew uninstall python@2.7.17 || echo - brew untap local/openssl || echo - brew untap local/python2 || echo brew update - # brew unlink python@2 - brew bundle --file=tests/Brewfile --no-upgrade || brew link --overwrite awscli - brew install libunistring - brew install cpanminus + brew bundle --file=tests/Brewfile --no-upgrade cpanm IPC::System::Simple cpanm String::ShellQuote - curl -L https://www.zlib.net/zlib-$ZLIB_VERSION.tar.gz | tar xz + curl -L https://github.com/madler/zlib/releases/download/v$ZLIB_VERSION/zlib-$ZLIB_VERSION.tar.gz | tar xz cd zlib-$ZLIB_VERSION ./configure make && make install @@ -697,7 +690,7 @@ jobs: fail-fast: false matrix: # TODO enable lua after https://github.com/HaxeFoundation/haxe/issues/10919 - target: [macro, js, hl, cpp, 'java,jvm', cs, php, python, flash, neko] + target: [macro, js, hl, cpp, jvm, php, python, flash, neko] steps: - uses: actions/checkout@main with: @@ -794,7 +787,7 @@ jobs: matrix: # TODO jvm: https://github.com/HaxeFoundation/haxe/issues/8601 # TODO enable lua after https://github.com/HaxeFoundation/haxe/issues/10919 - target: [macro, js, hl, cpp, java, cs, php, python, flash, neko] + target: [macro, js, hl, cpp, php, python, flash, neko] steps: - uses: actions/checkout@main with: @@ -888,7 +881,7 @@ jobs: strategy: fail-fast: false matrix: - target: [macro, js, hl, cpp, 'java,jvm', cs, php, python, flash, neko] + target: [macro, js, hl, cpp, jvm, php, python, flash, neko] include: - target: hl BREW_PACKAGES: ninja diff --git a/.vscode/schemas/meta.schema.json b/.vscode/schemas/meta.schema.json index b2dee2053c8..cc9e2ff4199 100644 --- a/.vscode/schemas/meta.schema.json +++ b/.vscode/schemas/meta.schema.json @@ -29,8 +29,7 @@ "flash", "php", "cpp", - "cs", - "java", + "jvm", "python", "hl", "eval" diff --git a/Earthfile b/Earthfile index dda473f6c60..00baadef0eb 100644 --- a/Earthfile +++ b/Earthfile @@ -221,7 +221,6 @@ xmldoc: RUN haxelib newrepo RUN haxelib git hxcpp https://github.com/HaxeFoundation/hxcpp RUN haxelib git hxjava https://github.com/HaxeFoundation/hxjava - RUN haxelib git hxcs https://github.com/HaxeFoundation/hxcs RUN haxe doc.hxml ARG COMMIT @@ -271,11 +270,6 @@ test-environment-php: DO +INSTALL_PACKAGES --PACKAGES="php-cli php-mbstring php-sqlite3" SAVE IMAGE --cache-hint -test-environment-cs: - FROM +test-environment - DO +INSTALL_PACKAGES --PACKAGES="mono-devel mono-mcs" - SAVE IMAGE --cache-hint - test-environment-hl: FROM +test-environment DO +INSTALL_PACKAGES --PACKAGES="cmake ninja-build libturbojpeg-dev libpng-dev zlib1g-dev libvorbis-dev libsqlite3-dev" @@ -361,12 +355,6 @@ test-jvm: ENV GITHUB_ACTIONS=$GITHUB_ACTIONS DO +RUN_CI --TEST=jvm -test-cs: - FROM +test-environment-cs - ARG GITHUB_ACTIONS - ENV GITHUB_ACTIONS=$GITHUB_ACTIONS - DO +RUN_CI --TEST=cs - test-php: FROM +test-environment-php ARG GITHUB_ACTIONS @@ -400,7 +388,6 @@ test-all: BUILD +test-python BUILD +test-java BUILD +test-jvm - BUILD +test-cs BUILD +test-cpp BUILD +test-lua BUILD +test-js diff --git a/Makefile b/Makefile index a369415b02b..634c698d403 100644 --- a/Makefile +++ b/Makefile @@ -162,7 +162,6 @@ xmldoc: $(CURDIR)/$(HAXELIB_OUTPUT) newrepo && \ $(CURDIR)/$(HAXELIB_OUTPUT) git hxcpp https://github.com/HaxeFoundation/hxcpp && \ $(CURDIR)/$(HAXELIB_OUTPUT) git hxjava https://github.com/HaxeFoundation/hxjava && \ - $(CURDIR)/$(HAXELIB_OUTPUT) git hxcs https://github.com/HaxeFoundation/hxcs && \ PATH="$(CURDIR):$(PATH)" $(CURDIR)/$(HAXE_OUTPUT) doc.hxml $(INSTALLER_TMP_DIR): diff --git a/README.md b/README.md index b7ee7589db0..2d17ef3d6a3 100644 --- a/README.md +++ b/README.md @@ -21,8 +21,6 @@ Haxe allows you to compile for the following targets: * JavaScript * C++ - * C# - * Java * JVM * Lua * PHP 7 diff --git a/extra/BUILDING.md b/extra/BUILDING.md index dc22b45c1c9..a5c7e986f04 100644 --- a/extra/BUILDING.md +++ b/extra/BUILDING.md @@ -36,7 +36,7 @@ You need to install some native libraries as well as some OCaml libraries. To install the native libraries, use the appropriate system package manager. * Mac OS X - * Use [Homebrew](https://brew.sh/), `brew install zlib pcre2 mbedtls@2`. + * Use [Homebrew](https://brew.sh/), `brew install zlib pcre2 mbedtls`. * Debian / Ubuntu * `sudo apt install libpcre2-dev zlib1g-dev libmbedtls-dev`. * Windows (Cygwin) diff --git a/extra/ImportAll.hx b/extra/ImportAll.hx index 390266bb8c7..a0818d1f3c7 100644 --- a/extra/ImportAll.hx +++ b/extra/ImportAll.hx @@ -25,7 +25,7 @@ class ImportAll { static function isSysTarget() { return Context.defined("neko") || Context.defined("php") || Context.defined("cpp") || - Context.defined("java") || Context.defined("python") || + Context.defined("jvm") || Context.defined("python") || Context.defined("lua") || Context.defined("hl") || Context.defined("eval"); } @@ -51,12 +51,8 @@ class ImportAll { if(!isSysTarget()) return; case "sys.thread": if ( !Context.defined("target.threaded") ) return; - case "java": - if( !Context.defined("java") ) return; - case "jvm": + case "java" | "jvm": if( !Context.defined("jvm") ) return; - case "cs": - if( !Context.defined("cs") ) return; case "python": if ( !Context.defined("python") ) return; case "hl": @@ -96,7 +92,6 @@ class ImportAll { case "haxe.remoting.SocketWrapper": if( !Context.defined("flash") ) continue; case "haxe.remoting.SyncSocketConnection": if( !(Context.defined("neko") || Context.defined("php") || Context.defined("cpp")) ) continue; case "neko.vm.Ui" | "sys.db.Sqlite" | "sys.db.Mysql" if ( Context.defined("interp") ): continue; - case "sys.db.Sqlite" | "sys.db.Mysql" | "cs.db.AdoNet" if ( Context.defined("cs") ): continue; case "haxe.atomic.AtomicBool" if(!Context.defined("target.atomics")): continue; case "haxe.atomic.AtomicInt" if(!Context.defined("target.atomics")): continue; case "haxe.atomic.AtomicObject" if(!Context.defined("target.atomics") || Context.defined("js") || Context.defined("cpp")): continue; diff --git a/extra/all.hxml b/extra/all.hxml index 9b8b7804523..f4446e51624 100644 --- a/extra/all.hxml +++ b/extra/all.hxml @@ -28,19 +28,10 @@ -xml cpp.xml -D HXCPP_MULTI_THREADED ---next --java all_java --xml java.xml - --next --jvm all_jvm -xml jvm.xml ---next --cs all_cs --D unsafe --xml cs.xml - --next -python all_python -xml python.xml diff --git a/extra/doc.hxml b/extra/doc.hxml index fa8b532121e..9a37c68e0f1 100644 --- a/extra/doc.hxml +++ b/extra/doc.hxml @@ -31,13 +31,8 @@ -D HXCPP_MULTI_THREADED --next --java all_java --xml doc/java.xml - ---next --cs all_cs --D unsafe --xml doc/cs.xml +--jvm all_jvm +-xml doc/jvm.xml --next -python all_py diff --git a/extra/github-actions/build-mac.yml b/extra/github-actions/build-mac.yml index d68882a90de..518912aff7a 100644 --- a/extra/github-actions/build-mac.yml +++ b/extra/github-actions/build-mac.yml @@ -1,23 +1,16 @@ - name: Install dependencies env: # For compatibility with macOS 10.13 - ZLIB_VERSION: 1.3 + ZLIB_VERSION: 1.3.1 MBEDTLS_VERSION: 2.28.5 PCRE2_VERSION: 10.42 run: | set -ex - brew uninstall openssl@1.0.2t || echo - brew uninstall python@2.7.17 || echo - brew untap local/openssl || echo - brew untap local/python2 || echo brew update - # brew unlink python@2 - brew bundle --file=tests/Brewfile --no-upgrade || brew link --overwrite awscli - brew install libunistring - brew install cpanminus + brew bundle --file=tests/Brewfile --no-upgrade cpanm IPC::System::Simple cpanm String::ShellQuote - curl -L https://www.zlib.net/zlib-$ZLIB_VERSION.tar.gz | tar xz + curl -L https://github.com/madler/zlib/releases/download/v$ZLIB_VERSION/zlib-$ZLIB_VERSION.tar.gz | tar xz cd zlib-$ZLIB_VERSION ./configure make && make install diff --git a/extra/github-actions/workflows/main.yml b/extra/github-actions/workflows/main.yml index 4b2825ccb37..767cf731fef 100644 --- a/extra/github-actions/workflows/main.yml +++ b/extra/github-actions/workflows/main.yml @@ -153,7 +153,7 @@ jobs: fail-fast: false matrix: ocaml: ["4.08.1", "5.0.0"] - target: [macro, js, hl, cpp, 'java,jvm', cs, php, python, lua, flash, neko] + target: [macro, js, hl, cpp, jvm, php, python, lua, flash, neko] include: - target: hl APT_PACKAGES: cmake ninja-build libturbojpeg-dev @@ -269,7 +269,7 @@ jobs: haxe dox.hxml mkdir resources cp ../../src-json/* resources - cpp/Dox -i ../../xmldoc -ex microsoft -ex javax -ex cs.internal -theme $(haxelib libpath dox)/themes/default + cpp/Dox -i ../../xmldoc -ex microsoft -ex javax -theme $(haxelib libpath dox)/themes/default working-directory: ${{github.workspace}}/tests/docgen linux-arm64: @@ -362,7 +362,7 @@ jobs: fail-fast: false matrix: # TODO enable lua after https://github.com/HaxeFoundation/haxe/issues/10919 - target: [macro, js, hl, cpp, 'java,jvm', cs, php, python, flash, neko] + target: [macro, js, hl, cpp, jvm, php, python, flash, neko] steps: - uses: actions/checkout@main with: @@ -389,7 +389,7 @@ jobs: matrix: # TODO jvm: https://github.com/HaxeFoundation/haxe/issues/8601 # TODO enable lua after https://github.com/HaxeFoundation/haxe/issues/10919 - target: [macro, js, hl, cpp, java, cs, php, python, flash, neko] + target: [macro, js, hl, cpp, php, python, flash, neko] steps: - uses: actions/checkout@main with: @@ -413,7 +413,7 @@ jobs: strategy: fail-fast: false matrix: - target: [macro, js, hl, cpp, 'java,jvm', cs, php, python, flash, neko] + target: [macro, js, hl, cpp, jvm, php, python, flash, neko] include: - target: hl BREW_PACKAGES: ninja diff --git a/extra/haxelib_src b/extra/haxelib_src index 70ff6b69a5b..98637027327 160000 --- a/extra/haxelib_src +++ b/extra/haxelib_src @@ -1 +1 @@ -Subproject commit 70ff6b69a5b35049d767056555c0bf7a54e8ad4e +Subproject commit 98637027327d8cf385d302acaaf104bd6107d2bf diff --git a/extra/release-checklist.txt b/extra/release-checklist.txt index 890a500cbf1..7232112bc75 100644 --- a/extra/release-checklist.txt +++ b/extra/release-checklist.txt @@ -2,7 +2,7 @@ - Check that haxelib is working - Make sure to update the haxelib submodule -- Check that the run-time haxelibs are ready for release: hxcpp, hxjava, hxcs +- Check that the run-time haxelibs are ready for release: hxcpp, hxjava - Check that the NEKO_VERSION variable in the "Makefile" is set to the latest Neko version # Making the release @@ -23,6 +23,8 @@ - If everything was working, run the command again without `--dry` - Update https://github.com/HaxeFoundation/haxe.org/blob/staging/downloads/versions.json - Wait for staging to update, check everything related to release and merge to master +- Update https://github.com/HaxeFoundation/api.haxe.org/blob/master/theme/templates/topbar.mtt +- Update https://github.com/HaxeFoundation/code-cookbook/blob/master/assets/content/index.mtt#L62-L63 # Cleanup diff --git a/haxe.opam b/haxe.opam index e93455e01f1..6b8d4f8d8f1 100644 --- a/haxe.opam +++ b/haxe.opam @@ -20,7 +20,7 @@ install: [make "install" "INSTALL_DIR=%{prefix}%"] remove: [make "uninstall" "INSTALL_DIR=%{prefix}%"] depends: [ ("ocaml" {>= "5.0"} & ("camlp5" {build})) - | ("ocaml" {>= "4.08" & < "5.0"} & ("camlp5" {build & = "8.00"})) + | ("ocaml" {>= "4.08" & < "5.0"} & ("camlp5" {build & = "8.00.03"})) "ocamlfind" {build} "dune" {>= "1.11"} "sedlex" {>= "2.0"} diff --git a/libs/Makefile b/libs/Makefile index d0b240a9d64..09637139c63 100644 --- a/libs/Makefile +++ b/libs/Makefile @@ -1,7 +1,7 @@ OCAMLOPT = ocamlopt OCAMLC = ocamlc TARGET_FLAG = all -LIBS=extlib-leftovers extc neko javalib ilib swflib ttflib objsize pcre2 ziplib +LIBS=extlib-leftovers extc neko javalib ilib swflib objsize pcre2 ziplib all: $(LIBS) $(LIBS): @@ -14,7 +14,6 @@ clean: $(MAKE) -C javalib clean $(MAKE) -C ilib clean $(MAKE) -C swflib clean - $(MAKE) -C ttflib clean $(MAKE) -C objsize clean $(MAKE) -C pcre2 clean $(MAKE) -C ziplib clean diff --git a/libs/ilib/Makefile b/libs/ilib/Makefile deleted file mode 100644 index 11aaec9f268..00000000000 --- a/libs/ilib/Makefile +++ /dev/null @@ -1,26 +0,0 @@ -OCAMLOPT=ocamlopt -OCAMLC=ocamlc - -SRCS=peData.ml peReader.ml peWriter.ml ilMeta.mli ilData.mli ilMetaTools.ml ilMetaDebug.ml ilMetaReader.ml - -all: native bytecode - -native: ilib.cmxa -bytecode: ilib.cma - -ilib.cmxa: $(SRCS) - ocamlfind $(OCAMLOPT) -g -package extlib -safe-string -a -o ilib.cmxa $(SRCS) - -ilib.cma: $(SRCS) - ocamlfind $(OCAMLC) -g -package extlib -safe-string -a -o ilib.cma $(SRCS) - -dump: ilib.cmxa dump.ml peDataDebug.ml ilMetaDebug.ml - ocamlfind $(OCAMLOPT) -g -package extlib -safe-string -o dump ../extlib/extLib.cmxa ilib.cmxa peDataDebug.ml dump.ml - -clean: - rm -f ilib.cma ilib.cmxa ilib.lib ilib.a $(wildcard *.cmx) $(wildcard *.cmo) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi) dump - -.PHONY: all bytecode native clean - -Makefile: ; -$(SRCS): ; diff --git a/libs/ilib/dump.ml b/libs/ilib/dump.ml deleted file mode 100644 index 6a2d1f764b8..00000000000 --- a/libs/ilib/dump.ml +++ /dev/null @@ -1,38 +0,0 @@ -open PeDataDebug;; -open PeData;; -open PeReader;; -open Printf;; -open IlData;; -open IlMetaTools;; -open IlMetaDebug;; - -let main () = - if Array.length Sys.argv <> 2 then - print_endline "Usage: dump " - else begin - let r = create_r (open_in Sys.argv.(1)) PMap.empty in - let ctx = read r in - let pe = ctx.pe_header in - print_endline (coff_header_s pe.pe_coff_header); - print_endline (pe_header_s pe); - let idata = read_idata ctx in - List.iter (fun t -> print_endline (idata_table_s t)) idata; - let clr_header = read_clr_header ctx in - print_endline (clr_header_s (clr_header)); - let cache = IlMetaReader.create_cache () in - let meta = IlMetaReader.read_meta_tables ctx clr_header cache in - Hashtbl.iter (fun path _ -> - print_endline ("\n\nclass " ^ path_s path ^ ": "); - let cls = convert_class meta path in - List.iter (fun t -> printf "%d: <%s> " t.tnumber (if t.tname = None then "_" else Option.get t.tname)) cls.ctypes; - printf "\n\tis nested: %s - %s\n" (string_of_bool (cls.cenclosing <> None)) (if cls.cenclosing = None then "None" else path_s (Option.get cls.cenclosing)); - print_endline "\tfields:"; - List.iter (fun f -> printf "\t\t%s : %s\n" f.fname (ilsig_s f.fsig.ssig)) cls.cfields; - print_endline "\tmethods:"; - List.iter (fun m -> printf "\t\t%s : %s\n" m.mname (ilsig_s m.msig.ssig)) cls.cmethods; - print_endline "\tprops:"; - List.iter (fun p -> printf "\t\t%s : %s\n" p.pname (ilsig_s p.psig.ssig)) cls.cprops; - ) meta.il_typedefs - end;; - -main() diff --git a/libs/ilib/dune b/libs/ilib/dune deleted file mode 100644 index 52a6fd81fb1..00000000000 --- a/libs/ilib/dune +++ /dev/null @@ -1,15 +0,0 @@ -(include_subdirs no) - -(env - (_ - (flags (-w -3 -w -27)) - ) -) - -(library - (name ilib) - (modules_without_implementation ilData ilMeta) - (modules (:standard \ dump)) - (libraries extlib) - (wrapped false) -) diff --git a/libs/ilib/ilData.mli b/libs/ilib/ilData.mli deleted file mode 100644 index 377fa234dfe..00000000000 --- a/libs/ilib/ilData.mli +++ /dev/null @@ -1,115 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) -open IlMeta;; - -type ilpath = string list * string list * string - -type ilsig = IlMeta.ilsig - -and ilsig_norm = - | LVoid | LBool | LChar - | LInt8 | LUInt8 | LInt16 - | LUInt16 | LInt32 | LUInt32 - | LInt64 | LUInt64 | LFloat32 - | LFloat64 | LString | LObject - | LPointer of ilsig_norm - | LTypedReference | LIntPtr | LUIntPtr - | LManagedPointer of ilsig_norm - | LValueType of ilpath * ilsig_norm list - | LClass of ilpath * ilsig_norm list - | LTypeParam of int - | LMethodTypeParam of int - | LVector of ilsig_norm - | LArray of ilsig_norm * (int option * int option) array - | LMethod of callconv list * ilsig_norm * (ilsig_norm list) - | LSentinel - -and ilsig_t = { - snorm : ilsig_norm; - ssig : ilsig; -} - -type ilversion = int * int (* minor + major *) - -type ilclass = { - cpath : ilpath; - cflags : type_def_flags; - csuper : ilsig_t option; - cfields : ilfield list; - cmethods : ilmethod list; - cimplements : ilsig_t list; - ctypes : type_param list; - cprops : ilprop list; - cevents : ilevent list; - (* cevents : *) - cenclosing : ilpath option; - cnested : ilpath list; - cattrs : meta_custom_attribute list; -} - -and type_param = { - tnumber : int; - tflags : generic_flags; - tname : string option; - tconstraints : ilsig_t list; -} - -and ilevent = { - ename : string; - eflags : event_flags; - eadd : (string * method_flags) option; - eremove : (string * method_flags) option; - eraise : (string * method_flags) option; - esig : ilsig_t; -} - -and ilfield = { - fname : string; - fflags : field_flags; - fsig : ilsig_t; - fconstant : constant option; -} - -and ilmethod = { - mname : string; - mflags : method_flags; - msig : ilsig_t; - margs : ilmethod_arg list; - mret : ilsig_t; - moverride : (ilpath * string) option; (* method_impl *) - (* refers to the signature of the declaring class *) - mtypes : type_param list; - msemantics : semantic_flags; -} - -and ilmethod_arg = string * param_flags * ilsig_t - -and ilprop = { - pname : string; - psig : ilsig_t; - pflags : property_flags; - pget : (string * method_flags) option; - pset : (string * method_flags) option; -} - -type ilctx = { - il_tables : (clr_meta DynArray.t) array; - il_relations : (meta_pointer, clr_meta) Hashtbl.t; - il_typedefs : (ilpath, meta_type_def) Hashtbl.t; -} diff --git a/libs/ilib/ilMeta.mli b/libs/ilib/ilMeta.mli deleted file mode 100644 index c0d74bdb8dc..00000000000 --- a/libs/ilib/ilMeta.mli +++ /dev/null @@ -1,1204 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) - -open PeData;; - -(* useful types for describing CLI metadata *) -type guid = string - (* reference from the #GUID stream *) -type stringref = string - (* reference from the #Strings stream *) -type blobref = string - (* reference from the #Blob stream *) -type id = stringref - (* a stringref that references an identifier. *) - (* must begin with an alphabetic character, or the following characters: *) - (* #, $, @, _ *) - (* and continue with alphanumeric characters or one of the following: *) - (* ?, $, @, _, ` *) - -type ns = id list - -type rid = int - (* record id on a specified meta table *) - -type clr_meta_idx = - (* strongly-type each table index *) - | IModule | ITypeRef | ITypeDef | IFieldPtr - | IField | IMethodPtr | IMethod | IParamPtr - | IParam | IInterfaceImpl | IMemberRef | IConstant - | ICustomAttribute | IFieldMarshal | IDeclSecurity - | IClassLayout | IFieldLayout | IStandAloneSig - | IEventMap | IEventPtr | IEvent | IPropertyMap - | IPropertyPtr | IProperty | IMethodSemantics - | IMethodImpl | IModuleRef | ITypeSpec | IImplMap - | IFieldRVA | IENCLog | IENCMap | IAssembly - | IAssemblyProcessor | IAssemblyOS | IAssemblyRef - | IAssemblyRefProcessor | IAssemblyRefOS - | IFile | IExportedType | IManifestResource | INestedClass - | IGenericParam | IMethodSpec | IGenericParamConstraint - (* reserved metas *) - | IR0x2D | IR0x2E | IR0x2F - | IR0x30 | IR0x31 | IR0x32 | IR0x33 | IR0x34 | IR0x35 | IR0x36 | IR0x37 - | IR0x38 | IR0x39 | IR0x3A | IR0x3B | IR0x3C | IR0x3D | IR0x3E | IR0x3F - (* coded tokens *) - | ITypeDefOrRef | IHasConstant | IHasCustomAttribute - | IHasFieldMarshal | IHasDeclSecurity | IMemberRefParent - | IHasSemantics | IMethodDefOrRef | IMemberForwarded | IImplementation - | ICustomAttributeType | IResolutionScope | ITypeOrMethodDef - -type meta_pointer = clr_meta_idx * rid - (* generic reference to the meta table *) - -(* starting with all annotations of special coded types *) -type type_def_or_ref = clr_meta -and has_const = clr_meta -and has_custom_attribute = clr_meta -and has_field_marshal = clr_meta -and has_decl_security = clr_meta -and member_ref_parent = clr_meta -and has_semantics = clr_meta -and method_def_or_ref = clr_meta -and member_forwarded = clr_meta -and implementation = clr_meta -and custom_attribute_type = clr_meta -and resolution_scope = clr_meta -and type_or_method_def = clr_meta - -and clr_meta = - | Module of meta_module - (* the current module descriptor *) - | TypeRef of meta_type_ref - (* class reference descriptors *) - | TypeDef of meta_type_def - (* class or interface definition descriptors *) - | FieldPtr of meta_field_ptr - (* a class-to-fields lookup table - does not exist in optimized metadatas *) - | Field of meta_field - (* field definition descriptors *) - | MethodPtr of meta_method_ptr - (* a class-to-methods lookup table - does not exist in optimized metadatas *) - | Method of meta_method - (* method definition descriptors *) - | ParamPtr of meta_param_ptr - (* a method-to-parameters lookup table - does not exist in optimized metadatas *) - | Param of meta_param - (* parameter definition descriptors *) - | InterfaceImpl of meta_interface_impl - (* interface implementation descriptors *) - | MemberRef of meta_member_ref - (* member (field or method) reference descriptors *) - | Constant of meta_constant - (* constant value that map the default values stored in the #Blob stream to *) - (* respective fields, parameters and properties *) - | CustomAttribute of meta_custom_attribute - (* custom attribute descriptors *) - | FieldMarshal of meta_field_marshal - (* field or parameter marshaling descriptors for managed/unmanaged interop *) - | DeclSecurity of meta_decl_security - (* security descriptors *) - | ClassLayout of meta_class_layout - (* class layout descriptors that hold information about how the loader should lay out respective classes *) - | FieldLayout of meta_field_layout - (* field layout descriptors that specify the offset or oridnal of individual fields *) - | StandAloneSig of meta_stand_alone_sig - (* stand-alone signature descriptors. used in two capacities: *) - (* as composite signatures of local variables of methods *) - (* and as parameters of the call indirect (calli) IL instruction *) - | EventMap of meta_event_map - (* a class-to-events mapping table. exists also in optimized metadatas *) - | EventPtr of meta_event_ptr - (* an event map-to-events lookup table - does not exist in optimized metadata *) - | Event of meta_event - (* event descriptors *) - | PropertyMap of meta_property_map - (* a class-to-properties mapping table. exists also in optimized metadatas *) - | PropertyPtr of meta_property_ptr - (* a property map-to-properties lookup table - does not exist in optimized metadata *) - | Property of meta_property - (* property descriptors *) - | MethodSemantics of meta_method_semantics - (* method semantics descriptors that hold information about which method is associated *) - (* with a specific property or event and in what capacity *) - | MethodImpl of meta_method_impl - (* method implementation descriptors *) - | ModuleRef of meta_module_ref - (* module reference descriptors *) - | TypeSpec of meta_type_spec - (* Type specification descriptors *) - | ImplMap of meta_impl_map - (* implementation map descriptors used for platform invocation (P/Invoke) *) - | FieldRVA of meta_field_rva - (* field-to-data mapping descriptors *) - | ENCLog of meta_enc_log - (* edit-and-continue log descriptors that hold information about what changes *) - (* have been made to specific metadata items during in-memory editing *) - (* this table does not exist on optimized metadata *) - | ENCMap of meta_enc_map - (* edit-and-continue mapping descriptors. does not exist on optimized metadata *) - | Assembly of meta_assembly - (* the current assembly descriptor, which should appear only in the prime module metadata *) - | AssemblyProcessor of meta_assembly_processor | AssemblyOS of meta_assembly_os - (* unused *) - | AssemblyRef of meta_assembly_ref - (* assembly reference descriptors *) - | AssemblyRefProcessor of meta_assembly_ref_processor | AssemblyRefOS of meta_assembly_ref_os - (* unused *) - | File of meta_file - (* file descriptors that contain information about other files in the current assembly *) - | ExportedType of meta_exported_type - (* exported type descriptors that contain information about public classes *) - (* exported by the current assembly, which are declared in other modules of the assembly *) - (* only the prime module of the assembly should carry this table *) - | ManifestResource of meta_manifest_resource - (* managed resource descriptors *) - | NestedClass of meta_nested_class - (* nested class descriptors that provide mapping of nested classes to their respective enclosing classes *) - | GenericParam of meta_generic_param - (* type parameter descriptors for generic classes and methods *) - | MethodSpec of meta_method_spec - (* generic method instantiation descriptors *) - | GenericParamConstraint of meta_generic_param_constraint - (* descriptors of constraints specified for type parameters of generic classes and methods *) - | UnknownMeta of int - -(* all fields here need to be mutable, as they will first be initialized empty *) - -and meta_root = { - root_id : int; -} - -and meta_root_ptr = { - ptr_id : int; - ptr_to : meta_root; -} - -and meta_module = { - mutable md_id : int; - mutable md_generation : int; - mutable md_name : id; - mutable md_vid : guid; - mutable md_encid : guid; - mutable md_encbase_id : guid; -} - -and meta_type_ref = { - mutable tr_id : int; - mutable tr_resolution_scope : resolution_scope; - mutable tr_name : id; - mutable tr_namespace : ns; -} - -and meta_type_def = { - mutable td_id : int; - mutable td_flags : type_def_flags; - mutable td_name : id; - mutable td_namespace : ns; - mutable td_extends : type_def_or_ref option; - mutable td_field_list : meta_field list; - mutable td_method_list : meta_method list; - - (* extra field *) - mutable td_extra_enclosing : meta_type_def option; -} - -and meta_field_ptr = { - mutable fp_id : int; - mutable fp_field : meta_field; -} - -and meta_field = { - mutable f_id : int; - mutable f_flags : field_flags; - mutable f_name : id; - mutable f_signature : ilsig; -} - -and meta_method_ptr = { - mutable mp_id : int; - mutable mp_method : meta_method; -} - -and meta_method = { - mutable m_id : int; - mutable m_rva : rva; - mutable m_flags : method_flags; - mutable m_name : id; - mutable m_signature : ilsig; - mutable m_param_list : meta_param list; (* rid: Param *) - - (* extra field *) - mutable m_declaring : meta_type_def option; -} - -and meta_param_ptr = { - mutable pp_id : int; - mutable pp_param : meta_param; -} - -and meta_param = { - mutable p_id : int; - mutable p_flags : param_flags; - mutable p_sequence : int; - (* 0 means return value *) - mutable p_name : id; -} - -and meta_interface_impl = { - mutable ii_id : int; - mutable ii_class : meta_type_def; (* TypeDef rid *) - mutable ii_interface : type_def_or_ref; -} - -and meta_member_ref = { - mutable memr_id : int; - mutable memr_class : member_ref_parent; - mutable memr_name : id; - mutable memr_signature : ilsig; -} - -and meta_constant = { - mutable c_id : int; - mutable c_type : constant_type; - mutable c_parent : has_const; - mutable c_value : constant; -} - -and named_attribute = bool * string * instance (* is_property * name * instance *) - -and meta_custom_attribute = { - mutable ca_id : int; - mutable ca_parent : has_custom_attribute; - mutable ca_type : custom_attribute_type; - mutable ca_value : (instance list * named_attribute list) option; - (* can be 0 *) -} - -and meta_field_marshal = { - mutable fm_id : int; - mutable fm_parent : has_field_marshal; - mutable fm_native_type : nativesig; -} - -and meta_decl_security = { - mutable ds_id : int; - mutable ds_action : action_security; - mutable ds_parent : has_decl_security; - mutable ds_permission_set : blobref; - (* an xml with the permission set *) -} - -and meta_class_layout = { - mutable cl_id : int; - mutable cl_packing_size : int; - (* power of two; from 1 through 128 *) - mutable cl_class_size : int; - mutable cl_parent : meta_type_def; (* TypeDef rid *) -} - -and meta_field_layout = { - mutable fl_id : int; - mutable fl_offset : int; - (* offset in bytes or ordinal *) - mutable fl_field : meta_field; (* Field rid *) -} - -and meta_stand_alone_sig = { - mutable sa_id : int; - mutable sa_signature : ilsig; -} - -and meta_event_map = { - mutable em_id : int; - mutable em_parent : meta_type_def; (* TypeDef rid *) - mutable em_event_list : meta_event list; (* Event rid *) -} - -and meta_event_ptr = { - mutable ep_id : int; - mutable ep_event : meta_event; (* Event rid *) -} - -and meta_event = { - mutable e_id : int; - mutable e_flags : event_flags; - mutable e_name : stringref; - mutable e_event_type : type_def_or_ref; -} - -and meta_property_map = { - mutable pm_id : int; - mutable pm_parent : meta_type_def; (* TypeDef rid *) - mutable pm_property_list : meta_property list; (* Property rid *) -} - -and meta_property_ptr = { - mutable prp_id : int; - mutable prp_property : meta_property; (* Property rid *) -} - -and meta_property = { - mutable prop_id : int; - mutable prop_flags : property_flags; - mutable prop_name : stringref; - mutable prop_type : ilsig; -} - -and meta_method_semantics = { - mutable ms_id : int; - mutable ms_semantic : semantic_flags; - mutable ms_method : meta_method; (* Method rid *) - mutable ms_association : has_semantics; -} - -and meta_method_impl = { - mutable mi_id : int; - mutable mi_class : meta_type_def; (* TypeDef rid *) - mutable mi_method_body : method_def_or_ref; - (* overriding method *) - mutable mi_method_declaration : method_def_or_ref; - (* overridden method *) -} - -and meta_module_ref = { - mutable modr_id : int; - mutable modr_name : stringref; -} - -and meta_type_spec = { - mutable ts_id : int; - mutable ts_signature : ilsig; -} - -(* reserved ? *) -and meta_enc_log = { - mutable el_id : int; - mutable el_token : to_det; - mutable el_func_code : to_det; -} - -and meta_impl_map = { - mutable im_id : int; - mutable im_flags : impl_flags; (* mapping_flags *) - mutable im_forwarded : member_forwarded; (* method only *) - mutable im_import_name : stringref; - mutable im_import_scope : meta_module_ref; (* ModuleRef rid *) -} - -(* reserved ? *) -and meta_enc_map = { - mutable encm_id : int; - mutable encm_token : to_det; -} - -and meta_field_rva = { - mutable fr_id : int; - mutable fr_rva : rva; - mutable fr_field : meta_field; (* Field rid *) -} - -and meta_assembly = { - mutable a_id : int; - mutable a_hash_algo : hash_algo; - mutable a_major : int; - mutable a_minor : int; - mutable a_build : int; - mutable a_rev : int; - mutable a_flags : assembly_flags; (* assembly_flags *) - mutable a_public_key : blobref; - mutable a_name : stringref; - mutable a_locale : stringref; -} - -(* unused *) -and meta_assembly_processor = { - mutable ap_id : int; - mutable ap_processor : to_det; -} - -(* unused *) -and meta_assembly_os = { - mutable aos_id : int; - mutable aos_platform_id : to_det; - mutable aos_major_version : to_det; - mutable aos_minor_version : to_det; -} - -and meta_assembly_ref = { - mutable ar_id : int; - mutable ar_major : int; - mutable ar_minor : int; - mutable ar_build : int; - mutable ar_rev : int; - mutable ar_flags : assembly_flags; - mutable ar_public_key : blobref; - mutable ar_name : stringref; (* no path, no extension *) - mutable ar_locale : stringref; - mutable ar_hash_value : blobref; -} - -(* unused *) -and meta_assembly_ref_processor = { - mutable arp_id : int; - mutable arp_processor : to_det; - mutable arp_assembly_ref : meta_assembly_ref; (* AssemblyRef rid *) -} - -(* unused *) -and meta_assembly_ref_os = { - mutable aros_id : int; - mutable aros_platform_id : to_det; - mutable aros_major : int; - mutable aros_minor : int; - mutable aros_assembly_ref : meta_assembly_ref; (* AssemblyRef rid *) -} - -and meta_file = { - mutable file_id : int; - mutable file_flags : file_flag; (* file_flags *) - mutable file_name : stringref; (* no path; only file name *) - mutable file_hash_value : blobref; -} - -and meta_exported_type = { - mutable et_id : int; - mutable et_flags : type_def_flags; - mutable et_type_def_id : int; - (* TypeDef token in another module *) - mutable et_type_name : stringref; - mutable et_type_namespace : ns; - mutable et_implementation : implementation; -} - -and meta_manifest_resource = { - mutable mr_id : int; - mutable mr_offset : int; - mutable mr_flags : manifest_resource_flag; (* manifest_resource_flags *) - mutable mr_name : stringref; - mutable mr_implementation : implementation option; -} - -and meta_nested_class = { - mutable nc_id : int; - mutable nc_nested : meta_type_def; (* TypeDef rid *) - mutable nc_enclosing : meta_type_def; (* TypeDef rid *) -} - -and meta_generic_param = { - mutable gp_id : int; - mutable gp_number : int; (* ordinal *) - mutable gp_flags : generic_flags; - mutable gp_owner : type_or_method_def; - (* generic type or method *) - mutable gp_name : stringref option; -} - -and meta_method_spec = { - mutable mspec_id : int; - mutable mspec_method : method_def_or_ref; - (* instantiated method *) - mutable mspec_instantiation : ilsig; - (* instantiated signature *) -} - -and meta_generic_param_constraint = { - mutable gc_id : int; - mutable gc_owner : meta_generic_param; (* GenericParam rid *) - (* constrained parameter *) - mutable gc_constraint : type_def_or_ref; - (* type the parameter must extend or implement *) -} - -and to_det = int - -and not_implemented = int - -and constant = - | IBool of bool - | IChar of int - | IByte of int - | IShort of int - | IInt of int32 - | IInt64 of int64 - | IFloat32 of float - | IFloat64 of float - | IString of string - | INull - -and instance = - | InstConstant of constant - | InstBoxed of instance - | InstType of string - | InstArray of instance list - | InstEnum of int - -and constant_type = - | CBool (* 0x2 *) - | CChar (* 0x3 *) - | CInt8 (* 0x4 *) - | CUInt8 (* 0x5 *) - | CInt16 (* 0x6 *) - | CUInt16 (* 0x7 *) - | CInt32 (* 0x8 *) - | CUInt32 (* 0x9 *) - | CInt64 (* 0xA *) - | CUInt64 (* 0xB *) - | CFloat32 (* 0xC *) - | CFloat64 (* 0xD *) - | CString (* 0xE *) - | CNullRef (* 0x12 *) - (* null object reference - the value of the constant *) - (* of this type must be a 4-byte integer containing 0 *) - -and type_def_vis = - (* visibility flags - mask 0x7 *) - | VPrivate (* 0x0 *) - (* type is not visible outside the assembly. default *) - | VPublic (* 0x1 *) - (* type visible outside the assembly *) - | VNestedPublic (* 0x2 *) - (* the nested type has public visibility *) - | VNestedPrivate (* 0x3 *) - (* nested type has private visibility - it's not visible outside the enclosing class *) - | VNestedFamily (* 0x4 *) - (* nested type has family visibility - it's visible to descendants of the enclosing class only *) - | VNestedAssembly (* 0x5 *) - (* nested type visible within the assembly only *) - | VNestedFamAndAssem (* 0x6 *) - (* nested type is visible to the descendants of the enclosing class residing in the same assembly *) - | VNestedFamOrAssem (* 0x7 *) - (* nested type is visible to the descendants of the enclosing class either within *) - (* or outside the assembly and to every type within the assembly *) - -and type_def_layout = - (* layout flags - mask 0x18 *) - | LAuto (* 0x0 *) - (* type fields are laid out automatically *) - | LSequential (* 0x8 *) - (* loader must preserve the order of the instance fields *) - | LExplicit (* 0x10 *) - (* type layout is specified explicitly *) - -and type_def_semantics = - (* semantics flags - mask 0x5A0 *) - | SInterface (* 0x20 *) - (* type is an interface. If specified, the default parent is set to nil *) - | SAbstract (* 0x80 *) - | SSealed (* 0x100 *) - | SSpecialName (* 0x400 *) - (* type has a special name. how special depends on the name itself *) - (* e.g. .ctor or .cctor *) - -and type_def_impl = - (* type implementation flags - mask 0x103000 *) - | IImport (* 0x1000 *) - (* the type is imported from a COM type library *) - | ISerializable (* 0x2000 *) - (* the type can be serialized into sequential data *) - | IBeforeFieldInit (* 0x00100000 *) - (* the type can be initialized any time before the first access *) - (* to a static field. *) - -and type_def_string = - (* string formatting flags - mask 0x00030000 *) - | SAnsi (* 0x0 *) - (* managed strings are marshaled to and from ANSI strings *) - | SUnicode (* 0x00010000 *) - (* managed strings are marshaled to and from UTF-16 *) - | SAutoChar (* 0x00020000 *) - (* marshaling is defined by the underlying platform *) - -and type_def_flags = { - tdf_vis : type_def_vis; - tdf_layout : type_def_layout; - tdf_semantics : type_def_semantics list; - tdf_impl : type_def_impl list; - tdf_string : type_def_string; -} - -and field_access = - (* access flags - mask 0x07 *) - | FAPrivateScope (* 0x0 *) - (* default - exempt from the requirement of having a unique triad of owner, name and signature *) - (* so it must always be referenced by a FieldDef token and never by a MemberRef *) - (* privatescope fields are accessible from anywhere within the current module *) - | FAPrivate (* 0x1 *) - (* field is accessible from its owner and from classes nested in the field's owner. *) - (* global private fields are accessible from anywhere within current module *) - | FAFamAndAssem (* 0x2 *) - (* accessible from types belonging to the owner's family defined in the current assembly *) - (* family means the type itself and all its descendants *) - | FAAssembly (* 0x3 *) - (* accessible from types defined in the current assembly *) - | FAFamily (* 0x4 *) - (* accessible from the owner's family - defined in this or any other assembly *) - | FAFamOrAssem (* 0x5 *) - (* accessible from the owner's family and from all types defined in the current assembly *) - | FAPublic (* 0x6 *) - (* field is accessible from any type *) - -and field_contract = - (* contract flags - mask 0x02F0 *) - | CStatic (* 0x10 *) - (* static field. global fields must be static *) - | CInitOnly (* 0x20 *) - (* field can be initialized only and cannot be written to later. *) - (* Initialization takes place in an instance constructor (.ctor) for instance fields *) - (* and in a class constructor (.cctor) for static fields. *) - (* this flag is not enforced by the CLR *) - | CLiteral (* 0x40 *) - (* field is a compile-time constant. the loader does not lay out this field *) - (* and does not create an internal handle for it *) - (* it cannot be directly addressed from IL and can only be used as a Reflection reference *) - | CNotSerialized (* 0x80 *) - (* field is not serialized when the owner is remoted *) - | CSpecialName (* 0x200 *) - (* the field is special in some way, as defined by its name *) - (* example is the field value__ of an enumeration type *) - -and field_reserved = - (* reserved flags - cannot be set explicitly. mask 0x9500 *) - | RSpecialName (* 0x400 *) - (* has a special name that is reserved for internal use of the CLR *) - (* two field names are reserved: value_, for instance fields in enumerations *) - (* and _Deleted* for fields marked for deletion but not actually removed from metadata *) - | RMarshal (* 0x1000 *) - (* The field has an associated FieldMarshal record specifying how the field must be *) - (* marshaled when consumed by unmanaged code. *) - | RConstant (* 0x8000 *) - (* field has an associated Constant record *) - | RFieldRVA (* 0x0100 *) - (* field is mapped to data and has an associated FieldRVA record *) - -and field_flags = { - ff_access : field_access; - ff_contract : field_contract list; - ff_reserved : field_reserved list; -} - -and method_contract = - (* contract flags - mask 0xF0 *) - | CMStatic (* 0x10 *) - | CMFinal (* 0x20 *) - (* must be paired with the virtual flag - otherwise it is meaningless *) - | CMVirtual (* 0x40 *) - | CMHideBySig (* 0x80 *) - (* the method hides all methods of the parent classes that have a matching *) - (* signature and name (as opposed to having a matching name only). ignored by the CLR *) - -and method_vtable = - (* vtable flags - mask 0x300 *) - | VNewSlot (* 0x100 *) - (* a new vtable slot is created, so it doesn't override the old implementation *) - | VStrict (* 0x200 *) - (* virtual method can be overridden only if it is accessible from the overriding class *) - -and method_impl = - (* implementation flags - mask 0x2C08 *) - | IAbstract (* 0x0400 *) - | ISpecialName (* 0x0800 *) - | IPInvokeImpl (* 0x2000 *) - (* the method has an unmanaged implementation and is called through the platform *) - (* invocation mechanism. the rva field must be 0, since the method is implemented externally *) - | IUnmanagedExp (* 0x0008 *) - (* the managed method is exposed as an unmanaged export. not used by the CLR currently *) - -and method_reserved = - (* reserved flags - cannot be set explicitly. mask 0xD000 *) - | RTSpecialName (* 0x1000 *) - (* has a special name: .ctor, .cctor, _VtblGap* and _Deleted* *) - | RHasSecurity (* 0x4000 *) - (* either has an associated DeclSecurity metadata or the custom attribte *) - (* System.Security.SuppressUnmanagedCodeSecurityAttribute *) - | RReqSecObj (* 0x8000 *) - (* this method calls another method containing security code, so it requires *) - (* an additional stack slot for a security object. *) - -and method_code_type = - (* code type - mask 0x3 *) - | CCil (* 0x0 *) - | CNative (* 0x1 *) - (* implemented in native platform-specific code *) - | COptIl (* 0x2 *) - (* optimized il - not supported; must not be set *) - | CRuntime (* 0x3 *) - (* automatically generated by the runtime itself (intrinsic) *) - -and method_code_mngmt = - (* code management - mask 0x4 *) - | MManaged (* 0x0 *) - | MUnmanaged (* 0x4 *) - (* must be paired with the native flag *) - -and method_interop = - (* method implementation and interop - mask 0x10D8 *) - | OForwardRef (* 0x10 *) - (* managed object fiels and edit-and-continue scenarios only *) - | OPreserveSig (* 0x80 *) - (* method signature must not be mangled during interop with classic COM code *) - | OInternalCall (* 0x1000 *) - (* reserved for internal use. if set, RVA must be 0 *) - | OSynchronized (* 0x20 *) - (* automatically insert code to take a lock on entry to the method and release it *) - (* on exit from the method. Value types cannot have this flag set *) - | ONoInlining (* 0x08 *) - (* the runtime is not allowed to inline the method *) - -and method_flags = { - mf_access : field_access; - mf_contract : method_contract list; - mf_vtable : method_vtable list; - mf_impl : method_impl list; - mf_reserved : method_reserved list; - mf_code_type : method_code_type; - mf_code_mngmt : method_code_mngmt; - mf_interop : method_interop list; -} - -and param_io = - (* input/output flags - mask 0x13 *) - | PIn (* 0x1 *) - | POut (* 0x2 *) - | POpt (* 0x10 *) - -and param_reserved = - (* reserved flags - mask 0xF000 *) - | PHasConstant (* 0x1000 *) - (* the parameter has an associated Constant record *) - | PMarshal (* 0x2000 *) - (* the parameter has an associated FieldMarshal record specifying how the parameter *) - (* must be marshaled when consumed by unmanaged code *) - -and param_flags = { - pf_io : param_io list; - pf_reserved : param_reserved list; -} - -and event_flag = - | ESpecialName (* 0x0200 *) - (* event is special *) - | ERTSpecialName (* 0x0400 *) - (* CLI provides special behavior, depending on the name of the event *) - -and event_flags = event_flag list - -and property_flag = - | PSpecialName (* 0x0200 *) - (* property is special *) - | PRTSpecialName (* 0x0400 *) - (* runtime (intrinsic) should check name encoding *) - | PHasDefault (* 0x1000 *) - (* property has default *) - | PUnused (* 0xE9FF *) - (* reserved *) - -and property_flags = property_flag list - -and semantic_flag = - | SSetter (* 0x0001 *) - (* setter for property *) - | SGetter (* 0x0002 *) - (* getter for property *) - | SOther (* 0x0004 *) - (* other method for property or event *) - | SAddOn (* 0x0008 *) - (* addon method for event - refers to the required add_ method for events *) - | SRemoveOn (* 0x0010 *) - (* removeon method for event - refers to the required remove_ method for events *) - | SFire (* 0x0020 *) - (* fire method for event. this refers to the optional raise_ method for events *) - -and semantic_flags = semantic_flag list - -and action_security = - | SecNull - | SecRequest (* 0x1 *) - | SecDemand (* 0x2 *) - | SecAssert (* 0x3 *) - | SecDeny (* 0x4 *) - | SecPermitOnly (* 0x5 *) - | SecLinkCheck (* 0x6 *) - | SecInheritCheck (* 0x7 *) - | SecReqMin (* 0x8 *) - | SecReqOpt (* 0x9 *) - | SecReqRefuse (* 0xA *) - | SecPreJitGrant (* 0xB *) - | SecPreJitDeny (* 0xC *) - | SecNonCasDemand (* 0xD *) - | SecNonCasLinkDemand (* 0xE *) - | SecNonCasInheritance (* 0xF *) - -and impl_charset = - | IDefault (* 0x0 *) - | IAnsi (* 0x2 *) - (* method parameters of type string must be marshaled as ANSI zero-terminated *) - (* strings unless explicitly specified otherwise *) - | IUnicode (* 0x4 *) - (* method parameters of type string must be marshaled as Unicode strings *) - | IAutoChar (* 0x6 *) - (* method parameters of type string must be marshaled as ANSI or Unicode strings *) - (* depending on the platform *) - -and impl_callconv = - | IDefaultCall (* 0x0 *) - | IWinApi (* 0x100 *) - (* the native method uses the calling convention standard for the underlying platform *) - | ICDecl (* 0x200 *) - (* the native method uses the C/C++ style calling convention *) - | IStdCall (* 0x300 *) - (* native method uses the standard Win32 API calling convention *) - | IThisCall (* 0x400 *) - (* native method uses the C++ member method (non-vararg) calling convention *) - | IFastCall (* 0x500 *) - -and impl_flag = - | INoMangle (* 0x1 *) - (* exported method's name must be matched literally *) - | IBestFit (* 0x10 *) - (* allow "best fit" guessing when converting the strings *) - | IBestFitOff (* 0x20 *) - (* disallow "best fit" guessing *) - | ILastErr (* 0x40 *) - (* the native method supports the last error querying by the Win32 API GetLastError *) - | ICharMapError (* 0x1000 *) - (* throw an exception when an unmappable character is encountered in a string *) - | ICharMapErrorOff (* 0x2000 *) - (* don't throw an exception when an unmappable character is encountered *) - -and impl_flags = { - if_charset : impl_charset; - if_callconv : impl_callconv; - if_flags : impl_flag list; -} - -and hash_algo = - | HNone (* 0x0 *) - | HReserved (* 0x8003 *) - (* MD5 ? *) - | HSha1 (* 0x8004 *) - (* SHA1 *) - -and assembly_flag = - | APublicKey (* 0x1 *) - (* assembly reference holds the full (unhashed) public key *) - | ARetargetable (* 0x100 *) - (* implementation of this assembly used at runtime is not expected to match *) - (* the version seen at compile-time *) - | ADisableJitCompileOptimizer (* 0x4000 *) - (* Reserved *) - | AEnableJitCompileTracking (* 0x8000 *) - (* Reserved *) - -and assembly_flags = assembly_flag list - -and file_flag = - | ContainsMetadata (* 0x0 *) - | ContainsNoMetadata (* 0x1 *) - -and manifest_resource_flag = - (* mask 0x7 *) - | RNone (* 0x0 *) - | RPublic (* 0x1 *) - | RPrivate (* 0x2 *) - -and generic_variance = - (* mask 0x3 *) - | VNone (* 0x0 *) - | VCovariant (* 0x1 *) - | VContravariant (* 0x2 *) - -and generic_constraint = - (* mask 0x1C *) - | CInstanceType (* 0x4 *) - (* generic parameter has the special class constraint *) - | CValueType (* 0x8 *) - (* generic parameter has the special valuetype constraint *) - | CDefaultCtor (* 0x10 *) - (* has the special .ctor constraint *) - -and generic_flags = { - gf_variance : generic_variance; - gf_constraint : generic_constraint list; -} - -and ilsig = - (* primitive types *) - | SVoid (* 0x1 *) - | SBool (* 0x2 *) - | SChar (* 0x3 *) - | SInt8 (* 0x4 *) - | SUInt8 (* 0x5 *) - | SInt16 (* 0x6 *) - | SUInt16 (* 0x7 *) - | SInt32 (* 0x8 *) - | SUInt32 (* 0x9 *) - | SInt64 (* 0xA *) - | SUInt64 (* 0xB *) - | SFloat32 (* 0xC *) - | SFloat64 (* 0xD *) - | SString (* 0xE *) - | SPointer of ilsig (* 0xF *) - (* unmanaged pointer to type ( * ) *) - | SManagedPointer of ilsig (* 0x10 *) - (* managed pointer to type ( & ) *) - | SValueType of type_def_or_ref (* 0x11 *) - (* a value type modifier, followed by TypeDef or TypeRef token *) - | SClass of type_def_or_ref (* 0x12 *) - (* a class type modifier, followed by TypeDef or TypeRef token *) - | STypeParam of int (* 0x13 *) - (* generic parameter in a generic type definition. represented by a number *) - | SArray of ilsig * (int option * int option) array (* 0x14 *) - (* ilsig * ( bound * size ) *) - (* a multi-dimensional array type modifier *) - (* encoded like: *) - (* SArray ... - ... *) - (* is the number of dimensions (K>0) *) - (* num of specified sizes for dimensions (N <= K) *) - (* num of lower bounds (M <= K) *) - (* all int values are compressed *) - | SGenericInst of ilsig * (ilsig list) (* 0x15 *) - (* A generic type instantiation. encoded like: *) - (* SGenericInst ... *) - | STypedReference (* 0x16 *) - (* typed reference, carrying both a reference to a type *) - (* and information identifying the referenced type *) - | SIntPtr (* 0x18 *) - (* pointer-sized managed integer *) - | SUIntPtr (* 0x19 *) - (* pointer-size managed unsigned integer *) - (* | SNativeFloat (* 0x1A *) *) - (* refer to http://stackoverflow.com/questions/13961205/native-float-type-usage-in-clr *) - | SFunPtr of callconv list * ilsig * (ilsig list) (* 0x1B *) - (* a pointer to a function, followed by full method signature *) - | SObject (* 0x1C *) - (* System.Object *) - | SVector of ilsig (* 0x1D *) - (* followed by the encoding of the underlying type *) - | SMethodTypeParam of int (* 0x1E *) - (* generic parameter in a generic method definition *) - | SReqModifier of type_def_or_ref * ilsig (* 0x1F *) - (* modreq: required custom modifier : indicate that the item to which they are attached *) - (* must be treated in a special way *) - | SOptModifier of type_def_or_ref * ilsig (* 0x20 *) - (* modopt: optional custom modifier *) - | SSentinel (* 0x41 *) - (* ... - signifies the beginning of optional arguments supplied for a vararg method call *) - (* This can only appear at call site, since varargs optional parameters are not specified *) - (* when a method is declared *) - | SPinned of ilsig (* 0x45 *) - (* pinned reference: it's only applicable to local variables only *) - (* special undocumented (yay) *) - | SType (* 0x50 *) - | SBoxed (* 0x51 *) - | SEnum of string (* 0x55 *) - -and callconv = - | CallDefault (* 0x0 *) - | CallCDecl (* 0x1 *) - | CallStdCall (* 0x2 *) - | CallThisCall (* 0x3 *) - | CallFastCall (* 0x4 *) - | CallVararg (* 0x5 *) - | CallField (* 0x6 *) - (* field call *) - | CallLocal (* 0x7 *) - (* local variable call *) - | CallProp (* 0x8 *) - (* property call *) - | CallUnmanaged (* 0x9 *) - (* unmanaged calling convention. not used *) - | CallGenericInst (* 0xA *) - (* generic instantiation - MethodSpec *) - | CallGeneric of int (* 0x10 *) - (* also contains the number of generic arguments *) - | CallHasThis (* 0x20 *) - (* instance method that has an instance pointer (this) *) - (* as an implicit first argument - ilasm 'instance' *) - | CallExplicitThis (* 0x40 *) - (* the first explicitly specified parameter is the instance pointer *) - (* ilasm 'explicit' *) - -and nativesig = - | NVoid (* 0x01 *) - (* obsolete *) - | NBool (* 0x02 *) - | NInt8 (* 0x03 *) - | NUInt8 (* 0x4 *) - | NInt16 (* 0x5 *) - | NUInt16 (* 0x6 *) - | NInt32 (* 0x7 *) - | NUInt32 (* 0x8 *) - | NInt64 (* 0x9 *) - | NUInt64 (* 0xA *) - | NFloat32 (* 0xB *) - | NFloat64 (* 0xC *) - | NSysChar (* 0xD *) - (* obsolete *) - | NVariant (* 0xE *) - (* obsolete *) - | NCurrency (* 0xF *) - | NPointer (* 0x10 *) - (* obsolete - use NativeInt *) - | NDecimal (* 0x11 *) - (* obsolete *) - | NDate (* 0x12 *) - (* obsolete *) - | NBStr (* 0x13 *) - (* unicode VB-style: used in COM operations *) - | NLPStr (* 0x14 *) - (* pointer to a zero-terminated ANSI string *) - | NLPWStr (* 0x15 *) - (* pointer to a zero-terminated Unicode string *) - | NLPTStr (* 0x16 *) - (* pointer to a zero-terminated ANSI or Unicode string - depends on platform *) - | NFixedString of int (* 0x17 *) - (* fixed-size system string of size bytes; applicable to field marshalling only *) - | NObjectRef (* 0x18 *) - (* obsolete *) - | NUnknown (* 0x19 *) - (* IUnknown interface pointer *) - | NDispatch (* 0x1A *) - (* IDispatch interface pointer *) - | NStruct (* 0x1B *) - (* C-style structure, for marshaling the formatted managed types *) - | NInterface (* 0x1C *) - (* interface pointer *) - | NSafeArray of variantsig (* 0x1D *) - (* safe array of type *) - | NFixedArray of int * variantsig (* 0x1E *) - (* fixed-size array, of size bytes *) - | NIntPointer (* 0x1F *) - (* signed pointer-size integer *) - | NUIntPointer (* 0x20 *) - (* unsigned pointer-sized integer *) - | NNestedStruct (* 0x21 *) - (* obsolete *) - | NByValStr (* 0x22 *) - (* VB-style string in a fixed-length buffer *) - | NAnsiBStr (* 0x23 *) - (* ansi bstr - ANSI VB-style string *) - | NTBStr (* 0x24 *) - (* tbstr - bstr or ansi bstr, depending on the platform *) - | NVariantBool (* 0x25 *) - (* variant bool - 2-byte Boolean: true = -1; false = 0 *) - | NFunctionPtr (* 0x26 *) - | NAsAny (* 0x28 *) - (* as any - object: type defined at run time (?) *) - | NArray of nativesig * int * int * int (* 0x2A *) - (* fixed-size array of a native type *) - (* if size is empty, the size of the native array is derived from the size *) - (* of the managed type being marshaled *) - | NLPStruct (* 0x2B *) - (* pointer to a c-style structure *) - | NCustomMarshaler of string * string (* 0x2C *) - (* custom (, ) *) - | NError (* 0x2D *) - (* maps in32 to VT_HRESULT *) - | NCustom of int - -and variantsig = - | VT_EMPTY (* 0x00 *) - (* No *) - | VT_NULL (* 0x01 *) - (* No null *) - | VT_I2 (* 0x02 *) - (* Yes int16 *) - | VT_I4 (* 0x03 *) - (* Yes int32 *) - | VT_R4 (* 0x04 *) - (* Yes float32 *) - | VT_R8 (* 0x05 *) - (* Yes float64 *) - | VT_CY (* 0x06 *) - (* Yes currency *) - | VT_DATE (* 0x07 *) - (* Yes date *) - | VT_BSTR (* 0x08 *) - (* Yes bstr *) - | VT_DISPATCH (* 0x09 *) - (* Yes idispatch *) - | VT_ERROR (* 0x0A *) - (* Yes error *) - | VT_BOOL (* 0x0B *) - (* Yes bool *) - | VT_VARIANT (* 0x0C *) - (* Yes variant *) - | VT_UNKNOWN (* 0x0D *) - (* Yes iunknown *) - | VT_DECIMAL (* 0x0E *) - (* Yes decimal *) - | VT_I1 (* 0x10 *) - (* Yes int8 *) - | VT_UI1 (* 0x11 *) - (* Yes unsigned int8, uint8 *) - | VT_UI2 (* 0x12 *) - (* Yes unsigned int16, uint16 *) - | VT_UI4 (* 0x13 *) - (* Yes unsigned int32, uint32 *) - | VT_I8 (* 0x14 *) - (* No int64 *) - | VT_UI8 (* 0x15 *) - (* No unsigned int64, uint64 *) - | VT_INT (* 0x16 *) - (* Yes int *) - | VT_UINT (* 0x17 *) - (* Yes unsigned int, uint *) - | VT_VOID (* 0x18 *) - (* No void *) - | VT_HRESULT (* 0x19 *) - (* No hresult *) - | VT_PTR (* 0x1A *) - (* No * *) - | VT_SAFEARRAY (* 0x1B *) - (* No safearray *) - | VT_CARRAY (* 0x1C *) - (* No carray *) - | VT_USERDEFINED (* 0x1D *) - (* No userdefined *) - | VT_LPSTR (* 0x1E *) - (* No lpstr *) - | VT_LPWSTR (* 0x1F *) - (* No lpwstr *) - | VT_RECORD (* 0x24 *) - (* Yes record *) - | VT_FILETIME (* 0x40 *) - (* No filetime *) - | VT_BLOB (* 0x41 *) - (* No blob *) - | VT_STREAM (* 0x42 *) - (* No stream *) - | VT_STORAGE (* 0x43 *) - (* No storage *) - | VT_STREAMED_OBJECT (* 0x44 *) - (* No streamed_object *) - | VT_STORED_OBJECT (* 0x45 *) - (* No stored_object *) - | VT_BLOB_OBJECT (* 0x46 *) - (* No blob_object *) - | VT_CF (* 0x47 *) - (* No cf *) - | VT_CLSID (* 0x48 *) - (* No clsid *) - (* | VT_VECTOR of variantsig (* 0x1000 *) *) - (* (* Yes vector *) *) - (* | VT_ARRAY of variantsig (* 0x2000 *) *) - (* (* Yes [ ] *) *) - (* | VT_BYREF of variantsig (* 0x4000 *) *) - (* (* Yes & *) *) diff --git a/libs/ilib/ilMetaDebug.ml b/libs/ilib/ilMetaDebug.ml deleted file mode 100644 index 023a14e5aae..00000000000 --- a/libs/ilib/ilMetaDebug.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) -open IlMeta;; -open IlMetaTools;; - -let path_s = IlMetaTools.path_s -let ilsig_s = IlMetaTools.ilsig_s -let instance_s = IlMetaTools.instance_s diff --git a/libs/ilib/ilMetaReader.ml b/libs/ilib/ilMetaReader.ml deleted file mode 100644 index 24a954cd395..00000000000 --- a/libs/ilib/ilMetaReader.ml +++ /dev/null @@ -1,2406 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) - -open PeData;; -open PeReader;; -open IlMeta;; -open IO;; -open Printf;; -open IlMetaTools;; -open ExtString;; -open IlData;; - -(* *) -let get_field = function - | Field f -> f - | _ -> assert false - -let get_method = function - | Method m -> m - | _ -> assert false - -let get_param = function - | Param p -> p - | _ -> assert false - -let get_type_def = function - | TypeDef p -> p - | _ -> assert false - -let get_event = function - | Event e -> e - | _ -> assert false - -let get_property = function - | Property p -> p - | _ -> assert false - -let get_module_ref = function - | ModuleRef r -> r - | _ -> assert false - -let get_assembly_ref = function - | AssemblyRef r -> r - | _ -> assert false - -let get_generic_param = function - | GenericParam p -> p - | _ -> assert false - -(* decoding helpers *) -let type_def_vis_of_int i = match i land 0x7 with - (* visibility flags - mask 0x7 *) - | 0x0 -> VPrivate (* 0x0 *) - | 0x1 -> VPublic (* 0x1 *) - | 0x2 -> VNestedPublic (* 0x2 *) - | 0x3 -> VNestedPrivate (* 0x3 *) - | 0x4 -> VNestedFamily (* 0x4 *) - | 0x5 -> VNestedAssembly (* 0x5 *) - | 0x6 -> VNestedFamAndAssem (* 0x6 *) - | 0x7 -> VNestedFamOrAssem (* 0x7 *) - | _ -> assert false - -let type_def_layout_of_int i = match i land 0x18 with - (* layout flags - mask 0x18 *) - | 0x0 -> LAuto (* 0x0 *) - | 0x8 -> LSequential (* 0x8 *) - | 0x10 -> LExplicit (* 0x10 *) - | _ -> assert false - -let type_def_semantics_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* semantics flags - mask 0x5A0 *) - | 0x20 -> SInterface (* 0x20 *) - | 0x80 -> SAbstract (* 0x80 *) - | 0x100 -> SSealed (* 0x100 *) - | 0x400 -> SSpecialName (* 0x400 *) - | _ -> assert false) :: acc - else - acc) [] [0x20;0x80;0x100;0x400] - -let type_def_impl_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* type implementation flags - mask 0x103000 *) - | 0x1000 -> IImport (* 0x1000 *) - | 0x2000 -> ISerializable (* 0x2000 *) - | 0x00100000 -> IBeforeFieldInit (* 0x00100000 *) - | _ -> assert false) :: acc - else - acc) [] [0x1000;0x2000;0x00100000] - -let type_def_string_of_int i = match i land 0x00030000 with - (* string formatting flags - mask 0x00030000 *) - | 0x0 -> SAnsi (* 0x0 *) - | 0x00010000 -> SUnicode (* 0x00010000 *) - | 0x00020000 -> SAutoChar (* 0x00020000 *) - | _ -> assert false - -let type_def_flags_of_int i = - { - tdf_vis = type_def_vis_of_int i; - tdf_layout = type_def_layout_of_int i; - tdf_semantics = type_def_semantics_of_int i; - tdf_impl = type_def_impl_of_int i; - tdf_string = type_def_string_of_int i; - } - -let null_type_def_flags = type_def_flags_of_int 0 - -let field_access_of_int i = match i land 0x07 with - (* access flags - mask 0x07 *) - | 0x0 -> FAPrivateScope (* 0x0 *) - | 0x1 -> FAPrivate (* 0x1 *) - | 0x2 -> FAFamAndAssem (* 0x2 *) - | 0x3 -> FAAssembly (* 0x3 *) - | 0x4 -> FAFamily (* 0x4 *) - | 0x5 -> FAFamOrAssem (* 0x5 *) - | 0x6 -> FAPublic (* 0x6 *) - | _ -> assert false - -let field_contract_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* contract flags - mask 0x02F0 *) - | 0x10 -> CStatic (* 0x10 *) - | 0x20 -> CInitOnly (* 0x20 *) - | 0x40 -> CLiteral (* 0x40 *) - | 0x80 -> CNotSerialized (* 0x80 *) - | 0x200 -> CSpecialName (* 0x200 *) - | _ -> assert false) :: acc - else - acc) [] [0x10;0x20;0x40;0x80;0x200] - -let field_reserved_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* reserved flags - cannot be set explicitly. mask 0x9500 *) - | 0x400 -> RSpecialName (* 0x400 *) - | 0x1000 -> RMarshal (* 0x1000 *) - | 0x8000 -> RConstant (* 0x8000 *) - | 0x0100 -> RFieldRVA (* 0x0100 *) - | _ -> assert false) :: acc - else - acc) [] [0x400;0x1000;0x8000;0x100] - -let field_flags_of_int i = - { - ff_access = field_access_of_int i; - ff_contract = field_contract_of_int i; - ff_reserved = field_reserved_of_int i; - } - -let null_field_flags = field_flags_of_int 0 - -let method_contract_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* contract flags - mask 0xF0 *) - | 0x10 -> CMStatic (* 0x10 *) - | 0x20 -> CMFinal (* 0x20 *) - | 0x40 -> CMVirtual (* 0x40 *) - | 0x80 -> CMHideBySig (* 0x80 *) - | _ -> assert false) :: acc - else - acc) [] [0x10;0x20;0x40;0x80] - -let method_vtable_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* vtable flags - mask 0x300 *) - | 0x100 -> VNewSlot (* 0x100 *) - | 0x200 -> VStrict (* 0x200 *) - | _ -> assert false) :: acc - else - acc) [] [0x100;0x200] - -let method_impl_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* implementation flags - mask 0x2C08 *) - | 0x0400 -> IAbstract (* 0x0400 *) - | 0x0800 -> ISpecialName (* 0x0800 *) - | 0x2000 -> IPInvokeImpl (* 0x2000 *) - | 0x0008 -> IUnmanagedExp (* 0x0008 *) - | _ -> assert false) :: acc - else - acc) [] [0x0400;0x0800;0x2000;0x0008] - -let method_reserved_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* reserved flags - cannot be set explicitly. mask 0xD000 *) - | 0x1000 -> RTSpecialName (* 0x1000 *) - | 0x4000 -> RHasSecurity (* 0x4000 *) - | 0x8000 -> RReqSecObj (* 0x8000 *) - | _ -> assert false) :: acc - else - acc) [] [0x1000;0x4000;0x8000] - -let method_code_type_of_int i = match i land 0x3 with - | 0x0 -> CCil (* 0x0 *) - | 0x1 -> CNative (* 0x1 *) - | 0x2 -> COptIl (* 0x2 *) - | 0x3 -> CRuntime (* 0x3 *) - | _ -> assert false - -let method_code_mngmt_of_int i = match i land 0x4 with - | 0x0 -> MManaged (* 0x0 *) - | 0x4 -> MUnmanaged (* 0x4 *) - | _ -> assert false - -let method_interop_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x10 -> OForwardRef (* 0x10 *) - | 0x80 -> OPreserveSig (* 0x80 *) - | 0x1000 -> OInternalCall (* 0x1000 *) - | 0x20 -> OSynchronized (* 0x20 *) - | 0x08 -> ONoInlining (* 0x08 *) - | _ -> assert false) :: acc - else - acc) [] [0x10;0x80;0x1000;0x20;0x08] - -let method_flags_of_int iflags flags = - { - mf_access = field_access_of_int flags; - mf_contract = method_contract_of_int flags; - mf_vtable = method_vtable_of_int flags; - mf_impl = method_impl_of_int flags; - mf_reserved = method_reserved_of_int flags; - mf_code_type = method_code_type_of_int iflags; - mf_code_mngmt = method_code_mngmt_of_int iflags; - mf_interop = method_interop_of_int iflags; - } - -let null_method_flags = method_flags_of_int 0 0 - -let param_io_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* input/output flags - mask 0x13 *) - | 0x1 -> PIn (* 0x1 *) - | 0x2 -> POut (* 0x2 *) - | 0x10 -> POpt (* 0x10 *) - | _ -> assert false) :: acc - else - acc) [] [0x1;0x2;0x10] - -let param_reserved_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* reserved flags - mask 0xF000 *) - | 0x1000 -> PHasConstant (* 0x1000 *) - | 0x2000 -> PMarshal (* 0x2000 *) - | _ -> assert false) :: acc - else - acc) [] [0x1000;0x2000] - -let param_flags_of_int i = - { - pf_io = param_io_of_int i; - pf_reserved = param_reserved_of_int i; - } - -let null_param_flags = param_flags_of_int 0 - -let callconv_of_int ?match_generic_inst:(match_generic_inst=false) i = - let basic = match i land 0xF with - | 0x0 -> CallDefault (* 0x0 *) - | 0x1 -> CallCDecl - | 0x2 -> CallStdCall - | 0x3 -> CallThisCall - | 0x4 -> CallFastCall - | 0x5 -> CallVararg (* 0x5 *) - | 0x6 -> CallField (* 0x6 *) - | 0x7 -> CallLocal (* 0x7 *) - | 0x8 -> CallProp (* 0x8 *) - | 0x9 -> CallUnmanaged (* 0x9 *) - | 0xa when match_generic_inst -> CallGenericInst (* 0xA *) - | i -> printf "error 0x%x\n\n" i; assert false - in - match i land 0x20 with - | 0x20 -> - [CallHasThis;basic] - | _ when i land 0x40 = 0x40 -> - [CallExplicitThis;basic] - | _ -> [basic] - -let event_flags_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x0200 -> ESpecialName (* 0x0200 *) - | 0x0400 -> ERTSpecialName (* 0x0400 *) - | _ -> assert false) :: acc - else - acc) [] [0x0200;0x0400] - -let property_flags_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x0200 -> PSpecialName (* 0x0200 *) - | 0x0400 -> PRTSpecialName (* 0x0400 *) - | 0x1000 -> PHasDefault (* 0x1000 *) - | 0xE9FF -> PUnused (* 0xE9FF *) - | _ -> assert false) :: acc - else - acc) [] [0x0200;0x0400;0x1000;0xE9FF] - -let semantic_flags_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x0001 -> SSetter (* 0x0001 *) - | 0x0002 -> SGetter (* 0x0002 *) - | 0x0004 -> SOther (* 0x0004 *) - | 0x0008 -> SAddOn (* 0x0008 *) - | 0x0010 -> SRemoveOn (* 0x0010 *) - | 0x0020 -> SFire (* 0x0020 *) - | _ -> assert false) :: acc - else - acc) [] [0x0001;0x0002;0x0004;0x0008;0x0010;0x0020] - -let impl_charset_of_int = function - | 0x0 -> IDefault (* 0x0 *) - | 0x2 -> IAnsi (* 0x2 *) - | 0x4 -> IUnicode (* 0x4 *) - | 0x6 -> IAutoChar (* 0x6 *) - | _ -> assert false - -let impl_callconv_of_int = function - | 0x0 -> IDefaultCall (* 0x0 *) - | 0x100 -> IWinApi (* 0x100 *) - | 0x200 -> ICDecl (* 0x200 *) - | 0x300 -> IStdCall (* 0x300 *) - | 0x400 -> IThisCall (* 0x400 *) - | 0x500 -> IFastCall (* 0x500 *) - | _ -> assert false - -let impl_flag_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x1 -> INoMangle (* 0x1 *) - | 0x10 -> IBestFit (* 0x10 *) - | 0x20 -> IBestFitOff (* 0x20 *) - | 0x40 -> ILastErr (* 0x40 *) - | 0x1000 -> ICharMapError (* 0x1000 *) - | 0x2000 -> ICharMapErrorOff (* 0x2000 *) - | _ -> assert false) :: acc - else - acc) [] [0x1;0x10;0x20;0x40;0x1000;0x2000] - -let impl_flags_of_int i = - { - if_charset = impl_charset_of_int (i land 0x6); - if_callconv = impl_callconv_of_int (i land 0x700); - if_flags = impl_flag_of_int i; - } - -let null_impl_flags = impl_flags_of_int 0 - -let assembly_flags_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x1 -> APublicKey (* 0x1 *) - | 0x100 -> ARetargetable (* 0x100 *) - | 0x4000 -> ADisableJitCompileOptimizer (* 0x4000 *) - | 0x8000 -> AEnableJitCompileTracking (* 0x8000 *) - | _ -> assert false) :: acc - else - acc) [] [0x1;0x100;0x4000;0x8000] - -let hash_algo_of_int = function - | 0x0 -> HNone (* 0x0 *) - | 0x8003 -> HReserved (* 0x8003 *) - | 0x8004 -> HSha1 (* 0x8004 *) - | _ -> assert false - -let file_flag_of_int = function - | 0x0 -> ContainsMetadata (* 0x0 *) - | 0x1 -> ContainsNoMetadata (* 0x1 *) - | _ -> assert false - -let manifest_resource_flag_of_int i = match i land 0x7 with - | 0x0 -> RNone (* 0x0 *) - | 0x1 -> RPublic (* 0x1 *) - | 0x2 -> RPrivate (* 0x2 *) - | _ -> assert false - -let generic_variance_of_int = function - (* mask 0x3 *) - | 0x0 -> VNone (* 0x0 *) - | 0x1 -> VCovariant (* 0x1 *) - | 0x2 -> VContravariant (* 0x2 *) - | _ -> assert false - -let generic_constraint_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - (* mask 0x1C *) - | 0x4 -> CInstanceType (* 0x4 *) - | 0x8 -> CValueType (* 0x8 *) - | 0x10 -> CDefaultCtor (* 0x10 *) - | _ -> assert false) :: acc - else - acc) [] [0x4;0x8;0x10] - -let generic_flags_of_int i = - { - gf_variance = generic_variance_of_int (i land 0x3); - gf_constraint = generic_constraint_of_int (i land 0x1C); - } - -let null_generic_flags = generic_flags_of_int 0 - -(* TODO: convert from string to Bigstring if OCaml 4 is available *) -type meta_ctx = { - compressed : bool; - (* is a compressed stream *) - strings_stream : string; - mutable strings_offset : int; - (* #Strings: a string heap containing the names of metadata items *) - blob_stream : string; - mutable blob_offset : int; - (* #Blob: blob heap containing internal metadata binary object, such as default values, signatures, etc *) - guid_stream : string; - mutable guid_offset : int; - (* #GUID: a GUID heap *) - us_stream : string; - (* #US: user-defined strings *) - meta_stream : string; - (* may be either: *) - (* #~: compressed (optimized) metadata stream *) - (* #-: uncompressed (unoptimized) metadata stream *) - mutable meta_edit_continue : bool; - mutable meta_has_deleted : bool; - - module_cache : meta_cache; - tables : (clr_meta DynArray.t) array; - table_sizes : ( string -> int -> int * int ) array; - extra_streams : clr_stream_header list; - relations : (meta_pointer, clr_meta) Hashtbl.t; - typedefs : (ilpath, meta_type_def) Hashtbl.t; - - mutable delays : (unit -> unit) list; -} - -and meta_cache = { - mutable lookups : (string -> meta_ctx option) list; - mutable mcache : (meta_module * meta_ctx) list; -} - -let empty = "" - -let create_cache () = - { - lookups = []; - mcache = []; - } - -let add_lookup cache fn = - cache.lookups <- fn :: cache.lookups - -(* ******* Reading from Strings ********* *) - -let sget s pos = Char.code (String.get s pos) - -let read_compressed_i32 s pos = - let v = sget s pos in - (* Printf.printf "compressed: %x (18 0x%x 19 0x%x)\n" v (sget s (pos+20)) (sget s (pos+21)); *) - if v land 0x80 = 0x00 then - pos+1, v - else if v land 0xC0 = 0x80 then - pos+2, ((v land 0x3F) lsl 8) lor (sget s (pos+1)) - else if v land 0xE0 = 0xC0 then - pos+4, ((v land 0x1F) lsl 24) lor ((sget s (pos+1)) lsl 16) lor ((sget s (pos+2)) lsl 8) lor (sget s (pos+3)) - else - error (Printf.sprintf "Error reading compressed data. Invalid first byte: %x" v) - -let int_of_table (idx : clr_meta_idx) : int = Obj.magic idx -let table_of_int (idx : int) : clr_meta_idx = Obj.magic idx - -let sread_ui8 s pos = - let n1 = sget s pos in - pos+1,n1 - -let sread_i32 s pos = - let n1 = sget s pos in - let n2 = sget s (pos+1) in - let n3 = sget s (pos+2) in - let n4 = sget s (pos+3) in - pos+4, (n4 lsl 24) lor (n3 lsl 16) lor (n2 lsl 8) lor n1 - -let sread_real_i32 s pos = - let n1 = sget s pos in - let n2 = sget s (pos+1) in - let n3 = sget s (pos+2) in - let n4 = Int32.of_int (sget s (pos+3)) in - let n = Int32.of_int ((n3 lsl 16) lor (n2 lsl 8) lor n1) in - let n4 = Int32.shift_left n4 24 in - pos+4, (Int32.logor n4 n) - -let sread_i64 s pos = - let pos, v1 = sread_real_i32 s (pos+1) in - let v1 = Int64.of_int32 v1 in - let pos, v2 = sread_real_i32 s pos in - let v2 = Int64.of_int32 v2 in - let v2 = Int64.shift_left v2 32 in - pos, (Int64.logor v1 v2) - -let sread_ui16 s pos = - let n1 = sget s pos in - let n2 = sget s (pos+1) in - pos+2, (n2 lsl 8) lor n1 - -let read_cstring ctx pos = - let s = ctx.strings_stream in - let rec loop en = - match String.get s en with - | '\x00' -> en - pos - | _ -> loop (en+1) - in - (* printf "len 0x%x - pos 0x%x\n" (String.length s) pos; *) - let len = loop pos in - String.sub s pos len - -let read_sstring_idx ctx pos = - let s = ctx.meta_stream in - let metapos,i = if ctx.strings_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - match i with - | 0 -> - metapos, "" - | _ -> - metapos, read_cstring ctx i - -let read_sblob_idx ctx pos = - let s = ctx.meta_stream in - let metapos, i = if ctx.blob_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - match i with - | 0 -> - metapos,"" - | _ -> - let bpos, len = read_compressed_i32 ctx.blob_stream i in - metapos, String.sub ctx.blob_stream bpos len - -let read_sguid_idx ctx pos = - let s = ctx.meta_stream in - let metapos,i = if ctx.guid_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - match i with - | 0 -> - metapos, "" - | _ -> - let s = ctx.guid_stream in - let i = i - 1 in - let pos = i * 16 in - metapos, String.sub s pos 16 - -let read_callconv ctx s pos = - let pos, conv = read_compressed_i32 s pos in - let callconv = callconv_of_int conv ~match_generic_inst:true in - let pos = match conv land 0x10 with - | 0x10 -> fst (read_compressed_i32 s pos) - | _ -> pos - in - pos, callconv - -let read_constant ctx with_type s pos = - match with_type with - | CBool -> - pos+1, IBool (sget s (pos) <> 0) - | CChar -> - let pos, v = sread_ui16 s (pos) in - pos, IChar v - | CInt8 | CUInt8 -> - pos+1,IByte (sget s (pos)) - | CInt16 | CUInt16 -> - let pos, v = sread_ui16 s (pos) in - pos, IShort v - | CInt32 | CUInt32 -> - let pos, v = sread_real_i32 s (pos) in - pos, IInt v - | CInt64 | CUInt64 -> - let pos, v = sread_i64 s (pos) in - pos, IInt64 v - | CFloat32 -> - let pos, v1 = sread_real_i32 s (pos) in - pos, IFloat32 (Int32.float_of_bits v1) - | CFloat64 -> - let pos, v1 = sread_i64 s (pos) in - pos, IFloat64 (Int64.float_of_bits v1) - | CString -> - if sget s pos = 0xff then - pos+1,IString "" - else - let pos, len = read_compressed_i32 s pos in - pos+len, IString (String.sub s pos len) - | CNullRef -> - pos+1, INull - -let sig_to_const = function - | SBool -> CBool - | SChar -> CChar - | SInt8 -> CInt8 - | SUInt8 -> CUInt8 - | SInt16 -> CInt16 - | SUInt16 -> CUInt16 - | SInt32 -> CInt32 - | SUInt32 -> CUInt32 - | SInt64 -> CInt64 - | SUInt64 -> CUInt64 - | SFloat32 -> CFloat32 - | SFloat64 -> CFloat64 - | SString -> CString - | _ -> CNullRef - -let read_constant_type ctx s pos = match sget s pos with - | 0x2 -> pos+1, CBool (* 0x2 *) - | 0x3 -> pos+1, CChar (* 0x3 *) - | 0x4 -> pos+1, CInt8 (* 0x4 *) - | 0x5 -> pos+1, CUInt8 (* 0x5 *) - | 0x6 -> pos+1, CInt16 (* 0x6 *) - | 0x7 -> pos+1, CUInt16 (* 0x7 *) - | 0x8 -> pos+1, CInt32 (* 0x8 *) - | 0x9 -> pos+1, CUInt32 (* 0x9 *) - | 0xA -> pos+1, CInt64 (* 0xA *) - | 0xB -> pos+1, CUInt64 (* 0xB *) - | 0xC -> pos+1, CFloat32 (* 0xC *) - | 0xD -> pos+1, CFloat64 (* 0xD *) - | 0xE -> pos+1, CString (* 0xE *) - | 0x12 -> pos+1, CNullRef (* 0x12 *) - | i -> Printf.printf "0x%x\n" i; assert false - -let action_security_of_int = function - | 0x1 -> SecRequest (* 0x1 *) - | 0x2 -> SecDemand (* 0x2 *) - | 0x3 -> SecAssert (* 0x3 *) - | 0x4 -> SecDeny (* 0x4 *) - | 0x5 -> SecPermitOnly (* 0x5 *) - | 0x6 -> SecLinkCheck (* 0x6 *) - | 0x7 -> SecInheritCheck (* 0x7 *) - | 0x8 -> SecReqMin (* 0x8 *) - | 0x9 -> SecReqOpt (* 0x9 *) - | 0xA -> SecReqRefuse (* 0xA *) - | 0xB -> SecPreJitGrant (* 0xB *) - | 0xC -> SecPreJitDeny (* 0xC *) - | 0xD -> SecNonCasDemand (* 0xD *) - | 0xE -> SecNonCasLinkDemand (* 0xE *) - | 0xF -> SecNonCasInheritance (* 0xF *) - | _ -> assert false - -(* ******* Metadata Tables ********* *) -let null_meta = UnknownMeta (-1) - -let mk_module id = - { - md_id = id; - md_generation = 0; - md_name = empty; - md_vid = empty; - md_encid = empty; - md_encbase_id = empty; - } - -let null_module = mk_module (-1) - -let mk_type_ref id = - { - tr_id = id; - tr_resolution_scope = null_meta; - tr_name = empty; - tr_namespace = []; - } - -let null_type_ref = mk_type_ref (-1) - -let mk_type_def id = - { - td_id = id; - td_flags = null_type_def_flags; - td_name = empty; - td_namespace = []; - td_extends = None; - td_field_list = []; - td_method_list = []; - td_extra_enclosing = None; - } - -let null_type_def = mk_type_def (-1) - -let mk_field id = - { - f_id = id; - f_flags = null_field_flags; - f_name = empty; - f_signature = SVoid; - } - -let null_field = mk_field (-1) - -let mk_field_ptr id = - { - fp_id = id; - fp_field = null_field; - } - -let null_field_ptr = mk_field_ptr (-1) - -let mk_method id = - { - m_id = id; - m_rva = Int32.of_int (-1); - m_flags = null_method_flags; - m_name = empty; - m_signature = SVoid; - m_param_list = []; - m_declaring = None; - } - -let null_method = mk_method (-1) - -let mk_method_ptr id = - { - mp_id = id; - mp_method = null_method; - } - -let null_method_ptr = mk_method_ptr (-1) - -let mk_param id = - { - p_id = id; - p_flags = null_param_flags; - p_sequence = -1; - p_name = empty; - } - -let null_param = mk_param (-1) - -let mk_param_ptr id = - { - pp_id = id; - pp_param = null_param; - } - -let null_param_ptr = mk_param_ptr (-1) - -let mk_interface_impl id = - { - ii_id = id; - ii_class = null_type_def; (* TypeDef rid *) - ii_interface = null_meta; - } - -let null_interface_impl = mk_interface_impl (-1) - -let mk_member_ref id = - { - memr_id = id; - memr_class = null_meta; - memr_name = empty; - memr_signature = SVoid; - } - -let null_member_ref = mk_member_ref (-1) - -let mk_constant id = - { - c_id = id; - c_type = CNullRef; - c_parent = null_meta; - c_value = INull; - } - -let null_constant = mk_constant (-1) - -let mk_custom_attribute id = - { - ca_id = id; - ca_parent = null_meta; - ca_type = null_meta; - ca_value = None; - } - -let null_custom_attribute = mk_custom_attribute (-1) - -let mk_field_marshal id = - { - fm_id = id; - fm_parent = null_meta; - fm_native_type = NVoid; - } - -let null_field_marshal = mk_field_marshal (-1) - -let mk_decl_security id = - { - ds_id = id; - ds_action = SecNull; - ds_parent = null_meta; - ds_permission_set = empty; - } - -let mk_class_layout id = - { - cl_id = id; - cl_packing_size = -1; - cl_class_size = -1; - cl_parent = null_type_def; - } - -let mk_field_layout id = - { - fl_id = id; - fl_offset = -1; - fl_field = null_field; - } - -let mk_stand_alone_sig id = - { - sa_id = id; - sa_signature = SVoid; - } - -let mk_event id = - { - e_id = id; - e_flags = []; - e_name = empty; - e_event_type = null_meta; - } - -let null_event = mk_event (-1) - -let mk_event_map id = - { - em_id = id; - em_parent = null_type_def; - em_event_list = []; - } - -let mk_event_ptr id = - { - ep_id = id; - ep_event = null_event; - } - -let mk_property id = - { - prop_id = id; - prop_flags = []; - prop_name = empty; - prop_type = SVoid; - } - -let null_property = mk_property (-1) - -let mk_property_map id = - { - pm_id = id; - pm_parent = null_type_def; - pm_property_list = []; - } - -let mk_property_ptr id = - { - prp_id = id; - prp_property = null_property; - } - -let mk_method_semantics id = - { - ms_id = id; - ms_semantic = []; - ms_method = null_method; - ms_association = null_meta; - } - -let mk_method_impl id = - { - mi_id = id; - mi_class = null_type_def; - mi_method_body = null_meta; - mi_method_declaration = null_meta; - } - -let mk_module_ref id = - { - modr_id = id; - modr_name = empty; - } - -let null_module_ref = mk_module_ref (-1) - -let mk_type_spec id = - { - ts_id = id; - ts_signature = SVoid; - } - -let mk_enc_log id = - { - el_id = id; - el_token = -1; - el_func_code = -1; - } - -let mk_impl_map id = - { - im_id = id; - im_flags = null_impl_flags; - im_forwarded = null_meta; - im_import_name = empty; - im_import_scope = null_module_ref; - } - -let mk_enc_map id = - { - encm_id = id; - encm_token = -1; - } - -let mk_field_rva id = - { - fr_id = id; - fr_rva = Int32.zero; - fr_field = null_field; - } - -let mk_assembly id = - { - a_id = id; - a_hash_algo = HNone; - a_major = -1; - a_minor = -1; - a_build = -1; - a_rev = -1; - a_flags = []; - a_public_key = empty; - a_name = empty; - a_locale = empty; - } - -let mk_assembly_processor id = - { - ap_id = id; - ap_processor = -1; - } - -let mk_assembly_os id = - { - aos_id = id; - aos_platform_id = -1; - aos_major_version = -1; - aos_minor_version = -1; - } - -let mk_assembly_ref id = - { - ar_id = id; - ar_major = -1; - ar_minor = -1; - ar_build = -1; - ar_rev = -1; - ar_flags = []; - ar_public_key = empty; - ar_name = empty; - ar_locale = empty; - ar_hash_value = empty; - } - -let null_assembly_ref = mk_assembly_ref (-1) - -let mk_assembly_ref_processor id = - { - arp_id = id; - arp_processor = -1; - arp_assembly_ref = null_assembly_ref; - } - -let mk_assembly_ref_os id = - { - aros_id = id; - aros_platform_id = -1; - aros_major = -1; - aros_minor = -1; - aros_assembly_ref = null_assembly_ref; - } - -let mk_file id = - { - file_id = id; - file_flags = ContainsMetadata; - file_name = empty; - file_hash_value = empty; - } - -let mk_exported_type id = - { - et_id = id; - et_flags = null_type_def_flags; - et_type_def_id = -1; - et_type_name = empty; - et_type_namespace = []; - et_implementation = null_meta; - } - -let mk_manifest_resource id = - { - mr_id = id; - mr_offset = -1; - mr_flags = RNone; - mr_name = empty; - mr_implementation = None; - } - -let mk_nested_class id = - { - nc_id = id; - nc_nested = null_type_def; - nc_enclosing = null_type_def; - } - -let mk_generic_param id = - { - gp_id = id; - gp_number = -1; - gp_flags = null_generic_flags; - gp_owner = null_meta; - gp_name = None; - } - -let null_generic_param = mk_generic_param (-1) - -let mk_method_spec id = - { - mspec_id = id; - mspec_method = null_meta; - mspec_instantiation = SVoid; - } - -let mk_generic_param_constraint id = - { - gc_id = id; - gc_owner = null_generic_param; - gc_constraint = null_meta; - } - -let mk_meta tbl id = match tbl with - | IModule -> Module (mk_module id) - | ITypeRef -> TypeRef (mk_type_ref id) - | ITypeDef -> TypeDef (mk_type_def id) - | IFieldPtr -> FieldPtr (mk_field_ptr id) - | IField -> Field (mk_field id) - | IMethodPtr -> MethodPtr (mk_method_ptr id) - | IMethod -> Method (mk_method id) - | IParamPtr -> ParamPtr (mk_param_ptr id) - | IParam -> Param (mk_param id) - | IInterfaceImpl -> InterfaceImpl (mk_interface_impl id) - | IMemberRef -> MemberRef (mk_member_ref id) - | IConstant -> Constant (mk_constant id) - | ICustomAttribute -> CustomAttribute (mk_custom_attribute id) - | IFieldMarshal -> FieldMarshal(mk_field_marshal id) - | IDeclSecurity -> DeclSecurity(mk_decl_security id) - | IClassLayout -> ClassLayout(mk_class_layout id) - | IFieldLayout -> FieldLayout(mk_field_layout id) - | IStandAloneSig -> StandAloneSig(mk_stand_alone_sig id) - | IEventMap -> EventMap(mk_event_map id) - | IEventPtr -> EventPtr(mk_event_ptr id) - | IEvent -> Event(mk_event id) - | IPropertyMap -> PropertyMap(mk_property_map id) - | IPropertyPtr -> PropertyPtr(mk_property_ptr id) - | IProperty -> Property(mk_property id) - | IMethodSemantics -> MethodSemantics(mk_method_semantics id) - | IMethodImpl -> MethodImpl(mk_method_impl id) - | IModuleRef -> ModuleRef(mk_module_ref id) - | ITypeSpec -> TypeSpec(mk_type_spec id) - | IImplMap -> ImplMap(mk_impl_map id) - | IFieldRVA -> FieldRVA(mk_field_rva id) - | IENCLog -> ENCLog(mk_enc_log id) - | IENCMap -> ENCMap(mk_enc_map id) - | IAssembly -> Assembly(mk_assembly id) - | IAssemblyProcessor -> AssemblyProcessor(mk_assembly_processor id) - | IAssemblyOS -> AssemblyOS(mk_assembly_os id) - | IAssemblyRef -> AssemblyRef(mk_assembly_ref id) - | IAssemblyRefProcessor -> AssemblyRefProcessor(mk_assembly_ref_processor id) - | IAssemblyRefOS -> AssemblyRefOS(mk_assembly_ref_os id) - | IFile -> File(mk_file id) - | IExportedType -> ExportedType(mk_exported_type id) - | IManifestResource -> ManifestResource(mk_manifest_resource id) - | INestedClass -> NestedClass(mk_nested_class id) - | IGenericParam -> GenericParam(mk_generic_param id) - | IMethodSpec -> MethodSpec(mk_method_spec id) - | IGenericParamConstraint -> GenericParamConstraint(mk_generic_param_constraint id) - | i -> UnknownMeta (int_of_table i) - -let get_table ctx idx rid = - let cur = ctx.tables.(int_of_table idx) in - DynArray.get cur (rid-1) - -(* special coded types *) -let max_clr_meta_idx = 76 - -let coded_description = Array.init (max_clr_meta_idx - 63) (fun i -> - let i = 64 + i in - match table_of_int i with - | ITypeDefOrRef -> - Array.of_list [ITypeDef;ITypeRef;ITypeSpec], 2 - | IHasConstant -> - Array.of_list [IField;IParam;IProperty], 2 - | IHasCustomAttribute -> - Array.of_list - [IMethod;IField;ITypeRef;ITypeDef;IParam;IInterfaceImpl;IMemberRef; - IModule;IDeclSecurity;IProperty;IEvent;IStandAloneSig;IModuleRef; - ITypeSpec;IAssembly;IAssemblyRef;IFile;IExportedType;IManifestResource; - IGenericParam;IGenericParamConstraint;IMethodSpec], 5 - | IHasFieldMarshal -> - Array.of_list [IField;IParam], 1 - | IHasDeclSecurity -> - Array.of_list [ITypeDef;IMethod;IAssembly], 2 - | IMemberRefParent -> - Array.of_list [ITypeDef;ITypeRef;IModuleRef;IMethod;ITypeSpec], 3 - | IHasSemantics -> - Array.of_list [IEvent;IProperty], 1 - | IMethodDefOrRef -> - Array.of_list [IMethod;IMemberRef], 1 - | IMemberForwarded -> - Array.of_list [IField;IMethod], 1 - | IImplementation -> - Array.of_list [IFile;IAssemblyRef;IExportedType], 2 - | ICustomAttributeType -> - Array.of_list [ITypeRef(* unused ? *);ITypeDef (* unused ? *);IMethod;IMemberRef(*;IString FIXME *)], 3 - | IResolutionScope -> - Array.of_list [IModule;IModuleRef;IAssemblyRef;ITypeRef], 2 - | ITypeOrMethodDef -> - Array.of_list [ITypeDef;IMethod], 1 - | _ -> - print_endline ("Unknown coded index: " ^ string_of_int i); - assert false) - -let set_coded_sizes ctx rows = - let check i tbls max = - if List.exists (fun t -> - let _, nrows = rows.(int_of_table t) in - nrows >= max - ) tbls then - ctx.table_sizes.(i) <- sread_i32 - in - for i = 64 to (max_clr_meta_idx) do - let tbls, size = coded_description.(i - 64) in - let max = 1 lsl (16 - size) in - check i (Array.to_list tbls) max - done - -let sread_from_table_opt ctx in_blob tbl s pos = - let i = int_of_table tbl in - let sread = if in_blob then - read_compressed_i32 - else - ctx.table_sizes.(i) - in - let pos, rid = sread s pos in - if i >= 64 then begin - let tbls,size = coded_description.(i-64) in - let mask = (1 lsl size) - 1 in - let mask = if mask = 0 then 1 else mask in - let tidx = rid land mask in - let real_rid = rid lsr size in - let real_tbl = tbls.(tidx) in - (* printf "rid 0x%x - table idx 0x%x - real_rid 0x%x\n\n" rid tidx real_rid; *) - if real_rid = 0 then - pos, None - else - pos, Some (get_table ctx real_tbl real_rid) - end else if rid = 0 then - pos, None - else - pos, Some (get_table ctx tbl rid) - -let sread_from_table ctx in_blob tbl s pos = - let pos, opt = sread_from_table_opt ctx in_blob tbl s pos in - pos, Option.get opt - -(* ******* SIGNATURE READING ********* *) -let read_inline_str s pos = - let pos, len = read_compressed_i32 s pos in - let ret = String.sub s pos len in - pos+len,ret - -let rec read_ilsig ctx s pos = - let i = sget s pos in - (* printf "0x%x\n" i; *) - let pos = pos + 1 in - match i with - | 0x1 -> pos, SVoid (* 0x1 *) - | 0x2 -> pos, SBool (* 0x2 *) - | 0x3 -> pos, SChar (* 0x3 *) - | 0x4 -> pos, SInt8 (* 0x4 *) - | 0x5 -> pos, SUInt8 (* 0x5 *) - | 0x6 -> pos, SInt16 (* 0x6 *) - | 0x7 -> pos, SUInt16 (* 0x7 *) - | 0x8 -> pos, SInt32 (* 0x8 *) - | 0x9 -> pos, SUInt32 (* 0x9 *) - | 0xA -> pos, SInt64 (* 0xA *) - | 0xB -> pos, SUInt64 (* 0xB *) - | 0xC -> pos, SFloat32 (* 0xC *) - | 0xD -> pos, SFloat64 (* 0xD *) - | 0xE -> pos, SString (* 0xE *) - | 0xF -> - let pos, s = read_ilsig ctx s pos in - pos, SPointer s - | 0x10 -> - let pos, s = read_ilsig ctx s pos in - pos, SManagedPointer s - | 0x11 -> - let pos, vt = sread_from_table ctx true ITypeDefOrRef s pos in - pos, SValueType vt - | 0x12 -> - let pos, c = sread_from_table ctx true ITypeDefOrRef s pos in - pos, SClass c - | 0x13 -> - let n = sget s pos in - pos + 1, STypeParam n - | 0x14 -> - let pos, ssig = read_ilsig ctx s pos in - let pos, rank = read_compressed_i32 s pos in - let pos, numsizes = read_compressed_i32 s pos in - let pos = ref pos in - let sizearray = Array.init numsizes (fun _ -> - let p, size = read_compressed_i32 s !pos in - pos := p; - size - ) in - let pos, bounds = read_compressed_i32 s !pos in - let pos = ref pos in - let boundsarray = Array.init bounds (fun _ -> - let p, b = read_compressed_i32 s !pos in - pos := p; - let signed = b land 0x1 = 0x1 in - let b = b lsr 1 in - if signed then -b else b - ) in - let ret = Array.init rank (fun i -> - (if i >= bounds then None else Some boundsarray.(i)) - , (if i >= numsizes then None else Some sizearray.(i)) - ) in - !pos, SArray(ssig, ret) - | 0x15 -> - (* let pos, c = sread_from_table ctx ITypeDefOrRef s pos in *) - let pos, ssig = read_ilsig ctx s pos in - let pos, ntypes = read_compressed_i32 s pos in - let rec loop acc pos n = - if n > ntypes then - pos, List.rev acc - else - let pos, ssig = read_ilsig ctx s pos in - loop (ssig :: acc) pos (n+1) - in - let pos, args = loop [] pos 1 in - pos, SGenericInst (ssig, args) - | 0x16 -> pos, STypedReference (* 0x16 *) - | 0x18 -> pos, SIntPtr (* 0x18 *) - | 0x19 -> pos, SUIntPtr (* 0x19 *) - | 0x1B -> - let pos, conv = read_compressed_i32 s pos in - let callconv = callconv_of_int conv in - let pos, ntypes = read_compressed_i32 s pos in - let pos, ret = read_ilsig ctx s pos in - let rec loop acc pos n = - if n >= ntypes then - pos, List.rev acc - else - let pos, ssig = read_ilsig ctx s pos in - loop (ssig :: acc) pos (n+1) - in - let pos, args = loop [] pos 1 in - pos, SFunPtr (callconv, ret, args) - | 0x1C -> pos, SObject (* 0x1C *) - | 0x1D -> - let pos, ssig = read_ilsig ctx s pos in - pos, SVector ssig - | 0x1E -> - let pos, conv = read_compressed_i32 s pos in - pos, SMethodTypeParam conv - | 0x1F -> - let pos, tdef = sread_from_table ctx true ITypeDefOrRef s pos in - let pos, ilsig = read_ilsig ctx s pos in - pos, SReqModifier (tdef, ilsig) - | 0x20 -> - let pos, tdef = sread_from_table ctx true ITypeDefOrRef s pos in - let pos, ilsig = read_ilsig ctx s pos in - pos, SOptModifier (tdef, ilsig) - | 0x41 -> pos, SSentinel (* 0x41 *) - | 0x45 -> - let pos, ssig = read_ilsig ctx s pos in - pos,SPinned ssig (* 0x45 *) - (* special undocumented constants *) - | 0x50 -> pos, SType - | 0x51 -> pos, SBoxed - | 0x55 -> - let pos, vt = read_inline_str s pos in - pos, SEnum vt - | _ -> - Printf.printf "unknown ilsig 0x%x\n\n" i; - assert false - -let rec read_variantsig ctx s pos = - let pos, b = sread_ui8 s pos in - match b with - | 0x00 -> pos, VT_EMPTY (* 0x00 *) - | 0x01 -> pos, VT_NULL (* 0x01 *) - | 0x02 -> pos, VT_I2 (* 0x02 *) - | 0x03 -> pos, VT_I4 (* 0x03 *) - | 0x04 -> pos, VT_R4 (* 0x04 *) - | 0x05 -> pos, VT_R8 (* 0x05 *) - | 0x06 -> pos, VT_CY (* 0x06 *) - | 0x07 -> pos, VT_DATE (* 0x07 *) - | 0x08 -> pos, VT_BSTR (* 0x08 *) - | 0x09 -> pos, VT_DISPATCH (* 0x09 *) - | 0x0A -> pos, VT_ERROR (* 0x0A *) - | 0x0B -> pos, VT_BOOL (* 0x0B *) - | 0x0C -> pos, VT_VARIANT (* 0x0C *) - | 0x0D -> pos, VT_UNKNOWN (* 0x0D *) - | 0x0E -> pos, VT_DECIMAL (* 0x0E *) - | 0x10 -> pos, VT_I1 (* 0x10 *) - | 0x11 -> pos, VT_UI1 (* 0x11 *) - | 0x12 -> pos, VT_UI2 (* 0x12 *) - | 0x13 -> pos, VT_UI4 (* 0x13 *) - | 0x14 -> pos, VT_I8 (* 0x14 *) - | 0x15 -> pos, VT_UI8 (* 0x15 *) - | 0x16 -> pos, VT_INT (* 0x16 *) - | 0x17 -> pos, VT_UINT (* 0x17 *) - | 0x18 -> pos, VT_VOID (* 0x18 *) - | 0x19 -> pos, VT_HRESULT (* 0x19 *) - | 0x1A -> pos, VT_PTR (* 0x1A *) - | 0x1B -> pos, VT_SAFEARRAY (* 0x1B *) - | 0x1C -> pos, VT_CARRAY (* 0x1C *) - | 0x1D -> pos, VT_USERDEFINED (* 0x1D *) - | 0x1E -> pos, VT_LPSTR (* 0x1E *) - | 0x1F -> pos, VT_LPWSTR (* 0x1F *) - | 0x24 -> pos, VT_RECORD (* 0x24 *) - | 0x40 -> pos, VT_FILETIME (* 0x40 *) - | 0x41 -> pos, VT_BLOB (* 0x41 *) - | 0x42 -> pos, VT_STREAM (* 0x42 *) - | 0x43 -> pos, VT_STORAGE (* 0x43 *) - | 0x44 -> pos, VT_STREAMED_OBJECT (* 0x44 *) - | 0x45 -> pos, VT_STORED_OBJECT (* 0x45 *) - | 0x46 -> pos, VT_BLOB_OBJECT (* 0x46 *) - | 0x47 -> pos, VT_CF (* 0x47 *) - | 0x48 -> pos, VT_CLSID (* 0x48 *) - | _ -> assert false - -let rec read_nativesig ctx s pos : int * nativesig = - let pos, b = sread_ui8 s pos in - match b with - | 0x01 -> pos, NVoid (* 0x01 *) - | 0x02 -> pos, NBool (* 0x02 *) - | 0x03 -> pos, NInt8 (* 0x03 *) - | 0x4 -> pos, NUInt8 (* 0x4 *) - | 0x5 -> pos, NInt16 (* 0x5 *) - | 0x6 -> pos, NUInt16 (* 0x6 *) - | 0x7 -> pos, NInt32 (* 0x7 *) - | 0x8 -> pos, NUInt32 (* 0x8 *) - | 0x9 -> pos, NInt64 (* 0x9 *) - | 0xA -> pos, NUInt64 (* 0xA *) - | 0xB -> pos, NFloat32 (* 0xB *) - | 0xC -> pos, NFloat64 (* 0xC *) - | 0xD -> pos, NSysChar (* 0xD *) - | 0xE -> pos, NVariant (* 0xE *) - | 0xF -> pos, NCurrency (* 0xF *) - | 0x10 -> pos, NPointer (* 0x10 *) - | 0x11 -> pos, NDecimal (* 0x11 *) - | 0x12 -> pos, NDate (* 0x12 *) - | 0x13 -> pos, NBStr (* 0x13 *) - | 0x14 -> pos, NLPStr (* 0x14 *) - | 0x15 -> pos, NLPWStr (* 0x15 *) - | 0x16 -> pos, NLPTStr (* 0x16 *) - | 0x17 -> - let pos, size = read_compressed_i32 s pos in - pos, NFixedString size - | 0x18 -> pos, NObjectRef (* 0x18 *) - | 0x19 -> pos, NUnknown (* 0x19 *) - | 0x1A -> pos, NDispatch (* 0x1A *) - | 0x1B -> pos, NStruct (* 0x1B *) - | 0x1C -> pos, NInterface (* 0x1C *) - | 0x1D -> - let pos, v = read_variantsig ctx s pos in - pos, NSafeArray v - | 0x1E -> - let pos, size = read_compressed_i32 s pos in - let pos, t = read_variantsig ctx s pos in - pos, NFixedArray (size,t) - | 0x1F -> pos, NIntPointer (* 0x1F *) - | 0x20 -> pos, NUIntPointer (* 0x20 *) - | 0x21 -> pos, NNestedStruct (* 0x21 *) - | 0x22 -> pos, NByValStr (* 0x22 *) - | 0x23 -> pos, NAnsiBStr (* 0x23 *) - | 0x24 -> pos, NTBStr (* 0x24 *) - | 0x25 -> pos, NVariantBool (* 0x25 *) - | 0x26 -> pos, NFunctionPtr (* 0x26 *) - | 0x28 -> pos, NAsAny (* 0x28 *) - | 0x2A -> - let pos, elt = read_nativesig ctx s pos in - let pos, paramidx = read_compressed_i32 s pos in - let pos, size = read_compressed_i32 s pos in - let pos, param_mult = read_compressed_i32 s pos in - pos, NArray(elt,paramidx,size,param_mult) - | 0x2B -> pos, NLPStruct (* 0x2B *) - | 0x2C -> - let pos, guid_val = read_inline_str s pos in - let pos, unmanaged = read_inline_str s pos in - (* FIXME: read TypeRef *) - pos, NCustomMarshaler (guid_val,unmanaged) - | 0x2D -> pos, NError (* 0x2D *) - | i -> pos, NCustom i - -let read_blob_idx ctx s pos = - let metapos,i = if ctx.blob_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - metapos, i - - -let read_nativesig_idx ctx s pos = - let s = ctx.meta_stream in - let metapos,i = if ctx.blob_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - let s = ctx.blob_stream in - let _, ret = read_nativesig ctx s i in - metapos, ret - -let read_method_ilsig_idx ctx pos = - let s = ctx.meta_stream in - let metapos,i = if ctx.blob_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - let s = ctx.blob_stream in - let pos, len = read_compressed_i32 s i in - (* for x = 0 to len do *) - (* printf "%x " (sget s (i+x)) *) - (* done; *) - let endpos = pos + len in - (* printf "\n"; *) - let pos, callconv = read_callconv ctx s pos in - let pos, ntypes = read_compressed_i32 s pos in - let pos, ret = read_ilsig ctx s pos in - let rec loop acc pos n = - if n > ntypes || pos >= endpos then - pos, List.rev acc - else - let pos, ssig = read_ilsig ctx s pos in - loop (ssig :: acc) pos (n+1) - in - let pos, args = loop [] pos 1 in - metapos, SFunPtr (callconv, ret, args) - -let read_ilsig_idx ctx pos = - let s = ctx.meta_stream in - let metapos,i = if ctx.blob_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - let s = ctx.blob_stream in - let i, _ = read_compressed_i32 s i in - let _, ilsig = read_ilsig ctx s i in - metapos, ilsig - -let read_field_ilsig_idx ?(force_field=true) ctx pos = - let s = ctx.meta_stream in - let metapos,i = if ctx.blob_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - let s = ctx.blob_stream in - let i, _ = read_compressed_i32 s i in - if sget s i <> 0x6 then - if force_field then - error ("Invalid field signature: " ^ string_of_int (sget s i)) - else - read_method_ilsig_idx ctx pos - else - let _, ilsig = read_ilsig ctx s (i+1) in - metapos, ilsig - -let get_underlying_enum_type ctx name = - (* first try to get a typedef *) - let ns, name = match List.rev (String.nsplit name ".") with - | name :: ns -> List.rev ns, name - | _ -> assert false - in - try - let tdefs = ctx.tables.(int_of_table ITypeDef) in - let len = DynArray.length tdefs in - let rec loop_find idx = - if idx >= len then - raise Not_found - else - let tdef = match DynArray.get tdefs idx with | TypeDef td -> td | _ -> assert false in - if tdef.td_name = name && tdef.td_namespace = ns then - tdef - else - loop_find (idx+1) - in - let tdef = loop_find 1 in - (* now find the first static field associated with it *) - try - let nonstatic = List.find (fun f -> - not (List.mem CStatic f.f_flags.ff_contract) - ) tdef.td_field_list in - nonstatic.f_signature - with | Not_found -> assert false (* should never happen! *) - with | Not_found -> - (* FIXME: in order to correctly handle SEnum, we need to look it up *) - (* from either this assembly or from any other assembly that we reference *) - (* this is tricky - specially since this reader does not intend to handle file system *) - (* operations by itself. For now, if an enum is referenced from another module, *) - (* we won't handle it. The `cache` structure is laid out to deal with these problems *) - (* but isn't implemented yet *) - raise Exit - -let read_custom_attr ctx attr_type s pos = - let pos, prolog = sread_ui16 s pos in - if prolog <> 0x0001 then error (sprintf "Error reading custom attribute: Expected prolog 0x0001 ; got 0x%x" prolog); - let isig = match attr_type with - | Method m -> m.m_signature - | MemberRef mr -> mr.memr_signature - | _ -> assert false - in - let args = match follow isig with - | SFunPtr (_,ret,args) -> args - | _ -> assert false - in - let rec read_instance ilsig pos = - (* print_endline (IlMetaDebug.ilsig_s ilsig); *) - match follow ilsig with - | SBool | SChar | SInt8 | SUInt8 | SInt16 | SUInt16 - | SInt32 | SUInt32 | SInt64 | SUInt64 | SFloat32 | SFloat64 | SString -> - let pos, cons = read_constant ctx (sig_to_const ilsig) s pos in - pos, InstConstant (cons) - | SClass c when is_type (["System"],"Type") c -> - if (sget s pos) == 0xff then - pos+1, InstConstant INull - else - let pos, len = read_compressed_i32 s pos in - pos+len, InstType (String.sub s pos len) - | SType -> - let pos, len = read_compressed_i32 s pos in - pos+len, InstType (String.sub s pos len) - | SObject | SBoxed -> (* boxed *) - let pos = if sget s pos = 0x51 then pos+1 else pos in - let pos, ilsig = read_ilsig ctx s pos in - let pos, ret = read_instance ilsig pos in - pos, InstBoxed( ret ) - (* (match follow ilsig with *) - (* | SEnum e -> *) - (* let ilsig = get_underlying_enum_type ctx e; *) - (* let pos,e = if is_boxed then sread_i32 s pos else read_compressed_i32 s pos in *) - (* pos, InstBoxed(InstEnum e) *) - (* | _ -> *) - (* let pos, boxed = read_constant ctx (sig_to_const ilsig) s pos in *) - (* pos, InstBoxed (InstConstant boxed)) *) - | SEnum e -> - let ilsig = get_underlying_enum_type ctx e in - read_instance ilsig pos - | SValueType _ -> (* enum *) - let pos, e = sread_i32 s pos in - pos, InstEnum e - | _ -> assert false - in - let rec read_fixed acc args pos = match args with - | [] -> - pos, List.rev acc - | SVector isig :: args -> - (* print_endline "vec"; *) - let pos, nelem = sread_real_i32 s pos in - let pos, ret = if nelem = -1l then - pos, InstConstant INull - else - let nelem = Int32.to_int nelem in - let rec loop acc pos n = - if n = nelem then - pos, InstArray (List.rev acc) - else - let pos, inst = read_instance isig pos in - loop (inst :: acc) pos (n+1) - in - loop [] pos 0 - in - read_fixed (ret :: acc) args pos - | isig :: args -> - let pos, i = read_instance isig pos in - read_fixed (i :: acc) args pos - in - (* let tpos = pos in *) - let pos, fixed = read_fixed [] args pos in - (* printf "fixed %d : " (List.length args); *) - (* for x = tpos to pos do *) - (* printf "%x " (sget s x) *) - (* done; *) - (* printf "\n"; *) - (* let len = String.length s - pos - 1 in *) - (* let len = if len > 10 then 10 else len in *) - (* for x = 0 to len do *) - (* printf "%x " (sget s (pos + x)) *) - (* done; *) - (* printf "\n"; *) - let pos, nnamed = read_compressed_i32 s pos in - let pos = if nnamed > 0 then pos+1 else pos in - (* FIXME: this is a hack / quick fix around #3485 . We need to actually read named arguments *) - (* let rec read_named acc pos n = *) - (* if n = nnamed then *) - (* pos, List.rev acc *) - (* else *) - (* let pos, forp = sread_ui8 s pos in *) - (* let is_prop = if forp = 0x53 then *) - (* false *) - (* else if forp = 0x54 then *) - (* true *) - (* else *) - (* error (sprintf "named custom attribute error: expected 0x53 or 0x54 - got 0x%x" forp) *) - (* in *) - (* let pos, t = read_ilsig ctx s pos in *) - (* let pos, len = read_compressed_i32 s pos in *) - (* let name = String.sub s pos len in *) - (* let pos = pos+len in *) - (* let pos, inst = read_instance t pos in *) - (* read_named ( (is_prop, name, inst) :: acc ) pos (n+1) *) - (* in *) - (* let pos, named = read_named [] pos 0 in *) - pos, (fixed, []) - (* pos, (fixed, named) *) - -let read_custom_attr_idx ctx ca attr_type pos = - let s = ctx.meta_stream in - let metapos,i = if ctx.blob_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - if i = 0 then - metapos - else - let s = ctx.blob_stream in - let i, _ = read_compressed_i32 s i in - ctx.delays <- (fun () -> - try - let _, attr = read_custom_attr ctx attr_type s i in - ca.ca_value <- Some attr - with | Exit -> - () - ) :: ctx.delays; - metapos - -let read_next_index ctx offset table last pos = - if last then - DynArray.length ctx.tables.(int_of_table table) + 1 - else - let s = ctx.meta_stream in - let _, idx = ctx.table_sizes.(int_of_table table) s (pos+offset) in - idx - -let get_rev_list ctx table ptr_table begin_idx end_idx = - (* first check if index exists on pointer table *) - let ptr_table_t = ctx.tables.(int_of_table ptr_table) in - (* printf "table %d begin %d end %d\n" (int_of_table table) begin_idx end_idx; *) - match ctx.compressed, DynArray.length ptr_table_t with - | true, _ | _, 0 -> - (* use direct index *) - let rec loop idx acc = - if idx >= end_idx then - acc - else - loop (idx+1) (get_table ctx table idx :: acc) - in - loop begin_idx [] - | _ -> - (* use indirect index *) - let rec loop idx acc = - if idx > end_idx then - acc - else - loop (idx+1) (get_table ctx ptr_table idx :: acc) - in - let ret = loop begin_idx [] in - List.map (fun meta -> - let p = meta_root_ptr meta in - get_table ctx table p.ptr_to.root_id - ) ret - -let read_list ctx table ptr_table begin_idx offset last pos = - let end_idx = read_next_index ctx offset table last pos in - get_rev_list ctx table ptr_table begin_idx end_idx - -let parse_ns id = match String.nsplit id "." with - | [""] -> [] - | ns -> ns - -let get_meta_pointer = function - | Module r -> IModule, r.md_id - | TypeRef r -> ITypeRef, r.tr_id - | TypeDef r -> ITypeDef, r.td_id - | FieldPtr r -> IFieldPtr, r.fp_id - | Field r -> IField, r.f_id - | MethodPtr r -> IMethodPtr, r.mp_id - | Method r -> IMethod, r.m_id - | ParamPtr r -> IParamPtr, r.pp_id - | Param r -> IParam, r.p_id - | InterfaceImpl r -> IInterfaceImpl, r.ii_id - | MemberRef r -> IMemberRef, r.memr_id - | Constant r -> IConstant, r.c_id - | CustomAttribute r -> ICustomAttribute, r.ca_id - | FieldMarshal r -> IFieldMarshal, r.fm_id - | DeclSecurity r -> IDeclSecurity, r.ds_id - | ClassLayout r -> IClassLayout, r.cl_id - | FieldLayout r -> IFieldLayout, r.fl_id - | StandAloneSig r -> IStandAloneSig, r.sa_id - | EventMap r -> IEventMap, r.em_id - | EventPtr r -> IEventPtr, r.ep_id - | Event r -> IEvent, r.e_id - | PropertyMap r -> IPropertyMap, r.pm_id - | PropertyPtr r -> IPropertyPtr, r.prp_id - | Property r -> IProperty, r.prop_id - | MethodSemantics r -> IMethodSemantics, r.ms_id - | MethodImpl r -> IMethodImpl, r.mi_id - | ModuleRef r -> IModuleRef, r.modr_id - | TypeSpec r -> ITypeSpec, r.ts_id - | ImplMap r -> IImplMap, r.im_id - | FieldRVA r -> IFieldRVA, r.fr_id - | ENCLog r -> IENCLog, r.el_id - | ENCMap r -> IENCMap, r.encm_id - | Assembly r -> IAssembly, r.a_id - | AssemblyProcessor r -> IAssemblyProcessor, r.ap_id - | AssemblyOS r -> IAssemblyOS, r.aos_id - | AssemblyRef r -> IAssemblyRef, r.ar_id - | AssemblyRefProcessor r -> IAssemblyRefProcessor, r.arp_id - | AssemblyRefOS r -> IAssemblyRefOS, r.aros_id - | File r -> IFile, r.file_id - | ExportedType r -> IExportedType, r.et_id - | ManifestResource r -> IManifestResource, r.mr_id - | NestedClass r -> INestedClass, r.nc_id - | GenericParam r -> IGenericParam, r.gp_id - | MethodSpec r -> IMethodSpec, r.mspec_id - | GenericParamConstraint r -> IGenericParamConstraint, r.gc_id - | _ -> assert false - -let add_relation ctx key v = - let ptr = get_meta_pointer key in - Hashtbl.add ctx.relations ptr v - -let read_table_at ctx tbl n last pos = - (* print_endline ("rr " ^ string_of_int (n+1)); *) - let s = ctx.meta_stream in - match get_table ctx tbl (n+1 (* indices start at 1 *)) with - | Module m -> - let pos, gen = sread_ui16 s pos in - let pos, name = read_sstring_idx ctx pos in - let pos, vid = read_sguid_idx ctx pos in - let pos, encid = read_sguid_idx ctx pos in - let pos, encbase_id = read_sguid_idx ctx pos in - m.md_generation <- gen; - m.md_name <- name; - m.md_vid <- vid; - m.md_encid <- encid; - m.md_encbase_id <- encbase_id; - pos, Module m - | TypeRef tr -> - let pos, scope = sread_from_table ctx false IResolutionScope s pos in - let pos, name = read_sstring_idx ctx pos in - let pos, ns = read_sstring_idx ctx pos in - tr.tr_resolution_scope <- scope; - tr.tr_name <- name; - tr.tr_namespace <- parse_ns ns; - (* print_endline name; *) - (* print_endline ns; *) - pos, TypeRef tr - | TypeDef td -> - let startpos = pos in - let pos, flags = sread_i32 s pos in - let pos, name = read_sstring_idx ctx pos in - let pos, ns = read_sstring_idx ctx pos in - let ns = parse_ns ns in - let pos, extends = sread_from_table_opt ctx false ITypeDefOrRef s pos in - let field_offset = pos - startpos in - let pos, flist_begin = ctx.table_sizes.(int_of_table IField) s pos in - let method_offset = pos - startpos in - let pos, mlist_begin = ctx.table_sizes.(int_of_table IMethod) s pos in - td.td_flags <- type_def_flags_of_int flags; - td.td_name <- name; - td.td_namespace <- ns; - td.td_extends <- extends; - td.td_field_list <- List.rev_map get_field (read_list ctx IField IFieldPtr flist_begin field_offset last pos); - td.td_method_list <- List.rev_map get_method (read_list ctx IMethod IMethodPtr mlist_begin method_offset last pos); - List.iter (fun m -> m.m_declaring <- Some td) td.td_method_list; - let path = get_path (TypeDef td) in - Hashtbl.add ctx.typedefs path td; - (* print_endline "Type Def!"; *) - (* print_endline name; *) - (* print_endline ns; *) - pos, TypeDef td - | FieldPtr fp -> - let pos, field = sread_from_table ctx false IField s pos in - let field = get_field field in - fp.fp_field <- field; - pos, FieldPtr fp - | Field f -> - let pos, flags = sread_ui16 s pos in - let pos, name = read_sstring_idx ctx pos in - (* print_endline ("FIELD NAME " ^ name); *) - let pos, ilsig = read_field_ilsig_idx ctx pos in - (* print_endline (ilsig_s ilsig); *) - f.f_flags <- field_flags_of_int flags; - f.f_name <- name; - f.f_signature <- ilsig; - pos, Field f - | MethodPtr mp -> - let pos, m = sread_from_table ctx false IMethod s pos in - let m = get_method m in - mp.mp_method <- m; - pos, MethodPtr mp - | Method m -> - let startpos = pos in - let pos, rva = sread_i32 s pos in - let pos, iflags = sread_ui16 s pos in - let pos, flags = sread_ui16 s pos in - let pos, name = read_sstring_idx ctx pos in - let pos, ilsig = read_method_ilsig_idx ctx pos in - let offset = pos - startpos in - let pos, paramlist = ctx.table_sizes.(int_of_table IParam) s pos in - m.m_rva <- Int32.of_int rva; - m.m_flags <- method_flags_of_int iflags flags; - m.m_name <- name; - m.m_signature <- ilsig; - m.m_param_list <- List.rev_map get_param (read_list ctx IParam IParamPtr paramlist offset last pos); - pos, Method m - | ParamPtr pp -> - let pos, p = sread_from_table ctx false IParam s pos in - let p = get_param p in - pp.pp_param <- p; - pos, ParamPtr pp - | Param p -> - let pos, flags = sread_ui16 s pos in - let pos, sequence = sread_ui16 s pos in - let pos, name = read_sstring_idx ctx pos in - p.p_flags <- param_flags_of_int flags; - p.p_sequence <- sequence; - p.p_name <- name; - pos, Param p - | InterfaceImpl ii -> - let pos, cls = sread_from_table ctx false ITypeDef s pos in - add_relation ctx cls (InterfaceImpl ii); - let cls = get_type_def cls in - let pos, interface = sread_from_table ctx false ITypeDefOrRef s pos in - ii.ii_class <- cls; - ii.ii_interface <- interface; - pos, InterfaceImpl ii - | MemberRef mr -> - let pos, cls = sread_from_table ctx false IMemberRefParent s pos in - let pos, name = read_sstring_idx ctx pos in - (* print_endline name; *) - (* let pos, signature = read_ilsig_idx ctx pos in *) - let pos, signature = read_field_ilsig_idx ~force_field:false ctx pos in - (* print_endline (ilsig_s signature); *) - mr.memr_class <- cls; - mr.memr_name <- name; - mr.memr_signature <- signature; - add_relation ctx cls (MemberRef mr); - pos, MemberRef mr - | Constant c -> - let pos, ctype = read_constant_type ctx s pos in - let pos = pos+1 in - let pos, parent = sread_from_table ctx false IHasConstant s pos in - let pos, blobpos = if ctx.blob_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - let blob = ctx.blob_stream in - let blobpos, _ = read_compressed_i32 blob blobpos in - let _, value = read_constant ctx ctype blob blobpos in - c.c_type <- ctype; - c.c_parent <- parent; - c.c_value <- value; - add_relation ctx parent (Constant c); - pos, Constant c - | CustomAttribute ca -> - let pos, parent = sread_from_table ctx false IHasCustomAttribute s pos in - let pos, t = sread_from_table ctx false ICustomAttributeType s pos in - let pos = read_custom_attr_idx ctx ca t pos in - ca.ca_parent <- parent; - ca.ca_type <- t; - ca.ca_value <- None; (* this will be delayed by read_custom_attr_idx *) - add_relation ctx parent (CustomAttribute ca); - pos, CustomAttribute ca - | FieldMarshal fm -> - let pos, parent = sread_from_table ctx false IHasFieldMarshal s pos in - let pos, nativesig = read_nativesig_idx ctx s pos in - fm.fm_parent <- parent; - fm.fm_native_type <- nativesig; - add_relation ctx parent (FieldMarshal fm); - pos, FieldMarshal fm - | DeclSecurity ds -> - let pos, action = sread_ui16 s pos in - let action = action_security_of_int action in - let pos, parent = sread_from_table ctx false IHasDeclSecurity s pos in - let pos, permission_set = read_sblob_idx ctx pos in - ds.ds_action <- action; - ds.ds_parent <- parent; - ds.ds_permission_set <- permission_set; - add_relation ctx parent (DeclSecurity ds); - pos, DeclSecurity ds - | ClassLayout cl -> - let pos, psize = sread_ui16 s pos in - let pos, csize = sread_i32 s pos in - let pos, parent = sread_from_table ctx false ITypeDef s pos in - add_relation ctx parent (ClassLayout cl); - let parent = get_type_def parent in - cl.cl_packing_size <- psize; - cl.cl_class_size <- csize; - cl.cl_parent <- parent; - pos, ClassLayout cl - | FieldLayout fl -> - let pos, offset = sread_i32 s pos in - let pos, field = sread_from_table ctx false IField s pos in - fl.fl_offset <- offset; - fl.fl_field <- get_field field; - add_relation ctx field (FieldLayout fl); - pos, FieldLayout fl - | StandAloneSig sa -> - let pos, ilsig = read_field_ilsig_idx ~force_field:false ctx pos in - (* print_endline (ilsig_s ilsig); *) - sa.sa_signature <- ilsig; - pos, StandAloneSig sa - | EventMap em -> - let startpos = pos in - let pos, parent = sread_from_table ctx false ITypeDef s pos in - let offset = pos - startpos in - let pos, event_list = ctx.table_sizes.(int_of_table IEvent) s pos in - em.em_parent <- get_type_def parent; - em.em_event_list <- List.rev_map get_event (read_list ctx IEvent IEventPtr event_list offset last pos); - add_relation ctx parent (EventMap em); - pos, EventMap em - | EventPtr ep -> - let pos, event = sread_from_table ctx false IEvent s pos in - ep.ep_event <- get_event event; - pos, EventPtr ep - | Event e -> - let pos, flags = sread_ui16 s pos in - let pos, name = read_sstring_idx ctx pos in - let pos, event_type = sread_from_table ctx false ITypeDefOrRef s pos in - e.e_flags <- event_flags_of_int flags; - e.e_name <- name; - (* print_endline name; *) - e.e_event_type <- event_type; - add_relation ctx event_type (Event e); - pos, Event e - | PropertyMap pm -> - let startpos = pos in - let pos, parent = sread_from_table ctx false ITypeDef s pos in - let offset = pos - startpos in - let pos, property_list = ctx.table_sizes.(int_of_table IProperty) s pos in - pm.pm_parent <- get_type_def parent; - pm.pm_property_list <- List.rev_map get_property (read_list ctx IProperty IPropertyPtr property_list offset last pos); - add_relation ctx parent (PropertyMap pm); - pos, PropertyMap pm - | PropertyPtr pp -> - let pos, property = sread_from_table ctx false IProperty s pos in - pp.prp_property <- get_property property; - pos, PropertyPtr pp - | Property prop -> - let pos, flags = sread_ui16 s pos in - let pos, name = read_sstring_idx ctx pos in - let pos, t = read_field_ilsig_idx ~force_field:false ctx pos in - prop.prop_flags <- property_flags_of_int flags; - prop.prop_name <- name; - (* print_endline name; *) - prop.prop_type <- t; - (* print_endline (ilsig_s t); *) - pos, Property prop - | MethodSemantics ms -> - let pos, semantic = sread_ui16 s pos in - let pos, m = sread_from_table ctx false IMethod s pos in - let pos, association = sread_from_table ctx false IHasSemantics s pos in - ms.ms_semantic <- semantic_flags_of_int semantic; - ms.ms_method <- get_method m; - ms.ms_association <- association; - add_relation ctx m (MethodSemantics ms); - add_relation ctx association (MethodSemantics ms); - pos, MethodSemantics ms - | MethodImpl mi -> - let pos, cls = sread_from_table ctx false ITypeDef s pos in - let pos, method_body = sread_from_table ctx false IMethodDefOrRef s pos in - let pos, method_declaration = sread_from_table ctx false IMethodDefOrRef s pos in - mi.mi_class <- get_type_def cls; - mi.mi_method_body <- method_body; - mi.mi_method_declaration <- method_declaration; - add_relation ctx method_body (MethodImpl mi); - pos, MethodImpl mi - | ModuleRef modr -> - let pos, name = read_sstring_idx ctx pos in - modr.modr_name <- name; - (* print_endline name; *) - pos, ModuleRef modr - | TypeSpec ts -> - let pos, signature = read_ilsig_idx ctx pos in - (* print_endline (ilsig_s signature); *) - ts.ts_signature <- signature; - pos, TypeSpec ts - | ENCLog el -> - let pos, token = sread_i32 s pos in - let pos, func_code = sread_i32 s pos in - el.el_token <- token; - el.el_func_code <- func_code; - pos, ENCLog el - | ImplMap im -> - let pos, flags = sread_ui16 s pos in - let pos, forwarded = sread_from_table ctx false IMemberForwarded s pos in - let pos, import_name = read_sstring_idx ctx pos in - let pos, import_scope = sread_from_table ctx false IModuleRef s pos in - im.im_flags <- impl_flags_of_int flags; - im.im_forwarded <- forwarded; - im.im_import_name <- import_name; - im.im_import_scope <- get_module_ref import_scope; - add_relation ctx forwarded (ImplMap im); - pos, ImplMap im - | ENCMap em -> - let pos, token = sread_i32 s pos in - em.encm_token <- token; - pos, ENCMap em - | FieldRVA f -> - let pos, rva = sread_real_i32 s pos in - let pos, field = sread_from_table ctx false IField s pos in - f.fr_rva <- rva; - f.fr_field <- get_field field; - add_relation ctx field (FieldRVA f); - pos, FieldRVA f - | Assembly a -> - let pos, hash_algo = sread_i32 s pos in - let pos, major = sread_ui16 s pos in - let pos, minor = sread_ui16 s pos in - let pos, build = sread_ui16 s pos in - let pos, rev = sread_ui16 s pos in - let pos, flags = sread_i32 s pos in - let pos, public_key = read_sblob_idx ctx pos in - let pos, name = read_sstring_idx ctx pos in - let pos, locale = read_sstring_idx ctx pos in - a.a_hash_algo <- hash_algo_of_int hash_algo; - a.a_major <- major; - a.a_minor <- minor; - a.a_build <- build; - a.a_rev <- rev; - a.a_flags <- assembly_flags_of_int flags; - a.a_public_key <- public_key; - a.a_name <- name; - a.a_locale <- locale; - pos, Assembly a - | AssemblyProcessor ap -> - let pos, processor = sread_i32 s pos in - ap.ap_processor <- processor; - pos, AssemblyProcessor ap - | AssemblyOS aos -> - let pos, platform_id = sread_i32 s pos in - let pos, major = sread_i32 s pos in - let pos, minor = sread_i32 s pos in - aos.aos_platform_id <- platform_id; - aos.aos_major_version <- major; - aos.aos_minor_version <- minor; - pos, AssemblyOS aos - | AssemblyRef ar -> - let pos, major = sread_ui16 s pos in - let pos, minor = sread_ui16 s pos in - let pos, build = sread_ui16 s pos in - let pos, rev = sread_ui16 s pos in - let pos, flags = sread_i32 s pos in - let pos, public_key = read_sblob_idx ctx pos in - let pos, name = read_sstring_idx ctx pos in - let pos, locale = read_sstring_idx ctx pos in - let pos, hash_value = read_sblob_idx ctx pos in - ar.ar_major <- major; - ar.ar_minor <- minor; - ar.ar_build <- build; - ar.ar_rev <- rev; - ar.ar_flags <- assembly_flags_of_int flags; - ar.ar_public_key <- public_key; - ar.ar_name <- name; - (* print_endline name; *) - ar.ar_locale <- locale; - (* print_endline locale; *) - ar.ar_hash_value <- hash_value; - pos, AssemblyRef ar - | AssemblyRefProcessor arp -> - let pos, processor = sread_i32 s pos in - let pos, assembly_ref = sread_from_table ctx false IAssemblyRef s pos in - arp.arp_processor <- processor; - arp.arp_assembly_ref <- get_assembly_ref assembly_ref; - pos, AssemblyRefProcessor arp - | AssemblyRefOS aros -> - let pos, platform_id = sread_i32 s pos in - let pos, major = sread_i32 s pos in - let pos, minor = sread_i32 s pos in - let pos, assembly_ref = sread_from_table ctx false IAssemblyRef s pos in - aros.aros_platform_id <- platform_id; - aros.aros_major <- major; - aros.aros_minor <- minor; - aros.aros_assembly_ref <- get_assembly_ref assembly_ref; - pos, AssemblyRefOS aros - | File file -> - let pos, flags = sread_i32 s pos in - let pos, name = read_sstring_idx ctx pos in - let pos, hash_value = read_sblob_idx ctx pos in - file.file_flags <- file_flag_of_int flags; - file.file_name <- name; - (* print_endline ("file " ^ name); *) - file.file_hash_value <- hash_value; - pos, File file - | ExportedType et -> - let pos, flags = sread_i32 s pos in - let pos, type_def_id = sread_i32 s pos in - let pos, type_name = read_sstring_idx ctx pos in - let pos, type_namespace = read_sstring_idx ctx pos in - let pos, impl = sread_from_table ctx false IImplementation s pos in - et.et_flags <- type_def_flags_of_int flags; - et.et_type_def_id <- type_def_id; - et.et_type_name <- type_name; - et.et_type_namespace <- parse_ns type_namespace; - et.et_implementation <- impl; - add_relation ctx impl (ExportedType et); - pos, ExportedType et - | ManifestResource mr -> - let pos, offset = sread_i32 s pos in - let pos, flags = sread_i32 s pos in - (* printf "offset 0x%x flags 0x%x\n" offset flags; *) - let pos, name = read_sstring_idx ctx pos in - let rpos, i = ctx.table_sizes.(int_of_table IImplementation) s pos in - let pos, impl = - if i = 0 then - rpos, None - else - let pos, ret = sread_from_table ctx false IImplementation s pos in - add_relation ctx ret (ManifestResource mr); - pos, Some ret - in - mr.mr_offset <- offset; - mr.mr_flags <- manifest_resource_flag_of_int flags; - mr.mr_name <- name; - mr.mr_implementation <- impl; - pos, ManifestResource mr - | NestedClass nc -> - let pos, nested = sread_from_table ctx false ITypeDef s pos in - let pos, enclosing = sread_from_table ctx false ITypeDef s pos in - nc.nc_nested <- get_type_def nested; - nc.nc_enclosing <- get_type_def enclosing; - - assert (nc.nc_nested.td_extra_enclosing = None); - nc.nc_nested.td_extra_enclosing <- Some nc.nc_enclosing; - add_relation ctx enclosing (NestedClass nc); - pos, NestedClass nc - | GenericParam gp -> - let pos, number = sread_ui16 s pos in - let pos, flags = sread_ui16 s pos in - let pos, owner = sread_from_table ctx false ITypeOrMethodDef s pos in - let spos, nidx = - if ctx.strings_offset = 2 then - sread_ui16 s pos - else - sread_i32 s pos - in - let pos, name = - if nidx = 0 then - spos, None - else - let pos, ret = read_sstring_idx ctx pos in - (* print_endline ret; *) - pos, Some ret - in - gp.gp_number <- number; - gp.gp_flags <- generic_flags_of_int flags; - gp.gp_owner <- owner; - gp.gp_name <- name; - add_relation ctx owner (GenericParam gp); - pos, GenericParam gp - | MethodSpec mspec -> - let pos, meth = sread_from_table ctx false IMethodDefOrRef s pos in - let pos, instantiation = read_method_ilsig_idx ctx pos in - (* print_endline (ilsig_s instantiation); *) - mspec.mspec_method <- meth; - mspec.mspec_instantiation <- instantiation; - add_relation ctx meth (MethodSpec mspec); - pos, MethodSpec mspec - | GenericParamConstraint gc -> - let pos, owner = sread_from_table ctx false IGenericParam s pos in - let pos, c = sread_from_table ctx false ITypeDefOrRef s pos in - gc.gc_owner <- get_generic_param owner; - gc.gc_constraint <- c; - add_relation ctx owner (GenericParamConstraint gc); - pos, GenericParamConstraint gc - | _ -> assert false - -(* ******* META READING ********* *) - -let preset_sizes ctx rows = - Array.iteri (fun n r -> match r with - | false,_ -> () - | true,nrows -> - (* printf "table %d nrows %d\n" n nrows; *) - let tbl = table_of_int n in - ctx.tables.(n) <- DynArray.init (nrows) (fun id -> mk_meta tbl (id+1)) - ) rows - -(* let read_ *) -let read_meta ctx = - (* read header *) - let s = ctx.meta_stream in - let pos = 4 + 1 + 1 in - let flags = sget s pos in - List.iter (fun i -> if flags land i = i then match i with - | 0x01 -> - ctx.strings_offset <- 4 - | 0x02 -> - ctx.guid_offset <- 4 - | 0x04 -> - ctx.blob_offset <- 4 - | 0x20 -> - assert (not ctx.compressed); - ctx.meta_edit_continue <- true - | 0x80 -> - assert (not ctx.compressed); - ctx.meta_has_deleted <- true - | _ -> assert false - ) [0x01;0x02;0x04;0x20;0x80]; - let rid = sget s (pos+1) in - ignore rid; - let pos = pos + 2 in - let mask = Array.init 8 ( fun n -> sget s (pos + n) ) in - (* loop over masks and check which table is set *) - let set_table = Array.init 64 (fun n -> - let idx = n / 8 in - let bit = n mod 8 in - (mask.(idx) lsr bit) land 0x1 = 0x1 - ) in - let pos = ref (pos + 8 + 8) in (* there is an extra 'sorted' field, which we do not use *) - let rows = Array.mapi (fun i b -> match b with - | false -> false,0 - | true -> - let nidx, nrows = sread_i32 s !pos in - if nrows > 0xFFFF then ctx.table_sizes.(i) <- sread_i32; - pos := nidx; - true,nrows - ) set_table in - set_coded_sizes ctx rows; - (* pre-set all sizes *) - preset_sizes ctx rows; - Array.iteri (fun n r -> match r with - | false,_ -> () - | true,nrows -> - (* print_endline (string_of_int n); *) - let fn = read_table_at ctx (table_of_int n) in - let rec loop_fn n = - if n = nrows then - () - else begin - let p, _ = fn n (n = (nrows-1)) !pos in - pos := p; - loop_fn (n+1) - end - in - loop_fn 0 - ) rows; - () - -let read_padded i npad = - let buf = Buffer.create 10 in - let rec loop n = - let chr = read i in - if chr = '\x00' then begin - let npad = n land 0x3 in - if npad <> 0 then ignore (nread i (4 - npad)); - Buffer.contents buf - end else begin - Buffer.add_char buf chr; - if n = npad then - Buffer.contents buf - else - loop (n+1) - end - in - loop 1 - -let read_meta_tables pctx header module_cache = - let i = pctx.r.i in - seek_rva pctx (fst header.clr_meta); - let magic = nread_string i 4 in - if magic <> "BSJB" then error ("Error reading metadata table: Expected magic 'BSJB'. Got " ^ magic); - let major = read_ui16 i in - let minor = read_ui16 i in - ignore major; ignore minor; (* no use for them *) - ignore (read_i32 i); (* reserved *) - let vlen = read_i32 i in - let ver = nread i vlen in - ignore ver; - - (* meta storage header *) - ignore (read_ui16 i); (* reserved *) - let nstreams = read_ui16 i in - let rec streams n acc = - let offset = read_i32 i in - let size = read_real_i32 i in - let name = read_padded i 32 in - let acc = { - str_offset = offset; - str_size = size; - str_name = name; - } :: acc in - if (n+1) = nstreams then - acc - else - streams (n+1) acc - in - let streams = streams 0 [] in - - (* streams *) - let compressed = ref None in - let sstrings = ref "" in - let sblob = ref "" in - let sguid = ref "" in - let sus = ref "" in - let smeta = ref "" in - let extra = ref [] in - List.iter (fun s -> - let rva = Int32.add (fst header.clr_meta) (Int32.of_int s.str_offset) in - seek_rva pctx rva; - match String.lowercase s.str_name with - | "#guid" -> - sguid := nread_string i (Int32.to_int s.str_size) - | "#strings" -> - sstrings := nread_string i (Int32.to_int s.str_size) - | "#us" -> - sus := nread_string i (Int32.to_int s.str_size) - | "#blob" -> - sblob := nread_string i (Int32.to_int s.str_size) - | "#~" -> - assert (Option.is_none !compressed); - compressed := Some true; - smeta := nread_string i (Int32.to_int s.str_size) - | "#-" -> - assert (Option.is_none !compressed); - compressed := Some false; - smeta := nread_string i (Int32.to_int s.str_size) - | _ -> - extra := s :: !extra - ) streams; - let compressed = match !compressed with - | None -> error "No compressed or uncompressed metadata streams was found!" - | Some c -> c - in - let tables = Array.init 64 (fun _ -> DynArray.create ()) in - let ctx = { - compressed = compressed; - strings_stream = !sstrings; - strings_offset = 2; - blob_stream = !sblob; - blob_offset = 2; - guid_stream = !sguid; - guid_offset = 2; - us_stream = !sus; - meta_stream = !smeta; - meta_edit_continue = false; - meta_has_deleted = false; - - module_cache = module_cache; - extra_streams = !extra; - relations = Hashtbl.create 64; - typedefs = Hashtbl.create 64; - tables = tables; - table_sizes = Array.make (max_clr_meta_idx+1) sread_ui16; - - delays = []; - } in - read_meta ctx; - let delays = ctx.delays in - ctx.delays <- []; - List.iter (fun fn -> fn()) delays; - assert (ctx.delays = []); - { - il_tables = ctx.tables; - il_relations = ctx.relations; - il_typedefs = ctx.typedefs; - } - diff --git a/libs/ilib/ilMetaTools.ml b/libs/ilib/ilMetaTools.ml deleted file mode 100644 index 5630e99bb0e..00000000000 --- a/libs/ilib/ilMetaTools.ml +++ /dev/null @@ -1,472 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) -open IlMeta;; -open IlData;; -open PeReader;; -open ExtString;; - -let rec follow s = match s with - | SReqModifier (_,s) - | SOptModifier (_,s) -> - follow s - | SPinned s -> - follow s - | s -> s - -(* tells if a type_def_or_ref is of type `path` *) -let rec is_type path = function - | TypeDef td -> - td.td_namespace = fst path && td.td_name = snd path - | TypeRef tr -> - tr.tr_namespace = fst path && tr.tr_name = snd path - | TypeSpec ts -> (match follow ts.ts_signature with - | SClass c | SValueType c -> - is_type path c - | SGenericInst(s,_) -> (match follow s with - | SClass c | SValueType c -> - is_type path c - | _ -> false) - | _ -> false) - | _ -> assert false - -let rec get_path type_def_or_ref = match type_def_or_ref with - | TypeDef td -> (match td.td_extra_enclosing with - | None -> - td.td_namespace,[], td.td_name - | Some t2 -> - let ns, nested = match get_path (TypeDef t2) with - | ns,nested, name -> - ns, nested @ [name] - in - ns,nested, td.td_name) - | TypeRef tr -> (match tr.tr_resolution_scope with - | TypeRef tr2 -> - let ns, nested = match get_path (TypeRef tr2) with - | ns,nested, name -> - ns, nested @ [name] - in - ns,nested, tr.tr_name - | _ -> - tr.tr_namespace,[],tr.tr_name) - | TypeSpec ts -> (match follow ts.ts_signature with - | SClass c | SValueType c -> - get_path c - | SGenericInst(s,_) -> (match follow s with - | SClass c | SValueType c -> - get_path c - | _ -> [],[],"") - | _ -> [],[],"") - | _ -> assert false - -let constant_s = function - | IBool true -> "true" - | IBool false -> "false" - | IChar chr -> "'" ^ Char.escaped (Char.chr chr) ^ "'" - | IByte i -> - Printf.sprintf "(byte) 0x%x" i - | IShort i -> - Printf.sprintf "(short) 0x%x" i - | IInt i -> - Printf.sprintf "0x%lx" i - | IInt64 i -> - Printf.sprintf "0x%Lx" i - | IFloat32 f -> - Printf.sprintf "%ff" f - | IFloat64 f -> - Printf.sprintf "%fd" f - | IString s -> "\"" ^ s ^ "\"" - | INull -> "null" - -let path_s = function - | [],[], s -> s - | ns,[], s -> String.concat "." ns ^ "." ^ s - | [],enc, s -> String.concat "@" enc ^ "." ^ s - | ns,enc,s -> String.concat "." ns ^ "." ^ String.concat "@" enc ^ "." ^ s - -let rec ilsig_s = function - | SBoxed -> "boxed" - | SEnum e -> "enum " ^ e - | SType -> "System.Type" - | SVoid -> "void" - | SBool -> "bool" - | SChar -> "char" - | SInt8 -> "int8" - | SUInt8 -> "uint8" - | SInt16 -> "int16" - | SUInt16 -> "uint16" - | SInt32 -> "int32" - | SUInt32 -> "uint32" - | SInt64 -> "int64" - | SUInt64 -> "uint64" - | SFloat32 -> "float" - | SFloat64 -> "double" - | SString -> "string" - | SPointer s -> ilsig_s s ^ "*" - | SManagedPointer s -> ilsig_s s ^ "&" - | SValueType td -> "valuetype " ^ path_s (get_path td) - | SClass cl -> "classtype " ^ path_s (get_path cl) - | STypeParam t | SMethodTypeParam t -> "!" ^ string_of_int t - | SArray (s,opts) -> - ilsig_s s ^ "[" ^ String.concat "," (List.map (function - | Some i,None when i <> 0 -> - string_of_int i ^ "..." - | None, Some i when i <> 0 -> - string_of_int i - | Some s, Some b when b = 0 && s <> 0 -> - string_of_int s ^ "..." - | Some s, Some b when s <> 0 || b <> 0 -> - let b = if b > 0 then b - 1 else b in - string_of_int s ^ "..." ^ string_of_int (s + b) - | _ -> - "" - ) (Array.to_list opts)) ^ "]" - | SGenericInst (t,tl) -> - "generic " ^ (ilsig_s t) ^ "<" ^ String.concat ", " (List.map ilsig_s tl) ^ ">" - | STypedReference -> "typedreference" - | SIntPtr -> "native int" - | SUIntPtr -> "native unsigned int" - | SFunPtr (callconv,ret,args) -> - "function " ^ ilsig_s ret ^ "(" ^ String.concat ", " (List.map ilsig_s args) ^ ")" - | SObject -> "object" - | SVector s -> ilsig_s s ^ "[]" - | SReqModifier (_,s) -> "modreq() " ^ ilsig_s s - | SOptModifier (_,s) -> "modopt() " ^ ilsig_s s - | SSentinel -> "..." - | SPinned s -> "pinned " ^ ilsig_s s - -let rec instance_s = function - | InstConstant c -> constant_s c - | InstBoxed b -> "boxed " ^ instance_s b - | InstType t -> "Type " ^ t - | InstArray il -> "[" ^ String.concat ", " (List.map instance_s il) ^ "]" - | InstEnum e -> "Enum " ^ string_of_int e - -let named_attribute_s (is_prop,name,inst) = - (if is_prop then - "/*prop*/ " - else - "") - ^ name ^ " = " ^ instance_s inst - -let attributes_s (il,nal) = - "(" ^ (String.concat ", " (List.map instance_s il)) ^ (if nal <> [] then ", " ^ (String.concat ", " (List.map named_attribute_s nal)) else "") ^")" - -let meta_root m : meta_root = match m with - | Module r -> Obj.magic r - | TypeRef r -> Obj.magic r - | TypeDef r -> Obj.magic r - | FieldPtr r -> Obj.magic r - | Field r -> Obj.magic r - | MethodPtr r -> Obj.magic r - | Method r -> Obj.magic r - | ParamPtr r -> Obj.magic r - | Param r -> Obj.magic r - | InterfaceImpl r -> Obj.magic r - | MemberRef r -> Obj.magic r - | Constant r -> Obj.magic r - | CustomAttribute r -> Obj.magic r - | FieldMarshal r -> Obj.magic r - | DeclSecurity r -> Obj.magic r - | ClassLayout r -> Obj.magic r - | FieldLayout r -> Obj.magic r - | StandAloneSig r -> Obj.magic r - | EventMap r -> Obj.magic r - | EventPtr r -> Obj.magic r - | Event r -> Obj.magic r - | PropertyMap r -> Obj.magic r - | PropertyPtr r -> Obj.magic r - | Property r -> Obj.magic r - | MethodSemantics r -> Obj.magic r - | MethodImpl r -> Obj.magic r - | ModuleRef r -> Obj.magic r - | TypeSpec r -> Obj.magic r - | ImplMap r -> Obj.magic r - | FieldRVA r -> Obj.magic r - | ENCLog r -> Obj.magic r - | ENCMap r -> Obj.magic r - | Assembly r -> Obj.magic r - | AssemblyProcessor r -> Obj.magic r - | AssemblyOS r -> Obj.magic r - | AssemblyRef r -> Obj.magic r - | AssemblyRefProcessor r -> Obj.magic r - | AssemblyRefOS r -> Obj.magic r - | File r -> Obj.magic r - | ExportedType r -> Obj.magic r - | ManifestResource r -> Obj.magic r - | NestedClass r -> Obj.magic r - | GenericParam r -> Obj.magic r - | MethodSpec r -> Obj.magic r - | GenericParamConstraint r -> Obj.magic r - | _ -> assert false - -let meta_root_ptr p : meta_root_ptr = match p with - | FieldPtr r -> Obj.magic r - | MethodPtr r -> Obj.magic r - | ParamPtr r -> Obj.magic r - | EventPtr r -> Obj.magic r - | _ -> assert false - -let rec ilsig_norm = function - | SVoid -> LVoid - | SBool -> LBool - | SChar -> LChar - | SInt8 -> LInt8 - | SUInt8 -> LUInt8 - | SInt16 -> LInt16 - | SUInt16 -> LUInt16 - | SInt32 -> LInt32 - | SUInt32 -> LUInt32 - | SInt64 -> LInt64 - | SUInt64 -> LUInt64 - | SFloat32 -> LFloat32 - | SFloat64 -> LFloat64 - | SString -> LString - | SPointer p -> LPointer (ilsig_norm p) - | SManagedPointer p -> LManagedPointer (ilsig_norm p) - | SValueType v -> LValueType (get_path v, []) - | SClass v -> LClass (get_path v, []) - | STypeParam i -> LTypeParam i - | SArray (t, opts) -> LArray(ilsig_norm t, opts) - | SGenericInst (p,args) -> (match follow p with - | SClass v -> - LClass(get_path v, List.map ilsig_norm args) - | SValueType v -> - LValueType(get_path v, List.map ilsig_norm args) - | _ -> assert false) - | STypedReference -> LTypedReference - | SIntPtr -> LIntPtr - | SUIntPtr -> LUIntPtr - | SFunPtr(conv,ret,args) -> LMethod(conv,ilsig_norm ret,List.map ilsig_norm args) - | SObject -> LObject - | SVector s -> LVector (ilsig_norm s) - | SMethodTypeParam i -> LMethodTypeParam i - | SReqModifier (_,s) -> ilsig_norm s - | SOptModifier (_,s) -> ilsig_norm s - | SSentinel -> LSentinel - | SPinned s -> ilsig_norm s - | SType -> LClass( (["System"],[],"Type"), []) - | SBoxed -> LObject - | SEnum e -> - let lst = String.nsplit e "." in - let rev = List.rev lst in - match rev with - | hd :: tl -> LValueType( (List.rev tl,[],hd), [] ) - | _ -> assert false - -let ilsig_t s = - { - snorm = ilsig_norm s; - ssig = s; - } - -let ilsig_of_tdef_ref = function - | TypeDef td -> - SClass (TypeDef td) - | TypeRef tr -> - SClass (TypeRef tr) - | TypeSpec ts -> - ts.ts_signature - | s -> - (* error ("Invalid tdef_or_ref: " ^ ilsig_s s) *) - error "Invalid tdef_or_ref" - -let convert_field ctx f = - let constant = List.fold_left (fun c -> function - | Constant c -> - Some c.c_value - | _ -> - c - ) None (Hashtbl.find_all ctx.il_relations (IField, f.f_id)) - in - { - fname = f.f_name; - fflags = f.f_flags; - fsig = ilsig_t f.f_signature; - fconstant = constant; - } - -let convert_generic ctx gp = - let constraints = List.fold_left (fun c -> function - | GenericParamConstraint gc -> - ilsig_t (ilsig_of_tdef_ref gc.gc_constraint) :: c - | _ -> - c - ) [] (Hashtbl.find_all ctx.il_relations (IGenericParam, gp.gp_id)) - in - { - tnumber = gp.gp_number; - tflags = gp.gp_flags; - tname = gp.gp_name; - tconstraints = constraints; - } - -let convert_method ctx m = - let msig = ilsig_t m.m_signature in - let ret, margs = match follow msig.ssig with - | SFunPtr (_,ret,args) -> - (* print_endline m.m_name; *) - (* print_endline (Printf.sprintf "%d vs %d" (List.length args) (List.length m.m_param_list)); *) - (* print_endline (String.concat ", " (List.map (fun p ->string_of_int p.p_sequence ^ ":" ^ p.p_name) m.m_param_list)); *) - (* print_endline (String.concat ", " (List.map (ilsig_s) args)); *) - (* print_endline "\n"; *) - (* TODO: find out WHY this happens *) - let param_list = List.filter (fun p -> p.p_sequence > 0) m.m_param_list in - if List.length param_list <> List.length args then - let i = ref 0 in - ilsig_t ret, List.map (fun s -> - incr i; "arg" ^ (string_of_int !i), { pf_io = []; pf_reserved = [] }, ilsig_t s) args - else - ilsig_t ret, List.map2 (fun p s -> - p.p_name, p.p_flags, ilsig_t s - ) param_list args - | _ -> assert false - in - - let override, types, semantics = - List.fold_left (fun (override,types,semantics) -> function - | MethodImpl mi -> - let declaring = match mi.mi_method_declaration with - | MemberRef mr -> - Some (get_path mr.memr_class, mr.memr_name) - | Method m -> (match m.m_declaring with - | Some td -> - Some (get_path (TypeDef td), m.m_name) - | None -> override) - | _ -> override - in - declaring, types, semantics - | GenericParam gp -> - override, (convert_generic ctx gp) :: types, semantics - | MethodSemantics ms -> - override, types, ms.ms_semantic @ semantics - | _ -> - override,types, semantics - ) (None,[],[]) (Hashtbl.find_all ctx.il_relations (IMethod, m.m_id)) - in - { - mname = m.m_name; - mflags = m.m_flags; - msig = msig; - margs = margs; - mret = ret; - moverride = override; - mtypes = types; - msemantics = semantics; - } - -let convert_prop ctx prop = - let name = prop.prop_name in - let flags = prop.prop_flags in - let psig = ilsig_t prop.prop_type in - let pget, pset = - List.fold_left (fun (get,set) -> function - | MethodSemantics ms when List.mem SGetter ms.ms_semantic -> - assert (get = None); - Some (ms.ms_method.m_name, ms.ms_method.m_flags), set - | MethodSemantics ms when List.mem SSetter ms.ms_semantic -> - assert (set = None); - get, Some (ms.ms_method.m_name,ms.ms_method.m_flags) - | _ -> get,set - ) - (None,None) - (Hashtbl.find_all ctx.il_relations (IProperty, prop.prop_id)) - in - { - pname = name; - psig = psig; - pflags = flags; - pget = pget; - pset = pset; - } - -let convert_event ctx event = - let name = event.e_name in - let flags = event.e_flags in - let esig = ilsig_of_tdef_ref event.e_event_type in - let esig = ilsig_t esig in - let add, remove, eraise = - List.fold_left (fun (add, remove, eraise) -> function - | MethodSemantics ms when List.mem SAddOn ms.ms_semantic -> - assert (add = None); - Some (ms.ms_method.m_name, ms.ms_method.m_flags), remove, eraise - | MethodSemantics ms when List.mem SRemoveOn ms.ms_semantic -> - assert (remove = None); - add, Some (ms.ms_method.m_name,ms.ms_method.m_flags), eraise - | MethodSemantics ms when List.mem SFire ms.ms_semantic -> - assert (eraise = None); - add, remove, Some (ms.ms_method.m_name, ms.ms_method.m_flags) - | _ -> add, remove, eraise - ) - (None,None,None) - (Hashtbl.find_all ctx.il_relations (IEvent, event.e_id)) - in - { - ename = name; - eflags = flags; - esig = esig; - eadd = add; - eremove = remove; - eraise = eraise; - } - -let convert_class ctx path = - let td = Hashtbl.find ctx.il_typedefs path in - let cpath = get_path (TypeDef td) in - let cflags = td.td_flags in - let csuper = Option.map (fun e -> ilsig_t (ilsig_of_tdef_ref e)) td.td_extends in - let cfields = List.map (convert_field ctx) td.td_field_list in - let cmethods = List.map (convert_method ctx) td.td_method_list in - let enclosing = Option.map (fun t -> get_path (TypeDef t)) td.td_extra_enclosing in - let impl, types, nested, props, events, attrs = - List.fold_left (fun (impl,types,nested,props,events,attrs) -> function - | InterfaceImpl ii -> - (ilsig_t (ilsig_of_tdef_ref ii.ii_interface)) :: impl,types,nested, props, events, attrs - | GenericParam gp -> - (impl, (convert_generic ctx gp) :: types, nested, props,events, attrs) - | NestedClass nc -> - assert (nc.nc_enclosing.td_id = td.td_id); - (impl,types,(get_path (TypeDef nc.nc_nested)) :: nested, props, events, attrs) - | PropertyMap pm -> - assert (props = []); - impl,types,nested,List.map (convert_prop ctx) pm.pm_property_list, events, attrs - | EventMap em -> - assert (events = []); - (impl,types,nested,props,List.map (convert_event ctx) em.em_event_list, attrs) - | CustomAttribute a -> - impl,types,nested,props,events,(a :: attrs) - | _ -> - (impl,types,nested,props,events,attrs) - ) - ([],[],[],[],[],[]) - (Hashtbl.find_all ctx.il_relations (ITypeDef, td.td_id)) - in - { - cpath = cpath; - cflags = cflags; - csuper = csuper; - cfields = cfields; - cmethods = cmethods; - cevents = events; - cprops = props; - cimplements = impl; - ctypes = types; - cenclosing = enclosing; - cnested = nested; - cattrs = attrs; - } diff --git a/libs/ilib/ilMetaWriter.ml b/libs/ilib/ilMetaWriter.ml deleted file mode 100644 index c6daa544fa7..00000000000 --- a/libs/ilib/ilMetaWriter.ml +++ /dev/null @@ -1,78 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) - -open PeData;; -open PeReader;; -open IlMeta;; -open IO;; - -(* encoding helpers *) - -let int_of_type_def_vis = function - (* visibility flags - mask 0x7 *) - | VPrivate -> 0x0 (* 0x0 *) - | VPublic -> 0x1 (* 0x1 *) - | VNestedPublic -> 0x2 (* 0x2 *) - | VNestedPrivate -> 0x3 (* 0x3 *) - | VNestedFamily -> 0x4 (* 0x4 *) - | VNestedAssembly -> 0x5 (* 0x5 *) - | VNestedFamAndAssem -> 0x6 (* 0x6 *) - | VNestedFamOrAssem -> 0x7 (* 0x7 *) - -let int_of_type_def_layout = function - (* layout flags - mask 0x18 *) - | LAuto -> 0x0 (* 0x0 *) - | LSequential -> 0x8 (* 0x8 *) - | LExplicit -> 0x10 (* 0x10 *) - -let int_of_type_def_semantics props = List.fold_left (fun acc prop -> - (match prop with - (* semantics flags - mask 0x5A0 *) - | SInterface -> 0x20 (* 0x20 *) - | SAbstract -> 0x80 (* 0x80 *) - | SSealed -> 0x100 (* 0x100 *) - | SSpecialName -> 0x400 (* 0x400 *) - ) lor acc - ) 0 props - -let int_of_type_def_impl props = List.fold_left (fun acc prop -> - (match prop with - (* type implementation flags - mask 0x103000 *) - | IImport -> 0x1000 (* 0x1000 *) - | ISerializable -> 0x2000 (* 0x2000 *) - | IBeforeFieldInit -> 0x00100000 (* 0x00100000 *) - ) lor acc - ) 0 props - -let int_of_type_def_string = function - (* string formatting flags - mask 0x00030000 *) - | SAnsi -> 0x0 (* 0x0 *) - | SUnicode -> 0x00010000 (* 0x00010000 *) - | SAutoChar -> 0x00020000 (* 0x00020000 *) - -let int_of_type_def_flags f = - int_of_type_def_vis f.tdf_vis - lor - int_of_type_def_layout f.tdf_layout - lor - int_of_type_def_semantics f.tdf_semantics - lor - int_of_type_def_impl f.tdf_impl - lor - int_of_type_def_string f.tdf_string diff --git a/libs/ilib/peData.ml b/libs/ilib/peData.ml deleted file mode 100644 index c513c6e777a..00000000000 --- a/libs/ilib/peData.ml +++ /dev/null @@ -1,548 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) - -(* - This data is based on the - Microsoft Portable Executable and Common Object File Format Specification - Revision 8.3 -*) - -type machine_type = - | TUnknown (* 0 - unmanaged PE files only *) - | Ti386 (* 0x014c - i386 *) - | TR3000 (* 0x0162 - R3000 MIPS Little Endian *) - | TR4000 (* 0x0166 - R4000 MIPS Little Endian *) - | TR10000 (* 0x0168 - R10000 MIPS Little Endian *) - | TWCeMipsV2 (* 0x0169 - MIPS Little Endian running MS Windows CE 2 *) - | TAlpha (* 0x0184 - Alpha AXP *) - | TSh3 (* 0x01a2 - SH3 Little Endian *) - | TSh3Dsp (* 0x01a3 SH3DSP Little Endian *) - | TSh3e (* 0x01a4 SH3E Little Endian *) - | TSh4 (* 0x01a6 SH4 Little Endian *) - | TSh5 (* 0x01a8 SH5 *) - | TArm (* 0x1c0 ARM Little Endian *) - | TArmN (* 0x1c4 ARMv7 (or higher) Thumb mode only Little Endian *) - | TArm64 (* 0xaa64 - ARMv8 in 64-bit mode *) - | TEbc (* 0xebc - EFI byte code *) - | TThumb (* 0x1c2 ARM processor with Thumb decompressor *) - | TAm33 (* 0x1d3 AM33 processor *) - | TPowerPC (* 0x01f0 IBM PowerPC Little Endian *) - | TPowerPCFP (* 0x01f1 IBM PowerPC with FPU *) - | TItanium64 (* 0x0200 Intel IA64 (Itanium) *) - | TMips16 (* 0x0266 MIPS *) - | TAlpha64 (* 0x0284 Alpha AXP64 *) - | TMipsFpu (* 0x0366 MIPS with FPU *) - | TMipsFpu16 (* 0x0466 MIPS16 with FPU *) - | TTriCore (* 0x0520 Infineon *) - | TAmd64 (* 0x8664 AMD x64 and Intel E64T *) - | TM32R (* 0x9041 M32R *) - | TOSXAmd64 (* 0xC020 = 0x8664 xor 0x4644 OSX AMD x64 *) - | TLinuxAmd64 (* 0xFD1D = 0x8664 xor 0x7B79 Linux AMD x64 *) - -type coff_prop = - | RelocsStripped (* 0x1 *) - (* image file only. Indicates the file contains no base relocations and *) - (* must be loaded at its preferred base address. Should not be set for MPE files *) - | ExecutableImage (* 0x2 *) - (* Indicates that the file is an image file (EXE or DLL). Should be set for MPE files *) - | LineNumsStripped (* 0x4 *) - (* COFF line numbers have been removed. This flag should not be set for MPE files *) - (* because they do not use the debug info embedded in the PE file itself. They are saved on PDB files *) - | LocalSymsStripped (* 0x8 *) - (* COFF symbol table entries for local symbols have been removed. It should be set for MPE files *) - | AgressiveWsTrim (* 0x10 *) - (* Agressively trim the working set. This flag should not be set for pure-IL MPE files *) - | LargeAddressAware (* 0x20 *) - (* Application can handle addresses beyond the 2GB range. This flag should not be set for *) - (* pure-IL MPE files of versions 1 and 1.1, but can be set for v2.0 files *) - | BytesReversedLO (* 0x80 *) - (* Little endian. This flag should not be set for pure-IL MPE files *) - | Machine32Bit (* 0x100 *) - (* Machine is based on 32-bit architecture. This flag is usually set by the current *) - (* versions of code generators producing PE files. V2.0+ can produce 64-bit specific images *) - (* which don't have this flag set *) - | DebugStripped (* 0x200 *) - (* Debug information has been removed from the image file *) - | RemovableRunFromSwap (* 0x400 *) - (* If the image file is on removable media, copy and run it from swap file. *) - (* This flag should no be set for pure-IL MPE files *) - | NetRunFromSwap (* 0x800 *) - (* If the image file is on a network, copy and run it from the swap file. *) - (* This flag should no be set for pure-IL MPE files *) - | FileSystem (* 0x1000 *) - (* The image file is a system file (for example, a device driver) *) - (* This flag should not be set for pure-IL MPE files *) - | FileDll (* 0x2000 *) - (* This image file is a DLL rather than an EXE. It cannot be directly run. *) - | UpSystemOnly (* 0x4000 *) - (* The image file should be run on an uniprocessor machine only. *) - (* This flag should not be set for pure-IL MPE files *) - | BytesReversedHI (* 0x8000 *) - (* Big endian *) - (* This flag should not be set for pure-IL MPE files *) - -(* represents a virtual address pointer. It's 64-bit on 64-bit executables, and 32-bit otherwise *) -type pointer = int64 - -(* represents a memory index address on the target architecture. It's 64-bit on 64-bit executables, and 32-bit otherwise *) -type size_t = pointer - -(* relative virtual address. *) -(* it's always 32-bit - which means that PE/COFF files are still limited to the 4GB size *) -type rva = int32 - -(* represents a PE file-bound memory index *) -type size_t_file = int32 - -(* represents a file offset *) -(* there's no point in defining it as int32, as file seek operations need an int *) -type pointer_file = int - -type coff_header = { - coff_machine : machine_type; (* offset 0 - size 2 . *) - (* If the managed PE file is intended for various machine types (AnyCPU), it should be Ti386 *) - coff_nsections : int; (* O2S2 *) - coff_timestamp : int32; (* O4S4 *) - coff_symbol_table_pointer : rva; (* O8S4 *) - (* File pointer of the COFF symbol table. In managed PE files, it is 0 *) - coff_nsymbols : int; (* O12S4 *) - (* Number of entries in the COFF symbol table. Should be 0 in managed PE files *) - coff_optheader_size: int; (* O16S2 *) - (* Size of the PE header *) - coff_props : coff_prop list; -} - -let coff_default_exe_props = [ ExecutableImage; LineNumsStripped; LocalSymsStripped; (* Machine32Bit; *) ] - -let coff_default_dll_props = [ ExecutableImage; LineNumsStripped; LocalSymsStripped; (* Machine32Bit; *) FileDll ] - -type pe_magic = - | P32 (* 0x10b *) - | PRom (* 0x107 *) - | P64 (* 0x20b - called PE32+ on the docs *) - (* allows 64-bit address space while limiting the image size to 2 gb *) - -type subsystem = - | SUnknown (* 0 *) - | SNative (* 1 *) - (* Device drivers and native windows processes *) - | SWGui (* 2 *) - (* Windows GUI subsystem *) - | SWCui (* 3 *) - (* Windows character subsystem *) - | SPCui (* 7 *) - (* Posix character subsystem *) - | SWCeGui (* 9 *) - (* Windows CE subsystem *) - | SEfi (* 10 *) - (* EFI application *) - | SEfiBoot (* 11 *) - (* EFI driver with boot services *) - | SEfiRuntime (* 12 *) - (* EFI driver with run-time services *) - | SEfiRom (* 13 *) - (* EFI ROM Image *) - | SXbox (* 14 *) - -type dll_prop = - | DDynamicBase (* 0x0040 *) - (* DLL can be relocated at load time *) - | DForceIntegrity (* 0x0080 *) - (* Code integrity checks are enforced *) - | DNxCompat (* 0x0100 *) - (* Image is NX compatible *) - | DNoIsolation (* 0x0200 *) - (* Isolation-aware, but do not isolate the image *) - | DNoSeh (* 0x0400 *) - (* No structured exception handling *) - | DNoBind (* 0x0800 *) - (* Do not bind the image *) - | DWdmDriver (* 0x2000 *) - (* A WDM driver *) - | DTerminalServer (* 0x8000 *) - (* Terminal server aware *) - -type directory_type = - | ExportTable (* .edata *) - (* contains information about four other tables, which hold data describing *) - (* unmanaged exports of the PE file. ILAsm and VC++ linker are capable of exposing *) - (* the managed PE file as unmanaged exports *) - | ImportTable (* .idata *) - (* data on unmanaged imports consumed by the PE file. Only the VC++ linker makes *) - (* use of this table, by marking the imported unmanaged external functions used by *) - (* the unmanaged native code embedded in the same assembly. Other compilers only *) - (* contain a single entry - that of the CLR entry function *) - | ResourceTable (* .rsrc *) - (* unmanaged resources embedded in the PE file. Managed resources don't use this *) - | ExceptionTable (* .pdata *) - (* unmanaged exceptions only *) - | CertificateTable - (* points to a table of attribute certificates, used for file authentication *) - (* the first field of this entry is a file pointer rather than an RVA *) - | RelocTable (* .reloc *) - (* relocation table. We need to be aware of it if we use native TLS. *) - (* only the VC++ linker uses native TLS' *) - | DebugTable - (* unmanaged debug data starting address and size. A managed PE file doesn't carry *) - (* embedded debug data, so this data is either all zero or points to a 30-byte debug dir entry *) - (* of type 2 (IMAGE_DEBUG_TYPE_CODEVIEW), which in turn points to a CodeView-style header, containing *) - (* the path to the PDB debug file. *) - | ArchitectureTable - (* for i386, Itanium64 or AMD64, this data is set to all zeros *) - | GlobalPointer - (* the RVA of the value to be stored in the global pointer register. Size must be 0. *) - (* if the target architecture (e.g. i386 or AMD64) don't use the concept of a global pointer, *) - (* it is set to all zeros *) - | TlsTable (* .tls *) - (* The thread-local storage data. Only the VC++ linker and IL assembler produce code that use it *) - | LoadConfigTable - (* data specific to Windows NT OS *) - | BoundImportTable - (* array of bound import descriptors, each of which describes a DLL this image was bound *) - (* at link-time, along with time stamps of the bindings. Iff they are up-to-date, the OS loader *) - (* uses these bindings as a "shortcut" for API import *) - | ImportAddressTable - (* referenced from the Import Directory table (data directory 1) *) - | DelayImport - (* delay-load imports are DLLs described as implicit imports but loaded as explicit imports *) - (* (via calls to the LoadLibrary API) *) - | ClrRuntimeHeader (* .cormeta *) - (* pointer to the clr_runtime_header *) - | Reserved - (* must be zero *) - | Custom of int - -let directory_type_info = function - | ExportTable -> 0, "ExportTable" - | ImportTable -> 1, "ImportTable" - | ResourceTable -> 2, "ResourceTable" - | ExceptionTable -> 3, "ExceptionTable" - | CertificateTable -> 4, "CertificateTable" - | RelocTable -> 5, "RelocTable" - | DebugTable -> 6, "DebugTable" - | ArchitectureTable -> 7, "ArchTable" - | GlobalPointer -> 8, "GlobalPointer" - | TlsTable -> 9, "TlsTable" - | LoadConfigTable -> 10, "LoadConfigTable" - | BoundImportTable -> 11, "BuildImportTable" - | ImportAddressTable -> 12, "ImportAddressTable" - | DelayImport -> 13, "DelayImport" - | ClrRuntimeHeader -> 14, "ClrRuntimeHeader" - | Reserved -> 15, "Reserved" - | Custom i -> i, "Custom" ^ (string_of_int i) - -let directory_type_of_int = function - | 0 -> ExportTable - | 1 -> ImportTable - | 2 -> ResourceTable - | 3 -> ExceptionTable - | 4 -> CertificateTable - | 5 -> RelocTable - | 6 -> DebugTable - | 7 -> ArchitectureTable - | 8 -> GlobalPointer - | 9 -> TlsTable - | 10 -> LoadConfigTable - | 11 -> BoundImportTable - | 12 -> ImportAddressTable - | 13 -> DelayImport - | 14 -> ClrRuntimeHeader - | 15 -> Reserved - | i -> Custom i - -type section_prop = - | SNoPad (* 0x8 *) - (* the section should not be padded to the next boundary. *) - (* OBSOLETE - replaced by SAlign1Bytes *) - | SHasCode (* 0x20 *) - (* the section contains executable code *) - | SHasIData (* 0x40 *) - (* contains initialized data *) - | SHasData (* 0x80 *) - (* contains uninitialized data *) - | SHasLinkInfo (* 0x200 *) - (* contains comments or other information. only valid for object files *) - | SLinkRemove (* 0x1000 *) - (* this will not become part of the image. only valid for object files *) - | SGlobalRel (* 0x8000 *) - (* contains data referenced through the global pointer (GP) *) - | SHas16BitMem (* 0x20000 *) - (* for ARM architecture. The section contains Thumb code *) - | SAlign1Bytes (* 0x100000 *) - (* align data on a 1-byte boundary. valid only for object files *) - | SAlign2Bytes (* 0x200000 *) - | SAlign4Bytes (* 0x300000 *) - | SAlign8Bytes (* 0x400000 *) - | SAlign16Bytes (* 0x500000 *) - | SAlign32Bytes (* 0x600000 *) - | SAlign64Bytes (* 0x700000 *) - | SAlign128Bytes (* 0x800000 *) - | SAlign256Bytes (* 0x900000 *) - | SAlign512Bytes (* 0xA00000 *) - | SAlign1024Bytes (* 0xB00000 *) - | SAlign2048Bytes (* 0xC00000 *) - | SAlign4096Bytes (* 0xD00000 *) - | SAlign8192Bytes (* 0xE00000 *) - | SHasExtRelocs (* 0x1000000 *) - (* section contains extended relocations *) - | SCanDiscard (* 0x02000000 *) - (* section can be discarded as needed *) - | SNotCached (* 0x04000000 *) - (* section cannot be cached *) - | SNotPaged (* 0x08000000 *) - (* section is not pageable *) - | SShared (* 0x10000000 *) - (* section can be shared in memory *) - | SExec (* 0x20000000 *) - (* section can be executed as code *) - | SRead (* 0x40000000 *) - (* section can be read *) - | SWrite (* 0x80000000 *) - (* section can be written to *) - -type pe_section = { - s_name : string; - (* an 8-byte, null-padded UTF-8 encoded string *) - s_vsize : size_t_file; - (* the total size of the section when loaded into memory. *) - (* if less than s_rawsize, the section is zero-padded *) - (* should be set to 0 on object files *) - s_vaddr : rva; - (* the RVA of the beginning of the section *) - s_raw_size : size_t_file; - (* the size of the initialized data on disk, rounded up to a multiple *) - (* of the file alignment value. If it's less than s_vsize, it should be *) - (* zero filled. It may happen that rawsize is greater than vsize. *) - s_raw_pointer : pointer_file; - (* the file pointer to the first page of the section within the COFF file *) - (* on executable images, this must be a multiple of file aignment value. *) - (* for object files, it should be aligned on a 4byte boundary *) - s_reloc_pointer : pointer_file; - (* the file pointer to the beginning of relocation entries for this section *) - (* this is set to zero for executable images or if there are no relocations *) - s_line_num_pointer : pointer_file; - (* the file pointer to the beginning of line-number entries for this section *) - (* must be 0 : COFF debugging image is deprecated *) - s_nrelocs : int; - (* number of relocation entries *) - s_nline_nums : int; - (* number of line number entries *) - s_props : section_prop list; - (* properties of the section *) -} - -(* The size of the PE header is not fixed. It depends on the number of data directories defined in the header *) -(* and is specified in the optheader_size in the COFF header *) -(* object files don't have this; but it's required for image files *) -type pe_header = { - pe_coff_header : coff_header; - (* Standard fields *) - pe_magic : pe_magic; - pe_major : int; - pe_minor : int; - pe_code_size : int; - (* size of the code section (.text) or the sum of all code sections, *) - (* if multiple sections exist. The IL assembler always emits a single code section *) - pe_init_size : int; - pe_uinit_size : int; - pe_entry_addr : rva; - (* RVA of the beginning of the entry point function. For unmanaged DLLs, this can be 0 *) - (* For managed PE files, this always points to the CLR invocation stub *) - pe_base_code : rva; - (* The address that is relative to the image base of the beginning-of-code section *) - (* when it's loaded into memory *) - pe_base_data : rva; - (* The address that is relative to the image base of the beginning-of-data section *) - (* when it's loaded into memory *) - - (* COFF Windows extension *) - pe_image_base : pointer; - (* The preferred address of the first byte of image when loaded into memory. *) - (* Should be a multiple of 64K *) - pe_section_alignment : int; - (* The alignment in bytes of sections when they are loaded into memory *) - (* It must be greater than or equal to FileAlignment. The default is the page size *) - (* for the architecture *) - (* x86 MPE files should have an alignment of 8KB, even though only 4KB would be needed *) - (* for compatibility with 64-bits *) - pe_file_alignment : int; - (* The alignment factor in bytes that is used to align the raw data of sections *) - (* in the image file. The value should be a POT between 512 and 64K. *) - (* If secion_alignment is less than architecture's page size, file_alignment must match *) - (* secion_alignment *) - pe_major_osver : int; - pe_minor_osver : int; - pe_major_imgver : int; - pe_minor_imgver : int; - pe_major_subsysver : int; - pe_minor_subsysver : int; - pe_image_size : int; - (* the size of the image in bytes, as the image is loaded into memory *) - (* must be a multiple of section_alignment *) - pe_headers_size : int; - (* the combined size of an MSDOS stub, PE header, and section headers *) - (* rounded up to a multiple of FileAlignment *) - pe_checksum : int32; - pe_subsystem : subsystem; - pe_dll_props : dll_prop list; - (* in MPE files of v1.0, always set to 0; In MPE of v1.1 and later, *) - (* always set to 0x400 (DNoSeh) *) - pe_stack_reserve : size_t; - (* the size of the stack to reserve. Only pe_stack_commit is committed *) - pe_stack_commit : size_t; - (* the size of the stack to commit *) - pe_heap_reserve : size_t; - (* the size of the local heap space to reserve. Only pe_heap_commit is committed *) - pe_heap_commit : size_t; - (* the size of the heap to commit *) - pe_ndata_dir : int; - (* the number of data-directory entries in the remainder of the optional header *) - (* should be at least 16. Although is possible to emit more than 16 data directories, *) - (* all existing managed compilers emit exactly 16 data directories, with the last never *) - (* used (reserved) *) - pe_data_dirs : (rva * size_t_file) array; - (* data directories are RVA's that point to sections on the PE that have special significance *) - (* see directory_type docs *) - - (* sections *) - pe_sections : pe_section array; -} - -(* raw .idata table *) -(* not used : only here for documentation purposes *) -type idata_table_raw = { - impr_lookup_table : rva; - (* the RVA of the lookup table *) - impr_timestamp : int32; - (* on bound images, it's set to the timestamp of the DLL *) - impr_fchain : int32; - (* the index of the first forwarder reference - which are references *) - (* that are both imported and exported *) - impr_name : rva; - (* the RVA to an ASCII string that contains the name of the DLL *) - impr_address_table : rva; - (* RVA of the import address table. The contents are identical to the imp_lookup_table *) - (* until the image is bound *) -} - -(* a symbol lookup can happen either by name, or by ordinal. *) -(* lookup by name happens to be an extra indirection, as the loader *) -(* uses the name to look up the export ordinal anyway. *) -(* Most (if not all) MPE will do a lookup by name, though *) -type symbol_lookup = - | SName of int * string - | SOrdinal of int - -type idata_table = { - imp_name : string; - (* ASCII string that contains the name of the DLL *) - imp_imports : symbol_lookup list; -} - -type clr_flag = - | FIlOnly (* 0x1 *) - (* the image file contains IL code only, with no embedded native unmanaged code *) - (* this can cause some problems on WXP+, because the .reloc section is ignored when this flag is set *) - (* e.g. if native TLS support is used. In this case the VC++ compiler unsets this flag *) - | F32BitRequired (* 0x2 *) - (* the file can be only loaded into a 32-bit process *) - | FIlLibrary (* 0x4 *) - (* obsolete *) - | FSigned (* 0x8 *) - (* the image file is protected with a strong name signature *) - | FNativeEntry (* 0x10 *) - (* the executable's entry point is an unmanaged method. *) - (* the EntryPointToken / EntryPointRVA field of the CLR header *) - (* contains the RVA of this native method *) - | FTrackDebug (* 0x10000 *) - (* the CLR loader is required to track debug information about the methods. This flag is not used *) - -type clr_header = { - clr_cb : int; - (* size of header *) - clr_major : int; - clr_minor : int; - - (* symbol table and startup information *) - clr_meta : rva * size_t_file; - clr_flags : clr_flag list; - clr_entry_point : rva; - (* metadata identifier (token) of the entry point for the image file *) - (* can be 0 for DLL images. This field identifies a method belonging to this module *) - (* or a module containing the entry point method. This field may contain RVA of the *) - (* embedded native entry point method, if FNativeEntry flag is set *) - - (* binding information *) - clr_res : rva * size_t_file; - (* RVA of managed resources *) - clr_sig : rva * size_t_file; - (* RVA of the hash data for this PE file, used by the loader for binding and versioning *) - - (* regular fixup and binding information *) - clr_codeman : rva * size_t_file; - (* code manager table - RESERVED and should be 0 *) - clr_vtable_fix : rva * size_t_file; - (* RVA of an array of vtable fixups. Only VC++ linker and IL assembler produce data in this array *) - clr_export_address : rva * size_t_file; - (* rva of addresses of jump thunks. obsolete and should be set to 0 *) -} - -(* unused structure: documentation purposes only *) -type clr_stream_header = { - str_offset : pointer_file; - (* the (relative to the start of metadata) offset in the file for this stream *) - str_size : size_t_file; - (* the size of the stream in bytes *) - str_name : string; - (* name of the stream - a zero-terminated ASCII string no longer than 31 characters (plus 0 terminator) *) - (* if the stream name is smaller, it can be reduced - but must be padded to the 4-byte boundary *) -} - -(* unused structure: documentation purposes only *) -type clr_meta_table = { - (* storage signature *) - meta_magic : string; - (* always BSJB *) - meta_major : int; - meta_minor : int; - (* meta_extra : int; *) - (* reserved; always 0 *) - meta_ver : string; - (* encoded by first passing its length *) - - (* storage header *) - (* meta_flags : int; *) - (* reserved; always 0 *) - meta_nstreams : int; - (* number of streams *) - meta_strings_stream : clr_stream_header; - (* #Strings: a string heap containing the names of metadata items *) - meta_blob_stream : clr_stream_header; - (* #Blob: blob heap containing internal metadata binary object, such as default values, signatures, etc *) - meta_guid_stream : clr_stream_header; - (* #GUID: a GUID heap *) - meta_us_stream : clr_stream_header; - (* #US: user-defined strings *) - meta_meta_stream : clr_stream_header; - (* may be either: *) - (* #~: compressed (optimized) metadata stream *) - (* #-: uncompressed (unoptimized) metadata stream *) - meta_streams : clr_stream_header list; - (* custom streams *) -} diff --git a/libs/ilib/peDataDebug.ml b/libs/ilib/peDataDebug.ml deleted file mode 100644 index 4b52c11c150..00000000000 --- a/libs/ilib/peDataDebug.ml +++ /dev/null @@ -1,186 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) -open PeData;; -open Printf;; - -let machine_type_s m = match m with - | TUnknown -> "TUnknown" - | Ti386 -> "Ti386" - | TR3000 -> "TR3000" - | TR4000 -> "TR4000" - | TR10000 -> "TR10000" - | TWCeMipsV2 -> "TWCeMipsV2" - | TAlpha -> "TAlpha" - | TSh3 -> "TSh3" - | TSh3Dsp -> "TSh3Dsp" - | TSh3e -> "TSh3e" - | TSh4 -> "TSh4" - | TSh5 -> "TSh5" - | TArm -> "TArm" - | TArmN -> "TArmN" - | TArm64 -> "TArm64" - | TEbc -> "TEbc" - | TThumb -> "TThumb" - | TAm33 -> "TAm33" - | TPowerPC -> "TPowerPC" - | TPowerPCFP -> "TPowerPCFP" - | TItanium64 -> "TItanium64" - | TMips16 -> "TMips16" - | TAlpha64 -> "TAlpha64" - | TMipsFpu -> "TMipsFpu" - | TMipsFpu16 -> "TMipsFpu16" - | TTriCore -> "TTriCore" - | TAmd64 -> "TAmd64" - | TM32R -> "TM32R" - | TOSXAmd64 -> "TOSXAmd64" - | TLinuxAmd64 -> "TLinuxAmd64" - -let coff_prop_s p = match p with - | RelocsStripped -> "RelocsStripped" - | ExecutableImage -> "ExecutableImage" - | LineNumsStripped -> "LineNumsStripped" - | LocalSymsStripped -> "LocalSymsStripped" - | AgressiveWsTrim -> "AgressiveWsTrim" - | LargeAddressAware -> "LargeAddressAware" - | BytesReversedLO -> "BytesReversedLO" - | Machine32Bit -> "Machine32Bit" - | DebugStripped -> "DebugStripped" - | RemovableRunFromSwap -> "RemovableRunFromSwap" - | NetRunFromSwap -> "NetRunFromSwap" - | FileSystem -> "FileSystem" - | FileDll -> "FileDll" - | UpSystemOnly -> "UpSystemOnly" - | BytesReversedHI -> "BytesReversedHI" - -let coff_header_s h = - sprintf "#COFF_HEADER\n\tmachine: %s\n\tnsections: %d\n\ttimestamp: %ld\n\tsymbol_tbl_pointer: %ld\n\tnsymbols: %d\n\toptheader_size: %x\n\tprops: [%s]\n" - (machine_type_s h.coff_machine) - h.coff_nsections - h.coff_timestamp - h.coff_symbol_table_pointer - h.coff_nsymbols - h.coff_optheader_size - (String.concat ", " (List.map coff_prop_s h.coff_props)) - -let pe_magic_s = function - | P32 -> "P32" - | PRom -> "PRom" - | P64 -> "P64" - -let subsystem_s = function - | SUnknown -> "SUnknown" (* 0 *) - | SNative -> "SNative" (* 1 *) - | SWGui -> "SWGui" (* 2 *) - | SWCui -> "SWCui" (* 3 *) - | SPCui -> "SPCui" (* 7 *) - | SWCeGui -> "SWCeGui" (* 9 *) - | SEfi -> "SEfi" (* 10 *) - | SEfiBoot -> "SEfiBoot" (* 11 *) - | SEfiRuntime -> "SEfiRuntime" (* 12 *) - | SEfiRom -> "SEfiRom" (* 13 *) - | SXbox -> "SXbox" (* 14 *) - -let dll_prop_s = function - | DDynamicBase -> "DDynamicBase" (* 0x0040 *) - | DForceIntegrity -> "DForceIntegrity" (* 0x0080 *) - | DNxCompat -> "DNxCompat" (* 0x0100 *) - | DNoIsolation -> "DNoIsolation" (* 0x0200 *) - | DNoSeh -> "DNoSeh" (* 0x0400 *) - | DNoBind -> "DNoBind" (* 0x0800 *) - | DWdmDriver -> "DWdmDriver" (* 0x2000 *) - | DTerminalServer -> "DTerminalServer" (* 0x8000 *) - -let section_prop_s = function - | SNoPad -> "SNoPad" - | SHasCode -> "SHasCode" - | SHasIData -> "SHasIData" - | SHasData -> "SHasData" - | SHasLinkInfo -> "SHasLinkInfo" - | SLinkRemove -> "SLinkRemove" - | SGlobalRel -> "SGlobalRel" - | SHas16BitMem -> "SHas16BitMem" - | SAlign1Bytes -> "SAlign1Bytes" - | SAlign2Bytes -> "SAlign2Bytes" - | SAlign4Bytes -> "SAlign4Bytes" - | SAlign8Bytes -> "SAlign8Bytes" - | SAlign16Bytes -> "SAlign16Bytes" - | SAlign32Bytes -> "SAlign32Bytes" - | SAlign64Bytes -> "SAlign64Bytes" - | SAlign128Bytes -> "SAlign128Bytes" - | SAlign256Bytes -> "SAlign256Bytes" - | SAlign512Bytes -> "SAlign512Bytes" - | SAlign1024Bytes -> "SAlign1024Bytes" - | SAlign2048Bytes -> "SAlign2048Bytes" - | SAlign4096Bytes -> "SAlign4096Bytes" - | SAlign8192Bytes -> "SAlign8192Bytes" - | SHasExtRelocs -> "SHasExtRelocs" - | SCanDiscard -> "SCanDiscard" - | SNotCached -> "SNotCached" - | SNotPaged -> "SNotPaged" - | SShared -> "SShared" - | SExec -> "SExec" - | SRead -> "SRead" - | SWrite -> "SWrite" - -let pe_section_s s = - Printf.sprintf "\t%s :\n\t\trva: %lx\n\t\traw size: %lx\n\t\tprops: [%s]" - s.s_name - s.s_vaddr - s.s_raw_size - (String.concat ", " (List.map section_prop_s s.s_props)) - -let data_dirs_s a = - let lst = Array.to_list (Array.mapi (fun i (r,l) -> - let _,s = directory_type_info (directory_type_of_int i) in - Printf.sprintf "%s: %lx (%lx)" s r l - ) a) in - String.concat "\n\t\t" lst - -let pe_header_s h = - sprintf "#PE_HEADER\n\tmagic: %s\n\tmajor.minor %d.%d\n\tsubsystem: %s\n\tdll props: [%s]\n\tndata_dir: %i\n\t\t%s\n#SECTIONS\n%s" - (pe_magic_s h.pe_magic) - h.pe_major h.pe_minor - (subsystem_s h.pe_subsystem) - (String.concat ", " (List.map dll_prop_s h.pe_dll_props)) - h.pe_ndata_dir - (data_dirs_s h.pe_data_dirs) - (String.concat "\n" (List.map pe_section_s (Array.to_list h.pe_sections))) - -let symbol_lookup_s = function - | SName (hint,s) -> "SName(" ^ string_of_int hint ^ ", " ^ s ^ ")" - | SOrdinal i -> "SOrdinal(" ^ string_of_int i ^ ")" - -let idata_table_s t = - sprintf "#IMPORT %s:\n\t%s" - t.imp_name - (String.concat "\n\t" (List.map symbol_lookup_s t.imp_imports)) - -let clr_flag_s = function - | FIlOnly -> "FIlOnly" (* 0x1 *) - | F32BitRequired -> "F32BitRequired" (* 0x2 *) - | FIlLibrary -> "FIlLibrary" (* 0x4 *) - | FSigned -> "FSigned" (* 0x8 *) - | FNativeEntry -> "FNativeEntry" (* 0x10 *) - | FTrackDebug -> "FTrackDebug" (* 0x10000 *) - -let clr_header_s h = - sprintf "#CLR v%d.%d\n\tflags: %s" - h.clr_major - h.clr_minor - (String.concat ", " (List.map clr_flag_s h.clr_flags)) diff --git a/libs/ilib/peReader.ml b/libs/ilib/peReader.ml deleted file mode 100644 index 4d2e4aadb7a..00000000000 --- a/libs/ilib/peReader.ml +++ /dev/null @@ -1,495 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) - -open PeData;; -open IO;; -open ExtString;; -open ExtList;; - -exception Error_message of string - -type reader_ctx = { - ch : Stdlib.in_channel; - i : IO.input; - verbose : bool; -} - -type ctx = { - r : reader_ctx; - pe_header : pe_header; - read_word : IO.input -> pointer; -} - -let error msg = raise (Error_message msg) - -let seek r pos = - seek_in r.ch pos - -let pos r = - Stdlib.pos_in r.ch - -let info r msg = - if r.verbose then - print_endline (msg()) - -let machine_type_of_int i = match i with - | 0x0 -> TUnknown (* 0 - unmanaged PE files only *) - | 0x014c -> Ti386 (* 0x014c - i386 *) - | 0x0162 -> TR3000 (* 0x0162 - R3000 MIPS Little Endian *) - | 0x0166 -> TR4000 (* 0x0166 - R4000 MIPS Little Endian *) - | 0x0168 -> TR10000 (* 0x0168 - R10000 MIPS Little Endian *) - | 0x0169 -> TWCeMipsV2 (* 0x0169 - MIPS Litlte Endian running MS Windows CE 2 *) - | 0x0184 -> TAlpha (* 0x0184 - Alpha AXP *) - | 0x01a2 -> TSh3 (* 0x01a2 - SH3 Little Endian *) - | 0x01a3 -> TSh3Dsp (* 0x01a3 SH3DSP Little Endian *) - | 0x01a4 -> TSh3e (* 0x01a4 SH3E Little Endian *) - | 0x01a6 -> TSh4 (* 0x01a6 SH4 Little Endian *) - | 0x01a8 -> TSh5 - | 0x01c0 -> TArm (* 0x1c0 ARM Little Endian *) - | 0x01c2 -> TThumb (* 0x1c2 ARM processor with Thumb decompressor *) - | 0x01c4 -> TArmN (* 0x1c0 ARM Little Endian *) - | 0xaa64 -> TArm64 - | 0xebc -> TEbc - | 0x01d3 -> TAm33 (* 0x1d3 AM33 processor *) - | 0x01f0 -> TPowerPC (* 0x01f0 IBM PowerPC Little Endian *) - | 0x01f1 -> TPowerPCFP (* 0x01f1 IBM PowerPC with FPU *) - | 0x0200 -> TItanium64 (* 0x0200 Intel IA64 (Itanium( *) - | 0x0266 -> TMips16 (* 0x0266 MIPS *) - | 0x0284 -> TAlpha64 (* 0x0284 Alpha AXP64 *) - | 0x0366 -> TMipsFpu (* 0x0366 MIPS with FPU *) - | 0x0466 -> TMipsFpu16 (* 0x0466 MIPS16 with FPU *) - | 0x0520 -> TTriCore (* 0x0520 Infineon *) - | 0x8664 -> TAmd64 (* 0x8664 AMD x64 and Intel E64T *) - | 0x9041 -> TM32R (* 0x9041 M32R *) - | 0xC020 -> TOSXAmd64 (* 0xC020 OSX AMD x64 *) - | 0xFD1D -> TLinuxAmd64 (* 0xFD1D Linux AMD x64 *) - | _ -> assert false - -let coff_props_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x1 -> RelocsStripped (* 0x1 *) - | 0x2 -> ExecutableImage (* 0x2 *) - | 0x4 -> LineNumsStripped (* 0x4 *) - | 0x8 -> LocalSymsStripped (* 0x8 *) - | 0x10 -> AgressiveWsTrim (* 0x10 *) - | 0x20 -> LargeAddressAware (* 0x20 *) - | 0x80 -> BytesReversedLO (* 0x80 *) - | 0x100 -> Machine32Bit (* 0x100 *) - | 0x200 -> DebugStripped (* 0x200 *) - | 0x400 -> RemovableRunFromSwap (* 0x400 *) - | 0x800 -> NetRunFromSwap (* 0x800 *) - | 0x1000 -> FileSystem (* 0x1000 *) - | 0x2000 -> FileDll (* 0x2000 *) - | 0x4000 -> UpSystemOnly (* 0x4000 *) - | 0x8000 -> BytesReversedHI (* 0x8000 *) - | _ -> assert false) :: acc - else - acc) [] [0x1;0x2;0x4;0x8;0x10;0x20;0x80;0x100;0x200;0x400;0x800;0x1000;0x2000;0x4000;0x8000] - -let section_props_of_int32 props = List.fold_left (fun acc i -> - if (Int32.logand props i) = i then (match i with - | 0x8l -> SNoPad - | 0x20l -> SHasCode - | 0x40l -> SHasIData - | 0x80l -> SHasData - | 0x200l -> SHasLinkInfo - | 0x1000l -> SLinkRemove - | 0x8000l -> SGlobalRel - | 0x20000l -> SHas16BitMem - | 0x100000l -> SAlign1Bytes - | 0x200000l -> SAlign2Bytes - | 0x300000l -> SAlign4Bytes - | 0x400000l -> SAlign8Bytes - | 0x500000l -> SAlign16Bytes - | 0x600000l -> SAlign32Bytes - | 0x700000l -> SAlign64Bytes - | 0x800000l -> SAlign128Bytes - | 0x900000l -> SAlign256Bytes - | 0xA00000l -> SAlign512Bytes - | 0xB00000l -> SAlign1024Bytes - | 0xC00000l -> SAlign2048Bytes - | 0xD00000l -> SAlign4096Bytes - | 0xE00000l -> SAlign8192Bytes - | 0x1000000l -> SHasExtRelocs - | 0x02000000l -> SCanDiscard - | 0x04000000l -> SNotCached - | 0x08000000l -> SNotPaged - | 0x10000000l -> SShared - | 0x20000000l -> SExec - | 0x40000000l -> SRead - | 0x80000000l -> SWrite - | _ -> assert false) :: acc - else - acc) [] [ 0x8l; 0x20l; 0x40l; 0x80l; 0x200l; 0x1000l; 0x8000l; 0x20000l; 0x100000l; 0x200000l; 0x300000l; 0x400000l; 0x500000l; 0x600000l; 0x700000l; 0x800000l; 0x900000l; 0xA00000l; 0xB00000l; 0xC00000l; 0xD00000l; 0xE00000l; 0x1000000l; 0x02000000l; 0x04000000l; 0x08000000l; 0x10000000l; 0x20000000l; 0x40000000l; 0x80000000l; ] - -let subsystem_of_int i = match i with - | 0 -> SUnknown (* 0 *) - | 1 -> SNative (* 1 *) - | 2 -> SWGui (* 2 *) - | 3 -> SWCui (* 3 *) - | 7 -> SPCui (* 7 *) - | 9 -> SWCeGui (* 9 *) - | 10 -> SEfi (* 10 *) - | 11 -> SEfiBoot (* 11 *) - | 12 -> SEfiRuntime (* 12 *) - | 13 -> SEfiRom (* 13 *) - | 14 -> SXbox (* 14 *) - | _ -> error ("Unknown subsystem " ^ string_of_int i) - -let dll_props_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x0040 -> DDynamicBase (* 0x0040 *) - | 0x0080 -> DForceIntegrity (* 0x0080 *) - | 0x0100 -> DNxCompat (* 0x0100 *) - | 0x0200 -> DNoIsolation (* 0x0200 *) - | 0x0400 -> DNoSeh (* 0x0400 *) - | 0x0800 -> DNoBind (* 0x0800 *) - | 0x2000 -> DWdmDriver (* 0x2000 *) - | 0x8000 -> DTerminalServer (* 0x8000 *) - | _ -> assert false) :: acc - else - acc) [] [0x40;0x80;0x100;0x200;0x400;0x800;0x2000;0x8000] - -let pe_magic_of_int i = match i with - | 0x10b -> P32 - | 0x107 -> PRom - | 0x20b -> P64 - | _ -> error ("Unknown PE magic number: " ^ string_of_int i) - -let clr_flags_of_int iprops = List.fold_left (fun acc i -> - if (iprops land i) = i then (match i with - | 0x1 -> FIlOnly (* 0x1 *) - | 0x2 -> F32BitRequired (* 0x2 *) - | 0x4 -> FIlLibrary (* 0x4 *) - | 0x8 -> FSigned (* 0x8 *) - | 0x10 -> FNativeEntry (* 0x10 *) - | 0x10000 -> FTrackDebug (* 0x10000 *) - | _ -> assert false) :: acc - else - acc) [] [0x1;0x2;0x4;0x8;0x10;0x10000] - -let get_dir dir ctx = - let idx,name = directory_type_info dir in - try - ctx.pe_header.pe_data_dirs.(idx) - with - | Invalid_argument _ -> - error (Printf.sprintf "The directory '%s' of index '%i' is required but is missing on this file" name idx) - -let read_rva = read_real_i32 - -let read_word is64 i = - if is64 then read_i64 i else Int64.logand (Int64.of_int32 (read_real_i32 i)) 0xFFFFFFFFL - -let read_coff_header i = - let machine = machine_type_of_int (read_ui16 i) in - let nsections = read_ui16 i in - let stamp = read_real_i32 i in - let symbol_table_pointer = read_rva i in - let nsymbols = read_i32 i in - let optheader_size = read_ui16 i in - let props = read_ui16 i in - let props = coff_props_of_int (props) in - { - coff_machine = machine; - coff_nsections = nsections; - coff_timestamp = stamp; - coff_symbol_table_pointer = symbol_table_pointer; - coff_nsymbols = nsymbols; - coff_optheader_size = optheader_size; - coff_props = props; - } - -let read_pe_header r header = - let i = r.i in - let sections_offset = (pos r) + header.coff_optheader_size in - let magic = pe_magic_of_int (read_ui16 i) in - let major = read_byte i in - let minor = read_byte i in - let code_size = read_i32 i in - let init_size = read_i32 i in - let uinit_size = read_i32 i in - let entry_addr = read_rva i in - let base_code = read_rva i in - let base_data, read_word = match magic with - | P32 | PRom -> - read_rva i, read_word false - | P64 -> - Int32.zero, read_word true - in - - (* COFF Windows extension *) - let image_base = read_word i in - let section_alignment = read_i32 i in - let file_alignment = read_i32 i in - let major_osver = read_ui16 i in - let minor_osver = read_ui16 i in - let major_imgver = read_ui16 i in - let minor_imgver = read_ui16 i in - let major_subsysver = read_ui16 i in - let minor_subsysver = read_ui16 i in - ignore (read_i32 i); (* reserved *) - let image_size = read_i32 i in - let headers_size = read_i32 i in - let checksum = read_real_i32 i in - let subsystem = subsystem_of_int (read_ui16 i) in - let dll_props = dll_props_of_int (read_ui16 i) in - let stack_reserve = read_word i in - let stack_commit = read_word i in - let heap_reserve = read_word i in - let heap_commit = read_word i in - ignore (read_i32 i); (* reserved *) - let ndata_dir = read_i32 i in - let data_dirs = Array.init ndata_dir (fun n -> - let addr = read_rva i in - let size = read_rva i in - addr,size) - in - (* sections *) - let nsections = header.coff_nsections in - seek r sections_offset; - let sections = Array.init nsections (fun n -> - let name = nread_string i 8 in - let name = try - let index = String.index name '\x00' in - String.sub name 0 index - with | Not_found -> - name - in - (*TODO check for slash names *) - let vsize = read_rva i in - let vaddr = read_rva i in - let raw_size = read_rva i in - let raw_pointer = read_i32 i in - let reloc_pointer = read_i32 i in - let line_num_pointer = read_i32 i in - let nrelocs = read_ui16 i in - let nline_nums = read_ui16 i in - let props = section_props_of_int32 (read_rva i) in - { - s_name = name; - s_vsize =vsize; - s_vaddr =vaddr; - s_raw_size =raw_size; - s_raw_pointer =raw_pointer; - s_reloc_pointer =reloc_pointer; - s_line_num_pointer =line_num_pointer; - s_nrelocs =nrelocs; - s_nline_nums =nline_nums; - s_props =props; - } - ) in - { - pe_coff_header = header; - pe_magic = magic; - pe_major = major; - pe_minor = minor; - pe_code_size = code_size; - pe_init_size = init_size; - pe_uinit_size = uinit_size; - pe_entry_addr = entry_addr; - pe_base_code = base_code; - pe_base_data = base_data; - pe_image_base = image_base; - pe_section_alignment = section_alignment; - pe_file_alignment = file_alignment; - pe_major_osver = major_osver; - pe_minor_osver = minor_osver; - pe_major_imgver = major_imgver; - pe_minor_imgver = minor_imgver; - pe_major_subsysver = major_subsysver; - pe_minor_subsysver = minor_subsysver; - pe_image_size = image_size; - pe_headers_size = headers_size; - pe_checksum = checksum; - pe_subsystem = subsystem; - pe_dll_props = dll_props; - pe_stack_reserve = stack_reserve; - pe_stack_commit = stack_commit; - pe_heap_reserve = heap_reserve; - pe_heap_commit = heap_commit; - pe_ndata_dir = ndata_dir; - pe_data_dirs = data_dirs; - pe_sections = sections; - } - -let create_r ch props = - let verbose = PMap.mem "IL_VERBOSE" props in - let i = IO.input_channel ch in - { - ch = ch; - i = i; - verbose = verbose; - } - -(* converts an RVA into a file offset. *) -let convert_rva ctx rva = - let sections = ctx.pe_header.pe_sections in - let nsections = Array.length sections in - let sec = - (* linear search. TODO maybe binary search for many sections? *) - let rec loop n = - if n >= nsections then error (Printf.sprintf "The RVA %lx is outside sections bounds!" rva); - let sec = sections.(n) in - if rva >= sec.s_vaddr && (rva < (Int32.add sec.s_vaddr sec.s_raw_size)) then - sec - else - loop (n+1) - in - loop 0 - in - let diff = Int32.to_int (Int32.sub rva sec.s_vaddr) in - sec.s_raw_pointer + diff - -let seek_rva ctx rva = seek ctx.r (convert_rva ctx rva) - -let read_cstring i = - let ret = Buffer.create 8 in - let rec loop () = - let chr = read i in - if chr = '\x00' then - Buffer.contents ret - else begin - Buffer.add_char ret chr; - loop() - end - in - loop() - -(* reads import data *) -let read_idata ctx = match get_dir ImportTable ctx with - | 0l,_ | _,0l -> - [] - | rva,size -> - seek_rva ctx rva; - let i = ctx.r.i in - let rec loop acc = - let lookup_table = read_rva i in - if lookup_table = Int32.zero then - acc - else begin - let timestamp = read_real_i32 i in - let fchain = read_real_i32 i in - let name_rva = read_rva i in - let addr_table = read_rva i in - ignore addr_table; ignore fchain; ignore timestamp; - loop ((lookup_table,name_rva) :: acc) - end - in - let tables = loop [] in - List.rev_map (function (lookup_table,name_rva) -> - seek_rva ctx lookup_table; - let is_64 = ctx.pe_header.pe_magic = P64 in - let imports_data = if not is_64 then - let rec loop acc = - let flags = read_real_i32 i in - if flags = Int32.zero then - acc - else begin - let is_ordinal = Int32.logand flags 0x80000000l = 0x80000000l in - loop ( (is_ordinal, if is_ordinal then Int32.logand flags 0xFFFFl else Int32.logand flags 0x7FFFFFFFl) :: acc ) - end - in - loop [] - else - let rec loop acc = - let flags = read_i64 i in - if flags = Int64.zero then - acc - else begin - let is_ordinal = Int64.logand flags 0x8000000000000000L = 0x8000000000000000L in - loop ( (is_ordinal, Int64.to_int32 (if is_ordinal then Int64.logand flags 0xFFFFL else Int64.logand flags 0x7FFFFFFFL)) :: acc ) - end - in - loop [] - in - let imports = List.rev_map (function - | true, ord -> - SOrdinal (Int32.to_int ord) - | false, rva -> - seek_rva ctx rva; - let hint = read_ui16 i in - SName (hint, read_cstring i) - ) imports_data in - seek_rva ctx name_rva; - let name = read_cstring i in - { - imp_name = name; - imp_imports = imports; - } - ) tables - -let has_clr_header ctx = match get_dir ClrRuntimeHeader ctx with - | 0l,_ | _,0l -> - false - | _ -> - true - -let read_clr_header ctx = match get_dir ClrRuntimeHeader ctx with - | 0l,_ | _,0l -> - error "This PE file does not have managed content" - | rva,size -> - seek_rva ctx rva; - let i = ctx.r.i in - let cb = read_i32 i in - let major = read_ui16 i in - let minor = read_ui16 i in - let read_tbl i = - let rva = read_rva i in - let size = read_real_i32 i in - rva,size - in - let meta = read_tbl i in - let corflags = clr_flags_of_int (read_i32 i) in - let entry_point = read_rva i in - let res = read_tbl i in - let clrsig = read_tbl i in - let codeman = read_tbl i in - let vtable_fix = read_tbl i in - let export_addr = read_tbl i in - { - clr_cb = cb; - clr_major = major; - clr_minor = minor; - clr_meta = meta; - clr_flags = corflags; - clr_entry_point = entry_point; - clr_res = res; - clr_sig = clrsig; - clr_codeman = codeman; - clr_vtable_fix = vtable_fix; - clr_export_address = export_addr; - } - -let read r = - let i = r.i in - if read i <> 'M' || read i <> 'Z' then - error "MZ magic header not found: Is the target file really a PE?"; - seek r 0x3c; - let pe_sig_offset = read_i32 i in - seek r pe_sig_offset; - if really_nread_string i 4 <> "PE\x00\x00" then - error "Invalid PE header signature: PE expected"; - let header = read_coff_header i in - let pe_header = read_pe_header r header in - { - r = r; - pe_header = pe_header; - read_word = read_word (pe_header.pe_magic = P64); - } diff --git a/libs/ilib/peWriter.ml b/libs/ilib/peWriter.ml deleted file mode 100644 index afc672386dc..00000000000 --- a/libs/ilib/peWriter.ml +++ /dev/null @@ -1,160 +0,0 @@ -(* - * This file is part of ilLib - * Copyright (c)2004-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. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) - -open PeData;; -open IO;; -open ExtString;; -open ExtList;; - -exception Error_message of string - -let error msg = raise (Error_message msg) - -type 'a writer_ctx = { - out : 'a IO.output; -} - -let int_of_machine_type t = match t with - | TUnknown -> 0x0 (* 0 - unmanaged PE files only *) - | Ti386 -> 0x014c (* 0x014c - i386 *) - | TR3000 -> 0x0162 (* 0x0162 - R3000 MIPS Little Endian *) - | TR4000 -> 0x0166 (* 0x0166 - R4000 MIPS Little Endian *) - | TR10000 -> 0x0168 (* 0x0168 - R10000 MIPS Little Endian *) - | TWCeMipsV2 -> 0x0169 (* 0x0169 - MIPS Litlte Endian running MS Windows CE 2 *) - | TAlpha -> 0x0184 (* 0x0184 - Alpha AXP *) - | TSh3 -> 0x01a2 (* 0x01a2 - SH3 Little Endian *) - | TSh3Dsp -> 0x01a3 (* 0x01a3 SH3DSP Little Endian *) - | TSh3e -> 0x01a4 (* 0x01a4 SH3E Little Endian *) - | TSh4 -> 0x01a6 (* 0x01a6 SH4 Little Endian *) - | TSh5 -> 0x01a8 - | TArm -> 0x01c0 (* 0x1c0 ARM Little Endian *) - | TArmN -> 0x01c4 (* 0x1c0 ARM Little Endian *) - | TArm64 -> 0xaa64 (* 0x1c0 ARM Little Endian *) - | TEbc -> 0xebc - | TThumb -> 0x01c2 (* 0x1c2 ARM processor with Thumb decompressor *) - | TAm33 -> 0x01d3 (* 0x1d3 AM33 processor *) - | TPowerPC -> 0x01f0 (* 0x01f0 IBM PowerPC Little Endian *) - | TPowerPCFP -> 0x01f1 (* 0x01f1 IBM PowerPC with FPU *) - | TItanium64 -> 0x0200 (* 0x0200 Intel IA64 (Itanium( *) - | TMips16 -> 0x0266 (* 0x0266 MIPS *) - | TAlpha64 -> 0x0284 (* 0x0284 Alpha AXP64 *) - | TMipsFpu -> 0x0366 (* 0x0366 MIPS with FPU *) - | TMipsFpu16 -> 0x0466 (* 0x0466 MIPS16 with FPU *) - | TTriCore -> 0x0520 (* 0x0520 Infineon *) - | TAmd64 -> 0x8664 (* 0x8664 AMD x64 and Intel E64T *) - | TM32R -> 0x9041 (* 0x9041 M32R *) - | TOSXAmd64 -> 0xC020 (* 0xC020 = 0x8664 xor 0x4644 OSX AMD x64 *) - | TLinuxAmd64 -> 0xFD1D (* 0xFD1D = 0x8664 xor 0x7B79 Linux AMD x64 *) - -let int_of_coff_props props = List.fold_left (fun acc prop -> - (match prop with - | RelocsStripped -> 0x1 (* 0x1 *) - | ExecutableImage -> 0x2 (* 0x2 *) - | LineNumsStripped -> 0x4 (* 0x4 *) - | LocalSymsStripped -> 0x8 (* 0x8 *) - | AgressiveWsTrim -> 0x10 (* 0x10 *) - | LargeAddressAware -> 0x20 (* 0x20 *) - | BytesReversedLO -> 0x80 (* 0x80 *) - | Machine32Bit -> 0x100 (* 0x100 *) - | DebugStripped -> 0x200 (* 0x200 *) - | RemovableRunFromSwap -> 0x400 (* 0x400 *) - | NetRunFromSwap -> 0x800 (* 0x800 *) - | FileSystem -> 0x1000 (* 0x1000 *) - | FileDll -> 0x2000 (* 0x2000 *) - | UpSystemOnly -> 0x4000 (* 0x4000 *) - | BytesReversedHI -> 0x8000 (* 0x8000 *) - ) lor acc - ) 0 props - -let int32_of_section_prop props = List.fold_left (fun acc prop -> - Int32.logor (match prop with - | SNoPad -> 0x8l (* 0x8 *) - | SHasCode -> 0x20l (* 0x20 *) - | SHasIData -> 0x40l (* 0x40 *) - | SHasData -> 0x80l (* 0x80 *) - | SHasLinkInfo -> 0x200l (* 0x200 *) - | SLinkRemove -> 0x1000l (* 0x1000 *) - | SGlobalRel -> 0x8000l (* 0x8000 *) - | SHas16BitMem -> 0x20000l (* 0x20000 *) - | SAlign1Bytes -> 0x100000l (* 0x100000 *) - | SAlign2Bytes -> 0x200000l (* 0x200000 *) - | SAlign4Bytes -> 0x300000l (* 0x300000 *) - | SAlign8Bytes -> 0x400000l (* 0x400000 *) - | SAlign16Bytes -> 0x500000l (* 0x500000 *) - | SAlign32Bytes -> 0x600000l (* 0x600000 *) - | SAlign64Bytes -> 0x700000l (* 0x700000 *) - | SAlign128Bytes -> 0x800000l (* 0x800000 *) - | SAlign256Bytes -> 0x900000l (* 0x900000 *) - | SAlign512Bytes -> 0xA00000l (* 0xA00000 *) - | SAlign1024Bytes -> 0xB00000l (* 0xB00000 *) - | SAlign2048Bytes -> 0xC00000l (* 0xC00000 *) - | SAlign4096Bytes -> 0xD00000l (* 0xD00000 *) - | SAlign8192Bytes -> 0xE00000l (* 0xE00000 *) - | SHasExtRelocs -> 0x1000000l (* 0x1000000 *) - | SCanDiscard -> 0x02000000l (* 0x02000000 *) - | SNotCached -> 0x04000000l (* 0x04000000 *) - | SNotPaged -> 0x08000000l (* 0x08000000 *) - | SShared -> 0x10000000l (* 0x10000000 *) - | SExec -> 0x20000000l (* 0x20000000 *) - | SRead -> 0x40000000l (* 0x40000000 *) - | SWrite -> 0x80000000l (* 0x80000000 *) - ) acc - ) 0l props - -let int_of_pe_magic m = match m with - | P32 -> 0x10b - | PRom -> 0x107 - | P64 -> 0x20b - -let int_of_subsystem s = match s with - | SUnknown -> 0 (* 0 *) - | SNative -> 1 (* 1 *) - | SWGui -> 2 (* 2 *) - | SWCui -> 3 (* 3 *) - | SPCui -> 7 (* 7 *) - | SWCeGui -> 9 (* 9 *) - | SEfi -> 10 (* 10 *) - | SEfiBoot -> 11 (* 11 *) - | SEfiRuntime -> 12 (* 12 *) - | SEfiRom -> 13 (* 13 *) - | SXbox -> 14 (* 14 *) - -let int_of_dll_props props = List.fold_left (fun acc prop -> - (match prop with - | DDynamicBase -> 0x0040 (* 0x0040 *) - | DForceIntegrity -> 0x0080 (* 0x0080 *) - | DNxCompat -> 0x0100 (* 0x0100 *) - | DNoIsolation -> 0x0200 (* 0x0200 *) - | DNoSeh -> 0x0400 (* 0x0400 *) - | DNoBind -> 0x0800 (* 0x0800 *) - | DWdmDriver -> 0x2000 (* 0x2000 *) - | DTerminalServer -> 0x8000 (* 0x8000 *) - ) lor acc - ) 0 props - -let int_of_clr_flags props = List.fold_left (fun acc prop -> - (match prop with - | FIlOnly -> 0x1 (* 0x1 *) - | F32BitRequired -> 0x2 (* 0x2 *) - | FIlLibrary -> 0x4 (* 0x4 *) - | FSigned -> 0x8 (* 0x8 *) - | FNativeEntry -> 0x10 (* 0x10 *) - | FTrackDebug -> 0x10000 (* 0x10000 *) - ) lor acc - ) 0 props diff --git a/libs/javalib/Makefile b/libs/javalib/Makefile deleted file mode 100644 index 2e7ddd22d8f..00000000000 --- a/libs/javalib/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -OCAMLOPT=ocamlopt -OCAMLC=ocamlc -SRC=jData.ml jReader.ml jWriter.ml - -all: bytecode native - -native: javalib.cmxa -bytecode: javalib.cma - -javalib.cmxa: $(SRC) - ocamlfind $(OCAMLOPT) -g -package extlib -safe-string -a -o javalib.cmxa $(SRC) - -javalib.cma: $(SRC) - ocamlfind $(OCAMLC) -g -package extlib -safe-string -a -o javalib.cma $(SRC) - -clean: - rm -rf javalib.cmxa javalib.cma javalib.lib javalib.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi) $(wildcard *.cmo) - -.PHONY: all bytecode native clean - -Makefile: ; -$(SRC): ; diff --git a/libs/javalib/dune b/libs/javalib/dune deleted file mode 100644 index 25c48591409..00000000000 --- a/libs/javalib/dune +++ /dev/null @@ -1,13 +0,0 @@ -(include_subdirs no) - -(env - (_ - (flags (-w -50)) - ) -) - -(library - (name javalib) - (libraries extlib) - (wrapped false) -) diff --git a/libs/javalib/jData.ml b/libs/javalib/jData.ml deleted file mode 100644 index 52c779e25bf..00000000000 --- a/libs/javalib/jData.ml +++ /dev/null @@ -1,267 +0,0 @@ -(* - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 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 *) - | ConstDynamic of (bootstrap_method * unqualified_name * jsignature) (* tag = 17 *) - | ConstInvokeDynamic of (bootstrap_method * unqualified_name * jsignature) (* tag = 18 *) - | ConstModule of unqualified_name (* tag = 19 *) - | ConstPackage of unqualified_name (* tag = 20 *) - | ConstUnusable - -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 *) - | JModule (* 0x8000 *) - (** 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 jsignature * 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 jlocal = { - ld_start_pc : int; - ld_length : int; - ld_name : string; - ld_descriptor : string; - ld_index : int; -} - -type jattribute = - | AttrDeprecated - | AttrVisibleAnnotations of jannotation list - | AttrInvisibleAnnotations of jannotation list - | AttrLocalVariableTable of jlocal list - | AttrMethodParameters of (string * int) list - | AttrUnknown of string * string - -type jcode = jattribute list (* TODO *) - -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 *) - | KDynamic of (bootstrapref * nametyperef) (* 17 *) - | KInvokeDynamic of (bootstrapref * nametyperef) (* 18 *) - | KModule of utf8ref (* 19 *) - | KPackage of utf8ref (* 20 *) - | 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 deleted file mode 100644 index 6a3a4706e4a..00000000000 --- a/libs/javalib/jReader.ml +++ /dev/null @@ -1,646 +0,0 @@ -(* - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 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_string ch len in - (* TODO: correctly decode modified UTF8 *) - KUtf8String str - | 15 -> - let reft = get_reference_type (IO.read_byte ch) idx in - let dynref = index() in - KMethodHandle (reft, dynref) - | 16 -> - KMethodType (index()) - | 17 -> - let bootstrapref = read_ui16 ch in (* not index *) - let nametyperef = index() in - KDynamic (bootstrapref, nametyperef) - | 18 -> - let bootstrapref = read_ui16 ch in (* not index *) - let nametyperef = index() in - KInvokeDynamic (bootstrapref, nametyperef) - | 19 -> - KModule (index()) - | 20 -> - KPackage (index()) - | 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)) - | KDynamic(bootstrapref, nametyperef) -> - let n, t = expand_nametype nametyperef in - ConstDynamic(bootstrapref, n, t) - | KInvokeDynamic (bootstrapref, nametyperef) -> - let n, t = expand_nametype nametyperef in - ConstInvokeDynamic(bootstrapref, n, t) - | KModule n -> - ConstModule (expand_string n) - | KPackage n -> - ConstPackage (expand_string n) - | KUnusable -> - ConstUnusable - -let parse_access_flags ch all_flags = - let fl = read_ui16 ch in - let flags = ref [] in - List.iteri (fun fbit 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 - ) 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' | 'F' | 'I' | 'J' | 'S' | 'Z' | 's' -> - let jsig = match (Char.chr tag) with - | 's' -> - TObject( (["java";"lang"],"String"), [] ) - | tag -> - fst (parse_signature_part (Char.escaped tag)) - in - ValConst(jsig, 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) - | "LocalVariableTable" -> - let len = read_ui16 ch in - let locals = List.init len (fun _ -> - let start_pc = read_ui16 ch in - let length = read_ui16 ch in - let name = get_string consts ch in - let descriptor = get_string consts ch in - let index = read_ui16 ch in - { - ld_start_pc = start_pc; - ld_length = length; - ld_name = name; - ld_descriptor = descriptor; - ld_index = index - } - ) in - Some (AttrLocalVariableTable locals) - | "MethodParameters" -> - let len = IO.read_byte ch in - let parameters = List.init len (fun _ -> - let name = get_string consts ch in - let flags = read_ui16 ch in - (name,flags) - ) in - Some (AttrMethodParameters parameters) - | "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_string 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" -> - ignore(read_ui16 ch); (* max stack *) - ignore(read_ui16 ch); (* max locals *) - let len = read_i32 ch in - ignore(IO.nread_string ch len); (* code *) - let len = read_ui16 ch in - for i = 0 to len - 1 do - ignore(IO.nread_string ch 8); - done; (* exceptions *) - let attrib_count = read_ui16 ch in - let attribs = parse_attributes consts ch attrib_count in - code := Some attribs; - None - | 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; JModule] 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 - IO.close_in ch; - { - 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 deleted file mode 100644 index 6218d199383..00000000000 --- a/libs/javalib/jWriter.ml +++ /dev/null @@ -1,299 +0,0 @@ -(* - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA - *) -open JData;; -open IO.BigEndian;; -open IO;; -open ExtString;; -open ExtList;; - -exception Writer_error_message of string - -type context = { - cpool : unit IO.output; - mutable ccount : int; - ch : string IO.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 rec encode_param ctx ch param = - match param with - | TAny -> write_byte ch (Char.code '*') - | TType(w, s) -> - (match w with - | WExtends -> write_byte ch (Char.code '+') - | WSuper -> write_byte ch (Char.code '-') - | WNone -> ()); - encode_sig_part ctx ch s - -and encode_sig_part ctx ch jsig = match jsig with - | TByte -> write_byte ch (Char.code 'B') - | TChar -> write_byte ch (Char.code 'C') - | TDouble -> write_byte ch (Char.code 'D') - | TFloat -> write_byte ch (Char.code 'F') - | TInt -> write_byte ch (Char.code 'I') - | TLong -> write_byte ch (Char.code 'J') - | TShort -> write_byte ch (Char.code 'S') - | TBool -> write_byte ch (Char.code 'Z') - | TObject(path, params) -> - write_byte ch (Char.code 'L'); - write_string ch (encode_path ctx path); - if params <> [] then begin - write_byte ch (Char.code '<'); - List.iter (encode_param ctx ch) params; - write_byte ch (Char.code '>') - end; - write_byte ch (Char.code ';') - | TObjectInner(pack, inners) -> - write_byte ch (Char.code 'L'); - List.iter (fun p -> - write_string ch p; - write_byte ch (Char.code '/') - ) pack; - - let first = ref true in - List.iter (fun (name,params) -> - (if !first then first := false else write_byte ch (Char.code '.')); - write_string ch name; - if params <> [] then begin - write_byte ch (Char.code '<'); - List.iter (encode_param ctx ch) params; - write_byte ch (Char.code '>') - end; - ) inners; - write_byte ch (Char.code ';') - | TArray(s,size) -> - write_byte ch (Char.code '['); - (match size with - | Some size -> - write_string ch (string_of_int size); - | None -> ()); - encode_sig_part ctx ch s - | TMethod(args, ret) -> - write_byte ch (Char.code '('); - List.iter (encode_sig_part ctx ch) args; - (match ret with - | None -> write_byte ch (Char.code 'V') - | Some jsig -> encode_sig_part ctx ch jsig) - | TTypeParameter name -> - write_byte ch (Char.code 'T'); - write_string ch name; - write_byte ch (Char.code ';') - -let encode_sig ctx jsig = - let buf = IO.output_string() in - encode_sig_part ctx buf jsig; - close_out buf - -let write_utf8 ch s = - String.iter (fun c -> - let c = Char.code c in - if c = 0 then begin - write_byte ch 0xC0; - write_byte ch 0x80 - end else - write_byte ch c - ) s - -let rec const ctx c = - try - PMap.find c ctx.constants - with - | Not_found -> - let ret = ctx.ccount in - (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 (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_infinite when f > 0.0 -> - write_real_i32 ctx.cpool 0x7f800000l - | FP_infinite -> - 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; - | 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_utf8 ctx.cpool 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)))) - | ConstDynamic (bootstrap_method, unqualified_name, jsignature) (* tag = 17 *) -> - write_byte ctx.cpool 17; - write_ui16 ctx.cpool bootstrap_method; - write_ui16 ctx.cpool (const ctx (ConstNameAndType(unqualified_name, jsignature))) - | 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))) - | ConstModule unqualified_name (* tag = 19 *) -> - write_byte ctx.cpool 19; - write_ui16 ctx.cpool (const ctx (ConstUtf8 (unqualified_name))); - | ConstPackage unqualified_name (* tag = 20 *) -> - write_byte ctx.cpool 20; - write_ui16 ctx.cpool (const ctx (ConstUtf8 (unqualified_name))); - | ConstUnusable -> assert false); - ctx.ccount <- ret + 1; - ret - -let write_const ctx ch cconst = - write_ui16 ch (const ctx cconst) -;; - -let write_formal_type_params ctx ch tparams = - write_byte ch (Char.code '<'); - List.iter (fun (name,ext,impl) -> - write_string ch name; - (match ext with - | None -> () - | Some jsig -> - write_byte ch (Char.code ':'); - write_string ch (encode_sig ctx jsig)); - List.iter (fun jsig -> - write_byte ch (Char.code ':'); - write_string ch (encode_sig ctx jsig) - ) impl - ) tparams; - write_byte ch (Char.code '>'); -;; - -let write_complete_method_signature ctx ch (tparams : jtypes) msig throws = - if tparams <> [] then write_formal_type_params ctx ch tparams; - write_string ch (encode_sig ctx (TMethod(msig))); - if throws <> [] then List.iter (fun jsig -> - write_byte ch (Char.code '^'); - write_string ch (encode_sig ctx jsig) - ) throws -;; - -let write_access_flags ctx ch all_flags flags = - let value = List.fold_left (fun acc flag -> - try - acc lor (Hashtbl.find all_flags flag) - with Not_found -> - error ("Not found flag: " ^ (string_of_int (Obj.magic flag))) - ) 0 flags in - write_ui16 ch value -;; - -let rec write_ann_element ctx ch (name,eval) = - write_const ctx ch (ConstUtf8 name); - write_element_value ctx ch eval - -and write_annotation ctx ch ann = - write_const ctx ch (ConstUtf8 (encode_sig ctx ann.ann_type)); - write_ui16 ch (List.length ann.ann_elements); - List.iter (write_ann_element ctx ch) ann.ann_elements - -and write_element_value ctx ch value = match value with - | ValConst(jsig, cconst) -> (match jsig with - | TObject((["java";"lang"],"String"), []) -> - write_byte ch (Char.code 's') - | TByte | TChar | TDouble | TFloat | TInt | TLong | TShort | TBool -> - write_string ch (encode_sig ctx jsig) - | _ -> - let s = encode_sig ctx jsig in - error ("Invalid signature " ^ s ^ " for constant value")); - write_ui16 ch (const ctx cconst) - | ValEnum(jsig,name) -> - write_byte ch (Char.code 'e'); - write_const ctx ch (ConstUtf8 (encode_sig ctx jsig)); - write_const ctx ch (ConstUtf8 name) - | ValClass(jsig) -> - write_byte ch (Char.code 'c'); - let esig = match jsig with - | TObject(([],"Void"),[]) - | TObject((["java";"lang"],"Void"),[]) -> - "V" - | _ -> - encode_sig ctx jsig - in - write_const ctx ch (ConstUtf8 (esig)) - | ValAnnotation ann -> - write_byte ch (Char.code '@'); - write_annotation ctx ch ann - | ValArray(lvals) -> - write_byte ch (Char.code '['); - write_ui16 ch (List.length lvals); - List.iter (write_element_value ctx ch) lvals -;; - diff --git a/libs/ocamake/ocamake.dsp b/libs/ocamake/ocamake.dsp deleted file mode 100644 index 461ebd15741..00000000000 --- a/libs/ocamake/ocamake.dsp +++ /dev/null @@ -1,66 +0,0 @@ -# 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 deleted file mode 100644 index 620f4514a98..00000000000 --- a/libs/ocamake/ocamake.dsw +++ /dev/null @@ -1,29 +0,0 @@ -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 deleted file mode 100644 index 9af8925b504..00000000000 --- a/libs/ocamake/ocamake.html +++ /dev/null @@ -1,94 +0,0 @@ - - -
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. - -
-
- -